#| -*-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
(declare (usual-integrations))
\f
-(define (initialize-system-primitives!)
- unspecific)
-
(define (file-directory? filename)
((ucode-primitive file-directory? 1)
(->namestring (merge-pathnames filename))))
access-time
modification-time))
\f
+(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)
+\f
(define (file-touch filename)
((ucode-primitive file-touch 1) (->namestring (merge-pathnames filename))))
(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"))
(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)
+\f
+(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)
+\f
+(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
projects / mit-scheme.git / commitdiff