From 6ad7b259dff72750483b65f9921b1a467eff8811 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Wed, 1 Sep 1993 18:29:47 +0000 Subject: [PATCH] Add select capabilities for NT. --- v7/src/microcode/ntutl/bch-cl3.lst | 1 + v7/src/microcode/ntutl/bch-p-nt.lst | 3 +- v7/src/microcode/ntutl/makefile | 14 ++-- v7/src/microcode/ntutl/scm-cl3.lst | 1 + v7/src/microcode/ntutl/scm-p-nt.lst | 3 +- v7/src/runtime/dosprm.scm | 103 ++++++++++++++++++++++++++-- 6 files changed, 114 insertions(+), 11 deletions(-) diff --git a/v7/src/microcode/ntutl/bch-cl3.lst b/v7/src/microcode/ntutl/bch-cl3.lst index d9c37bc7c..ac6be5557 100644 --- 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 71160466d..42537d4f3 100644 --- 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 5e89f86df..59fe51d19 100644 --- 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 3fccd22ab..3575931aa 100644 --- 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 a0f1e7b40..f2585b337 100644 --- 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 e52c51852..2db5b95c0 100644 --- 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!))) + +(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?)))) + +(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 -- 2.25.1