diff --git a/code/commandline.lisp b/code/commandline.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..2ae87e6af6fb8aa3f18d03f2586ce7aad517d816
--- /dev/null
+++ b/code/commandline.lisp
@@ -0,0 +1,188 @@
+;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Stuff to eat the command line passed to us from the shell.
+;;; Written by Bill Chiles.
+;;;
+
+(in-package "EXTENSIONS")
+(export '(*command-line-words* *command-line-switches*
+	  *command-switch-demons* *command-line-utility-name*
+	  *command-line-strings* cmd-switch-string command-line-switch-p
+	  cmd-switch-name cmd-switch-value cmd-switch-words command-line-switch
+	  defswitch cmd-switch-arg get-command-line-switch))
+
+(defvar *command-line-switches* ()
+  "A list of cmd-switch's representing the arguments used to invoke
+  this process.")
+
+(defvar *command-line-utility-name* ""
+  "The string name that was used to invoke this process.")
+
+(defvar *command-line-words* ()
+  "A list of words between the utility name and the first switch.")
+
+(defvar *command-line-strings* ()
+  "A list of strings obtained from the command line that invoked this process.")
+
+(defvar *command-switch-demons* ()
+  "An Alist of (\"argument-name\" . demon-function)")
+
+
+
+(defstruct (command-line-switch (:conc-name cmd-switch-)
+				(:constructor make-cmd-switch
+					      (name value words))
+				(:print-function print-command-line-switch))
+  name         		;the name of the switch
+  value                 ;the value of that switch
+  words                 ;random words dangling between switches assigned to the
+                        ;preceeding switch
+  )
+
+(defun print-command-line-switch (object stream n)
+  (declare (ignore n))
+  (write-string "#<Command Line Switch " stream)
+  (prin1 (cmd-switch-name object) stream)
+  (let ((value (cmd-switch-value object))
+	(words (cmd-switch-words object)))
+    (when (or value words) (write-string " -- " stream)
+      (when value (prin1 value stream))
+      (when words (prin1 words stream))))
+  (write-string ">" stream))
+
+
+
+;;;; Processing the command strings.
+
+(defun process-command-strings ()
+  (setq *command-line-words* nil)
+  (setq *command-line-switches* nil)
+  (let ((cmd-strings lisp::lisp-command-line-list)
+	str)
+    (declare (special lisp::lisp-command-line-list))
+    ;; Set some initial variables.
+    ;; 
+    (setf *command-line-strings* (copy-list lisp::lisp-command-line-list))
+    (setf *command-line-utility-name* (pop cmd-strings))
+    (setq str (pop cmd-strings))
+    ;; Set initial command line words.
+    ;; 
+    (loop
+      (unless str (return nil))
+      (unless (zerop (length (the simple-string str)))
+	(when (char= (schar str 0) #\-) 
+	  (setq *command-line-words* (reverse *command-line-words*))
+	  (return nil))
+	(push str *command-line-words*))
+      (setq str (pop cmd-strings)))
+    ;; Set command line switches.
+    ;; 
+    (loop
+      (unless str
+	(return (setf *command-line-switches*
+		      (nreverse *command-line-switches*))))
+      (let* ((position (position #\= (the simple-string str) :test #'char=))
+	     (switch (subseq (the simple-string str) 1 position))
+	     (value (if position
+			(subseq (the simple-string str) (1+ position)
+				(length (the simple-string str))))))
+	(setq str (pop cmd-strings))
+	;; Set this switches words until the next switch.
+	;; 
+	(let (word-list)
+	  (loop
+	    (unless str
+	      (push (make-cmd-switch switch value (nreverse word-list))
+		    *command-line-switches*)
+	      (return nil))
+	    (unless (zerop (length (the simple-string str)))
+	      (when (char= #\- (schar str 0))
+		(push (make-cmd-switch switch value (nreverse word-list))
+		      *command-line-switches*)
+		(return nil))
+	      (push str word-list))
+	    (setq str (pop cmd-strings))))))))
+
+(defun get-command-line-switch (sname)
+  "Accepts the name of a switch as a string and returns the value of the
+   switch.  If no value was specified, then any following words are returned.
+   If there are no following words, then t is returned.  If the switch was not
+   specified, then nil is returned."
+  (let* ((name (if (char= (schar sname 0) #\-) (subseq sname 1) sname))
+	 (switch (find name *command-line-switches*
+		       :test #'string-equal
+		       :key #'cmd-switch-name)))
+    (when switch
+      (or (cmd-switch-value switch)
+	  (cmd-switch-words switch)
+	  T))))
+
+
+
+;;;; Defining Switches and invoking demons.
+
+(defvar *complain-about-illegal-switches* t
+  "When set, invoking switch demons complains about illegal switches that have
+   not been defined with DEFSWITCH.")
+
+;;; This is a list of legal switch names.  DEFSWITCH sets this, and
+;;; INVOKE-SWITCH-DEMONS makes sure all the switches it sees are on this
+;;; list.
+;;;
+(defvar *legal-cmd-line-switches* nil)
+
+;;; INVOKE-SWITCH-DEMONS cdrs down the list of *command-line-switches*.  For
+;;; each switch, it checks to see if there is a switch demon with the same
+;;; name.  If there is, then that demon is called as a function on the switch.
+;;;
+(defun invoke-switch-demons (&optional (switches *command-line-switches*)
+					 (demons *command-switch-demons*))
+  (dolist (switch switches t)
+    (let* ((name (cmd-switch-name switch))
+	   (demon (cdr (assoc name demons :test #'string-equal))))
+      (cond (demon (funcall demon switch))
+	    ((or (member name *legal-cmd-line-switches* :test #'string-equal)
+		 (not *complain-about-illegal-switches*)))
+	    (t (warn "~S is an illegal switch" switch))))))
+
+(defmacro defswitch (name &optional function)
+  "Associates function with the switch name in *command-switch-demons*.  Name
+   is a simple-string that does not begin with a hyphen, unless the switch name
+   really does begin with one.  Function is optional, but defining the switch
+   is necessary to keep invoking switch demons from complaining about illegal
+   switches.  This can be inhibited with *complain-about-illegal-switches*."
+  (let ((gname (gensym))
+	(gfunction (gensym)))
+    `(let ((,gname ,name)
+	   (,gfunction ,function))
+       (check-type ,gname simple-string)
+       (check-type ,gfunction (or symbol function) "a symbol or function")
+       (push ,gname *legal-cmd-line-switches*)
+       (when ,gfunction
+	 (push (cons ,gname ,gfunction) *command-switch-demons*)))))
+
+
+(defun eval-switch-demon (switch)
+  (eval (read-from-string (cmd-switch-arg switch))))
+(defswitch "eval" #'eval-switch-demon)
+
+(defun load-switch-demon (switch)
+  (load (cmd-switch-arg switch)))
+(defswitch "load" #'load-switch-demon)
+
+(defun cmd-switch-arg (switch)
+  (or (cmd-switch-value switch)
+      (car (cmd-switch-words switch))
+      (car *command-line-words*)))
+
+(defswitch "core")
+(defswitch "init")
+(defswitch "noinit")
+(defswitch "hinit")
diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..703ff0d33ec7fdb26d0b939c48809a53a85ee53f
--- /dev/null
+++ b/code/fd-stream.lisp
@@ -0,0 +1,1291 @@
+;;; -*- Log: code.log; Package: LISP -*-
+
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Streams for UNIX file descriptors.
+;;;
+;;; Written by William Lott, July 1989 - January 1990.
+;;; 
+;;; **********************************************************************
+
+
+(in-package "SYSTEM")
+
+(export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
+	  beep *beep-function* 
+	  output-raw-bytes
+	  *tty* *stdin* *stdout* *stderr*))
+
+
+(in-package "EXTENSIONS")
+
+(export '(*backup-extension*))
+
+
+(in-package "LISP")
+
+(defmacro byte-blt (src-string src-start dst-string dst-start dst-end)
+  "Move the bytes from src-string to dst-string."
+  `(system:%primitive byte-blt
+		      ,src-string
+		      ,src-start
+		      ,dst-string
+		      ,dst-start
+		      ,dst-end))
+
+
+;;;; Buffer manipulation routines.
+
+(defvar *available-buffers* ()
+  "List of available buffers. Each buffer is an dynamic alien.")
+
+(defconstant bytes-per-buffer (* 4 1024)
+  "Number of bytes per buffer.")
+
+;;; NEXT-AVAILABLE-BUFFER -- Internal.
+;;;
+;;; Returns the next available alien buffer, creating one if necessary.
+;;;
+(proclaim '(inline next-available-buffer))
+;;;
+(defun next-available-buffer ()
+  (if *available-buffers*
+      (pop *available-buffers*)
+      (system:make-alien 'alien (* bytes-per-buffer 8))))
+
+
+
+;;;; The FD-STREAM structure.
+
+(defstruct (fd-stream
+	    (:print-function %print-fd-stream)
+	    (:constructor %make-fd-stream)
+	    (:include stream
+		      (misc #'fd-stream-misc-routine)))
+
+  (name nil)		      ; The name of this stream
+  (file nil)		      ; The file this stream is for
+  (original nil)	      ; The original file (for :if-exists :rename)
+  (delete-original nil)	      ; for :if-exists :rename-and-delete
+  (element-size 1)	      ; Number of bytes per element.
+  (element-type 'string-char) ; The type of element being transfered.
+  (fd -1 :type fixnum)	      ; The file descriptor
+  (buffering :full)	      ; One of :none, :line, or :full
+  (char-pos nil)	      ; Character position if known.
+  (listen nil)		      ; T if we don't need to listen
+
+  ;; The input buffer.
+  (unread nil)
+  (ibuf nil)
+  (ibuf-sap nil)
+  (ibuf-length nil)
+  (ibuf-head 0 :type fixnum)
+  (ibuf-tail 0 :type fixnum)
+
+  ;; The output buffer.
+  (obuf nil)
+  (obuf-sap nil)
+  (obuf-length nil)
+  (obuf-tail 0 :type fixnum)
+
+  ;; Output flushed, but not written due to non-blocking io.
+  (output-later nil)
+  (handler nil))
+
+(defun %print-fd-stream (fd-stream stream depth)
+  (declare (ignore depth))
+  (format stream "#<Stream for ~A>"
+	  (fd-stream-name fd-stream)))
+
+
+
+;;;; Output routines and related noise.
+
+(defvar *output-routines* ()
+  "List of all available output routines. Each element is a list of the
+  element-type output, the kind of buffering, the function name, and the number
+  of bytes per element.")
+
+;;; DO-OUTPUT-LATER -- internal
+;;;
+;;;   Called by the server when we can write to the given file descriptor.
+;;; Attemt to write the data again. If it worked, remove the data from the
+;;; output-later list. If it didn't work, something is wrong.
+;;;
+(defun do-output-later (stream)
+  (let* ((stuff (pop (fd-stream-output-later stream)))
+	 (base (car stuff))
+	 (start (cadr stuff))
+	 (end (caddr stuff))
+	 (buffer (cadddr stuff))
+	 (length (- end start)))
+    (multiple-value-bind
+	(count errno)
+	(mach:unix-write (fd-stream-fd stream)
+			 base
+			 start
+			 length)
+      (cond ((eql count length) ; Hot damn, it workded.
+	     (when buffer
+	       (push buffer *available-buffers*)))
+	    ((not (null count)) ; Sorta worked.
+	     (push (list base
+			 (+ start count)
+			 end
+			 buffer)
+		   (fd-stream-output-later stream)))
+	    ((= errno mach:ewouldblock)
+	     (error "Write would have blocked, but SERVER told us to go."))
+	    (t
+	     (error "While writing ~S: ~A"
+		    stream
+		    (mach:get-unix-error-msg errno))))))
+  (unless (fd-stream-output-later stream)
+    (system:remove-fd-handler (fd-stream-handler stream))
+    (setf (fd-stream-handler stream) nil)))
+
+;;; OUTPUT-LATER -- internal
+;;;
+;;;   Arange to output the string when we can write on the file descriptor.
+;;;
+(defun output-later (stream base start end buffer)
+  (cond ((null (fd-stream-output-later stream))
+	 (setf (fd-stream-output-later stream)
+	       (list (list base start end buffer)))
+	 (setf (fd-stream-handler stream)
+	       (system:add-fd-handler (fd-stream-fd stream)
+				      :output
+				      #'(lambda (fd)
+					  (declare (ignore fd))
+					  (do-output-later stream)))))
+	(t
+	 (nconc (fd-stream-output-later stream)
+		(list (list base start end buffer)))))
+  (when buffer
+    (let ((new-buffer (next-available-buffer)))
+      (setf (fd-stream-obuf stream) new-buffer)
+      (setf (fd-stream-obuf-sap stream)
+	    (system:alien-sap new-buffer))
+      (setf (fd-stream-obuf-length stream)
+	    (/ (system:alien-size new-buffer) 8)))))
+
+;;; DO-OUTPUT -- internal
+;;;
+;;;   Output the given noise. Check to see if there are any pending writes. If
+;;; so, just queue this one. Otherwise, try to write it. If this would block,
+;;; queue it.
+;;;
+(defun do-output (stream base start end buffer)
+  (if (not (null (fd-stream-output-later stream))) ; something buffered.
+    (progn
+      (output-later stream base start end buffer)
+      ;; XXX check to see if any of this noise can be output
+      )
+    (let ((length (- end start)))
+      (multiple-value-bind
+	  (count errno)
+	  (mach:unix-write (fd-stream-fd stream) base start length)
+	(cond ((eql count length)) ; Hot damn, it worked.
+	      ((not (null count))
+	       (output-later stream base (+ start count) end buffer))
+	      ((= errno mach:ewouldblock)
+	       (output-later stream base start end buffer))
+	      (t
+	       (error "While writing ~S: ~A"
+		      stream
+		      (mach:get-unix-error-msg errno))))))))
+
+;;; FLUSH-OUTPUT-BUFFER -- internal
+;;;
+;;;   Flush any data in the output buffer.
+;;;
+(defun flush-output-buffer (stream)
+  (let ((length (fd-stream-obuf-tail stream)))
+    (unless (= length 0)
+      (do-output stream
+		 (fd-stream-obuf-sap stream)
+		 0
+		 length
+		 (fd-stream-obuf stream))
+      (setf (fd-stream-obuf-tail stream) 0))))
+
+;;; DEF-OUTPUT-ROUTINES -- internal
+;;;
+;;;   Define output routines that output numbers size bytes long for the
+;;; given bufferings. Use body to do the actual output.
+;;;
+(defmacro def-output-routines ((name size &rest bufferings) &body body)
+  (cons 'progn
+	(mapcar
+	    #'(lambda (buffering)
+		(let ((function
+		       (intern (let ((*print-case* :upcase))
+				 (format nil name (car buffering))))))
+		  `(progn
+		     (defun ,function (stream byte)
+		       ,(unless (eq (car buffering) :none)
+			  `(when (< (fd-stream-obuf-length stream)
+				    (+ (fd-stream-obuf-tail stream)
+				       ,size))
+			     (flush-output-buffer stream)))
+		       ,@body
+		       (incf (fd-stream-obuf-tail stream) ,size)
+		       ,(ecase (car buffering)
+			  (:none
+			   `(flush-output-buffer stream))
+			  (:line
+			   `(when (eq (char-code byte) (char-code #\Newline))
+			      (flush-output-buffer stream)))
+			  (:full
+			   ))
+		       (values))
+		     (setf *output-routines*
+			   (nconc *output-routines*
+				  ',(mapcar
+					#'(lambda (type)
+					    (list type
+						  (car buffering)
+						  function
+						  size))
+				      (cdr buffering)))))))
+	  bufferings)))
+
+(def-output-routines ("OUTPUT-BYTE-~A-BUFFERED"
+		      1
+		      (:none (signed-byte 8) (unsigned-byte 8) string-char)
+		      (:line string-char)
+		      (:full (signed-byte 8) (unsigned-byte 8) string-char))
+  (when (characterp byte)
+    (if (eq (char-code byte)
+	    (char-code #\Newline))
+      (setf (fd-stream-char-pos stream) 0)
+      (incf (fd-stream-char-pos stream))))
+  (system:%primitive 8bit-system-set
+		     (fd-stream-obuf-sap stream)
+		     (fd-stream-obuf-tail stream)
+		     byte))
+
+(def-output-routines ("OUTPUT-SHORT-~A-BUFFERED"
+		      2
+		      (:none (signed-byte 16) (unsigned-byte 16))
+		      (:full (signed-byte 16) (unsigned-byte 16)))
+  (system:%primitive 16bit-system-set
+		     (fd-stream-obuf-sap stream)
+		     (/ (fd-stream-obuf-tail stream) 2)
+		     byte))
+(def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
+		      4
+		      (:none (signed-byte 32))
+		      (:full (signed-byte 32)))
+  (system:%primitive signed-32bit-system-set
+		     (fd-stream-obuf-sap stream)
+		     (/ (fd-stream-obuf-tail stream) 2)
+		     byte))
+; XXX What? no unsigned-32bit-system-set?
+(def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
+		      4
+		      (:none (unsigned-byte 31))
+		      (:full (unsigned-byte 31)))
+  (system:%primitive signed-32bit-system-set
+		     (fd-stream-obuf-sap stream)
+		     (/ (fd-stream-obuf-tail stream) 2)
+		     byte))
+
+;;; OUTPUT-RAW-BYTES -- public
+;;;
+;;;   Does the actual output. If there is space to buffer the string, buffer
+;;; it. If the string would normally fit in the buffer, but doesn't because
+;;; of other stuff in the buffer, flush the old noise out of the buffer and
+;;; put the string in it. Otherwise we have a very long string, so just
+;;; send it directly (after flushing the buffer, of course).
+;;;
+(defun output-raw-bytes (stream thing &optional start end)
+  "Output THING to stream.  THING can be any kind of vector or a sap.  If THING
+  is a SAP, END must be supplied (as length won't work)."
+  (let ((start (or start 0))
+	(end (or end (length thing))))
+    (declare (fixnum start end))
+    (let* ((len (fd-stream-obuf-length stream))
+	   (tail (fd-stream-obuf-tail stream))
+	   (space (- len tail))
+	   (bytes (- end start))
+	   (newtail (+ tail bytes)))
+      (cond ((minusp bytes) ; Error case
+	     (cerror "Just go on as if nothing happened..."
+		     "~S called with :END before :START!"
+		     'output-raw-bytes))
+	    ((zerop bytes)) ; Easy case
+	    ((<= bytes space)
+	     (byte-blt thing start (fd-stream-obuf-sap stream) tail newtail)
+	     (setf (fd-stream-obuf-tail stream) newtail))
+	    ((<= bytes len)
+	     (flush-output-buffer stream)
+	     (byte-blt thing start (fd-stream-obuf-sap stream) 0 bytes)
+	     (setf (fd-stream-obuf-tail stream) bytes))
+	    (t
+	     (flush-output-buffer stream)
+	     (do-output stream thing start end nil))))))
+
+;;; FD-SOUT -- internal
+;;;
+;;;   Routine to use to output a string. If the stream is unbuffered, slam
+;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to
+;;; buffer the string. Update charpos by checking to see where the last newline
+;;; was.
+;;;
+;;;   Note: some bozos (the FASL dumper) call write-string with things other
+;;; than strings. Therefore, we must make sure we have a string before calling
+;;; position on it.
+;;; 
+(defun fd-sout (stream thing start end)
+  (let ((start (or start 0))
+	(end (or end (length thing))))
+    (declare (fixnum start end))
+    (if (stringp thing)
+      (let ((last-newline (and (find #\newline (the simple-string thing)
+				     :start start :end end)
+			       (position #\newline (the simple-string thing)
+					    :from-end t
+					    :start start
+					    :end end))))
+	(ecase (fd-stream-buffering stream)
+	  (:full
+	   (output-raw-bytes stream thing start end))
+	  (:line
+	   (output-raw-bytes stream thing start end)
+	   (when last-newline
+	     (flush-output-buffer stream)))
+	  (:none
+	   (do-output stream thing start end nil)))
+	(if last-newline
+	  (setf (fd-stream-char-pos stream)
+		(- end last-newline 1))
+	  (incf (fd-stream-char-pos stream)
+		(- end start))))
+      (ecase (fd-stream-buffering stream)
+	((:line :full)
+	 (output-raw-bytes stream thing start end))
+	(:none
+	 (do-output stream thing start end nil))))))
+
+;;; PICK-OUTPUT-ROUTINE -- internal
+;;;
+;;;   Find an output routine to use given the type and buffering. Return as
+;;; multiple values the routine, the real type transfered, and the number of
+;;; bytes per element.
+;;;
+(defun pick-output-routine (type buffering)
+  (dolist (entry *output-routines*)
+    (when (and (subtypep type (car entry))
+	       (eq buffering (cadr entry)))
+      (return (values (symbol-function (caddr entry))
+		      (car entry)
+		      (cadddr entry))))))
+
+
+;;;; Input routines and related noise.
+
+(defvar *input-routines* ()
+  "List of all available input routines. Each element is a list of the
+  element-type input, the function name, and the number of bytes per element.")
+
+;;; DO-INPUT -- internal
+;;;
+;;;   Fills the input buffer, and returns the first character. Throws to
+;;; eof-input-catcher if the eof was reached. Drops into system:server if
+;;; necessary.
+;;;
+(defun do-input (stream)
+  (let ((fd (fd-stream-fd stream))
+	(ibuf-sap (fd-stream-ibuf-sap stream))
+	(buflen (fd-stream-ibuf-length stream))
+	(head (fd-stream-ibuf-head stream))
+	(tail (fd-stream-ibuf-tail stream)))
+    (unless (zerop head)
+      (cond ((eq head tail)
+	     (setf head 0)
+	     (setf tail 0)
+	     (setf (fd-stream-ibuf-head stream) 0)
+	     (setf (fd-stream-ibuf-tail stream) 0))
+	    (t
+	     (decf tail head)
+	     (byte-blt ibuf-sap head ibuf-sap 0 tail)
+	     (setf head 0)
+	     (setf (fd-stream-ibuf-head stream) 0)
+	     (setf (fd-stream-ibuf-tail stream) tail))))
+    (setf (fd-stream-listen stream) nil)
+    (multiple-value-bind
+	(count errno)
+	(mach:unix-select (1+ fd) (ash 1 fd) 0 0 0)
+      (case count
+	(1)
+	(0
+	 (system:wait-until-fd-usable fd :input))
+	(t
+	 (error "Problem checking to see if ~S is readable: ~A"
+		stream
+		(mach:get-unix-error-msg errno)))))
+    (multiple-value-bind
+	(count errno)
+	(mach:unix-read fd
+			(system:int-sap (+ (system:sap-int ibuf-sap) tail))
+			(- buflen tail))
+      (cond ((null count)
+	     (if (eql errno mach:ewouldblock)
+	       (progn
+		 (system:wait-until-fd-usable fd :input)
+		 (do-input stream))
+	       (error "Error reading ~S: ~A"
+		      stream
+		      (mach:get-unix-error-msg errno))))
+	    ((zerop count)
+	     (throw 'eof-input-catcher nil))
+	    (t
+	     (incf (fd-stream-ibuf-tail stream) count))))))
+			
+;;; INPUT-AT-LEAST -- internal
+;;;
+;;;   Makes sure there are at least ``bytes'' number of bytes in the input
+;;; buffer. Keeps calling do-input until that condition is met.
+;;;
+(defmacro input-at-least (stream bytes)
+  (let ((stream-var (gensym))
+	(bytes-var (gensym)))
+    `(let ((,stream-var ,stream)
+	   (,bytes-var ,bytes))
+       (loop
+	 (when (>= (- (fd-stream-ibuf-tail ,stream-var)
+		      (fd-stream-ibuf-head ,stream-var))
+		   ,bytes-var)
+	   (return))
+	 (do-input ,stream-var)))))
+
+;;; INPUT-WRAPPER -- intenal
+;;;
+;;;   Macro to wrap around all input routines to handle eof-error noise. This
+;;; should make provisions for filling stream-in-buffer.
+;;;
+(defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
+  (let ((stream-var (gensym))
+	(element-var (gensym)))
+    `(let ((,stream-var ,stream))
+       (if (fd-stream-unread ,stream)
+	 (prog1
+	     (fd-stream-unread ,stream)
+	   (setf (fd-stream-unread ,stream) nil))
+	 (let ((,element-var
+		(catch 'eof-input-catcher
+		  (input-at-least ,stream-var ,bytes)
+		  ,@read-forms)))
+	   (cond (,element-var
+		  (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
+		  ,element-var)
+		 (,eof-error
+		  (error "EOF while reading ~S" stream))
+		 (t
+		  ,eof-value)))))))
+
+;;; DEF-INPUT-ROUTINE -- internal
+;;;
+;;;   Defines an input routine.
+;;;
+(defmacro def-input-routine (name
+			     (type size sap head)
+			     &rest body)
+  `(progn
+     (defun ,name (stream eof-error eof-value)
+       (input-wrapper (stream ,size eof-error eof-value)
+	 (let ((,sap (fd-stream-ibuf-sap stream))
+	       (,head (fd-stream-ibuf-head stream)))
+	   ,@body)))
+     (setf *input-routines*
+	   (nconc *input-routines*
+		  (list (list ',type ',name ',size))))))
+
+;;; INPUT-STRING-CHAR -- internal
+;;;
+;;;   Routine to use in stream-in slot for reading string chars.
+;;;
+(def-input-routine input-string-char
+		   (string-char 1 sap head)
+  (system:%primitive make-immediate-type
+		     (system:%primitive 8bit-system-ref sap head)
+		     ; XXX character-type, should be a constant.
+		     27))
+
+;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
+;;;
+;;;   Routine to read in an unsigned 8 bit number.
+;;;
+(def-input-routine input-unsigned-8bit-byte
+		   ((unsigned-byte 8) 1 sap head)
+  (system:%primitive 8bit-system-ref sap head))
+
+;;; INPUT-SIGNED-8BIT-BYTE -- internal
+;;;
+;;;   Routine to read in a signed 8 bit number.
+;;;
+(def-input-routine input-signed-8bit-number
+		   ((signed-byte 8) 1 sap head)
+  (let ((byte (system:%primitive 8bit-system-ref sap head)))
+    (if (logand byte #x80)
+      (- byte #x100)
+      byte)))
+
+;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
+;;;
+;;;   Routine to read in an unsigned 16 bit number.
+;;;
+(def-input-routine input-unsigned-16bit-byte
+		   ((unsigned-byte 16) 2 sap head)
+  (system:%primitive 16bit-system-ref
+		     sap
+		     (/ head 2)))
+
+;;; INPUT-SIGNED-16BIT-BYTE -- internal
+;;;
+;;;   Routine to read in a signed 16 bit number.
+;;;
+(def-input-routine input-signed-16bit-byte
+		   ((signed-byte 16) 2 sap head)
+  (system:%primitive signed-16bit-system-ref
+		     sap
+		     (/ head 2)))
+
+;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
+;;;
+;;;   Routine to read in a unsigned 32 bit number.
+;;;
+(def-input-routine input-unsigned-32bit-byte
+		   ((unsigned-byte 32) 4 sap head)
+  (system:%primitive unsigned-32bit-system-ref
+		     sap
+		     (/ head 2)))
+
+;;; INPUT-SIGNED-32BIT-BYTE -- internal
+;;;
+;;;   Routine to read in a signed 32 bit number.
+;;;
+(def-input-routine input-signed-32bit-byte
+		   ((signed-byte 32) 4 sap head)
+  (system:%primitive signed-32bit-system-ref
+		     sap
+		     (/ head 2)))
+
+;;; PICK-INPUT-ROUTINE -- internal
+;;;
+;;;   Find an input routine to use given the type. Return as multiple values
+;;; the routine, the real type transfered, and the number of bytes per element.
+;;;
+(defun pick-input-routine (type)
+  (dolist (entry *input-routines*)
+    (when (subtypep type (car entry))
+      (return (values (symbol-function (cadr entry))
+		      (car entry)
+		      (caddr entry))))))
+
+;;; STRING-FROM-SAP -- internal
+;;;
+;;;   Returns a string constructed from the sap, start, and end.
+;;;
+(defun string-from-sap (sap start end)
+  (let* ((length (- end start))
+	 (string (make-string length)))
+    (byte-blt sap start string 0 length)
+    string))
+
+;;; FD-STREAM-READ-LINE -- internal
+;;;
+;;;   Reads a line, returning a simple string. Note: this relies on the fact
+;;; that the input buffer does not change during do-input.
+;;;
+(defun fd-stream-read-line (stream eof-error-p eof-value)
+  (let ((eof t))
+    (values
+     (or (let ((sap (fd-stream-ibuf-sap stream))
+	       (results (if (fd-stream-unread stream)
+			  (prog1
+			      (string (fd-stream-unread stream))
+			    (setf (fd-stream-unread stream) nil)))))
+	   (catch 'eof-input-catcher
+	     (loop
+	       (input-at-least stream 1)
+	       (let* ((head (fd-stream-ibuf-head stream))
+		      (tail (fd-stream-ibuf-tail stream))
+		      (newline (system:%primitive find-character
+						  sap
+						  head
+						  tail
+						  #\Newline))
+		      (end (or newline tail)))
+		 (push (string-from-sap sap head end)
+		       results)
+
+		 (when newline
+		   (setf eof nil)
+		   (setf (fd-stream-ibuf-head stream)
+			 (1+ newline))
+		   (return))
+		 (setf (fd-stream-ibuf-head stream) end))))
+	   (cond ((null results)
+		  nil)
+		 ((null (cdr results))
+		  (car results))
+		 (t
+		  (apply #'concatenate 'simple-string (nreverse results)))))
+	 (if eof-error-p
+	   (error "EOF while reading ~S" stream)
+	   eof-value))
+     eof)))
+
+
+;;; FD-STREAM-READ-N-BYTES -- internal
+;;;
+;;; The n-bin routine.
+;;; 
+(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
+  (let* ((sap (fd-stream-ibuf-sap stream))
+	 (elsize (fd-stream-element-size stream))
+	 (offset (* elsize start))
+	 (bytes (* elsize requested))
+	 (result (catch 'eof-input-catcher
+		   (loop
+		     (input-at-least stream 1)
+		     (let* ((head (fd-stream-ibuf-head stream))
+			    (tail (fd-stream-ibuf-tail stream))
+			    (available (- tail head))
+			    (copy (min available bytes)))
+		       (byte-blt sap head buffer offset (+ offset copy))
+		       (incf (fd-stream-ibuf-head stream) copy)
+		       (incf offset copy)
+		       (decf bytes copy))
+		     (when (zerop bytes)
+		       (return requested))))))
+    (cond (result)
+	  ((not eof-error-p)
+	   (- requested (/ bytes elsize)))
+	  (t
+	   (error "Hit eof on ~S after reading ~D ~D~2:*-bit byte~P~*, ~
+		   but ~D~2:* ~D-bit byte~P~:* ~[were~;was~:;were~] requested."
+		  stream
+		  (- requested (/ bytes elsize))
+		  (* elsize 8)
+		  requested)))))
+
+
+;;;; Utility functions (misc routines, etc)
+
+;;; SET-ROUTINES -- internal
+;;;
+;;;   Fill in the various routine slots for the given type. Input-p and output-p
+;;; indicate what slots to fill. The buffering slot must be set prior to
+;;; calling this routine.
+;;;
+(defun set-routines (stream type input-p output-p)
+  (let ((target-type (case type
+		       ((:default unsigned-byte)
+			'(unsigned-byte 8))
+		       (signed-byte
+			'(signed-byte 8))
+		       (t
+			type)))
+	(input-type nil)
+	(output-type nil)
+	(input-size nil)
+	(output-size nil))
+    
+    (when (fd-stream-obuf stream)
+      (push (fd-stream-obuf stream) *available-buffers*)
+      (setf (fd-stream-obuf stream) nil))
+    (when (fd-stream-ibuf stream)
+      (push (fd-stream-ibuf stream) *available-buffers*)
+      (setf (fd-stream-ibuf stream) nil))
+    
+    (when input-p
+      (multiple-value-bind
+	  (routine type size)
+	  (pick-input-routine target-type)
+	(unless routine
+	  (error "Could not find any input routine for ~S" target-type))
+	(setf (fd-stream-ibuf stream)
+	      (next-available-buffer))
+	(setf (fd-stream-ibuf-sap stream)
+	      (system:alien-sap (fd-stream-ibuf stream)))
+	(setf (fd-stream-ibuf-length stream)
+	      (/ (system:alien-size (fd-stream-ibuf stream)) 8))
+	(setf (fd-stream-ibuf-tail stream)
+	      0)
+	(if (subtypep type 'character)
+	  (setf (fd-stream-in stream) routine
+		(fd-stream-bin stream) #'ill-bin
+		(fd-stream-n-bin stream) #'ill-bin)
+	  (setf (fd-stream-in stream) #'ill-in
+		(fd-stream-bin stream) routine
+		(fd-stream-n-bin stream) #'fd-stream-read-n-bytes))
+	(setf input-size size)
+	(setf input-type type)))
+
+    (when output-p
+      (multiple-value-bind
+	  (routine type size)
+	  (pick-output-routine target-type (fd-stream-buffering stream))
+	(unless routine
+	  (error "Could not find any output routine for ~S buffered ~S."
+		 (fd-stream-buffering stream)
+		 target-type))
+	(setf (fd-stream-obuf stream) (next-available-buffer))
+	(setf (fd-stream-obuf-sap stream)
+	      (system:alien-sap (fd-stream-obuf stream)))
+	(setf (fd-stream-obuf-length stream)
+	      (/ (system:alien-size (fd-stream-obuf stream)) 8))
+	(setf (fd-stream-obuf-tail stream) 0)
+	(if (subtypep type 'character)
+	  (setf (fd-stream-out stream) routine
+		(fd-stream-bout stream) #'ill-bout)
+	  (setf (fd-stream-out stream)
+		(or (if (eql size 1)
+		      (pick-output-routine 'string-char
+					   (fd-stream-buffering stream)))
+		    #'ill-out)
+		(fd-stream-bout stream) routine))
+	(setf (fd-stream-sout stream)
+	      (if (eql size 1) #'fd-sout #'ill-out))
+	(setf (fd-stream-char-pos stream) 0)
+	(setf output-size size)
+	(setf output-type type)))
+
+    (when (and input-size output-size
+	       (not (eq input-size output-size)))
+      (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
+	     input-type input-size
+	     output-type output-size))
+    (setf (fd-stream-element-size stream)
+	  (or input-size output-size))
+
+    (setf (fd-stream-element-type stream)
+	  (cond ((equal input-type output-type)
+		 input-type)
+		((subtypep input-type output-type)
+		 input-type)
+		((subtypep output-type input-type)
+		 output-type)
+		(t
+		 (error "Input type (~S) and output type (~S) are unrelated?"
+			input-type
+			output-type))))))
+
+;;; FD-STREAM-MISC-ROUTINE -- input
+;;;
+;;;   Handle the various misc operations on fd-stream.
+;;;
+(defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
+  (case operation
+    (:read-line
+     (fd-stream-read-line stream arg1 arg2))
+    (:listen
+     (or (not (eql (fd-stream-ibuf-head stream)
+		   (fd-stream-ibuf-tail stream)))
+	 (fd-stream-listen stream)
+	 (setf (fd-stream-listen stream)
+	       (not (zerop (mach:unix-select (1+ (fd-stream-fd stream))
+					     (ash 1 (fd-stream-fd stream))
+					     0
+					     0
+					     0))))))
+    (:unread
+     (setf (fd-stream-unread stream) arg1))
+    (:close
+     (cond (arg1
+	    ;; We got us an abort on our hands.
+	    (when (and (fd-stream-file stream)
+		       (fd-stream-obuf stream))
+	      ;; Can't do anything unless we know what file were dealing with,
+	      ;; and we don't want to do anything strange unless we were
+	      ;; writing to the file.
+	      (if (fd-stream-original stream)
+		  ;; Have an handle on the original, just revert.
+		  (multiple-value-bind
+		      (okay err)
+		      (mach:unix-rename (fd-stream-original stream)
+					(fd-stream-file stream))
+		    (unless okay
+		      (cerror "Go on as if nothing bad happened."
+		        "Could not restore ~S to it's original contents: ~A"
+			      (fd-stream-file stream)
+			      (mach:get-unix-error-msg err))))
+		  ;; Can't restore the orignal, so nuke that puppy.
+		  (multiple-value-bind
+		      (okay err)
+		      (mach:unix-unlink (fd-stream-file stream))
+		    (unless okay
+		      (cerror "Go on as if nothing bad happened."
+			      "Could not remove ~S: ~A"
+			      (fd-stream-file stream)
+			      (mach:get-unix-error-msg err)))))))
+	   (t
+	    (fd-stream-misc-routine stream :finish-output)
+	    (when (and (fd-stream-original stream)
+		       (fd-stream-delete-original stream))
+	      (multiple-value-bind
+		  (okay err)
+		  (mach:unix-unlink (fd-stream-original stream))
+		(unless okay
+		  (cerror "Go on as if nothing bad happened."
+			  "Could not delete ~S during close of ~S: ~A"
+			  (fd-stream-original stream)
+			  stream
+			  (mach:get-unix-error-msg err)))))))
+     (mach:unix-close (fd-stream-fd stream))
+     (when (fd-stream-obuf stream)
+       (push (fd-stream-obuf stream) *available-buffers*)
+       (setf (fd-stream-obuf stream) nil))
+     (when (fd-stream-ibuf stream)
+       (push (fd-stream-ibuf stream) *available-buffers*)
+       (setf (fd-stream-ibuf stream) nil))
+     (lisp::set-closed-flame stream))
+    (:clear-input)
+    (:force-output
+     (flush-output-buffer stream))
+    (:finish-output
+     (flush-output-buffer stream)
+     (do ()
+	 ((null (fd-stream-output-later stream)))
+       (system:serve-all-events)))
+    (:element-type
+     (fd-stream-element-type stream))
+    (:line-length
+     80)
+    (:charpos
+     (fd-stream-char-pos stream))
+    (:file-length
+     (multiple-value-bind
+	 (okay dev ino mode nlink uid gid rdev size
+	       atime mtime ctime blksize blocks)
+	 (mach:unix-fstat (fd-stream-fd stream))
+       (declare (ignore ino nlink uid gid rdev
+			atime mtime ctime blksize blocks))
+       (unless okay
+	 (error "Error fstating ~S: ~A"
+		stream
+		(mach:get-unix-error-msg dev)))
+       (if (zerop mode)
+	 nil
+	 (/ size (fd-stream-element-size stream)))))
+    (:file-position
+     (fd-stream-file-position stream arg1))
+    (:file-name
+     (fd-stream-file stream))))
+
+;;; FD-STREAM-FILE-POSITION -- internal.
+;;;
+(defun fd-stream-file-position (stream &optional newpos)
+  (if (null newpos)
+      (system:without-interrupts
+	;; First, find the position of the UNIX file descriptor in the
+	;; file.
+	(multiple-value-bind
+	    (posn errno)
+	    (mach:unix-lseek (fd-stream-fd stream) 0 mach:l_incr)
+	  (cond ((numberp posn)
+		 ;; Adjust for buffered output:
+		 ;;  If there is any output buffered, the *real* file position
+		 ;; will be larger than reported by lseek because lseek
+		 ;; obviously cannot take into account output we have not
+		 ;; sent yet.
+		 (dolist (later (fd-stream-output-later stream))
+		   (incf posn (- (caddr later) (cadr later))))
+		 (incf posn (fd-stream-obuf-tail stream))
+		 ;; Adjust for unread input:
+		 ;;  If there is any input read from UNIX but not supplied to
+		 ;; the user of the stream, the *real* file position will
+		 ;; smaller than reported, because we want to look like the
+		 ;; unread stuff is still available.
+		 (decf posn (- (fd-stream-ibuf-tail stream)
+			       (fd-stream-ibuf-head stream)))
+		 (when (fd-stream-unread stream)
+		   (decf posn))
+		 ;; Divide bytes by element size.
+		 (/ posn (fd-stream-element-size stream)))
+		((eq errno mach:espipe)
+		 nil)
+		(t
+		 (system:with-interrupts
+		   (error "Error lseek'ing ~S: ~A"
+			  stream
+			  (mach:get-unix-error-msg errno)))))))
+      (let (offset origin)
+	;; Make sure we don't have any output pending, because if we move the
+	;; file pointer before writing this stuff, it will be written in the
+	;; wrong location.
+	(flush-output-buffer stream)
+	(do ()
+	    ((null (fd-stream-output-later stream)))
+	  (system:serve-all-events))
+	(cond ((eq newpos :start)
+	       (setf offset 0 origin mach:l_set))
+	      ((eq newpos :end)
+	       (setf offset 0 origin mach:l_xtnd))
+	      ((numberp newpos)
+	       (setf offset (* newpos (fd-stream-element-size stream))
+		     origin mach:l_set))
+	      (t
+	       (error "Invalid position given to file-position: ~S" newpos)))
+	(multiple-value-bind
+	    (posn errno)
+	    (mach:unix-lseek (fd-stream-fd stream) offset origin)
+	  (cond ((numberp posn)
+		 t)
+		((eq errno mach:espipe)
+		 nil)
+		(t
+		 (error "Error lseek'ing ~S: ~A"
+			stream
+			(mach:get-unix-error-msg errno))))))))
+
+
+
+;;;; Creation routines (MAKE-FD-STREAM and OPEN)
+
+;;; MAKE-FD-STREAM -- Public.
+;;;
+;;; Returns a FD-STREAM on the given file.
+;;;
+(defun make-fd-stream (fd
+		       &key
+		       (input nil input-p)
+		       (output nil output-p)
+		       (element-type 'string-char)
+		       (buffering :full)
+		       file
+		       original
+		       delete-original
+		       (name (if file
+				 (format nil "file ~S" file)
+				 (format nil "descriptor ~D" fd))))
+  "Create a stream for the given unix file descriptor.  If input is non-nil,
+   allow input operations.  If output is non-nil, allow output operations. If
+   neither input nor output are specified, default to allowing input.
+   element-type indicates the element type to use (as for open).  Buffering
+   indicates the kind of buffering to use (one of :none, :line, or :full). If
+   file is spesified, it should be the name of the file.  Name is used to
+   identify the stream when printed."
+  (cond ((not (or input-p output-p))
+	 (setf input t))
+	((not (or input output))
+	 (error "File descriptor must be opened either for input or output.")))
+  (let ((stream (%make-fd-stream :fd fd
+				 :name name
+				 :file file
+				 :original original
+				 :delete-original delete-original
+				 :buffering buffering)))
+    (set-routines stream element-type input output)
+    stream))
+
+;;; PICK-PACKUP-NAME -- internal
+;;;
+;;; Pick a name to use for the backup file.
+;;;
+(defvar *backup-extension* ".BAK"
+  "This is a string that OPEN tacks on the end of a file namestring to produce
+   a name for the :if-exists :rename-and-delete and :rename options.  Also,
+   this can be a function that takes a namestring and returns a complete
+   namestring.")
+;;;
+(defun pick-backup-name (name)
+  (etypecase *backup-extension*
+    (string (concatenate 'simple-string name *backup-extension*))
+    (function (funcall *backup-extension* name))))
+
+;;; ASSURE-ONE-OF -- internal
+;;;
+;;; Assure that the given arg is one of the given list of valid things.
+;;; Allow the user to fix any problems.
+;;; 
+(defun assure-one-of (item list what)
+  (unless (member item list)
+    (loop
+      (cerror "Enter new value for ~*~S"
+	      "~S is invalid for ~S. Must be one of~{ ~S~}"
+	      item
+	      what
+	      list)
+      (format *query-io* "Enter new value for ~S: " what)
+      (force-output *query-io*)
+      (setf item (read *query-io*))
+      (when (member item list)
+	(return))))
+  item)
+
+;;; OPEN -- public
+;;;
+;;;   Open the given file.
+;;;
+(defun open (filename
+	     &key
+	     (direction :input)
+	     (element-type 'string-char)
+	     (if-exists nil if-exists-given)
+	     (if-does-not-exist nil if-does-not-exist-given))
+  "Return a stream which reads from or writes to Filename.
+  Defined keywords:
+   :direction - one of :input, :output, :io, or :probe
+   :element-type - Type of object to read or write, default STRING-CHAR
+   :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
+                       :overwrite, :append, :supersede or nil
+   :if-does-not-exist - one of :error, :create or nil
+  See the manual for details."
+  ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
+  (setf direction
+	(assure-one-of direction
+		       '(:input :output :io :probe)
+		       :direction))
+
+  ;; Calculate useful stuff.
+  (multiple-value-bind
+      (input output mask)
+      (case direction
+	(:input (values t nil mach:o_rdonly))
+	(:output (values nil t mach:o_wronly))
+	(:io (values t t mach:o_rdwr))
+	(:probe (values nil nil mach:o_rdonly)))
+    (let* ((pathname (pathname filename))
+	   (namestring (predict-name pathname input)))
+      
+      ;; Process if-exists argument if we are doing any output.
+      (cond (output
+	     (unless if-exists-given
+	       (setf if-exists
+		     (if (eq (pathname-version pathname) :newest)
+		       :new-version
+		       :error)))
+	     (setf if-exists
+		   (assure-one-of if-exists
+				  '(:error :new-version :rename
+				    :rename-and-delete :overwrite
+				    :append :supersede nil)
+				  :if-exists))
+	     (case if-exists
+	       ((:error nil)
+		(setf mask (logior mask mach:o_excl)))
+	       ((:rename :rename-and-delete)
+		(setf mask (logior mask mach:o_creat)))
+	       ((:new-version :supersede)
+		(setf mask (logior mask mach:o_trunc)))
+	       (:append
+		(setf mask (logior mask mach:o_append)))))
+	    (t
+	     (setf if-exists :ignore-this-arg)))
+      
+      (unless if-does-not-exist-given
+	(setf if-does-not-exist
+	      (cond ((eq direction :input) :error)
+		    ((and output
+			  (member if-exists '(:overwrite :append)))
+		     :error)
+		    ((eq direction :probe)
+		     nil)
+		    (t
+		     :create))))
+      (setf if-does-not-exist
+	    (assure-one-of if-does-not-exist
+			   '(:error :create nil)
+			   :if-does-not-exist))
+      (if (eq if-does-not-exist :create)
+	(setf mask (logior mask mach:o_creat)))
+       
+      (let ((original (if (member if-exists
+				  '(:rename :rename-and-delete))
+			(pick-backup-name namestring)))
+	    (delete-original (eq if-exists :rename-and-delete))
+	    (mode #o666))
+	(when original
+	  ;; We are doing a :rename or :rename-and-delete.
+	  ;; Determine if the file already exists, make sure the original
+	  ;; file is not a directory and keep the mode
+	  (let ((exists
+		 (multiple-value-bind
+		     (okay err/dev inode orig-mode)
+		     (mach:unix-stat namestring)
+		   (declare (ignore inode))
+		   (cond (okay
+			  (when (and output (= (logand orig-mode #o170000)
+					       #o40000))
+			    (error "Cannot open ~S for output: Is a directory."
+				   namestring))
+			  (setf mode (logand orig-mode #o777))
+			  t)
+			 ((eql err/dev mach:enoent)
+			  nil)
+			 (t
+			  (error "Cannot find ~S: ~A"
+				 namestring
+				 (mach:get-unix-error-msg err/dev)))))))
+	    (when (or (not exists)
+		      ;; Do the rename.
+		      (multiple-value-bind
+			  (okay err)
+			  (mach:unix-rename namestring original)
+			(unless okay
+			  (cerror "Use :SUPERSEDE instead."
+				  "Could not rename ~S to ~S: ~A."
+				  namestring
+				  original
+				  (mach:get-unix-error-msg err))
+			  t)))
+	      (setf original nil)
+	      (setf delete-original nil)
+	      ;; In order to use SUPERSEDE instead, we have
+	      ;; to make sure mach:o_creat corresponds to
+	      ;; if-does-not-exist.  mach:o_creat was set
+	      ;; before because of if-exists being :rename.
+	      (unless (eq if-does-not-exist :create)
+		(setf mask (logior (logandc2 mask mach:o_creat) mach:o_trunc)))
+	      (setf if-exists :supersede))))
+	
+	;; Okay, now we can try the actual open.
+	(multiple-value-bind
+	    (fd errno)
+	    (mach:unix-open namestring mask mode)
+	  (cond ((numberp fd)
+		 (case direction
+		   ((:input :output :io)
+		    (make-fd-stream fd
+				    :input input
+				    :output output
+				    :element-type element-type
+				    :file namestring
+				    :original original
+				    :delete-original delete-original))
+		   (:probe
+		    (let ((stream (%make-fd-stream :name namestring
+						   :fd fd
+						   :element-type element-type)))
+		      (close stream)
+		      stream))))
+		((eql errno mach:enoent)
+		 (case if-does-not-exist
+		   (:error
+		    (cerror "Return NIL."
+			    "Error opening ~S, ~A."
+			    pathname
+			    (mach:get-unix-error-msg errno)))
+		   (:create
+		    (cerror "Return NIL."
+			    "Error creating ~S, path does not exist."
+			    pathname)))
+		 nil)
+		((eql errno mach:eexist)
+		 (unless (eq nil if-exists)
+		   (cerror "Return NIL."
+			   "Error opening ~S, ~A."
+			   pathname
+			   (mach:get-unix-error-msg errno)))
+		 nil)
+		(t
+		 (cerror "Return NIL."
+			 "Error opening ~S, ~A."
+			 pathname
+			 (mach:get-unix-error-msg errno))
+		 nil)))))))
+
+;;;; Initialization.
+
+(defvar *tty* nil
+  "The stream connected to the controlling terminal or NIL if there is none.")
+(defvar *stdin* nil
+  "The stream connected to the standard input (file descriptor 0).")
+(defvar *stdout* nil
+  "The stream connected to the standard output (file descriptor 1).")
+(defvar *stderr* nil
+  "The stream connected to the standard error output (file descriptor 2).")
+
+;;; STREAM-INIT -- internal interface
+;;;
+;;; Called when the cold load is first started up.
+;;; 
+(defun stream-init ()
+  (stream-reinit)
+  (setf *terminal-io* (make-synonym-stream '*tty*))
+  (setf *standard-input* (make-synonym-stream '*stdin*))
+  (setf *standard-output* (make-synonym-stream '*stdout*))
+  (setf *error-output* (make-synonym-stream '*stderr*))
+  (setf *query-io* (make-synonym-stream '*terminal-io*))
+  (setf *debug-io* *query-io*)
+  (setf *trace-output* *standard-output*)
+  nil)
+
+;;; STREAM-REINIT -- internal interface
+;;;
+;;; Called whenever a saved core is restarted.
+;;; 
+(defun stream-reinit ()
+  (setf *available-buffers* nil)
+  (setf *stdin*
+	(make-fd-stream 0 :name "Standard Input" :input t :buffering :line))
+  (setf *stdout*
+	(make-fd-stream 1 :name "Standard Output" :output t :buffering :line))
+  (setf *stderr*
+	(make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
+  (let ((tty (mach:unix-open "/dev/tty" mach:o_rdwr #o666)))
+    (if tty
+	(setf *tty*
+	      (make-fd-stream tty :name "the Terminal" :input t :output t
+			      :buffering :line))
+	(setf *tty* (make-two-way-stream *stdin* *stdout*))))
+  nil)
+
+
+;;;; Beeping.
+
+(defun default-beep-function (stream)
+  (write-char #\bell stream)
+  (finish-output stream))
+
+(defvar *beep-function* #'default-beep-function
+  "This is called in BEEP to feep the user.  It takes a stream.")
+
+(defun beep (&optional (stream *terminal-io*))
+  (funcall *beep-function* stream))
+
+
+;;;; File position and file length.
+
+;;; File-Position  --  Public
+;;;
+;;;    Call the misc method with the :file-position operation.
+;;;
+(defun file-position (stream &optional position)
+  "With one argument returns the current position within the file
+  File-Stream is open to.  If the second argument is supplied, then
+  this becomes the new file position.  The second argument may also
+  be :start or :end for the start and end of the file, respectively."
+  (unless (streamp stream)
+    (error "Argument ~S is not a stream." stream))
+  (funcall (stream-misc stream) stream :file-position position))
+
+;;; File-Length  --  Public
+;;;
+;;;    Like File-Position, only use :file-length.
+;;;
+(defun file-length (stream)
+  "This function returns the length of the file that File-Stream is open to."
+  (unless (streamp stream)
+    (error "Argument ~S is not a stream." stream))
+  (funcall (stream-misc stream) stream :file-length))
+
+;;; File-Name  --  internal interface
+;;;
+;;;    Kind of like File-Position, but is an internal hack used by the filesys
+;;; stuff to get and set the file name.
+;;;
+(defun file-name (stream &optional new-name)
+  (when (fd-stream-p stream)
+    (if new-name
+	(setf (fd-stream-file stream) new-name)
+	(fd-stream-file stream))))