*** Note: this version of the runtime system requires microcode

    version 11.155 or later.  ***

* Implement heuristic to detect unix drivers and perform appropriate
  end-of-line translations for them.

* Provide names for Win32 file-system info flags.

* Reimplement SELECT support to match changes in microcode.  The
  improved support helps to prevent Scheme from getting stuck while
  waiting for input.

diff --git a/v7/src/runtime/ntprm.scm b/v7/src/runtime/ntprm.scm
index d3979e48a2d4bc29d4963f7486c4906b715af427..e0ad84329445278c358ed9b91e8fb4f33044197a 100644 (file)
--- a/v7/src/runtime/ntprm.scm
+++ b/v7/src/runtime/ntprm.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: ntprm.scm,v 1.9 1996/10/07 18:52:13 cph Exp $
+$Id: ntprm.scm,v 1.10 1997/01/02 04:37:46 cph Exp $
 
-Copyright (c) 1992-96 Massachusetts Institute of Technology
+Copyright (c) 1992-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -295,8 +295,12 @@ MIT in each case. |#
    (->namestring (directory-pathname-as-file (merge-pathnames name)))))
 
 (define (os/file-end-of-line-translation pathname)
-  pathname
-  "\r\n")
+  (if (let ((type (dos/fs-drive-type pathname)))
+       (or (string=? "NFS" (car type))
+           (string=? "NtNfs" (car type))
+           (string=? "Samba" (car type))))
+      #f
+      "\r\n"))
 
 (define (os/default-end-of-line-translation)
   "\r\n")
@@ -350,6 +354,13 @@ MIT in each case. |#
   (file-system-flags #f read-only #t)
   (file-system-name #f read-only #t))
 
+(define nt-fs-flag/case-sensitive-search       #x00000001)
+(define nt-fs-flag/case-preserved-names                #x00000002)
+(define nt-fs-flag/unicode-on-disk             #x00000004)
+(define nt-fs-flag/persistent-acls             #x00000008)
+(define nt-fs-flag/file-compression            #x00000010)
+(define nt-fs-flag/volume-is-compressed                #x00008000)
+
 (define (copy-file from to)
   ((ucode-primitive nt-copy-file 2) (->namestring (merge-pathnames from))
                                    (->namestring (merge-pathnames to))))
@@ -419,44 +430,6 @@ MIT in each case. |#
                       (set! port #f)
                       unspecific))))))))))
 \f
-(define (select-internal console? handles block?)
-  (let* ((nt/qs-allinput #xff)
-        (select
-         (if console?
-             (lambda (period)
-               ((ucode-primitive nt:msgwaitformultipleobjects 4)
-                handles #f period nt/qs-allinput))
-             (lambda (period)
-               ((ucode-primitive nt:waitformultipleobjects 3)
-                handles #f period)))))
-    (if (not block?)
-       (select 0)
-       (let loop ()
-         (let ((res (select 20)))
-           (if (zero? res)
-               (loop)
-               res))))))
-              
-(define console-channel-descriptor)
-
-(define (cache-console-channel-descriptor!)
-  (set! console-channel-descriptor ((ucode-primitive get-handle 1) 1))
-  unspecific)
-
-(define (select-descriptor descriptor block?)
-  (define (select-result result)
-    (cond ((fix:> result 0)
-          'INPUT-AVAILABLE)
-         ((fix:< result 0)
-          (error "Illegal result from select-internal" result))
-         (else
-          #f)))
-
-  (select-result
-   (if (= descriptor console-channel-descriptor)
-       (select-internal true '#() block?)
-       (select-internal false (vector descriptor) block?))))
-\f
 (define-structure (nt-select-registry
                   (conc-name nt-select-registry/)
                   (constructor nt-select-registry/make))
@@ -495,15 +468,44 @@ MIT in each case. |#
               (delq! dr (nt-select-registry/descriptors registry)))))))
 
 (define (select-registry-test registry block?)
-  (let* ((handles (list->vector (nt-select-registry/descriptors registry)))
-        (result (select-internal (nt-select-registry/console registry)
-                                 handles
-                                 block?)))
-    (cond ((fix:< result 0)
-          (error "Illegal result from select-internal" result))
-         ((fix:= result 0)
-          #f)
-         ((fix:> result (vector-length handles))
-          (list (nt-select-registry/console registry)))
-         (else
-          (list (vector-ref handles (fix:- result 1)))))))
\ No newline at end of file
+  (let ((handles (list->vector (nt-select-registry/descriptors registry))))
+    (let ((nhand (vector-length handles))
+         (result
+          (select-internal (nt-select-registry/console registry)
+                           handles
+                           block?)))
+      (cond ((fix:< result 0)
+            (error "Illegal result from select-internal:" result))
+           ((fix:= result 0) #f)
+           ((fix:<= result nhand)
+            (list (vector-ref handles (fix:- result 1))))
+           ((fix:= result (fix:+ nhand 1))
+            (list (nt-select-registry/console registry)))
+           (else 'INTERRUPT)))))
+
+(define (select-descriptor descriptor block?)
+  (let ((result
+        (if (= descriptor console-channel-descriptor)
+            (select-internal #t '#() block?)
+            (select-internal #f (vector descriptor) block?))))
+    (case result
+      ((0) #f)
+      ((1) 'INPUT-AVAILABLE)
+      ((2 3) 'INTERRUPT)
+      (else (error "Illegal result from select-internal:" result)))))
+
+(define (select-internal console? handles block?)
+  (let ((nt/QS_ALLINPUT #xFF)
+       (nt/INFINITE #xFFFFFFFF))
+    (let ((timeout (if block? nt/INFINITE 0)))
+      (if console?
+         ((ucode-primitive nt:msgwaitformultipleobjects 4)
+          handles #f timeout nt/QS_ALLINPUT)
+         ((ucode-primitive nt:waitformultipleobjects 3)
+          handles #f timeout)))))
+
+(define console-channel-descriptor)
+
+(define (cache-console-channel-descriptor!)
+  (set! console-channel-descriptor ((ucode-primitive get-handle 1) 1))
+  unspecific)
\ No newline at end of file

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index e4a213e68999d207cbe7a64d4e8d3f1c12c092cb..66f67418689cf0241d7efaab640d9863e522ef51 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: version.scm,v 14.170 1996/05/18 06:15:47 cph Exp $
+$Id: version.scm,v 14.171 1997/01/02 04:37:53 cph Exp $
 
-Copyright (c) 1988-96 Massachusetts Institute of Technology
+Copyright (c) 1988-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 170))
+  (add-identification! "Runtime" 14 171))
 
 (define microcode-system)