From c7ca4414ca7151977208756ca993b0e68007a3fe Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 30 Dec 2020 04:49:48 -0700 Subject: [PATCH] cs & io: small clean-ups to `seconds->date` Streamline some things that probably needed to be different along the way. --- racket/src/cs/io.sls | 7 ++ racket/src/cs/rumble.sls | 1 - racket/src/cs/rumble/time.ss | 7 -- racket/src/cs/schemified/io.scm | 85 ++++++++++--------- racket/src/io/demo.rkt | 4 +- racket/src/io/host/bootstrap-rktio.rkt | 111 +++++++++++++------------ racket/src/io/time/main.rkt | 42 +++++----- 7 files changed, 132 insertions(+), 125 deletions(-) diff --git a/racket/src/cs/io.sls b/racket/src/cs/io.sls index 90d824868a..a368a46df6 100644 --- a/racket/src/cs/io.sls +++ b/racket/src/cs/io.sls @@ -213,6 +213,13 @@ (ftype-ref rktio_identity_t (b_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) (cond [(not (in-date-range? si)) diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index d239c8f5d5..259966ebd8 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -133,7 +133,6 @@ struct:date* date*? date* make-date* 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? arity-at-least-value diff --git a/racket/src/cs/rumble/time.ss b/racket/src/cs/rumble/time.ss index 0d44123216..02ae267e97 100644 --- a/racket/src/cs/rumble/time.ss +++ b/racket/src/cs/rumble/time.ss @@ -104,10 +104,3 @@ (define (current-seconds) (let ((t (current-time 'time-utc))) (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 "?")) diff --git a/racket/src/cs/schemified/io.scm b/racket/src/cs/schemified/io.scm index 1f9c17ec9d..07e05a8119 100644 --- a/racket/src/cs/schemified/io.scm +++ b/racket/src/cs/schemified/io.scm @@ -38087,46 +38087,51 @@ 'current-load-extension)) (define rktio_seconds_to_date-error-kind (vector-immutable 3 25)) (define 1/seconds->date - (|#%name| - seconds->date - (case-lambda - ((s_0) (begin (1/seconds->date s_0 #t))) - ((s_0 local?_0) - (begin - (if (real? s_0) - (void) - (raise-argument-error 'seconds->date "real?" s_0)) - (let ((s_1 (inexact->exact s_0))) - (let ((si_0 (floor s_1))) - (let ((get-gmt_0 (if local?_0 0 1))) - (let ((nsecs_0 (floor (* (- s_1 si_0) 1000000000)))) - (let ((dt_0 - (|#%app| - rktio_seconds_to_date* - (unsafe-place-local-ref cell.1) - si_0 - nsecs_0 - get-gmt_0))) - (if (date*? dt_0) - dt_0 - (if (equal? dt_0 rktio_seconds_to_date-error-kind) - (raise-arguments-error - 'seconds->date - "integer is out-of-range" - "integer" - si_0) - (let ((base-msg_0 "conversion error")) - (begin-unsafe - (raise - (let ((app_0 - (format-rktio-message - 'seconds->date - dt_0 - base-msg_0))) - (|#%app| - exn:fail - app_0 - (current-continuation-marks)))))))))))))))))) + (let ((seconds->date_0 + (|#%name| + seconds->date + (lambda (s2_0 local?1_0) + (begin + (begin + (if (real? s2_0) + (void) + (raise-argument-error 'seconds->date "real?" s2_0)) + (let ((s_0 (inexact->exact s2_0))) + (let ((si_0 (floor s_0))) + (let ((get-gmt_0 (if local?1_0 0 1))) + (let ((nsecs_0 (floor (* (- s_0 si_0) 1000000000)))) + (let ((dt_0 + (|#%app| + rktio_seconds_to_date* + (unsafe-place-local-ref cell.1) + si_0 + nsecs_0 + get-gmt_0))) + (if (date*? dt_0) + dt_0 + (if (equal? dt_0 rktio_seconds_to_date-error-kind) + (raise-arguments-error + 'seconds->date + "integer is out-of-range" + "integer" + si_0) + (let ((base-msg_0 "conversion error")) + (begin-unsafe + (raise + (let ((app_0 + (format-rktio-message + 'seconds->date + dt_0 + base-msg_0))) + (|#%app| + exn:fail + app_0 + (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 (|#%name| unsafe-poller diff --git a/racket/src/io/demo.rkt b/racket/src/io/demo.rkt index 638f56ac7f..f284670b84 100644 --- a/racket/src/io/demo.rkt +++ b/racket/src/io/demo.rkt @@ -747,8 +747,8 @@ (test l (sync l)) (define-values (tai tao) (tcp-accept l)) -(test #f (file-stream-port? i)) -(test #f (file-stream-port? o)) +(test #f (file-stream-port? ti)) +(test #f (file-stream-port? to)) (test 6 (write-string "hello\n" to)) (flush-output to) diff --git a/racket/src/io/host/bootstrap-rktio.rkt b/racket/src/io/host/bootstrap-rktio.rkt index 7673207bec..0f8501b7e7 100644 --- a/racket/src/io/host/bootstrap-rktio.rkt +++ b/racket/src/io/host/bootstrap-rktio.rkt @@ -2,7 +2,6 @@ (require racket/include racket/fixnum (only-in '#%linklet primitive-table) - (only-in '#%kernel [date* kernel:date*]) ffi/unsafe ffi/unsafe/atomic (for-syntax racket/base) @@ -135,7 +134,7 @@ (define dt (cast p _pointer _Rrktio_date_t-pointer)) (define tzn (Rrktio_date_t-zone_name dt)) (begin0 - (kernel:date* + (date* (Rrktio_date_t-second dt) (Rrktio_date_t-minute dt) (Rrktio_date_t-hour dt) @@ -226,54 +225,62 @@ (define (rktio_make_sha2_ctx) (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 - (let () - (define-syntax extract-functions - (syntax-rules (define-constant - define-type - define-struct-type - define-function - define-function/errno - define-function/errno+step) - [(_ accum) (hasheq . accum)] - [(_ accum (define-constant . _) . rest) - (extract-functions accum . rest)] - [(_ accum (define-type . _) . rest) - (extract-functions accum . rest)] - [(_ accum (define-struct-type . _) . rest) - (extract-functions accum . rest)] - [(_ accum (define-function _ _ id . _) . rest) - (extract-functions ('id id . accum) . rest)] - [(_ accum (define-function/errno _ _ _ id . _) . rest) - (extract-functions ('id id . accum) . rest)] - [(_ accum (define-function/errno+step _ _ _ id . _) . rest) - (extract-functions ('id id . accum) . rest)])) - (define-syntax-rule (begin form ...) - (extract-functions [#;(begin) - 'rktio_NULL rktio_NULL - 'rktio_filesize_ref rktio_filesize_ref - 'rktio_timestamp_ref rktio_timestamp_ref - 'rktio_is_timestamp rktio_is_timestamp - 'rktio_recv_length_ref rktio_recv_length_ref - 'rktio_recv_address_ref rktio_recv_address_ref - 'rktio_identity_to_vector rktio_identity_to_vector - 'rktio_seconds_to_date* rktio_seconds_to_date* - 'rktio_convert_result_to_vector rktio_convert_result_to_vector - 'rktio_to_bytes rktio_to_bytes - 'rktio_to_bytes_list rktio_to_bytes_list - 'rktio_to_shorts rktio_to_shorts - 'rktio_from_bytes_list rktio_from_bytes_list - 'rktio_free_bytes_list rktio_free_bytes_list - 'rktio_make_sha1_ctx rktio_make_sha1_ctx - 'rktio_make_sha2_ctx rktio_make_sha2_ctx - 'rktio_process_result_stdin_fd rktio_process_result_stdin_fd - 'rktio_process_result_stdout_fd rktio_process_result_stdout_fd - 'rktio_process_result_stderr_fd rktio_process_result_stderr_fd - 'rktio_process_result_process rktio_process_result_process - 'rktio_status_running rktio_status_running - 'rktio_status_result rktio_status_result - 'rktio_pipe_results rktio_pipe_results - 'rktio_do_install_os_signal_handler rktio_do_install_os_signal_handler - 'rktio_get_ctl_c_handler rktio_get_ctl_c_handler] - form ...)) - (include "../../rktio/rktio.rktl"))) + (replace-ltps-open + (let () + (define-syntax extract-functions + (syntax-rules (define-constant + define-type + define-struct-type + define-function + define-function/errno + define-function/errno+step) + [(_ accum) (hasheq . accum)] + [(_ accum (define-constant . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-type . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-struct-type . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-function _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)] + [(_ accum (define-function/errno _ _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)] + [(_ accum (define-function/errno+step _ _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)])) + (define-syntax-rule (begin form ...) + (extract-functions [#;(begin) + 'rktio_NULL rktio_NULL + 'rktio_filesize_ref rktio_filesize_ref + 'rktio_timestamp_ref rktio_timestamp_ref + 'rktio_is_timestamp rktio_is_timestamp + 'rktio_recv_length_ref rktio_recv_length_ref + 'rktio_recv_address_ref rktio_recv_address_ref + 'rktio_identity_to_vector rktio_identity_to_vector + 'rktio_seconds_to_date* rktio_seconds_to_date* + 'rktio_convert_result_to_vector rktio_convert_result_to_vector + 'rktio_to_bytes rktio_to_bytes + 'rktio_to_bytes_list rktio_to_bytes_list + 'rktio_to_shorts rktio_to_shorts + 'rktio_from_bytes_list rktio_from_bytes_list + 'rktio_free_bytes_list rktio_free_bytes_list + 'rktio_make_sha1_ctx rktio_make_sha1_ctx + 'rktio_make_sha2_ctx rktio_make_sha2_ctx + 'rktio_process_result_stdin_fd rktio_process_result_stdin_fd + 'rktio_process_result_stdout_fd rktio_process_result_stdout_fd + 'rktio_process_result_stderr_fd rktio_process_result_stderr_fd + 'rktio_process_result_process rktio_process_result_process + 'rktio_status_running rktio_status_running + 'rktio_status_result rktio_status_result + 'rktio_pipe_results rktio_pipe_results + 'rktio_do_install_os_signal_handler rktio_do_install_os_signal_handler + 'rktio_get_ctl_c_handler rktio_get_ctl_c_handler] + form ...)) + (include "../../rktio/rktio.rktl")))) diff --git a/racket/src/io/time/main.rkt b/racket/src/io/time/main.rkt index c4f15b4104..60747e6755 100644 --- a/racket/src/io/time/main.rkt +++ b/racket/src/io/time/main.rkt @@ -3,7 +3,6 @@ (provide seconds->date) (require racket/fixnum - (only-in '#%kernel [date*? kernel:date*?]) "../common/check.rkt" "../host/rktio.rkt" "../host/error.rkt" @@ -12,26 +11,23 @@ (define rktio_seconds_to_date-error-kind (vector-immutable RKTIO_ERROR_KIND_RACKET - RKTIO_ERROR_TIME_OUT_OF_RANGE )) + RKTIO_ERROR_TIME_OUT_OF_RANGE)) -(define/who seconds->date - (case-lambda - [(s) (seconds->date s #t)] - [(s local?) - (check who real? s) - (let* ([s (inexact->exact s)] - [si (floor s)] - [get-gmt (if local? 0 1)] - [nsecs (floor (* (- s si) 1000000000))] - ;; The allocation, deallocation and the conversion of the - ;; rktio_date_t* result is hidden in rktio_seconds_to_date*, - ;; therefore no atomicity is needed here. - [dt (rktio_seconds_to_date* rktio si nsecs get-gmt)]) - (cond - [(kernel:date*? dt) - dt] - [(equal? dt rktio_seconds_to_date-error-kind) - (raise-arguments-error who "integer is out-of-range" - "integer" si)] - [else - (raise-rktio-error who dt "conversion error")]))])) +(define/who (seconds->date s [local? #t]) + (check who real? s) + (let* ([s (inexact->exact s)] + [si (floor s)] + [get-gmt (if local? 0 1)] + [nsecs (floor (* (- s si) 1000000000))] + ;; The allocation, deallocation and the conversion of the + ;; rktio_date_t* result is hidden in rktio_seconds_to_date*, + ;; therefore no atomicity is needed here. + [dt (rktio_seconds_to_date* rktio si nsecs get-gmt)]) + (cond + [(date*? dt) + dt] + [(equal? dt rktio_seconds_to_date-error-kind) + (raise-arguments-error who "integer is out-of-range" + "integer" si)] + [else + (raise-rktio-error who dt "conversion error")])))