From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 19 Dec 1994 21:08:01 +0000 (+0000)
Subject: Implement additional support needed for Edwin.
X-Git-Tag: 20090517-FFI~6856
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8939c77cc9dc653b13e0c1e3175b960c22a3de30;p=mit-scheme.git

Implement additional support needed for Edwin.
---

diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm
index 8b809ece3..a2f36673a 100644
--- a/v7/src/runtime/os2prm.scm
+++ b/v7/src/runtime/os2prm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2prm.scm,v 1.1 1994/11/28 05:46:24 cph Exp $
+$Id: os2prm.scm,v 1.2 1994/12/19 21:08:01 cph Exp $
 
 Copyright (c) 1994 Massachusetts Institute of Technology
 
@@ -37,9 +37,6 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
-(define (initialize-system-primitives!)
-  unspecific)
-
 (define (file-directory? filename)
   ((ucode-primitive file-directory? 1)
    (->namestring (merge-pathnames filename))))
@@ -107,6 +104,55 @@ MIT in each case. |#
    access-time
    modification-time))
 
+(define (os2/file-time->string time)
+  (let* ((twosecs (remainder time 32))
+	 (time    (quotient  time 32))
+	 (minutes (remainder time 64))
+	 (time    (quotient  time 64))
+	 (hours   (remainder time 32))
+	 (time    (quotient  time 32))
+	 (day     (remainder time 32))
+	 (time    (quotient  time 32))
+	 (month   (remainder time 16))
+	 (year    (quotient  time 16)))
+    (string-append (vector-ref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun"
+					"Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+			       (- month 1))
+		   " "
+		   (string-pad-left (number->string day) 2 #\space)
+		   " "
+		   (string-pad-left (number->string hours) 2 #\0)
+		   ":"
+		   (string-pad-left (number->string minutes) 2 #\0)
+		   ":"
+		   (string-pad-left (number->string (* twosecs 2)) 2 #\0)
+		   " "
+		   (number->string (+ 1980 year)))))
+
+(define (os2/current-file-time)
+  (call-with-temporary-file-pathname file-modification-time))
+
+(define (file-attributes filename)
+  ((ucode-primitive file-info 1)
+   (->namestring (merge-pathnames filename))))
+(define file-attributes-direct file-attributes)
+(define file-attributes-indirect file-attributes)
+
+(define-structure (file-attributes
+		   (type vector)
+		   (constructor #f)
+		   (conc-name file-attributes/))
+  (type false read-only true)
+  (access-time false read-only true)
+  (modification-time false read-only true)
+  (change-time false read-only true)
+  (length false read-only true)
+  (mode-string false read-only true))
+
+(define (file-attributes/n-links attributes)
+  attributes
+  1)
+
 (define (file-touch filename)
   ((ucode-primitive file-touch 1) (->namestring (merge-pathnames filename))))
 
@@ -145,30 +191,11 @@ MIT in each case. |#
 	  (try-directory "\\")
 	  (error "Can't find temporary directory.")))))
 
-(define (file-attributes filename)
-  ((ucode-primitive file-info 1)
-   (->namestring (merge-pathnames filename))))
-(define file-attributes-direct file-attributes)
-(define file-attributes-indirect file-attributes)
-
-(define-structure (file-attributes
-		   (type vector)
-		   (constructor #f)
-		   (conc-name file-attributes/))
-  (type false read-only true)
-  (access-time false read-only true)
-  (modification-time false read-only true)
-  (change-time false read-only true)
-  (length false read-only true)
-  (mode-string false read-only true))
-
-(define (file-attributes/n-links attributes)
-  attributes
-  1)
-
 (define (os2/current-home-directory)
-  (or (get-environment-variable "HOME")
-      (os2/user-home-directory (os2/current-user-name))))
+  (let ((home (get-environment-variable "HOME")))
+    (if home
+	(pathname-as-directory (merge-pathnames home))
+	(os2/user-home-directory (os2/current-user-name)))))
 
 (define (os2/current-user-name)
   (get-environment-variable "USER"))
@@ -177,11 +204,104 @@ MIT in each case. |#
   (or (and user-name
 	   (let ((directory (get-environment-variable "USERDIR")))
 	     (and directory
-		  (pathname-new-name
-		   (pathname-as-directory (merge-pathnames directory))
-		   user-name))))
+		  (pathname-as-directory
+		   (pathname-new-name
+		    (pathname-as-directory (merge-pathnames directory))
+		    user-name)))))
       "\\"))
 
 ;; These two aliases are needed by the DOS pathname parser.
 (define dos/current-home-directory os2/current-home-directory)
-(define dos/user-home-directory os2/user-home-directory)
\ No newline at end of file
+(define dos/user-home-directory os2/user-home-directory)
+
+(define (initialize-system-primitives!)
+  (discard-select-registry-result-vectors!)
+  (add-event-receiver! event:after-restart
+		       discard-select-registry-result-vectors!))
+
+(define os2/select-registry-lub)
+(define select-registry-result-vectors)
+
+(define (discard-select-registry-result-vectors!)
+  (set! os2/select-registry-lub ((ucode-primitive os2-select-registry-lub 0)))
+  (set! select-registry-result-vectors '())
+  unspecific)
+
+(define (allocate-select-registry-result-vector)
+  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+    (let ((v
+	   (let loop ((rv select-registry-result-vectors))
+	     (cond ((null? rv)
+		    (make-string os2/select-registry-lub))
+		   ((car rv)
+		    => (lambda (v) (set-car! rv #f) v))
+		   (else
+		    (loop (cdr rv)))))))
+      (set-interrupt-enables! interrupt-mask)
+      v)))
+
+(define (deallocate-select-registry-result-vector v)
+  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+    (let loop ((rv select-registry-result-vectors))
+      (cond ((null? rv)
+	     (set! select-registry-result-vectors
+		   (cons v select-registry-result-vectors)))
+	    ((car rv)
+	     (loop (cdr rv)))
+	    (else
+	     (set-car! rv v))))
+    (set-interrupt-enables! interrupt-mask))
+  unspecific)
+
+(define (make-select-registry . descriptors)
+  (let ((registry (make-string os2/select-registry-lub)))
+    (vector-8b-fill! registry 0 os2/select-registry-lub 0)
+    (do ((descriptors descriptors (cdr descriptors)))
+	((null? descriptors))
+      (add-to-select-registry! registry (car descriptors)))
+    registry))
+
+(define (os2/guarantee-select-descriptor descriptor procedure)
+  (if (not (and (fix:fixnum? descriptor)
+		(fix:<= 0 descriptor)
+		(fix:< descriptor os2/select-registry-lub)))
+      (error:wrong-type-argument descriptor "select descriptor" procedure))
+  descriptor)
+
+(define (add-to-select-registry! registry descriptor)
+  (os2/guarantee-select-descriptor descriptor 'ADD-TO-SELECT-REGISTRY!)
+  (vector-8b-set! registry descriptor 1))
+
+(define (remove-from-select-registry! registry descriptor)
+  (os2/guarantee-select-descriptor descriptor 'REMOVE-FROM-SELECT-REGISTRY!)
+  (vector-8b-set! registry descriptor 0))
+
+(define (select-descriptor descriptor block?)
+  (vector-ref os2/select-result-values
+	      ((ucode-primitive os2-select-descriptor 2) descriptor block?)))
+
+(define (select-registry-test registry block?)
+  (let ((result-vector (allocate-select-registry-result-vector)))
+    (let ((result
+	   ((ucode-primitive os2-select-registry-test 3) registry
+							 result-vector
+							 block?)))
+      (if (fix:= result 0)
+	  (let loop
+	      ((index (fix:- os2/select-registry-lub 1))
+	       (descriptors '()))
+	    (let ((descriptors
+		   (if (fix:= 0 (vector-8b-ref result-vector index))
+		       descriptors
+		       (cons index descriptors))))
+	      (if (fix:= 0 index)
+		  (begin
+		    (deallocate-select-registry-result-vector result-vector)
+		    descriptors)
+		  (loop (fix:- index 1) descriptors))))
+	  (begin
+	    (deallocate-select-registry-result-vector result-vector)
+	    (vector-ref os2/select-result-values result))))))
+
+(define os2/select-result-values
+  '#(INPUT-AVAILABLE #F INTERRUPT))
\ No newline at end of file