suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs & io: small clean-ups to seconds->date

Browse Source 
Streamline some things that probably needed to be different along the
way.
This commit is contained in:
Matthew Flatt 2020-12-30 04:49:48 -07:00
parent 4b7b1872dc
commit c7ca4414ca
7 changed files with 132 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
racket/src/cs/io.sls
View File

@ -213,6 +213,13 @@
(ftype-ref rktio_identity_t (b_bits) p) (ftype-ref rktio_identity_t (b_bits) p)
(ftype-ref rktio_identity_t (c_bits) p)))) (ftype-ref rktio_identity_t (c_bits) p))))
(define (in-date-range? si)
(if (> (fixnum-width) 32)
(<= -9223372036854775808 si 9223372036854775807)
(<= -2147483648 si 2147483647)))
(define unknown-zone-name (string->immutable-string "?"))
(define (rktio_seconds_to_date* rktio si nsecs get-gmt) (define (rktio_seconds_to_date* rktio si nsecs get-gmt)
(cond (cond
[(not (in-date-range? si)) [(not (in-date-range? si))

1
racket/src/cs/rumble.sls
View File

@ -133,7 +133,6 @@
struct:date* date*? date* make-date* struct:date* date*? date* make-date*
date*-nanosecond date*-time-zone-name date*-nanosecond date*-time-zone-name
in-date-range? unknown-zone-name ;; not exported to Racket
struct:arity-at-least arity-at-least arity-at-least? struct:arity-at-least arity-at-least arity-at-least?
arity-at-least-value arity-at-least-value

7
racket/src/cs/rumble/time.ss
View File

@ -104,10 +104,3 @@
(define (current-seconds) (define (current-seconds)
(let ((t (current-time 'time-utc))) (let ((t (current-time 'time-utc)))
(time-second t))) (time-second t)))
(define (in-date-range? si)
(if (> (fixnum-width) 32)
(<= -9223372036854775808 si 9223372036854775807)
(<= -2147483648 si 2147483647)))
(define unknown-zone-name (string->immutable-string "?"))

85
racket/src/cs/schemified/io.scm
View File

@ -38087,46 +38087,51 @@
'current-load-extension)) 'current-load-extension))
(define rktio_seconds_to_date-error-kind (vector-immutable 3 25)) (define rktio_seconds_to_date-error-kind (vector-immutable 3 25))
(define 1/seconds->date (define 1/seconds->date
(|#%name| (let ((seconds->date_0
seconds->date (|#%name|
(case-lambda seconds->date
((s_0) (begin (1/seconds->date s_0 #t))) (lambda (s2_0 local?1_0)
((s_0 local?_0) (begin
(begin (begin
(if (real? s_0) (if (real? s2_0)
(void) (void)
(raise-argument-error 'seconds->date "real?" s_0)) (raise-argument-error 'seconds->date "real?" s2_0))
(let ((s_1 (inexact->exact s_0))) (let ((s_0 (inexact->exact s2_0)))
(let ((si_0 (floor s_1))) (let ((si_0 (floor s_0)))
(let ((get-gmt_0 (if local?_0 0 1))) (let ((get-gmt_0 (if local?1_0 0 1)))
(let ((nsecs_0 (floor (* (- s_1 si_0) 1000000000)))) (let ((nsecs_0 (floor (* (- s_0 si_0) 1000000000))))
(let ((dt_0 (let ((dt_0
(|#%app| (|#%app|
rktio_seconds_to_date* rktio_seconds_to_date*
(unsafe-place-local-ref cell.1) (unsafe-place-local-ref cell.1)
si_0 si_0
nsecs_0 nsecs_0
get-gmt_0))) get-gmt_0)))
(if (date*? dt_0) (if (date*? dt_0)
dt_0 dt_0
(if (equal? dt_0 rktio_seconds_to_date-error-kind) (if (equal? dt_0 rktio_seconds_to_date-error-kind)
(raise-arguments-error (raise-arguments-error
'seconds->date 'seconds->date
"integer is out-of-range" "integer is out-of-range"
"integer" "integer"
si_0) si_0)
(let ((base-msg_0 "conversion error")) (let ((base-msg_0 "conversion error"))
(begin-unsafe (begin-unsafe
(raise (raise
(let ((app_0 (let ((app_0
(format-rktio-message (format-rktio-message
'seconds->date 'seconds->date
dt_0 dt_0
base-msg_0))) base-msg_0)))
(|#%app| (|#%app|
exn:fail exn:fail
app_0 app_0
(current-continuation-marks)))))))))))))))))) (current-continuation-marks)))))))))))))))))))
(|#%name|
seconds->date
(case-lambda
((s_0) (begin (seconds->date_0 s_0 #t)))
((s_0 local?1_0) (seconds->date_0 s_0 local?1_0))))))
(define 1/unsafe-poller (define 1/unsafe-poller
(|#%name| (|#%name|
unsafe-poller unsafe-poller

4
racket/src/io/demo.rkt
View File

@ -747,8 +747,8 @@
(test l (sync l)) (test l (sync l))
(define-values (tai tao) (tcp-accept l)) (define-values (tai tao) (tcp-accept l))
(test #f (file-stream-port? i)) (test #f (file-stream-port? ti))
(test #f (file-stream-port? o)) (test #f (file-stream-port? to))
(test 6 (write-string "hello\n" to)) (test 6 (write-string "hello\n" to))
(flush-output to) (flush-output to)

111
racket/src/io/host/bootstrap-rktio.rkt
View File

@ -2,7 +2,6 @@
(require racket/include (require racket/include
racket/fixnum racket/fixnum
(only-in '#%linklet primitive-table) (only-in '#%linklet primitive-table)
(only-in '#%kernel [date* kernel:date*])
ffi/unsafe ffi/unsafe
ffi/unsafe/atomic ffi/unsafe/atomic
(for-syntax racket/base) (for-syntax racket/base)
@ -135,7 +134,7 @@
(define dt (cast p _pointer _Rrktio_date_t-pointer)) (define dt (cast p _pointer _Rrktio_date_t-pointer))
(define tzn (Rrktio_date_t-zone_name dt)) (define tzn (Rrktio_date_t-zone_name dt))
(begin0 (begin0
(kernel:date* (date*
(Rrktio_date_t-second dt) (Rrktio_date_t-second dt)
(Rrktio_date_t-minute dt) (Rrktio_date_t-minute dt)
(Rrktio_date_t-hour dt) (Rrktio_date_t-hour dt)
@ -226,54 +225,62 @@
(define (rktio_make_sha2_ctx) (define (rktio_make_sha2_ctx)
(malloc _Rrktio_sha2_ctx_t)) (malloc _Rrktio_sha2_ctx_t))
(define (replace-ltps-open ht)
;; Disable rktio_ltps_open in demo mode, since it is not
;; connected to the host scheduler
(hash-set ht 'rktio_ltps_open
(lambda (x) (vector RKTIO_ERROR_KIND_RACKET
RKTIO_ERROR_UNSUPPORTED))))
(primitive-table '#%rktio (primitive-table '#%rktio
(let () (replace-ltps-open
(define-syntax extract-functions (let ()
(syntax-rules (define-constant (define-syntax extract-functions
define-type (syntax-rules (define-constant
define-struct-type define-type
define-function define-struct-type
define-function/errno define-function
define-function/errno+step) define-function/errno
[(_ accum) (hasheq . accum)] define-function/errno+step)
[(_ accum (define-constant . _) . rest) [(_ accum) (hasheq . accum)]
(extract-functions accum . rest)] [(_ accum (define-constant . _) . rest)
[(_ accum (define-type . _) . rest) (extract-functions accum . rest)]
(extract-functions accum . rest)] [(_ accum (define-type . _) . rest)
[(_ accum (define-struct-type . _) . rest) (extract-functions accum . rest)]
(extract-functions accum . rest)] [(_ accum (define-struct-type . _) . rest)
[(_ accum (define-function _ _ id . _) . rest) (extract-functions accum . rest)]
(extract-functions ('id id . accum) . rest)] [(_ accum (define-function _ _ id . _) . rest)
[(_ accum (define-function/errno _ _ _ id . _) . rest) (extract-functions ('id id . accum) . rest)]
(extract-functions ('id id . accum) . rest)] [(_ accum (define-function/errno _ _ _ id . _) . rest)
[(_ accum (define-function/errno+step _ _ _ id . _) . rest) (extract-functions ('id id . accum) . rest)]
(extract-functions ('id id . accum) . rest)])) [(_ accum (define-function/errno+step _ _ _ id . _) . rest)
(define-syntax-rule (begin form ...) (extract-functions ('id id . accum) . rest)]))
(extract-functions [#;(begin) (define-syntax-rule (begin form ...)
'rktio_NULL rktio_NULL (extract-functions [#;(begin)
'rktio_filesize_ref rktio_filesize_ref 'rktio_NULL rktio_NULL
'rktio_timestamp_ref rktio_timestamp_ref 'rktio_filesize_ref rktio_filesize_ref
'rktio_is_timestamp rktio_is_timestamp 'rktio_timestamp_ref rktio_timestamp_ref
'rktio_recv_length_ref rktio_recv_length_ref 'rktio_is_timestamp rktio_is_timestamp
'rktio_recv_address_ref rktio_recv_address_ref 'rktio_recv_length_ref rktio_recv_length_ref
'rktio_identity_to_vector rktio_identity_to_vector 'rktio_recv_address_ref rktio_recv_address_ref
'rktio_seconds_to_date* rktio_seconds_to_date* 'rktio_identity_to_vector rktio_identity_to_vector
'rktio_convert_result_to_vector rktio_convert_result_to_vector 'rktio_seconds_to_date* rktio_seconds_to_date*
'rktio_to_bytes rktio_to_bytes 'rktio_convert_result_to_vector rktio_convert_result_to_vector
'rktio_to_bytes_list rktio_to_bytes_list 'rktio_to_bytes rktio_to_bytes
'rktio_to_shorts rktio_to_shorts 'rktio_to_bytes_list rktio_to_bytes_list
'rktio_from_bytes_list rktio_from_bytes_list 'rktio_to_shorts rktio_to_shorts
'rktio_free_bytes_list rktio_free_bytes_list 'rktio_from_bytes_list rktio_from_bytes_list
'rktio_make_sha1_ctx rktio_make_sha1_ctx 'rktio_free_bytes_list rktio_free_bytes_list
'rktio_make_sha2_ctx rktio_make_sha2_ctx 'rktio_make_sha1_ctx rktio_make_sha1_ctx
'rktio_process_result_stdin_fd rktio_process_result_stdin_fd 'rktio_make_sha2_ctx rktio_make_sha2_ctx
'rktio_process_result_stdout_fd rktio_process_result_stdout_fd 'rktio_process_result_stdin_fd rktio_process_result_stdin_fd
'rktio_process_result_stderr_fd rktio_process_result_stderr_fd 'rktio_process_result_stdout_fd rktio_process_result_stdout_fd
'rktio_process_result_process rktio_process_result_process 'rktio_process_result_stderr_fd rktio_process_result_stderr_fd
'rktio_status_running rktio_status_running 'rktio_process_result_process rktio_process_result_process
'rktio_status_result rktio_status_result 'rktio_status_running rktio_status_running
'rktio_pipe_results rktio_pipe_results 'rktio_status_result rktio_status_result
'rktio_do_install_os_signal_handler rktio_do_install_os_signal_handler 'rktio_pipe_results rktio_pipe_results
'rktio_get_ctl_c_handler rktio_get_ctl_c_handler] 'rktio_do_install_os_signal_handler rktio_do_install_os_signal_handler
form ...)) 'rktio_get_ctl_c_handler rktio_get_ctl_c_handler]
(include "../../rktio/rktio.rktl"))) form ...))
(include "../../rktio/rktio.rktl"))))

42
racket/src/io/time/main.rkt
View File

@ -3,7 +3,6 @@
(provide seconds->date) (provide seconds->date)
(require racket/fixnum (require racket/fixnum
(only-in '#%kernel [date*? kernel:date*?])
"../common/check.rkt" "../common/check.rkt"
"../host/rktio.rkt" "../host/rktio.rkt"
"../host/error.rkt" "../host/error.rkt"
@ -12,26 +11,23 @@
(define rktio_seconds_to_date-error-kind (define rktio_seconds_to_date-error-kind
(vector-immutable RKTIO_ERROR_KIND_RACKET (vector-immutable RKTIO_ERROR_KIND_RACKET
RKTIO_ERROR_TIME_OUT_OF_RANGE )) RKTIO_ERROR_TIME_OUT_OF_RANGE))
(define/who seconds->date (define/who (seconds->date s [local? #t])
(case-lambda (check who real? s)
[(s) (seconds->date s #t)] (let* ([s (inexact->exact s)]
[(s local?) [si (floor s)]
(check who real? s) [get-gmt (if local? 0 1)]
(let* ([s (inexact->exact s)] [nsecs (floor (* (- s si) 1000000000))]
[si (floor s)] ;; The allocation, deallocation and the conversion of the
[get-gmt (if local? 0 1)] ;; rktio_date_t* result is hidden in rktio_seconds_to_date*,
[nsecs (floor (* (- s si) 1000000000))] ;; therefore no atomicity is needed here.
;; The allocation, deallocation and the conversion of the [dt (rktio_seconds_to_date* rktio si nsecs get-gmt)])
;; rktio_date_t* result is hidden in rktio_seconds_to_date*, (cond
;; therefore no atomicity is needed here. [(date*? dt)
[dt (rktio_seconds_to_date* rktio si nsecs get-gmt)]) dt]
(cond [(equal? dt rktio_seconds_to_date-error-kind)
[(kernel:date*? dt) (raise-arguments-error who "integer is out-of-range"
dt] "integer" si)]
[(equal? dt rktio_seconds_to_date-error-kind) [else
(raise-arguments-error who "integer is out-of-range" (raise-rktio-error who dt "conversion error")])))
"integer" si)]
[else
(raise-rktio-error who dt "conversion error")]))]))