From 575b12f310b69a50db544bf581a720338465b705 Mon Sep 17 00:00:00 2001
From: pw <pw>
Date: Wed, 5 Feb 1997 16:15:59 +0000
Subject: [PATCH] initial post 1.3.7 merge

---
 code/bit-bash.lisp  |   3 +-
 code/debug-int.lisp |  25 ++++-----
 code/error.lisp     |   5 +-
 code/exports.lisp   |  27 ++++++++--
 code/format.lisp    |   7 +--
 code/irrat.lisp     |  49 +++++++----------
 code/load.lisp      |  30 +++++------
 code/macros.lisp    |  20 ++++---
 code/pathname.lisp  | 129 +++++++++++++++++++++++---------------------
 code/pred.lisp      |   4 +-
 code/save.lisp      |   6 +--
 11 files changed, 155 insertions(+), 150 deletions(-)

diff --git a/code/bit-bash.lisp b/code/bit-bash.lisp
index de4f47283..455c200f3 100644
--- a/code/bit-bash.lisp
+++ b/code/bit-bash.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bit-bash.lisp,v 1.19 1997/01/18 14:30:33 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bit-bash.lisp,v 1.20 1997/02/05 16:15:32 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -77,7 +77,6 @@
       (:big-endian big-endian)
       (:little-endian little-endian))))
 
-(proclaim '(inline shift-towards-start shift-towards-end))
 (defun shift-towards-start (number count)
   "Shift NUMBER by COUNT bits, adding zero bits at the ``end'' and removing
   bits from the ``start.''  On big-endian machines this is a left-shift and
diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index dd9188f5d..2cf2ffacc 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.69 1997/01/18 14:31:08 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.70 1997/02/05 16:15:36 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2948,18 +2948,18 @@
 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
   (macrolet ((with-escaped-value ((var) &body forms)
 	       `(if escaped
-		 (let ((,var (vm:sigcontext-register
-			      escaped
-			      (c::sc-offset-offset sc-offset))))
-		   ,@forms)
-		 :invalid-value-for-unescaped-register-storage))
+		    (let ((,var (vm:sigcontext-register
+				 escaped
+				 (c::sc-offset-offset sc-offset))))
+		      ,@forms)
+		    :invalid-value-for-unescaped-register-storage))
 	     (escaped-float-value (format)
 	       `(if escaped
-		 (vm:sigcontext-float-register
-		  escaped
-		  (c::sc-offset-offset sc-offset)
-		  ',format)
-		 :invalid-value-for-unescaped-register-storage))
+		    (vm:sigcontext-float-register
+		     escaped
+		     (c::sc-offset-offset sc-offset)
+		     ',format)
+		    :invalid-value-for-unescaped-register-storage))
 	     (with-nfp ((var) &body body)
 	       `(let ((,var (if escaped
 				(system:int-sap
@@ -3012,8 +3012,6 @@
 				       vm:word-bytes))))
       (#.vm:control-stack-sc-number
        (kernel:stack-ref fp (c::sc-offset-offset sc-offset)))
-      (#.vm:immediate-stack-sc-number
-       (kernel:stack-ref fp (c::sc-offset-offset sc-offset)))
       (#.vm:base-char-stack-sc-number
        (with-nfp (nfp)
 	 (code-char (system:sap-ref-32 nfp (* (c::sc-offset-offset sc-offset)
@@ -3030,7 +3028,6 @@
        (with-nfp (nfp)
 	 (system:sap-ref-sap nfp (* (c::sc-offset-offset sc-offset)
 				    vm:word-bytes)))))))
-
 #+x86
 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
   (declare (type system:system-area-pointer fp))
diff --git a/code/error.lisp b/code/error.lisp
index 2f7ac1b41..a10c32e08 100644
--- a/code/error.lisp
+++ b/code/error.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.45 1997/01/18 14:30:53 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.46 1997/02/05 16:15:41 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -759,7 +759,8 @@
 		       `#'(lambda (condition stream)
 			    (declare (ignore condition))
 			    (write-string ,arg stream))
-		       `#',arg))))
+		       `#'(lambda (condition stream)
+			    (funcall #',arg condition stream))))))
 	  (:default-initargs
 	   (do ((initargs (rest option) (cddr initargs)))
 	       ((endp initargs))
diff --git a/code/exports.lisp b/code/exports.lisp
index 5a9397ce9..495fd1fbb 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.108 1997/01/18 14:30:55 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.109 1997/02/05 16:15:46 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -249,7 +249,26 @@
 	     "C-CFLAG" "TTY-OCRNL" "VMIN" "VEOF" "TCSAFLUSH"
 	     "TTY-IXON" "C-CC" "SIOCSPGRP" "TERMIOS" "VQUIT"
 	     "UNIX-TCSETATTR" "VINTR" "VSTART" "TIOCSIGSEND"
-	     #+(or svr4 freebsd linux) "O_NDELAY"))
+	     #+(or svr4 freebsd linux) "O_NDELAY")
+            #+(or svr4 linux)
+            (:export "EADDRINUSE" "EADDRNOTAVAIL" "EADV" "EAFNOSUPPORT"
+	     "EALREADY" "EBADE" "EBADFD" "EBADMSG" "EBADR" "EBADRQC"
+	     "EBADSLT" "EBFONT" #+svr4 "ECANCELED" "ECHRNG" "ECOMM"
+	     "ECONNABORTED" "ECONNREFUSED" "ECONNRESET" "EDEADLK"
+	     "EDEADLOCK" "EDESTADDRREQ" #+linux "EDOTDOT" #+linux "EDQUOT"
+	     "EHOSTDOWN" "EHOSTUNREACH" "EIDRM" "EILSEQ" "EINPROGRESS"
+	     "EISCONN" #+linux "EISNAM" "EL2HLT" "EL2NSYNC" "EL3HLT"
+	     "EL3RST" "ELIBACC" "ELIBBAD" "ELIBEXEC" "ELIBMAX" "ELIBSCN"
+	     "ELNRNG" "ELOOP" "EMSGSIZE" "EMULTIHOP" "ENAMETOOLONG"
+	     #+linux "ENAVAIL" "ENETDOWN" "ENETRESET" "ENETUNREACH" "ENOANO"
+	     "ENOBUFS" "ENOCSI" "ENODATA" "ENOLCK" "ENOLINK" "ENOMSG" "ENONET"
+	     "ENOPKG" "ENOPROTOOPT" "ENOSR" "ENOSTR" "ENOSYS" "ENOTCONN"
+	     "ENOTEMPTY" #+linux "ENOTNAM" "ENOTSOCK" #+svr4 "ENOTSUP"
+	     "ENOTUNIQ" "EOPNOTSUPP" "EOVERFLOW" "EPFNOSUPPORT" "EPROTO"
+	     "EPROTONOSUPPORT" "EPROTOTYPE" "EREMCHG" "EREMOTE"
+	     #+linux "EREMOTEIO" "ERESTART" "ESHUTDOWN" "ESOCKTNOSUPPORT"
+	     "ESRMNT" "ESTALE" "ESTRPIPE" "ETIME" "ETIMEDOUT" "ETOOMANYREFS"
+	     #+linux "EUCLEAN" "EUNATCH" "EUSERS" "EWOULDBLOCK" "EXFULL"))
   
 (defpackage "FORMAT")
 (defpackage "COMMON-LISP"
@@ -721,7 +740,9 @@
 	   "FUNCALLABLE-INSTANCE-LAYOUT-SLOT"
 	   "FUNCALLABLE-INSTANCE-LEXENV-SLOT"
 	   "FP-DOUBLE-ZERO-SC-NUMBER" "FP-SINGLE-ZERO-SC-NUMBER"
-	   "SINGLE-STEP-BREAKPOINT-TRAP"))
+	   "SINGLE-STEP-BREAKPOINT-TRAP"
+	   #+sparc "OBJECT-NOT-LIST-TRAP"
+	   #+sparc "OBJECT-NOT-INSTANCE-TRAP"))
 
 (defpackage "CONDITIONS")
 (intern "DISASSEMBLE" "LISP")
diff --git a/code/format.lisp b/code/format.lisp
index 385a5814a..f6d087316 100644
--- a/code/format.lisp
+++ b/code/format.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.32 1997/01/18 14:31:03 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.33 1997/02/05 16:15:49 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -136,10 +136,7 @@
 		 (incf posn)
 		 (push (cons posn (get-char)) params))
 		((char= char #\,)
-		 (push (cons (1- posn) nil) params)
-		 (incf posn)
-		 (if (not (char= (get-char) #\,))
-		     (decf posn)))
+		 (push (cons (1- posn) nil) params))
 		((char= char #\:)
 		 (if colonp
 		     (error 'format-error
diff --git a/code/irrat.lisp b/code/irrat.lisp
index 4dbada9bf..80fd391ae 100644
--- a/code/irrat.lisp
+++ b/code/irrat.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.17 1997/01/18 14:30:40 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.18 1997/02/05 16:15:51 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -66,9 +66,9 @@
 (def-math-rtn "sinh" 1)
 (def-math-rtn "cosh" 1)
 (def-math-rtn "tanh" 1)
-#-hpux (def-math-rtn "asinh" 1)
-#-hpux (def-math-rtn "acosh" 1)
-#-hpux (def-math-rtn "atanh" 1)
+(def-math-rtn "asinh" 1)
+(def-math-rtn "acosh" 1)
+(def-math-rtn "atanh" 1)
 
 ;;; Exponential and Logarithmic.
 #-x86(def-math-rtn "exp" 1)
@@ -77,6 +77,7 @@
 (def-math-rtn "pow" 2)
 #-x86 (def-math-rtn "sqrt" 1)
 (def-math-rtn "hypot" 2)
+#-hpux
 (def-math-rtn "log1p" 1)
 
 #+x86 ;; These are needed for use by byte-compiled files.
@@ -241,7 +242,9 @@
 (defun log (number &optional (base nil base-p))
   "Return the logarithm of NUMBER in the base BASE, which defaults to e."
   (if base-p
-      (/ (log number) (log base))
+      (if (zerop base)
+	  base				; ANSI spec
+	  (/ (log number) (log base)))
       (number-dispatch ((number number))
 	(((foreach fixnum bignum ratio))
 	 (if (minusp number)
@@ -504,32 +507,16 @@
     ((complex)
      (complex-atanh number))))
 
-;;; HP-UX does not supply C versions of asinh, acosh, and atanh, so just
-;;; use the definitions.
+;;; HP-UX does not supply a C version of log1p, so 
+;;; use the definition.
 
 #+hpux
-(defun %asinh (number)
-  (declare (type double-float number)
-	   (values double-float)
-	   (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
-  (log (+ number (sqrt (+ 1.0d0 (* number number))))))
-
-#+hpux
-(defun %acosh (number)
-  (declare (type (double-float 1.0d0) number)
-	   (values double-float)
-	   (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
-  (log (+ number (* (sqrt (- number 1.0d0))
-		    (sqrt (+ number 1.0d0))))))
-
+(declaim (inline %log1p))
 #+hpux
-(defun %atanh (number)
-  (declare (type (double-float -1.0d0 1.0d0) number)
-	   (values double-float)
-	   (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
-  (* 0.5d0 (- (log (+ 1.0d0 number))
-	      (log (- 1.0d0 number)))))
-
+(defun %log1p (number)
+  (declare (double-float number)
+	   (optimize (speed 3) (safety 0)))
+  (the double-float (log (the (double-float 0d0) (+ number 1d0)))))
 
 
 #+old-elfun
@@ -898,10 +885,10 @@ Z may be any number, but the result is always a complex."
 	(y (float (imagpart z) 1.0d0)))
     (declare (double-float x y))
     (cond ((> (abs x)
-	      #-linux #.(/ (%asinh most-positive-double-float) 4d0)
+	      #-(or linux hpux) #.(/ (%asinh most-positive-double-float) 4d0)
 	      ;; This is more accurate under linux.
-	      #+linux #.(/ (+ (%log 2.0d0)
-			      (%log most-positive-double-float)) 4d0))
+	      #+(or linux hpux) #.(/ (+ (%log 2.0d0)
+					(%log most-positive-double-float)) 4d0))
 	   (complex (float-sign x)
 		    (float-sign y 0.0d0)))
 	  (t
diff --git a/code/load.lisp b/code/load.lisp
index 080687012..42c5317ea 100644
--- a/code/load.lisp
+++ b/code/load.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.59 1997/01/18 14:30:39 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.60 1997/02/05 16:15:52 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -592,18 +592,18 @@
 
 ;;; TRY-DEFAULT-TYPES  --  Internal
 ;;;
-(defun try-default-types (pathname types)
-  (dolist (type types (values nil nil))
-    ;; toy@rtp.ericsson.se: add diddle-case so that this can handle
-    ;; both unix-namestrings and logical pathname namestrings.  The
-    ;; case handling seems to be the opposite between these two
-    ;; styles.
-    (let* ((pn (make-pathname
-		:type (maybe-diddle-case
-		       type (logical-pathname-p (pathname pathname)))
-		:defaults pathname))
-	   (tn (probe-file pn)))
-      (when tn (return (values pn tn))))))
+(defun try-default-types (pathname types lp-type)
+  ;; Modified 18-Jan-97/pw for logical-pathname support.
+  (flet ((frob (pathname type)
+	   (let* ((pn (make-pathname :type type :defaults pathname))
+		  (tn (probe-file pn)))
+	     (values pn tn))))
+    (if (logical-pathname-p pathname)
+	(frob pathname lp-type)
+	(dolist (type types (values nil nil))
+	  (multiple-value-bind (pn tn)(frob pathname type)
+	    (when tn
+	      (return (values pn tn))))))))
 
 ;;; INTERNAL-LOAD-DEFAULT-TYPE  --  Internal
 ;;;
@@ -612,10 +612,10 @@
 (defun internal-load-default-type (pathname if-does-not-exist)
   (multiple-value-bind
       (src-pn src-tn)
-      (try-default-types pathname *load-source-types*)
+      (try-default-types pathname *load-source-types* "LISP")
     (multiple-value-bind
 	(obj-pn obj-tn)
-	(try-default-types pathname *load-object-types*)
+	(try-default-types pathname *load-object-types* "FASL")
       (cond
        ((and obj-tn src-tn
 	     (> (file-write-date src-tn) (file-write-date obj-tn)))
diff --git a/code/macros.lisp b/code/macros.lisp
index 12365359f..0cc1e9021 100644
--- a/code/macros.lisp
+++ b/code/macros.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.46 1997/01/18 14:31:12 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.47 1997/02/05 16:15:54 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1365,26 +1365,24 @@
 
 
 ;;;; With-XXX
-
 (defmacro with-open-file ((var &rest open-args) &body (forms decls))
   "Bindspec is of the form (Stream File-Name . Options).  The file whose
    name is File-Name is opened using the Options and bound to the variable
-   Stream.  If the call to open is unsuccessful, the forms are not
-   evaluated.  The Forms are executed, and when they terminate, normally or
-   otherwise, the file is closed."
+   Stream. If the call to open is unsuccessful, the forms are not
+   evaluated.  The Forms are executed, and when they 
+   terminate, normally or otherwise, the file is closed."
   (let ((abortp (gensym)))
     `(let ((,var (open ,@open-args))
 	   (,abortp t))
        ,@decls
-       (when ,var
-	 (unwind-protect
-	     (multiple-value-prog1
-		 (progn ,@forms)
-	       (setq ,abortp nil))
+       (unwind-protect
+	   (multiple-value-prog1
+	       (progn ,@forms)
+	     (setq ,abortp nil))
+	 (when ,var
 	   (close ,var :abort ,abortp))))))
 
 
-
 (defmacro with-open-stream ((var stream) &body (forms decls))
   "The form stream should evaluate to a stream.  VAR is bound
    to the stream and the forms are evaluated as an implicit
diff --git a/code/pathname.lisp b/code/pathname.lisp
index fa0f21db5..aeaa2debe 100644
--- a/code/pathname.lisp
+++ b/code/pathname.lisp
@@ -4,7 +4,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.27 1997/01/18 14:30:44 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.28 1997/02/05 16:15:56 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -112,7 +112,7 @@
 	   (error "~S Cannot be printed readably." pathname))
 	  (t
 	   (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~
-				Directory=~S, File=~S, Name=~S, Version=~S>")
+				Directory=~S, Name=~S, Type=~S, Version=~S>")
 		    stream
 		    (%pathname-host pathname)
 		    (%pathname-device pathname)
@@ -178,6 +178,17 @@
 		    (%pathname-type pathname)
 		    (%pathname-version pathname))))))
 
+;;; %MAKE-PATHNAME-OBJECT -- internal
+;;;
+;;; A pathname is logical if the host component is a logical-host.
+;;; This constructor is used to make an instance of the correct type
+;;; from parsed arguments.
+
+(defun %make-pathname-object (host device directory name type version)
+  (if (typep host 'logical-host)
+      (%make-logical-pathname host :unspecific directory name type version)
+      (%make-pathname         host device      directory name type version)))
+
 ;;; *LOGICAL-HOSTS* --internal.
 ;;;
 ;;; Hash table searching maps a logical-pathname's host to their physical
@@ -405,11 +416,14 @@
 ;;; Converts the var, a host or string name for a host, into a logical-host
 ;;; structure or nil if not defined.
 ;;;
+;;; pw notes 1/12/97 this potentially useful macro is not used anywhere
+;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed.
+;;;
 (defmacro with-host ((var expr) &body body)
   `(let ((,var (let ((,var ,expr))
 		 (typecase ,var
 		   (logical-host ,var)
-		   (string (find-host ,var))
+		   (string (find-logical-host ,var nil))
 		   (t nil)))))
      ,@body))
 
@@ -532,26 +546,22 @@
 	      (and default-host pathname-host
 		   (not (eq (host-customary-case default-host)
 			    (host-customary-case pathname-host))))))
-	(make-pathname :host (or pathname-host default-host)
-		       :device
-		       (or (%pathname-device pathname)
-			    (maybe-diddle-case (%pathname-device defaults)
-					       diddle-case))
-		       :directory
-			(merge-directories (%pathname-directory pathname)
-					   (%pathname-directory defaults)
-					   diddle-case)
-			:name
-			(or (%pathname-name pathname)
-			    (maybe-diddle-case (%pathname-name defaults)
-					       diddle-case))
-			:type
-			(or (%pathname-type pathname)
-			    (maybe-diddle-case (%pathname-type defaults)
-					       diddle-case))
-			:version
-			(or (%pathname-version pathname)
-			    default-version))))))
+	(%make-pathname-object
+	 (or pathname-host default-host)
+	 (or (%pathname-device pathname)
+	     (maybe-diddle-case (%pathname-device defaults)
+				diddle-case))
+	 (merge-directories (%pathname-directory pathname)
+			    (%pathname-directory defaults)
+			    diddle-case)
+	 (or (%pathname-name pathname)
+	     (maybe-diddle-case (%pathname-name defaults)
+				diddle-case))
+	 (or (%pathname-type pathname)
+	     (maybe-diddle-case (%pathname-type defaults)
+				diddle-case))
+	 (or (%pathname-version pathname)
+	     default-version))))))
 
 ;;; IMPORT-DIRECTORY -- Internal
 ;;;
@@ -615,7 +625,25 @@ a host-structure or string."
 	 ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
 	 ;; string (as a logical-host) for the host part.  We map that
 	 ;; string into the corresponding logical host structure.
-	 (host (or (gethash host *logical-hosts*) host default-host))
+
+	 ;; pw@snoopy.mv.com:
+	 ;; HyperSpec says for the arg to MAKE-PATHNAME;
+	 ;; "host---a valid physical pathname host. ..."
+	 ;; where it probably means -- a valid pathname host.
+	 ;; "valid pathname host n. a valid physical pathname host or
+	 ;; a valid logical pathname host."
+	 ;; and defines 
+	 ;; "valid physical pathname host n. any of a string,
+	 ;; a list of strings, or the symbol :unspecific,
+	 ;; that is recognized by the implementation as the name of a host." 
+	 ;; "valid logical pathname host n. a string that has been defined
+	 ;; as the name of a logical host. ..."
+	 ;; HS is silent on what happens if the :host arg is NOT one of these.
+	 ;; It seems an error message is appropriate.
+	 (host (typecase host
+		 (host host) 		; A valid host, use it. 
+		 (string (find-logical-host host t)) ; logical-host or lose.
+		 (t default-host)))	; unix-host
 	 (diddle-args (and (eq (host-customary-case host) :lower)
 			   (eq case :common)))
 	 (diddle-defaults
@@ -647,21 +675,12 @@ a host-structure or string."
 					    diddle-defaults))
 			(t
 			 nil))))
-      (if (logical-host-p host)
-	  (%make-logical-pathname
-	   host
-	   :unspecific
-	   dir
-	   (pick name namep %pathname-name)
-	   (pick type typep %pathname-type)
-	   ver)
-	  (%make-pathname
-	   host
-	   dev
-	   dir
-	   (pick name namep %pathname-name)
-	   (pick type typep %pathname-type)
-	   ver)))))
+      (%make-pathname-object host
+			     dev ; forced to :unspecific when logical-host
+			     dir
+			     (pick name namep %pathname-name)
+			     (pick type typep %pathname-type)
+			     ver))))
 
 ;;; PATHNAME-HOST -- Interface
 ;;;
@@ -784,10 +803,8 @@ a host-structure or string."
 		    does not match explicit host argument: ~S"
 		   host))
 	  (let ((pn-host (or new-host parse-host)))
-	    (values (funcall (if (typep pn-host 'logical-host)
-				 #'%make-logical-pathname
-				 #'%make-pathname)
-			     pn-host device directory file type version)
+	    (values (%make-pathname-object
+		     pn-host device directory file type version)
 		    end))))))
 
 
@@ -1190,25 +1207,13 @@ a host-structure or string."
 			    (if (eq result :error)
 				(error "~S doesn't match ~S" source from)
 				result))))
-	      #+nil ;; pw- 1/3/97 This doesn't work.
-	      (%make-pathname (or to-host source-host)
-			      (frob %pathname-device)
-			      (frob %pathname-directory translate-directories)
-			      (frob %pathname-name)
-			      (frob %pathname-type)
-			      (frob %pathname-version))
-
-	      (let ((host      (or to-host source-host))
-		    (device    (frob %pathname-device))
-		    (directory (frob %pathname-directory translate-directories))
-		    (name      (frob %pathname-name))
-		    (type      (frob %pathname-type))
-		    (version   (frob %pathname-version)))
-		(if (logical-host-p host)
-		     (%make-logical-pathname
-		      host :unspecific directory name type version)
-		     (%make-pathname 
-		      host device directory name type version)))))))))
+	      (%make-pathname-object
+	       (or to-host source-host)
+	       (frob %pathname-device)
+	       (frob %pathname-directory translate-directories)
+	       (frob %pathname-name)
+	       (frob %pathname-type)
+	       (frob %pathname-version))))))))
 
 
 ;;;; Search lists.
diff --git a/code/pred.lisp b/code/pred.lisp
index d4f086f41..9a2adaece 100644
--- a/code/pred.lisp
+++ b/code/pred.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.35 1997/01/18 14:30:34 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.36 1997/02/05 16:15:58 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -26,7 +26,7 @@
 (export '(typep null symbolp atom consp listp numberp integerp rationalp
 	  floatp complexp characterp stringp bit-vector-p vectorp
 	  simple-vector-p simple-string-p simple-bit-vector-p arrayp
-	  functionp compiled-function-p commonp eq eql equal equalp not
+	  functionp compiled-function-p eq eql equal equalp not
 	  type-of upgraded-array-element-type realp
 	  ;; Names of types...
 	  array atom bignum bit bit-vector character common
diff --git a/code/save.lisp b/code/save.lisp
index 778f22b0d..8b35c4f1e 100644
--- a/code/save.lisp
+++ b/code/save.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.29 1997/01/18 14:30:54 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.30 1997/02/05 16:15:59 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -162,8 +162,6 @@
 		(reinit)
 		(dolist (f *after-save-initializations*) (funcall f))
 		(environment-init)
-		(when site-init
-		  (load site-init :if-does-not-exist nil :verbose nil))
 		(when process-command-line
 		  (ext::process-command-strings))
 		(setf *editor-lisp-p* nil)
@@ -173,6 +171,8 @@
 				    :test #'(lambda (x y)
 					      (declare (simple-string x y))
 					      (string-equal x y)))))
+		  (when site-init
+		    (load site-init :if-does-not-exist nil :verbose nil))
 		  (when (and process-command-line (find-switch "edit"))
 		    (setf *editor-lisp-p* t))
 		  (when (and load-init-file
-- 
GitLab