diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/assembler/assem.lisp src-to-be/assembler/assem.lisp
--- src/assembler/assem.lisp	Mon Feb 26 10:38:16 1990
+++ src-to-be/assembler/assem.lisp	Mon Nov  9 20:09:09 1998
@@ -11,6 +11,8 @@
 ;;; LAP code into binary code and dumping the results in the right places.
 ;;; There also ulilities for dealing with the various output files.
 ;;; 
+(ext:file-comment
+  "$Header$")
 
 ;;; Written by many hands: Joe Ginder, Scott Fahlman, Dave Dill,
 ;;; Walter van Roggen, and Skef Wholey.
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/assembler/assembler.lisp src-to-be/assembler/assembler.lisp
--- src/assembler/assembler.lisp	Thu Feb  8 12:10:48 1990
+++ src-to-be/assembler/assembler.lisp	Mon Nov  9 20:09:09 1998
@@ -10,6 +10,8 @@
 ;;;
 ;;; A user-level assembler for the ROMP.
 ;;; Written by Skef Wholey.
+(ext:file-comment
+  "$Header$")
 ;;;
 ;;; This program processes a file of lispy assembly code and produces a Lisp
 ;;; FASL file.  It will be used primarily for coding the assembler support
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/assembler/disassemble.lisp src-to-be/assembler/disassemble.lisp
--- src/assembler/disassemble.lisp	Thu Feb  8 12:10:54 1990
+++ src-to-be/assembler/disassemble.lisp	Mon Nov  9 20:09:09 1998
@@ -11,6 +11,9 @@
 ;;; The  DISASSEMBLE function as described in the Common Lisp manual.
 ;;; 
 ;;; Written by Don Mathis
+(ext:file-comment
+  "$Header$")
+
 ;;;
 ;;;
 ;;; Modified 11/83 by Robert Rose to put an asterisk before lines
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/assembler/miscasm.lisp src-to-be/assembler/miscasm.lisp
--- src/assembler/miscasm.lisp	Mon Apr 23 12:29:09 1990
+++ src-to-be/assembler/miscasm.lisp	Mon Nov  9 20:09:09 1998
@@ -7,6 +7,8 @@
 ;;; If you want to use this code or any part of Spice Lisp, please contact
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
+(ext:file-comment
+  "$Header$")
 
 (in-package 'compiler)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/assembler/rompconst.lisp src-to-be/assembler/rompconst.lisp
--- src/assembler/rompconst.lisp	Mon May 21 19:21:42 1990
+++ src-to-be/assembler/rompconst.lisp	Mon Nov  9 20:09:09 1998
@@ -11,6 +11,8 @@
 ;;; Constants for the Romp.
 ;;; Written by: David B. McDonald and Skef Wholey.
 ;;;
+(ext:file-comment
+  "$Header$")
 
 (in-package "COMPILER")
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/assembler/ropdefs.lisp src-to-be/assembler/ropdefs.lisp
--- src/assembler/ropdefs.lisp	Thu Feb  8 12:11:02 1990
+++ src-to-be/assembler/ropdefs.lisp	Mon Nov  9 20:09:09 1998
@@ -11,6 +11,8 @@
 ;;; used by the compiler.
 
 ;;; Written by David B. McDonald.
+(ext:file-comment
+  "$Header$")
 
 (in-package 'Compiler)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/attributes.lisp src-to-be/clx/attributes.lisp
--- src/clx/attributes.lisp	Fri Jun  5 04:45:25 1998
+++ src-to-be/clx/attributes.lisp	Mon Nov  9 20:09:10 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 ;;;	The special variable *window-attributes* is an alist containg:
 ;;;	(drawable attributes attribute-changes geometry geometry-changes)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/buffer.lisp src-to-be/clx/buffer.lisp
--- src/clx/buffer.lisp	Fri Jun  5 04:45:25 1998
+++ src-to-be/clx/buffer.lisp	Mon Nov  9 20:09:10 1998
@@ -18,6 +18,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 ;; A few notes:
 ;;
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/bufmac.lisp src-to-be/clx/bufmac.lisp
--- src/clx/bufmac.lisp	Tue Aug 11 17:15:28 1992
+++ src-to-be/clx/bufmac.lisp	Mon Nov  9 20:09:10 1998
@@ -18,6 +18,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/build-clx.lisp src-to-be/clx/build-clx.lisp
--- src/clx/build-clx.lisp	Sun Jun 17 13:44:43 1990
+++ src-to-be/clx/build-clx.lisp	Mon Nov  9 20:09:10 1998
@@ -1,4 +1,7 @@
 ;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 ;;; Load this file if you want to compile CLX in its entirety.
 #+nil
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/clx.lisp src-to-be/clx/clx.lisp
--- src/clx/clx.lisp	Fri Jun  5 04:45:26 1998
+++ src-to-be/clx/clx.lisp	Mon Nov  9 20:09:10 1998
@@ -15,6 +15,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+ "$Header$")
 
 ;; Primary Interface Author:
 ;;	Robert W. Scheifler
@@ -82,6 +85,7 @@
 
 (pushnew :clx *features*)
 (pushnew :xlib *features*)
+(setf *features* (remove :no-clx *features*))
 
 (defparameter *version* "MIT R5.02")
 (pushnew :clx-mit-r4 *features*)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/debug/debug.lisp src-to-be/clx/debug/debug.lisp
--- src/clx/debug/debug.lisp	Fri Sep 30 17:07:33 1994
+++ src-to-be/clx/debug/debug.lisp	Mon Nov  9 20:09:10 1998
@@ -19,6 +19,9 @@
 ;;;
 
 ;;; Created 04/09/87 14:30:41 by LaMott G. OREN
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/debug/describe.lisp src-to-be/clx/debug/describe.lisp
--- src/clx/debug/describe.lisp	Fri Sep 30 17:07:33 1994
+++ src-to-be/clx/debug/describe.lisp	Mon Nov  9 20:09:10 1998
@@ -19,6 +19,9 @@
 ;;;
 
 ;;; Created 07/15/87 by LaMott G. OREN
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/debug/event-test.lisp src-to-be/clx/debug/event-test.lisp
--- src/clx/debug/event-test.lisp	Fri Sep 30 17:07:34 1994
+++ src-to-be/clx/debug/event-test.lisp	Mon Nov  9 20:09:10 1998
@@ -1,4 +1,7 @@
 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*-
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xtest :use '(:xlib :lisp))
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/debug/keytrans.lisp src-to-be/clx/debug/keytrans.lisp
--- src/clx/debug/keytrans.lisp	Fri Sep 30 17:07:35 1994
+++ src-to-be/clx/debug/keytrans.lisp	Mon Nov  9 20:09:10 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/debug/trace.lisp src-to-be/clx/debug/trace.lisp
--- src/clx/debug/trace.lisp	Fri Sep 30 17:07:36 1994
+++ src-to-be/clx/debug/trace.lisp	Mon Nov  9 20:09:10 1998
@@ -31,6 +31,9 @@
 ;; 7feb91 -- jdi
 
 ;;; Created 09/14/87 by LaMott G. OREN
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/debug/util.lisp src-to-be/clx/debug/util.lisp
--- src/clx/debug/util.lisp	Fri Sep 30 17:07:36 1994
+++ src-to-be/clx/debug/util.lisp	Mon Nov  9 20:09:10 1998
@@ -19,6 +19,9 @@
 ;;;
 
 ;;; Created 04/09/87 14:30:41 by LaMott G. OREN
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/defsystem.lisp src-to-be/clx/defsystem.lisp
--- src/clx/defsystem.lisp	Fri Feb 14 13:43:30 1997
+++ src-to-be/clx/defsystem.lisp	Mon Nov  9 20:09:10 1998
@@ -18,6 +18,9 @@
 ;;;
 ;;; Franz Incorporated provides this software "as is" without express or
 ;;; implied warranty.
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 ;;; #+ features used in this file
 ;;;   clx-ansi-common-lisp
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/demo/bezier.lisp src-to-be/clx/demo/bezier.lisp
--- src/clx/demo/bezier.lisp	Fri Sep 30 17:07:47 1994
+++ src-to-be/clx/demo/bezier.lisp	Mon Nov  9 20:09:10 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/demo/beziertest.lisp src-to-be/clx/demo/beziertest.lisp
--- src/clx/demo/beziertest.lisp	Fri Sep 30 17:07:48 1994
+++ src-to-be/clx/demo/beziertest.lisp	Mon Nov  9 20:09:10 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/demo/hello.lisp src-to-be/clx/demo/hello.lisp
--- src/clx/demo/hello.lisp	Fri Sep 30 17:07:48 1994
+++ src-to-be/clx/demo/hello.lisp	Mon Nov  9 20:09:10 1998
@@ -1,4 +1,7 @@
 ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*-
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/demo/menu.lisp src-to-be/clx/demo/menu.lisp
--- src/clx/demo/menu.lisp	Fri Sep 30 17:07:49 1994
+++ src-to-be/clx/demo/menu.lisp	Mon Nov  9 20:09:10 1998
@@ -15,6 +15,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.  
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/demo/zoid.lisp src-to-be/clx/demo/zoid.lisp
--- src/clx/demo/zoid.lisp	Fri Sep 30 17:07:49 1994
+++ src-to-be/clx/demo/zoid.lisp	Mon Nov  9 20:09:10 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/depdefs.lisp src-to-be/clx/depdefs.lisp
--- src/clx/depdefs.lisp	Fri Feb 14 13:43:31 1997
+++ src-to-be/clx/depdefs.lisp	Mon Nov  9 20:09:10 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/dependent.lisp src-to-be/clx/dependent.lisp
--- src/clx/dependent.lisp	Fri Jun  5 04:45:27 1998
+++ src-to-be/clx/dependent.lisp	Mon Nov  9 20:09:10 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/display.lisp src-to-be/clx/display.lisp
--- src/clx/display.lisp	Wed Jan 21 14:19:05 1998
+++ src-to-be/clx/display.lisp	Mon Nov  9 20:09:10 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/doc.lisp src-to-be/clx/doc.lisp
--- src/clx/doc.lisp	Tue Aug 11 17:16:08 1992
+++ src-to-be/clx/doc.lisp	Mon Nov  9 20:09:10 1998
@@ -14,6 +14,9 @@
 
 ;;; Texas Instruments Incorporated provides this document "as is" without
 ;;; express or implied warranty.
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 ;; Version 4
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/fonts.lisp src-to-be/clx/fonts.lisp
--- src/clx/fonts.lisp	Fri Feb 14 13:43:32 1997
+++ src-to-be/clx/fonts.lisp	Mon Nov  9 20:09:10 1998
@@ -15,6 +15,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/gcontext.lisp src-to-be/clx/gcontext.lisp
--- src/clx/gcontext.lisp	Fri Jun  5 04:45:27 1998
+++ src-to-be/clx/gcontext.lisp	Mon Nov  9 20:09:10 1998
@@ -41,6 +41,9 @@
 ;;;	lisps will have problems.  Fortunately, most other lisps don't care,
 ;;;	because they don't run in a multi-processing shared-address space
 ;;;	environment.
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/graphics.lisp src-to-be/clx/graphics.lisp
--- src/clx/graphics.lisp	Fri Jun  5 04:45:28 1998
+++ src-to-be/clx/graphics.lisp	Mon Nov  9 20:09:10 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/image.lisp src-to-be/clx/image.lisp
--- src/clx/image.lisp	Fri Jun  5 04:45:28 1998
+++ src-to-be/clx/image.lisp	Mon Nov  9 20:09:10 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/input.lisp src-to-be/clx/input.lisp
--- src/clx/input.lisp	Fri Jun  5 04:45:28 1998
+++ src-to-be/clx/input.lisp	Mon Nov  9 20:09:10 1998
@@ -24,6 +24,9 @@
 ;;;  Date	Author	Description
 ;;; -------------------------------------------------------------------------------------
 ;;; 12/10/87	LGO	Created
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/keysyms.lisp src-to-be/clx/keysyms.lisp
--- src/clx/keysyms.lisp	Mon May 14 16:48:50 1990
+++ src-to-be/clx/keysyms.lisp	Mon Nov  9 20:09:10 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/macros.lisp src-to-be/clx/macros.lisp
--- src/clx/macros.lisp	Fri Sep 30 17:05:07 1994
+++ src-to-be/clx/macros.lisp	Mon Nov  9 20:09:11 1998
@@ -24,6 +24,9 @@
 ;;; it makes it easier to extend the protocol.
 
 ;;; This is built on top of BUFFER
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/manager.lisp src-to-be/clx/manager.lisp
--- src/clx/manager.lisp	Fri Jun  5 04:45:29 1998
+++ src-to-be/clx/manager.lisp	Mon Nov  9 20:09:11 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/package.lisp src-to-be/clx/package.lisp
--- src/clx/package.lisp	Fri Jun  5 04:45:29 1998
+++ src-to-be/clx/package.lisp	Mon Nov  9 20:09:11 1998
@@ -10,6 +10,9 @@
 ;;; documentation, and that the name MIT not be used in advertising or
 ;;; publicity pertaining to distribution of the software without specific,
 ;;; written prior permission.
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 ;;; The CLtL way
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/provide.lisp src-to-be/clx/provide.lisp
--- src/clx/provide.lisp	Thu Nov  7 17:58:35 1991
+++ src-to-be/clx/provide.lisp	Mon Nov  9 20:09:11 1998
@@ -13,6 +13,9 @@
 ;;; put in a site specific
 ;;;			(require :clx <pathname-of-this-file>)
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 #-clx-ansi-common-lisp 
 (in-package :user)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/requests.lisp src-to-be/clx/requests.lisp
--- src/clx/requests.lisp	Fri Jun  5 04:45:29 1998
+++ src-to-be/clx/requests.lisp	Mon Nov  9 20:09:11 1998
@@ -15,6 +15,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/resource.lisp src-to-be/clx/resource.lisp
--- src/clx/resource.lisp	Sat Nov  7 15:45:47 1998
+++ src-to-be/clx/resource.lisp	Mon Nov  9 20:09:12 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/sockcl.lisp src-to-be/clx/sockcl.lisp
--- src/clx/sockcl.lisp	Mon May 14 16:49:11 1990
+++ src-to-be/clx/sockcl.lisp	Mon Nov  9 20:09:12 1998
@@ -22,6 +22,9 @@
 
 ;;; Compile this file with compile-file.
 ;;; Load it with (si:faslink "sockcl.o" "socket.o -lc")
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/test/image.lisp src-to-be/clx/test/image.lisp
--- src/clx/test/image.lisp	Fri Sep 30 17:07:56 1994
+++ src-to-be/clx/test/image.lisp	Mon Nov  9 20:09:12 1998
@@ -5,6 +5,9 @@
 ;;; of the image windows appear.  If one of these image windows is garbled,
 ;;; then somewhere something is broken.  Entry point is the function
 ;;; IMAGE-TEST
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/test/trapezoid.lisp src-to-be/clx/test/trapezoid.lisp
--- src/clx/test/trapezoid.lisp	Fri Sep 30 17:07:57 1994
+++ src-to-be/clx/test/trapezoid.lisp	Mon Nov  9 20:09:12 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/clx/text.lisp src-to-be/clx/text.lisp
--- src/clx/text.lisp	Fri Jun  5 04:45:30 1998
+++ src-to-be/clx/text.lisp	Mon Nov  9 20:09:12 1998
@@ -17,6 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :xlib)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/class.lisp src-to-be/code/class.lisp
--- src/code/class.lisp	Fri Jul 24 19:17:50 1998
+++ src-to-be/code/class.lisp	Mon Nov  9 20:09:12 1998
@@ -788,7 +788,11 @@
 	  (setf (info type builtin name) class))
 	(let* ((inheritance-depth (if hierarchical (length inherits) -1))
 	       (inherit-layouts
-		(map 'vector
+		(#-high-security
+		 map
+		 #+high-security
+		 lisp::map-without-errorchecking
+		     'vector
 		     #'(lambda (x)
 			 (let ((super-layout (class-layout (find-class x))))
 			   (when (= (layout-inheritance-depth super-layout) -1)
@@ -812,7 +816,11 @@
       (setf (info type class name) class-cell)
       (setf (info type kind name) :instance)
       (let ((inherit-layouts
-	     (map 'vector #'(lambda (x)
+	     (#-high-security
+	      map
+	      #+high-security
+	      lisp::map-without-errorchecking
+	      'vector #'(lambda (x)
 			      (lisp::class-layout (lisp:find-class x)))
 		  inherits)))
 	(lisp::register-layout (lisp::find-layout name 0 inherit-layouts -1)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/defstruct.lisp src-to-be/code/defstruct.lisp
--- src/code/defstruct.lisp	Sun Jul 26 01:37:39 1998
+++ src-to-be/code/defstruct.lisp	Mon Nov  9 20:09:12 1998
@@ -556,7 +556,7 @@
 		spec))
 	spec))
     (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
-      (error 'program-error
+      (error 'simple-program-error
 	     :format-control "Duplicate slot name ~S."
 	     :format-arguments (list name)))
     (setf (dsd-%name islot) (string name))
@@ -1164,17 +1164,30 @@
     (if (typep class 'basic-structure-class)
 	#'(lambda (structure)
 	    (declare (optimize (speed 3) (safety 0)))
-	    (unless (typep-to-layout structure layout)
-	      (error "Structure for accessor ~S is not a ~S:~% ~S"
-		     (dsd-accessor dsd) (class-name (layout-class layout))
-		     structure))
+	    (flet ((structure-test (structure)
+		     (typep-to-layout structure layout)))
+	      (unless (structure-test structure)
+		(error 'simple-type-error
+		       :datum structure
+		       :expected-type '(satisfies structure-test) 
+		       :format-control
+		       "Structure for accessor ~S is not a ~S:~% ~S"
+		       :format-arguments
+		       (list (dsd-accessor dsd)
+			     (class-name (layout-class layout))
+			     structure))))
 	    (%instance-ref structure (dsd-index dsd)))
 	#'(lambda (structure)
 	    (declare (optimize (speed 3) (safety 0)))
 	    (unless (%typep structure class)
-	      (error "Structure for accessor ~S is not a ~S:~% ~S"
-		     (dsd-accessor dsd) class
-		     structure))
+	      (error 'simple-type-error
+		     :datum structure
+		     :expected-type 'class
+		     :format-control
+		     "Structure for accessor ~S is not a ~S:~% ~S"
+		     :format-arguments
+		     (list (dsd-accessor dsd) class
+			   structure)))
 	    (%instance-ref structure (dsd-index dsd))))))
 ;;;
 (defun structure-slot-setter (layout dsd)
@@ -1182,27 +1195,57 @@
     (if (typep class 'basic-structure-class)
 	#'(lambda (new-value structure)
 	    (declare (optimize (speed 3) (safety 0)))
-	    (unless (typep-to-layout structure layout)
-	      (error "Structure for setter ~S is not a ~S:~% ~S"
-		     `(setf ,(dsd-accessor dsd))
-		     (class-name (layout-class layout))
-		     structure))
-	    (unless (%typep new-value (dsd-type dsd))
-	      (error "New-Value for setter ~S is not a ~S:~% ~S."
-		     `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
-		     new-value))
+	    (flet ((structure-test (structure)
+		     (typep-to-layout structure layout))
+		   (typep-test (new-value)
+		     (%typep new-value (dsd-type dsd))))
+	      (unless (structure-test structure)
+		(error 'simple-type-error
+		       :datum structure
+		       :expected-type '(satisfies structure-test) 
+		       :format-control
+		       "Structure for setter ~S is not a ~S:~% ~S"
+		       :format-arguments
+		       (list `(setf ,(dsd-accessor dsd))
+			     (class-name (layout-class layout))
+			     structure)))
+	      (unless  (typep-test new-value)
+		(error 'simple-type-error
+		       :datum new-value
+		       :expected-type '(satisfies typep-test) 
+		       :format-control
+		       "New-Value for setter ~S is not a ~S:~% ~S"
+		       :format-arguments
+		       (list `(setf ,(dsd-accessor dsd))
+			      (dsd-type dsd)
+			      new-value))))
 	    (setf (%instance-ref structure (dsd-index dsd)) new-value))
 	#'(lambda (new-value structure)
 	    (declare (optimize (speed 3) (safety 0)))
-	    (unless (%typep structure class)
-	      (error "Structure for setter ~S is not a ~S:~% ~S"
-		     `(setf ,(dsd-accessor dsd))
-		     (class-name class)
-		     structure))
-	    (unless (%typep new-value (dsd-type dsd))
-	      (error "New-Value for setter ~S is not a ~S:~% ~S."
-		     `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
-		     new-value))
+	    (flet ((structure-test (structure)
+		     (typep structure class))
+		   (typep-test (new-value)
+		     (%typep new-value (dsd-type dsd))))
+	      (unless (structure-test structure)
+		(error 'simple-type-error
+		       :datum structure
+		       :expected-type '(satisfies structure-test) 
+		       :format-control
+		       "Structure for setter ~S is not a ~S:~% ~S"
+		       :format-arguments
+		       (list `(setf ,(dsd-accessor dsd))
+			     (class-name class)
+			     structure)))
+	      (unless  (typep-test new-value)
+		(error 'simple-type-error
+		       :datum new-value
+		       :expected-type '(satisfies typep-test) 
+		       :format-control
+		       "New-Value for setter ~S is not a ~S:~% ~S"
+		       :format-arguments
+		       (list `(setf ,(dsd-accessor dsd))
+			     (dsd-type dsd)
+			     new-value))))
 	    (setf (%instance-ref structure (dsd-index dsd)) new-value)))))
 
 
@@ -1254,10 +1297,17 @@
 	(setf (symbol-function (dd-copier info))
 	      #'(lambda (structure)
 		  (declare (optimize (speed 3) (safety 0)))
-		  (unless (typep-to-layout structure layout)
-		    (error "Structure for copier is not a ~S:~% ~S"
-			   (class-name (layout-class layout))
-			   structure))
+		  (flet ((layout-test (structure)
+			   (typep-to-layout structure layout)))
+		    (unless (layout-test structure)
+		      (error 'simple-type-error
+			     :datum structure
+			     :expected-type '(satisfies layout-test) 
+			     :format-control
+			     "Structure for copier is not a ~S:~% ~S"
+			     :format-arguments
+			     (list (class-name (layout-class layout))
+				   structure))))
 		  (copy-structure structure)))))
   
   (when (dd-doc info)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/error.lisp src-to-be/code/error.lisp
--- src/code/error.lisp	Fri Aug 14 09:16:58 1998
+++ src-to-be/code/error.lisp	Mon Nov  9 20:09:12 1998
@@ -522,9 +522,21 @@
 	 (class (typecase thing
 		  (condition-class thing)
 		  (class
-		   (error "~S is not a condition class." thing))
+		   (error 'simple-type-error
+			  :datum thing
+			  :expected-time 'condition-class
+			  :format-control
+			  "~S is not a condition class."
+			  :format-arguments
+			  (list thing)))
 		  (t
-		   (error "Bad thing for class arg:~%  ~S" thing))))
+		   (error 'simple-type-error
+			  :datum thing
+			  :expected-time 'condition-class
+			  :format-control
+			  "Bad thing for class arg:~%  ~S"
+			  :format-arguments
+			  (list thing)))))
 	 (res (make-condition-object args)))
     (setf (%instance-layout res) (class-layout class))
     ;;
@@ -903,7 +915,14 @@
 	     (stream-error-stream condition)))))
 
 (define-condition file-error (error)
-  ((pathname :reader file-error-pathname :initarg :pathname)))
+  ((pathname :reader file-error-pathname :initarg :pathname))
+  (:report
+   (lambda (condition stream)
+     (format stream "~&~@<File-error in function ~S:  ~3i~:_~?~:>"
+	     (condition-function-name condition)
+	     (serious-condition-format-control condition)
+	     (serious-condition-format-arguments condition)))))
+  
 
 ;;; INTERNAL
 (define-condition simple-file-error    (simple-condition file-error)())
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/eval.lisp src-to-be/code/eval.lisp
--- src/code/eval.lisp	Fri Feb 13 17:09:43 1998
+++ src-to-be/code/eval.lisp	Mon Nov  9 20:09:12 1998
@@ -175,7 +175,11 @@
 	 (case name
 	   (function
 	    (unless (= args 1)
-	      (error "Wrong number of args to FUNCTION:~% ~S." exp))
+	      (error 'simple-program-error
+		     :format-control
+		     "Wrong number of args to FUNCTION:~% ~S."
+		     :format-arguments
+		     (list exp)))
 	    (let ((name (second exp)))
 	      (if (or (atom name)
 		      (and (consp name)
@@ -184,7 +188,11 @@
 		  (eval:make-interpreted-function name))))
 	   (quote
 	    (unless (= args 1)
-	      (error "Wrong number of args to QUOTE:~% ~S." exp))
+	      (error 'simple-program-error
+		     :format-control
+		     "Wrong number of args to QUOTE:~% ~S."
+		     :format-arguments
+		     (list exp)))
 	    (second exp))
 	   (setq
 	    (unless (evenp args)
@@ -360,7 +368,8 @@
   (setf (info function macro-function symbol) function)
   (setf (symbol-function symbol)
 	#'(lambda (&rest args) (declare (ignore args))
-	    (error "Cannot funcall macro functions.")))
+	    (error 'undefined-function
+		   :name symbol)))
   function)
 
 ;;; Macroexpand-1  --  Public
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/fd-stream.lisp src-to-be/code/fd-stream.lisp
--- src/code/fd-stream.lisp	Thu Jul 16 15:30:45 1998
+++ src-to-be/code/fd-stream.lisp	Fri Dec 11 13:56:22 1998
@@ -276,7 +276,7 @@
 		      (:none character)
 		      (:line character)
 		      (:full character))
-  (if (char= byte #\Newline)
+  (if (and (base-char-p byte) (char= byte #\Newline))
       (setf (fd-stream-char-pos stream) 0)
       (incf (fd-stream-char-pos stream)))
   (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
@@ -1260,8 +1260,12 @@
                        :overwrite, :append, :supersede or nil
    :if-does-not-exist - one of :error, :create or nil
   See the manual for details."
-  (declare (ignore external-format))
 
+  (unless (eq external-format :default)
+    (error 'simple-error
+	   :format-control
+	   "Any external format other then :default isn't recognised"))
+  
   ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
   (setf direction
 	(assure-one-of direction
@@ -1405,8 +1409,11 @@
 			      (list pathname (unix:get-unix-error-msg errno))))
 		     (:create
 		      (cerror "Return NIL."
+			      'simple-error
+			      :format-control
 			      "Error creating ~S, path does not exist."
-			      pathname)))
+			      :format-arguments
+			      (list pathname))))
 		   (return nil))
 		  ((eql errno unix:eexist)
 		   (unless (eq nil if-exists)
@@ -1449,7 +1456,10 @@
   (setf *terminal-io* (make-synonym-stream '*tty*))
   (setf *standard-output* (make-synonym-stream '*stdout*))
   (setf *standard-input*
-	(make-two-way-stream (make-synonym-stream '*stdin*)
+	(#-high-security
+	 make-two-way-stream
+	 #+high-security
+	 %make-two-way-stream (make-synonym-stream '*stdin*)
 			     *standard-output*))
   (setf *error-output* (make-synonym-stream '*stderr*))
   (setf *query-io* (make-synonym-stream '*terminal-io*))
@@ -1471,7 +1481,7 @@
 	(make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
   (let ((tty (unix:unix-open "/dev/tty" unix:o_rdwr #o666)))
     (if tty
-	(setf *tty*
+	(setf *tty* ;HIER
 	      (make-fd-stream tty :name "the Terminal" :input t :output t
 			      :buffering :line :auto-close t))
 	(setf *tty* (make-two-way-stream *stdin* *stdout*))))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/filesys.lisp src-to-be/code/filesys.lisp
--- src/code/filesys.lisp	Thu Jul 16 15:30:47 1998
+++ src-to-be/code/filesys.lisp	Mon Nov  9 20:09:12 1998
@@ -271,6 +271,15 @@
 	    (unless (= tail-start tail-end)
 	      (setf pieces (butlast pieces))
 	      (extract-name-type-and-version namestr tail-start tail-end)))
+	;; PVE: make sure there are no illigal characters in
+	;; the name. illigal being (code-char 0) and #\/
+	#+high-security
+	(when (and (stringp name)
+                   (find-if #'(lambda (x) (or (char= x #\null)
+					      (char= x #\/)))
+			    name))
+	  (error 'parse-error))
+	
 	;; Now we have everything we want.  So return it.
 	(values nil ; no host for unix namestrings.
 		nil ; no devices for unix namestrings.
@@ -649,7 +658,9 @@
       (let ((names (names)))
 	(when names
 	  (when (cdr names)
-	    (error "~S is ambiguous:~{~%  ~A~}" pathname names))
+	    (error 'simple-file-error
+		   :format-control "~S is ambiguous:~{~%  ~A~}"
+		   :format-arguments (list pathname names)))
 	  (return (car names))))))))
 
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/float.lisp src-to-be/code/float.lisp
--- src/code/float.lisp	Sat Mar 21 09:11:56 1998
+++ src-to-be/code/float.lisp	Mon Nov  9 20:09:12 1998
@@ -351,7 +351,7 @@
 (defun float-radix (f)
   "Returns (as an integer) the radix b of its floating-point
    argument."
-  (declare (ignore f))
+  (declare (type float f))
   2)
 
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/interr.lisp src-to-be/code/interr.lisp
--- src/code/interr.lisp	Fri Aug 14 09:16:58 1998
+++ src-to-be/code/interr.lisp	Mon Nov  9 20:09:12 1998
@@ -232,14 +232,16 @@
 	 :expected-type 'coercable-to-function))
 
 (deferr invalid-argument-count-error (nargs)
-  (error 'simple-error
+  (error 'simple-program-error
 	 :function-name name
 	 :format-control "Invalid number of arguments: ~S"
 	 :format-arguments (list nargs)))
 
 (deferr bogus-argument-to-values-list-error (list)
-  (error 'simple-error
+  (error 'simple-type-error
 	 :function-name name
+	 :datum list
+	 :expected-type 'list
 	 :format-control "Attempt to use VALUES-LIST on a dotted-list:~%  ~S"
 	 :format-arguments (list list)))
 
@@ -299,12 +301,14 @@
 	 :expected-type (layout-class layout)))
 
 (deferr odd-keyword-arguments-error ()
-  (error 'simple-error
+  (error 'simple-type-error
+  	 :datum nil
+	 :expected-type nil
 	 :function-name name
 	 :format-control "Odd number of keyword arguments."))
 
 (deferr unknown-keyword-argument-error (key)
-  (error 'simple-error
+  (error 'simple-program-error
 	 :function-name name
 	 :format-control "Unknown keyword: ~S"
 	 :format-arguments (list key)))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/load.lisp src-to-be/code/load.lisp
--- src/code/load.lisp	Fri Jul 24 19:17:54 1998
+++ src-to-be/code/load.lisp	Mon Nov  9 20:09:12 1998
@@ -530,8 +530,12 @@
 	       (let ((pn (merge-pathnames (pathname filename)
 					  *default-pathname-defaults*)))
 		 (if (wild-pathname-p pn)
-		     (dolist (file (directory pn) t)
-		       (internal-load pn file if-does-not-exist contents))
+		     (let ((files (directory pn)))
+		       #+high-security
+		       (when (null files)
+			 (error 'file-error :pathname filename))
+		       (dolist (file files t)
+			 (internal-load pn file if-does-not-exist contents)))
 		     (let ((tn (probe-file pn)))
 		       (if (or tn (pathname-type pn) contents)
 			   (internal-load pn tn if-does-not-exist contents)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/macros.lisp src-to-be/code/macros.lisp
--- src/code/macros.lisp	Fri Jul 17 14:10:44 1998
+++ src-to-be/code/macros.lisp	Mon Nov  9 20:09:13 1998
@@ -1339,6 +1339,21 @@
 	 (setf ,place
 	       (check-type-error ',place ,place-value ',type ,type-string))))))
 
+#+high-security-support
+(defmacro check-type-var (place type-var &optional type-string)
+  "Signals an error of type type-error if the contents of place are not of the
+   specified type to which the type-var evaluates.  If an error is signaled,
+   this can only return if STORE-VALUE is invoked.  It will store into place
+   and start over."
+  (let ((place-value (gensym))
+	(type-value (gensym)))
+    `(loop
+       (let ((,place-value ,place)
+	     (,type-value  ,type-var))
+	 (when (typep ,place-value ,type-value) (return nil))
+	 (setf ,place
+	       (check-type-error ',place ,place-value ,type-value ,type-string))))))
+
 (defun check-type-error (place place-value type type-string)
   (let ((cond (if type-string
 		  (make-condition 'simple-type-error
@@ -1515,7 +1530,7 @@
        (setqs nil)
        (pairs pairs (cddr pairs)))
       ((atom (cdr pairs))
-       `(let ,(nreverse lets) (setq ,@(nreverse setqs))))
+       `(let ,(nreverse lets) (setq ,@(nreverse setqs)) nil))
     (let ((gen (gensym)))
       (push `(,gen ,(cadr pairs)) lets)
       (push (car pairs) setqs)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/pathname.lisp src-to-be/code/pathname.lisp
--- src/code/pathname.lisp	Mon Feb  9 16:19:39 1998
+++ src-to-be/code/pathname.lisp	Mon Nov  9 20:09:13 1998
@@ -1458,7 +1458,10 @@
 			   *logical-hosts*)))
        (if (or found (not errorp))
 	   found
-	   (error "Logical host not yet defined: ~S" thing))))
+	   (error 'simple-file-error
+		  :pathname thing
+		  :format-control "Logical host not yet defined: ~S"
+		  :format-arguments (list thing)))))
     (logical-host thing)))
 
 
@@ -1795,7 +1798,10 @@
   (typecase pathname
     (logical-pathname
      (dolist (x (logical-host-canon-transls (%pathname-host pathname))
-		(error "No translation for ~S" pathname))
+		(error 'simple-file-error
+		       :pathname pathname
+		       :format-control "No translation for ~S"
+		       :format-arguments (list pathname)))
        (destructuring-bind (from to) x
 	 (when (pathname-match-p pathname from)
 	   (return (translate-logical-pathname
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/rand-mt19937.lisp src-to-be/code/rand-mt19937.lisp
--- src/code/rand-mt19937.lisp	Sat Mar 21 09:12:04 1998
+++ src-to-be/code/rand-mt19937.lisp	Mon Nov  9 20:09:13 1998
@@ -300,16 +300,16 @@
   (declare (inline %random-single-float %random-double-float
 		   #+long-float %long-float))
   (cond
-    ((and (fixnump arg) (<= arg random-fixnum-max))
+    ((and (fixnump arg) (<= arg random-fixnum-max) #+high-security (> arg 0))
      (rem (random-chunk state) arg))
-    ((typep arg 'single-float)
+    ((and (typep arg 'single-float) #+high-security (> arg 0.0S0))
      (%random-single-float arg state))
-    ((typep arg 'double-float)
+    ((and (typep arg 'double-float) #+high-security (> arg 0.0D0))
      (%random-double-float arg state))
     #+long-float
-    ((typep arg 'long-float)
+    ((and (typep arg 'long-float) #+high-security (> arg 0.0L0))
      (%random-long-float arg state))
-    ((integerp arg)
+    ((and (integerp arg) #+high-security (> arg 0))
      (%random-integer arg state))
     (t
      (error 'simple-type-error
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/seq.lisp src-to-be/code/seq.lisp
--- src/code/seq.lisp	Sun Jul 19 03:41:26 1998
+++ src-to-be/code/seq.lisp	Mon Nov  9 20:09:13 1998
@@ -602,7 +602,10 @@
     ((simple-vector simple-string vector string array simple-array
 		    bit-vector simple-bit-vector base-string
 		    simple-base-string)
-     (apply #'concat-to-simple* output-type-spec sequences))
+     (let ((result (apply #'concat-to-simple* output-type-spec sequences)))
+       #+high-security
+       (check-type-var result output-type-spec)
+       result))
     (list (apply #'concat-to-list* sequences))
     (t
      (apply #'concatenate (result-type-or-lose output-type-spec) sequences))))
@@ -671,6 +674,19 @@
 
 )
 
+#+high-security-support
+(defun get-minimum-length-sequences (sequences)
+  "Gets the minimum length of the sequences. This is
+needed to check if the supplied type is appropriate."
+    (let ((min nil))
+      (dolist (i sequences)      
+	(when (or (listp i) (vectorp i))
+	  (let ((l (length i)))
+	    (when (or (null min)
+		      (> min l)))
+	    (setf min l))))
+      min))
+
 (defun map (output-type-spec function first-sequence &rest more-sequences)
   "FUNCTION must take as many arguments as there are sequences provided.  The 
    result is a sequence such that element i is the result of applying FUNCTION
@@ -680,7 +696,46 @@
       ((nil) (map-for-effect function sequences))
       (list (map-to-list function sequences))
       ((simple-vector simple-string vector string array simple-array
-		    bit-vector simple-bit-vector base-string simple-base-string)
+		      bit-vector simple-bit-vector base-string simple-base-string)
+       #+high-security
+       (let ((min-length-sequences (get-minimum-length-sequences
+				    sequences)) 
+	     (dimensions (array-type-dimensions (specifier-type
+						 output-type-spec))))
+	 (when (or (/= (length dimensions) 1)
+		   (and (not (eq (car dimensions) '*))
+			(/= (car dimensions) min-length-sequences)))
+	   (error 'simple-type-error
+		  :datum output-type-spec
+		  :expected-type
+		  (ecase (type-specifier-atom output-type-spec)
+		    ((simple-vector bit-vector simple-bit-vector string simple-string base-string)
+		     `(,(type-specifier-atom output-type-spec) ,min-length-sequences))
+		    ((array vector simple-array)   `(,(type-specifier-atom output-type-spec) * ,min-length-sequences)))
+		  :format-control "Minimum length of sequences is ~S, this is not compatible with the type ~S."
+		  :format-arguments
+		  (list min-length-sequences output-type-spec))))	   
+       (let ((result (map-to-simple output-type-spec function sequences)))
+           #+high-security
+	   (check-type-var result output-type-spec)
+	   result))
+      (t
+       (apply #'map (result-type-or-lose output-type-spec t)
+	      function sequences)))))
+
+#+high-security-support
+(defun map-without-errorchecking
+    (output-type-spec function first-sequence &rest more-sequences)
+  "FUNCTION must take as many arguments as there are sequences provided.  The 
+   result is a sequence such that element i is the result of applying FUNCTION
+   to element i of each of the argument sequences. This version has no
+   error-checking, to pass cold-load."
+  (let ((sequences (cons first-sequence more-sequences)))
+    (case (type-specifier-atom output-type-spec)
+      ((nil) (map-for-effect function sequences))
+     (list (map-to-list function sequences))
+      ((simple-vector simple-string vector string array simple-array
+		    bit-vector simple-bit-vector base-string simple-base-string)       
        (map-to-simple output-type-spec function sequences))
       (t
        (apply #'map (result-type-or-lose output-type-spec t)
@@ -842,7 +897,11 @@
   (flet ((coerce-error ()
 	   (error 'simple-type-error
 		  :format-control "~S can't be converted to type ~S."
-		  :format-arguments (list object output-type-spec))))
+		  :format-arguments (list object output-type-spec)))
+	 (check-result (result)
+	   #+high-security
+	   (check-type-var result output-type-spec)
+	   result))
     (let ((type (specifier-type output-type-spec)))
       (cond
 	((%typep object output-type-spec)
@@ -852,6 +911,33 @@
 	((csubtypep type (specifier-type 'character))
 	 (character object))
 	((csubtypep type (specifier-type 'function))
+	 #+high-security
+	 (when (and (or (symbolp object)
+			(and (listp object)
+			     (= (length object) 2)
+			     (eq (car object) 'setf)))
+		    (not (fboundp object)))
+	   (error 'simple-type-error
+		  :datum object
+		  :expected-type '(satisfies fboundp)
+	       :format-control "~S isn't fbound."
+	       :format-arguments (list object)))
+	 #+high-security
+	 (when (and (symbolp object)
+		    (macro-function object))
+	   (error 'simple-type-error
+		  :datum object
+		  :expected-type '(not (satisfies macro-function))
+		  :format-control "~S is a macro."
+		  :format-arguments (list object)))
+	 #+high-security
+	 (when (and (symbolp object)
+		    (special-operator-p object))
+	   (error 'simple-type-error
+		  :datum object
+		  :expected-type '(not (satisfies special-operator-p))
+		  :format-control "~S is a special operator."
+		  :format-arguments (list object)))		 
 	 (eval `#',object))
 	((numberp object)
 	 (let ((res
@@ -891,24 +977,27 @@
 	     (vector-to-list* object)
 	     (coerce-error)))
 	((csubtypep type (specifier-type 'string))
-	 (typecase object
-	   (list (list-to-string* object))
-	   (string (string-to-simple-string* object))
-	   (vector (vector-to-string* object))
-	   (t
-	    (coerce-error))))
+	 (check-result
+	  (typecase object
+	    (list (list-to-string* object))
+	    (string (string-to-simple-string* object))
+	    (vector (vector-to-string* object))
+	    (t
+	     (coerce-error)))))
 	((csubtypep type (specifier-type 'bit-vector))
-	 (typecase object
-	   (list (list-to-bit-vector* object))
-	   (vector (vector-to-bit-vector* object))
-	   (t
-	    (coerce-error))))
+	 (check-result
+	  (typecase object
+	    (list (list-to-bit-vector* object))
+	    (vector (vector-to-bit-vector* object))
+	    (t
+	     (coerce-error)))))
 	((csubtypep type (specifier-type 'vector))
-	 (typecase object
-	   (list (list-to-vector* object output-type-spec))
-	   (vector (vector-to-vector* object output-type-spec))
-	   (t
-	    (coerce-error))))
+	 (check-result
+	  (typecase object
+	    (list (list-to-vector* object output-type-spec))
+	    (vector (vector-to-vector* object output-type-spec))
+	    (t
+	     (coerce-error)))))
 	(t
 	 (coerce-error))))))
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/seq.lisp.werkt src-to-be/code/seq.lisp.werkt
--- src/code/seq.lisp.werkt	Thu Jan  1 01:00:00 1970
+++ src-to-be/code/seq.lisp.werkt	Fri Oct 23 13:56:17 1998
@@ -0,0 +1,2482 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: /home/pvaneynd/fakeroot/cvs2.cons.org/src/code/seq.lisp,v 1.33 1998/07/19 01:41:26 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Functions to implement generic sequences for Spice Lisp.
+;;; Written by Skef Wholey.
+;;; Fixed up by Jim Muller on Friday the 13th, January, 1984.
+;;; Gone over again by Bill Chiles.  Next?
+;;;
+;;; Be careful when modifying code.  A lot of the structure of the code is
+;;; affected by the fact that compiler transforms use the lower level support
+;;; functions.  If transforms are written for some sequence operation, note
+;;; how the end argument is handled in other operations with transforms.
+
+(in-package "LISP")
+(export '(elt subseq copy-seq coerce
+	  length reverse nreverse make-sequence concatenate map some every
+	  notany notevery reduce fill replace remove remove-if remove-if-not
+	  delete delete-if delete-if-not remove-duplicates delete-duplicates
+	  substitute substitute-if substitute-if-not nsubstitute nsubstitute-if
+	  nsubstitute-if-not find find-if find-if-not position position-if
+	  position-if-not count count-if count-if-not mismatch search
+	  map-into
+          identity)) ; Yep, thet's whar it is.
+
+	  
+;;; Spice-Lisp specific stuff and utilities:
+	  
+(eval-when (compile)
+
+;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence.
+
+(defmacro seq-dispatch (sequence list-form array-form)
+  `(if (listp ,sequence)
+       ,list-form
+       ,array-form))
+
+(defmacro elt-slice (sequences n)
+  "Returns a list of the Nth element of each of the sequences.  Used by MAP
+   and friends."
+  `(mapcar #'(lambda (seq) (elt seq ,n)) ,sequences))
+
+(defmacro make-sequence-like (sequence length)
+  "Returns a sequence of the same type as SEQUENCE and the given LENGTH."
+  `(make-sequence-of-type (type-of ,sequence) ,length))
+
+(defmacro type-specifier-atom (type)
+  "Returns the broad class of which TYPE is a specific subclass."
+  `(if (atom ,type) ,type (car ,type)))
+
+) ; eval-when
+
+
+
+
+;;; RESULT-TYPE-OR-LOSE  --  Internal
+;;;
+;;;    Given an arbitrary type specifier, return a sane sequence type specifier
+;;; that we can directly match.
+;;;
+(defun result-type-or-lose (type &optional nil-ok)
+  (let ((type (specifier-type type)))
+    (cond
+      ((eq type *empty-type*)
+       (if nil-ok
+	   nil
+	   (error 'simple-type-error
+		  :datum type
+		  :expected-type '(or vector cons)
+		  :format-control
+		  "NIL output type invalid for this sequence function."
+		  :format-arguments ())))
+      ((dolist (seq-type '(list string simple-vector bit-vector))
+	 (when (csubtypep type (specifier-type seq-type))
+	   (return seq-type))))
+      ((csubtypep type (specifier-type 'vector))
+       (type-specifier type))
+      (t
+       (error 'simple-type-error
+	      :datum type
+	      :expected-type 'sequence
+	      :format-control
+	      "~S is a bad type specifier for sequence functions."
+	      :format-arguments (list type))))))
+
+(define-condition index-too-large-error (type-error)
+  ()
+  (:report
+   (lambda(condition stream)
+     (format stream "Error in ~S: ~S: Index too large."
+	     (condition-function-name condition)
+	     (type-error-datum condition)))))
+
+(defun signal-index-too-large-error (sequence index)
+  (let* ((length (length sequence))
+	 (max-index (and (plusp length)(1- length))))
+    (error 'index-too-large-error
+	   :datum index
+	   :expected-type (if max-index
+			      `(integer 0 ,max-index)
+			      ;; This seems silly, is there something better?
+			      '(integer (0) (0))))))
+
+(defun make-sequence-of-type (type length)
+  "Returns a sequence of the given TYPE and LENGTH."
+  (declare (fixnum length))
+  (case (type-specifier-atom type)
+    (list (make-list length))
+    ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2)))
+    ((string simple-string base-string simple-base-string)
+     (make-string length))
+    (simple-vector (make-array length))
+    ((array simple-array vector)
+     (if (listp type)
+	 (make-array length :element-type (cadr type))
+	 (make-array length)))
+    (t
+     (make-sequence-of-type (result-type-or-lose type) length))))
+  
+(defun elt (sequence index)
+  "Returns the element of SEQUENCE specified by INDEX."
+  (etypecase sequence
+    (list
+     (do ((count index (1- count))
+	  (list sequence (cdr list)))
+	 ((= count 0)
+	  (if (endp list)
+	      (signal-index-too-large-error sequence index)
+	      (car list)))
+       (declare (type (integer 0) count))))
+    (vector
+     (when (>= index (length sequence))
+       (signal-index-too-large-error sequence index))
+     (aref sequence index))))
+
+(defun %setelt (sequence index newval)
+  "Store NEWVAL as the component of SEQUENCE specified by INDEX."
+  (etypecase sequence
+    (list
+     (do ((count index (1- count))
+	  (seq sequence))
+ 	 ((= count 0) (rplaca seq newval) newval)
+       (declare (fixnum count))
+       (if (atom (cdr seq))
+	   (signal-index-too-large-error sequence index)
+	   (setq seq (cdr seq)))))
+    (vector
+     (when (>= index (length sequence))
+       (signal-index-too-large-error sequence index))
+     (setf (aref sequence index) newval))))
+
+
+(defun length (sequence)
+  "Returns an integer that is the length of SEQUENCE."
+  (etypecase sequence
+    (vector (length (truly-the vector sequence)))
+    (list (length (truly-the list sequence)))))
+
+(defun make-sequence (type length &key (initial-element NIL iep))
+  "Returns a sequence of the given Type and Length, with elements initialized
+  to :Initial-Element."
+  (declare (fixnum length))
+  (let ((type (specifier-type type)))
+    (cond ((csubtypep type (specifier-type 'list))
+	   (make-list length :initial-element initial-element))
+	  ((csubtypep type (specifier-type 'string))
+	   (if iep
+	       (make-string length :initial-element initial-element)
+	       (make-string length)))
+	  ((csubtypep type (specifier-type 'simple-vector))
+	   (make-array length :initial-element initial-element))
+	  ((csubtypep type (specifier-type 'bit-vector))
+	   (if iep
+	       (make-array length :element-type '(mod 2)
+			   :initial-element initial-element)
+	       (make-array length :element-type '(mod 2))))
+	  ((csubtypep type (specifier-type 'vector))
+	   (if (typep type 'array-type)
+               (let ((etype (type-specifier
+                             (array-type-specialized-element-type type)))
+                     (vlen (car (array-type-dimensions type))))
+                 (if (and (numberp vlen) (/= vlen length))
+                   (error 'simple-type-error
+			  ;; these two are under-specified by ANSI
+			  :datum (type-specifier type)
+			  :expected-type (type-specifier type)
+			  :format-control
+			  "The length of ~S does not match the specified length  of ~S."
+			  :format-arguments
+			  (list (type-specifier type) length)))
+		 (if iep
+		     (make-array length :element-type etype
+				 :initial-element initial-element)
+		     (make-array length :element-type etype)))
+	       (make-array length :initial-element initial-element)))
+	  (t (error 'simple-type-error
+		    :datum type
+		    :expected-type 'sequence
+		    :format-control "~S is a bad type specifier for sequences."
+		    :format-arguments (list type))))))
+
+
+
+;;; Subseq:
+;;;
+;;; The support routines for SUBSEQ are used by compiler transforms, so we
+;;; worry about dealing with end being supplied as or defaulting to nil
+;;; at this level.
+
+(defun vector-subseq* (sequence start &optional end)
+  (declare (vector sequence) (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (do ((old-index start (1+ old-index))
+       (new-index 0 (1+ new-index))
+       (copy (make-sequence-like sequence (- end start))))
+      ((= old-index end) copy)
+    (declare (fixnum old-index new-index))
+    (setf (aref copy new-index) (aref sequence old-index))))
+
+(defun list-subseq* (sequence start &optional end)
+  (declare (list sequence) (fixnum start))
+  (if (and end (>= start (the fixnum end)))
+      ()
+      (let* ((groveled (nthcdr start sequence))
+	     (result (list (car groveled))))
+	(if groveled
+	    (do ((list (cdr groveled) (cdr list))
+		 (splice result (cdr (rplacd splice (list (car list)))))
+		 (index (1+ start) (1+ index)))
+		((or (atom list) (and end (= index (the fixnum end))))
+		 result)
+	      (declare (fixnum index)))
+	    ()))))
+
+;;; SUBSEQ cannot default end to the length of sequence since it is not
+;;; an error to supply nil for its value.  We must test for end being nil
+;;; in the body of the function, and this is actually done in the support
+;;; routines for other reasons (see above).
+(defun subseq (sequence start &optional end)
+  "Returns a copy of a subsequence of SEQUENCE starting with element number 
+   START and continuing to the end of SEQUENCE or the optional END."
+  (seq-dispatch sequence
+		(list-subseq* sequence start end)
+		(vector-subseq* sequence start end)))
+
+
+;;; Copy-seq:
+
+(eval-when (compile eval)
+
+(defmacro vector-copy-seq (sequence type)
+  `(let ((length (length (the vector ,sequence))))
+     (declare (fixnum length))
+     (do ((index 0 (1+ index))
+	  (copy (make-sequence-of-type ,type length)))
+	 ((= index length) copy)
+       (declare (fixnum index))
+       (setf (aref copy index) (aref ,sequence index)))))
+
+(defmacro list-copy-seq (list)
+  `(if (atom ,list) '()
+       (let ((result (cons (car ,list) '()) ))
+	 (do ((x (cdr ,list) (cdr x))
+	      (splice result
+		      (cdr (rplacd splice (cons (car x) '() ))) ))
+	     ((atom x) (unless (null x)
+			       (rplacd splice x))
+		       result)))))
+
+)
+
+(defun copy-seq (sequence)
+  "Returns a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
+  (seq-dispatch sequence
+		(list-copy-seq* sequence)
+		(vector-copy-seq* sequence)))
+
+;;; Internal Frobs:
+
+(defun list-copy-seq* (sequence)
+  (list-copy-seq sequence))
+
+(defun vector-copy-seq* (sequence)
+  (vector-copy-seq sequence (type-of sequence)))
+
+
+;;; Fill:
+
+(eval-when (compile eval)
+
+(defmacro vector-fill (sequence item start end)
+  `(do ((index ,start (1+ index)))
+       ((= index (the fixnum ,end)) ,sequence)
+     (declare (fixnum index))
+     (setf (aref ,sequence index) ,item)))
+
+(defmacro list-fill (sequence item start end)
+  `(do ((current (nthcdr ,start ,sequence) (cdr current))
+	(index ,start (1+ index)))
+       ((or (atom current) (and end (= index (the fixnum ,end))))
+	sequence)
+     (declare (fixnum index))
+     (rplaca current ,item)))
+
+)
+
+;;; The support routines for FILL are used by compiler transforms, so we
+;;; worry about dealing with end being supplied as or defaulting to nil
+;;; at this level.
+
+(defun list-fill* (sequence item start end)
+  (declare (list sequence))
+  (list-fill sequence item start end))
+
+(defun vector-fill* (sequence item start end)
+  (declare (vector sequence))
+  (when (null end) (setq end (length sequence)))
+  (vector-fill sequence item start end))
+
+;;; FILL cannot default end to the length of sequence since it is not
+;;; an error to supply nil for its value.  We must test for end being nil
+;;; in the body of the function, and this is actually done in the support
+;;; routines for other reasons (see above).
+(defun fill (sequence item &key (start 0) end)
+  "Replace the specified elements of SEQUENCE with ITEM."
+  (seq-dispatch sequence
+		(list-fill* sequence item start end)
+		(vector-fill* sequence item start end)))
+
+
+
+;;; Replace:
+
+(eval-when (compile eval)
+
+;;; If we are copying around in the same vector, be careful not to copy the
+;;; same elements over repeatedly.  We do this by copying backwards.
+(defmacro mumble-replace-from-mumble ()
+  `(if (and (eq target-sequence source-sequence) (> target-start source-start))
+       (let ((nelts (min (- target-end target-start) (- source-end source-start))))
+	 (do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1)
+			    (1- target-index))
+	      (source-index (+ (the fixnum source-start) (the fixnum nelts) -1)
+			    (1- source-index)))
+	     ((= target-index (the fixnum (1- target-start))) target-sequence)
+	   (declare (fixnum target-index source-index))
+	   (setf (aref target-sequence target-index)
+		 (aref source-sequence source-index))))
+       (do ((target-index target-start (1+ target-index))
+	    (source-index source-start (1+ source-index)))
+	   ((or (= target-index (the fixnum target-end))
+		(= source-index (the fixnum source-end)))
+	    target-sequence)
+	 (declare (fixnum target-index source-index))
+	 (setf (aref target-sequence target-index)
+	       (aref source-sequence source-index)))))
+
+(defmacro list-replace-from-list ()
+  `(if (and (eq target-sequence source-sequence) (> target-start source-start))
+       (let ((new-elts (subseq source-sequence source-start
+			       (+ (the fixnum source-start)
+				  (the fixnum
+				       (min (- (the fixnum target-end)
+					       (the fixnum target-start))
+					    (- (the fixnum source-end)
+					       (the fixnum source-start))))))))
+	 (do ((n new-elts (cdr n))
+	      (o (nthcdr target-start target-sequence) (cdr o)))
+	     ((null n) target-sequence)
+	   (rplaca o (car n))))
+       (do ((target-index target-start (1+ target-index))
+	    (source-index source-start (1+ source-index))
+	    (target-sequence-ref (nthcdr target-start target-sequence)
+				 (cdr target-sequence-ref))
+	    (source-sequence-ref (nthcdr source-start source-sequence)
+				 (cdr source-sequence-ref)))
+	   ((or (= target-index (the fixnum target-end))
+		(= source-index (the fixnum source-end))
+		(null target-sequence-ref) (null source-sequence-ref))
+	    target-sequence)
+	 (declare (fixnum target-index source-index))
+	 (rplaca target-sequence-ref (car source-sequence-ref)))))
+
+(defmacro list-replace-from-mumble ()
+  `(do ((target-index target-start (1+ target-index))
+	(source-index source-start (1+ source-index))
+	(target-sequence-ref (nthcdr target-start target-sequence)
+			     (cdr target-sequence-ref)))
+       ((or (= target-index (the fixnum target-end))
+	    (= source-index (the fixnum source-end))
+	    (null target-sequence-ref))
+	target-sequence)
+     (declare (fixnum source-index target-index))
+     (rplaca target-sequence-ref (aref source-sequence source-index))))
+
+(defmacro mumble-replace-from-list ()
+  `(do ((target-index target-start (1+ target-index))
+	(source-index source-start (1+ source-index))
+	(source-sequence (nthcdr source-start source-sequence)
+			 (cdr source-sequence)))
+       ((or (= target-index (the fixnum target-end))
+	    (= source-index (the fixnum source-end))
+	    (null source-sequence))
+	target-sequence)
+     (declare (fixnum target-index source-index))
+     (setf (aref target-sequence target-index) (car source-sequence))))
+
+) ; eval-when
+
+;;; The support routines for REPLACE are used by compiler transforms, so we
+;;; worry about dealing with end being supplied as or defaulting to nil
+;;; at this level.
+
+(defun list-replace-from-list* (target-sequence source-sequence target-start
+				target-end source-start source-end)
+  (when (null target-end) (setq target-end (length target-sequence)))
+  (when (null source-end) (setq source-end (length source-sequence)))
+  (list-replace-from-list))
+
+(defun list-replace-from-vector* (target-sequence source-sequence target-start
+				  target-end source-start source-end)
+  (when (null target-end) (setq target-end (length target-sequence)))
+  (when (null source-end) (setq source-end (length source-sequence)))
+  (list-replace-from-mumble))
+
+(defun vector-replace-from-list* (target-sequence source-sequence target-start
+				  target-end source-start source-end)
+  (when (null target-end) (setq target-end (length target-sequence)))
+  (when (null source-end) (setq source-end (length source-sequence)))
+  (mumble-replace-from-list))
+
+(defun vector-replace-from-vector* (target-sequence source-sequence
+				    target-start target-end source-start
+				    source-end)
+  (when (null target-end) (setq target-end (length target-sequence)))
+  (when (null source-end) (setq source-end (length source-sequence)))
+  (mumble-replace-from-mumble))
+
+;;; REPLACE cannot default end arguments to the length of sequence since it
+;;; is not an error to supply nil for their values.  We must test for ends
+;;; being nil in the body of the function.
+(defun replace (target-sequence source-sequence &key
+	        ((:start1 target-start) 0)
+		((:end1 target-end))
+		((:start2 source-start) 0)
+		((:end2 source-end)))
+  "The target sequence is destructively modified by copying successive
+   elements into it from the source sequence."
+  (let ((target-end (or target-end (length target-sequence)))
+	(source-end (or source-end (length source-sequence))))
+    (seq-dispatch target-sequence
+		  (seq-dispatch source-sequence
+				(list-replace-from-list)
+				(list-replace-from-mumble))
+		  (seq-dispatch source-sequence
+				(mumble-replace-from-list)
+				(mumble-replace-from-mumble)))))
+
+
+;;; Reverse:
+
+(eval-when (compile eval)
+
+(defmacro vector-reverse (sequence type)
+  `(let ((length (length ,sequence)))
+     (declare (fixnum length))
+     (do ((forward-index 0 (1+ forward-index))
+	  (backward-index (1- length) (1- backward-index))
+	  (new-sequence (make-sequence-of-type ,type length)))
+	 ((= forward-index length) new-sequence)
+       (declare (fixnum forward-index backward-index))
+       (setf (aref new-sequence forward-index)
+	     (aref ,sequence backward-index)))))
+
+(defmacro list-reverse-macro (sequence)
+  `(do ((new-list ()))
+       ((atom ,sequence) new-list)
+     (push (pop ,sequence) new-list)))
+
+)
+
+(defun reverse (sequence)
+  "Returns a new sequence containing the same elements but in reverse order."
+  (seq-dispatch sequence
+		(list-reverse* sequence)
+		(vector-reverse* sequence)))
+
+;;; Internal Frobs:
+
+(defun list-reverse* (sequence)
+  (list-reverse-macro sequence))
+
+(defun vector-reverse* (sequence)
+  (vector-reverse sequence (type-of sequence)))
+
+
+;;; Nreverse:
+
+(eval-when (compile eval)
+
+(defmacro vector-nreverse (sequence)
+  `(let ((length (length (the vector ,sequence))))
+     (declare (fixnum length))
+     (do ((left-index 0 (1+ left-index))
+	  (right-index (1- length) (1- right-index))
+	  (half-length (truncate length 2)))
+	 ((= left-index half-length) ,sequence)
+       (declare (fixnum left-index right-index half-length))
+       (rotatef (aref ,sequence left-index)
+		(aref ,sequence right-index)))))
+
+(defmacro list-nreverse-macro (list)
+  `(do ((1st (cdr ,list) (if (atom 1st) 1st (cdr 1st)))
+	(2nd ,list 1st)
+	(3rd '() 2nd))
+       ((atom 2nd) 3rd)
+     (rplacd 2nd 3rd)))
+
+)
+
+
+(defun list-nreverse* (sequence)
+  (list-nreverse-macro sequence))
+
+(defun vector-nreverse* (sequence)
+  (vector-nreverse sequence))
+
+(defun nreverse (sequence)
+  "Returns a sequence of the same elements in reverse order; the argument
+   is destroyed."
+  (seq-dispatch sequence
+		(list-nreverse* sequence)
+		(vector-nreverse* sequence)))
+
+
+;;; Concatenate:
+
+(eval-when (compile eval)
+
+(defmacro concatenate-to-list (sequences)
+  `(let ((result (list nil)))
+     (do ((sequences ,sequences (cdr sequences))
+	  (splice result))
+	 ((null sequences) (cdr result))
+       (let ((sequence (car sequences)))
+	 (seq-dispatch sequence
+		       (do ((sequence sequence (cdr sequence)))
+			   ((atom sequence))
+			 (setq splice
+			       (cdr (rplacd splice (list (car sequence))))))
+		       (do ((index 0 (1+ index))
+			    (length (length sequence)))
+			   ((= index length))
+			 (declare (fixnum index length))
+			 (setq splice
+			       (cdr (rplacd splice
+					    (list (aref sequence index)))))))))))
+
+(defmacro concatenate-to-mumble (output-type-spec sequences)
+  `(do ((seqs ,sequences (cdr seqs))
+	(total-length 0)
+	(lengths ()))
+       ((null seqs)
+	(do ((sequences ,sequences (cdr sequences))
+	     (lengths lengths (cdr lengths))
+	     (index 0)
+	     (result (make-sequence-of-type ,output-type-spec total-length)))
+	    ((= index total-length) result)
+	  (declare (fixnum index))
+	  (let ((sequence (car sequences)))
+	    (seq-dispatch sequence
+			  (do ((sequence sequence (cdr sequence)))
+			      ((atom sequence))
+			    (setf (aref result index) (car sequence))
+			    (setq index (1+ index)))
+			  (do ((jndex 0 (1+ jndex))
+			       (this-length (car lengths)))
+			      ((= jndex this-length))
+			    (declare (fixnum jndex this-length))
+			    (setf (aref result index)
+				  (aref sequence jndex))
+			    (setq index (1+ index)))))))
+     (let ((length (length (car seqs))))
+       (declare (fixnum length))
+       (setq lengths (nconc lengths (list length)))
+       (setq total-length (+ total-length length)))))
+
+)
+
+(defun concatenate (output-type-spec &rest sequences)
+  "Returns a new sequence of all the argument sequences concatenated together
+  which shares no structure with the original argument sequences of the
+  specified OUTPUT-TYPE-SPEC."
+  (case (type-specifier-atom output-type-spec)
+    ((simple-vector simple-string vector string array simple-array
+		    bit-vector simple-bit-vector base-string
+		    simple-base-string)
+     (let ((result (apply #'concat-to-simple* output-type-spec sequences)))
+       #+high-security
+       (check-type result output-type-spec)
+       result))
+    (list (apply #'concat-to-list* sequences))
+    (t
+     (apply #'concatenate (result-type-or-lose output-type-spec) sequences))))
+
+;;; Internal Frobs:
+
+(defun concat-to-list* (&rest sequences)
+  (concatenate-to-list sequences))
+
+(defun concat-to-simple* (type &rest sequences)
+  (concatenate-to-mumble type sequences))
+
+
+;;; Map:
+
+(eval-when (compile eval)
+
+(defmacro map-to-list (function sequences)
+  `(do ((seqs more-sequences (cdr seqs))
+	(min-length (length first-sequence)))
+       ((null seqs)
+	(let ((result (list nil)))
+	  (do ((index 0 (1+ index))
+	       (splice result))
+	      ((= index min-length) (cdr result))
+	    (declare (fixnum index))
+	    (setq splice
+		  (cdr (rplacd splice
+			       (list (apply ,function (elt-slice ,sequences
+								 index)))))))))
+     (declare (fixnum min-length))
+     (let ((length (length (car seqs))))
+       (declare (fixnum length))
+       (if (< length min-length)
+	   (setq min-length length)))))
+
+(defmacro map-to-simple (output-type-spec function sequences)
+  `(do ((seqs more-sequences (cdr seqs))
+	(min-length (length first-sequence)))
+       ((null seqs)
+	(do ((index 0 (1+ index))
+	     (result (make-sequence-of-type ,output-type-spec min-length)))
+	    ((= index min-length) result)
+	  (declare (fixnum index))
+	  (setf (aref result index)
+		(apply ,function (elt-slice ,sequences index)))))
+     (declare (fixnum min-length))
+     (let ((length (length (car seqs))))
+       (declare (fixnum length))
+       (if (< length min-length)
+	   (setq min-length length)))))
+
+(defmacro map-for-effect (function sequences)
+  `(do ((seqs more-sequences (cdr seqs))
+	(min-length (length first-sequence)))
+       ((null seqs)
+	(do ((index 0 (1+ index)))
+	    ((= index min-length) nil)
+	  (apply ,function (elt-slice ,sequences index))))
+     (declare (fixnum min-length))
+     (let ((length (length (car seqs))))
+       (declare (fixnum length))
+       (if (< length min-length)
+	   (setq min-length length)))))
+
+
+)
+
+#+high-security-support
+(defun get-minimum-length-sequences (sequences)
+  "Gets the minimum length of the sequences. This is
+needed to check if the supplied type is appropriate."
+    (let ((min nil))
+      (dolist (i sequences)      
+	(when (or (listp i) (vectorp i))
+	  (let ((l (length i)))
+	    (when (or (null min)
+		      (> min l)))
+	    (setf min l))))
+      min))
+
+(defun map (output-type-spec function first-sequence &rest more-sequences)
+  "FUNCTION must take as many arguments as there are sequences provided.  The 
+   result is a sequence such that element i is the result of applying FUNCTION
+   to element i of each of the argument sequences."
+  (let ((sequences (cons first-sequence more-sequences)))
+    (case (type-specifier-atom output-type-spec)
+      ((nil) (map-for-effect function sequences))
+      (list (map-to-list function sequences))
+      ((simple-vector simple-string vector string array simple-array
+		      bit-vector simple-bit-vector base-string simple-base-string)
+       #+high-security
+       (let ((min-length-sequences (get-minimum-length-sequences
+				    sequences))
+	     (dimensions (array-type-dimensions (specifier-type
+						 output-type-spec))))
+	 (when (or (/= (length dimensions) 1)
+		   (and (not (eq (car dimensions) '*))
+			(/= (car dimensions) min-length-sequences)))
+	   (error 'simple-type-error
+		  :datum output-type-spec
+		  :expected-type
+		  (ecase (type-specifier-atom output-type-spec)
+		    ((simple-vector bit-vector simple-bit-vector string simple-string base-string)
+		     `(,(type-specifier-atom output-type-spec) ,min-length-sequences))
+		    ((array vector simple-array)   `(,(type-specifier-atom output-type-spec) * ,min-length-sequences)))
+		  :format-control "Minimum length of sequences is ~S, this is not compatible with the type ~S."
+		  :format-arguments
+		  (list min-length-sequences output-type-spec))))	   
+       (let ((result (map-to-simple output-type-spec function sequences)))
+           #+high-security
+	   (lisp::check-type result output-type-spec)
+	   result))
+      (t
+       (apply #'map (result-type-or-lose output-type-spec t)
+	      function sequences)))))
+
+#+high-security-support
+(defun map-without-errorchecking
+    (output-type-spec function first-sequence &rest more-sequences)
+  "FUNCTION must take as many arguments as there are sequences provided.  The 
+   result is a sequence such that element i is the result of applying FUNCTION
+   to element i of each of the argument sequences. This version has no
+   error-checking, to pass cold-load."
+  (let ((sequences (cons first-sequence more-sequences)))
+    (case (type-specifier-atom output-type-spec)
+      ((nil) (map-for-effect function sequences))
+     (list (map-to-list function sequences))
+      ((simple-vector simple-string vector string array simple-array
+		    bit-vector simple-bit-vector base-string simple-base-string)       
+       (map-to-simple output-type-spec function sequences))
+      (t
+       (apply #'map (result-type-or-lose output-type-spec t)
+	      function sequences)))))
+
+(defun map-into (result-sequence function &rest sequences)
+  (let* ((fp-result
+	  (and (arrayp result-sequence)
+	       (array-has-fill-pointer-p result-sequence)))
+	 (len (apply #'min
+		     (if fp-result
+			 (array-dimension result-sequence 0)
+			 (length result-sequence))
+		     (mapcar #'length sequences))))
+
+    (when fp-result
+      (setf (fill-pointer result-sequence) len))
+
+    (dotimes (index len)
+      (setf (elt result-sequence index)
+	    (apply function
+		   (mapcar #'(lambda (seq) (elt seq index))
+			   sequences)))))
+  result-sequence)
+  
+
+;;; Quantifiers:
+
+(eval-when (compile eval)
+(defmacro defquantifier (name doc-string every-result abort-sense abort-value)
+  `(defun ,name (predicate first-sequence &rest more-sequences)
+     ,doc-string
+     (do ((seqs more-sequences (cdr seqs))
+	  (length (length first-sequence))
+	  (sequences (cons first-sequence more-sequences)))
+	 ((null seqs)
+	  (do ((index 0 (1+ index)))
+	      ((= index length) ,every-result)
+	    (declare (fixnum index))
+	    (let ((result (apply predicate (elt-slice sequences index))))
+	      (if ,(if abort-sense 'result '(not result))
+		  (return ,abort-value)))))
+       (declare (fixnum length))
+       (let ((this (length (car seqs))))
+	 (declare (fixnum this))
+	 (if (< this length) (setq length this))))))
+) ; eval-when
+
+(defquantifier some
+  "PREDICATE is applied to the elements with index 0 of the sequences, then 
+   possibly to those with index 1, and so on.  SOME returns the first 
+   non-() value encountered, or () if the end of a sequence is reached."
+  nil t result)
+
+(defquantifier every
+  "PREDICATE is applied to the elements with index 0 of the sequences, then
+   possibly to those with index 1, and so on.  EVERY returns () as soon
+   as any invocation of PREDICATE returns (), or T if every invocation
+   is non-()."
+  t nil nil)
+
+(defquantifier notany
+  "PREDICATE is applied to the elements with index 0 of the sequences, then 
+   possibly to those with index 1, and so on.  NOTANY returns () as soon
+   as any invocation of PREDICATE returns a non-() value, or T if the end
+   of a sequence is reached."
+  t t nil)
+
+(defquantifier notevery
+  "PREDICATE is applied to the elements with index 0 of the sequences, then
+   possibly to those with index 1, and so on.  NOTEVERY returns T as soon
+   as any invocation of PREDICATE returns (), or () if every invocation
+   is non-()."
+  nil nil t)
+
+
+
+;;; Reduce:
+
+(eval-when (compile eval)
+
+(defmacro mumble-reduce (function sequence key start end initial-value ref)
+  `(do ((index ,start (1+ index))
+	(value ,initial-value))
+       ((= index (the fixnum ,end)) value)
+     (declare (fixnum index))
+     (setq value (funcall ,function value
+			  (apply-key ,key (,ref ,sequence index))))))
+
+(defmacro mumble-reduce-from-end (function sequence key start end initial-value ref)
+  `(do ((index (1- ,end) (1- index))
+	(value ,initial-value)
+	(terminus (1- ,start)))
+       ((= index terminus) value)
+     (declare (fixnum index terminus))
+     (setq value (funcall ,function
+			  (apply-key ,key (,ref ,sequence index))
+			  value))))
+
+(defmacro list-reduce (function sequence key start end initial-value ivp)
+  `(let ((sequence (nthcdr ,start ,sequence)))
+     (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
+		 (1+ count))
+	  (sequence (if ,ivp sequence (cdr sequence))
+		    (cdr sequence))
+	  (value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
+		 (funcall ,function value (apply-key ,key (car sequence)))))
+	 ((= count (the fixnum ,end)) value)
+       (declare (fixnum count)))))
+
+(defmacro list-reduce-from-end (function sequence key start end initial-value ivp)
+  `(let ((sequence (nthcdr (- (the fixnum (length ,sequence)) (the fixnum ,end))
+			   (reverse ,sequence))))
+     (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
+		 (1+ count))
+	  (sequence (if ,ivp sequence (cdr sequence))
+		    (cdr sequence))
+	  (value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
+		 (funcall ,function (apply-key ,key (car sequence)) value)))
+	 ((= count (the fixnum ,end)) value)
+       (declare (fixnum count)))))
+
+)
+
+(defun reduce (function sequence &key key from-end (start 0)
+			end (initial-value nil ivp))
+  "The specified Sequence is ``reduced'' using the given Function.
+  See manual for details."
+  (declare (type index start))
+  (let ((start start)
+	(end (or end (length sequence))))
+    (declare (type index start end))
+    (cond ((= end start)
+	   (if ivp initial-value (funcall function)))
+	  ((listp sequence)
+	   (if from-end
+	       (list-reduce-from-end function sequence key start end
+				     initial-value ivp)
+	       (list-reduce function sequence key start end
+			    initial-value ivp)))
+	  (from-end
+	   (when (not ivp)
+	     (setq end (1- (the fixnum end)))
+	     (setq initial-value (apply-key key (aref sequence end))))
+	   (mumble-reduce-from-end function sequence key start end
+				   initial-value aref))
+	  (t
+	   (when (not ivp)
+	     (setq initial-value (apply-key key (aref sequence start)))
+	     (setq start (1+ start)))
+	   (mumble-reduce function sequence key start end
+			  initial-value aref)))))
+
+
+;;; Coerce:
+
+(defun coerce (object output-type-spec)
+  "Coerces the Object to an object of type Output-Type-Spec."
+  (flet ((coerce-error ()
+	   (error 'simple-type-error
+		  :format-control "~S can't be converted to type ~S."
+		  :format-arguments (list object output-type-spec)))
+	 (check-result (result)
+	   #+high-security
+	   (lisp::check-type result output-type-spec)
+	   result))
+    (let ((type (specifier-type output-type-spec)))
+      (cond
+	((%typep object output-type-spec)
+	 object)
+	((eq type *empty-type*)
+	 (coerce-error))
+	((csubtypep type (specifier-type 'character))
+	 (character object))
+	((csubtypep type (specifier-type 'function))
+	 ;#+high-security
+	 (when (and (or (symbolp object)
+			(and (listp object)
+			     (= (length object) 2)
+			     (eq (car object) 'setf)))
+		    (not (fboundp object)))
+	   (error 'simple-type-error
+		  :datum object
+		  :expected-type '(satisfies fboundp)
+	       :format-control "~S isn't fbound."
+	       :format-arguments (list object)))
+	 ;#+high-security
+	 (when (and (symbolp object)
+		    (macro-function object))
+	   (error 'simple-type-error
+		  :datum object
+		  :expected-type '(not (satisfies macro-function))
+		  :format-control "~S is a macro."
+		  :format-arguments (list object)))
+	 ;#+high-security
+	 (when (and (symbolp object)
+		    (special-operator-p object))
+	   (error 'simple-type-error
+		  :datum object
+		  :expected-type '(not (satisfies special-operator-p))
+		  :format-control "~S is a special operator."
+		  :format-arguments (list object)))		 
+	 (eval `#',object))
+	((numberp object)
+	 (let ((res
+		(cond
+		  ((csubtypep type (specifier-type 'single-float))
+		   (%single-float object))
+		  ((csubtypep type (specifier-type 'double-float))
+		   (%double-float object))
+		  #+long-float
+		  ((csubtypep type (specifier-type 'long-float))
+		   (%long-float object))
+		  ((csubtypep type (specifier-type 'float))
+		   (%single-float object))
+		  ((csubtypep type (specifier-type '(complex single-float)))
+		   (complex (%single-float (realpart object))
+			    (%single-float (imagpart object))))
+		  ((csubtypep type (specifier-type '(complex double-float)))
+		   (complex (%double-float (realpart object))
+			    (%double-float (imagpart object))))
+		  #+long-float
+		  ((csubtypep type (specifier-type '(complex long-float)))
+		   (complex (%long-float (realpart object))
+			    (%long-float (imagpart object))))
+		  ((csubtypep type (specifier-type 'complex))
+		   (complex object))
+		  (t
+		   (coerce-error)))))
+	   ;; If RES has the wrong type, that means that rule of canonical
+	   ;; representation for complex rationals was invoked.  According to
+	   ;; the Hyperspec, (coerce 7/2 'complex) returns 7/2.  Thus, if the
+	   ;; object was a rational, there is no error here.
+	   (unless (or (typep res output-type-spec) (rationalp object))
+	     (coerce-error))
+	   res))
+	((csubtypep type (specifier-type 'list))
+	 (if (vectorp object)
+	     (vector-to-list* object)
+	     (coerce-error)))
+	((csubtypep type (specifier-type 'string))
+	 (check-result
+	  (typecase object
+	    (list (list-to-string* object))
+	    (string (string-to-simple-string* object))
+	    (vector (vector-to-string* object))
+	    (t
+	     (coerce-error)))))
+	((csubtypep type (specifier-type 'bit-vector))
+	 (check-result
+	  (typecase object
+	    (list (list-to-bit-vector* object))
+	    (vector (vector-to-bit-vector* object))
+	    (t
+	     (coerce-error)))))
+	((csubtypep type (specifier-type 'vector))
+	 (check-result
+	  (typecase object
+	    (list (list-to-vector* object output-type-spec))
+	    (vector (vector-to-vector* object output-type-spec))
+	    (t
+	     (coerce-error)))))
+	(t
+	 (coerce-error))))))
+
+
+;;; Internal Frobs:
+
+(macrolet ((frob (name result access src-type &optional typep)
+		 `(defun ,name (object ,@(if typep '(type) ()))
+		    (do* ((index 0 (1+ index))
+			  (length (length (the ,(case src-type
+						  (:list 'list)
+						  (:vector 'vector))
+					       object)))
+			  (result ,result))
+			 ((= index length) result)
+		      (declare (fixnum length index))
+		      (setf (,access result index)
+			    ,(case src-type
+			       (:list '(pop object))
+			       (:vector '(aref object index))))))))
+
+  (frob list-to-string* (make-string length) schar :list)
+
+  (frob list-to-bit-vector* (make-array length :element-type '(mod 2))
+	sbit :list)
+
+  (frob list-to-vector* (make-sequence-of-type type length)
+	aref :list t)
+
+  (frob vector-to-vector* (make-sequence-of-type type length)
+	aref :vector t)
+
+  (frob vector-to-string* (make-string length) schar :vector)
+
+  (frob vector-to-bit-vector* (make-array length :element-type '(mod 2))
+	sbit :vector))
+
+(defun vector-to-list* (object)
+  (let ((result (list nil))
+	(length (length object)))
+    (declare (fixnum length))
+    (do ((index 0 (1+ index))
+	 (splice result (cdr splice)))
+	((= index length) (cdr result))
+      (declare (fixnum index))
+      (rplacd splice (list (aref object index))))))
+
+(defun string-to-simple-string* (object)
+  (if (simple-string-p object)
+      object
+      (with-array-data ((data object)
+			(start)
+			(end (length object)))
+	(declare (simple-string data))
+	(subseq data start end))))
+
+(defun bit-vector-to-simple-bit-vector* (object)
+  (if (simple-bit-vector-p object)
+      object
+      (with-array-data ((data object)
+			(start)
+			(end (length object)))
+	(declare (simple-bit-vector data))
+	(subseq data start end))))
+
+
+;;; Delete:
+
+(eval-when (compile eval)
+
+(defmacro mumble-delete (pred)
+  `(do ((index start (1+ index))
+	(jndex start)
+	(number-zapped 0))
+       ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+	(do ((index index (1+ index))		; copy the rest of the vector
+	     (jndex jndex (1+ jndex)))
+	    ((= index (the fixnum length))
+	     (shrink-vector sequence jndex))
+	  (declare (fixnum index jndex))
+	  (setf (aref sequence jndex) (aref sequence index))))
+     (declare (fixnum index jndex number-zapped))
+     (setf (aref sequence jndex) (aref sequence index))
+     (if ,pred
+	 (setq number-zapped (1+ number-zapped))
+	 (setq jndex (1+ jndex)))))
+
+(defmacro mumble-delete-from-end (pred)
+  `(do ((index (1- (the fixnum end)) (1- index)) ; find the losers
+	(number-zapped 0)
+	(losers ())
+        this-element
+	(terminus (1- start)))
+       ((or (= index terminus) (= number-zapped (the fixnum count)))
+	(do ((losers losers)			 ; delete the losers
+	     (index start (1+ index))
+	     (jndex start))
+	    ((or (null losers) (= index (the fixnum end)))
+	     (do ((index index (1+ index))	 ; copy the rest of the vector
+		  (jndex jndex (1+ jndex)))
+		 ((= index (the fixnum length))
+		  (shrink-vector sequence jndex))
+	       (declare (fixnum index jndex))
+	       (setf (aref sequence jndex) (aref sequence index))))
+	  (declare (fixnum index jndex))
+	  (setf (aref sequence jndex) (aref sequence index))
+	  (if (= index (the fixnum (car losers)))
+	      (pop losers)
+	      (setq jndex (1+ jndex)))))
+     (declare (fixnum index number-zapped terminus))
+     (setq this-element (aref sequence index))
+     (when ,pred
+       (setq number-zapped (1+ number-zapped))
+       (push index losers))))
+
+(defmacro normal-mumble-delete ()
+  `(mumble-delete
+    (if test-not
+	(not (funcall test-not item (apply-key key (aref sequence index))))
+	(funcall test item (apply-key key (aref sequence index))))))
+
+(defmacro normal-mumble-delete-from-end ()
+  `(mumble-delete-from-end
+    (if test-not
+	(not (funcall test-not item (apply-key key this-element)))
+	(funcall test item (apply-key key this-element)))))
+
+(defmacro list-delete (pred)
+  `(let ((handle (cons nil sequence)))
+     (do ((current (nthcdr start sequence) (cdr current))
+	  (previous (nthcdr start handle))
+	  (index start (1+ index))
+	  (number-zapped 0))
+	 ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+	  (cdr handle))
+       (declare (fixnum index number-zapped))
+       (cond (,pred
+	      (rplacd previous (cdr current))
+	      (setq number-zapped (1+ number-zapped)))
+	     (t
+	      (setq previous (cdr previous)))))))
+
+(defmacro list-delete-from-end (pred)
+  `(let* ((reverse (nreverse (the list sequence)))
+	  (handle (cons nil reverse)))
+     (do ((current (nthcdr (- (the fixnum length) (the fixnum end)) reverse)
+		   (cdr current))
+	  (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle))
+	  (index start (1+ index))
+	  (number-zapped 0))
+	 ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+	  (nreverse (cdr handle)))
+       (declare (fixnum index number-zapped))
+       (cond (,pred
+	      (rplacd previous (cdr current))
+	      (setq number-zapped (1+ number-zapped)))
+	     (t
+	      (setq previous (cdr previous)))))))
+
+(defmacro normal-list-delete ()
+  '(list-delete
+    (if test-not
+	(not (funcall test-not item (apply-key key (car current))))
+	(funcall test item (apply-key key (car current))))))
+
+(defmacro normal-list-delete-from-end ()
+  '(list-delete-from-end
+    (if test-not
+	(not (funcall test-not item (apply-key key (car current))))
+	(funcall test item (apply-key key (car current))))))
+)
+
+(defun delete (item sequence &key from-end (test #'eql) test-not (start 0)
+		end count key)
+  "Returns a sequence formed by destructively removing the specified Item from
+  the given Sequence."
+  (declare (fixnum start))
+  (let* ((length (length sequence))
+	 (end (or end length))
+	 (count (or count most-positive-fixnum)))
+    (declare (type index length end)
+	     (fixnum count))
+    (seq-dispatch sequence
+		  (if from-end
+		      (normal-list-delete-from-end)
+		      (normal-list-delete))
+		  (if from-end
+		      (normal-mumble-delete-from-end)
+		      (normal-mumble-delete)))))
+
+(eval-when (compile eval)
+
+(defmacro if-mumble-delete ()
+  `(mumble-delete
+    (funcall predicate (apply-key key (aref sequence index)))))
+
+(defmacro if-mumble-delete-from-end ()
+  `(mumble-delete-from-end
+    (funcall predicate (apply-key key this-element))))
+
+(defmacro if-list-delete ()
+  '(list-delete
+    (funcall predicate (apply-key key (car current)))))
+
+(defmacro if-list-delete-from-end ()
+  '(list-delete-from-end
+    (funcall predicate (apply-key key (car current)))))
+
+)
+
+(defun delete-if (predicate sequence &key from-end (start 0) key end count)
+  "Returns a sequence formed by destructively removing the elements satisfying
+  the specified Predicate from the given Sequence."
+  (declare (fixnum start))
+  (let* ((length (length sequence))
+	 (end (or end length))
+	 (count (or count most-positive-fixnum)))
+    (declare (type index length end)
+	     (fixnum count))
+    (seq-dispatch sequence
+		  (if from-end
+		      (if-list-delete-from-end)
+		      (if-list-delete))
+		  (if from-end
+		      (if-mumble-delete-from-end)
+		      (if-mumble-delete)))))
+
+(eval-when (compile eval)
+
+(defmacro if-not-mumble-delete ()
+  `(mumble-delete
+    (not (funcall predicate (apply-key key (aref sequence index))))))
+
+(defmacro if-not-mumble-delete-from-end ()
+  `(mumble-delete-from-end
+    (not (funcall predicate (apply-key key this-element)))))
+
+(defmacro if-not-list-delete ()
+  '(list-delete
+    (not (funcall predicate (apply-key key (car current))))))
+
+(defmacro if-not-list-delete-from-end ()
+  '(list-delete-from-end
+    (not (funcall predicate (apply-key key (car current))))))
+
+)
+
+(defun delete-if-not (predicate sequence &key from-end (start 0) end key count)
+  "Returns a sequence formed by destructively removing the elements not
+  satisfying the specified Predicate from the given Sequence."
+  (declare (fixnum start))
+  (let* ((length (length sequence))
+	 (end (or end length))
+	 (count (or count most-positive-fixnum)))
+    (declare (type index length end)
+	     (fixnum count))
+    (seq-dispatch sequence
+		  (if from-end
+		      (if-not-list-delete-from-end)
+		      (if-not-list-delete))
+		  (if from-end
+		      (if-not-mumble-delete-from-end)
+		      (if-not-mumble-delete)))))
+
+
+;;; Remove:
+
+(eval-when (compile eval)
+
+;;; MUMBLE-REMOVE-MACRO does not include (removes) each element that
+;;; satisfies the predicate.
+(defmacro mumble-remove-macro (bump left begin finish right pred)
+  `(do ((index ,begin (,bump index))
+	(result
+	 (do ((index ,left (,bump index))
+	      (result (make-sequence-like sequence length)))
+	     ((= index (the fixnum ,begin)) result)
+	   (declare (fixnum index))
+	   (setf (aref result index) (aref sequence index))))
+	(new-index ,begin)
+	(number-zapped 0)
+	(this-element))
+       ((or (= index (the fixnum ,finish)) (= number-zapped (the fixnum count)))
+	(do ((index index (,bump index))
+	     (new-index new-index (,bump new-index)))
+	    ((= index (the fixnum ,right)) (shrink-vector result new-index))
+	  (declare (fixnum index new-index))
+	  (setf (aref result new-index) (aref sequence index))))
+     (declare (fixnum index new-index number-zapped))
+     (setq this-element (aref sequence index))
+     (cond (,pred (setq number-zapped (1+ number-zapped)))
+	   (t (setf (aref result new-index) this-element)
+	      (setq new-index (,bump new-index))))))
+
+(defmacro mumble-remove (pred)
+  `(mumble-remove-macro 1+ 0 start end length ,pred))
+
+(defmacro mumble-remove-from-end (pred)
+  `(let ((sequence (copy-seq sequence)))
+     (mumble-delete-from-end ,pred)))
+
+(defmacro normal-mumble-remove ()
+  `(mumble-remove 
+    (if test-not
+	(not (funcall test-not item (apply-key key this-element)))
+	(funcall test item (apply-key key this-element)))))
+
+(defmacro normal-mumble-remove-from-end ()
+  `(mumble-remove-from-end 
+    (if test-not
+	(not (funcall test-not item (apply-key key this-element)))
+	(funcall test item (apply-key key this-element)))))
+
+(defmacro if-mumble-remove ()
+  `(mumble-remove (funcall predicate (apply-key key this-element))))
+
+(defmacro if-mumble-remove-from-end ()
+  `(mumble-remove-from-end (funcall predicate (apply-key key this-element))))
+
+(defmacro if-not-mumble-remove ()
+  `(mumble-remove (not (funcall predicate (apply-key key this-element)))))
+
+(defmacro if-not-mumble-remove-from-end ()
+  `(mumble-remove-from-end
+    (not (funcall predicate (apply-key key this-element)))))
+
+;;; LIST-REMOVE-MACRO does not include (removes) each element that satisfies
+;;; the predicate.
+(defmacro list-remove-macro (pred reverse?)
+  `(let* ((sequence ,(if reverse?
+			 '(reverse (the list sequence))
+			 'sequence))
+	  (splice (list nil))
+	  (results (do ((index 0 (1+ index))
+			(before-start splice))
+		       ((= index (the fixnum start)) before-start)
+		     (declare (fixnum index))
+		     (setq splice
+			   (cdr (rplacd splice (list (pop sequence))))))))
+     (do ((index start (1+ index))
+	  (this-element)
+	  (number-zapped 0))
+	 ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+	  (do ((index index (1+ index)))
+	      ((null sequence)
+	       ,(if reverse?
+		    '(nreverse (the list (cdr results)))
+		    '(cdr results)))
+	    (declare (fixnum index))
+	    (setq splice (cdr (rplacd splice (list (pop sequence)))))))
+       (declare (fixnum index number-zapped))
+       (setq this-element (pop sequence))
+       (if ,pred
+	   (setq number-zapped (1+ number-zapped))
+	   (setq splice (cdr (rplacd splice (list this-element))))))))
+
+(defmacro list-remove (pred)
+  `(list-remove-macro ,pred nil))
+
+(defmacro list-remove-from-end (pred)
+  `(list-remove-macro ,pred t))
+
+(defmacro normal-list-remove ()
+  `(list-remove
+    (if test-not
+	(not (funcall test-not item (apply-key key this-element)))
+	(funcall test item (apply-key key this-element)))))
+
+(defmacro normal-list-remove-from-end ()
+  `(list-remove-from-end
+    (if test-not
+	(not (funcall test-not item (apply-key key this-element)))
+	(funcall test item (apply-key key this-element)))))
+
+(defmacro if-list-remove ()
+  `(list-remove
+    (funcall predicate (apply-key key this-element))))
+
+(defmacro if-list-remove-from-end ()
+  `(list-remove-from-end
+    (funcall predicate (apply-key key this-element))))
+
+(defmacro if-not-list-remove ()
+  `(list-remove
+    (not (funcall predicate (apply-key key this-element)))))
+
+(defmacro if-not-list-remove-from-end ()
+  `(list-remove-from-end
+    (not (funcall predicate (apply-key key this-element)))))
+
+)
+
+(defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
+		end count key)
+  "Returns a copy of SEQUENCE with elements satisfying the test (default is
+   EQL) with ITEM removed."
+  (declare (fixnum start))
+  (let* ((length (length sequence))
+	 (end (or end length))
+	 (count (or count most-positive-fixnum)))
+    (declare (type index length end)
+	     (fixnum count))
+    (seq-dispatch sequence
+		  (if from-end
+		      (normal-list-remove-from-end)
+		      (normal-list-remove))
+		  (if from-end
+		      (normal-mumble-remove-from-end)
+		      (normal-mumble-remove)))))
+
+(defun remove-if (predicate sequence &key from-end (start 0) end count key)
+  "Returns a copy of sequence with elements such that predicate(element)
+   is non-null are removed"
+  (declare (fixnum start))
+  (let* ((length (length sequence))
+	 (end (or end length))
+	 (count (or count most-positive-fixnum)))
+    (declare (type index length end)
+	     (fixnum count))
+    (seq-dispatch sequence
+		  (if from-end
+		      (if-list-remove-from-end)
+		      (if-list-remove))
+		  (if from-end
+		      (if-mumble-remove-from-end)
+		      (if-mumble-remove)))))
+
+(defun remove-if-not (predicate sequence &key from-end (start 0) end count key)
+  "Returns a copy of sequence with elements such that predicate(element)
+   is null are removed"
+  (declare (fixnum start))
+  (let* ((length (length sequence))
+	 (end (or end length))
+	 (count (or count most-positive-fixnum)))
+    (declare (type index length end)
+	     (fixnum count))
+    (seq-dispatch sequence
+		  (if from-end
+		      (if-not-list-remove-from-end)
+		      (if-not-list-remove))
+		  (if from-end
+		      (if-not-mumble-remove-from-end)
+		      (if-not-mumble-remove)))))
+
+
+;;; Remove-Duplicates:
+     
+;;; Remove duplicates from a list. If from-end, remove the later duplicates,
+;;; not the earlier ones. Thus if we check from-end we don't copy an item
+;;; if we look into the already copied structure (from after :start) and see
+;;; the item. If we check from beginning we check into the rest of the 
+;;; original list up to the :end marker (this we have to do by running a
+;;; do loop down the list that far and using our test.
+(defun list-remove-duplicates* (list test test-not start end key from-end)
+  (declare (fixnum start))
+  (let* ((result (list ())) ; Put a marker on the beginning to splice with.
+	 (splice result)
+	 (current list))
+    (do ((index 0 (1+ index)))
+	((= index start))
+      (declare (fixnum index))
+      (setq splice (cdr (rplacd splice (list (car current)))))
+      (setq current (cdr current)))
+    (do ((index 0 (1+ index)))
+	((or (and end (= index (the fixnum end)))
+	     (atom current)))
+      (declare (fixnum index))
+      (if (or (and from-end 
+		   (not (member (apply-key key (car current))
+				(nthcdr (1+ start) result)
+				:test test
+				:test-not test-not
+				:key key)))
+	      (and (not from-end)
+		   (not (do ((it (apply-key key (car current)))
+			     (l (cdr current) (cdr l))
+			     (i (1+ index) (1+ i)))
+			    ((or (atom l) (and end (= i (the fixnum end))))
+			     ())
+			  (declare (fixnum i))
+			  (if (if test-not
+				  (not (funcall test-not it (apply-key key (car l))))
+				  (funcall test it (apply-key key (car l))))
+			      (return t))))))
+	  (setq splice (cdr (rplacd splice (list (car current))))))
+      (setq current (cdr current)))
+    (do ()
+	((atom current))
+      (setq splice (cdr (rplacd splice (list (car current)))))
+      (setq current (cdr current)))
+    (cdr result)))
+
+
+
+(defun vector-remove-duplicates* (vector test test-not start end key from-end
+					 &optional (length (length vector)))
+  (declare (vector vector) (fixnum start length))
+  (when (null end) (setf end (length vector)))
+  (let ((result (make-sequence-like vector length))
+	(index 0)
+	(jndex start))
+    (declare (fixnum index jndex))
+    (do ()
+	((= index start))
+      (setf (aref result index) (aref vector index))
+      (setq index (1+ index)))
+    (do ((elt))
+	((= index end))
+      (setq elt (aref vector index))
+      (unless (or (and from-end
+		        (position (apply-key key elt) result :start start
+			   :end jndex :test test :test-not test-not :key key))
+		  (and (not from-end)
+		        (position (apply-key key elt) vector :start (1+ index)
+			   :end end :test test :test-not test-not :key key)))
+	(setf (aref result jndex) elt)
+	(setq jndex (1+ jndex)))
+      (setq index (1+ index)))
+    (do ()
+	((= index length))
+      (setf (aref result jndex) (aref vector index))
+      (setq index (1+ index))
+      (setq jndex (1+ jndex)))
+    (shrink-vector result jndex)))
+
+
+(defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) from-end
+				   end key)
+  "The elements of Sequence are compared pairwise, and if any two match,
+   the one occuring earlier is discarded, unless FROM-END is true, in
+   which case the one later in the sequence is discarded.  The resulting
+   sequence is returned.
+
+   The :TEST-NOT argument is depreciated."
+  (declare (fixnum start))
+  (seq-dispatch sequence
+		(if sequence
+		    (list-remove-duplicates* sequence test test-not
+					      start end key from-end))
+		(vector-remove-duplicates* sequence test test-not
+					    start end key from-end)))
+
+
+
+;;; Delete-Duplicates:
+
+
+(defun list-delete-duplicates* (list test test-not key from-end start end)
+  (declare (fixnum start))
+  (let ((handle (cons nil list)))
+    (do ((current (nthcdr start list) (cdr current))
+	 (previous (nthcdr start handle))
+	 (index start (1+ index)))
+	((or (and end (= index (the fixnum end))) (null current))
+	 (cdr handle))
+      (declare (fixnum index))
+      (if (do ((x (if from-end 
+		      (nthcdr (1+ start) handle)
+		      (cdr current))
+		  (cdr x))
+	       (i (1+ index) (1+ i)))
+	      ((or (null x)
+		   (and (not from-end) end (= i (the fixnum end)))
+		   (eq x current))
+	       nil)
+	    (declare (fixnum i))
+	    (if (if test-not
+		    (not (funcall test-not 
+				  (apply-key key (car current))
+				  (apply-key key (car x))))
+		    (funcall test 
+			     (apply-key key (car current)) 
+			     (apply-key key (car x))))
+		(return t)))
+	  (rplacd previous (cdr current))
+	  (setq previous (cdr previous))))))
+
+
+(defun vector-delete-duplicates* (vector test test-not key from-end start end 
+					 &optional (length (length vector)))
+  (declare (vector vector) (fixnum start length))
+  (when (null end) (setf end (length vector)))
+  (do ((index start (1+ index))
+       (jndex start))
+      ((= index end)
+       (do ((index index (1+ index))		; copy the rest of the vector
+	    (jndex jndex (1+ jndex)))
+	   ((= index length)
+	    (shrink-vector vector jndex)
+	    vector)
+	 (setf (aref vector jndex) (aref vector index))))
+    (declare (fixnum index jndex))
+    (setf (aref vector jndex) (aref vector index))
+    (unless (position (apply-key key (aref vector index)) vector :key key
+		      :start (if from-end start (1+ index)) :test test
+		      :end (if from-end jndex end) :test-not test-not)
+      (setq jndex (1+ jndex)))))
+
+
+(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end
+			    end key)
+  "The elements of Sequence are examined, and if any two match, one is
+   discarded.  The resulting sequence, which may be formed by destroying the
+   given sequence, is returned.
+
+   The :TEST-NOT argument is depreciated."
+  (seq-dispatch sequence
+    (if sequence
+	(list-delete-duplicates* sequence test test-not key from-end start end))
+  (vector-delete-duplicates* sequence test test-not key from-end start end)))
+
+(defun list-substitute* (pred new list start end count key test test-not old)
+  (declare (fixnum start end count))
+  (let* ((result (list nil))
+	 elt
+	 (splice result)
+	 (list list))           ; Get a local list for a stepper.
+    (do ((index 0 (1+ index)))
+	((= index start))
+      (declare (fixnum index))
+      (setq splice (cdr (rplacd splice (list (car list)))))
+      (setq list (cdr list)))
+    (do ((index start (1+ index)))
+	((or (= index end) (null list) (= count 0)))
+      (declare (fixnum index))
+      (setq elt (car list))
+      (setq splice
+	    (cdr (rplacd splice
+			 (list
+			  (cond
+			   ((case pred
+				   (normal
+				    (if test-not
+					(not 
+					 (funcall test-not old (apply-key key elt)))
+					(funcall test old (apply-key key elt))))
+				   (if (funcall test (apply-key key elt)))
+				   (if-not (not (funcall test (apply-key key elt)))))
+			    (setq count (1- count))
+			    new)
+				(t elt))))))
+      (setq list (cdr list)))
+    (do ()
+	((null list))
+      (setq splice (cdr (rplacd splice (list (car list)))))
+      (setq list (cdr list)))
+    (cdr result)))
+
+;;; Replace old with new in sequence moving from left to right by incrementer
+;;; on each pass through the loop. Called by all three substitute functions.
+(defun vector-substitute* (pred new sequence incrementer left right length
+			   start end count key test test-not old)
+  (declare (fixnum start count end incrementer right))
+  (let ((result (make-sequence-like sequence length))
+	(index left))
+    (declare (fixnum index))
+    (do ()
+	((= index start))
+      (setf (aref result index) (aref sequence index))
+      (setq index (+ index incrementer)))
+    (do ((elt))
+	((or (= index end) (= count 0)))
+      (setq elt (aref sequence index))
+      (setf (aref result index) 
+	    (cond ((case pred
+			  (normal
+			    (if test-not
+				(not (funcall test-not old (apply-key key elt)))
+				(funcall test old (apply-key key elt))))
+			  (if (funcall test (apply-key key elt)))
+			  (if-not (not (funcall test (apply-key key elt)))))
+		   (setq count (1- count))
+		   new)
+		  (t elt)))
+      (setq index (+ index incrementer)))
+    (do ()
+	((= index right))
+      (setf (aref result index) (aref sequence index))
+      (setq index (+ index incrementer)))
+    result))
+
+(eval-when (compile eval)
+
+
+(defmacro subst-dispatch (pred)
+ `(if (listp sequence)
+      (if from-end
+	  (nreverse (list-substitute* ,pred new (reverse sequence)
+				      (- (the fixnum length) (the fixnum end))
+				      (- (the fixnum length) (the fixnum start))
+				      count key test test-not old))
+	  (list-substitute* ,pred new sequence start end count key test test-not
+			    old))
+      (if from-end
+	  (vector-substitute* ,pred new sequence -1 (1- (the fixnum length))
+			      -1 length (1- (the fixnum end))
+			      (1- (the fixnum start)) count key test test-not old)
+	  (vector-substitute* ,pred new sequence 1 0 length length
+	   start end count key test test-not old))))
+
+)
+
+
+;;; Substitute:
+
+(defun substitute (new old sequence &key from-end (test #'eql) test-not
+		   (start 0) count end key)
+  "Returns a sequence of the same kind as Sequence with the same elements
+  except that all elements equal to Old are replaced with New.  See manual
+  for details."
+  (declare (fixnum start))
+  (let* ((length (length sequence))
+	 (end (or end length))
+	 (count (or count most-positive-fixnum)))
+    (declare (type index length end)
+	     (fixnum count))
+    (subst-dispatch 'normal)))
+
+
+;;; Substitute-If:
+
+(defun substitute-if (new test sequence &key from-end (start 0) end count key)
+  "Returns a sequence of the same kind as Sequence with the same elements
+  except that all elements satisfying the Test are replaced with New.  See
+  manual for details."
+  (declare (fixnum start))
+  (let* ((length (length sequence))
+	 (end (or end length))
+	 (count (or count most-positive-fixnum))
+	 test-not
+	 old)
+    (declare (type index length end)
+	     (fixnum count))
+    (subst-dispatch 'if)))
+  
+
+;;; Substitute-If-Not:
+
+(defun substitute-if-not (new test sequence &key from-end (start 0)
+			   end count key)
+  "Returns a sequence of the same kind as Sequence with the same elements
+  except that all elements not satisfying the Test are replaced with New.
+  See manual for details."
+  (declare (fixnum start))
+  (let* ((length (length sequence))
+	 (end (or end length))
+	 (count (or count most-positive-fixnum))
+	 test-not
+	 old)
+    (declare (type index length end)
+	     (fixnum count))
+    (subst-dispatch 'if-not)))
+
+
+
+;;; NSubstitute:
+
+(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not 
+		     end count key (start 0))
+  "Returns a sequence of the same kind as Sequence with the same elements
+  except that all elements equal to Old are replaced with New.  The Sequence
+  may be destroyed.  See manual for details."
+  (declare (fixnum start))
+  (let ((end (or end (length sequence)))
+	(count (or count most-positive-fixnum)))
+    (declare (fixnum count))
+    (if (listp sequence)
+	(if from-end
+	    (nreverse (nlist-substitute*
+		       new old (nreverse (the list sequence))
+		       test test-not start end count key))
+	    (nlist-substitute* new old sequence
+			       test test-not start end count key))
+	(if from-end
+	    (nvector-substitute* new old sequence -1
+				 test test-not (1- end) (1- start) count key)
+	    (nvector-substitute* new old sequence 1
+				 test test-not start end count key)))))
+
+(defun nlist-substitute* (new old sequence test test-not start end count key)
+  (declare (fixnum start count end))
+  (do ((list (nthcdr start sequence) (cdr list))
+       (index start (1+ index)))
+      ((or (= index end) (null list) (= count 0)) sequence)
+    (declare (fixnum index))
+    (when (if test-not
+	      (not (funcall test-not old (apply-key key (car list))))
+	      (funcall test old (apply-key key (car list))))
+      (rplaca list new)
+      (setq count (1- count)))))
+
+(defun nvector-substitute* (new old sequence incrementer
+			    test test-not start end count key)
+  (declare (fixnum start incrementer count end))
+  (do ((index start (+ index incrementer)))
+      ((or (= index end) (= count 0)) sequence)
+    (declare (fixnum index))
+    (when (if test-not
+	      (not (funcall test-not old (apply-key key (aref sequence index))))
+	      (funcall test old (apply-key key (aref sequence index))))
+      (setf (aref sequence index) new)
+      (setq count (1- count)))))
+
+
+;;; NSubstitute-If:
+
+(defun nsubstitute-if (new test sequence &key from-end (start 0) end count key)
+  "Returns a sequence of the same kind as Sequence with the same elements
+   except that all elements satisfying the Test are replaced with New.  The
+   Sequence may be destroyed.  See manual for details."
+  (declare (fixnum start))
+  (let ((end (or end (length sequence)))
+	(count (or count most-positive-fixnum)))
+    (declare (fixnum end count))
+    (if (listp sequence)
+	(if from-end
+	    (nreverse (nlist-substitute-if*
+		       new test (nreverse (the list sequence))
+		       start end count key))
+	    (nlist-substitute-if* new test sequence
+				  start end count key))
+	(if from-end
+	    (nvector-substitute-if* new test sequence -1
+				    (1- end) (1- start) count key)
+	    (nvector-substitute-if* new test sequence 1
+				    start end count key)))))
+
+(defun nlist-substitute-if* (new test sequence start end count key)
+  (declare (fixnum end))
+  (do ((list (nthcdr start sequence) (cdr list))
+       (index start (1+ index)))
+      ((or (= index end) (null list) (= count 0)) sequence)
+    (when (funcall test (apply-key key (car list)))
+      (rplaca list new)
+      (setq count (1- count)))))
+
+(defun nvector-substitute-if* (new test sequence incrementer
+			       start end count key)
+  (do ((index start (+ index incrementer)))
+      ((or (= index end) (= count 0)) sequence)
+    (when (funcall test (apply-key key (aref sequence index)))
+      (setf (aref sequence index) new)
+      (setq count (1- count)))))
+
+
+;;; NSubstitute-If-Not:
+
+(defun nsubstitute-if-not (new test sequence &key from-end (start 0)
+			       end count key)
+  "Returns a sequence of the same kind as Sequence with the same elements
+   except that all elements not satisfying the Test are replaced with New.
+   The Sequence may be destroyed.  See manual for details."
+  (declare (fixnum start))
+  (let ((end (or end (length sequence)))
+	(count (or count most-positive-fixnum)))
+    (declare (fixnum end count))
+    (if (listp sequence)
+	(if from-end
+	    (nreverse (nlist-substitute-if-not*
+		       new test (nreverse (the list sequence))
+		       start end count key))
+	    (nlist-substitute-if-not* new test sequence
+				      start end count key))
+	(if from-end
+	    (nvector-substitute-if-not* new test sequence -1
+					(1- end) (1- start) count key)
+	    (nvector-substitute-if-not* new test sequence 1
+					start end count key)))))
+
+(defun nlist-substitute-if-not* (new test sequence start end count key)
+  (declare (fixnum end))
+  (do ((list (nthcdr start sequence) (cdr list))
+       (index start (1+ index)))
+      ((or (= index end) (null list) (= count 0)) sequence)
+    (when (not (funcall test (apply-key key (car list))))
+      (rplaca list new)
+      (setq count (1- count)))))
+
+(defun nvector-substitute-if-not* (new test sequence incrementer
+				   start end count key)
+  (do ((index start (+ index incrementer)))
+      ((or (= index end) (= count 0)) sequence)
+    (when (not (funcall test (apply-key key (aref sequence index))))
+      (setf (aref sequence index) new)
+      (setq count (1- count)))))
+
+
+;;; Locater macros used by FIND and POSITION.
+
+(eval-when (compile eval)
+
+(defmacro vector-locater-macro (sequence body-form return-type)
+  `(let ((incrementer (if from-end -1 1))
+	 (start (if from-end (1- (the fixnum end)) start))
+	 (end (if from-end (1- (the fixnum start)) end)))
+     (declare (fixnum start end incrementer))
+     (do ((index start (+ index incrementer))
+	  ,@(case return-type (:position nil) (:element '(current))))
+	 ((= index end) ())
+       (declare (fixnum index))
+       ,@(case return-type
+	   (:position nil)
+	   (:element `((setf current (aref ,sequence index)))))
+       ,body-form)))
+
+(defmacro locater-test-not (item sequence seq-type return-type)
+  (let ((seq-ref (case return-type
+		   (:position
+		    (case seq-type
+		      (:vector `(aref ,sequence index))
+		      (:list `(pop ,sequence))))
+		   (:element 'current)))
+	(return (case return-type
+		  (:position 'index)
+		  (:element 'current))))
+    `(if test-not
+	 (if (not (funcall test-not ,item (apply-key key ,seq-ref)))
+	     (return ,return))
+	 (if (funcall test ,item (apply-key key ,seq-ref))
+	     (return ,return)))))
+
+(defmacro vector-locater (item sequence return-type)
+  `(vector-locater-macro ,sequence
+			 (locater-test-not ,item ,sequence :vector ,return-type)
+			 ,return-type))
+
+(defmacro locater-if-test (test sequence seq-type return-type sense)
+  (let ((seq-ref (case return-type
+		   (:position
+		    (case seq-type
+		      (:vector `(aref ,sequence index))
+		      (:list `(pop ,sequence))))
+		   (:element 'current)))
+	(return (case return-type
+		  (:position 'index)
+		  (:element 'current))))
+    (if sense
+	`(if (funcall ,test (apply-key key ,seq-ref))
+	     (return ,return))
+	`(if (not (funcall ,test (apply-key key ,seq-ref)))
+	     (return ,return)))))
+
+(defmacro vector-locater-if-macro (test sequence return-type sense)
+  `(vector-locater-macro ,sequence
+			 (locater-if-test ,test ,sequence :vector ,return-type ,sense)
+			 ,return-type))
+
+(defmacro vector-locater-if (test sequence return-type)
+  `(vector-locater-if-macro ,test ,sequence ,return-type t))
+
+(defmacro vector-locater-if-not (test sequence return-type)
+  `(vector-locater-if-macro ,test ,sequence ,return-type nil))
+
+
+(defmacro list-locater-macro (sequence body-form return-type)
+  `(if from-end
+       (do ((sequence (nthcdr (- (the fixnum (length sequence))
+				 (the fixnum end))
+			      (reverse (the list ,sequence))))
+	    (index (1- (the fixnum end)) (1- index))
+	    (terminus (1- (the fixnum start)))
+	    ,@(case return-type (:position nil) (:element '(current))))
+	   ((or (= index terminus) (null sequence)) ())
+	 (declare (fixnum index terminus))
+	 ,@(case return-type
+	     (:position nil)
+	     (:element `((setf current (pop ,sequence)))))
+	 ,body-form)
+       (do ((sequence (nthcdr start ,sequence))
+	    (index start (1+ index))
+	    ,@(case return-type (:position nil) (:element '(current))))
+	   ((or (= index (the fixnum end)) (null sequence)) ())
+	 (declare (fixnum index))
+	 ,@(case return-type
+	     (:position nil)
+	     (:element `((setf current (pop ,sequence)))))
+	 ,body-form)))
+
+(defmacro list-locater (item sequence return-type)
+  `(list-locater-macro ,sequence
+		       (locater-test-not ,item ,sequence :list ,return-type)
+		       ,return-type))
+
+(defmacro list-locater-if-macro (test sequence return-type sense)
+  `(list-locater-macro ,sequence
+		       (locater-if-test ,test ,sequence :list ,return-type ,sense)
+		       ,return-type))
+
+(defmacro list-locater-if (test sequence return-type)
+  `(list-locater-if-macro ,test ,sequence ,return-type t))
+
+(defmacro list-locater-if-not (test sequence return-type)
+  `(list-locater-if-macro ,test ,sequence ,return-type nil))
+
+) ; eval-when
+
+
+;;; Position:
+
+(eval-when (compile eval)
+
+(defmacro vector-position (item sequence)
+  `(vector-locater ,item ,sequence :position))
+
+(defmacro list-position (item sequence)
+  `(list-locater ,item ,sequence :position))
+
+) ; eval-when
+
+
+;;; POSITION cannot default end to the length of sequence since it is not
+;;; an error to supply nil for its value.  We must test for end being nil
+;;; in the body of the function, and this is actually done in the support
+;;; routines for other reasons (see below).
+(defun position (item sequence &key from-end (test #'eql) test-not (start 0)
+		  end key)
+  "Returns the zero-origin index of the first element in SEQUENCE
+   satisfying the test (default is EQL) with the given ITEM"
+  (seq-dispatch sequence
+    (list-position* item sequence from-end test test-not start end key)
+    (vector-position* item sequence from-end test test-not start end key)))
+
+
+;;; The support routines for SUBSEQ are used by compiler transforms, so we
+;;; worry about dealing with end being supplied as or defaulting to nil
+;;; at this level.
+
+(defun list-position* (item sequence from-end test test-not start end key)
+  (declare (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (list-position item sequence))
+
+(defun vector-position* (item sequence from-end test test-not start end key)
+  (declare (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (vector-position item sequence))
+
+
+;;; Position-if:
+
+(eval-when (compile eval)
+
+(defmacro vector-position-if (test sequence)
+  `(vector-locater-if ,test ,sequence :position))
+
+
+(defmacro list-position-if (test sequence)
+  `(list-locater-if ,test ,sequence :position))
+
+)
+
+(defun position-if (test sequence &key from-end (start 0) key end)
+  "Returns the zero-origin index of the first element satisfying test(el)"
+  (declare (fixnum start))
+  (let ((end (or end (length sequence))))
+    (declare (type index end))
+    (seq-dispatch sequence
+		  (list-position-if test sequence)
+		  (vector-position-if test sequence))))
+
+
+;;; Position-if-not:
+
+(eval-when (compile eval)
+
+(defmacro vector-position-if-not (test sequence)
+  `(vector-locater-if-not ,test ,sequence :position))
+
+(defmacro list-position-if-not (test sequence)
+  `(list-locater-if-not ,test ,sequence :position))
+
+)
+
+(defun position-if-not (test sequence &key from-end (start 0) key end)
+  "Returns the zero-origin index of the first element not satisfying test(el)"
+  (declare (fixnum start))
+  (let ((end (or end (length sequence))))
+    (declare (type index end))
+    (seq-dispatch sequence
+		  (list-position-if-not test sequence)
+		  (vector-position-if-not test sequence))))
+
+
+;;; Find:
+
+(eval-when (compile eval)
+
+(defmacro vector-find (item sequence)
+  `(vector-locater ,item ,sequence :element))
+
+(defmacro list-find (item sequence)
+  `(list-locater ,item ,sequence :element))
+
+)
+
+;;; FIND cannot default end to the length of sequence since it is not
+;;; an error to supply nil for its value.  We must test for end being nil
+;;; in the body of the function, and this is actually done in the support
+;;; routines for other reasons (see above).
+(defun find (item sequence &key from-end (test #'eql) test-not (start 0)
+	       end key)
+  "Returns the first element in SEQUENCE satisfying the test (default
+   is EQL) with the given ITEM"
+  (declare (fixnum start))
+  (seq-dispatch sequence
+    (list-find* item sequence from-end test test-not start end key)
+    (vector-find* item sequence from-end test test-not start end key)))
+
+
+;;; The support routines for FIND are used by compiler transforms, so we
+;;; worry about dealing with end being supplied as or defaulting to nil
+;;; at this level.
+
+(defun list-find* (item sequence from-end test test-not start end key)
+  (when (null end) (setf end (length sequence)))
+  (list-find item sequence))
+
+(defun vector-find* (item sequence from-end test test-not start end key)
+  (when (null end) (setf end (length sequence)))
+  (vector-find item sequence))
+
+
+;;; Find-if:
+
+(eval-when (compile eval)
+
+(defmacro vector-find-if (test sequence)
+  `(vector-locater-if ,test ,sequence :element))
+
+(defmacro list-find-if (test sequence)
+  `(list-locater-if ,test ,sequence :element))
+
+)
+
+(defun find-if (test sequence &key from-end (start 0) end key)
+  "Returns the zero-origin index of the first element satisfying the test."
+  (declare (fixnum start))
+  (let ((end (or end (length sequence))))
+    (declare (type index end))
+    (seq-dispatch sequence
+		  (list-find-if test sequence)
+		  (vector-find-if test sequence))))
+
+
+;;; Find-if-not:
+
+(eval-when (compile eval)
+
+(defmacro vector-find-if-not (test sequence)
+  `(vector-locater-if-not ,test ,sequence :element))
+
+(defmacro list-find-if-not (test sequence)
+  `(list-locater-if-not ,test ,sequence :element))
+
+)
+
+(defun find-if-not (test sequence &key from-end (start 0) end key)
+  "Returns the zero-origin index of the first element not satisfying the test."
+  (declare (fixnum start))
+  (let ((end (or end (length sequence))))
+    (declare (type index end))
+    (seq-dispatch sequence
+		  (list-find-if-not test sequence)
+		  (vector-find-if-not test sequence))))
+
+
+;;; Count:
+
+(eval-when (compile eval)
+
+(defmacro vector-count (item sequence)
+  `(do ((index start (1+ index))
+	(count 0))
+       ((= index (the fixnum end)) count)
+     (declare (fixnum index count))
+     (if test-not
+	 (unless (funcall test-not ,item
+			  (apply-key key (aref ,sequence index)))
+	   (setq count (1+ count)))
+	 (when (funcall test ,item (apply-key key (aref ,sequence index)))
+	   (setq count (1+ count))))))
+
+(defmacro list-count (item sequence)
+  `(do ((sequence (nthcdr start ,sequence))
+	(index start (1+ index))
+	(count 0))
+       ((or (= index (the fixnum end)) (null sequence)) count)
+     (declare (fixnum index count))
+     (if test-not
+	 (unless (funcall test-not ,item (apply-key key (pop sequence)))
+	   (setq count (1+ count)))
+	 (when (funcall test ,item (apply-key key (pop sequence)))
+	   (setq count (1+ count))))))
+
+)
+
+(defun count (item sequence &key from-end (test #'eql) test-not (start 0)
+		end key)
+  "Returns the number of elements in SEQUENCE satisfying a test with ITEM,
+   which defaults to EQL."
+  (declare (ignore from-end) (fixnum start))
+  (let ((end (or end (length sequence))))
+    (declare (type index end))
+    (seq-dispatch sequence
+		  (list-count item sequence)
+		  (vector-count item sequence))))
+
+
+;;; Count-if:
+
+(eval-when (compile eval)
+
+(defmacro vector-count-if (predicate sequence)
+  `(do ((index start (1+ index))
+	(count 0))
+       ((= index (the fixnum end)) count)
+     (declare (fixnum index count))
+     (if (funcall ,predicate (apply-key key (aref ,sequence index)))
+	 (setq count (1+ count)))))
+
+(defmacro list-count-if (predicate sequence)
+  `(do ((sequence (nthcdr start ,sequence))
+	(index start (1+ index))
+	(count 0))
+       ((or (= index (the fixnum end)) (null sequence)) count)
+     (declare (fixnum index count))
+     (if (funcall ,predicate (apply-key key (pop sequence)))
+	 (setq count (1+ count)))))
+
+)
+
+(defun count-if (test sequence &key from-end (start 0) end key)
+  "Returns the number of elements in SEQUENCE satisfying TEST(el)."
+  (declare (ignore from-end) (fixnum start))
+  (let ((end (or end (length sequence))))
+    (declare (type index end))
+    (seq-dispatch sequence
+		  (list-count-if test sequence)
+		  (vector-count-if test sequence))))
+
+
+;;; Count-if-not:
+
+(eval-when (compile eval)
+
+(defmacro vector-count-if-not (predicate sequence)
+  `(do ((index start (1+ index))
+	(count 0))
+       ((= index (the fixnum end)) count)
+     (declare (fixnum index count))
+     (if (not (funcall ,predicate (apply-key key (aref ,sequence index))))
+	 (setq count (1+ count)))))
+
+(defmacro list-count-if-not (predicate sequence)
+  `(do ((sequence (nthcdr start ,sequence))
+	(index start (1+ index))
+	(count 0))
+       ((or (= index (the fixnum end)) (null sequence)) count)
+     (declare (fixnum index count))
+     (if (not (funcall ,predicate (apply-key key (pop sequence))))
+	 (setq count (1+ count)))))
+
+)
+
+(defun count-if-not (test sequence &key from-end (start 0) end key)
+  "Returns the number of elements in SEQUENCE not satisfying TEST(el)."
+  (declare (ignore from-end) (fixnum start))
+  (let ((end (or end (length sequence))))
+    (declare (type index end))
+    (seq-dispatch sequence
+		  (list-count-if-not test sequence)
+		  (vector-count-if-not test sequence))))
+
+
+;;; Mismatch utilities:
+
+(eval-when (compile eval)
+
+
+(defmacro match-vars (&rest body)
+  `(let ((inc (if from-end -1 1))
+	 (start1 (if from-end (1- (the fixnum end1)) start1))
+	 (start2 (if from-end (1- (the fixnum end2)) start2))
+	 (end1 (if from-end (1- (the fixnum start1)) end1))
+	 (end2 (if from-end (1- (the fixnum start2)) end2)))
+     (declare (fixnum inc start1 start2 end1 end2))
+     ,@body))
+
+(defmacro matchify-list ((sequence start length end) &body body)
+  (declare (ignore end)) ;; ### Should END be used below?
+  `(let ((,sequence (if from-end
+			(nthcdr (- (the fixnum ,length) (the fixnum ,start) 1)
+				(reverse (the list ,sequence)))
+			(nthcdr ,start ,sequence))))
+     (declare (type list ,sequence))
+     ,@body))
+
+)
+
+;;; Mismatch:
+
+(eval-when (compile eval)
+
+(defmacro if-mismatch (elt1 elt2)
+  `(cond ((= (the fixnum index1) (the fixnum end1))
+	  (return (if (= (the fixnum index2) (the fixnum end2))
+		      nil
+		      (if from-end
+			  (1+ (the fixnum index1))
+			  (the fixnum index1)))))
+	 ((= (the fixnum index2) (the fixnum end2))
+	  (return (if from-end (1+ (the fixnum index1)) index1)))
+	 (test-not
+	  (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
+	      (return (if from-end (1+ (the fixnum index1)) index1))))
+	 (t (if (not (funcall test (apply-key key ,elt1)
+			      (apply-key key ,elt2)))
+		(return (if from-end (1+ (the fixnum index1)) index1))))))
+
+(defmacro mumble-mumble-mismatch ()
+  `(do ((index1 start1 (+ index1 (the fixnum inc)))
+	(index2 start2 (+ index2 (the fixnum inc))))
+       (())
+     (declare (fixnum index1 index2))
+     (if-mismatch (aref sequence1 index1) (aref sequence2 index2))))
+
+(defmacro mumble-list-mismatch ()
+  `(do ((index1 start1 (+ index1 (the fixnum inc)))
+	(index2 start2 (+ index2 (the fixnum inc))))
+       (())
+     (declare (fixnum index1 index2))
+     (if-mismatch (aref sequence1 index1) (pop sequence2))))
+
+(defmacro list-mumble-mismatch ()
+  `(do ((index1 start1 (+ index1 (the fixnum inc)))
+	(index2 start2 (+ index2 (the fixnum inc))))
+       (())
+     (declare (fixnum index1 index2))
+     (if-mismatch (pop sequence1) (aref sequence2 index2))))
+
+(defmacro list-list-mismatch ()
+  `(do ((sequence1 sequence1)
+	(sequence2 sequence2)
+	(index1 start1 (+ index1 (the fixnum inc)))
+	(index2 start2 (+ index2 (the fixnum inc))))
+       (())
+     (declare (fixnum index1 index2))
+     (if-mismatch (pop sequence1) (pop sequence2))))
+
+)
+
+(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not 
+			   (start1 0) end1 (start2 0) end2 key)
+  "The specified subsequences of Sequence1 and Sequence2 are compared
+   element-wise.  If they are of equal length and match in every element, the
+   result is Nil.  Otherwise, the result is a non-negative integer, the index
+   within Sequence1 of the leftmost position at which they fail to match; or,
+   if one is shorter than and a matching prefix of the other, the index within
+   Sequence1 beyond the last position tested is returned.  If a non-Nil
+   :From-End keyword argument is given, then one plus the index of the
+   rightmost position in which the sequences differ is returned."
+  (declare (fixnum start1 start2))
+  (let* ((length1 (length sequence1))
+	 (end1 (or end1 length1))
+	 (length2 (length sequence2))
+	 (end2 (or end2 length2)))
+    (declare (type index length1 end1 length2 end2))
+    (match-vars
+     (seq-dispatch sequence1
+       (matchify-list (sequence1 start1 length1 end1)
+	 (seq-dispatch sequence2
+	   (matchify-list (sequence2 start2 length2 end2)
+	     (list-list-mismatch))
+	   (list-mumble-mismatch)))
+       (seq-dispatch sequence2
+	 (matchify-list (sequence2 start2 length2 end2)
+	   (mumble-list-mismatch))
+	 (mumble-mumble-mismatch))))))
+
+
+;;; Search comparison functions:
+
+(eval-when (compile eval)
+
+;;; Compare two elements and return if they don't match:
+
+(defmacro compare-elements (elt1 elt2)
+  `(if test-not
+       (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
+	   (return nil)
+	   t)
+       (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
+	   (return nil)
+	   t)))
+
+(defmacro search-compare-list-list (main sub)
+  `(do ((main ,main (cdr main))
+	(jndex start1 (1+ jndex))
+	(sub (nthcdr start1 ,sub) (cdr sub)))
+       ((or (null main) (null sub) (= (the fixnum end1) jndex))
+	t)
+     (declare (fixnum jndex))
+     (compare-elements (car main) (car sub))))
+
+(defmacro search-compare-list-vector (main sub)
+  `(do ((main ,main (cdr main))
+	(index start1 (1+ index)))
+       ((or (null main) (= index (the fixnum end1))) t)
+     (declare (fixnum index))
+     (compare-elements (car main) (aref ,sub index))))
+
+(defmacro search-compare-vector-list (main sub index)
+  `(do ((sub (nthcdr start1 ,sub) (cdr sub))
+	(jndex start1 (1+ jndex))
+	(index ,index (1+ index)))
+       ((or (= (the fixnum end1) jndex) (null sub)) t)
+     (declare (fixnum jndex index))
+     (compare-elements (aref ,main index) (car sub))))
+
+(defmacro search-compare-vector-vector (main sub index)
+  `(do ((index ,index (1+ index))
+	(sub-index start1 (1+ sub-index)))
+       ((= sub-index (the fixnum end1)) t)
+     (declare (fixnum sub-index index))
+     (compare-elements (aref ,main index) (aref ,sub sub-index))))
+
+(defmacro search-compare (main-type main sub index)
+  (if (eq main-type 'list)
+      `(seq-dispatch ,sub
+		     (search-compare-list-list ,main ,sub)
+		     (search-compare-list-vector ,main ,sub))
+      `(seq-dispatch ,sub
+		     (search-compare-vector-list ,main ,sub ,index)
+		     (search-compare-vector-vector ,main ,sub ,index))))
+
+)
+
+(eval-when (compile eval)
+ 
+(defmacro list-search (main sub)
+  `(do ((main (nthcdr start2 ,main) (cdr main))
+	(index2 start2 (1+ index2))
+	(terminus (- (the fixnum end2)
+		     (the fixnum (- (the fixnum end1)
+				    (the fixnum start1)))))
+	(last-match ()))
+       ((> index2 terminus) last-match)
+     (declare (fixnum index2 terminus))
+     (if (search-compare list main ,sub index2)
+	 (if from-end
+	     (setq last-match index2)
+	     (return index2)))))
+
+
+(defmacro vector-search (main sub)
+  `(do ((index2 start2 (1+ index2))
+	(terminus (- (the fixnum end2)
+		     (the fixnum (- (the fixnum end1)
+				    (the fixnum start1)))))
+	(last-match ()))
+       ((> index2 terminus) last-match)
+     (declare (fixnum index2 terminus))
+     (if (search-compare vector ,main ,sub index2)
+	 (if from-end
+	     (setq last-match index2)
+	     (return index2)))))
+
+)
+
+
+(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not 
+		(start1 0) end1 (start2 0) end2 key)
+  "A search is conducted using EQL for the first subsequence of sequence2 
+   which element-wise matches sequence1.  If there is such a subsequence in 
+   sequence2, the index of the its leftmost element is returned; 
+   otherwise () is returned."
+  (declare (fixnum start1 start2))
+  (let ((end1 (or end1 (length sequence1)))
+	(end2 (or end2 (length sequence2))))
+    (seq-dispatch sequence2
+		  (list-search sequence2 sequence1)
+		  (vector-search sequence2 sequence1))))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/sort.lisp src-to-be/code/sort.lisp
--- src/code/sort.lisp	Fri Nov 27 23:17:04 1998
+++ src-to-be/code/sort.lisp	Thu Dec 17 08:59:37 1998
@@ -437,6 +437,9 @@
 	     (result (make-sequence-of-type result-type (+ length-1 length-2))))
 	(declare (vector vector-1 vector-2)
 		 (fixnum length-1 length-2))
+
+	#+high-security
+	(check-type-var result result-type)
 	(if (and (simple-vector-p result)
 		 (simple-vector-p vector-1)
 		 (simple-vector-p vector-2))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/sort.lisp~ src-to-be/code/sort.lisp~
--- src/code/sort.lisp~	Thu Jan  1 01:00:00 1970
+++ src-to-be/code/sort.lisp~	Fri Dec 11 16:27:16 1998
@@ -0,0 +1,453 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+<<<<<<< sort.lisp
+  "$Header: /home/pvaneynd/fakeroot/cvs2.cons.org//src/code/sort.lisp,v 1.7 1998/11/27 22:17:04 dtc Exp $")
+=======
+  "$Header: /home/CVS-cmucl/src/code/sort.lisp,v 1.7 1998/11/27 22:17:04 dtc Exp $")
+>>>>>>> 1.7
+;;;
+;;; **********************************************************************
+;;;
+;;; Sort functions for Spice Lisp 
+;;;   these functions are part of the standard spice lisp environment.  
+;;; 
+;;; Written by Jim Large 
+;;; Hacked on and maintained by Skef Wholey 
+;;; Rewritten by Bill Chiles
+;;;
+;;; *******************************************************************
+
+(in-package "LISP")
+
+(export '(sort stable-sort merge))
+
+
+
+(defun sort (sequence predicate &key key)
+  "Destructively sorts sequence.  Predicate should returns non-Nil if
+   Arg1 is to precede Arg2."
+  (typecase sequence
+    (simple-vector
+     (if (> (the fixnum (length (the simple-vector sequence))) 0)
+	 (sort-simple-vector sequence predicate key)
+	 sequence))
+    (list
+     (sort-list sequence predicate key))
+    (vector
+     (if (> (the fixnum (length sequence)) 0)
+	 (sort-vector sequence predicate key)
+	 sequence))
+    (t
+     (error 'simple-type-error
+	    :datum sequence
+	    :expected-type 'sequence
+	    :format-control "~S is not a sequence."
+	    :format-arguments (list sequence)))))
+
+
+
+;;; Sorting Vectors
+
+;;; Sorting is done with a heap sort.
+
+(eval-when (compile eval)
+
+;;; HEAPIFY, assuming both sons of root are heaps, percolates the root element
+;;; through the sons to form a heap at root.  Root and max are zero based
+;;; coordinates, but the heap algorithm only works on arrays indexed from 1
+;;; through N (not 0 through N-1); This is because a root at I has sons at 2*I
+;;; and 2*I+1 which does not work for a root at 0.  Because of this, boundaries,
+;;; roots, and termination are computed using 1..N indexes.
+
+(defmacro heapify (seq vector-ref root max pred key)
+  (let ((heap-root (gensym))   (heap-max (gensym))     (root-ele (gensym))
+	(root-key (gensym))    (heap-max/2 (gensym))   (heap-l-son (gensym))
+	(one-son (gensym))     (one-son-ele (gensym))  (one-son-key (gensym))
+	(r-son-ele (gensym))   (r-son-key (gensym))    (var-root (gensym)))
+    `(let* ((,var-root ,root) ; necessary to not clobber calling root var.
+	    (,heap-root (1+ ,root))
+	    (,heap-max (1+ ,max))
+	    (,root-ele (,vector-ref ,seq ,root))
+	    (,root-key (apply-key ,key ,root-ele))
+	    (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2)
+       (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2))
+       (loop
+	(if (> ,heap-root ,heap-max/2) (return))
+	(let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root)
+	       ;; l-son index in seq (0..N-1) is one less than heap computation
+	       (,one-son (1- ,heap-l-son))
+	       (,one-son-ele (,vector-ref ,seq ,one-son))
+	       (,one-son-key (apply-key ,key ,one-son-ele)))
+	  (declare (fixnum ,heap-l-son ,one-son))
+	  (if (< ,heap-l-son ,heap-max)
+	      ;; there is a right son.
+	      (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son))
+		     (,r-son-key (apply-key ,key ,r-son-ele)))
+		;; choose the greater of the two sons.
+		(when (funcall ,pred ,one-son-key ,r-son-key)
+		  (setf ,one-son ,heap-l-son)
+		  (setf ,one-son-ele ,r-son-ele)
+		  (setf ,one-son-key ,r-son-key))))
+	  ;; if greater son is less than root, then we've formed a heap again.
+	  (if (funcall ,pred ,one-son-key ,root-key) (return))
+	  ;; else put greater son at root and make greater son node be the root.
+	  (setf (,vector-ref ,seq ,var-root) ,one-son-ele)
+	  (setf ,heap-root (1+ ,one-son)) ; one plus to be in heap coordinates.
+	  (setf ,var-root ,one-son)))     ; actual index into vector for root ele.
+       ;; now really put percolated value into heap at the appropriate root node.
+       (setf (,vector-ref ,seq ,var-root) ,root-ele))))
+
+
+;;; BUILD-HEAP rearranges seq elements into a heap to start heap sorting.
+(defmacro build-heap (seq type len-1 pred key)
+  (let ((i (gensym)))
+    `(do ((,i (floor ,len-1 2) (1- ,i)))
+	 ((minusp ,i) ,seq)
+       (declare (fixnum ,i))
+       (heapify ,seq ,type ,i ,len-1 ,pred ,key))))
+
+) ; eval-when
+
+
+;;; Make simple-vector and miscellaneous vector sorting functions.
+(macrolet ((frob-rob (fun-name vector-ref)
+	     `(defun ,fun-name (seq pred key)
+		(let ((len-1 (1- (length (the vector seq)))))
+		  (declare (fixnum len-1))
+		  (build-heap seq ,vector-ref len-1 pred key)
+		  (do* ((i len-1 i-1)
+			(i-1 (1- i) (1- i-1)))
+		       ((zerop i) seq)
+		    (declare (fixnum i i-1))
+		    (rotatef (,vector-ref seq 0) (,vector-ref seq i))
+		    (heapify seq ,vector-ref 0 i-1 pred key))))))
+
+  (frob-rob sort-vector aref)
+
+  (frob-rob sort-simple-vector svref))
+
+
+
+;;;; Stable Sorting
+
+(defun stable-sort (sequence predicate &key key)
+  "Destructively sorts sequence.  Predicate should returns non-Nil if
+   Arg1 is to precede Arg2."
+  (typecase sequence
+    (simple-vector
+     (stable-sort-simple-vector sequence predicate key))
+    (list
+     (sort-list sequence predicate key))
+    (vector
+     (stable-sort-vector sequence predicate key))
+    (t
+     (error 'simple-type-error
+	    :datum sequence
+	    :expected-type 'sequence
+	    :format-control "~S is not a sequence."
+	    :format-arguments (list sequence)))))
+
+
+;;; Stable Sorting Lists
+
+
+;;; APPLY-PRED saves us a function call sometimes.
+(eval-when (compile eval)
+  (defmacro apply-pred (one two pred key)
+    `(if ,key
+	 (funcall ,pred (funcall ,key ,one)
+		  (funcall ,key  ,two))
+	 (funcall ,pred ,one ,two)))
+) ; eval-when
+
+
+;;; MERGE-LISTS*   originally written by Jim Large.
+;;; 		   modified to return a pointer to the end of the result
+;;; 		      and to not cons header each time its called.
+;;; It destructively merges list-1 with list-2.  In the resulting
+;;; list, elements of list-2 are guaranteed to come after equal elements
+;;; of list-1.
+(defun merge-lists* (list-1 list-2 pred key
+			    &optional (merge-lists-header (list :header)))
+  (do* ((result merge-lists-header)
+	(P result))                            ; P points to last cell of result
+       ((or (null list-1) (null list-2))       ; done when either list used up	
+	(if (null list-1)                      ; in which case, append the
+	    (rplacd p list-2)                  ;   other list
+	    (rplacd p list-1))
+	(do ((drag p lead)
+	     (lead (cdr p) (cdr lead)))
+	    ((null lead)
+	     (values (prog1 (cdr result)       ; return the result sans header
+			    (rplacd result nil)) ; (free memory, be careful)
+		     drag))))		       ; and return pointer to last element
+    (cond ((apply-pred (car list-2) (car list-1) pred key)
+	   (rplacd p list-2)           ; append the lesser list to last cell of
+	   (setq p (cdr p))            ;   result.  Note: test must bo done for
+	   (pop list-2))               ;   list-2 < list-1 so merge will be
+	  (T (rplacd p list-1)         ;   stable for list-1
+	     (setq p (cdr p))
+	     (pop list-1)))))
+
+
+;;; SORT-LIST uses a bottom up merge sort.  First a pass is made over
+;;; the list grabbing one element at a time and merging it with the next one
+;;; form pairs of sorted elements.  Then n is doubled, and elements are taken
+;;; in runs of two, merging one run with the next to form quadruples of sorted
+;;; elements.  This continues until n is large enough that the inner loop only
+;;; runs for one iteration; that is, there are only two runs that can be merged,
+;;; the first run starting at the beginning of the list, and the second being
+;;; the remaining elements.
+
+(defun sort-list (list pred key)
+  (let ((head (cons :header list))  ; head holds on to everything
+	(n 1)                       ; bottom-up size of lists to be merged
+	unsorted		    ; unsorted is the remaining list to be
+				    ;   broken into n size lists and merged
+	list-1			    ; list-1 is one length n list to be merged
+	last			    ; last points to the last visited cell
+	(merge-lists-header (list :header)))
+    (declare (fixnum n))
+    (loop
+     ;; start collecting runs of n at the first element
+     (setf unsorted (cdr head))
+     ;; tack on the first merge of two n-runs to the head holder
+     (setf last head)
+     (let ((n-1 (1- n)))
+       (declare (fixnum n-1))
+       (loop
+	(setf list-1 unsorted)
+	(let ((temp (nthcdr n-1 list-1))
+	      list-2)
+	  (cond (temp
+		 ;; there are enough elements for a second run
+		 (setf list-2 (cdr temp))
+		 (setf (cdr temp) nil)
+		 (setf temp (nthcdr n-1 list-2))
+		 (cond (temp
+			(setf unsorted (cdr temp))
+			(setf (cdr temp) nil))
+		       ;; the second run goes off the end of the list
+		       (t (setf unsorted nil)))
+		 (multiple-value-bind (merged-head merged-last)
+				      (merge-lists* list-1 list-2 pred key
+						    merge-lists-header)
+		   (setf (cdr last) merged-head)
+		   (setf last merged-last))
+		 (if (null unsorted) (return)))
+		;; if there is only one run, then tack it on to the end
+		(t (setf (cdr last) list-1)
+		   (return)))))
+       (setf n (ash n 1)) ; (+ n n)
+       ;; If the inner loop only executed once, then there were only enough
+       ;; elements for two runs given n, so all the elements have been merged
+       ;; into one list.  This may waste one outer iteration to realize.
+       (if (eq list-1 (cdr head))
+	   (return list-1))))))
+
+
+
+;;; Stable Sort Vectors
+
+;;; Stable sorting vectors is done with the same algorithm used for lists,
+;;; using a temporary vector to merge back and forth between it and the
+;;; given vector to sort.
+
+
+(eval-when (compile eval)
+
+;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
+;;;    start-1 (inclusive) ... end-1 (exclusive) and
+;;;    end-1 (inclusive) ... end-2 (exclusive),
+;;; and merges them into a target vector starting at index start-1.
+
+(defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
+					     pred key source-ref target-ref)
+  (let ((i (gensym))
+	(j (gensym))
+	(target-i (gensym)))
+    `(let ((,i ,start-1)
+	   (,j ,end-1) ; start-2
+	   (,target-i ,start-1))
+       (declare (fixnum ,i ,j ,target-i))
+       (loop
+	(cond ((= ,i ,end-1)
+	       (loop (if (= ,j ,end-2) (return))
+		     (setf (,target-ref ,target ,target-i)
+			   (,source-ref ,source ,j))
+		     (incf ,target-i)
+		     (incf ,j))
+	       (return))
+	      ((= ,j ,end-2)
+	       (loop (if (= ,i ,end-1) (return))
+		     (setf (,target-ref ,target ,target-i)
+			   (,source-ref ,source ,i))
+		     (incf ,target-i)
+		     (incf ,i))
+	       (return))
+	      ((apply-pred (,source-ref ,source ,j)
+			   (,source-ref ,source ,i)
+			   ,pred ,key)
+	       (setf (,target-ref ,target ,target-i)
+		     (,source-ref ,source ,j))
+	       (incf ,j))
+	      (t (setf (,target-ref ,target ,target-i)
+		       (,source-ref ,source ,i))
+		 (incf ,i)))
+	(incf ,target-i)))))
+
+
+;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but
+;;; it uses a temporary vector.  Direction determines whether we are merging
+;;; into the temporary (T) or back into the given vector (NIL).
+
+(defmacro vector-merge-sort (vector pred key vector-ref)
+  (let ((vector-len (gensym)) 		(n (gensym))
+	(direction (gensym)) 		(unsorted (gensym))
+	(start-1 (gensym)) 		(end-1 (gensym))
+	(end-2 (gensym))		(i (gensym))
+	(temp-vector (gensym)))
+    `(let* ((,vector-len (length (the vector ,vector)))
+	    (,n 1)         ; bottom-up size of contiguous runs to be merged
+	    (,direction t) ; t vector --> temp    nil temp --> vector
+	    (,temp-vector (make-array ,vector-len))
+	    (,unsorted 0)  ; unsorted..vector-len are the elements that need
+			   ; to be merged for a given n
+	    (,start-1 0))  ; one n-len subsequence to be merged with the next
+       (declare (fixnum ,vector-len ,n ,unsorted ,start-1)	
+		(type simple-vector ,temp-vector))
+       (loop
+	;; for each n, we start taking n-runs from the start of the vector
+	(setf ,unsorted 0)
+	(loop
+	 (setf ,start-1 ,unsorted)
+	 (let ((,end-1 (+ ,start-1 ,n)))
+	   (declare (fixnum ,end-1))
+	   (cond ((< ,end-1 ,vector-len)
+		  ;; there are enough elements for a second run
+		  (let ((,end-2 (+ ,end-1 ,n)))
+		    (declare (fixnum ,end-2))
+		    (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
+		    (setf ,unsorted ,end-2)
+		    (if ,direction
+			(stable-sort-merge-vectors*
+			 ,vector ,temp-vector
+			 ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
+			(stable-sort-merge-vectors*
+			 ,temp-vector ,vector
+			 ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
+		    (if (= ,unsorted ,vector-len) (return))))
+		 ;; if there is only one run, copy those elements to the end
+		 (t (if ,direction
+			(do ((,i ,start-1 (1+ ,i)))
+			    ((= ,i ,vector-len))
+			  (declare (fixnum ,i))
+			  (setf (svref ,temp-vector ,i)
+				(,vector-ref ,vector ,i)))
+			(do ((,i ,start-1 (1+ ,i)))
+			    ((= ,i ,vector-len))
+			  (declare (fixnum ,i))
+			  (setf (,vector-ref ,vector ,i)
+				(svref ,temp-vector ,i))))
+		    (return)))))
+	;; If the inner loop only executed once, then there were only enough
+	;; elements for two subsequences given n, so all the elements have
+	;; been merged into one list.  Start-1 will have remained 0 upon exit.
+	(when (zerop ,start-1)
+	  (if ,direction
+	      ;; if we just merged into the temporary, copy it all back
+	      ;; to the given vector.
+	      (dotimes (,i ,vector-len)
+		(setf (,vector-ref ,vector ,i)
+		      (svref ,temp-vector ,i))))
+	  (return ,vector))
+	(setf ,n (ash ,n 1)) ; (* 2 n)
+	(setf ,direction (not ,direction))))))
+
+) ; eval-when
+
+
+(defun stable-sort-simple-vector (vector pred key)
+  (declare (simple-vector vector))
+  (vector-merge-sort vector pred key svref))
+
+(defun stable-sort-vector (vector pred key)
+  (vector-merge-sort vector pred key aref))
+
+
+
+;;;; Merge
+
+(eval-when (compile eval)
+
+;;; MERGE-VECTORS returns a new vector which contains an interleaving
+;;; of the elements of vector-1 and vector-2.  Elements from vector-2 are
+;;; chosen only if they are strictly less than elements of vector-1,
+;;; (pred elt-2 elt-1), as specified in the manual.
+
+(defmacro merge-vectors (vector-1 length-1 vector-2 length-2
+			 result-vector pred key access)
+  (let ((result-i (gensym))
+	(i (gensym))
+	(j (gensym)))
+    `(let* ((,result-i 0)
+	    (,i 0)
+	    (,j 0))
+       (declare (fixnum ,result-i ,i ,j))
+       (loop
+	(cond ((= ,i ,length-1)
+	       (loop (if (= ,j ,length-2) (return))
+		     (setf (,access ,result-vector ,result-i)
+			   (,access ,vector-2 ,j))
+		     (incf ,result-i)
+		     (incf ,j))
+	       (return ,result-vector))
+	      ((= ,j ,length-2)
+	       (loop (if (= ,i ,length-1) (return))
+		     (setf (,access ,result-vector ,result-i)
+			   (,access ,vector-1 ,i))
+		     (incf ,result-i)
+		     (incf ,i))
+	       (return ,result-vector))
+	      ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
+			   ,pred ,key)
+	       (setf (,access ,result-vector ,result-i)
+		     (,access ,vector-2 ,j))
+	       (incf ,j))
+	      (t (setf (,access ,result-vector ,result-i)
+		       (,access ,vector-1 ,i))
+		 (incf ,i)))
+	(incf ,result-i)))))
+
+) ; eval-when
+
+(defun merge (result-type sequence1 sequence2 predicate &key key)
+  "The sequences Sequence1 and Sequence2 are destructively merged into
+   a sequence of type Result-Type using the Predicate to order the elements."
+  (if (eq result-type 'list)
+      (let ((result (merge-lists* (coerce sequence1 'list)
+				  (coerce sequence2 'list)
+				  predicate key)))
+	result)
+      (let* ((vector-1 (coerce sequence1 'vector))
+	     (vector-2 (coerce sequence2 'vector))
+	     (length-1 (length vector-1))
+	     (length-2 (length vector-2))
+	     (result (make-sequence-of-type result-type (+ length-1 length-2))))
+	(declare (vector vector-1 vector-2)
+		 (fixnum length-1 length-2))
+
+	#+high-security
+	(check-type-var result result-type)
+	(if (and (simple-vector-p result)
+		 (simple-vector-p vector-1)
+		 (simple-vector-p vector-2))
+	    (merge-vectors vector-1 length-1 vector-2 length-2
+			   result predicate key svref)
+	    (merge-vectors vector-1 length-1 vector-2 length-2
+			   result predicate key aref)))))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/stream.lisp src-to-be/code/stream.lisp
--- src/code/stream.lisp	Fri Jul 24 19:17:55 1998
+++ src-to-be/code/stream.lisp	Mon Nov  9 20:09:13 1998
@@ -180,6 +180,13 @@
 
 (defun input-stream-p (stream)
   "Returns non-nil if the given Stream can perform input operations."
+  (declare (type stream stream))
+
+  #+high-security
+  (when (synonym-stream-p stream)
+    (setf stream (symbol-value
+		  (synonym-stream-symbol stream))))
+  
   (and (lisp-stream-p stream)
        (not (eq (lisp-stream-in stream) #'closed-flame))
        (or (not (eq (lisp-stream-in stream) #'ill-in))
@@ -187,6 +194,13 @@
 
 (defun output-stream-p (stream)
   "Returns non-nil if the given Stream can perform output operations."
+  (declare (type stream stream))
+
+  #+high-security
+  (when (synonym-stream-p stream)
+    (setf stream (symbol-value
+		  (synonym-stream-symbol stream))))
+  
   (and (lisp-stream-p stream)
        (not (eq (lisp-stream-in stream) #'closed-flame))
        (or (not (eq (lisp-stream-out stream) #'ill-out))
@@ -253,6 +267,15 @@
     (let ((res (funcall (lisp-stream-misc stream) stream :file-position nil)))
       (when res (- res (- in-buffer-length (lisp-stream-in-index stream))))))))
 
+;;; declaration test functions
+
+#+high-security
+(defun stream-associated-with-file (stream)
+  "Tests if the stream is associated with a file"
+  (or (typep stream 'file-stream)
+      (and (synonym-stream-p stream)
+	   (typep (symbol-value (synonym-stream-symbol stream))
+		  'file-stream))))
 
 ;;; File-Length  --  Public
 ;;;
@@ -260,7 +283,12 @@
 ;;;
 (defun file-length (stream)
   "This function returns the length of the file that File-Stream is open to."
-  (declare (stream stream))
+  (declare (type (or file-stream synonym-stream) stream))
+
+  #+high-security
+  (check-type-var stream '(satisfies stream-associated-with-file)
+		  "A stream associated with a file")
+  
   (funcall (lisp-stream-misc stream) stream :file-length))
 
 
@@ -347,7 +375,9 @@
 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
 			    (eof-errorp t) eof-value recursive-p)
   "Peeks at the next character in the input Stream.  See manual for details."
-  (declare (ignore recursive-p))
+  (when recursive-p
+    (setf eof-errorp t))
+  
   (let ((stream (in-synonym-of stream)))
     (if (lisp-stream-p stream)
 	(let ((char (read-char stream eof-errorp eof-value)))
@@ -560,6 +590,19 @@
 (defun write-string (string &optional (stream *standard-output*)
 			    &key (start 0) (end (length (the vector string))))
   "Outputs the String to the given Stream."
+
+  #+high-security
+  (setf end (min end (length (the vector string))))
+  #+high-security
+  (setf start (max start 0))
+
+  #+high-security
+  (when (< end start)
+      (cerror "Continue with switched start and end ~s <-> ~s"
+	      "Write-string: start (~S) and end (~S) exchanged."
+	      start  end string)
+      (rotatef start end))
+    
   (write-string* string stream start end))
 
 (defun write-string* (string &optional (stream *standard-output*)
@@ -683,12 +726,28 @@
 				       (sout #'broadcast-sout)
 				       (misc #'broadcast-misc))
 			     (:print-function %print-broadcast-stream)
-			     (:constructor make-broadcast-stream (&rest streams)))
+			     (:constructor #-high-security-support
+					   make-broadcast-stream
+					   #+high-security-support
+					   %make-broadcast-stream (&rest streams)))
   ;; This is a list of all the streams we broadcast to.
   (streams () :type list :read-only t))
 
+#-high-security-support
 (setf (documentation 'make-broadcast-stream 'function)
  "Returns an ouput stream which sends its output to all of the given streams.")
+#+high-security-support
+(defun make-broadcast-stream (&rest streams)
+  "Returns an ouput stream which sends its output to all of the given streams."
+  (dolist (stream streams)    
+    (unless (or (and (synonym-stream-p stream)
+		     (output-stream-p (symbol-value
+				       (synonym-stream-symbol stream))))
+		(output-stream-p stream))
+      (error 'type-error
+	     :datum stream
+	     :expected-type '(satisfies output-stream-p))))
+  (apply #'%make-broadcast-stream streams))
 
 (defun %print-broadcast-stream (s stream d)
   (declare (ignore s d))
@@ -819,7 +878,10 @@
 		      (sout #'two-way-sout)
 		      (misc #'two-way-misc))
 	    (:print-function %print-two-way-stream)
-	    (:constructor make-two-way-stream (input-stream output-stream)))
+	    (:constructor #-high-security-support
+			  make-two-way-stream
+			  #+high-security-support
+			  %make-two-way-stream (input-stream output-stream)))
   ;; We read from this stream...
   (input-stream (required-argument) :type stream :read-only t)
   ;; And write to this one
@@ -831,9 +893,29 @@
 	  (two-way-stream-input-stream s)
 	  (two-way-stream-output-stream s)))
 
+#-high-security-support
 (setf (documentation 'make-two-way-stream 'function)
   "Returns a bidirectional stream which gets its input from Input-Stream and
    sends its output to Output-Stream.")
+#+high-security-support
+(defun make-two-way-stream (input-stream output-stream)
+  "Returns a bidirectional stream which gets its input from Input-Stream and
+   sends its output to Output-Stream."
+  (unless (or (and (synonym-stream-p output-stream)
+	 	   (output-stream-p (symbol-value
+				     (synonym-stream-symbol output-stream))))
+	      (output-stream-p output-stream))    
+    (error 'type-error 
+	   :datum output-stream
+	   :expected-type '(satisfies output-stream-p)))
+  (unless (or (and (synonym-stream-p input-stream)
+		   (input-stream-p (symbol-value
+				    (synonym-stream-symbol input-stream))))
+	      (input-stream-p input-stream))
+    (error 'type-error
+	   :datum input-stream
+	   :expected-type '(satisfies input-stream-p)))
+  (funcall #'%make-two-way-stream input-stream output-stream))
 
 (macrolet ((out-fun (name slot stream-method &rest args)
 	     `(defun ,name (stream ,@args)
@@ -897,7 +979,9 @@
 		      (misc #'concatenated-misc))
 	    (:print-function %print-concatenated-stream)
 	    (:constructor
-	     make-concatenated-stream (&rest streams &aux (current streams))))
+	     #-high-security-support make-concatenated-stream
+	     #+high-security-support %make-concatenated-stream 
+	         (&rest streams &aux (current streams))))
   ;; The car of this is the stream we are reading from now.
   current
   ;; This is a list of all the streams.  We need to remember them so that
@@ -909,10 +993,25 @@
   (format stream "#<Concatenated Stream, Streams = ~S>"
 	  (concatenated-stream-streams s)))
 
+#-high-security-support
 (setf (documentation 'make-concatenated-stream 'function)
   "Returns a stream which takes its input from each of the Streams in turn,
    going on to the next at EOF.")
 
+#+high-security-support
+(defun make-concatenated-stream (&rest streams)
+  "Returns a stream which takes its input from each of the Streams in turn,
+   going on to the next at EOF."
+  (dolist (stream streams)
+    (unless (or (and (synonym-stream-p stream)
+		     (input-stream-p (symbol-value
+				      (synonym-stream-symbol stream))))
+		(input-stream-p stream))    
+      (error 'type-error
+	     :datum stream
+	     :expected-type '(satisfies input-stream-p))))
+  (apply #'%make-concatenated-stream streams))
+
 (macrolet ((in-fun (name fun)
 	     `(defun ,name (stream eof-errorp eof-value)
 		(do ((current (concatenated-stream-current stream) (cdr current)))
@@ -1109,6 +1208,13 @@
   (declare (type string string)
 	   (type index start)
 	   (type (or index null) end))
+  
+  #+high-security
+  (when (> end (length string))
+    (cerror "Continue with end changed from ~s to ~s"
+	      "Write-string: end (~S) is larger then the length of the string (~S)"
+	      end (1- (length string))))
+
   (internal-make-string-input-stream (coerce string 'simple-string)
 				     start end))
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/sysmacs.lisp src-to-be/code/sysmacs.lisp
--- src/code/sysmacs.lisp	Tue Jul 28 08:56:32 1998
+++ src-to-be/code/sysmacs.lisp	Mon Nov  9 20:09:13 1998
@@ -97,6 +97,13 @@
        (cond ((null ,svar) *standard-input*)
 	     ((eq ,svar t) *terminal-io*)
 	     (T ,@(if check-type `((check-type ,svar ,check-type)))
+		#+high-security
+		(unless (input-stream-p ,svar)
+		  (error 'simple-type-error
+			 :datum ,svar
+			 :expected-type '(satisfies input-stream-p)
+			 :format-control "~S isn't an input stream"
+			 :format-arguments ,(list  svar)))		
 		,svar)))))
 
 (defmacro out-synonym-of (stream &optional check-type)
@@ -105,6 +112,13 @@
        (cond ((null ,svar) *standard-output*)
 	     ((eq ,svar t) *terminal-io*)
 	     (T ,@(if check-type `((check-type ,svar ,check-type)))
+		#+high-security
+		(unless (output-stream-p ,svar)
+		  (error 'simple-type-error
+			 :datum ,svar
+			 :expected-type '(satisfies output-stream-p)
+			 :format-control "~S isn't an output stream"
+			 :format-arguments ,(list  svar)))
 		,svar)))))
 
 ;;; With-Mumble-Stream calls the function in the given Slot of the
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/t/d1 src-to-be/code/t/d1
--- src/code/t/d1	Thu Jan  1 01:00:00 1970
+++ src-to-be/code/t/d1	Fri Oct 23 13:56:17 1998
@@ -0,0 +1,14 @@
+--- fd-stream.lisp	Mon Oct 12 16:43:40 1998
++++ ../../src-to-be/fd-stream.lisp	Mon Oct 12 10:18:54 1998
+@@ -1482,9 +1482,9 @@
+   (let ((tty (unix:unix-open "/dev/tty" unix:o_rdwr #o666)))
+     (if tty
+ 	(setf *tty*
+-	      (;#-high-security
++	      (#-high-security
+ 	       make-fd-stream
+-	       #+nil ;#+high-security
++	       #+high-security
+ 	       %make-fd-stream tty :name "the Terminal" :input t :output t
+ 			      :buffering :line :auto-close t))
+ 	(setf *tty* (make-two-way-stream *stdin* *stdout*))))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/t/fd-stream.lisp-diff src-to-be/code/t/fd-stream.lisp-diff
--- src/code/t/fd-stream.lisp-diff	Thu Jan  1 01:00:00 1970
+++ src-to-be/code/t/fd-stream.lisp-diff	Fri Oct 23 13:56:17 1998
@@ -0,0 +1,24 @@
+--- fd-stream.lisp~	Mon Oct 12 19:02:07 1998
++++ fd-stream.lisp	Tue Oct 13 00:01:30 1998
+@@ -276,7 +276,8 @@
+ 		      (:none character)
+ 		      (:line character)
+ 		      (:full character))
+-  (if (char= byte #\Newline)
++  (if (and (not (eq byte COMMON-LISP::*EOF*))
++           (char= byte #\Newline))
+       (setf (fd-stream-char-pos stream) 0)
+       (incf (fd-stream-char-pos stream)))
+   (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
+@@ -1456,9 +1457,9 @@
+   (setf *terminal-io* (make-synonym-stream '*tty*))
+   (setf *standard-output* (make-synonym-stream '*stdout*))
+   (setf *standard-input*
+-	(;#-high-security
++	(#-high-security
+ 	 make-two-way-stream
+-	 #+nil ;#+high-security
++	 #+high-security
+ 	 %make-two-way-stream (make-synonym-stream '*stdin*)
+ 			     *standard-output*))
+   (setf *error-output* (make-synonym-stream '*stderr*))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/t/macros.lisp-diff src-to-be/code/t/macros.lisp-diff
--- src/code/t/macros.lisp-diff	Thu Jan  1 01:00:00 1970
+++ src-to-be/code/t/macros.lisp-diff	Fri Oct 23 13:56:17 1998
@@ -0,0 +1,11 @@
+--- macros.lisp~	Mon Oct 12 19:43:42 1998
++++ macros.lisp	Mon Oct 12 21:57:40 1998
+@@ -1530,7 +1530,7 @@
+        (setqs nil)
+        (pairs pairs (cddr pairs)))
+       ((atom (cdr pairs))
+-       `(let ,(nreverse lets) (setq ,@(nreverse setqs) nil)))
++       `(let ,(nreverse lets) (setq ,@(nreverse setqs)) nil))
+     (let ((gen (gensym)))
+       (push `(,gen ,(cadr pairs)) lets)
+       (push (car pairs) setqs)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/t/stream.lisp-diff src-to-be/code/t/stream.lisp-diff
--- src/code/t/stream.lisp-diff	Thu Jan  1 01:00:00 1970
+++ src-to-be/code/t/stream.lisp-diff	Fri Oct 23 13:56:17 1998
@@ -0,0 +1,15 @@
+--- stream.lisp~	Mon Oct 12 19:42:18 1998
++++ stream.lisp	Mon Oct 12 23:49:51 1998
+@@ -1210,10 +1210,10 @@
+ 	   (type (or index null) end))
+   
+   #+high-security
+-  (when (> end (length string))
++  (when (>= end (length string))
+     (cerror "Continue with end changed from ~s to ~s"
+ 	      "Write-string: end (~S) is larger then the length of the string (~S)"
+-	      end (length string)))
++	      end (1- (length string))))
+ 
+   (internal-make-string-input-stream (coerce string 'simple-string)
+ 				     start end))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/code/unix.lisp src-to-be/code/unix.lisp
--- src/code/unix.lisp	Sun Oct  4 09:38:29 1998
+++ src-to-be/code/unix.lisp	Mon Nov  9 20:09:13 1998
@@ -1450,6 +1450,9 @@
 (defconstant tty-cbreak #-linux #o2 #+linux 64)
 #-(or linux hpux)
 (defconstant tty-tandem #o1)
+#+linux (defconstant tty-echo 8)
+#+linux (defconstant tty-oddp 16)
+#+linux (defconstant tty-evenp 32)
 
 #+(or hpux svr4 freebsd linux)
 (progn
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/globals.lisp src-to-be/compiler/globals.lisp
--- src/compiler/globals.lisp	Mon Feb 11 17:16:59 1991
+++ src-to-be/compiler/globals.lisp	Mon Nov  9 20:09:13 1998
@@ -1,3 +1,6 @@
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package "C")
 (proclaim '(special
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/core.lisp src-to-be/compiler/old-rt/core.lisp
--- src/compiler/old-rt/core.lisp	Thu Feb 15 12:00:16 1990
+++ src-to-be/compiler/old-rt/core.lisp	Mon Nov  9 20:09:13 1998
@@ -11,6 +11,10 @@
 ;;;    This file contains stuff that knows how to load compiled code directly
 ;;; into core, e.g. incremental compilation.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/dump.lisp src-to-be/compiler/old-rt/dump.lisp
--- src/compiler/old-rt/dump.lisp	Mon Mar 19 13:11:26 1990
+++ src-to-be/compiler/old-rt/dump.lisp	Mon Nov  9 20:09:14 1998
@@ -11,6 +11,10 @@
 ;;;    This file contains stuff that knows about dumping code both to files to
 ;;; the running Lisp.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 (proclaim '(special compiler-version))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/genesis.lisp src-to-be/compiler/old-rt/genesis.lisp
--- src/compiler/old-rt/genesis.lisp	Mon Mar 19 13:12:07 1990
+++ src-to-be/compiler/old-rt/genesis.lisp	Mon Nov  9 20:09:14 1998
@@ -16,6 +16,9 @@
 ;;; image, and twiddle the page map to map the parts of the image consecutively
 ;;; into this large block, which we then write out as a file.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package "LISP")
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/memory.lisp src-to-be/compiler/old-rt/memory.lisp
--- src/compiler/old-rt/memory.lisp	Tue Feb  6 12:33:25 1990
+++ src-to-be/compiler/old-rt/memory.lisp	Mon Nov  9 20:09:15 1998
@@ -12,6 +12,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/miscop.lisp src-to-be/compiler/old-rt/miscop.lisp
--- src/compiler/old-rt/miscop.lisp	Fri Apr 13 14:56:49 1990
+++ src-to-be/compiler/old-rt/miscop.lisp	Mon Nov  9 20:09:15 1998
@@ -12,6 +12,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
     
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/move.lisp src-to-be/compiler/old-rt/move.lisp
--- src/compiler/old-rt/move.lisp	Mon Apr 16 12:57:42 1990
+++ src-to-be/compiler/old-rt/move.lisp	Mon Nov  9 20:09:15 1998
@@ -12,6 +12,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/nlx.lisp src-to-be/compiler/old-rt/nlx.lisp
--- src/compiler/old-rt/nlx.lisp	Wed Jun  6 16:51:56 1990
+++ src-to-be/compiler/old-rt/nlx.lisp	Mon Nov  9 20:09:15 1998
@@ -12,6 +12,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/odump.lisp src-to-be/compiler/old-rt/odump.lisp
--- src/compiler/old-rt/odump.lisp	Tue Feb  6 12:33:34 1990
+++ src-to-be/compiler/old-rt/odump.lisp	Mon Nov  9 20:09:15 1998
@@ -11,6 +11,10 @@
 ;;;    This file contains stuff that knows about dumping code both to files to
 ;;; the running Lisp.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 (proclaim '(special compiler-version))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/parms.lisp src-to-be/compiler/old-rt/parms.lisp
--- src/compiler/old-rt/parms.lisp	Thu Aug 16 18:45:05 1990
+++ src-to-be/compiler/old-rt/parms.lisp	Mon Nov  9 20:09:15 1998
@@ -13,6 +13,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 (eval-when (compile load eval)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/pred.lisp src-to-be/compiler/old-rt/pred.lisp
--- src/compiler/old-rt/pred.lisp	Tue Feb  6 12:33:38 1990
+++ src-to-be/compiler/old-rt/pred.lisp	Mon Nov  9 20:09:15 1998
@@ -11,6 +11,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/print.lisp src-to-be/compiler/old-rt/print.lisp
--- src/compiler/old-rt/print.lisp	Tue Feb  6 12:33:40 1990
+++ src-to-be/compiler/old-rt/print.lisp	Mon Nov  9 20:09:15 1998
@@ -12,6 +12,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 (define-vop (print one-arg-miscop)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/subprim.lisp src-to-be/compiler/old-rt/subprim.lisp
--- src/compiler/old-rt/subprim.lisp	Tue May 29 18:41:21 1990
+++ src-to-be/compiler/old-rt/subprim.lisp	Mon Nov  9 20:09:15 1998
@@ -12,6 +12,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/system.lisp src-to-be/compiler/old-rt/system.lisp
--- src/compiler/old-rt/system.lisp	Mon Apr 16 12:59:16 1990
+++ src-to-be/compiler/old-rt/system.lisp	Mon Nov  9 20:09:15 1998
@@ -11,6 +11,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 (define-vop (pointer+)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/type-vops.lisp src-to-be/compiler/old-rt/type-vops.lisp
--- src/compiler/old-rt/type-vops.lisp	Wed Jun  6 16:52:33 1990
+++ src-to-be/compiler/old-rt/type-vops.lisp	Mon Nov  9 20:09:15 1998
@@ -12,6 +12,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 ;;;; Simple type checking and testing:
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/values.lisp src-to-be/compiler/old-rt/values.lisp
--- src/compiler/old-rt/values.lisp	Fri Apr 13 15:00:33 1990
+++ src-to-be/compiler/old-rt/values.lisp	Mon Nov  9 20:09:15 1998
@@ -11,6 +11,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 (define-vop (reset-stack-pointer)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/vm-tran.lisp src-to-be/compiler/old-rt/vm-tran.lisp
--- src/compiler/old-rt/vm-tran.lisp	Tue May 29 18:42:27 1990
+++ src-to-be/compiler/old-rt/vm-tran.lisp	Mon Nov  9 20:09:15 1998
@@ -12,6 +12,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 ;;; We need to define these predicates, since the TYPEP source transform picks
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/vm-type.lisp src-to-be/compiler/old-rt/vm-type.lisp
--- src/compiler/old-rt/vm-type.lisp	Tue Feb  6 12:33:50 1990
+++ src-to-be/compiler/old-rt/vm-type.lisp	Mon Nov  9 20:09:15 1998
@@ -13,6 +13,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 ;;;; Implementation dependent deftypes:
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/old-rt/vm.lisp src-to-be/compiler/old-rt/vm.lisp
--- src/compiler/old-rt/vm.lisp	Mon Jun 11 16:22:06 1990
+++ src-to-be/compiler/old-rt/vm.lisp	Mon Nov  9 20:09:15 1998
@@ -11,6 +11,10 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package 'c)
 
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/proclaim.lisp src-to-be/compiler/proclaim.lisp
--- src/compiler/proclaim.lisp	Mon Oct 31 05:27:28 1994
+++ src-to-be/compiler/proclaim.lisp	Thu Dec 10 21:47:00 1998
@@ -62,8 +62,12 @@
 ;;; 
 (defun proclaim-init ()
   (setf *default-cookie*
+	#-high-security
 	(make-cookie :safety 1 :speed 1 :space 1 :cspeed 1
-		     :brevity 1 :debug 2))
+		     :brevity 1 :debug 2)
+	#+high-security
+	(make-cookie :safety 3 :speed 0 :space 0 :cspeed 0
+		     :brevity 0 :debug 3))
   (setf *default-interface-cookie*
 	(make-cookie)))
 ;;;
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/compiler/profile.lisp src-to-be/compiler/profile.lisp
--- src/compiler/profile.lisp	Tue Mar 16 03:03:36 1993
+++ src-to-be/compiler/profile.lisp	Mon Nov  9 20:09:15 1998
@@ -1,4 +1,8 @@
 ;;; -*- Package: C -*-
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package "C")
 
 (use-package "PROFILE")
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/docs/Makefile src-to-be/docs/Makefile
--- src/docs/Makefile	Thu Jan  1 01:00:00 1970
+++ src-to-be/docs/Makefile	Fri Oct 23 13:56:18 1998
@@ -0,0 +1,16 @@
+all:
+	(cd cmu-user && latex cmu-user && latex cmu-user ;  \
+	dvips -o cmu-user.ps cmu-user.dvi ) 
+	(cd interface && latex internals && latex internals && \
+	latex toolkit && latex toolkit && dvips -o internals.ps \
+	internals.dvi && dvips -o toolkit.ps toolkit.dvi)
+	 
+clean:
+	find cmu-user interface  \
+	-name "*.cb" -or -name ".idx" -or -name "*.aux" -or \
+	-name "*.log" -or -name "*.tdx" -or -name "*.vdx" -or \
+	-name "*.fdx" -or -name  "*.cdx" -or -name "*.dvi" -or \
+	-name "*.toc"  -or -name "*.idx"  -or -name "*.ps" \
+	| xargs rm ; true 
+	
+	rm -rf cmu-user/cmu-user interface/internals interface/toolkit 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/docs/cmu-user/cmu-user.tex src-to-be/docs/cmu-user/cmu-user.tex
--- src/docs/cmu-user/cmu-user.tex	Fri Aug 28 18:49:25 1998
+++ src-to-be/docs/cmu-user/cmu-user.tex	Fri Oct 23 13:56:19 1998
@@ -28,7 +28,8 @@
 \usepackage{verbatim}
 \usepackage{ifthen}
 \usepackage{calc}
-\usepackage{html2e}
+%\usepackage{html2e}
+\usepackage{html,color}
 \usepackage{varioref}
 
 %% Define the indices.  We need one for Types, Variables, Functions,
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/docs/interface/internals.tex src-to-be/docs/interface/internals.tex
--- src/docs/interface/internals.tex	Sun Dec 28 19:03:24 1997
+++ src-to-be/docs/interface/internals.tex	Fri Oct 23 13:56:20 1998
@@ -4,7 +4,7 @@
 %% LaTeX formatting by Marco Antoniotti based on internals.doc.
 
 \documentclass{article}
-\usepackage{a4wide}
+%\usepackage{a4wide}
 
 \title{General Design Notes on the Motif Toolkit Interface}
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/docs/interface/toolkit.tex src-to-be/docs/interface/toolkit.tex
--- src/docs/interface/toolkit.tex	Sun Dec 28 19:06:25 1997
+++ src-to-be/docs/interface/toolkit.tex	Fri Oct 23 13:56:20 1998
@@ -4,7 +4,7 @@
 %% LaTeX formatting by Marco Antoniotti based on internals.doc.
 
 \documentclass{article}
-\usepackage{a4wide}
+%\usepackage{a4wide}
 
 
 \newcommand{\functdescr}[1]{\paragraph{\texttt{#1}}}
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/hemlock/hacks.lisp src-to-be/hemlock/hacks.lisp
--- src/hemlock/hacks.lisp	Fri Feb 11 22:53:09 1994
+++ src-to-be/hemlock/hacks.lisp	Mon Nov  9 20:09:15 1998
@@ -1,4 +1,7 @@
 (in-package "HI")
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (defun %sp-byte-blt (src start dest dstart end)
   (%primitive byte-blt src start dest dstart end))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/hemlock/main.lisp src-to-be/hemlock/main.lisp
--- src/hemlock/main.lisp	Mon Oct 31 05:50:12 1994
+++ src-to-be/hemlock/main.lisp	Mon Nov  9 20:09:16 1998
@@ -31,6 +31,8 @@
 
 (defvar *hemlock-version* "3.5")
 (pushnew :hemlock *features*)
+(setf *features* (remove :no-hemlock *features*))
+
 (setf (getf ext:*herald-items* :hemlock) 
       `("    Hemlock " ,*hemlock-version*))
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/interface/initial.lisp src-to-be/interface/initial.lisp
--- src/interface/initial.lisp	Mon Oct 31 05:53:18 1994
+++ src-to-be/interface/initial.lisp	Mon Nov  9 20:09:16 1998
@@ -12,6 +12,7 @@
 (in-package "USER")
 
 (pushnew :motif *features*)
+(setf *features* (remove :no-clm *features*))
 
 (setf (getf ext:*herald-items* :motif)
       `("    Motif toolkit and graphical debugger 1.0"))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/ldb/Makefile.orig src-to-be/ldb/Makefile.orig
--- src/ldb/Makefile.orig	Fri Mar  6 13:39:06 1992
+++ src-to-be/ldb/Makefile.orig	Thu Jan  1 01:00:00 1970
@@ -1,153 +0,0 @@
-/* $Header: /home/CVS-cmucl/src/ldb/Makefile.orig,v 1.29 1992/03/06 12:39:06 wlott Exp $ */
-INCLS = -I. -I/usr/misc/.X11/include
-
-SRCS = ldb.c egets.c coreparse.c alloc.c monitor.c print.c \
-	os.c os-common.c arch.c vars.c assem.s parse.c interrupt.c test.c \
-	search.c validate.c gc.c globals.c dynbind.c breakpoint.c \
-	regnames.c backtrace.c bitbash.c save.c purify.c socket.c
-
-OBJS = ldb.o egets.o coreparse.o alloc.o monitor.o print.o \
-	os.o os-common.o arch.o vars.o assem.o parse.o interrupt.o test.o \
-	search.o validate.o gc.o globals.o dynbind.o breakpoint.o \
-	regnames.o backtrace.o bitbash.o save.o purify.o socket.o
-
-#ifdef mips
-CFLAGS = -O ${INCLS}
-UNDEFSYMPATTERN=&
-ASSEMFILE='mips-assem.s'
-ARCH_SRC="mips-arch.c"
-#endif
-
-#ifdef ibmrt
-CFLAGS = -g ${INCLS}
-UNDEFSYMPATTERN=_&
-ASSEMFILE='rt-assem.s'
-ARCH_SRC="rt-arch.c"
-#endif
-
-#ifdef sparc
-CFLAGS = -O ${INCLS}
-UNDEFSYMPATTERN=_&
-ASSEMFILE='sparc-assem.s'
-ARCH_SRC="sparc-arch.c"
-#endif
-
-#ifdef MACH
-OS_SRC=mach-os.c
-OS_LINK_FLAGS=
-OS_SRCS=
-OS_OBJS=
-OS_LIBS=-lmach
-CPP=/usr/cs/lib/cpp
-#else
-#ifdef sun
-OS_SRC=sunos-os.c
-OS_LINK_FLAGS=-Bstatic
-OS_SRCS=fake-mach.c
-OS_OBJS=fake-mach.o
-OS_LIBS=
-#endif
-CPP=/lib/cpp
-#endif
-
-
-all: ldb.map
-
-ldb.map: ldb
-	echo -n 'Map file for ldb version ' > ldb.map
-	cat version >> ldb.map
-	nm -gp ldb >> ldb.map
-
-
-ldb: ${OBJS} ${OS_OBJS} version undefineds
-	echo -n '1 + ' | cat - version | bc > ,version
-	mv ,version version
-	cc ${CFLAGS} -DVERSION=`cat version` -c version.c
-	cc ${OS_LINK_FLAGS} `cat undefineds` -o ,ldb \
-		${OBJS} ${OS_OBJS} version.o \
-		${OS_LIBS} -lm -lc
-	mv -f ,ldb ldb
-
-version:
-	echo 0 > version
-
-undefineds: undefineds.src
-	${CPP} undefineds.src | \
-	sed -e '/^#/d' -e '/^[ 	]*$$/d' -e 's/.*/-u ${UNDEFSYMPATTERN}/' | \
-	sort -u > ,undefineds
-	mv ,undefineds undefineds
-
-assem.s:
-	rm -f assem.s
-	ln -s ${ASSEMFILE} assem.s
-
-os.c:
-	rm -f os.c
-	ln -s ${OS_SRC} os.c
-
-arch.c:
-	rm -f arch.c
-	ln -s ${ARCH_SRC} arch.c
-
-#ifdef mips
-
-/* MIPS specific stuff. */
-
-/* If we get an interrupt while in lisp code, the global pointer */
-/* is trash.  Therefore, we can't use the GP relative addressing */
-/* mode in the interrupt handlers. */
-
-arch.o: arch.c
-	cc ${CFLAGS} -G 0 -c arch.c
-interrupt.o: interrupt.c
-	cc ${CFLAGS} -G 0 -c interrupt.c
-
-assem.o: assem.s lisp.h lispregs.h globals.h
-	as -G 0 -o $@ assem.s
-
-#endif
-
-#ifdef ibmrt
-
-assem.o: assem.s
-	${CPP} assem.s | as -o assem.o
-
-#endif
-
-
-#ifdef sparc
-
-/* We need this shit because as runs the wrong preprocessor. */
-#ifdef MACH
-ASSEMDEFS=-DMACH
-#else
-ASSEMDEFS=-UMACH
-#endif
-
-assem.o: assem.s lisp.h lispregs.h globals.h
-	as -P ${ASSEMDEFS} -o $@ assem.s
-
-#endif
-
-
-socket.o: socket.c
-	cc ${CFLAGS} -DUNIXCONN -c socket.c
-
-lisp.h:
-	@echo "You must run genesis to create lisp.h!"
-	@false
-
-clean:
-	rm -f lisp.h os.c arch.c assem.s undefineds *.o ldb ldb.map
-
-depend: depends
-
-depends: os.c arch.c assem.s
-	rm -f Makefile.BAK
-	ln Makefile Makefile.BAK
-	sed -n '1,/^\/\*@/p' Makefile > Makefile.NEW
-	cc -M ${INCLS} ${SRCS} ${OS_SRCS} | egrep -v ' /usr/' >> Makefile.NEW
-	mv Makefile.NEW Makefile
-	rm Makefile.BAK
-
-/*@ Do not edit anything after this line. */
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/lisp/Config.linux_gencgc src-to-be/lisp/Config.linux_gencgc
--- src/lisp/Config.linux_gencgc	Fri May  1 03:21:40 1998
+++ src-to-be/lisp/Config.linux_gencgc	Fri Oct 23 13:56:20 1998
@@ -1,7 +1,7 @@
-vpath %.h /usr/src/cmucl/cmucl/p86/lisp:/usr/src/cmucl/cmucl/src/lisp
-vpath %.c /usr/src/cmucl/cmucl/p86/lisp:/usr/src/cmucl/cmucl/src/lisp
-vpath %.S /usr/src/cmucl/cmucl/p86/lisp:/usr/src/cmucl/cmucl/src/lisp
-CPPFLAGS = -I. -I/usr/src/cmucl/cmucl/src/lisp -I- -I/usr/X11R6/include
+vpath %.h /usr/src/cmucl/cmucl/src/lisp/
+vpath %.c /usr/src/cmucl/cmucl/src/lisp/
+vpath %.S /usr/src/cmucl/cmucl/src/lisp/
+CPPFLAGS = -I. -I/usr/src/cmucl/cmucl/src/lisp/ -I- -I/usr/X11R6/include
 CC = gcc  -Wstrict-prototypes -O2 -fno-strength-reduce # -Wall
 LD = ld
 CPP = cpp
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/lisp/GNUmakefile src-to-be/lisp/GNUmakefile
--- src/lisp/GNUmakefile	Sat Jun  7 17:25:37 1997
+++ src-to-be/lisp/GNUmakefile	Fri Oct 23 13:56:20 1998
@@ -29,12 +29,12 @@
 	mv ,lisp.nm lisp.nm
 
 lisp: version.c ${OBJS} version
-	echo '1 + ' `cat version` | bc > ,version
-	mv ,version version
+	echo '1 + ' `cat version` | bc | tail -n 1 | sed "s/
//g" > ,version
+	mv -f ,version version
 	$(CC) ${CFLAGS} -DVERSION=`cat version` -c $<
 	$(CC) -g ${OS_LINK_FLAGS} -o ,lisp \
 		${OBJS} version.o \
-		${OS_LIBS} -lm
+		${OS_LIBS} -lm 
 	mv -f ,lisp lisp
 
 version:
@@ -49,10 +49,11 @@
 	@false
 
 clean:
-	rm -f Depends *.o lisp lisp.nm core
+	rm -f Depends *.o lisp lisp.nm core ; true
+	touch Depends
 
 depend: ${SRCS}
 	$(CC) -MM -E ${DEPEND_FLAGS} ${CFLAGS} ${CPPFLAGS} $? > ,depends
-	mv ,depends Depends
+	mv -f ,depends Depends
 
 include Depends
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/lisp/gencgc.c src-to-be/lisp/gencgc.c
--- src/lisp/gencgc.c	Wed Dec 16 13:38:05 1998
+++ src-to-be/lisp/gencgc.c	Sat Mar 21 08:45:51 1998
@@ -5795,7 +5795,7 @@
       gc_assert(page_table[page].allocated == FREE_PAGE);
       gc_assert(page_table[page].bytes_used == 0);
       
-      page_start = (int *)page_address(page);
+      page_start = (int *)page_address(i);
 
       for(i=0; i<1024; i++)
 	if (page_start[i] != 0)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/lisp/monitor.c src-to-be/lisp/monitor.c
--- src/lisp/monitor.c	Sat Jan 17 06:56:35 1998
+++ src-to-be/lisp/monitor.c	Fri Oct 23 13:56:20 1998
@@ -436,7 +436,7 @@
     while (!done) {
         printf("ldb> ");
         fflush(stdout);
-        line = gets(buf);
+        line = fgets(buf, sizeof(buf), stdin);
         if (line == NULL) {
 	    if (isatty(0)) {
 		putchar('\n');
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/lisp/print.c src-to-be/lisp/print.c
--- src/lisp/print.c	Wed Jun  3 04:24:11 1998
+++ src-to-be/lisp/print.c	Fri Oct 23 13:56:20 1998
@@ -139,7 +139,7 @@
             printf("More? [y] ");
             fflush(stdout);
 
-            gets(buffer);
+            fgets(buffer, sizeof(buffer), stdin);
 
             if (buffer[0] == 'n' || buffer[0] == 'N')
                 throw_to_monitor();
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/motif/lisp/internals.lisp src-to-be/motif/lisp/internals.lisp
--- src/motif/lisp/internals.lisp	Fri Aug 22 22:49:28 1997
+++ src-to-be/motif/lisp/internals.lisp	Mon Nov  9 20:09:16 1998
@@ -12,6 +12,9 @@
 ;;; This file contains internal functions required to support the Motif
 ;;; toolkit in Lisp.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package "TOOLKIT-INTERNALS")
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/motif/lisp/prototypes.lisp src-to-be/motif/lisp/prototypes.lisp
--- src/motif/lisp/prototypes.lisp	Fri Mar 20 12:33:44 1998
+++ src-to-be/motif/lisp/prototypes.lisp	Mon Nov  9 20:09:16 1998
@@ -12,6 +12,9 @@
 ;;; This file contains the prototyping code for RPC requests between the
 ;;; Lisp client and the C server.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package "TOOLKIT")
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/motif/lisp/transport.lisp src-to-be/motif/lisp/transport.lisp
--- src/motif/lisp/transport.lisp	Mon Oct 31 05:54:48 1994
+++ src-to-be/motif/lisp/transport.lisp	Wed Dec  9 22:47:14 1998
@@ -110,7 +110,8 @@
 			      (4 'system:sap-ref-32)))
 		   (bits (* size 8)))
 	       `(defun ,name (packet data)
-		  (declare (type (signed-byte ,bits) data))
+		  (declare (type (or (signed-byte ,bits)
+		                     (unsigned-byte ,bits)) data))
 		  (let ((fill (system:sap+ (packet-head packet)
 					   (packet-fill packet))))
 		    (setf (,sap-ref fill 0) data)
@@ -126,7 +127,8 @@
 		  (let* ((fill (system:sap+ (packet-head packet)
 					    (packet-fill packet)))
 			 (data (,sap-ref fill 0)))
-		    (declare (type (signed-byte ,bits) data))
+		    (declare (type (or (signed-byte ,bits)
+		                       (unsigned-byte ,bits)) data))
 		    (incf (packet-fill packet) ,size)
 		    data)))))
   (def-packet-writer packet-put-byte 1)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/motif/server/Config.x86 src-to-be/motif/server/Config.x86
--- src/motif/server/Config.x86	Sat Apr 19 22:13:23 1997
+++ src-to-be/motif/server/Config.x86	Fri Oct 23 13:56:20 1998
@@ -1,6 +1,8 @@
 CFLAGS = -O2 -I/usr/X11R6/include -I. -I$(VPATH)
 LDFLAGS = -L/usr/X11R6/lib
-LIBS = -static -lXm -dynamic -lXt -lXext -lX11 -lSM -lICE
+# -L/usr/lib/libc5-compat/
+LIBS = -lXm -lXt -lXext -lX11 -lSM -lICE 
+# -static
 # This def assumes you are building in the same or parallel
 # tree to the CVS souce layout. Sites may need to customize
 # this path.
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/motif/server/GNUmakefile src-to-be/motif/server/GNUmakefile
--- src/motif/server/GNUmakefile	Sat Jan 18 15:31:43 1997
+++ src-to-be/motif/server/GNUmakefile	Fri Oct 23 13:56:20 1998
@@ -1,7 +1,7 @@
-CC = gcc
+#CC=i486-linuxlibc1-gcc
+CC=gcc
 LIBS = -lXm -lXt -lX11
-CFLAGS = -O
-LDFLAGS =
+CFLAGS = -O 
 
 TARGET = motifd
 OBJS = main.o server.o translations.o packet.o message.o datatrans.o \
@@ -18,3 +18,6 @@
 
 requests.o : requests.c Interface.h
 	$(CC) $(CFLAGS) -c $<
+
+clean:
+	rm -f core *.o motifd ; true
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/bench.lisp src-to-be/pcl/bench.lisp
--- src/pcl/bench.lisp	Sun Dec 14 14:41:41 1997
+++ src-to-be/pcl/bench.lisp	Mon Nov  9 20:09:16 1998
@@ -23,6 +23,9 @@
 ;;;
 ;;; jeff morrill
 ;;; jmorrill@bbn.com
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 #+Genera
 (eval-when (compile load eval)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/braid.lisp src-to-be/pcl/braid.lisp
--- src/pcl/braid.lisp	Thu Jul 16 13:30:20 1998
+++ src-to-be/pcl/braid.lisp	Mon Nov  9 20:09:16 1998
@@ -33,6 +33,9 @@
 ;;; deeply.
 ;;;
 ;;; 
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/cache.lisp src-to-be/pcl/cache.lisp
--- src/pcl/cache.lisp	Fri Jun  5 04:53:51 1998
+++ src-to-be/pcl/cache.lisp	Mon Nov  9 20:09:16 1998
@@ -26,6 +26,9 @@
 ;;;
 ;;; The basics of the PCL wrapper cache mechanism.
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :pcl)
 ;;;
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/cloe-low.lisp src-to-be/pcl/cloe-low.lisp
--- src/pcl/cloe-low.lisp	Tue Jan 12 19:23:20 1993
+++ src-to-be/pcl/cloe-low.lisp	Mon Nov  9 20:09:16 1998
@@ -24,6 +24,9 @@
 ;;; Suggestions, comments and requests for improvements are also welcome.
 ;;; *************************************************************************
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/cmu-low.lisp src-to-be/pcl/cmu-low.lisp
--- src/pcl/cmu-low.lisp	Fri Jun  5 04:55:30 1998
+++ src-to-be/pcl/cmu-low.lisp	Mon Nov  9 20:09:16 1998
@@ -26,6 +26,9 @@
 ;;; 
 ;;; This is the CMU Lisp version of the file low.
 ;;; 
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/combin.lisp src-to-be/pcl/combin.lisp
--- src/pcl/combin.lisp	Thu Jan 22 13:32:52 1998
+++ src-to-be/pcl/combin.lisp	Mon Nov  9 20:09:16 1998
@@ -24,6 +24,9 @@
 ;;; Suggestions, comments and requests for improvements are also welcome.
 ;;; *************************************************************************
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/construct.lisp src-to-be/pcl/construct.lisp
--- src/pcl/construct.lisp	Fri Jun  5 04:53:51 1998
+++ src-to-be/pcl/construct.lisp	Mon Nov  9 20:09:16 1998
@@ -28,6 +28,9 @@
 ;;; This file defines the defconstructor and other make-instance optimization
 ;;; mechanisms.
 ;;; 
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/coral-low.lisp src-to-be/pcl/coral-low.lisp
--- src/pcl/coral-low.lisp	Tue Jan 12 19:23:41 1993
+++ src-to-be/pcl/coral-low.lisp	Mon Nov  9 20:09:16 1998
@@ -24,6 +24,9 @@
 ;;; Suggestions, comments and requests for improvements are also welcome.
 ;;; *************************************************************************
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/cpatch.lisp src-to-be/pcl/cpatch.lisp
--- src/pcl/cpatch.lisp	Mon Nov  9 16:18:36 1992
+++ src-to-be/pcl/cpatch.lisp	Mon Nov  9 20:09:16 1998
@@ -4,6 +4,9 @@
 ;;  
 ;; copyright (c) 1990 Franz Inc.
 ;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :comp)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/cpl.lisp src-to-be/pcl/cpl.lisp
--- src/pcl/cpl.lisp	Tue Jan 12 19:23:44 1993
+++ src-to-be/pcl/cpl.lisp	Mon Nov  9 20:09:16 1998
@@ -24,6 +24,9 @@
 ;;; Suggestions, comments and requests for improvements are also welcome.
 ;;; *************************************************************************
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/ctypes.lisp src-to-be/pcl/ctypes.lisp
--- src/pcl/ctypes.lisp	Tue Jan 12 19:23:47 1993
+++ src-to-be/pcl/ctypes.lisp	Mon Nov  9 20:09:16 1998
@@ -24,6 +24,9 @@
 ;;; Suggestions, comments and requests for improvements are also welcome.
 ;;; *************************************************************************
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/defclass.lisp src-to-be/pcl/defclass.lisp
--- src/pcl/defclass.lisp	Sat Aug 30 20:34:24 1997
+++ src-to-be/pcl/defclass.lisp	Mon Nov  9 20:09:16 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+#+cmu
+(ext:file-comment
+  "$Header$")
+
 (in-package :pcl)
 
 ;;;
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/defcombin.lisp src-to-be/pcl/defcombin.lisp
--- src/pcl/defcombin.lisp	Sat Oct 17 06:01:14 1998
+++ src-to-be/pcl/defcombin.lisp	Mon Nov  9 20:09:16 1998
@@ -25,6 +25,9 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
 (in-package :pcl)
 
 ;;;
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/defsys.lisp src-to-be/pcl/defsys.lisp
--- src/pcl/defsys.lisp	Thu Jun 11 10:09:57 1998
+++ src-to-be/pcl/defsys.lisp	Mon Nov  9 20:09:16 1998
@@ -50,6 +50,9 @@
 ;;;    loaded into the same world it was compiled in.
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
 (in-package :user)
 
 (defpackage "WALKER" (:use :common-lisp))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/dfun.lisp src-to-be/pcl/dfun.lisp
--- src/pcl/dfun.lisp	Fri Jun  5 04:53:52 1998
+++ src-to-be/pcl/dfun.lisp	Mon Nov  9 20:09:17 1998
@@ -25,6 +25,9 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
 (in-package :pcl)
 
 #|
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/dlap.lisp src-to-be/pcl/dlap.lisp
--- src/pcl/dlap.lisp	Tue Jan 12 19:24:25 1993
+++ src-to-be/pcl/dlap.lisp	Mon Nov  9 20:09:17 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/dlisp.lisp src-to-be/pcl/dlisp.lisp
--- src/pcl/dlisp.lisp	Sun Jun  7 20:04:21 1998
+++ src-to-be/pcl/dlisp.lisp	Mon Nov  9 20:09:17 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 ;;; This file is (almost) functionally equivalent to dlap.lisp,
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/dlisp2.lisp src-to-be/pcl/dlisp2.lisp
--- src/pcl/dlisp2.lisp	Mon Dec 15 04:40:43 1997
+++ src-to-be/pcl/dlisp2.lisp	Mon Nov  9 20:09:17 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 (defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/dlisp3.lisp src-to-be/pcl/dlisp3.lisp
--- src/pcl/dlisp3.lisp	Thu Jun 11 10:09:57 1998
+++ src-to-be/pcl/dlisp3.lisp	Mon Nov  9 20:09:17 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 (eval-when (compile load eval)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/env.lisp src-to-be/pcl/env.lisp
--- src/pcl/env.lisp	Fri May 30 20:39:12 1997
+++ src-to-be/pcl/env.lisp	Mon Nov  9 20:09:17 1998
@@ -27,6 +27,10 @@
 ;;; Basic environmental stuff.
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 #+Lucid
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/excl-low.lisp src-to-be/pcl/excl-low.lisp
--- src/pcl/excl-low.lisp	Mon Nov  9 16:19:23 1992
+++ src-to-be/pcl/excl-low.lisp	Mon Nov  9 20:09:17 1998
@@ -30,6 +30,9 @@
 ;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in
 ;;; a later release so this will need to be changed.
 ;;; 
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package 'pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/extensions.lisp src-to-be/pcl/extensions.lisp
--- src/pcl/extensions.lisp	Sat Aug  1 17:28:44 1992
+++ src-to-be/pcl/extensions.lisp	Mon Nov  9 20:09:17 1998
@@ -17,6 +17,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package 'pcl)
 
 (eval-when (compile load eval)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/fast-init.lisp src-to-be/pcl/fast-init.lisp
--- src/pcl/fast-init.lisp	Thu Feb  6 22:24:09 1997
+++ src-to-be/pcl/fast-init.lisp	Mon Nov  9 20:09:17 1998
@@ -28,6 +28,10 @@
 ;;; This file defines the optimized make-instance functions.
 ;;; 
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 (defvar *compile-make-instance-functions-p* nil)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/fin.lisp src-to-be/pcl/fin.lisp
--- src/pcl/fin.lisp	Thu Feb  6 22:24:11 1997
+++ src-to-be/pcl/fin.lisp	Mon Nov  9 20:09:17 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
   ;;   
 ;;;;;; FUNCALLABLE INSTANCES
   ;;
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/fixup.lisp src-to-be/pcl/fixup.lisp
--- src/pcl/fixup.lisp	Tue Jan 12 19:24:57 1993
+++ src-to-be/pcl/fixup.lisp	Mon Nov  9 20:09:17 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 (fix-early-generic-functions)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/fngen.lisp src-to-be/pcl/fngen.lisp
--- src/pcl/fngen.lisp	Tue Jan 12 19:25:00 1993
+++ src-to-be/pcl/fngen.lisp	Mon Nov  9 20:09:17 1998
@@ -25,6 +25,9 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
 (in-package :pcl)
 
 ;;;
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/fsc.lisp src-to-be/pcl/fsc.lisp
--- src/pcl/fsc.lisp	Sun Jun 21 12:16:56 1998
+++ src-to-be/pcl/fsc.lisp	Mon Nov  9 20:09:17 1998
@@ -37,6 +37,9 @@
 ;;; 
 ;;; workings of this metaclass and the standard-class metaclass.
 ;;; 
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/generic-functions.lisp src-to-be/pcl/generic-functions.lisp
--- src/pcl/generic-functions.lisp	Fri Jun  5 04:53:52 1998
+++ src-to-be/pcl/generic-functions.lisp	Mon Nov  9 20:09:17 1998
@@ -1,5 +1,9 @@
 ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 ;;; class predicates
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/init.lisp src-to-be/pcl/init.lisp
--- src/pcl/init.lisp	Fri Jun  5 04:53:52 1998
+++ src-to-be/pcl/init.lisp	Mon Nov  9 20:09:18 1998
@@ -28,6 +28,10 @@
 ;;; This file defines the initialization and related protocols.
 ;;; 
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 (defmethod make-instance ((class symbol) &rest initargs)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/inline.lisp src-to-be/pcl/inline.lisp
--- src/pcl/inline.lisp	Mon Nov  9 16:20:08 1992
+++ src-to-be/pcl/inline.lisp	Mon Nov  9 20:09:18 1998
@@ -1,5 +1,9 @@
 ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 ;; This file contains some of the things that will have to change to support
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/iterate.lisp src-to-be/pcl/iterate.lisp
--- src/pcl/iterate.lisp	Tue Jan 20 14:08:32 1998
+++ src-to-be/pcl/iterate.lisp	Mon Nov  9 20:09:18 1998
@@ -26,6 +26,10 @@
 ;;; 
 ;;; Original source {pooh/n}<pooh>vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33
 
+(ext:file-comment
+  "$Header$")
+
+
 (defpackage "ITERATE" (:use :common-lisp :walker)
   (:export "ITERATE" "ITERATE*" "GATHERING" "GATHER" "WITH-GATHERING"
 	   "INTERVAL" "ELEMENTS" "LIST-ELEMENTS" "LIST-TAILS"
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/lap.lisp src-to-be/pcl/lap.lisp
--- src/pcl/lap.lisp	Mon Nov  9 16:20:28 1992
+++ src-to-be/pcl/lap.lisp	Mon Nov  9 20:09:18 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package 'pcl)
 
 ;;;
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/list-functions.lisp src-to-be/pcl/list-functions.lisp
--- src/pcl/list-functions.lisp	Tue Jan 12 19:25:38 1993
+++ src-to-be/pcl/list-functions.lisp	Mon Nov  9 20:09:18 1998
@@ -1,4 +1,8 @@
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 (defvar *defun-list* nil)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/low.lisp src-to-be/pcl/low.lisp
--- src/pcl/low.lisp	Sun Jun  7 20:01:19 1998
+++ src-to-be/pcl/low.lisp	Mon Nov  9 20:09:18 1998
@@ -61,6 +61,9 @@
 ;;;
 ;;; Thanks.
 ;;; 
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package :pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/macros.lisp src-to-be/pcl/macros.lisp
--- src/pcl/macros.lisp	Tue Jan 20 14:04:09 1998
+++ src-to-be/pcl/macros.lisp	Mon Nov  9 20:09:18 1998
@@ -31,6 +31,10 @@
 ;;; loaded before it can be compiled.
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 (proclaim '(declaration
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/make-test.lisp src-to-be/pcl/make-test.lisp
--- src/pcl/make-test.lisp	Mon Jun  1 20:38:32 1992
+++ src-to-be/pcl/make-test.lisp	Mon Nov  9 20:09:18 1998
@@ -1,5 +1,9 @@
 (in-package :pcl)
 
+(ext:file-comment
+  "$Header$")
+
+
 (defun top-level-form-form (form)
   #+cmu
   (if (and (consp form) (eq (car form) 'eval-when))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/methods.lisp src-to-be/pcl/methods.lisp
--- src/pcl/methods.lisp	Tue Jun 30 14:51:23 1998
+++ src-to-be/pcl/methods.lisp	Mon Nov  9 20:09:18 1998
@@ -25,6 +25,9 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
 (in-package :pcl)
 
 (defmethod print-object (instance stream)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/pclcom.lisp src-to-be/pcl/pclcom.lisp
--- src/pcl/pclcom.lisp	Mon Jun  1 20:38:47 1992
+++ src-to-be/pcl/pclcom.lisp	Mon Nov  9 20:09:18 1998
@@ -1,4 +1,7 @@
 ;;I think this isn't used; instead, "target:tools/pclcom.lisp" is used.
+#+cmu
+(ext:file-comment
+  "$Header$")
 (setq ext:*gc-verbose* nil)
 (setq c:*suppress-values-declaration* t)
 (setf (search-list "pcl:") '("build:pcl/"))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/pclload.lisp src-to-be/pcl/pclload.lisp
--- src/pcl/pclload.lisp	Fri Mar 27 13:03:08 1998
+++ src-to-be/pcl/pclload.lisp	Mon Nov  9 20:09:18 1998
@@ -1,3 +1,6 @@
+#+cmu
+(ext:file-comment
+  "$Header$")
 (in-package "PCL")
 (unless (find-package "SLOT-ACCESSOR-NAME")
   (make-package "SLOT-ACCESSOR-NAME" :use nil))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/pkg.lisp src-to-be/pcl/pkg.lisp
--- src/pcl/pkg.lisp	Fri Jun  5 04:53:53 1998
+++ src-to-be/pcl/pkg.lisp	Mon Nov  9 20:09:18 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 ;;; CMUCL 18a: Jan-1998 -- Changing to DEFPACKAGE.
 ;;; Note that at this time CMUCL is not in compliance with ANSI
 ;;; specified use of feature names :cltl2 :x3j13 :draft-ansi-cl or :ansi-cl
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/plap.lisp src-to-be/pcl/plap.lisp
--- src/pcl/plap.lisp	Mon Nov  9 16:21:31 1992
+++ src-to-be/pcl/plap.lisp	Mon Nov  9 20:09:18 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package 'pcl)
 
 ;;;
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/precom1.lisp src-to-be/pcl/precom1.lisp
--- src/pcl/precom1.lisp	Tue Jan 12 19:26:35 1993
+++ src-to-be/pcl/precom1.lisp	Mon Nov  9 20:09:18 1998
@@ -25,6 +25,9 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
 (in-package :pcl)
 
 ;;;
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/precom2.lisp src-to-be/pcl/precom2.lisp
--- src/pcl/precom2.lisp	Tue Jan 12 19:26:41 1993
+++ src-to-be/pcl/precom2.lisp	Mon Nov  9 20:09:18 1998
@@ -26,6 +26,9 @@
 ;;;
 
 (in-package :pcl)
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (precompile-random-code-segments pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/precom4.lisp src-to-be/pcl/precom4.lisp
--- src/pcl/precom4.lisp	Sat Oct 19 18:23:23 1991
+++ src-to-be/pcl/precom4.lisp	Mon Nov  9 20:09:18 1998
@@ -24,6 +24,9 @@
 ;;; Suggestions, comments and requests for improvements are also welcome.
 ;;; *************************************************************************
 ;;;
+#+cmu
+(ext:file-comment
+  "$Header$")
 
 (in-package 'pcl)
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/slots-boot.lisp src-to-be/pcl/slots-boot.lisp
--- src/pcl/slots-boot.lisp	Sun Jun  7 20:01:19 1998
+++ src-to-be/pcl/slots-boot.lisp	Mon Nov  9 20:09:18 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 (defmacro slot-symbol (slot-name type)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/slots.lisp src-to-be/pcl/slots.lisp
--- src/pcl/slots.lisp	Fri Jun  5 04:53:53 1998
+++ src-to-be/pcl/slots.lisp	Mon Nov  9 20:09:18 1998
@@ -25,6 +25,9 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
 (in-package :pcl)
 
 ;;; ANSI CL condition for unbound slots.
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/std-class.lisp src-to-be/pcl/std-class.lisp
--- src/pcl/std-class.lisp	Sun Jun 21 21:04:44 1998
+++ src-to-be/pcl/std-class.lisp	Mon Nov  9 20:09:18 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 (defmethod slot-accessor-function ((slotd effective-slot-definition) type)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/structure-class.lisp src-to-be/pcl/structure-class.lisp
--- src/pcl/structure-class.lisp	Sat Aug  1 17:30:04 1992
+++ src-to-be/pcl/structure-class.lisp	Mon Nov  9 20:09:18 1998
@@ -25,6 +25,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package 'pcl)
 
 (defmethod initialize-internal-slot-functions :after
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/sys-proclaim.lisp src-to-be/pcl/sys-proclaim.lisp
--- src/pcl/sys-proclaim.lisp	Wed May 27 05:17:55 1998
+++ src-to-be/pcl/sys-proclaim.lisp	Mon Nov  9 20:09:18 1998
@@ -1,4 +1,8 @@
 
+(ext:file-comment
+  "$Header$")
+
+
 (IN-PACKAGE "USER") 
 (PROCLAIM '(FTYPE (FUNCTION (*) FIXNUM) PCL::ZERO)) 
 (PROCLAIM
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/sysdef.lisp src-to-be/pcl/sysdef.lisp
--- src/pcl/sysdef.lisp	Tue Jan 12 19:28:04 1993
+++ src-to-be/pcl/sysdef.lisp	Mon Nov  9 20:09:18 1998
@@ -2,6 +2,10 @@
 ;;; File: sysdef.lisp 
 ;;; Author: Richard Harris
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package "DSYS")
 
 (defvar *pcl-compiled-p* nil)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/time.lisp src-to-be/pcl/time.lisp
--- src/pcl/time.lisp	Mon Nov  9 16:22:14 1992
+++ src-to-be/pcl/time.lisp	Mon Nov  9 20:09:18 1998
@@ -1,3 +1,7 @@
+
+(ext:file-comment
+  "$Header$")
+
 (in-package "PCL")
 
 (proclaim '(optimize (speed 3)(safety 0)(compilation-speed 0)))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/user-instances.lisp src-to-be/pcl/user-instances.lisp
--- src/pcl/user-instances.lisp	Sat Aug  1 17:30:17 1992
+++ src-to-be/pcl/user-instances.lisp	Mon Nov  9 20:09:18 1998
@@ -19,6 +19,10 @@
 ;;; *************************************************************************
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package 'pcl)
 
 ;;;   This file builds on the PCL-USER-INSTANCES feature of July 92 PCL
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/vector.lisp src-to-be/pcl/vector.lisp
--- src/pcl/vector.lisp	Fri May  1 03:04:35 1998
+++ src-to-be/pcl/vector.lisp	Mon Nov  9 20:09:18 1998
@@ -27,6 +27,10 @@
 ;;; Permutation vectors.
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 (in-package :pcl)
 
 (defmacro instance-slot-index (wrapper slot-name)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/pcl/walk.lisp src-to-be/pcl/walk.lisp
--- src/pcl/walk.lisp	Sat Jan 18 15:31:59 1997
+++ src-to-be/pcl/walk.lisp	Mon Nov  9 20:09:18 1998
@@ -37,6 +37,10 @@
 ;;; do.  Maybe it will grow up someday.
 ;;;
 
+(ext:file-comment
+  "$Header$")
+
+
 ;;;
 ;;; This code walker used to be completely portable.  Now it is just "Real
 ;;; easy to port".  This change had to happen because the hack that made it
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/tools/clmcom.lisp src-to-be/tools/clmcom.lisp
--- src/tools/clmcom.lisp	Tue Nov  4 17:29:36 1997
+++ src-to-be/tools/clmcom.lisp	Thu Dec 10 20:36:13 1998
@@ -74,23 +74,43 @@
     ("target:compile-motif.log")
 
   (with-compilation-unit
-      (:optimize '(optimize (speed 3) (ext:inhibit-warnings 3)
-			    #+small (safety 0)
-			    #+small (debug .5)))
+      (:optimize  #-high-security
+                  '(optimize (speed 3)
+		             (ext:inhibit-warnings 3)
+		            #+small (safety 0)
+			    #+small (debug .5))
+		  #+high-security
+		  '(optimize (speed 2)
+		             (ext:inhibit-warnings 0)
+		             (safety 3)
+			     (debug 3)))
     
     (dolist (f tk-internals-files)
       (comf f :load t)))
   
   (with-compilation-unit
       (:optimize
-       '(optimize (debug #-small 2 #+small .5) 
+       #-(or small high-security)
+       '(optimize (debug 2) 
 		  (speed 2) (inhibit-warnings 2)
-		  (safety #-small 1 #+small 0))
+		  (safety 1))
+       #+small
+       '(optimize (debug .5) 
+		  (speed 2) (inhibit-warnings 2)
+		  (safety 0))
+       #+high-security
+       '(optimize (debug 3) 
+		  (speed 2) (inhibit-warnings 0)
+		  (safety 3))
        :optimize-interface
-       '(optimize-interface (debug .5))
+       '(optimize-interface (debug #-high-security .5
+			           #+high-security 3))
        :context-declarations
        '(((:and :external :global)
-	  (declare (optimize-interface (safety 2) (debug 1))))
+	  #-high-security
+	  (declare (optimize-interface (safety 2) (debug 1)))
+	  #+high-security
+	  (declare (optimize-interface (safety 3) (debug 3))))
 	 ((:and :external :macro)
 	  (declare (optimize (safety 2))))
 	 (:macro (declare (optimize (speed 0))))))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/tools/clxcom.lisp src-to-be/tools/clxcom.lisp
--- src/tools/clxcom.lisp	Tue Nov  4 17:29:35 1997
+++ src-to-be/tools/clxcom.lisp	Thu Dec 10 20:37:54 1998
@@ -1,5 +1,8 @@
 (in-package "USER")
 
+(ext:file-comment
+  "$Header$")
+
 #+bootstrap
 (unless (find-package "OLD-XLIB")
   (when (find-package "XLIB")
@@ -18,11 +21,21 @@
 (with-compiler-log-file
     ("target:compile-clx.log"
      :optimize
-     '(optimize (debug #-small 2 #+small .5) 
+     #-(or small high-security)
+     '(optimize (debug 2) 
+		(speed 2) (inhibit-warnings 2)
+		(safety 1))
+     #+small
+     '(optimize (debug .5) 
 		(speed 2) (inhibit-warnings 2)
-		(safety #-small 1 #+small 0))
+		(safety 0))
+     #+high-security
+     '(optimize (debug 3) 
+		(speed 2) (inhibit-warnings 0)
+		(safety 3))
      :optimize-interface
-     '(optimize-interface (debug .5))
+     '(optimize-interface #-high-security (debug .5)
+                          #+high-security (debug 3))
      :context-declarations
      '(((:and :external :global)
 	(declare (optimize-interface (safety 2) (debug 1))))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/tools/comcom.lisp src-to-be/tools/comcom.lisp
--- src/tools/comcom.lisp	Thu Jan 22 01:01:03 1998
+++ src-to-be/tools/comcom.lisp	Thu Dec 10 19:37:28 1998
@@ -2,6 +2,9 @@
 ;;;
 (in-package "USER")
 
+(ext:file-comment
+  "$Header$")
+
 #+bootstrap
 (copy-packages (cons (c::backend-name c::*target-backend*) '("NEW-ASSEM" "C")))
 
@@ -22,21 +25,41 @@
 (with-compiler-log-file
     ("target:compile-compiler.log"
      :optimize
+     #-(or small high-security)
+     '(optimize (speed 2) (space 2) (inhibit-warnings 2)
+		(safety 1)
+		(debug 2))
+     #+small
      '(optimize (speed 2) (space 2) (inhibit-warnings 2)
-		(safety #+small 0 #-small 1)
-		(debug #+small .5 #-small 2))
+		(safety 0)
+		(debug .5))
+     #+high-security
+     '(optimize (speed 2) (space 2) (inhibit-warnings 0)
+		(safety 3)
+		(debug 3))
      :optimize-interface
-     '(optimize-interface (safety #+small 1 #-small 2)
-			  (debug #+small .5 #-small 2))
+     #-(or small high-security)
+     '(optimize-interface (safety 2)
+			  (debug 2))
+     #+small
+     '(optimize-interface (safety 1)
+       (debug .5))
+     #+high-security
+     '(optimize-interface (safety 3)
+                          (debug 3))
      :context-declarations
-     '(#+small
+     '(#+(or high-security small)
        ((:or :macro
 	     (:match "$SOURCE-TRANSFORM-" "$IR1-CONVERT-"
 		     "$PRIMITIVE-TRANSLATE-" "$PARSE-"))
-	(declare (optimize (safety 1))))
+	(declare (optimize (safety #+small 1
+				   #+high-security 3))))
        ((:or :macro (:match "$%PRINT-"))
 	(declare (optimize (speed 0))))
-       (:external (declare (optimize-interface (safety 2) (debug 1))))))
+       (:external #-high-security
+             	  (declare (optimize-interface (safety 2) (debug 1)))
+	          #+high-security
+	          (declare (optimize-interface (safety 3) (debug 3))))))
 
 
 (comf "target:compiler/macros"
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/tools/heapanal.lisp src-to-be/tools/heapanal.lisp
--- src/tools/heapanal.lisp	Mon Mar  1 19:48:40 1993
+++ src-to-be/tools/heapanal.lisp	Mon Nov  9 20:09:18 1998
@@ -7,6 +7,9 @@
 (use-package "ALIEN")
 (use-package "C-CALL")
 
+(ext:file-comment
+  "$Header$")
+
 
 ;;;; MACH primitives we need.
 
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/tools/hemcom.lisp src-to-be/tools/hemcom.lisp
--- src/tools/hemcom.lisp	Tue Nov  4 17:29:37 1997
+++ src-to-be/tools/hemcom.lisp	Thu Dec 10 20:50:12 1998
@@ -1,6 +1,8 @@
 ;;;
 ;;; This file compiles all of Hemlock.
 ;;;
+(ext:file-comment
+  "$Header$")
 
 #+bootstrap
 (progn
@@ -126,7 +128,12 @@
      '(optimize (safety 2) (speed 0))
      :context-declarations
      '(((:match "-COMMAND$")
-	(declare (optimize (safety #+small 0 #-small 1))
+	(declare (optimize #-(or high-security small)
+		           (safety 1)
+			   #+small
+		           (safety 0)
+			   #+high-security
+		           (safety 3))
 		 (optimize-interface (safety 2))))))
 
 (comf "target:hemlock/command" :byte-compile t)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/tools/pclcom.lisp src-to-be/tools/pclcom.lisp
--- src/tools/pclcom.lisp	Thu Jun 25 20:45:29 1998
+++ src-to-be/tools/pclcom.lisp	Thu Dec 10 21:41:20 1998
@@ -1,6 +1,9 @@
 
 (in-package "USER")
 
+(ext:file-comment
+  "$Header$")
+
 (when (find-package "PCL")
   ;; Load the lisp:documentation functions.
   (load "target:code/misc")
@@ -72,10 +75,20 @@
 (import 'kernel:funcallable-instance-p (find-package "PCL"))
 
 (with-compilation-unit
-    (:optimize '(optimize (debug #+small .5 #-small 2)
-			  (speed 2) (safety #+small 0 #-small 2)
+    (:optimize #-(or high-security small)
+               '(optimize (debug 2)
+			  (speed 2) (safety 2)
+			  (inhibit-warnings 2))
+	       #+small
+               '(optimize (debug .5)
+			  (speed 2) (safety 0)
 			  (inhibit-warnings 2))
-     :optimize-interface '(optimize-interface #+small (safety 1))
+	       #+high-security
+               '(optimize (debug 3)
+			  (speed 2) (safety 3)
+			  (inhibit-warnings 0))
+     :optimize-interface '(optimize-interface #+small (safety 1)
+			                      #+high-security (safety 3))
      :context-declarations
      '((:external (declare (optimize-interface (safety 2) (debug 1))))
        ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/tools/setup.lisp src-to-be/tools/setup.lisp
--- src/tools/setup.lisp	Thu Jun 16 02:08:52 1994
+++ src-to-be/tools/setup.lisp	Mon Nov  9 20:09:18 1998
@@ -5,6 +5,9 @@
 ;;;
 (in-package "USER")
 
+(ext:file-comment
+  "$Header$")
+
 
 ;;; DUMP-PACKAGE-STATE  --  Public
 ;;;
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/tools/worldbuild.lisp src-to-be/tools/worldbuild.lisp
--- src/tools/worldbuild.lisp	Fri May  1 03:21:42 1998
+++ src-to-be/tools/worldbuild.lisp	Mon Nov  9 20:09:19 1998
@@ -16,6 +16,12 @@
 
 (in-package "LISP")
 
+;;; Add for a linux worldbuild on FreeBSD.
+;(pushnew :freebsd (c::backend-misfeatures c:*backend*))
+;(pushnew :bsd (c::backend-misfeatures c:*backend*))
+;(pushnew :mp (c::backend-misfeatures c:*backend*))
+;(pushnew :linux (c::backend-%features c:*backend*))
+
 (unless (fboundp 'genesis)
   (load "target:compiler/generic/new-genesis"))
 
@@ -170,7 +176,13 @@
       #+(and mach sparc) "/usr/tmp/kernel.core"
       #-(and mach sparc) "target:lisp/kernel.core")
 (setf *genesis-c-header-name* "target:lisp/internals.h")
+#-linux
+(setf *genesis-symbol-table* "target:lisp/lisp.nm")
+#+linux
 (setf *genesis-symbol-table* "target:lisp/lisp.nm")
+#-linux
+(setf *genesis-map-name* "target:lisp/lisp.map")
+#+linux
 (setf *genesis-map-name* "target:lisp/lisp.map")
 
 (when (boundp '*target-page-size*)
diff --unified --ignore-matching-lines=$Header --recursive --new-file --exclude=CVS --speed-large-files src/tools/worldcom.lisp src-to-be/tools/worldcom.lisp
--- src/tools/worldcom.lisp	Sun Aug 30 06:55:03 1998
+++ src-to-be/tools/worldcom.lisp	Thu Dec 10 21:44:06 1998
@@ -20,16 +20,31 @@
 
 (with-compiler-log-file
     ("target:compile-lisp.log"
-     :optimize '(optimize (speed 2) (space 2) (inhibit-warnings 2)
-			  (debug #-small 2 #+small .5)
-			  (safety #-small 1 #+small 0))
-     :optimize-interface '(optimize-interface (safety #-small 2 #+small 1)
-					      #+small (debug .5))
+     :optimize #-(or high-security small)
+               '(optimize (speed 2) (space 2) (inhibit-warnings 2)
+			  (debug 2)
+			  (safety 1))
+	       #+small
+               '(optimize (speed 2) (space 2) (inhibit-warnings 2)
+			  (debug .5)
+			  (safety 0))
+	       #+high-security
+               '(optimize (speed 2) (space 2) (inhibit-warnings 2)
+			  (debug 3)
+			  (safety 3))
+     :optimize-interface '(optimize-interface #-(or hish-security small)
+			                      (safety 2)
+			                      #+small (safety 1)
+			                      #+high-security (safety 3)
+					      #+small (debug .5)
+			                      #+high-security (debug 3))
      :context-declarations
      '(((:or :external (:and (:match "%") (:match "SET"))
 	     (:member lisp::%put lisp::%rplaca lisp::%rplacd lisp::%puthash))
-	(declare (optimize-interface (safety 2) #+small (debug 1))
-		 #+small (optimize (debug 1))))
+	(declare (optimize-interface (safety 2) #+small (debug 1)
+				                #+high-security (debug 3))
+		 #+small (optimize (debug 1))
+	         #+high-security (optimize (debug 3))))
        ((:or (:and :external :macro)
 	     (:match "$PARSE-"))
 	(declare (optimize (safety 2))))
