Add select capabilities for NT.

diff --git a/v7/src/microcode/ntutl/bch-cl3.lst b/v7/src/microcode/ntutl/bch-cl3.lst
index d9c37bc7ce91dde6213bab5b210d1c084b3dc128..ac6be55573346cd7a7de147aee17a7747cac0d86 100644 (file)
--- a/v7/src/microcode/ntutl/bch-cl3.lst
+++ b/v7/src/microcode/ntutl/bch-cl3.lst
@@ -59,6 +59,7 @@ prostty.obj
 
 prntenv.obj
 prntfs.obj
+prntio.obj
 
 ntasutl.obj
 ntenv.obj

diff --git a/v7/src/microcode/ntutl/bch-p-nt.lst b/v7/src/microcode/ntutl/bch-p-nt.lst
index 71160466d8865135d1a8fb9bc6d2bb184eb9f121..42537d4f30790a28635ace82e0a700f711e694a6 100644 (file)
--- a/v7/src/microcode/ntutl/bch-p-nt.lst
+++ b/v7/src/microcode/ntutl/bch-p-nt.lst
@@ -1,6 +1,6 @@
 ;;; -*-Fundamental-*-
 ;;;
-;;;    $Id: bch-p-nt.lst,v 1.3 1993/08/21 01:43:08 gjr Exp $
+;;;    $Id: bch-p-nt.lst,v 1.4 1993/09/01 18:25:40 gjr Exp $
 ;;;
 ;;;    Copyright (c) 1993 Massachusetts Institute of Technology
 ;;;
@@ -93,6 +93,7 @@ prostty.c
 ;;;;   NT OS primitive files
 prntenv.c
 prntfs.c
+prntio.c
 ;;;;   Bizarre NT primitive files
 ntgui.c
 nttterm.c

diff --git a/v7/src/microcode/ntutl/makefile b/v7/src/microcode/ntutl/makefile
index 5e89f86df94bc04f246b3b9b9e815034417d4707..59fe51d191116c192f0749590beea0e1e5247cf8 100644 (file)
--- a/v7/src/microcode/ntutl/makefile
+++ b/v7/src/microcode/ntutl/makefile
@@ -1,6 +1,6 @@
 ### -*- Fundamental -*-
 ###
-###    $Id: makefile,v 1.9 1993/08/23 01:40:13 gjr Exp $
+###    $Id: makefile,v 1.10 1993/09/01 18:28:41 gjr Exp $
 ###
 ###    Copyright (c) 1992-1993 Massachusetts Institute of Technology
 ###
@@ -185,8 +185,9 @@ prosio.c \
 prosterm.c \
 prostty.c \
 prosenv.c \
+prntenv.c \
 prntfs.c \
-prntenv.c
+prntio.c
 
 HEAD_FILES = scheme.tch prims.h zones.h locks.h bignum.h \
        $(GC_HEAD_FILES) trap.h lookup.h history.h cmpint.h
@@ -248,7 +249,8 @@ prosterm.obj \
 prosenv.obj \
 prostty.obj \
 prntenv.obj \
-prntfs.obj
+prntfs.obj \
+prntio.obj
 
 STD_GC_OBJECTS = \
 fasdump.obj \
@@ -410,7 +412,7 @@ prmcon.obj : scheme.tch prims.h prmcon.h $(OS_PRIM_DEPENDENCIES)
 
 NT_DEPENDENCIES = oscond.h ansidecl.h posixtyp.h intext.h \
                   dstack.h os.h osscheme.h nt.h ntsys.h syscall.h
-ntenv.obj : osenv.h $(NT_DEPENDENCIES)
+ntenv.obj : scheme.tch osenv.h $(NT_DEPENDENCIES)
 ntfile.obj : osfile.h osio.h ntio.h $(NT_DEPENDENCIES)
 ntfs.obj : osfs.h $(NT_DEPENDENCIES)
 ntio.obj : osio.h ntio.h $(NT_DEPENDENCIES)
@@ -425,7 +427,9 @@ ntasutl.obj : ntasutl.asm
 ntkbutl.obj : ntkbutl.asm
 ntscreen.obj : ntscreen.c ntscreen.h
 prntenv.obj : $(NT_DEPENDENCIES)
-prntfs.obj : $(NT_DEPENDENCIES) scheme.h prims.h osfs.h
+prntfs.obj : $(NT_DEPENDENCIES) scheme.tch prims.h osfs.h
+prntio.obj : $(NT_DEPENDENCIES) scheme.tch prims.h ntio.h osio.h syscall.h
+
 cmpauxmd.obj : cmpauxmd.asm
 
 ntscmlib.dll: ntwntlib.dll ntw32lib.dll

diff --git a/v7/src/microcode/ntutl/scm-cl3.lst b/v7/src/microcode/ntutl/scm-cl3.lst
index 3fccd22ab1f6b6c11f1674f6b9980c7add5862c4..3575931aabe94d153a3c4f0734bfb4c5ef172c7e 100644 (file)
--- a/v7/src/microcode/ntutl/scm-cl3.lst
+++ b/v7/src/microcode/ntutl/scm-cl3.lst
@@ -59,6 +59,7 @@ prostty.obj
 
 prntenv.obj
 prntfs.obj
+prntio.obj
 
 ntasutl.obj
 ntenv.obj

diff --git a/v7/src/microcode/ntutl/scm-p-nt.lst b/v7/src/microcode/ntutl/scm-p-nt.lst
index a0f1e7b40d48103187a3ee87c579a081614e11a0..f2585b337c0feeba63e9c0c89a72a90e8346144d 100644 (file)
--- a/v7/src/microcode/ntutl/scm-p-nt.lst
+++ b/v7/src/microcode/ntutl/scm-p-nt.lst
@@ -1,6 +1,6 @@
 ;;; -*-Fundamental-*-
 ;;;
-;;;    $Id: scm-p-nt.lst,v 1.3 1993/08/21 04:02:56 gjr Exp $
+;;;    $Id: scm-p-nt.lst,v 1.4 1993/09/01 18:29:47 gjr Exp $
 ;;;
 ;;;    Copyright (c) 1993 Massachusetts Institute of Technology
 ;;;
@@ -93,6 +93,7 @@ prostty.c
 ;;;;   NT OS primitive files
 prntenv.c
 prntfs.c
+prntio.c
 ;;;;   Bizarre NT primitive files
 ntgui.c
 nttterm.c

diff --git a/v7/src/runtime/dosprm.scm b/v7/src/runtime/dosprm.scm
index e52c51852098b1ec2918d4ec87164df2c630df99..2db5b95c07beb233c1bbc64acb2abe3153dc9220 100644 (file)
--- a/v7/src/runtime/dosprm.scm
+++ b/v7/src/runtime/dosprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: dosprm.scm,v 1.17 1993/01/12 19:01:03 gjr Exp $
+$Id: dosprm.scm,v 1.18 1993/09/01 18:23:42 gjr Exp $
 
 Copyright (c) 1992-1993 Massachusetts Institute of Technology
 
@@ -273,7 +273,102 @@ MIT in each case. |#
   ((ucode-primitive directory-delete 1)
    (->namestring (merge-pathnames name))))
 
-;;; Queues after-restart daemon to clean up environment space
-
 (define (initialize-system-primitives!)
-  (add-event-receiver! event:after-restart reset-environment-variables!))
\ No newline at end of file
+  (let ((reset!
+        (lambda ()
+          (reset-environment-variables!)
+          (cache-console-channel-descriptor!))))
+    (reset!)
+    (add-event-receiver! event:after-restart reset!)))
+\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
+       (if (string-ci=? microcode-id/operating-system-name "dos")
+           -1
+           ((ucode-primitive get-handle 1) 1)))
+  unspecific)
+
+(define (select-descriptor descriptor block?)
+  (define (select-result res)
+    (cond ((fix:> res 0)
+          'INPUT-AVAILABLE)
+         ((fix:< res 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))
+  console
+  descriptors)
+
+(define-integrable (find-descriptor df dl)
+  (list-search-positive dl
+    (lambda (d)
+      (= d df))))
+
+(define (make-select-registry . descriptors)
+  (cond ((find-descriptor console-channel-descriptor descriptors)
+        => (lambda (ccd)
+             (nt-select-registry/make console-channel-descriptor
+                                      (delq! ccd descriptors))))
+       (else
+        (nt-select-registry/make false descriptors))))
+
+(define (add-to-select-registry! registry descriptor)
+  (cond ((= descriptor console-channel-descriptor)
+        (set-nt-select-registry/console! registry console-channel-descriptor))
+       ((not (find-descriptor descriptor
+                              (nt-select-registry/descriptors registry)))
+        (set-nt-select-registry/descriptors!
+         registry
+         (cons descriptor (nt-select-registry/descriptors registry))))))
+
+(define (remove-from-select-registry! registry descriptor)
+  (cond ((= descriptor console-channel-descriptor)
+        (set-nt-select-registry/console! registry false))
+       ((find-descriptor descriptor (nt-select-registry/descriptors registry))
+        => (lambda (dr)
+             (set-nt-select-registry/descriptors!
+              registry
+              (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