[Openmcl-cvs-notifications] r15230 - in /trunk/source/level-1: l1-boot-2.lisp linux-files.lisp

[gb at clozure.com]

Author: gb
Date: Sun Mar  4 09:01:55 2012
New Revision: 15230

Log:
(SAME-FD-P a b) returns true if it can tell that file descriptors
(file handles on Windows) a and b refer to the same underlying file
(socket, pipe, tty.)

Make *ERROR-OUTPUT* a synonym to CCL::*STDERR* if *batch-flag* or if
file descriptors 1 and 2 (or the Windows equivalents) don't refer
to the same file (handy for those who run interactively with whatever
line noise is required to redirect fd 2 ...)

Modified:
    trunk/source/level-1/l1-boot-2.lisp
    trunk/source/level-1/linux-files.lisp

Modified: trunk/source/level-1/l1-boot-2.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-boot-2.lisp (original)
+++ trunk/source/level-1/l1-boot-2.lisp Sun Mar  4 09:01:55 2012
@@ -175,7 +175,9 @@
                              *terminal-input* *terminal-output*))
         (setq *standard-input* (make-synonym-stream '*terminal-io*)
               *standard-output* (make-synonym-stream '*terminal-io*))))
-    (setq *error-output* (if *batch-flag*
+    (setq *error-output* (if (or *batch-flag*
+                                 (not (same-fd-p (stream-device *stderr* :=
output)
+                                                 (stream-device *stdout* :=
output))))
                            (make-synonym-stream '*stderr*)
                            (make-synonym-stream '*terminal-io*)))
     (setq *query-io* (make-synonym-stream '*terminal-io*))

Modified: trunk/source/level-1/linux-files.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/linux-files.lisp (original)
+++ trunk/source/level-1/linux-files.lisp Sun Mar  4 09:01:55 2012
@@ -2183,6 +2183,31 @@
 =

 ;;(assert (=3D (logcount *host-page-size*) 1))
 =

+
+(defun same-fd-p (a b)
+  (or (eql a b)
+      #-windows-target
+      (let* ((a-stat (multiple-value-list (%fstat a)))
+             (b-stat (multiple-value-list (%fstat b))))
+        (declare (dynamic-extent a-stat b-stat))
+        (and (car a-stat) (car b-stat)
+             (eql (nth 9 a-stat)
+                  (nth 9 b-stat))
+             (eql (nth 4 a-stat)
+                  (nth 4 b-stat))))
+      #+windows-target
+      (rlet ((a-info #>BY_HANDLE_FILE_INFORMATION)
+             (b-info #>BY_HANDLE_FILE_INFORMATION))
+        (unless (or (eql 0 (#_GetFileInformationByHandle (%int-to-ptr a) a=
-info))
+                    (eql 0 (#_GetFileInformationByHandle (%int-to-ptr b) b=
-info)))
+          (and (eql (pref a-info #>BY_HANDLE_FILE_INFORMATION.dwVolumeSeri=
alNumber)
+                    (pref b-info #>BY_HANDLE_FILE_INFORMATION.dwVolumeSeri=
alNumber))
+               (eql (pref a-info #>BY_HANDLE_FILE_INFORMATION.nFileIndexHi=
gh)
+                    (pref b-info #>BY_HANDLE_FILE_INFORMATION.nFileIndexHi=
gh))
+               (eql (pref a-info #>BY_HANDLE_FILE_INFORMATION.nFileIndexLo=
w)
+                    (pref b-info #>BY_HANDLE_FILE_INFORMATION.nFileIndexLo=
w)))))))
+
+  =

 (defun get-universal-time ()
   "Return a single integer for the current time of
    day in universal time format."