scsh-conservatory
/
scsh-0.5
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Time args to SELECT and SET-FILE-TIMES can now be reals.

This commit is contained in:
shivers 1995-10-28 22:07:16 +00:00
parent 05df0d4773
commit dce0dc36cd
3 changed files with 29 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
scsh/select.scm
View File

@ -33,7 +33,16 @@
(define (select!/copyback/errno read-vec write-vec (define (select!/copyback/errno read-vec write-vec
exception-vec . maybe-timeout) exception-vec . maybe-timeout)
(let ((timeout (optional-arg maybe-timeout #f)) (let ((timeout (and (pair? maybe-timeout)
(if (pair? (cdr maybe-timeout))
(apply error "Too many arguments"
select!/copyback/errno
read-vec write-vec exception-vec
maybe-timeout)
(real->exact-integer (check-arg real?
(car maybe-timeout)
select!/copyback/errno)))))
(vec-ok? (lambda (v) (vec-ok? (lambda (v)
(vector-every? (lambda (elt) (vector-every? (lambda (elt)
(or (and (integer? elt) (>= elt 0)) (or (and (integer? elt) (>= elt 0))
@ -86,7 +95,16 @@
(values nr nw ne)))) (values nr nw ne))))
(define (select!/errno read-vec write-vec exception-vec . maybe-timeout) (define (select!/errno read-vec write-vec exception-vec . maybe-timeout)
(let ((timeout (optional-arg maybe-timeout #f)) (let ((timeout (and (pair? maybe-timeout)
(if (pair? (cdr maybe-timeout))
(apply error "Too many arguments"
select!/copyback/errno
read-vec write-vec exception-vec
maybe-timeout)
(real->exact-integer (check-arg real?
(car maybe-timeout)
select!/copyback/errno)))))
(vec-ok? (lambda (v) (vec-ok? (lambda (v)
(vector-every? (lambda (elt) (vector-every? (lambda (elt)
(or (and (integer? elt) (>= elt 0)) (or (and (integer? elt) (>= elt 0))

12
scsh/time.scm
View File

@ -157,7 +157,7 @@
(define (date . args) ; Optional args [time zone] (define (date . args) ; Optional args [time zone]
(let ((time (if (pair? args) (let ((time (if (pair? args)
(integerize-time (check-arg real? (car args) date)) (real->exact-integer (check-arg real? (car args) date))
(time))) (time)))
(zone (check-arg time-zone? (zone (check-arg time-zone?
(and (pair? args) (optional-arg (cdr args) #f)) (and (pair? args) (optional-arg (cdr args) #f))
@ -219,7 +219,7 @@
;;; ;;;
;(define (utc-offset . args) ; Optional args [time tz] ;(define (utc-offset . args) ; Optional args [time tz]
; (let ((tim (if (pair? args) ; (let ((tim (if (pair? args)
; (integerize-time (check-arg real? (car args) utc-offset)) ; (real->exact-integer (check-arg real? (car args) utc-offset))
; (time))) ; (time)))
; (tz (and (pair? args) ; (tz (and (pair? args)
; (check-arg time-zone? (optional-arg (cdr args) #f) utc-offset)))) ; (check-arg time-zone? (optional-arg (cdr args) #f) utc-offset))))
@ -233,7 +233,7 @@
; (if (integer? tz) ; (if (integer? tz)
; (deintegerize-time-zone tz) ; (deintegerize-time-zone tz)
; (let* ((summer? (if (pair? args) (car args) (time))) ; (let* ((summer? (if (pair? args) (car args) (time)))
; (summer? (if (real? summer?) (integerize-time summer?) summer?))) ; (summer? (if (real? summer?) (real->exact-integer summer?) summer?)))
; (receive (err zone) (%time-zone/errno summer? tz) ; (receive (err zone) (%time-zone/errno summer? tz)
; (if err (errno-error err time-zone summer? tz) ; (if err (errno-error err time-zone summer? tz)
; zone)))))) ; zone))))))
@ -297,9 +297,3 @@
sign (two-digits h) (two-digits m))) sign (two-digits h) (two-digits m)))
(format #f "~a~a~a:~a:~a" ; name+hh:mm:ss (format #f "~a~a~a:~a:~a" ; name+hh:mm:ss
sign (two-digits h) (two-digits m) (two-digits s))))))) sign (two-digits h) (two-digits m) (two-digits s)))))))
;;; (floor x), as an exact int.
(define (integerize-time x)
(let ((f (floor x)))
(if (inexact? f) (inexact->exact f) f)))

6
scsh/utilities.scm
View File

@ -209,3 +209,9 @@
name name
maybe-preferred-msg))) maybe-preferred-msg)))
(apply proc args)))) (apply proc args))))
(define (real->exact-integer x)
(let ((f (round x)))
(if (inexact? f) (inexact->exact f) f)))