From c0561a8d1471d81f61c7d07eb917a2b2432b6d08 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Wed, 24 Jun 2026 17:44:32 -0400 Subject: [PATCH 1/3] java.time Phase 1: LocalDate/LocalTime/LocalDateTime/Instant Core java.time value types as jolt host objects backed by the inst-time.ss calendar engine (days-from-civil/civil-from-days/inst-fields/format-ms), in a new host/chez/java-time.ss. tz-free reps: LocalDate=epoch-day, LocalTime=nano-of-day, LocalDateTime=(epoch-day,nano-of-day); Instant reuses the ms-based instant jhost (ms granularity; nano is a documented gap). Each type registers statics (of/parse/now/MIN/MAX/...), instance methods (plus/minus/with/get/isBefore/until/toString/...), =/hash, compare, ISO-8601 print, instance?, and value-host-tags for protocol dispatch. Reconciles the old ms-based local-date/local-dt stubs into the rich types (LocalDateTime now prints ISO; .toLocalDate/.atZone paths preserved). The four cljc.java-time namespaces (local-date/local-time/local-date-time/instant) load. Deep temporal-field/unit machinery (range/get-long/with-field/until/ adjust-into) stubbed for Phase 2. 12 corpus rows certified vs JVM 1.12.5. make test + shakesmoke green, 0 new divergences, data.json stays 138/139, selfhost holds. --- host/chez/inst-time.ss | 35 ++- host/chez/java-time.ss | 515 +++++++++++++++++++++++++++++++++++++++++ host/chez/records.ss | 3 + host/chez/rt.ss | 6 + test/chez/corpus.edn | 12 + 5 files changed, 560 insertions(+), 11 deletions(-) create mode 100644 host/chez/java-time.ss diff --git a/host/chez/inst-time.ss b/host/chez/inst-time.ss index 89f343d..701b30f 100644 --- a/host/chez/inst-time.ss +++ b/host/chez/inst-time.ss @@ -245,7 +245,9 @@ ;; java.time.Instant/ZonedDateTime/LocalDateTime values (mk-instant/mk-zoned/mk-local ;; jhosts) are equal when same kind + same epoch-ms — two parsed Instants compare =. -(define (time-jhost? x) (and (jhost? x) (member (jhost-tag x) '("instant" "zoned-dt" "local-dt" "local-date" "sql-date")) #t)) +;; java.time LocalDate/LocalTime/LocalDateTime own their = / hash in java-time.ss; +;; this arm covers the ms-based shim values (instant / zoned-dt / sql-date). +(define (time-jhost? x) (and (jhost? x) (member (jhost-tag x) '("instant" "zoned-dt" "sql-date")) #t)) (register-eq-arm! (lambda (a b) (or (time-jhost? a) (time-jhost? b))) (lambda (a b) (and (time-jhost? a) (time-jhost? b) (string=? (jhost-tag a) (jhost-tag b)) @@ -274,7 +276,6 @@ ((string=? tn "Timestamp") #f) (else 'pass))) ((and (jhost? val) (string=? (jhost-tag val) "instant")) (if (string=? tn "Instant") #t 'pass)) - ((and (jhost? val) (string=? (jhost-tag val) "local-dt")) (if (string=? tn "LocalDateTime") #t 'pass)) ;; java.sql.Date is a java.util.Date subclass (but not a Timestamp). ((and (jhost? val) (string=? (jhost-tag val) "sql-date")) (cond ((or (string=? tn "Date")) #t) ((string=? tn "Timestamp") #f) (else 'pass))) @@ -284,16 +285,31 @@ (def-var! "clojure.core" "inst-ms*" (lambda (i) (jinst-ms i))) ;; --- java.time shim values (jhost objects over host-static.ss registries) ----- +;; "local-date" stores an epoch-day (java-time.ss owns the type); ms-of projects it +;; to UTC midnight so existing date math keeps working. "local-dt" stores epoch-day + +;; nano-of-day; the others store epoch-ms. (define (ms-of d) (cond ((number? d) d) ((jinst? d) (jinst-ms d)) - ((and (jhost? d) (member (jhost-tag d) '("instant" "zoned-dt" "local-dt" "local-date" "calendar" "sql-date"))) + ((and (jhost? d) (string=? (jhost-tag d) "local-date")) + (* (vector-ref (jhost-state d) 0) 86400000)) + ((and (jhost? d) (string=? (jhost-tag d) "local-date-time")) + (+ (* (vector-ref (jhost-state d) 0) 86400000) + (quotient (vector-ref (jhost-state d) 1) 1000000))) + ((and (jhost? d) (member (jhost-tag d) '("instant" "zoned-dt" "calendar" "sql-date"))) (vector-ref (jhost-state d) 0)) (else (error #f "not a date value" d)))) (define (mk-instant ms) (make-jhost "instant" (vector ms))) (define (mk-zoned ms) (make-jhost "zoned-dt" (vector ms))) -(define (mk-local ms) (make-jhost "local-dt" (vector ms))) -(define (mk-local-date ms) (make-jhost "local-date" (vector ms))) +;; LocalDateTime from epoch-ms (UTC): the java-time.ss "local-date-time" jhost, +;; state [epoch-day nano-of-day]. +(define (mk-local ms) + (let* ((ems (exact (truncate ms))) + (ed (inst-floor-div ems 86400000)) + (mod (inst-floor-mod ems 86400000))) + (make-jhost "local-date-time" (vector ed (* mod 1000000))))) +;; local-date from epoch-ms: the epoch-day of the UTC day containing ms. +(define (mk-local-date ms) (make-jhost "local-date" (vector (inst-floor-div (exact (truncate ms)) 86400000)))) ;; start of the UTC day containing ms. (define (start-of-utc-day ms) (* (inst-floor-div (exact (truncate ms)) 86400000) 86400000)) @@ -310,13 +326,10 @@ (register-host-methods! "zoned-dt" (list (cons "toLocalDateTime" (lambda (self) (mk-local (ms-of self)))) (cons "toInstant" (lambda (self) (mk-instant (ms-of self)))))) -(register-host-methods! "local-dt" - (list (cons "atZone" (lambda (self zone) (mk-zoned (ms-of self)))) - (cons "toLocalDate" (lambda (self) (mk-local-date (ms-of self)))))) -;; LocalDate.atStartOfDay(zone): midnight of the UTC day (the layer is UTC). +;; LocalDate.atZone(zone): the UTC layer treats it as a zoned value at midnight. +;; (java-time.ss registers atStartOfDay and the rest of the local-date surface.) (register-host-methods! "local-date" - (list (cons "atStartOfDay" (lambda (self . zone) (mk-zoned (start-of-utc-day (ms-of self))))) - (cons "atZone" (lambda (self zone) (mk-zoned (ms-of self)))))) + (list (cons "atZone" (lambda (self zone) (mk-zoned (ms-of self)))))) (register-host-methods! "dt-formatter" (list (cons "withLocale" (lambda (self locale) (mk-formatter (fmt-pat self)))) (cons "withZone" (lambda (self zone) (mk-formatter (fmt-pat self)))) diff --git a/host/chez/java-time.ss b/host/chez/java-time.ss new file mode 100644 index 0000000..7e6837e --- /dev/null +++ b/host/chez/java-time.ss @@ -0,0 +1,515 @@ +;; java.time core value types: LocalDate, LocalTime, LocalDateTime, Instant. +;; +;; Each is a tz-free jhost over an integer state: +;; local-date (vector epoch-day) day number from 1970-01-01 +;; local-time (vector nano-of-day) [0, 86_400_000_000_000) +;; local-dt (vector epoch-day nano-of-day) +;; instant (vector epoch-ms) reused from inst-time.ss +;; +;; The cljc.java-time wrappers are thin interop over these — static factories +;; (LocalDate/of …) reach register-class-statics!, instance methods reach the +;; per-tag method tables. Equality / hash / compare / print / instance? / protocol +;; dispatch are wired through the host registries. +;; +;; Precision: Instant is millisecond-granular (it carries epoch-ms only). get-nano +;; reports (ms-sub-second * 1e6); plus-nanos / plus-millis round to the millisecond. +;; LocalTime / LocalDateTime carry full nanosecond precision. + +;; --- shared helpers ---------------------------------------------------------- +(define nanos-per-day 86400000000000) +(define nanos-per-sec 1000000000) + +(define (jt-floor-div a b) (let ((q (quotient a b)) (r (remainder a b))) + (if (and (not (= r 0)) (< (* a b) 0)) (- q 1) q))) +(define (jt-floor-mod a b) (- a (* (jt-floor-div a b) b))) +(define (jt->exact n) (cond ((and (number? n) (exact? n) (integer? n)) n) + ((number? n) (exact (truncate n))) + (else (error #f "java.time: not an integer" n)))) + +(define (jt-leap? y) (and (= 0 (modulo y 4)) (or (not (= 0 (modulo y 100))) (= 0 (modulo y 400))))) +(define (jt-len-of-month y m) + (cond ((= m 2) (if (jt-leap? y) 29 28)) + ((memv m '(4 6 9 11)) 30) + (else 31))) + +;; constructors +(define (jt-local-date ed) (make-jhost "local-date" (vector ed))) +(define (jt-local-time nod) (make-jhost "local-time" (vector nod))) +(define (jt-local-dt ed nod) (make-jhost "local-date-time" (vector ed nod))) + +;; state accessors +(define (ld-epoch-day d) (vector-ref (jhost-state d) 0)) +(define (lt-nano-of-day t) (vector-ref (jhost-state t) 0)) +;; the LocalDateTime jhost uses tag "local-date-time" with [epoch-day nano-of-day]. +;; inst-time.ss's ms-based "local-dt" tag stays for the #inst formatting shim. +(define (ldt-epoch-day x) (vector-ref (jhost-state x) 0)) +(define (ldt-nano-of-day x) (vector-ref (jhost-state x) 1)) + +;; civil <-> epoch-day (inst-time.ss owns days-from-civil / civil-from-days) +(define (ymd->epoch-day y m d) (days-from-civil y m d)) +(define (epoch-day->ymd ed) (civil-from-days ed)) ; -> (values y m d) + +;; build a LocalDate, normalizing month/day overflow the way java.time does: +;; the year/month roll, then the day is clamped to the month length. +(define (jt-date-of y m d) + (let* ((ym (+ (* y 12) (- m 1))) + (y2 (jt-floor-div ym 12)) + (m2 (+ 1 (jt-floor-mod ym 12))) + (dom (min d (jt-len-of-month y2 m2)))) + (jt-local-date (ymd->epoch-day y2 m2 dom)))) + +;; day-of-week: 1970-01-01 is Thursday; java.time DayOfWeek is 1=Mon..7=Sun. +(define (ld-dow ed) (+ 1 (jt-floor-mod (+ ed 3) 7))) +(define jt-day-names (vector "MONDAY" "TUESDAY" "WEDNESDAY" "THURSDAY" "FRIDAY" "SATURDAY" "SUNDAY")) +(define jt-month-names (vector "JANUARY" "FEBRUARY" "MARCH" "APRIL" "MAY" "JUNE" "JULY" + "AUGUST" "SEPTEMBER" "OCTOBER" "NOVEMBER" "DECEMBER")) + +(define (ld-day-of-year ed) + (call-with-values (lambda () (epoch-day->ymd ed)) + (lambda (y m d) (+ 1 (- ed (ymd->epoch-day y 1 1)))))) + +;; nano-of-day <-> (h m s nano) +(define (hmsn->nano h m s nano) (+ (* (+ (* h 3600) (* m 60) s) nanos-per-sec) nano)) +(define (lt-hour t) (quotient (lt-nano-of-day t) (* 3600 nanos-per-sec))) +(define (lt-minute t) (modulo (quotient (lt-nano-of-day t) (* 60 nanos-per-sec)) 60)) +(define (lt-second t) (modulo (quotient (lt-nano-of-day t) nanos-per-sec) 60)) +(define (lt-nano t) (modulo (lt-nano-of-day t) nanos-per-sec)) + +;; --- ISO-8601 rendering ------------------------------------------------------ +(define (iso-date-str ed) + (call-with-values (lambda () (epoch-day->ymd ed)) + (lambda (y m d) (string-append (pad4 y) "-" (pad2 m) "-" (pad2 d))))) + +;; LocalTime: "HH:mm", "HH:mm:ss", or with a fractional second (3/6/9 digits). +(define (frac-digits nano) + (cond ((= 0 (modulo nano 1000000)) (let ((s (number->string (quotient nano 1000000)))) + (string-append (make-string (max 0 (- 3 (string-length s))) #\0) s))) + ((= 0 (modulo nano 1000)) (let ((s (number->string (quotient nano 1000)))) + (string-append (make-string (max 0 (- 6 (string-length s))) #\0) s))) + (else (let ((s (number->string nano))) + (string-append (make-string (max 0 (- 9 (string-length s))) #\0) s))))) +(define (iso-time-str nod) + (let ((h (quotient nod (* 3600 nanos-per-sec))) + (mi (modulo (quotient nod (* 60 nanos-per-sec)) 60)) + (s (modulo (quotient nod nanos-per-sec) 60)) + (nano (modulo nod nanos-per-sec))) + (string-append (pad2 h) ":" (pad2 mi) + (if (and (= s 0) (= nano 0)) "" + (string-append ":" (pad2 s) (if (= nano 0) "" (string-append "." (frac-digits nano)))))))) +(define (iso-datetime-str ed nod) + (string-append (iso-date-str ed) "T" (iso-time-str nod))) +;; Instant: always UTC with a trailing Z; seconds always shown, millis only when nonzero. +(define (iso-instant-str ms) + (let* ((ems (exact (truncate ms))) + (secs (jt-floor-div ems 1000)) + (frac (- ems (* secs 1000))) + (ed (jt-floor-div secs 86400)) + (sod (jt-floor-mod secs 86400)) + (nod (* (+ (* (quotient sod 3600) 3600) (* (quotient (modulo sod 3600) 60) 60) (modulo sod 60)) + nanos-per-sec))) + (string-append (iso-date-str ed) "T" + (pad2 (quotient sod 3600)) ":" (pad2 (modulo (quotient sod 60) 60)) ":" (pad2 (modulo sod 60)) + (if (= frac 0) "" (string-append "." (frac-digits (* frac 1000000)))) + "Z"))) + +;; --- ISO parsing ------------------------------------------------------------- +(define (jt-str x) (if (string? x) x (jolt-str-render-one x))) +;; "yyyy-MM-dd" -> epoch-day +(define (parse-iso-date s) + (let ((y (digits-at s 0 4)) (m (digits-at s 5 2)) (d (digits-at s 8 2))) + (if (and y m d (char=? (string-ref s 4) #\-) (char=? (string-ref s 7) #\-)) + (ymd->epoch-day y m d) + (error #f (string-append "could not parse LocalDate: " s))))) +;; "HH:mm[:ss[.fff…]]" -> nano-of-day +(define (parse-iso-time s) + (let ((len (string-length s))) + (let ((h (digits-at s 0 2)) (mi (digits-at s 3 2))) + (unless (and h mi (char=? (string-ref s 2) #\:)) + (error #f (string-append "could not parse LocalTime: " s))) + (let ((s2 (and (> len 5) (char=? (string-ref s 5) #\:) (digits-at s 6 2)))) + (if (not s2) + (hmsn->nano h mi 0 0) + (let loop ((i 8) (nano 0)) ; optional .fraction + (if (and (< i len) (char=? (string-ref s 8) #\.)) + (let frac ((j 9) (k 0) (acc 0)) + (if (and (< j len) (digit? (string-ref s j))) + (frac (+ j 1) (+ k 1) (+ (* acc 10) (- (char->integer (string-ref s j)) 48))) + (hmsn->nano h mi s2 (* acc (expt 10 (max 0 (- 9 k))))))) + (hmsn->nano h mi s2 0)))))))) +;; "yyyy-MM-ddTHH:mm[:ss[.fff]]" -> (values epoch-day nano-of-day) +(define (parse-iso-datetime s) + (let ((ti (let loop ((i 0)) (cond ((>= i (string-length s)) #f) + ((or (char=? (string-ref s i) #\T) (char=? (string-ref s i) #\t)) i) + (else (loop (+ i 1))))))) + (unless ti (error #f (string-append "could not parse LocalDateTime: " s))) + (values (parse-iso-date (substring s 0 ti)) + (parse-iso-time (substring s (+ ti 1) (string-length s)))))) + +;; --- LocalDate --------------------------------------------------------------- +(define ld-min (jt-local-date (ymd->epoch-day -999999999 1 1))) +(define ld-max (jt-local-date (ymd->epoch-day 999999999 12 31))) + +(register-class-statics! "LocalDate" + (list (cons "of" (lambda (y m d) (jt-date-of (jt->exact y) (jt->exact m) (jt->exact d)))) + (cons "ofEpochDay" (lambda (n) (jt-local-date (jt->exact n)))) + (cons "ofYearDay" (lambda (y doy) (jt-local-date (+ (ymd->epoch-day (jt->exact y) 1 1) (- (jt->exact doy) 1))))) + (cons "parse" (lambda (s . _) (jt-local-date (parse-iso-date (jt-str s))))) + (cons "now" (lambda _ (mk-local-date (now-ms)))) + (cons "from" (lambda (t) (cond ((and (jhost? t) (string=? (jhost-tag t) "local-date")) t) + ((and (jhost? t) (string=? (jhost-tag t) "local-date-time")) (jt-local-date (ldt-epoch-day t))) + (else (mk-local-date (ms-of t)))))) + (cons "MIN" ld-min) + (cons "MAX" ld-max))) + +(define (ld-plus-months d n) + (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) + (lambda (y m dom) + (let* ((ym (+ (* y 12) (- m 1) n)) + (y2 (jt-floor-div ym 12)) (m2 (+ 1 (jt-floor-mod ym 12)))) + (jt-local-date (ymd->epoch-day y2 m2 (min dom (jt-len-of-month y2 m2)))))))) +(define (ld-plus-years d n) + (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) + (lambda (y m dom) (jt-local-date (ymd->epoch-day (+ y n) m (min dom (jt-len-of-month (+ y n) m))))))) + +(define (ld-with-field d which v) + (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) + (lambda (y m dom) + (case which + ((year) (jt-local-date (ymd->epoch-day v m (min dom (jt-len-of-month v m))))) + ((month) (jt-local-date (ymd->epoch-day y v (min dom (jt-len-of-month y v))))) + ((day) (jt-local-date (ymd->epoch-day y m v))) + ((day-of-year) (jt-local-date (+ (ymd->epoch-day y 1 1) (- v 1)))))))) + +(register-host-methods! "local-date" + (list (cons "getYear" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) y)))) + (cons "getMonthValue" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) m)))) + (cons "getDayOfMonth" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) dd)))) + (cons "getMonth" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) + (lambda (y m dd) (make-jhost "month-enum" (vector m)))))) + (cons "getDayOfWeek" (lambda (d) (make-jhost "dow-enum" (vector (ld-dow (ld-epoch-day d)))))) + (cons "getDayOfYear" (lambda (d) (ld-day-of-year (ld-epoch-day d)))) + (cons "toEpochDay" (lambda (d) (ld-epoch-day d))) + (cons "lengthOfMonth" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) + (lambda (y m dd) (jt-len-of-month y m))))) + (cons "lengthOfYear" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) + (lambda (y m dd) (if (jt-leap? y) 366 365))))) + (cons "isLeapYear" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) + (lambda (y m dd) (jt-leap? y))))) + (cons "plusDays" (lambda (d n) (jt-local-date (+ (ld-epoch-day d) (jt->exact n))))) + (cons "minusDays" (lambda (d n) (jt-local-date (- (ld-epoch-day d) (jt->exact n))))) + (cons "plusWeeks" (lambda (d n) (jt-local-date (+ (ld-epoch-day d) (* 7 (jt->exact n)))))) + (cons "minusWeeks" (lambda (d n) (jt-local-date (- (ld-epoch-day d) (* 7 (jt->exact n)))))) + (cons "plusMonths" (lambda (d n) (ld-plus-months d (jt->exact n)))) + (cons "minusMonths" (lambda (d n) (ld-plus-months d (- (jt->exact n))))) + (cons "plusYears" (lambda (d n) (ld-plus-years d (jt->exact n)))) + (cons "minusYears" (lambda (d n) (ld-plus-years d (- (jt->exact n))))) + (cons "withYear" (lambda (d v) (ld-with-field d 'year (jt->exact v)))) + (cons "withMonth" (lambda (d v) (ld-with-field d 'month (jt->exact v)))) + (cons "withDayOfMonth" (lambda (d v) (ld-with-field d 'day (jt->exact v)))) + (cons "withDayOfYear" (lambda (d v) (ld-with-field d 'day-of-year (jt->exact v)))) + (cons "isBefore" (lambda (d o) (< (ld-epoch-day d) (ld-epoch-day o)))) + (cons "isAfter" (lambda (d o) (> (ld-epoch-day d) (ld-epoch-day o)))) + (cons "isEqual" (lambda (d o) (= (ld-epoch-day d) (ld-epoch-day o)))) + (cons "compareTo" (lambda (d o) (let ((a (ld-epoch-day d)) (b (ld-epoch-day o))) + (cond ((< a b) -1) ((> a b) 1) (else 0))))) + (cons "equals" (lambda (d o) (and (jhost? o) (string=? (jhost-tag o) "local-date") (= (ld-epoch-day d) (ld-epoch-day o))))) + (cons "hashCode" (lambda (d) (ld-epoch-day d))) + (cons "atStartOfDay" (lambda (d . _) (jt-local-dt (ld-epoch-day d) 0))) + (cons "atTime" (case-lambda + ((d t) (if (and (jhost? t) (string=? (jhost-tag t) "local-time")) + (jt-local-dt (ld-epoch-day d) (lt-nano-of-day t)) + (error #f "atTime: expected LocalTime"))) + ((d h m) (jt-local-dt (ld-epoch-day d) (hmsn->nano (jt->exact h) (jt->exact m) 0 0))) + ((d h m s) (jt-local-dt (ld-epoch-day d) (hmsn->nano (jt->exact h) (jt->exact m) (jt->exact s) 0))) + ((d h m s nano) (jt-local-dt (ld-epoch-day d) (hmsn->nano (jt->exact h) (jt->exact m) (jt->exact s) (jt->exact nano)))))) + (cons "toString" (lambda (d) (iso-date-str (ld-epoch-day d)))))) + +;; --- LocalTime --------------------------------------------------------------- +(define lt-min (jt-local-time 0)) +(define lt-max (jt-local-time (- nanos-per-day 1))) + +(register-class-statics! "LocalTime" + (list (cons "of" (case-lambda + ((h m) (jt-local-time (hmsn->nano (jt->exact h) (jt->exact m) 0 0))) + ((h m s) (jt-local-time (hmsn->nano (jt->exact h) (jt->exact m) (jt->exact s) 0))) + ((h m s nano) (jt-local-time (hmsn->nano (jt->exact h) (jt->exact m) (jt->exact s) (jt->exact nano)))))) + (cons "ofNanoOfDay" (lambda (n) (jt-local-time (jt->exact n)))) + (cons "ofSecondOfDay" (lambda (n) (jt-local-time (* (jt->exact n) nanos-per-sec)))) + (cons "parse" (lambda (s . _) (jt-local-time (parse-iso-time (jt-str s))))) + (cons "now" (lambda _ (jt-local-time (let ((ms (now-ms))) (* (jt-floor-mod (exact (truncate ms)) 86400000) 1000000))))) + (cons "from" (lambda (t) (cond ((and (jhost? t) (string=? (jhost-tag t) "local-time")) t) + ((and (jhost? t) (string=? (jhost-tag t) "local-date-time")) (jt-local-time (ldt-nano-of-day t))) + (else (error #f "LocalTime/from: unsupported"))))) + (cons "MIN" lt-min) + (cons "MAX" lt-max) + (cons "MIDNIGHT" (jt-local-time 0)) + (cons "NOON" (jt-local-time (* 12 3600 nanos-per-sec))))) + +(define (lt-plus t nanos) (jt-local-time (jt-floor-mod (+ (lt-nano-of-day t) nanos) nanos-per-day))) +(define (lt-with t which v) + (let ((h (lt-hour t)) (mi (lt-minute t)) (s (lt-second t)) (nano (lt-nano t))) + (case which + ((hour) (jt-local-time (hmsn->nano v mi s nano))) + ((minute) (jt-local-time (hmsn->nano h v s nano))) + ((second) (jt-local-time (hmsn->nano h mi v nano))) + ((nano) (jt-local-time (hmsn->nano h mi s v)))))) + +(register-host-methods! "local-time" + (list (cons "getHour" (lambda (t) (lt-hour t))) + (cons "getMinute" (lambda (t) (lt-minute t))) + (cons "getSecond" (lambda (t) (lt-second t))) + (cons "getNano" (lambda (t) (lt-nano t))) + (cons "toNanoOfDay" (lambda (t) (lt-nano-of-day t))) + (cons "toSecondOfDay" (lambda (t) (quotient (lt-nano-of-day t) nanos-per-sec))) + (cons "plusHours" (lambda (t n) (lt-plus t (* (jt->exact n) 3600 nanos-per-sec)))) + (cons "minusHours" (lambda (t n) (lt-plus t (- (* (jt->exact n) 3600 nanos-per-sec))))) + (cons "plusMinutes" (lambda (t n) (lt-plus t (* (jt->exact n) 60 nanos-per-sec)))) + (cons "minusMinutes" (lambda (t n) (lt-plus t (- (* (jt->exact n) 60 nanos-per-sec))))) + (cons "plusSeconds" (lambda (t n) (lt-plus t (* (jt->exact n) nanos-per-sec)))) + (cons "minusSeconds" (lambda (t n) (lt-plus t (- (* (jt->exact n) nanos-per-sec))))) + (cons "plusNanos" (lambda (t n) (lt-plus t (jt->exact n)))) + (cons "minusNanos" (lambda (t n) (lt-plus t (- (jt->exact n))))) + (cons "withHour" (lambda (t v) (lt-with t 'hour (jt->exact v)))) + (cons "withMinute" (lambda (t v) (lt-with t 'minute (jt->exact v)))) + (cons "withSecond" (lambda (t v) (lt-with t 'second (jt->exact v)))) + (cons "withNano" (lambda (t v) (lt-with t 'nano (jt->exact v)))) + (cons "truncatedTo" (lambda (t u) (lt-truncate t u))) + (cons "isBefore" (lambda (t o) (< (lt-nano-of-day t) (lt-nano-of-day o)))) + (cons "isAfter" (lambda (t o) (> (lt-nano-of-day t) (lt-nano-of-day o)))) + (cons "compareTo" (lambda (t o) (let ((a (lt-nano-of-day t)) (b (lt-nano-of-day o))) + (cond ((< a b) -1) ((> a b) 1) (else 0))))) + (cons "equals" (lambda (t o) (and (jhost? o) (string=? (jhost-tag o) "local-time") (= (lt-nano-of-day t) (lt-nano-of-day o))))) + (cons "hashCode" (lambda (t) (lt-nano-of-day t))) + (cons "atDate" (lambda (t d) (jt-local-dt (ld-epoch-day d) (lt-nano-of-day t)))) + (cons "toString" (lambda (t) (iso-time-str (lt-nano-of-day t)))))) + +;; truncatedTo a ChronoUnit: zero out below the unit. The unit arrives as a +;; chrono-unit jhost (name) or a keyword/string; common units only. +(define (chrono-unit-name u) + (cond ((and (jhost? u) (string=? (jhost-tag u) "chrono-unit")) (vector-ref (jhost-state u) 0)) + ((string? u) u) + ((keyword? u) (keyword-t-name u)) + (else #f))) +(define (lt-truncate t u) + (let* ((nod (lt-nano-of-day t)) + (unit (chrono-unit-name u)) + (div (cond ((not unit) 1) + ((string-ci=? unit "NANOS") 1) + ((string-ci=? unit "MICROS") 1000) + ((string-ci=? unit "MILLIS") 1000000) + ((string-ci=? unit "SECONDS") nanos-per-sec) + ((string-ci=? unit "MINUTES") (* 60 nanos-per-sec)) + ((string-ci=? unit "HOURS") (* 3600 nanos-per-sec)) + ((string-ci=? unit "DAYS") nanos-per-day) + (else 1)))) + (jt-local-time (* (quotient nod div) div)))) + +;; --- LocalDateTime ----------------------------------------------------------- +(define ldt-min (jt-local-dt (ymd->epoch-day -999999999 1 1) 0)) +(define ldt-max (jt-local-dt (ymd->epoch-day 999999999 12 31) (- nanos-per-day 1))) + +;; epoch-seconds at a zero offset (the tz-free layer treats LocalDateTime as UTC). +(define (ldt->epoch-second x) (+ (* (ldt-epoch-day x) 86400) (quotient (ldt-nano-of-day x) nanos-per-sec))) +(define (ldt->ms x) (+ (* (ldt-epoch-day x) 86400000) (quotient (ldt-nano-of-day x) 1000000))) + +(register-class-statics! "LocalDateTime" + (list (cons "of" (case-lambda + ((d t) (jt-local-dt (ld-epoch-day d) (lt-nano-of-day t))) ; (LocalDate LocalTime) + ((y mo d h mi) (jt-local-dt (ymd->epoch-day (jt->exact y) (jt->exact mo) (jt->exact d)) + (hmsn->nano (jt->exact h) (jt->exact mi) 0 0))) + ((y mo d h mi s) (jt-local-dt (ymd->epoch-day (jt->exact y) (jt->exact mo) (jt->exact d)) + (hmsn->nano (jt->exact h) (jt->exact mi) (jt->exact s) 0))) + ((y mo d h mi s nano) (jt-local-dt (ymd->epoch-day (jt->exact y) (jt->exact mo) (jt->exact d)) + (hmsn->nano (jt->exact h) (jt->exact mi) (jt->exact s) (jt->exact nano)))))) + (cons "ofEpochSecond" (lambda (secs nano off) + (let ((es (jt->exact secs))) + (jt-local-dt (jt-floor-div es 86400) + (+ (* (jt-floor-mod es 86400) nanos-per-sec) (jt->exact nano)))))) + (cons "ofInstant" (lambda (inst . _) (let ((ms (ms-of inst))) + (jt-local-dt (jt-floor-div (exact (truncate ms)) 86400000) + (* (jt-floor-mod (exact (truncate ms)) 86400000) 1000000))))) + (cons "parse" (lambda (s . _) (call-with-values (lambda () (parse-iso-datetime (jt-str s))) + (lambda (ed nod) (jt-local-dt ed nod))))) + (cons "now" (lambda _ (let ((ms (exact (truncate (now-ms))))) + (jt-local-dt (jt-floor-div ms 86400000) (* (jt-floor-mod ms 86400000) 1000000))))) + (cons "from" (lambda (t) (cond ((and (jhost? t) (string=? (jhost-tag t) "local-date-time")) t) + (else (let ((ms (ms-of t))) + (jt-local-dt (jt-floor-div (exact (truncate ms)) 86400000) + (* (jt-floor-mod (exact (truncate ms)) 86400000) 1000000))))))) + (cons "MIN" ldt-min) + (cons "MAX" ldt-max))) + +;; date / time arithmetic on a LocalDateTime: round-trip through the components. +(define (ldt-date x) (jt-local-date (ldt-epoch-day x))) +(define (ldt-time x) (jt-local-time (ldt-nano-of-day x))) +(define (ldt-combine d t) (jt-local-dt (ld-epoch-day d) (lt-nano-of-day t))) +;; add nanos to a LocalDateTime, carrying whole days into the date. +(define (ldt-plus-nanos x nanos) + (let* ((total (+ (ldt-nano-of-day x) nanos)) + (carry (jt-floor-div total nanos-per-day)) + (nod (jt-floor-mod total nanos-per-day))) + (jt-local-dt (+ (ldt-epoch-day x) carry) nod))) + +(register-host-methods! "local-date-time" + (list (cons "getYear" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day x))) (lambda (y m d) y)))) + (cons "getMonthValue" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day x))) (lambda (y m d) m)))) + (cons "getMonth" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day x))) (lambda (y m d) (make-jhost "month-enum" (vector m)))))) + (cons "getDayOfMonth" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day x))) (lambda (y m d) d)))) + (cons "getDayOfWeek" (lambda (x) (make-jhost "dow-enum" (vector (ld-dow (ldt-epoch-day x)))))) + (cons "getDayOfYear" (lambda (x) (ld-day-of-year (ldt-epoch-day x)))) + (cons "getHour" (lambda (x) (lt-hour (ldt-time x)))) + (cons "getMinute" (lambda (x) (lt-minute (ldt-time x)))) + (cons "getSecond" (lambda (x) (lt-second (ldt-time x)))) + (cons "getNano" (lambda (x) (lt-nano (ldt-time x)))) + (cons "toLocalDate" (lambda (x) (ldt-date x))) + (cons "toLocalTime" (lambda (x) (ldt-time x))) + (cons "toEpochSecond" (lambda (x . _) (ldt->epoch-second x))) + (cons "plusDays" (lambda (x n) (jt-local-dt (+ (ldt-epoch-day x) (jt->exact n)) (ldt-nano-of-day x)))) + (cons "minusDays" (lambda (x n) (jt-local-dt (- (ldt-epoch-day x) (jt->exact n)) (ldt-nano-of-day x)))) + (cons "plusWeeks" (lambda (x n) (jt-local-dt (+ (ldt-epoch-day x) (* 7 (jt->exact n))) (ldt-nano-of-day x)))) + (cons "minusWeeks" (lambda (x n) (jt-local-dt (- (ldt-epoch-day x) (* 7 (jt->exact n))) (ldt-nano-of-day x)))) + (cons "plusMonths" (lambda (x n) (ldt-combine (ld-plus-months (ldt-date x) (jt->exact n)) (ldt-time x)))) + (cons "minusMonths" (lambda (x n) (ldt-combine (ld-plus-months (ldt-date x) (- (jt->exact n))) (ldt-time x)))) + (cons "plusYears" (lambda (x n) (ldt-combine (ld-plus-years (ldt-date x) (jt->exact n)) (ldt-time x)))) + (cons "minusYears" (lambda (x n) (ldt-combine (ld-plus-years (ldt-date x) (- (jt->exact n))) (ldt-time x)))) + (cons "plusHours" (lambda (x n) (ldt-plus-nanos x (* (jt->exact n) 3600 nanos-per-sec)))) + (cons "minusHours" (lambda (x n) (ldt-plus-nanos x (- (* (jt->exact n) 3600 nanos-per-sec))))) + (cons "plusMinutes" (lambda (x n) (ldt-plus-nanos x (* (jt->exact n) 60 nanos-per-sec)))) + (cons "minusMinutes" (lambda (x n) (ldt-plus-nanos x (- (* (jt->exact n) 60 nanos-per-sec))))) + (cons "plusSeconds" (lambda (x n) (ldt-plus-nanos x (* (jt->exact n) nanos-per-sec)))) + (cons "minusSeconds" (lambda (x n) (ldt-plus-nanos x (- (* (jt->exact n) nanos-per-sec))))) + (cons "plusNanos" (lambda (x n) (ldt-plus-nanos x (jt->exact n)))) + (cons "minusNanos" (lambda (x n) (ldt-plus-nanos x (- (jt->exact n))))) + (cons "withYear" (lambda (x v) (ldt-combine (ld-with-field (ldt-date x) 'year (jt->exact v)) (ldt-time x)))) + (cons "withMonth" (lambda (x v) (ldt-combine (ld-with-field (ldt-date x) 'month (jt->exact v)) (ldt-time x)))) + (cons "withDayOfMonth" (lambda (x v) (ldt-combine (ld-with-field (ldt-date x) 'day (jt->exact v)) (ldt-time x)))) + (cons "withDayOfYear" (lambda (x v) (ldt-combine (ld-with-field (ldt-date x) 'day-of-year (jt->exact v)) (ldt-time x)))) + (cons "withHour" (lambda (x v) (ldt-combine (ldt-date x) (lt-with (ldt-time x) 'hour (jt->exact v))))) + (cons "withMinute" (lambda (x v) (ldt-combine (ldt-date x) (lt-with (ldt-time x) 'minute (jt->exact v))))) + (cons "withSecond" (lambda (x v) (ldt-combine (ldt-date x) (lt-with (ldt-time x) 'second (jt->exact v))))) + (cons "withNano" (lambda (x v) (ldt-combine (ldt-date x) (lt-with (ldt-time x) 'nano (jt->exact v))))) + (cons "truncatedTo" (lambda (x u) (ldt-combine (ldt-date x) (lt-truncate (ldt-time x) u)))) + (cons "isBefore" (lambda (x o) (ldtms x)))) + (cons "atOffset" (lambda (x off) (mk-zoned (ldt->ms x)))) + (cons "toInstant" (lambda (x . _) (mk-instant (ldt->ms x)))) + (cons "toString" (lambda (x) (iso-datetime-str (ldt-epoch-day x) (ldt-nano-of-day x)))))) + +(define (ldt-cmp x o) + (cond ((< (ldt-epoch-day x) (ldt-epoch-day o)) -1) + ((> (ldt-epoch-day x) (ldt-epoch-day o)) 1) + ((< (ldt-nano-of-day x) (ldt-nano-of-day o)) -1) + ((> (ldt-nano-of-day x) (ldt-nano-of-day o)) 1) + (else 0))) +(define (ldtexact s) 1000))) + ((s nano) (mk-instant (+ (* (jt->exact s) 1000) (quotient (jt->exact nano) 1000000)))))) + (cons "EPOCH" (mk-instant 0)) + ;; java.time Instant MIN/MAX are -1e9..1e9 yrs; the ms model can't hold those + ;; exactly, so use the broadest range the ms layer represents safely. + (cons "MIN" (mk-instant (* (ymd->epoch-day -999999999 1 1) 86400000))) + (cons "MAX" (mk-instant (+ (* (ymd->epoch-day 999999999 12 31) 86400000) 86399999))))) + +(register-host-methods! "instant" + (list (cons "getEpochSecond" (lambda (x) (jt-floor-div (exact (truncate (inst-ms x))) 1000))) + (cons "getNano" (lambda (x) (* (jt-floor-mod (exact (truncate (inst-ms x))) 1000) 1000000))) + (cons "plusMillis" (lambda (x n) (mk-instant (+ (inst-ms x) (jt->exact n))))) + (cons "minusMillis" (lambda (x n) (mk-instant (- (inst-ms x) (jt->exact n))))) + (cons "plusSeconds" (lambda (x n) (mk-instant (+ (inst-ms x) (* (jt->exact n) 1000))))) + (cons "minusSeconds" (lambda (x n) (mk-instant (- (inst-ms x) (* (jt->exact n) 1000))))) + (cons "plusNanos" (lambda (x n) (mk-instant (+ (inst-ms x) (quotient (jt->exact n) 1000000))))) + (cons "minusNanos" (lambda (x n) (mk-instant (- (inst-ms x) (quotient (jt->exact n) 1000000))))) + (cons "isBefore" (lambda (x o) (< (inst-ms x) (inst-ms o)))) + (cons "isAfter" (lambda (x o) (> (inst-ms x) (inst-ms o)))) + (cons "compareTo" (lambda (x o) (let ((a (inst-ms x)) (b (inst-ms o))) + (cond ((< a b) -1) ((> a b) 1) (else 0))))) + (cons "equals" (lambda (x o) (and (jhost? o) (string=? (jhost-tag o) "instant") (= (inst-ms x) (inst-ms o))))) + (cons "hashCode" (lambda (x) (jt->exact (inst-ms x)))) + (cons "truncatedTo" (lambda (x u) (let ((unit (chrono-unit-name u))) + (mk-instant (* (quotient (exact (truncate (inst-ms x))) + (cond ((and unit (string-ci=? unit "DAYS")) 86400000) + ((and unit (string-ci=? unit "HOURS")) 3600000) + ((and unit (string-ci=? unit "MINUTES")) 60000) + ((and unit (string-ci=? unit "SECONDS")) 1000) + (else 1))) + (cond ((and unit (string-ci=? unit "DAYS")) 86400000) + ((and unit (string-ci=? unit "HOURS")) 3600000) + ((and unit (string-ci=? unit "MINUTES")) 60000) + ((and unit (string-ci=? unit "SECONDS")) 1000) + (else 1))))))) + (cons "atOffset" (lambda (x off) (mk-zoned (inst-ms x)))) + (cons "toString" (lambda (x) (iso-instant-str (inst-ms x)))))) + +;; --- Month / DayOfWeek enums (returned by getMonth / getDayOfWeek) ----------- +;; minimal: name / getValue / toString, plus the static value fields cljc.java-time +;; might def at load (java.time.Month/JANUARY etc. — not needed by the four core nses +;; but harmless to provide). +(register-host-methods! "month-enum" + (list (cons "getValue" (lambda (e) (vector-ref (jhost-state e) 0))) + (cons "name" (lambda (e) (vector-ref jt-month-names (- (vector-ref (jhost-state e) 0) 1)))) + (cons "toString" (lambda (e) (vector-ref jt-month-names (- (vector-ref (jhost-state e) 0) 1)))))) +(register-host-methods! "dow-enum" + (list (cons "getValue" (lambda (e) (vector-ref (jhost-state e) 0))) + (cons "name" (lambda (e) (vector-ref jt-day-names (- (vector-ref (jhost-state e) 0) 1)))) + (cons "toString" (lambda (e) (vector-ref jt-day-names (- (vector-ref (jhost-state e) 0) 1)))))) + +;; --- equality / hash / compare / print / instance? -------------------------- +(define (jt-date? x) (and (jhost? x) (string=? (jhost-tag x) "local-date"))) +(define (jt-time? x) (and (jhost? x) (string=? (jhost-tag x) "local-time"))) +(define (jt-dt? x) (and (jhost? x) (string=? (jhost-tag x) "local-date-time"))) + +(register-eq-arm! (lambda (a b) (or (jt-date? a) (jt-date? b))) + (lambda (a b) (and (jt-date? a) (jt-date? b) (= (ld-epoch-day a) (ld-epoch-day b))))) +(register-hash-arm! jt-date? (lambda (x) (jolt-hash (ld-epoch-day x)))) +(register-eq-arm! (lambda (a b) (or (jt-time? a) (jt-time? b))) + (lambda (a b) (and (jt-time? a) (jt-time? b) (= (lt-nano-of-day a) (lt-nano-of-day b))))) +(register-hash-arm! jt-time? (lambda (x) (jolt-hash (lt-nano-of-day x)))) +(register-eq-arm! (lambda (a b) (or (jt-dt? a) (jt-dt? b))) + (lambda (a b) (and (jt-dt? a) (jt-dt? b) (ldt=? a b)))) +(register-hash-arm! jt-dt? (lambda (x) (jolt-hash (+ (* (ldt-epoch-day x) 31) (ldt-nano-of-day x))))) + +(register-str-render! jt-date? (lambda (x) (iso-date-str (ld-epoch-day x)))) +(register-pr-arm! jt-date? (lambda (x) (iso-date-str (ld-epoch-day x)))) +(register-str-render! jt-time? (lambda (x) (iso-time-str (lt-nano-of-day x)))) +(register-pr-arm! jt-time? (lambda (x) (iso-time-str (lt-nano-of-day x)))) +(register-str-render! jt-dt? (lambda (x) (iso-datetime-str (ldt-epoch-day x) (ldt-nano-of-day x)))) +(register-pr-arm! jt-dt? (lambda (x) (iso-datetime-str (ldt-epoch-day x) (ldt-nano-of-day x)))) + +;; the "instant" jhost prints as a java.time ISO instant (…Z), not the bare record. +(define (jt-instant? x) (and (jhost? x) (string=? (jhost-tag x) "instant"))) +(register-str-render! jt-instant? (lambda (x) (iso-instant-str (inst-ms x)))) +(register-pr-arm! jt-instant? (lambda (x) (iso-instant-str (inst-ms x)))) + +;; compare: same-type java.time values compare on their canonical state. +(define %jt-prev-compare jolt-compare) +(set! jolt-compare + (lambda (a b) + (cond + ((and (jt-date? a) (jt-date? b)) (cond ((< (ld-epoch-day a) (ld-epoch-day b)) -1) ((> (ld-epoch-day a) (ld-epoch-day b)) 1) (else 0))) + ((and (jt-time? a) (jt-time? b)) (cond ((< (lt-nano-of-day a) (lt-nano-of-day b)) -1) ((> (lt-nano-of-day a) (lt-nano-of-day b)) 1) (else 0))) + ((and (jt-dt? a) (jt-dt? b)) (ldt-cmp a b)) + ((and (jt-instant? a) (jt-instant? b)) (cond ((< (inst-ms a) (inst-ms b)) -1) ((> (inst-ms a) (inst-ms b)) 1) (else 0))) + (else (%jt-prev-compare a b))))) +(def-var! "clojure.core" "compare" jolt-compare) + +;; instance? for the three new tags (inst-time.ss already answers "instant"). +(register-instance-check-arm! + (lambda (type-sym val) + (let ((tn (short-class-name (symbol-t-name type-sym)))) + (cond + ((jt-date? val) (if (string=? tn "LocalDate") #t 'pass)) + ((jt-time? val) (if (string=? tn "LocalTime") #t 'pass)) + ((jt-dt? val) (if (string=? tn "LocalDateTime") #t 'pass)) + (else 'pass))))) diff --git a/host/chez/records.ss b/host/chez/records.ss index 0e86e60..a1cb351 100644 --- a/host/chez/records.ss +++ b/host/chez/records.ss @@ -141,6 +141,9 @@ ((jinst? obj) '("Date" "java.util.Date" "Timestamp" "java.sql.Timestamp" "Object")) ((jbigdec? obj) '("BigDecimal" "java.math.BigDecimal" "Number" "Object")) ((and (jhost? obj) (string=? (jhost-tag obj) "instant")) '("Instant" "java.time.Instant" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "local-date")) '("LocalDate" "java.time.LocalDate" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "local-time")) '("LocalTime" "java.time.LocalTime" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "local-date-time")) '("LocalDateTime" "java.time.LocalDateTime" "Object")) ;; java.sql.Date — a distinct class from java.util.Date so a protocol ;; extended to both (data.json's JSONWriter) routes a sql.Date to its impl. ((and (jhost? obj) (string=? (jhost-tag obj) "sql-date")) '("java.sql.Date" "Date" "java.util.Date" "Object")) diff --git a/host/chez/rt.ss b/host/chez/rt.ss index 8d93e69..9f1875c 100644 --- a/host/chez/rt.ss +++ b/host/chez/rt.ss @@ -351,6 +351,12 @@ ;; jolt-pr-str / jolt-type / instance-check and uses host-static.ss's registries. (load "host/chez/inst-time.ss") +;; java.time value types: LocalDate / LocalTime / LocalDateTime / Instant as +;; tz-free jhost values (epoch-day / nano-of-day / epoch-ms). Loads after +;; inst-time.ss — it reuses its civil<->days helpers, the jhost registries, and +;; re-registers a few LocalDateTime/Instant statics to use the richer reps. +(load "host/chez/java-time.ss") + ;; Chez-side data reader: read-string / __parse-next / ;; __read-tagged. Loads after inst-time.ss — __read-tagged reuses its #uuid/#inst ;; constructors, and the reader needs the full value/collection layer above. diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index 12401f4..fe15c27 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -2999,4 +2999,16 @@ {:suite "interop / numbers & classes" :label "instance? PushbackReader" :expected "true" :actual "(instance? java.io.PushbackReader (java.io.PushbackReader. (java.io.StringReader. \"x\")))"} {:suite "interop / numbers & classes" :label "EOFException catch by class" :expected "\"boom\"" :actual "(try (throw (java.io.EOFException. \"boom\")) (catch java.io.EOFException e (.getMessage e)))"} {:suite "interop / numbers & classes" :label "Reader.read into char[]" :expected "[4 \"abcd\"]" :actual "(let [r (java.io.StringReader. \"abcd\") b (char-array 4)] (let [n (.read r b 0 4)] [n (String. b 0 n)]))"} + {:suite "interop / java.time" :label "LocalDate toString" :expected "\"2020-01-15\"" :actual "(str (java.time.LocalDate/of 2020 1 15))"} + {:suite "interop / java.time" :label "LocalDate plusDays over leap day" :expected "\"2020-02-29\"" :actual "(str (.plusDays (java.time.LocalDate/of 2020 2 28) 1))"} + {:suite "interop / java.time" :label "LocalDate equality" :expected "true" :actual "(= (java.time.LocalDate/of 2020 1 15) (java.time.LocalDate/of 2020 1 15))"} + {:suite "interop / java.time" :label "LocalDate compare" :expected "-1" :actual "(compare (java.time.LocalDate/of 2020 1 15) (java.time.LocalDate/of 2020 1 16))"} + {:suite "interop / java.time" :label "LocalDate ofEpochDay round-trip" :expected "1" :actual "(.toEpochDay (java.time.LocalDate/of 1970 1 2))"} + {:suite "interop / java.time" :label "LocalDate parse" :expected "\"2020-01-15\"" :actual "(str (java.time.LocalDate/parse \"2020-01-15\"))"} + {:suite "interop / java.time" :label "LocalDate getDayOfWeek name" :expected "\"WEDNESDAY\"" :actual "(.name (.getDayOfWeek (java.time.LocalDate/of 2020 1 15)))"} + {:suite "interop / java.time" :label "LocalTime toString" :expected "\"10:30:15\"" :actual "(str (java.time.LocalTime/of 10 30 15))"} + {:suite "interop / java.time" :label "LocalTime plusHours wraps midnight" :expected "\"01:30\"" :actual "(str (.plusHours (java.time.LocalTime/of 23 30) 2))"} + {:suite "interop / java.time" :label "LocalDateTime toString" :expected "\"2020-01-15T10:30\"" :actual "(str (java.time.LocalDateTime/of 2020 1 15 10 30 0))"} + {:suite "interop / java.time" :label "Instant ofEpochMilli toString" :expected "\"2020-01-15T10:30:00Z\"" :actual "(str (java.time.Instant/ofEpochMilli 1579084200000))"} + {:suite "interop / java.time" :label "Instant ofEpochMilli round-trip" :expected "1579084200000" :actual "(.toEpochMilli (java.time.Instant/ofEpochMilli 1579084200000))"} ] From e3c14e656c9ab4b612c61978eade49bb64be5bff Mon Sep 17 00:00:00 2001 From: Yogthos Date: Wed, 24 Jun 2026 18:10:40 -0400 Subject: [PATCH 2/3] java.time Phase 2: Duration/Period, enums, ChronoUnit/Field machinery MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Duration (ISO PT.. toString, between, full arithmetic), Period (between with borrow, P.. toString, normalized), full Month/DayOfWeek enums (named constants, print as their name — fixes the Phase-1 raw-jhost print), Year, YearMonth (2020-02 toString, leap, atDay/atEndOfMonth), ChronoUnit (between/getDuration) and ChronoField. The temporal machinery on the Phase-1 types now works with ChronoUnit/ChronoField: (.plus t n DAYS), (.until t1 t2 unit), (.get/.getLong t field), (.with t field v), (.isSupported ..), (.truncatedTo ..). Analyzer: (. Class method args) with a class target lowers to a static call (Class/method args) instead of mis-dispatching as an instance call on the arg — matches JVM; needed by cljc.java-time.year. Seed re-minted; selfhost holds. The Phase-2 cljc.java-time namespaces load; tick.core advances to a Phase-3 zone gap. 10 corpus rows certified vs JVM. make test + shakesmoke green, 0 new divergences, data.json stays 138/139. --- host/chez/java-time.ss | 743 +++++++++++++++++++++++++++++++++++- host/chez/records.ss | 8 + host/chez/seed/image.ss | 12 +- jolt-core/jolt/analyzer.clj | 15 +- test/chez/corpus.edn | 12 + 5 files changed, 773 insertions(+), 17 deletions(-) diff --git a/host/chez/java-time.ss b/host/chez/java-time.ss index 7e6837e..b5ae1b1 100644 --- a/host/chez/java-time.ss +++ b/host/chez/java-time.ss @@ -453,17 +453,707 @@ (cons "toString" (lambda (x) (iso-instant-str (inst-ms x)))))) ;; --- Month / DayOfWeek enums (returned by getMonth / getDayOfWeek) ----------- -;; minimal: name / getValue / toString, plus the static value fields cljc.java-time -;; might def at load (java.time.Month/JANUARY etc. — not needed by the four core nses -;; but harmless to provide). +(define (jt-month n) (make-jhost "month-enum" (vector n))) +(define (jt-dow n) (make-jhost "dow-enum" (vector n))) +(define (month-val e) (vector-ref (jhost-state e) 0)) +(define (dow-val e) (vector-ref (jhost-state e) 0)) +(define (month-name n) (vector-ref jt-month-names (- n 1))) +(define (dow-name n) (vector-ref jt-day-names (- n 1))) +;; quarter starts: Jan/Apr/Jul/Oct. +(define (month-quarter-start m) (+ 1 (* 3 (quotient (- m 1) 3)))) +;; day-of-year of the first day of month m (non-leap base; +1 from March on a leap year). +(define (month-first-day-of-year m leap) + (let ((cum (vector 0 0 31 59 90 120 151 181 212 243 273 304 334))) + (+ 1 (vector-ref cum m) (if (and leap (> m 2)) 1 0)))) + (register-host-methods! "month-enum" - (list (cons "getValue" (lambda (e) (vector-ref (jhost-state e) 0))) - (cons "name" (lambda (e) (vector-ref jt-month-names (- (vector-ref (jhost-state e) 0) 1)))) - (cons "toString" (lambda (e) (vector-ref jt-month-names (- (vector-ref (jhost-state e) 0) 1)))))) + (list (cons "getValue" (lambda (e) (month-val e))) + (cons "ordinal" (lambda (e) (- (month-val e) 1))) + (cons "name" (lambda (e) (month-name (month-val e)))) + (cons "toString" (lambda (e) (month-name (month-val e)))) + (cons "getDisplayName" (lambda (e . _) (month-name (month-val e)))) + (cons "plus" (lambda (e n) (jt-month (+ 1 (jt-floor-mod (+ (- (month-val e) 1) (jt->exact n)) 12))))) + (cons "minus" (lambda (e n) (jt-month (+ 1 (jt-floor-mod (- (- (month-val e) 1) (jt->exact n)) 12))))) + (cons "length" (lambda (e leap) (jt-len-of-month (if (jolt-truthy? leap) 4 1) (month-val e)))) + (cons "minLength" (lambda (e) (if (= (month-val e) 2) 28 (jt-len-of-month 1 (month-val e))))) + (cons "maxLength" (lambda (e) (if (= (month-val e) 2) 29 (jt-len-of-month 1 (month-val e))))) + (cons "firstMonthOfQuarter" (lambda (e) (jt-month (month-quarter-start (month-val e))))) + (cons "firstDayOfYear" (lambda (e leap) (month-first-day-of-year (month-val e) (jolt-truthy? leap)))) + (cons "compareTo" (lambda (e o) (- (month-val e) (month-val o)))) + (cons "equals" (lambda (e o) (and (jhost? o) (string=? (jhost-tag o) "month-enum") (= (month-val e) (month-val o))))) + (cons "hashCode" (lambda (e) (month-val e))))) (register-host-methods! "dow-enum" - (list (cons "getValue" (lambda (e) (vector-ref (jhost-state e) 0))) - (cons "name" (lambda (e) (vector-ref jt-day-names (- (vector-ref (jhost-state e) 0) 1)))) - (cons "toString" (lambda (e) (vector-ref jt-day-names (- (vector-ref (jhost-state e) 0) 1)))))) + (list (cons "getValue" (lambda (e) (dow-val e))) + (cons "ordinal" (lambda (e) (- (dow-val e) 1))) + (cons "name" (lambda (e) (dow-name (dow-val e)))) + (cons "toString" (lambda (e) (dow-name (dow-val e)))) + (cons "getDisplayName" (lambda (e . _) (dow-name (dow-val e)))) + (cons "plus" (lambda (e n) (jt-dow (+ 1 (jt-floor-mod (+ (- (dow-val e) 1) (jt->exact n)) 7))))) + (cons "minus" (lambda (e n) (jt-dow (+ 1 (jt-floor-mod (- (- (dow-val e) 1) (jt->exact n)) 7))))) + (cons "compareTo" (lambda (e o) (- (dow-val e) (dow-val o)))) + (cons "equals" (lambda (e o) (and (jhost? o) (string=? (jhost-tag o) "dow-enum") (= (dow-val e) (dow-val o))))) + (cons "hashCode" (lambda (e) (dow-val e))))) + +(define (month-from-temporal t) + (cond ((and (jhost? t) (string=? (jhost-tag t) "month-enum")) t) + ((jt-date? t) (jt-month (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) (lambda (y m d) m)))) + ((jt-dt? t) (jt-month (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day t))) (lambda (y m d) m)))) + (else (error #f "Month/from: unsupported")))) +(register-class-statics! "Month" + (append + (list (cons "of" (lambda (n) (jt-month (jt->exact n)))) + (cons "valueOf" (lambda (s) (let ((nm (jt-str s))) + (let loop ((i 0)) (cond ((= i 12) (error #f (string-append "No enum constant Month." nm))) + ((string=? (vector-ref jt-month-names i) nm) (jt-month (+ i 1))) + (else (loop (+ i 1)))))))) + (cons "from" (lambda (t) (month-from-temporal t))) + (cons "values" (lambda () (make-pvec (list->vector (map jt-month '(1 2 3 4 5 6 7 8 9 10 11 12))))))) + (map (lambda (i) (cons (vector-ref jt-month-names (- i 1)) (jt-month i))) '(1 2 3 4 5 6 7 8 9 10 11 12)))) +(define (dow-from-temporal t) + (cond ((and (jhost? t) (string=? (jhost-tag t) "dow-enum")) t) + ((jt-date? t) (jt-dow (ld-dow (ld-epoch-day t)))) + ((jt-dt? t) (jt-dow (ld-dow (ldt-epoch-day t)))) + (else (error #f "DayOfWeek/from: unsupported")))) +(register-class-statics! "DayOfWeek" + (append + (list (cons "of" (lambda (n) (jt-dow (jt->exact n)))) + (cons "valueOf" (lambda (s) (let ((nm (jt-str s))) + (let loop ((i 0)) (cond ((= i 7) (error #f (string-append "No enum constant DayOfWeek." nm))) + ((string=? (vector-ref jt-day-names i) nm) (jt-dow (+ i 1))) + (else (loop (+ i 1)))))))) + (cons "from" (lambda (t) (dow-from-temporal t))) + (cons "values" (lambda () (make-pvec (list->vector (map jt-dow '(1 2 3 4 5 6 7))))))) + (map (lambda (i) (cons (vector-ref jt-day-names (- i 1)) (jt-dow i))) '(1 2 3 4 5 6 7)))) + +;; --- Duration: (vector seconds nanos), nanos in [0, 1e9) ---------------------- +(define (dur-normalize secs nanos) + (let* ((carry (jt-floor-div nanos nanos-per-sec)) + (n (jt-floor-mod nanos nanos-per-sec))) + (make-jhost "duration" (vector (+ secs carry) n)))) +(define (dur-secs d) (vector-ref (jhost-state d) 0)) +(define (dur-nanos d) (vector-ref (jhost-state d) 1)) +(define (dur-total-nanos d) (+ (* (dur-secs d) nanos-per-sec) (dur-nanos d))) +(define (dur-of-total-nanos tn) (dur-normalize (jt-floor-div tn nanos-per-sec) (jt-floor-mod tn nanos-per-sec))) +(define dur-zero (make-jhost "duration" (vector 0 0))) + +;; ISO-8601: PTnHnMnS. Components come from the normalized (secs,nanos>=0) state; +;; each H/M/S field carries its own sign (java.time prints them per-component). The +;; seconds field folds in the fractional nanos: a negative second with nanos shows +;; e.g. "-0.5" (rem-sec -1 + nanos 5e8 -> -0.5). +(define (dur->string d) + (let ((secs (dur-secs d)) (nanos (dur-nanos d))) + (if (and (= secs 0) (= nanos 0)) "PT0S" + (let* ((hours (quotient secs 3600)) + (mins (quotient (remainder secs 3600) 60)) + (rem-secs (remainder secs 60)) + (out (open-output-string))) + (display "PT" out) + (unless (= hours 0) (display (number->string hours) out) (write-char #\H out)) + (unless (= mins 0) (display (number->string mins) out) (write-char #\M out)) + (when (or (not (= rem-secs 0)) (not (= nanos 0)) (and (= hours 0) (= mins 0))) + (if (= nanos 0) + (display (number->string rem-secs) out) + ;; whole second + fraction; a negative rem-sec with positive nanos + ;; rolls toward zero (rem+1) and shows fraction as 1e9-nanos. + (let* ((neg (< rem-secs 0)) + (whole (if neg (+ rem-secs 1) rem-secs)) + (frac (if neg (- nanos-per-sec nanos) nanos))) + (when (and neg (= whole 0)) (write-char #\- out)) + (display (number->string whole) out) + (write-char #\. out) + (display (dur-frac-digits frac) out))) + (write-char #\S out)) + (get-output-string out))))) +;; nanos -> a 9-digit fraction with all trailing zeros stripped (Duration shows the +;; minimal fraction, e.g. .5, unlike LocalTime which pads to 3/6/9). +(define (dur-frac-digits nano) + (let ((s9 (let ((s (number->string nano))) (string-append (make-string (max 0 (- 9 (string-length s))) #\0) s)))) + (let loop ((i 9)) (cond ((<= i 1) (substring s9 0 1)) + ((char=? (string-ref s9 (- i 1)) #\0) (loop (- i 1))) + (else (substring s9 0 i)))))) + +(define (dur-temporal-nanos t) ; instant/ldt/lt -> a nanos-since-epoch-ish count + (cond ((jt-instant? t) (* (inst-ms t) 1000000)) + ((jt-dt? t) (+ (* (ldt-epoch-day t) nanos-per-day) (ldt-nano-of-day t))) + ((jt-time? t) (lt-nano-of-day t)) + ((jt-date? t) (* (ld-epoch-day t) nanos-per-day)) + (else (error #f "Duration/between: unsupported temporal")))) +(register-class-statics! "Duration" + (list (cons "ZERO" dur-zero) + (cons "of" (lambda (n unit) (dur-of-total-nanos (* (jt->exact n) (chrono-unit-nanos unit))))) + (cons "ofDays" (lambda (n) (dur-normalize (* (jt->exact n) 86400) 0))) + (cons "ofHours" (lambda (n) (dur-normalize (* (jt->exact n) 3600) 0))) + (cons "ofMinutes" (lambda (n) (dur-normalize (* (jt->exact n) 60) 0))) + (cons "ofSeconds" (case-lambda + ((s) (dur-normalize (jt->exact s) 0)) + ((s na) (dur-normalize (jt->exact s) (jt->exact na))))) + (cons "ofMillis" (lambda (n) (dur-of-total-nanos (* (jt->exact n) 1000000)))) + (cons "ofNanos" (lambda (n) (dur-of-total-nanos (jt->exact n)))) + (cons "between" (lambda (a b) (dur-of-total-nanos (- (dur-temporal-nanos b) (dur-temporal-nanos a))))) + (cons "from" (lambda (t) (if (and (jhost? t) (string=? (jhost-tag t) "duration")) t (error #f "Duration/from")))) + (cons "parse" (lambda (s) (parse-iso-duration (jt-str s)))))) + +(define (dur-plus a b) (dur-of-total-nanos (+ (dur-total-nanos a) (dur-total-nanos b)))) +(register-host-methods! "duration" + (list (cons "getSeconds" (lambda (d) (dur-secs d))) + (cons "getNano" (lambda (d) (dur-nanos d))) + (cons "toDays" (lambda (d) (quotient (dur-secs d) 86400))) + (cons "toHours" (lambda (d) (quotient (dur-secs d) 3600))) + (cons "toMinutes" (lambda (d) (quotient (dur-secs d) 60))) + (cons "toMillis" (lambda (d) (+ (* (dur-secs d) 1000) (quotient (dur-nanos d) 1000000)))) + (cons "toNanos" (lambda (d) (dur-total-nanos d))) + (cons "plus" (lambda (d o) (cond ((and (jhost? o) (string=? (jhost-tag o) "duration")) (dur-plus d o)) + (else (error #f "Duration.plus: expected Duration"))))) + (cons "minus" (lambda (d o) (dur-of-total-nanos (- (dur-total-nanos d) (dur-total-nanos o))))) + (cons "plusDays" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) 86400 nanos-per-sec))))) + (cons "plusHours" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) 3600 nanos-per-sec))))) + (cons "plusMinutes" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) 60 nanos-per-sec))))) + (cons "plusSeconds" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) nanos-per-sec))))) + (cons "plusMillis" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) 1000000))))) + (cons "plusNanos" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (jt->exact n))))) + (cons "minusDays" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) 86400 nanos-per-sec))))) + (cons "minusHours" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) 3600 nanos-per-sec))))) + (cons "minusMinutes" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) 60 nanos-per-sec))))) + (cons "minusSeconds" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) nanos-per-sec))))) + (cons "minusMillis" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) 1000000))))) + (cons "minusNanos" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (jt->exact n))))) + (cons "multipliedBy" (lambda (d n) (dur-of-total-nanos (* (dur-total-nanos d) (jt->exact n))))) + (cons "dividedBy" (lambda (d n) (dur-of-total-nanos (quotient (dur-total-nanos d) (jt->exact n))))) + (cons "negated" (lambda (d) (dur-of-total-nanos (- (dur-total-nanos d))))) + (cons "abs" (lambda (d) (dur-of-total-nanos (abs (dur-total-nanos d))))) + (cons "withSeconds" (lambda (d s) (dur-normalize (jt->exact s) (dur-nanos d)))) + (cons "withNanos" (lambda (d na) (dur-normalize (dur-secs d) (jt->exact na)))) + (cons "isZero" (lambda (d) (and (= (dur-secs d) 0) (= (dur-nanos d) 0)))) + (cons "isNegative" (lambda (d) (< (dur-total-nanos d) 0))) + (cons "compareTo" (lambda (d o) (let ((a (dur-total-nanos d)) (b (dur-total-nanos o))) + (cond ((< a b) -1) ((> a b) 1) (else 0))))) + (cons "equals" (lambda (d o) (and (jhost? o) (string=? (jhost-tag o) "duration") (= (dur-total-nanos d) (dur-total-nanos o))))) + (cons "hashCode" (lambda (d) (jolt-hash (dur-total-nanos d)))) + ;; TemporalAmount: addTo/subtractFrom apply this duration to a temporal. + (cons "addTo" (lambda (d t) (temporal-plus-nanos t (dur-total-nanos d)))) + (cons "subtractFrom" (lambda (d t) (temporal-plus-nanos t (- (dur-total-nanos d))))) + (cons "toString" (lambda (d) (dur->string d))))) + +;; "PT…" parse: PnDTnHnMn.nS (we accept the time part; days fold into hours). +(define (parse-iso-duration s) + (let ((len (string-length s)) (neg #f) (i 0) (total 0)) + (define (sign-at j) (cond ((>= j len) (values 1 j)) + ((char=? (string-ref s j) #\-) (values -1 (+ j 1))) + ((char=? (string-ref s j) #\+) (values 1 (+ j 1))) + (else (values 1 j)))) + (when (and (< i len) (char=? (string-ref s i) #\-)) (set! neg #t) (set! i (+ i 1))) + (unless (and (< i len) (or (char=? (string-ref s i) #\P) (char=? (string-ref s i) #\p))) + (error #f (string-append "could not parse Duration: " s))) + (set! i (+ i 1)) + (let loop ((in-time #f)) + (when (< i len) + (let ((c (string-ref s i))) + (cond + ((or (char=? c #\T) (char=? c #\t)) (set! i (+ i 1)) (loop #t)) + (else + (call-with-values (lambda () (sign-at i)) + (lambda (sg j) + ;; read number (with optional fraction) + (let num ((k j) (acc 0) (frac 0) (fdigits 0) (in-frac #f) (any #f)) + (cond + ((and (< k len) (digit? (string-ref s k))) + (if in-frac + (num (+ k 1) acc (+ (* frac 10) (- (char->integer (string-ref s k)) 48)) (+ fdigits 1) #t #t) + (num (+ k 1) (+ (* acc 10) (- (char->integer (string-ref s k)) 48)) frac fdigits #f #t))) + ((and (< k len) (char=? (string-ref s k) #\.)) (num (+ k 1) acc frac fdigits #t any)) + ((and any (< k len)) + (let* ((unit (char-upcase (string-ref s k))) + (nanos (* (+ (* acc nanos-per-sec) (* frac (expt 10 (max 0 (- 9 fdigits))))) sg)) + (mult (cond ((char=? unit #\D) 86400) ((char=? unit #\H) 3600) + ((char=? unit #\M) (if in-time 60 (error #f "Duration months unsupported"))) + ((char=? unit #\S) 1) + (else (error #f (string-append "bad Duration unit: " s)))))) + (set! total (+ total (* nanos mult))) + (set! i (+ k 1)) + (loop in-time))) + (else (error #f (string-append "could not parse Duration: " s)))))))))))) + (dur-of-total-nanos (if neg (- total) total)))) + +;; --- Period: (vector years months days) -------------------------------------- +(define (jt-period y m d) (make-jhost "period" (vector y m d))) +(define (per-years p) (vector-ref (jhost-state p) 0)) +(define (per-months p) (vector-ref (jhost-state p) 1)) +(define (per-days p) (vector-ref (jhost-state p) 2)) +(define per-zero (jt-period 0 0 0)) +(define (per->string p) + (let ((y (per-years p)) (m (per-months p)) (d (per-days p))) + (if (and (= y 0) (= m 0) (= d 0)) "P0D" + (let ((out (open-output-string))) + (write-char #\P out) + (unless (= y 0) (display (number->string y) out) (write-char #\Y out)) + (unless (= m 0) (display (number->string m) out) (write-char #\M out)) + (unless (= d 0) (display (number->string d) out) (write-char #\D out)) + (get-output-string out))))) +;; Period/between counts whole years/months/days from a to b (java.time semantics). +(define (per-between a b) + (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day a))) + (lambda (y1 m1 d1) + (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day b))) + (lambda (y2 m2 d2) + (let* ((total-months (- (+ (* y2 12) m2) (+ (* y1 12) m1))) + (days (- d2 d1))) + ;; if days go negative, borrow a month (using the prior month length of b) + (let-values (((tm dd) + (if (and (> total-months 0) (< days 0)) + (let* ((tm (- total-months 1)) + (bm (+ (* y1 12) (- m1 1) tm)) + (by (jt-floor-div bm 12)) (bmo (+ 1 (jt-floor-mod bm 12))) + (len (jt-len-of-month by bmo))) + (values tm (+ days len))) + (if (and (< total-months 0) (> days 0)) + (values (+ total-months 1) (- days (jt-len-of-month y2 m2))) + (values total-months days))))) + (jt-period (jt-floor-div tm 12) (jt-floor-mod tm 12) dd)))))))) +(define (per-normalize p) + (let ((tm (+ (* (per-years p) 12) (per-months p)))) + (jt-period (jt-floor-div tm 12) (jt-floor-mod tm 12) (per-days p)))) +(register-class-statics! "Period" + (list (cons "ZERO" per-zero) + (cons "of" (lambda (y m d) (jt-period (jt->exact y) (jt->exact m) (jt->exact d)))) + (cons "ofYears" (lambda (y) (jt-period (jt->exact y) 0 0))) + (cons "ofMonths" (lambda (m) (jt-period 0 (jt->exact m) 0))) + (cons "ofWeeks" (lambda (w) (jt-period 0 0 (* 7 (jt->exact w))))) + (cons "ofDays" (lambda (d) (jt-period 0 0 (jt->exact d)))) + (cons "between" (lambda (a b) (per-between a b))) + (cons "from" (lambda (t) (if (and (jhost? t) (string=? (jhost-tag t) "period")) t (error #f "Period/from")))) + (cons "parse" (lambda (s) (parse-iso-period (jt-str s)))))) +(register-host-methods! "period" + (list (cons "getYears" (lambda (p) (per-years p))) + (cons "getMonths" (lambda (p) (per-months p))) + (cons "getDays" (lambda (p) (per-days p))) + (cons "toTotalMonths" (lambda (p) (+ (* (per-years p) 12) (per-months p)))) + (cons "plusYears" (lambda (p n) (jt-period (+ (per-years p) (jt->exact n)) (per-months p) (per-days p)))) + (cons "plusMonths" (lambda (p n) (jt-period (per-years p) (+ (per-months p) (jt->exact n)) (per-days p)))) + (cons "plusDays" (lambda (p n) (jt-period (per-years p) (per-months p) (+ (per-days p) (jt->exact n))))) + (cons "minusYears" (lambda (p n) (jt-period (- (per-years p) (jt->exact n)) (per-months p) (per-days p)))) + (cons "minusMonths" (lambda (p n) (jt-period (per-years p) (- (per-months p) (jt->exact n)) (per-days p)))) + (cons "minusDays" (lambda (p n) (jt-period (per-years p) (per-months p) (- (per-days p) (jt->exact n))))) + (cons "withYears" (lambda (p n) (jt-period (jt->exact n) (per-months p) (per-days p)))) + (cons "withMonths" (lambda (p n) (jt-period (per-years p) (jt->exact n) (per-days p)))) + (cons "withDays" (lambda (p n) (jt-period (per-years p) (per-months p) (jt->exact n)))) + (cons "plus" (lambda (p o) (jt-period (+ (per-years p) (per-years o)) (+ (per-months p) (per-months o)) (+ (per-days p) (per-days o))))) + (cons "minus" (lambda (p o) (jt-period (- (per-years p) (per-years o)) (- (per-months p) (per-months o)) (- (per-days p) (per-days o))))) + (cons "multipliedBy" (lambda (p n) (jt-period (* (per-years p) (jt->exact n)) (* (per-months p) (jt->exact n)) (* (per-days p) (jt->exact n))))) + (cons "negated" (lambda (p) (jt-period (- (per-years p)) (- (per-months p)) (- (per-days p))))) + (cons "normalized" (lambda (p) (per-normalize p))) + (cons "isZero" (lambda (p) (and (= (per-years p) 0) (= (per-months p) 0) (= (per-days p) 0)))) + (cons "isNegative" (lambda (p) (or (< (per-years p) 0) (< (per-months p) 0) (< (per-days p) 0)))) + (cons "equals" (lambda (p o) (and (jhost? o) (string=? (jhost-tag o) "period") + (= (per-years p) (per-years o)) (= (per-months p) (per-months o)) (= (per-days p) (per-days o))))) + (cons "hashCode" (lambda (p) (+ (per-years p) (bitwise-arithmetic-shift-left (per-months p) 8) (bitwise-arithmetic-shift-left (per-days p) 16)))) + ;; TemporalAmount: a Period adds its y/m/d to a date-bearing temporal. + (cons "addTo" (lambda (p t) (temporal-plus-period t p 1))) + (cons "subtractFrom" (lambda (p t) (temporal-plus-period t p -1))) + (cons "toString" (lambda (p) (per->string p))))) +;; "PnYnMnWnD" -> a Period (weeks fold into days). +(define (parse-iso-period s) + (let ((len (string-length s)) (sign 1) (i 0) (y 0) (m 0) (d 0)) + (when (and (< i len) (char=? (string-ref s i) #\-)) (set! sign -1) (set! i (+ i 1))) + (unless (and (< i len) (or (char=? (string-ref s i) #\P) (char=? (string-ref s i) #\p))) + (error #f (string-append "could not parse Period: " s))) + (set! i (+ i 1)) + (let loop () + (when (< i len) + (let ((vsign (cond ((char=? (string-ref s i) #\-) (set! i (+ i 1)) -1) + ((char=? (string-ref s i) #\+) (set! i (+ i 1)) 1) + (else 1)))) + (let num ((k i) (acc 0) (any #f)) + (cond + ((and (< k len) (digit? (string-ref s k))) (num (+ k 1) (+ (* acc 10) (- (char->integer (string-ref s k)) 48)) #t)) + ((and any (< k len)) + (let ((u (char-upcase (string-ref s k))) (val (* vsign acc))) + (cond ((char=? u #\Y) (set! y val)) ((char=? u #\M) (set! m val)) + ((char=? u #\W) (set! d (+ d (* 7 val)))) ((char=? u #\D) (set! d (+ d val))) + (else (error #f (string-append "bad Period unit: " s)))) + (set! i (+ k 1)) (loop))) + (else (error #f (string-append "could not parse Period: " s)))))))) + (jt-period (* sign y) (* sign m) (* sign d)))) + +;; --- Year -------------------------------------------------------------------- +(define (jt-year y) (make-jhost "year" (vector y))) +(define (year-val y) (vector-ref (jhost-state y) 0)) +(define (year-from-temporal t) + (cond ((and (jhost? t) (string=? (jhost-tag t) "year")) t) + ((jt-date? t) (jt-year (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) (lambda (y m d) y)))) + ((jt-dt? t) (jt-year (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day t))) (lambda (y m d) y)))) + ((and (jhost? t) (string=? (jhost-tag t) "year-month")) (jt-year (ym-year t))) + (else (error #f "Year/from: unsupported")))) +(register-class-statics! "Year" + (list (cons "of" (lambda (y) (jt-year (jt->exact y)))) + (cons "now" (lambda _ (jt-year (call-with-values (lambda () (epoch-day->ymd (jt-floor-div (exact (truncate (now-ms))) 86400000))) (lambda (y m d) y))))) + (cons "isLeap" (lambda (y) (jt-leap? (jt->exact y)))) + (cons "parse" (lambda (s . _) (jt-year (or (string->number (jt-str s)) (error #f "could not parse Year"))))) + (cons "from" (lambda (t) (year-from-temporal t))) + (cons "MIN_VALUE" -999999999) + (cons "MAX_VALUE" 999999999))) +(register-host-methods! "year" + (list (cons "getValue" (lambda (y) (year-val y))) + (cons "isLeap" (lambda (y) (jt-leap? (year-val y)))) + (cons "length" (lambda (y) (if (jt-leap? (year-val y)) 366 365))) + (cons "plusYears" (lambda (y n) (jt-year (+ (year-val y) (jt->exact n))))) + (cons "minusYears" (lambda (y n) (jt-year (- (year-val y) (jt->exact n))))) + (cons "atMonth" (lambda (y m) (jt-year-month (year-val y) (jt->exact m)))) + (cons "atDay" (lambda (y doy) (jt-local-date (+ (ymd->epoch-day (year-val y) 1 1) (- (jt->exact doy) 1))))) + (cons "atMonthDay" (lambda (y md) (error #f "Year.atMonthDay: MonthDay unsupported"))) + (cons "isBefore" (lambda (y o) (< (year-val y) (year-val o)))) + (cons "isAfter" (lambda (y o) (> (year-val y) (year-val o)))) + (cons "isValidMonthDay" (lambda (y md) #f)) + (cons "compareTo" (lambda (y o) (let ((a (year-val y)) (b (year-val o))) (cond ((< a b) -1) ((> a b) 1) (else 0))))) + (cons "equals" (lambda (y o) (and (jhost? o) (string=? (jhost-tag o) "year") (= (year-val y) (year-val o))))) + (cons "hashCode" (lambda (y) (year-val y))) + (cons "toString" (lambda (y) (number->string (year-val y)))))) + +;; --- YearMonth: (vector year month) ------------------------------------------ +(define (jt-year-month y m) + (let* ((ym (+ (* y 12) (- m 1))) (y2 (jt-floor-div ym 12)) (m2 (+ 1 (jt-floor-mod ym 12)))) + (make-jhost "year-month" (vector y2 m2)))) +(define (ym-year x) (vector-ref (jhost-state x) 0)) +(define (ym-month x) (vector-ref (jhost-state x) 1)) +(define (ym-plus-months x n) + (let ((tm (+ (* (ym-year x) 12) (- (ym-month x) 1) n))) + (make-jhost "year-month" (vector (jt-floor-div tm 12) (+ 1 (jt-floor-mod tm 12)))))) +(define (ym->string x) (string-append (pad4 (ym-year x)) "-" (pad2 (ym-month x)))) +(define (ym-from-temporal t) + (cond ((and (jhost? t) (string=? (jhost-tag t) "year-month")) t) + ((jt-date? t) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) (lambda (y m d) (jt-year-month y m)))) + ((jt-dt? t) (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day t))) (lambda (y m d) (jt-year-month y m)))) + (else (error #f "YearMonth/from: unsupported")))) +(register-class-statics! "YearMonth" + (list (cons "of" (lambda (y m) (jt-year-month (jt->exact y) (jt->exact m)))) + (cons "now" (lambda _ (call-with-values (lambda () (epoch-day->ymd (jt-floor-div (exact (truncate (now-ms))) 86400000))) + (lambda (y m d) (jt-year-month y m))))) + (cons "parse" (lambda (s . _) (let ((str (jt-str s))) + (jt-year-month (or (digits-at str 0 4) (error #f "could not parse YearMonth")) + (or (digits-at str 5 2) (error #f "could not parse YearMonth")))))) + (cons "from" (lambda (t) (ym-from-temporal t))))) +(register-host-methods! "year-month" + (list (cons "getYear" (lambda (x) (ym-year x))) + (cons "getMonthValue" (lambda (x) (ym-month x))) + (cons "getMonth" (lambda (x) (jt-month (ym-month x)))) + (cons "lengthOfMonth" (lambda (x) (jt-len-of-month (ym-year x) (ym-month x)))) + (cons "lengthOfYear" (lambda (x) (if (jt-leap? (ym-year x)) 366 365))) + (cons "isLeapYear" (lambda (x) (jt-leap? (ym-year x)))) + (cons "plusMonths" (lambda (x n) (ym-plus-months x (jt->exact n)))) + (cons "minusMonths" (lambda (x n) (ym-plus-months x (- (jt->exact n))))) + (cons "plusYears" (lambda (x n) (jt-year-month (+ (ym-year x) (jt->exact n)) (ym-month x)))) + (cons "minusYears" (lambda (x n) (jt-year-month (- (ym-year x) (jt->exact n)) (ym-month x)))) + (cons "withYear" (lambda (x v) (jt-year-month (jt->exact v) (ym-month x)))) + (cons "withMonth" (lambda (x v) (jt-year-month (ym-year x) (jt->exact v)))) + (cons "atDay" (lambda (x d) (jt-local-date (ymd->epoch-day (ym-year x) (ym-month x) (jt->exact d))))) + (cons "atEndOfMonth" (lambda (x) (jt-local-date (ymd->epoch-day (ym-year x) (ym-month x) (jt-len-of-month (ym-year x) (ym-month x)))))) + (cons "isValidDay" (lambda (x d) (let ((dd (jt->exact d))) (and (>= dd 1) (<= dd (jt-len-of-month (ym-year x) (ym-month x))))))) + (cons "isBefore" (lambda (x o) (< (ym-cmp x o) 0))) + (cons "isAfter" (lambda (x o) (> (ym-cmp x o) 0))) + (cons "compareTo" (lambda (x o) (ym-cmp x o))) + (cons "equals" (lambda (x o) (and (jhost? o) (string=? (jhost-tag o) "year-month") (= (ym-cmp x o) 0)))) + (cons "hashCode" (lambda (x) (+ (* (ym-year x) 13) (ym-month x)))) + (cons "toString" (lambda (x) (ym->string x))))) +(define (ym-cmp x o) + (cond ((< (ym-year x) (ym-year o)) -1) ((> (ym-year x) (ym-year o)) 1) + ((< (ym-month x) (ym-month o)) -1) ((> (ym-month x) (ym-month o)) 1) (else 0))) + +;; --- ChronoUnit / ChronoField ------------------------------------------------ +;; Each ChronoUnit is a jhost (vector name nanos-or-#f) — nanos is the fixed +;; duration in nanoseconds for time-based units, or an estimate for date-based ones. +;; The conversion lets Duration/of and unit-based between/plus/until work. +(define seconds-per-year (* (/ 146097 400) 86400)) ; 365.2425 days +(define chrono-unit-table + ;; (name . nanos-per-unit) month/year use the average-length estimate java.time uses. + (list (cons "NANOS" 1) + (cons "MICROS" 1000) + (cons "MILLIS" 1000000) + (cons "SECONDS" nanos-per-sec) + (cons "MINUTES" (* 60 nanos-per-sec)) + (cons "HOURS" (* 3600 nanos-per-sec)) + (cons "HALF_DAYS" (* 43200 nanos-per-sec)) + (cons "DAYS" (* 86400 nanos-per-sec)) + (cons "WEEKS" (* 7 86400 nanos-per-sec)) + (cons "MONTHS" (exact (round (* (/ seconds-per-year 12) nanos-per-sec)))) + (cons "YEARS" (exact (round (* seconds-per-year nanos-per-sec)))) + (cons "DECADES" (exact (round (* 10 seconds-per-year nanos-per-sec)))) + (cons "CENTURIES" (exact (round (* 100 seconds-per-year nanos-per-sec)))) + (cons "MILLENNIA" (exact (round (* 1000 seconds-per-year nanos-per-sec)))) + (cons "ERAS" (exact (round (* 1000000000 seconds-per-year nanos-per-sec)))) + (cons "FOREVER" #f))) +(define (jt-chrono-unit name) (make-jhost "chrono-unit" (vector name))) +(define (cu-name u) (vector-ref (jhost-state u) 0)) +(define (chrono-unit-nanos u) + (let* ((nm (chrono-unit-name u)) (row (and nm (assoc (string-upcase nm) chrono-unit-table)))) + (if (and row (cdr row)) (cdr row) (error #f (string-append "no fixed duration for unit " (or nm "?")))))) +;; register the 16 unit constants under ChronoUnit statics. +(register-class-statics! "ChronoUnit" + (append + (map (lambda (row) (cons (car row) (jt-chrono-unit (car row)))) chrono-unit-table) + (list (cons "valueOf" (lambda (s) (jt-chrono-unit (jt-str s)))) + (cons "values" (lambda () (make-pvec (list->vector (map (lambda (r) (jt-chrono-unit (car r))) chrono-unit-table)))))))) +(register-host-methods! "chrono-unit" + (list (cons "name" (lambda (u) (cu-name u))) + (cons "toString" (lambda (u) (cu-name u))) + (cons "ordinal" (lambda (u) (let loop ((t chrono-unit-table) (i 0)) + (cond ((null? t) -1) ((string=? (caar t) (cu-name u)) i) (else (loop (cdr t) (+ i 1))))))) + (cons "getDuration" (lambda (u) (dur-of-total-nanos (chrono-unit-nanos u)))) + (cons "isDateBased" (lambda (u) (and (member (cu-name u) '("DAYS" "WEEKS" "MONTHS" "YEARS" "DECADES" "CENTURIES" "MILLENNIA" "ERAS")) #t))) + (cons "isTimeBased" (lambda (u) (and (member (cu-name u) '("NANOS" "MICROS" "MILLIS" "SECONDS" "MINUTES" "HOURS" "HALF_DAYS")) #t))) + (cons "isDurationEstimated" (lambda (u) (and (member (cu-name u) '("DAYS" "WEEKS" "MONTHS" "YEARS" "DECADES" "CENTURIES" "MILLENNIA" "ERAS" "FOREVER")) #t))) + (cons "between" (lambda (u a b) (unit-between (cu-name u) a b))) + (cons "addTo" (lambda (u t n) (temporal-plus-unit t (jt->exact n) (cu-name u)))) + (cons "equals" (lambda (u o) (and (jhost? o) (string=? (jhost-tag o) "chrono-unit") (string=? (cu-name u) (cu-name o))))) + (cons "hashCode" (lambda (u) (string-hash (cu-name u)))))) + +;; ChronoField: a jhost (vector name). get/getLong/with project the field onto a +;; temporal via the field-projection table below. +;; the full ChronoField enum (the cljc wrapper defs every constant at load). Only +;; the common ones are projected by temporal-get-field; the rest exist as tokens. +(define chrono-field-names + '("NANO_OF_SECOND" "NANO_OF_DAY" "MICRO_OF_SECOND" "MICRO_OF_DAY" "MILLI_OF_SECOND" "MILLI_OF_DAY" + "SECOND_OF_MINUTE" "SECOND_OF_DAY" "MINUTE_OF_HOUR" "MINUTE_OF_DAY" + "HOUR_OF_AMPM" "CLOCK_HOUR_OF_AMPM" "HOUR_OF_DAY" "CLOCK_HOUR_OF_DAY" "AMPM_OF_DAY" + "DAY_OF_WEEK" "ALIGNED_DAY_OF_WEEK_IN_MONTH" "ALIGNED_DAY_OF_WEEK_IN_YEAR" + "DAY_OF_MONTH" "DAY_OF_YEAR" "EPOCH_DAY" + "ALIGNED_WEEK_OF_MONTH" "ALIGNED_WEEK_OF_YEAR" + "MONTH_OF_YEAR" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "YEAR" "ERA" + "INSTANT_SECONDS" "OFFSET_SECONDS")) +(define (jt-chrono-field name) (make-jhost "chrono-field" (vector name))) +(define (cf-name f) (vector-ref (jhost-state f) 0)) +(register-class-statics! "ChronoField" + (append + (map (lambda (n) (cons n (jt-chrono-field n))) chrono-field-names) + (list (cons "valueOf" (lambda (s) (jt-chrono-field (jt-str s)))) + (cons "values" (lambda () (make-pvec (list->vector (map jt-chrono-field chrono-field-names)))))))) +(register-host-methods! "chrono-field" + (list (cons "name" (lambda (f) (cf-name f))) + (cons "toString" (lambda (f) (cf-name f))) + (cons "getDisplayName" (lambda (f . _) (cf-name f))) + (cons "isDateBased" (lambda (f) (and (member (cf-name f) '("DAY_OF_WEEK" "DAY_OF_MONTH" "DAY_OF_YEAR" "EPOCH_DAY" "MONTH_OF_YEAR" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "YEAR" "ERA")) #t))) + (cons "isTimeBased" (lambda (f) (not (member (cf-name f) '("DAY_OF_WEEK" "DAY_OF_MONTH" "DAY_OF_YEAR" "EPOCH_DAY" "MONTH_OF_YEAR" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "YEAR" "ERA" "INSTANT_SECONDS" "OFFSET_SECONDS"))))) + (cons "getFrom" (lambda (f t) (temporal-get-field t (cf-name f)))) + (cons "equals" (lambda (f o) (and (jhost? o) (string=? (jhost-tag o) "chrono-field") (string=? (cf-name f) (cf-name o))))) + (cons "hashCode" (lambda (f) (string-hash (cf-name f)))))) + +;; --- ValueRange (minimal min/max holder) ------------------------------------- +(define (jt-value-range smin lmin smax lmax) (make-jhost "value-range" (vector smin lmin smax lmax))) +(register-host-methods! "value-range" + (list (cons "getMinimum" (lambda (r) (vector-ref (jhost-state r) 1))) + (cons "getLargestMinimum" (lambda (r) (vector-ref (jhost-state r) 1))) + (cons "getSmallestMaximum" (lambda (r) (vector-ref (jhost-state r) 2))) + (cons "getMaximum" (lambda (r) (vector-ref (jhost-state r) 3))) + (cons "isFixed" (lambda (r) (and (= (vector-ref (jhost-state r) 0) (vector-ref (jhost-state r) 1)) + (= (vector-ref (jhost-state r) 2) (vector-ref (jhost-state r) 3))))) + (cons "isValidValue" (lambda (r v) (let ((x (jt->exact v))) (and (>= x (vector-ref (jhost-state r) 1)) (<= x (vector-ref (jhost-state r) 3)))))) + (cons "toString" (lambda (r) (string-append (number->string (vector-ref (jhost-state r) 1)) " - " (number->string (vector-ref (jhost-state r) 3))))))) + +;; --- temporal field/unit machinery: plus/minus/until/get/with on core types -- +;; These power the generic cljc.java-time.temporal dispatchers, which forward to +;; the receiver's plus/minus/until/get/getLong/with/range/isSupported. + +;; add n of `unit` to a temporal (local-date / local-time / local-date-time / instant). +(define (temporal-plus-unit t n unit) + (let ((u (string-upcase unit))) + (cond + ((jt-date? t) + (cond ((string=? u "DAYS") (jt-local-date (+ (ld-epoch-day t) n))) + ((string=? u "WEEKS") (jt-local-date (+ (ld-epoch-day t) (* 7 n)))) + ((string=? u "MONTHS") (ld-plus-months t n)) + ((string=? u "YEARS") (ld-plus-years t n)) + ((string=? u "DECADES") (ld-plus-years t (* 10 n))) + ((string=? u "CENTURIES") (ld-plus-years t (* 100 n))) + ((string=? u "MILLENNIA") (ld-plus-years t (* 1000 n))) + (else (error #f (string-append "LocalDate plus unsupported unit " u))))) + ((jt-time? t) (lt-plus t (* n (chrono-unit-nanos (jt-chrono-unit u))))) + ((jt-dt? t) + (cond ((string=? u "DAYS") (jt-local-dt (+ (ldt-epoch-day t) n) (ldt-nano-of-day t))) + ((string=? u "WEEKS") (jt-local-dt (+ (ldt-epoch-day t) (* 7 n)) (ldt-nano-of-day t))) + ((string=? u "MONTHS") (ldt-combine (ld-plus-months (ldt-date t) n) (ldt-time t))) + ((string=? u "YEARS") (ldt-combine (ld-plus-years (ldt-date t) n) (ldt-time t))) + ((string=? u "DECADES") (ldt-combine (ld-plus-years (ldt-date t) (* 10 n)) (ldt-time t))) + ((string=? u "CENTURIES") (ldt-combine (ld-plus-years (ldt-date t) (* 100 n)) (ldt-time t))) + ((string=? u "MILLENNIA") (ldt-combine (ld-plus-years (ldt-date t) (* 1000 n)) (ldt-time t))) + (else (ldt-plus-nanos t (* n (chrono-unit-nanos (jt-chrono-unit u))))))) + ((jt-instant? t) + (cond ((string=? u "DAYS") (mk-instant (+ (inst-ms t) (* n 86400000)))) + (else (mk-instant (+ (inst-ms t) (quotient (* n (chrono-unit-nanos (jt-chrono-unit u))) 1000000)))))) + (else (error #f "plus: unsupported temporal"))))) + +;; add raw nanos (for Duration.addTo). +(define (temporal-plus-nanos t nanos) + (cond ((jt-time? t) (lt-plus t nanos)) + ((jt-dt? t) (ldt-plus-nanos t nanos)) + ((jt-instant? t) (mk-instant (+ (inst-ms t) (quotient nanos 1000000)))) + ((jt-date? t) (jt-local-date (+ (ld-epoch-day t) (quotient nanos (* 86400 nanos-per-sec))))) + (else (error #f "plus(Duration): unsupported temporal")))) + +;; add a Period (scaled by sign) to a date-bearing temporal. +(define (temporal-plus-period t p sign) + (let ((y (* sign (per-years p))) (m (* sign (per-months p))) (d (* sign (per-days p)))) + (cond ((jt-date? t) (jt-local-date (+ (ld-epoch-day (ld-plus-months (ld-plus-years t y) m)) d))) + ((jt-dt? t) (let ((nd (ld-plus-months (ld-plus-years (ldt-date t) y) m))) + (jt-local-dt (+ (ld-epoch-day nd) d) (ldt-nano-of-day t)))) + (else (error #f "plus(Period): unsupported temporal"))))) + +;; count whole `unit`s from a to b. +(define (unit-between unit a b) + (let ((u (string-upcase unit))) + (cond + ((and (jt-date? a) (jt-date? b)) + (let ((da (ld-epoch-day a)) (db (ld-epoch-day b))) + (cond ((string=? u "DAYS") (- db da)) + ((string=? u "WEEKS") (quotient (- db da) 7)) + ((string=? u "MONTHS") (date-months-between da db)) + ((string=? u "YEARS") (quotient (date-months-between da db) 12)) + ((string=? u "DECADES") (quotient (date-months-between da db) 120)) + ((string=? u "CENTURIES") (quotient (date-months-between da db) 1200)) + (else (error #f (string-append "between unsupported unit " u)))))) + ((and (jt-time? a) (jt-time? b)) (quotient (- (lt-nano-of-day b) (lt-nano-of-day a)) (chrono-unit-nanos (jt-chrono-unit u)))) + ((and (jt-dt? a) (jt-dt? b)) + (cond ((member u '("YEARS" "MONTHS" "DECADES" "CENTURIES" "MILLENNIA")) + (unit-between u (ldt-date a) (ldt-date b))) ; date-based: ignore time-of-day below months on LDT? use date months adjusted + (else (quotient (- (+ (* (ldt-epoch-day b) nanos-per-day) (ldt-nano-of-day b)) + (+ (* (ldt-epoch-day a) nanos-per-day) (ldt-nano-of-day a))) + (chrono-unit-nanos (jt-chrono-unit u)))))) + ((and (jt-instant? a) (jt-instant? b)) + (quotient (* (- (inst-ms b) (inst-ms a)) 1000000) (chrono-unit-nanos (jt-chrono-unit u)))) + (else (error #f "between: unsupported temporals"))))) +;; whole months between two epoch-days (java.time: months, then -1 if day-of-month +;; of b hasn't reached a's). +(define (date-months-between da db) + (call-with-values (lambda () (epoch-day->ymd da)) + (lambda (y1 m1 d1) + (call-with-values (lambda () (epoch-day->ymd db)) + (lambda (y2 m2 d2) + (let ((months (- (+ (* y2 12) m2) (+ (* y1 12) m1)))) + (cond ((and (> months 0) (< d2 d1)) (- months 1)) + ((and (< months 0) (> d2 d1)) (+ months 1)) + (else months)))))))) + +;; field get: project a ChronoField onto a temporal. +(define (temporal-get-field t field) + (let ((f (string-upcase field))) + (cond + ((jt-date? t) + (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) + (lambda (y m d) + (cond ((string=? f "YEAR") y) ((string=? f "MONTH_OF_YEAR") m) ((string=? f "DAY_OF_MONTH") d) + ((string=? f "DAY_OF_WEEK") (ld-dow (ld-epoch-day t))) + ((string=? f "DAY_OF_YEAR") (ld-day-of-year (ld-epoch-day t))) + ((string=? f "EPOCH_DAY") (ld-epoch-day t)) + ((string=? f "PROLEPTIC_MONTH") (+ (* y 12) (- m 1))) + ((string=? f "YEAR_OF_ERA") (if (>= y 1) y (- 1 y))) + ((string=? f "ERA") (if (>= y 1) 1 0)) + (else (error #f (string-append "LocalDate has no field " f))))))) + ((jt-time? t) + (cond ((string=? f "HOUR_OF_DAY") (lt-hour t)) ((string=? f "MINUTE_OF_HOUR") (lt-minute t)) + ((string=? f "SECOND_OF_MINUTE") (lt-second t)) ((string=? f "NANO_OF_SECOND") (lt-nano t)) + ((string=? f "NANO_OF_DAY") (lt-nano-of-day t)) + ((string=? f "MILLI_OF_DAY") (quotient (lt-nano-of-day t) 1000000)) + ((string=? f "SECOND_OF_DAY") (quotient (lt-nano-of-day t) nanos-per-sec)) + ((string=? f "MINUTE_OF_DAY") (quotient (lt-nano-of-day t) (* 60 nanos-per-sec))) + ((string=? f "MILLI_OF_SECOND") (quotient (lt-nano t) 1000000)) + ((string=? f "MICRO_OF_SECOND") (quotient (lt-nano t) 1000)) + ((string=? f "AMPM_OF_DAY") (quotient (lt-hour t) 12)) + (else (error #f (string-append "LocalTime has no field " f))))) + ((jt-dt? t) + (if (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_WEEK" "DAY_OF_YEAR" "EPOCH_DAY" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "ERA")) + (temporal-get-field (ldt-date t) f) + (temporal-get-field (ldt-time t) f))) + ((jt-instant? t) + (cond ((string=? f "INSTANT_SECONDS") (jt-floor-div (exact (truncate (inst-ms t))) 1000)) + ((string=? f "NANO_OF_SECOND") (* (jt-floor-mod (exact (truncate (inst-ms t))) 1000) 1000000)) + ((string=? f "MILLI_OF_SECOND") (jt-floor-mod (exact (truncate (inst-ms t))) 1000)) + (else (error #f (string-append "Instant has no field " f))))) + (else (error #f "get(field): unsupported temporal"))))) + +;; field set: (with temporal ChronoField value) -> a new temporal. +(define (temporal-with-field t field v) + (let ((f (string-upcase field))) + (cond + ((jt-date? t) + (cond ((string=? f "YEAR") (ld-with-field t 'year v)) ((string=? f "MONTH_OF_YEAR") (ld-with-field t 'month v)) + ((string=? f "DAY_OF_MONTH") (ld-with-field t 'day v)) ((string=? f "DAY_OF_YEAR") (ld-with-field t 'day-of-year v)) + ((string=? f "EPOCH_DAY") (jt-local-date v)) + (else (error #f (string-append "LocalDate.with unsupported field " f))))) + ((jt-time? t) + (cond ((string=? f "HOUR_OF_DAY") (lt-with t 'hour v)) ((string=? f "MINUTE_OF_HOUR") (lt-with t 'minute v)) + ((string=? f "SECOND_OF_MINUTE") (lt-with t 'second v)) ((string=? f "NANO_OF_SECOND") (lt-with t 'nano v)) + ((string=? f "NANO_OF_DAY") (jt-local-time v)) + (else (error #f (string-append "LocalTime.with unsupported field " f))))) + ((jt-dt? t) + (if (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_YEAR" "EPOCH_DAY")) + (ldt-combine (temporal-with-field (ldt-date t) f v) (ldt-time t)) + (ldt-combine (ldt-date t) (temporal-with-field (ldt-time t) f v)))) + (else (error #f "with(field): unsupported temporal"))))) + +(define (temporal-supports-unit? t unit) + (let ((u (string-upcase unit))) + (cond ((jt-date? t) (and (member u '("DAYS" "WEEKS" "MONTHS" "YEARS" "DECADES" "CENTURIES" "MILLENNIA" "ERAS")) #t)) + ((jt-time? t) (and (member u '("NANOS" "MICROS" "MILLIS" "SECONDS" "MINUTES" "HOURS" "HALF_DAYS")) #t)) + ((or (jt-dt? t) (jt-instant? t)) (not (member u '("FOREVER")))) + (else #f)))) +(define (temporal-supports-field? t field) + (let ((f (string-upcase field))) + (cond ((jt-date? t) (and (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_WEEK" "DAY_OF_YEAR" "EPOCH_DAY" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "ERA")) #t)) + ((jt-time? t) (and (member f '("HOUR_OF_DAY" "MINUTE_OF_HOUR" "SECOND_OF_MINUTE" "NANO_OF_SECOND" "NANO_OF_DAY" "MILLI_OF_DAY" "SECOND_OF_DAY" "MINUTE_OF_DAY" "MILLI_OF_SECOND" "MICRO_OF_SECOND" "AMPM_OF_DAY")) #t)) + ((jt-dt? t) (or (temporal-supports-field? (ldt-date t) field) (temporal-supports-field? (ldt-time t) field))) + ((jt-instant? t) (and (member f '("INSTANT_SECONDS" "NANO_OF_SECOND" "MILLI_OF_SECOND" "MICRO_OF_SECOND")) #t)) + (else #f)))) + +;; isSupported / get / getLong / with / range / plus / minus / until accept a +;; chrono-unit OR chrono-field jhost (or a string). These method names extend the +;; existing per-tag tables. +(define (unit-or-field-arg x) x) +(define (arg-is-unit? x) (and (jhost? x) (string=? (jhost-tag x) "chrono-unit"))) +(define (arg-is-field? x) (and (jhost? x) (string=? (jhost-tag x) "chrono-field"))) +(define (arg-is-amount? x) (and (jhost? x) (member (jhost-tag x) '("duration" "period")))) +(define (arg-unit-name x) (cond ((arg-is-unit? x) (cu-name x)) ((string? x) x) ((keyword? x) (keyword-t-name x)) (else #f))) +(define (arg-field-name x) (cond ((arg-is-field? x) (cf-name x)) ((string? x) x) ((keyword? x) (keyword-t-name x)) (else #f))) + +;; the generic plus/minus/until/get/getLong/with/range/isSupported, shared by all +;; four core tags. plus/minus accept (n unit) or (amount); with accepts (field val). +(define (mk-temporal-methods) + (list + (cons "plus" (case-lambda + ((t a) (cond ((arg-is-amount? a) (if (string=? (jhost-tag a) "duration") + (temporal-plus-nanos t (dur-total-nanos a)) + (temporal-plus-period t a 1))) + (else (error #f "plus: bad amount")))) + ((t n u) (temporal-plus-unit t (jt->exact n) (arg-unit-name u))))) + (cons "minus" (case-lambda + ((t a) (cond ((arg-is-amount? a) (if (string=? (jhost-tag a) "duration") + (temporal-plus-nanos t (- (dur-total-nanos a))) + (temporal-plus-period t a -1))) + (else (error #f "minus: bad amount")))) + ((t n u) (temporal-plus-unit t (- (jt->exact n)) (arg-unit-name u))))) + (cons "until" (lambda (t o u) (unit-between (arg-unit-name u) t o))) + (cons "get" (lambda (t f) (temporal-get-field t (arg-field-name f)))) + (cons "getLong" (lambda (t f) (temporal-get-field t (arg-field-name f)))) + (cons "with" (lambda (t f v) (temporal-with-field t (arg-field-name f) (jt->exact v)))) + (cons "isSupported" (lambda (t x) (cond ((arg-is-unit? x) (temporal-supports-unit? t (cu-name x))) + ((arg-is-field? x) (temporal-supports-field? t (cf-name x))) + (else #f)))) + (cons "range" (lambda (t f) (temporal-range t (arg-field-name f)))))) +(register-host-methods! "local-date" (mk-temporal-methods)) +(register-host-methods! "local-time" (mk-temporal-methods)) +(register-host-methods! "local-date-time" (mk-temporal-methods)) +(register-host-methods! "instant" (mk-temporal-methods)) + +;; range(field): a ValueRange. A small set of common fields; others fall back to a +;; generous range so callers that only read min/max don't crash. +(define (temporal-range t field) + (let ((f (string-upcase field))) + (cond + ((and (jt-date? t) (string=? f "DAY_OF_MONTH")) + (jt-value-range 1 1 28 (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) (lambda (y m d) (jt-len-of-month y m))))) + ((string=? f "MONTH_OF_YEAR") (jt-value-range 1 1 12 12)) + ((string=? f "DAY_OF_WEEK") (jt-value-range 1 1 7 7)) + ((string=? f "HOUR_OF_DAY") (jt-value-range 0 0 23 23)) + ((string=? f "MINUTE_OF_HOUR") (jt-value-range 0 0 59 59)) + ((string=? f "SECOND_OF_MINUTE") (jt-value-range 0 0 59 59)) + ((string=? f "NANO_OF_SECOND") (jt-value-range 0 0 999999999 999999999)) + (else (jt-value-range 0 0 999999999999 999999999999))))) ;; --- equality / hash / compare / print / instance? -------------------------- (define (jt-date? x) (and (jhost? x) (string=? (jhost-tag x) "local-date"))) @@ -492,6 +1182,25 @@ (register-str-render! jt-instant? (lambda (x) (iso-instant-str (inst-ms x)))) (register-pr-arm! jt-instant? (lambda (x) (iso-instant-str (inst-ms x)))) +;; Phase-2 value types: amounts, enums, and the chrono-unit/field tokens. Each +;; prints as its java.time toString and is = / hashed on its canonical state. +(define (jt-tagged? tag) (lambda (x) (and (jhost? x) (string=? (jhost-tag x) tag)))) +(define (register-jt-value! tag str-fn hash-fn) + (let ((pred (jt-tagged? tag))) + (register-str-render! pred str-fn) + (register-pr-arm! pred str-fn) + (register-eq-arm! (lambda (a b) (or (pred a) (pred b))) + (lambda (a b) (and (pred a) (pred b) (equal? (jhost-state a) (jhost-state b))))) + (register-hash-arm! pred hash-fn))) +(register-jt-value! "duration" dur->string (lambda (x) (jolt-hash (dur-total-nanos x)))) +(register-jt-value! "period" per->string (lambda (x) (jolt-hash (+ (per-years x) (per-months x) (per-days x))))) +(register-jt-value! "month-enum" (lambda (x) (month-name (month-val x))) (lambda (x) (jolt-hash (month-val x)))) +(register-jt-value! "dow-enum" (lambda (x) (dow-name (dow-val x))) (lambda (x) (jolt-hash (dow-val x)))) +(register-jt-value! "year" (lambda (x) (number->string (year-val x))) (lambda (x) (jolt-hash (year-val x)))) +(register-jt-value! "year-month" ym->string (lambda (x) (jolt-hash (+ (* (ym-year x) 13) (ym-month x))))) +(register-jt-value! "chrono-unit" cu-name (lambda (x) (jolt-hash (cu-name x)))) +(register-jt-value! "chrono-field" cf-name (lambda (x) (jolt-hash (cf-name x)))) + ;; compare: same-type java.time values compare on their canonical state. (define %jt-prev-compare jolt-compare) (set! jolt-compare @@ -501,7 +1210,15 @@ ((and (jt-time? a) (jt-time? b)) (cond ((< (lt-nano-of-day a) (lt-nano-of-day b)) -1) ((> (lt-nano-of-day a) (lt-nano-of-day b)) 1) (else 0))) ((and (jt-dt? a) (jt-dt? b)) (ldt-cmp a b)) ((and (jt-instant? a) (jt-instant? b)) (cond ((< (inst-ms a) (inst-ms b)) -1) ((> (inst-ms a) (inst-ms b)) 1) (else 0))) + ((and (jt-tagged-as? a "duration") (jt-tagged-as? b "duration")) + (let ((x (dur-total-nanos a)) (y (dur-total-nanos b))) (cond ((< x y) -1) ((> x y) 1) (else 0)))) + ((and (jt-tagged-as? a "month-enum") (jt-tagged-as? b "month-enum")) (- (month-val a) (month-val b))) + ((and (jt-tagged-as? a "dow-enum") (jt-tagged-as? b "dow-enum")) (- (dow-val a) (dow-val b))) + ((and (jt-tagged-as? a "year") (jt-tagged-as? b "year")) + (let ((x (year-val a)) (y (year-val b))) (cond ((< x y) -1) ((> x y) 1) (else 0)))) + ((and (jt-tagged-as? a "year-month") (jt-tagged-as? b "year-month")) (ym-cmp a b)) (else (%jt-prev-compare a b))))) +(define (jt-tagged-as? x tag) (and (jhost? x) (string=? (jhost-tag x) tag))) (def-var! "clojure.core" "compare" jolt-compare) ;; instance? for the three new tags (inst-time.ss already answers "instant"). @@ -512,4 +1229,12 @@ ((jt-date? val) (if (string=? tn "LocalDate") #t 'pass)) ((jt-time? val) (if (string=? tn "LocalTime") #t 'pass)) ((jt-dt? val) (if (string=? tn "LocalDateTime") #t 'pass)) + ((jt-tagged-as? val "duration") (if (member tn '("Duration" "TemporalAmount")) #t 'pass)) + ((jt-tagged-as? val "period") (if (member tn '("Period" "TemporalAmount")) #t 'pass)) + ((jt-tagged-as? val "month-enum") (if (string=? tn "Month") #t 'pass)) + ((jt-tagged-as? val "dow-enum") (if (string=? tn "DayOfWeek") #t 'pass)) + ((jt-tagged-as? val "year") (if (string=? tn "Year") #t 'pass)) + ((jt-tagged-as? val "year-month") (if (string=? tn "YearMonth") #t 'pass)) + ((jt-tagged-as? val "chrono-unit") (if (member tn '("ChronoUnit" "TemporalUnit")) #t 'pass)) + ((jt-tagged-as? val "chrono-field") (if (member tn '("ChronoField" "TemporalField")) #t 'pass)) (else 'pass))))) diff --git a/host/chez/records.ss b/host/chez/records.ss index a1cb351..776fed6 100644 --- a/host/chez/records.ss +++ b/host/chez/records.ss @@ -144,6 +144,14 @@ ((and (jhost? obj) (string=? (jhost-tag obj) "local-date")) '("LocalDate" "java.time.LocalDate" "Object")) ((and (jhost? obj) (string=? (jhost-tag obj) "local-time")) '("LocalTime" "java.time.LocalTime" "Object")) ((and (jhost? obj) (string=? (jhost-tag obj) "local-date-time")) '("LocalDateTime" "java.time.LocalDateTime" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "duration")) '("Duration" "java.time.Duration" "TemporalAmount" "java.time.temporal.TemporalAmount" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "period")) '("Period" "java.time.Period" "TemporalAmount" "java.time.temporal.TemporalAmount" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "month-enum")) '("Month" "java.time.Month" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "dow-enum")) '("DayOfWeek" "java.time.DayOfWeek" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "year")) '("Year" "java.time.Year" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "year-month")) '("YearMonth" "java.time.YearMonth" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "chrono-unit")) '("ChronoUnit" "java.time.temporal.ChronoUnit" "TemporalUnit" "java.time.temporal.TemporalUnit" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "chrono-field")) '("ChronoField" "java.time.temporal.ChronoField" "TemporalField" "java.time.temporal.TemporalField" "Object")) ;; java.sql.Date — a distinct class from java.util.Date so a protocol ;; extended to both (data.json's JSONWriter) routes a sql.Date to its impl. ((and (jhost? obj) (string=? (jhost-tag obj) "sql-date")) '("java.sql.Date" "Date" "java.util.Date" "Object")) diff --git a/host/chez/seed/image.ss b/host/chez/seed/image.ss index 27ac600..17e8415 100644 --- a/host/chez/seed/image.ss +++ b/host/chez/seed/image.ss @@ -109,17 +109,17 @@ (guard (e (#t #f)) (def-var! "jolt.analyzer" "analyze-ffi-callable" (letrec ((analyze-ffi-callable (lambda (ctx items env) (let fnrec7244 ((ctx ctx) (items items) (env env)) (begin (if (jolt-not (<= 4 (jolt-count items) 5)) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "jolt.ffi/foreign-callable expects (foreign-callable f [argtypes] rettype [:collect-safe])")) jolt-nil) (let* ((_o$7245 (keyword #f "op")) (_o$7246 (keyword #f "ffi-callable")) (_o$7247 (keyword #f "fn")) (_o$7248 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-nth items 1) env)) (_o$7249 (keyword #f "argtypes")) (_o$7250 (jolt-invoke (var-deref "clojure.core" "mapv") (var-deref "clojure.core" "name") (jolt-invoke (var-deref "jolt.host" "form-vec-items") (jolt-nth items 2)))) (_o$7251 (keyword #f "rettype")) (_o$7252 (jolt-invoke (var-deref "clojure.core" "name") (jolt-nth items 3))) (_o$7253 (keyword #f "collect-safe")) (_o$7254 (let* ((and__25__auto (jolt= 5 (jolt-count items)))) (if (jolt-truthy? and__25__auto) (jolt= "collect-safe" (jolt-invoke (var-deref "clojure.core" "name") (jolt-nth items 4))) and__25__auto)))) (jolt-hash-map _o$7245 _o$7246 _o$7247 _o$7248 _o$7249 _o$7250 _o$7251 _o$7252 _o$7253 _o$7254))))))) analyze-ffi-callable))) (guard (e (#t #f)) - (def-var! "jolt.analyzer" "analyze-dot" (letrec ((analyze-dot (lambda (ctx items env) (let fnrec7255 ((ctx ctx) (items items) (env env)) (begin (if (< (jolt-count items) 3) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "Malformed (. target member ...) form")) jolt-nil) (let* ((member (jolt-nth items 2))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-sym?") member)) (let* ((_o$7260 (keyword #f "op")) (_o$7261 (keyword #f "host-call")) (_o$7262 (keyword #f "method")) (_o$7263 (jolt-invoke (var-deref "jolt.host" "form-sym-name") member)) (_o$7264 (keyword #f "target")) (_o$7265 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-nth items 1) env)) (_o$7266 (keyword #f "args")) (_o$7267 (let* ((_a$7257 (var-deref "clojure.core" "mapv")) (_a$7258 (lambda (p__91_) (let fnrec7256 ((p__91_ p__91_)) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx p__91_ env)))) (_a$7259 (jolt-drop 3 items))) (jolt-invoke _a$7257 _a$7258 _a$7259)))) (jolt-hash-map _o$7260 _o$7261 _o$7262 _o$7263 _o$7264 _o$7265 _o$7266 _o$7267)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-keyword?") member)) (let* ((_a$7268 (var-deref "jolt.ir" "invoke")) (_a$7269 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx member env)) (_a$7270 (jolt-vector (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-nth items 1) env)))) (jolt-invoke _a$7268 _a$7269 _a$7270)) (if (jolt-truthy? (keyword #f "else")) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") "special form . (non-symbol member)") jolt-nil))))))))) analyze-dot))) + (def-var! "jolt.analyzer" "analyze-dot" (letrec ((analyze-dot (lambda (ctx items env) (let fnrec7255 ((ctx ctx) (items items) (env env)) (begin (if (< (jolt-count items) 3) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "Malformed (. target member ...) form")) jolt-nil) (let* ((target (jolt-nth items 1)) (member (jolt-nth items 2)) (class-target (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") target))) (if (jolt-truthy? and__25__auto) (jolt-not (jolt-invoke (var-deref "jolt.analyzer" "local?") env (jolt-invoke (var-deref "jolt.host" "form-sym-name") target))) and__25__auto))) (let* ((r (jolt-invoke (var-deref "jolt.host" "resolve-global") ctx target))) (if (jolt= (keyword #f "class") (jolt-get r (keyword #f "kind"))) (jolt-get r (keyword #f "name")) jolt-nil)) jolt-nil))) (if (jolt-truthy? (let* ((and__25__auto class-target)) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-sym?") member) and__25__auto))) (let* ((_a$7260 (var-deref "jolt.ir" "invoke")) (_a$7261 (jolt-invoke (var-deref "jolt.ir" "host-static") class-target (jolt-invoke (var-deref "jolt.host" "form-sym-name") member))) (_a$7262 (let* ((_a$7257 (var-deref "clojure.core" "mapv")) (_a$7258 (lambda (p__91_) (let fnrec7256 ((p__91_ p__91_)) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx p__91_ env)))) (_a$7259 (jolt-drop 3 items))) (jolt-invoke _a$7257 _a$7258 _a$7259)))) (jolt-invoke _a$7260 _a$7261 _a$7262)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-sym?") member)) (let* ((_o$7267 (keyword #f "op")) (_o$7268 (keyword #f "host-call")) (_o$7269 (keyword #f "method")) (_o$7270 (jolt-invoke (var-deref "jolt.host" "form-sym-name") member)) (_o$7271 (keyword #f "target")) (_o$7272 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx target env)) (_o$7273 (keyword #f "args")) (_o$7274 (let* ((_a$7264 (var-deref "clojure.core" "mapv")) (_a$7265 (lambda (p__92_) (let fnrec7263 ((p__92_ p__92_)) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx p__92_ env)))) (_a$7266 (jolt-drop 3 items))) (jolt-invoke _a$7264 _a$7265 _a$7266)))) (jolt-hash-map _o$7267 _o$7268 _o$7269 _o$7270 _o$7271 _o$7272 _o$7273 _o$7274)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-keyword?") member)) (let* ((_a$7275 (var-deref "jolt.ir" "invoke")) (_a$7276 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx member env)) (_a$7277 (jolt-vector (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-nth items 1) env)))) (jolt-invoke _a$7275 _a$7276 _a$7277)) (if (jolt-truthy? (keyword #f "else")) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") "special form . (non-symbol member)") jolt-nil)))))))))) analyze-dot))) (guard (e (#t #f)) - (def-var! "jolt.analyzer" "analyze-field" (letrec ((analyze-field (lambda (ctx hname items env) (let fnrec7271 ((ctx ctx) (hname hname) (items items) (env env)) (begin (if (< (jolt-count items) 2) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "Malformed (.-field target) form")) jolt-nil) (let* ((_o$7272 (keyword #f "op")) (_o$7273 (keyword #f "host-call")) (_o$7274 (keyword #f "method")) (_o$7275 (jolt-invoke (var-deref "clojure.core" "subs") hname 1)) (_o$7276 (keyword #f "target")) (_o$7277 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-nth items 1) env)) (_o$7278 (keyword #f "args")) (_o$7279 (jolt-vector))) (jolt-hash-map _o$7272 _o$7273 _o$7274 _o$7275 _o$7276 _o$7277 _o$7278 _o$7279))))))) analyze-field))) + (def-var! "jolt.analyzer" "analyze-field" (letrec ((analyze-field (lambda (ctx hname items env) (let fnrec7278 ((ctx ctx) (hname hname) (items items) (env env)) (begin (if (< (jolt-count items) 2) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "Malformed (.-field target) form")) jolt-nil) (let* ((_o$7279 (keyword #f "op")) (_o$7280 (keyword #f "host-call")) (_o$7281 (keyword #f "method")) (_o$7282 (jolt-invoke (var-deref "clojure.core" "subs") hname 1)) (_o$7283 (keyword #f "target")) (_o$7284 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-nth items 1) env)) (_o$7285 (keyword #f "args")) (_o$7286 (jolt-vector))) (jolt-hash-map _o$7279 _o$7280 _o$7281 _o$7282 _o$7283 _o$7284 _o$7285 _o$7286))))))) analyze-field))) (guard (e (#t #f)) - (def-var! "jolt.analyzer" "analyze-symbol" (letrec ((analyze-symbol (lambda (ctx form env) (let fnrec7280 ((ctx ctx) (form form) (env env)) (let* ((nm (jolt-invoke (var-deref "jolt.host" "form-sym-name") form)) (ns (jolt-invoke (var-deref "jolt.host" "form-sym-ns") form))) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "clojure.core" "nil?") ns))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "local?") env nm) and__25__auto))) (let* ((h (jolt-get (jolt-get env (keyword #f "hints")) nm))) (if (jolt-truthy? h) (jolt-assoc (jolt-invoke (var-deref "jolt.ir" "local") nm) (keyword #f "hint") h) (jolt-invoke (var-deref "jolt.ir" "local") nm))) (if (jolt-truthy? ns) (let* ((r (jolt-invoke (var-deref "jolt.host" "resolve-global") ctx form))) (if (jolt= (keyword #f "var") (jolt-get r (keyword #f "kind"))) (let* ((G__134 (let* ((_a$7281 (var-deref "jolt.ir" "var-ref")) (_a$7282 (jolt-get r (keyword #f "ns"))) (_a$7283 (jolt-get r (keyword #f "name")))) (jolt-invoke _a$7281 _a$7282 _a$7283)))) (let* ((G__135 (if (jolt-truthy? (jolt-get r (keyword #f "num-ret"))) (jolt-assoc G__134 (keyword #f "num-ret") (jolt-get r (keyword #f "num-ret"))) G__134))) G__135)) (jolt-invoke (var-deref "jolt.ir" "host-static") ns nm))) (if (jolt-truthy? (keyword #f "else")) (let* ((r (jolt-invoke (var-deref "jolt.host" "resolve-global") ctx form))) (let* ((G__136 (jolt-get r (keyword #f "kind")))) (if (jolt= G__136 (keyword #f "var")) (let* ((G__137 (let* ((_a$7284 (var-deref "jolt.ir" "var-ref")) (_a$7285 (jolt-get r (keyword #f "ns"))) (_a$7286 (jolt-get r (keyword #f "name")))) (jolt-invoke _a$7284 _a$7285 _a$7286)))) (let* ((G__138 (if (jolt-truthy? (jolt-get r (keyword #f "num-ret"))) (jolt-assoc G__137 (keyword #f "num-ret") (jolt-get r (keyword #f "num-ret"))) G__137))) G__138)) (if (jolt= G__136 (keyword #f "host")) (jolt-invoke (var-deref "jolt.ir" "host-ref") (jolt-get r (keyword #f "name"))) (if (jolt= G__136 (keyword #f "class")) (jolt-invoke (var-deref "jolt.ir" "const") (jolt-get r (keyword #f "name"))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "late-bind?") ctx)) (jolt-invoke (var-deref "jolt.ir" "var-ref") (jolt-invoke (var-deref "jolt.host" "compile-ns") ctx) nm) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") (jolt-invoke (var-deref "clojure.core" "str") "Unable to resolve symbol: " nm " in this context")))))))) jolt-nil)))))))) analyze-symbol))) + (def-var! "jolt.analyzer" "analyze-symbol" (letrec ((analyze-symbol (lambda (ctx form env) (let fnrec7287 ((ctx ctx) (form form) (env env)) (let* ((nm (jolt-invoke (var-deref "jolt.host" "form-sym-name") form)) (ns (jolt-invoke (var-deref "jolt.host" "form-sym-ns") form))) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "clojure.core" "nil?") ns))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "local?") env nm) and__25__auto))) (let* ((h (jolt-get (jolt-get env (keyword #f "hints")) nm))) (if (jolt-truthy? h) (jolt-assoc (jolt-invoke (var-deref "jolt.ir" "local") nm) (keyword #f "hint") h) (jolt-invoke (var-deref "jolt.ir" "local") nm))) (if (jolt-truthy? ns) (let* ((r (jolt-invoke (var-deref "jolt.host" "resolve-global") ctx form))) (if (jolt= (keyword #f "var") (jolt-get r (keyword #f "kind"))) (let* ((G__134 (let* ((_a$7288 (var-deref "jolt.ir" "var-ref")) (_a$7289 (jolt-get r (keyword #f "ns"))) (_a$7290 (jolt-get r (keyword #f "name")))) (jolt-invoke _a$7288 _a$7289 _a$7290)))) (let* ((G__135 (if (jolt-truthy? (jolt-get r (keyword #f "num-ret"))) (jolt-assoc G__134 (keyword #f "num-ret") (jolt-get r (keyword #f "num-ret"))) G__134))) G__135)) (jolt-invoke (var-deref "jolt.ir" "host-static") ns nm))) (if (jolt-truthy? (keyword #f "else")) (let* ((r (jolt-invoke (var-deref "jolt.host" "resolve-global") ctx form))) (let* ((G__136 (jolt-get r (keyword #f "kind")))) (if (jolt= G__136 (keyword #f "var")) (let* ((G__137 (let* ((_a$7291 (var-deref "jolt.ir" "var-ref")) (_a$7292 (jolt-get r (keyword #f "ns"))) (_a$7293 (jolt-get r (keyword #f "name")))) (jolt-invoke _a$7291 _a$7292 _a$7293)))) (let* ((G__138 (if (jolt-truthy? (jolt-get r (keyword #f "num-ret"))) (jolt-assoc G__137 (keyword #f "num-ret") (jolt-get r (keyword #f "num-ret"))) G__137))) G__138)) (if (jolt= G__136 (keyword #f "host")) (jolt-invoke (var-deref "jolt.ir" "host-ref") (jolt-get r (keyword #f "name"))) (if (jolt= G__136 (keyword #f "class")) (jolt-invoke (var-deref "jolt.ir" "const") (jolt-get r (keyword #f "name"))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "late-bind?") ctx)) (jolt-invoke (var-deref "jolt.ir" "var-ref") (jolt-invoke (var-deref "jolt.host" "compile-ns") ctx) nm) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") (jolt-invoke (var-deref "clojure.core" "str") "Unable to resolve symbol: " nm " in this context")))))))) jolt-nil)))))))) analyze-symbol))) (guard (e (#t #f)) - (def-var! "jolt.analyzer" "analyze-list" (letrec ((analyze-list (lambda (ctx form env) (let fnrec7287 ((ctx ctx) (form form) (env env)) (let* ((items (jolt-invoke (var-deref "clojure.core" "vec") (jolt-invoke (var-deref "jolt.host" "form-elements") form)))) (if (jolt-zero? (jolt-count items)) (jolt-invoke (var-deref "jolt.ir" "quote-node") form) (let* ((head (jolt-first items)) (hname (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "clojure.core" "nil?") (jolt-invoke (var-deref "jolt.host" "form-sym-ns") head)) and__25__auto))) (jolt-invoke (var-deref "jolt.host" "form-sym-name") head) jolt-nil)) (shadowed (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "local?") env hname) and__25__auto)))) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-macro?") ctx head) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-invoke (var-deref "jolt.host" "form-expand-1") ctx form) env) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt= "jolt.ffi" (jolt-invoke (var-deref "jolt.host" "form-sym-ns") head)))) (if (jolt-truthy? and__25__auto) (jolt= "__cfn" (jolt-invoke (var-deref "jolt.host" "form-sym-name") head)) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-ffi-fn") ctx items env) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt= "jolt.ffi" (jolt-invoke (var-deref "jolt.host" "form-sym-ns") head)))) (if (jolt-truthy? and__25__auto) (jolt= "__ccallable" (jolt-invoke (var-deref "jolt.host" "form-sym-name") head)) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-ffi-callable") ctx items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (jolt-contains? (var-deref "jolt.analyzer" "handled") hname) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-special") ctx hname items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "method-head?") hname) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-host-call") ctx hname items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "ctor-head?") hname) and__25__auto)) and__25__auto))) (let* ((_a$7288 (var-deref "jolt.analyzer" "analyze-ctor")) (_a$7289 ctx) (_a$7290 (jolt-invoke (var-deref "clojure.core" "subs") hname 0 (jolt-dec (jolt-count hname)))) (_a$7291 (jolt-rest items)) (_a$7292 env)) (jolt-invoke _a$7288 _a$7289 _a$7290 _a$7291 _a$7292)) (if (jolt-truthy? (let* ((and__25__auto (jolt= hname "new"))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (>= (jolt-count items) 2))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-sym?") (jolt-nth items 1)) and__25__auto)) and__25__auto)) and__25__auto))) (let* ((_a$7293 (var-deref "jolt.analyzer" "analyze-ctor")) (_a$7294 ctx) (_a$7295 (jolt-invoke (var-deref "jolt.host" "form-sym-name") (jolt-nth items 1))) (_a$7296 (jolt-drop 2 items)) (_a$7297 env)) (jolt-invoke _a$7293 _a$7294 _a$7295 _a$7296 _a$7297)) (if (jolt-truthy? (let* ((and__25__auto (jolt= hname "."))) (if (jolt-truthy? and__25__auto) (jolt-not shadowed) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-dot") ctx items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "field-head?") hname) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-field") ctx hname items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-special?") hname) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") (jolt-invoke (var-deref "clojure.core" "str") "special form " hname)) (if (jolt-truthy? (keyword #f "else")) (let* ((n (let* ((_a$7302 (var-deref "jolt.ir" "invoke")) (_a$7303 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx head env)) (_a$7304 (let* ((_a$7299 (var-deref "clojure.core" "mapv")) (_a$7300 (lambda (p__92_) (let fnrec7298 ((p__92_ p__92_)) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx p__92_ env)))) (_a$7301 (jolt-rest items))) (jolt-invoke _a$7299 _a$7300 _a$7301)))) (jolt-invoke _a$7302 _a$7303 _a$7304))) (p (jolt-invoke (var-deref "jolt.host" "form-position") form))) (if (jolt-truthy? p) (jolt-assoc n (keyword #f "pos") p) n)) jolt-nil)))))))))))))))))) analyze-list))) + (def-var! "jolt.analyzer" "analyze-list" (letrec ((analyze-list (lambda (ctx form env) (let fnrec7294 ((ctx ctx) (form form) (env env)) (let* ((items (jolt-invoke (var-deref "clojure.core" "vec") (jolt-invoke (var-deref "jolt.host" "form-elements") form)))) (if (jolt-zero? (jolt-count items)) (jolt-invoke (var-deref "jolt.ir" "quote-node") form) (let* ((head (jolt-first items)) (hname (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "clojure.core" "nil?") (jolt-invoke (var-deref "jolt.host" "form-sym-ns") head)) and__25__auto))) (jolt-invoke (var-deref "jolt.host" "form-sym-name") head) jolt-nil)) (shadowed (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "local?") env hname) and__25__auto)))) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-macro?") ctx head) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-invoke (var-deref "jolt.host" "form-expand-1") ctx form) env) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt= "jolt.ffi" (jolt-invoke (var-deref "jolt.host" "form-sym-ns") head)))) (if (jolt-truthy? and__25__auto) (jolt= "__cfn" (jolt-invoke (var-deref "jolt.host" "form-sym-name") head)) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-ffi-fn") ctx items env) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt= "jolt.ffi" (jolt-invoke (var-deref "jolt.host" "form-sym-ns") head)))) (if (jolt-truthy? and__25__auto) (jolt= "__ccallable" (jolt-invoke (var-deref "jolt.host" "form-sym-name") head)) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-ffi-callable") ctx items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (jolt-contains? (var-deref "jolt.analyzer" "handled") hname) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-special") ctx hname items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "method-head?") hname) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-host-call") ctx hname items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "ctor-head?") hname) and__25__auto)) and__25__auto))) (let* ((_a$7295 (var-deref "jolt.analyzer" "analyze-ctor")) (_a$7296 ctx) (_a$7297 (jolt-invoke (var-deref "clojure.core" "subs") hname 0 (jolt-dec (jolt-count hname)))) (_a$7298 (jolt-rest items)) (_a$7299 env)) (jolt-invoke _a$7295 _a$7296 _a$7297 _a$7298 _a$7299)) (if (jolt-truthy? (let* ((and__25__auto (jolt= hname "new"))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (>= (jolt-count items) 2))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-sym?") (jolt-nth items 1)) and__25__auto)) and__25__auto)) and__25__auto))) (let* ((_a$7300 (var-deref "jolt.analyzer" "analyze-ctor")) (_a$7301 ctx) (_a$7302 (jolt-invoke (var-deref "jolt.host" "form-sym-name") (jolt-nth items 1))) (_a$7303 (jolt-drop 2 items)) (_a$7304 env)) (jolt-invoke _a$7300 _a$7301 _a$7302 _a$7303 _a$7304)) (if (jolt-truthy? (let* ((and__25__auto (jolt= hname "."))) (if (jolt-truthy? and__25__auto) (jolt-not shadowed) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-dot") ctx items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "field-head?") hname) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-field") ctx hname items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-special?") hname) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") (jolt-invoke (var-deref "clojure.core" "str") "special form " hname)) (if (jolt-truthy? (keyword #f "else")) (let* ((n (let* ((_a$7309 (var-deref "jolt.ir" "invoke")) (_a$7310 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx head env)) (_a$7311 (let* ((_a$7306 (var-deref "clojure.core" "mapv")) (_a$7307 (lambda (p__93_) (let fnrec7305 ((p__93_ p__93_)) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx p__93_ env)))) (_a$7308 (jolt-rest items))) (jolt-invoke _a$7306 _a$7307 _a$7308)))) (jolt-invoke _a$7309 _a$7310 _a$7311))) (p (jolt-invoke (var-deref "jolt.host" "form-position") form))) (if (jolt-truthy? p) (jolt-assoc n (keyword #f "pos") p) n)) jolt-nil)))))))))))))))))) analyze-list))) (guard (e (#t #f)) - (def-var! "jolt.analyzer" "with-coll-meta" (letrec ((with-coll-meta (lambda (ctx form env node) (let fnrec7305 ((ctx ctx) (form form) (env env) (node node)) (let* ((m (jolt-invoke (var-deref "jolt.host" "form-coll-meta") form))) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "nil?") m)) node (let* ((_a$7308 (var-deref "jolt.ir" "invoke")) (_a$7309 (jolt-invoke (var-deref "jolt.ir" "var-ref") "clojure.core" "with-meta")) (_a$7310 (let* ((_o$7306 node) (_o$7307 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx m env))) (jolt-vector _o$7306 _o$7307)))) (jolt-invoke _a$7308 _a$7309 _a$7310)))))))) with-coll-meta))) + (def-var! "jolt.analyzer" "with-coll-meta" (letrec ((with-coll-meta (lambda (ctx form env node) (let fnrec7312 ((ctx ctx) (form form) (env env) (node node)) (let* ((m (jolt-invoke (var-deref "jolt.host" "form-coll-meta") form))) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "nil?") m)) node (let* ((_a$7315 (var-deref "jolt.ir" "invoke")) (_a$7316 (jolt-invoke (var-deref "jolt.ir" "var-ref") "clojure.core" "with-meta")) (_a$7317 (let* ((_o$7313 node) (_o$7314 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx m env))) (jolt-vector _o$7313 _o$7314)))) (jolt-invoke _a$7315 _a$7316 _a$7317)))))))) with-coll-meta))) (guard (e (#t #f)) - (def-var! "jolt.analyzer" "analyze" (letrec ((analyze (case-lambda ((ctx form) (let fnrec7311 ((ctx ctx) (form form)) (jolt-invoke analyze ctx form (jolt-invoke (var-deref "jolt.analyzer" "empty-env"))))) ((ctx form env) (let fnrec7312 ((ctx ctx) (form form) (env env)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-literal?") form)) (jolt-invoke (var-deref "jolt.ir" "const") form) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-sym?") form)) (jolt-invoke (var-deref "jolt.analyzer" "analyze-symbol") ctx form env) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-vec?") form)) (jolt-invoke (var-deref "jolt.analyzer" "with-coll-meta") ctx form env (jolt-invoke (var-deref "jolt.ir" "vector-node") (let* ((_a$7314 (var-deref "clojure.core" "mapv")) (_a$7315 (lambda (p__93_) (let fnrec7313 ((p__93_ p__93_)) (jolt-invoke analyze ctx p__93_ env)))) (_a$7316 (jolt-invoke (var-deref "jolt.host" "form-vec-items") form))) (jolt-invoke _a$7314 _a$7315 _a$7316)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-map?") form)) (jolt-invoke (var-deref "jolt.analyzer" "with-coll-meta") ctx form env (jolt-invoke (var-deref "jolt.ir" "map-node") (let* ((_a$7320 (var-deref "clojure.core" "mapv")) (_a$7321 (lambda (p) (let fnrec7317 ((p p)) (let* ((_o$7318 (jolt-invoke analyze ctx (jolt-first p) env)) (_o$7319 (jolt-invoke analyze ctx (jolt-invoke (var-deref "clojure.core" "second") p) env))) (jolt-vector _o$7318 _o$7319))))) (_a$7322 (jolt-invoke (var-deref "jolt.host" "form-map-pairs") form))) (jolt-invoke _a$7320 _a$7321 _a$7322)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-set?") form)) (jolt-invoke (var-deref "jolt.analyzer" "with-coll-meta") ctx form env (jolt-invoke (var-deref "jolt.ir" "set-node") (let* ((_a$7324 (var-deref "clojure.core" "mapv")) (_a$7325 (lambda (p__94_) (let fnrec7323 ((p__94_ p__94_)) (jolt-invoke analyze ctx p__94_ env)))) (_a$7326 (jolt-invoke (var-deref "jolt.host" "form-set-items") form))) (jolt-invoke _a$7324 _a$7325 _a$7326)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-list?") form)) (jolt-invoke (var-deref "jolt.analyzer" "analyze-list") ctx form env) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-regex?") form)) (let* ((_o$7327 (keyword #f "op")) (_o$7328 (keyword #f "regex")) (_o$7329 (keyword #f "source")) (_o$7330 (jolt-invoke (var-deref "jolt.host" "form-regex-source") form))) (jolt-hash-map _o$7327 _o$7328 _o$7329 _o$7330)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-inst?") form)) (let* ((_o$7331 (keyword #f "op")) (_o$7332 (keyword #f "inst")) (_o$7333 (keyword #f "source")) (_o$7334 (jolt-invoke (var-deref "jolt.host" "form-inst-source") form))) (jolt-hash-map _o$7331 _o$7332 _o$7333 _o$7334)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-uuid?") form)) (let* ((_o$7335 (keyword #f "op")) (_o$7336 (keyword #f "uuid")) (_o$7337 (keyword #f "source")) (_o$7338 (jolt-invoke (var-deref "jolt.host" "form-uuid-source") form))) (jolt-hash-map _o$7335 _o$7336 _o$7337 _o$7338)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-bigdec?") form)) (let* ((_o$7339 (keyword #f "op")) (_o$7340 (keyword #f "bigdec")) (_o$7341 (keyword #f "source")) (_o$7342 (jolt-invoke (var-deref "jolt.host" "form-bigdec-source") form))) (jolt-hash-map _o$7339 _o$7340 _o$7341 _o$7342)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-ns-value?") form)) (let* ((_o$7343 (keyword #f "op")) (_o$7344 (keyword #f "the-ns")) (_o$7345 (keyword #f "name")) (_o$7346 (jolt-invoke (var-deref "jolt.host" "form-ns-value-name") form))) (jolt-hash-map _o$7343 _o$7344 _o$7345 _o$7346)) (if (jolt-truthy? (keyword #f "else")) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") "unsupported form") jolt-nil))))))))))))))))) analyze))) + (def-var! "jolt.analyzer" "analyze" (letrec ((analyze (case-lambda ((ctx form) (let fnrec7318 ((ctx ctx) (form form)) (jolt-invoke analyze ctx form (jolt-invoke (var-deref "jolt.analyzer" "empty-env"))))) ((ctx form env) (let fnrec7319 ((ctx ctx) (form form) (env env)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-literal?") form)) (jolt-invoke (var-deref "jolt.ir" "const") form) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-sym?") form)) (jolt-invoke (var-deref "jolt.analyzer" "analyze-symbol") ctx form env) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-vec?") form)) (jolt-invoke (var-deref "jolt.analyzer" "with-coll-meta") ctx form env (jolt-invoke (var-deref "jolt.ir" "vector-node") (let* ((_a$7321 (var-deref "clojure.core" "mapv")) (_a$7322 (lambda (p__94_) (let fnrec7320 ((p__94_ p__94_)) (jolt-invoke analyze ctx p__94_ env)))) (_a$7323 (jolt-invoke (var-deref "jolt.host" "form-vec-items") form))) (jolt-invoke _a$7321 _a$7322 _a$7323)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-map?") form)) (jolt-invoke (var-deref "jolt.analyzer" "with-coll-meta") ctx form env (jolt-invoke (var-deref "jolt.ir" "map-node") (let* ((_a$7327 (var-deref "clojure.core" "mapv")) (_a$7328 (lambda (p) (let fnrec7324 ((p p)) (let* ((_o$7325 (jolt-invoke analyze ctx (jolt-first p) env)) (_o$7326 (jolt-invoke analyze ctx (jolt-invoke (var-deref "clojure.core" "second") p) env))) (jolt-vector _o$7325 _o$7326))))) (_a$7329 (jolt-invoke (var-deref "jolt.host" "form-map-pairs") form))) (jolt-invoke _a$7327 _a$7328 _a$7329)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-set?") form)) (jolt-invoke (var-deref "jolt.analyzer" "with-coll-meta") ctx form env (jolt-invoke (var-deref "jolt.ir" "set-node") (let* ((_a$7331 (var-deref "clojure.core" "mapv")) (_a$7332 (lambda (p__95_) (let fnrec7330 ((p__95_ p__95_)) (jolt-invoke analyze ctx p__95_ env)))) (_a$7333 (jolt-invoke (var-deref "jolt.host" "form-set-items") form))) (jolt-invoke _a$7331 _a$7332 _a$7333)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-list?") form)) (jolt-invoke (var-deref "jolt.analyzer" "analyze-list") ctx form env) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-regex?") form)) (let* ((_o$7334 (keyword #f "op")) (_o$7335 (keyword #f "regex")) (_o$7336 (keyword #f "source")) (_o$7337 (jolt-invoke (var-deref "jolt.host" "form-regex-source") form))) (jolt-hash-map _o$7334 _o$7335 _o$7336 _o$7337)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-inst?") form)) (let* ((_o$7338 (keyword #f "op")) (_o$7339 (keyword #f "inst")) (_o$7340 (keyword #f "source")) (_o$7341 (jolt-invoke (var-deref "jolt.host" "form-inst-source") form))) (jolt-hash-map _o$7338 _o$7339 _o$7340 _o$7341)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-uuid?") form)) (let* ((_o$7342 (keyword #f "op")) (_o$7343 (keyword #f "uuid")) (_o$7344 (keyword #f "source")) (_o$7345 (jolt-invoke (var-deref "jolt.host" "form-uuid-source") form))) (jolt-hash-map _o$7342 _o$7343 _o$7344 _o$7345)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-bigdec?") form)) (let* ((_o$7346 (keyword #f "op")) (_o$7347 (keyword #f "bigdec")) (_o$7348 (keyword #f "source")) (_o$7349 (jolt-invoke (var-deref "jolt.host" "form-bigdec-source") form))) (jolt-hash-map _o$7346 _o$7347 _o$7348 _o$7349)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-ns-value?") form)) (let* ((_o$7350 (keyword #f "op")) (_o$7351 (keyword #f "the-ns")) (_o$7352 (keyword #f "name")) (_o$7353 (jolt-invoke (var-deref "jolt.host" "form-ns-value-name") form))) (jolt-hash-map _o$7350 _o$7351 _o$7352 _o$7353)) (if (jolt-truthy? (keyword #f "else")) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") "unsupported form") jolt-nil))))))))))))))))) analyze))) (guard (e (#t #f)) (def-var-with-meta! "jolt.backend-scheme" "native-ops" (let* ((_o$5919 "+") (_o$5920 "+") (_o$5921 "-") (_o$5922 "-") (_o$5923 "*") (_o$5924 "*") (_o$5925 "/") (_o$5926 "/") (_o$5927 "<") (_o$5928 "<") (_o$5929 ">") (_o$5930 ">") (_o$5931 "<=") (_o$5932 "<=") (_o$5933 ">=") (_o$5934 ">=") (_o$5935 "=") (_o$5936 "jolt=") (_o$5937 "inc") (_o$5938 "jolt-inc") (_o$5939 "dec") (_o$5940 "jolt-dec") (_o$5941 "not") (_o$5942 "jolt-not") (_o$5943 "min") (_o$5944 "min") (_o$5945 "max") (_o$5946 "max") (_o$5947 "mod") (_o$5948 "modulo") (_o$5949 "rem") (_o$5950 "remainder") (_o$5951 "quot") (_o$5952 "quotient") (_o$5953 "vector") (_o$5954 "jolt-vector") (_o$5955 "hash-map") (_o$5956 "jolt-hash-map") (_o$5957 "hash-set") (_o$5958 "jolt-hash-set") (_o$5959 "conj") (_o$5960 "jolt-conj") (_o$5961 "get") (_o$5962 "jolt-get") (_o$5963 "nth") (_o$5964 "jolt-nth") (_o$5965 "count") (_o$5966 "jolt-count") (_o$5967 "assoc") (_o$5968 "jolt-assoc") (_o$5969 "dissoc") (_o$5970 "jolt-dissoc") (_o$5971 "contains?") (_o$5972 "jolt-contains?") (_o$5973 "empty?") (_o$5974 "jolt-empty?") (_o$5975 "peek") (_o$5976 "jolt-peek") (_o$5977 "pop") (_o$5978 "jolt-pop") (_o$5979 "first") (_o$5980 "jolt-first") (_o$5981 "rest") (_o$5982 "jolt-rest") (_o$5983 "next") (_o$5984 "jolt-next") (_o$5985 "seq") (_o$5986 "jolt-seq") (_o$5987 "cons") (_o$5988 "jolt-cons") (_o$5989 "list") (_o$5990 "jolt-list") (_o$5991 "reverse") (_o$5992 "jolt-reverse") (_o$5993 "last") (_o$5994 "jolt-last") (_o$5995 "map") (_o$5996 "jolt-map") (_o$5997 "filter") (_o$5998 "jolt-filter") (_o$5999 "remove") (_o$6000 "jolt-remove") (_o$6001 "reduce") (_o$6002 "jolt-reduce") (_o$6003 "into") (_o$6004 "jolt-into") (_o$6005 "concat") (_o$6006 "jolt-concat") (_o$6007 "apply") (_o$6008 "jolt-apply") (_o$6009 "range") (_o$6010 "jolt-range") (_o$6011 "take") (_o$6012 "jolt-take") (_o$6013 "drop") (_o$6014 "jolt-drop") (_o$6015 "keys") (_o$6016 "jolt-keys") (_o$6017 "vals") (_o$6018 "jolt-vals") (_o$6019 "even?") (_o$6020 "jolt-even?") (_o$6021 "odd?") (_o$6022 "jolt-odd?") (_o$6023 "pos?") (_o$6024 "jolt-pos?") (_o$6025 "neg?") (_o$6026 "jolt-neg?") (_o$6027 "zero?") (_o$6028 "jolt-zero?") (_o$6029 "identity") (_o$6030 "jolt-identity") (_o$6031 "ex-info") (_o$6032 "jolt-ex-info")) (jolt-hash-map _o$5919 _o$5920 _o$5921 _o$5922 _o$5923 _o$5924 _o$5925 _o$5926 _o$5927 _o$5928 _o$5929 _o$5930 _o$5931 _o$5932 _o$5933 _o$5934 _o$5935 _o$5936 _o$5937 _o$5938 _o$5939 _o$5940 _o$5941 _o$5942 _o$5943 _o$5944 _o$5945 _o$5946 _o$5947 _o$5948 _o$5949 _o$5950 _o$5951 _o$5952 _o$5953 _o$5954 _o$5955 _o$5956 _o$5957 _o$5958 _o$5959 _o$5960 _o$5961 _o$5962 _o$5963 _o$5964 _o$5965 _o$5966 _o$5967 _o$5968 _o$5969 _o$5970 _o$5971 _o$5972 _o$5973 _o$5974 _o$5975 _o$5976 _o$5977 _o$5978 _o$5979 _o$5980 _o$5981 _o$5982 _o$5983 _o$5984 _o$5985 _o$5986 _o$5987 _o$5988 _o$5989 _o$5990 _o$5991 _o$5992 _o$5993 _o$5994 _o$5995 _o$5996 _o$5997 _o$5998 _o$5999 _o$6000 _o$6001 _o$6002 _o$6003 _o$6004 _o$6005 _o$6006 _o$6007 _o$6008 _o$6009 _o$6010 _o$6011 _o$6012 _o$6013 _o$6014 _o$6015 _o$6016 _o$6017 _o$6018 _o$6019 _o$6020 _o$6021 _o$6022 _o$6023 _o$6024 _o$6025 _o$6026 _o$6027 _o$6028 _o$6029 _o$6030 _o$6031 _o$6032)) (jolt-hash-map (keyword #f "private") #t))) (guard (e (#t #f)) diff --git a/jolt-core/jolt/analyzer.clj b/jolt-core/jolt/analyzer.clj index d16ca55..771fc4e 100644 --- a/jolt-core/jolt/analyzer.clj +++ b/jolt-core/jolt/analyzer.clj @@ -478,12 +478,23 @@ (defn- analyze-dot [ctx items env] (when (< (count items) 3) (throw (str "Malformed (. target member ...) form"))) - (let [member (nth items 2)] + (let [target (nth items 1) + member (nth items 2) + ;; (. Class method args*) with a class target is a static call — + ;; equivalent to (Class/method args*). resolve-global tags a class + ;; symbol :kind :class; a local of the same name shadows it. + class-target (when (and (form-sym? target) + (not (local? env (form-sym-name target)))) + (let [r (resolve-global ctx target)] + (when (= :class (:kind r)) (:name r))))] (cond + (and class-target (form-sym? member)) + (invoke (host-static class-target (form-sym-name member)) + (mapv #(analyze ctx % env) (drop 3 items))) (form-sym? member) {:op :host-call :method (form-sym-name member) - :target (analyze ctx (nth items 1) env) + :target (analyze ctx target env) :args (mapv #(analyze ctx % env) (drop 3 items))} ;; (. obj :kw) is a keyword lookup — invoke the keyword on the target. (form-keyword? member) diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index fe15c27..f48333a 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -3011,4 +3011,16 @@ {:suite "interop / java.time" :label "LocalDateTime toString" :expected "\"2020-01-15T10:30\"" :actual "(str (java.time.LocalDateTime/of 2020 1 15 10 30 0))"} {:suite "interop / java.time" :label "Instant ofEpochMilli toString" :expected "\"2020-01-15T10:30:00Z\"" :actual "(str (java.time.Instant/ofEpochMilli 1579084200000))"} {:suite "interop / java.time" :label "Instant ofEpochMilli round-trip" :expected "1579084200000" :actual "(.toEpochMilli (java.time.Instant/ofEpochMilli 1579084200000))"} + {:suite "interop / java.time" :label "Duration ofSeconds toString" :expected "\"PT1M30S\"" :actual "(str (java.time.Duration/ofSeconds 90))"} + {:suite "interop / java.time" :label "Duration between instants" :expected "\"PT1H1M1S\"" :actual "(str (java.time.Duration/between (java.time.Instant/ofEpochSecond 0) (java.time.Instant/ofEpochSecond 3661)))"} + {:suite "interop / java.time" :label "Period between dates" :expected "\"P1Y2M2D\"" :actual "(str (java.time.Period/between (java.time.LocalDate/of 2020 1 1) (java.time.LocalDate/of 2021 3 3)))"} + {:suite "interop / java.time" :label "Period parse round-trip" :expected "\"P1Y2M3D\"" :actual "(str (java.time.Period/parse \"P1Y2M3D\"))"} + {:suite "interop / java.time" :label "Period normalized" :expected "\"P2Y1M5D\"" :actual "(str (.normalized (java.time.Period/of 1 13 5)))"} + {:suite "interop / java.time" :label "Month of toString" :expected "\"FEBRUARY\"" :actual "(.toString (java.time.Month/of 2))"} + {:suite "interop / java.time" :label "Month length leap" :expected "29" :actual "(.length (java.time.Month/of 2) true)"} + {:suite "interop / java.time" :label "DayOfWeek constant prints name" :expected "\"MONDAY\"" :actual "(str java.time.DayOfWeek/MONDAY)"} + {:suite "interop / java.time" :label "YearMonth toString" :expected "\"2020-02\"" :actual "(str (java.time.YearMonth/of 2020 2))"} + {:suite "interop / java.time" :label "ChronoUnit DAYS between" :expected "14" :actual "(.between java.time.temporal.ChronoUnit/DAYS (java.time.LocalDate/of 2020 1 1) (java.time.LocalDate/of 2020 1 15))"} + {:suite "interop / java.time" :label "LocalDate plus ChronoUnit DAYS" :expected "\"2020-01-04\"" :actual "(str (.plus (java.time.LocalDate/of 2020 1 1) 3 java.time.temporal.ChronoUnit/DAYS))"} + {:suite "interop / java.time" :label "LocalDate until ChronoUnit DAYS" :expected "31" :actual "(.until (java.time.LocalDate/of 2020 1 1) (java.time.LocalDate/of 2020 2 1) java.time.temporal.ChronoUnit/DAYS)"} ] From a05eeefb0825e6a7d512a18d7e933809a3f48582 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Wed, 24 Jun 2026 18:45:46 -0400 Subject: [PATCH 3/3] =?UTF-8?q?java.time=20Phase=203:=20zones,=20offsets,?= =?UTF-8?q?=20ZonedDateTime,=20formatters=20=E2=80=94=20tick=20runs?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ZoneOffset/ZoneId (SHORT_IDS, fixed-offset + UTC + system; named zones via a fixed-offset table), ZonedDateTime/OffsetDateTime/OffsetTime, Clock (fixed/ system, with now [clock] arity), and DateTimeFormatter integration (ofPattern + ISO_* constants, .format/.parse over the rich java.time values via the inst-time.ss pattern engine). systemDefault resolves to UTC to keep the #inst atZone/toInstant round-trip machine-tz-independent. tick.core + tick.protocols + tick.locale-en-us load; tick's api_test runs 31 tests / 352 pass / 7 fail / 0 error. The 7 are host gaps: named-zone DST (no tzdb), French locale month names (no locale DB), nanosecond Instant. General fixes surfaced by tick: :ns/keys map destructuring ({:tick/keys [..]}) in 00-syntax.clj (re-minted), and extend-protocol to java.time classes (records.ss host-type-set). 12 corpus rows certified vs JVM. make test + shakesmoke green, selfhost holds, 0 new divergences, data.json stays 138/139. --- host/chez/inst-time.ss | 54 +- host/chez/java-time.ss | 848 ++++++++++++++++++++++++++- host/chez/records.ss | 13 +- host/chez/seed/prelude.ss | 2 +- jolt-core/clojure/core/00-syntax.clj | 28 +- test/chez/corpus.edn | 12 + 6 files changed, 922 insertions(+), 35 deletions(-) diff --git a/host/chez/inst-time.ss b/host/chez/inst-time.ss index 701b30f..37bfd2a 100644 --- a/host/chez/inst-time.ss +++ b/host/chez/inst-time.ss @@ -45,11 +45,23 @@ (and (digit? (string-ref s j)) (loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref s j)) 48)))))))) -(define (jolt-inst-from-string ts) +(define (jolt-inst-from-string ts0) + ;; a leading '-' marks a negative (proleptic) year; the rest of the field may be + ;; more than 4 digits (java.time prints -999999999-…). Read the year up to the + ;; first '-' that separates it from the month. + (define neg-year (and (> (string-length ts0) 0) (char=? (string-ref ts0 0) #\-))) + (define ts (if neg-year (substring ts0 1 (string-length ts0)) ts0)) (define len (string-length ts)) - (define (fail) (error #f (string-append "Unrecognized #inst timestamp: " ts))) - (let* ((year (or (digits-at ts 0 4) (fail))) - (i 4) (month 1) (day 1) (hh 0) (mm 0) (ss 0) (frac-ms 0) (off-s 0)) + (define (fail) (error #f (string-append "Unrecognized #inst timestamp: " ts0))) + (define (read-year) + ;; >=4 digits up to a non-digit; java.time uses min-4 but allows more. + (let loop ((j 0) (acc 0) (n 0)) + (if (and (< j len) (digit? (string-ref ts j))) + (loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref ts j)) 48)) (+ n 1)) + (if (>= n 4) (cons acc j) #f)))) + (let* ((yr (or (read-year) (fail))) + (year (if neg-year (- (car yr)) (car yr))) + (i (cdr yr)) (month 1) (day 1) (hh 0) (mm 0) (ss 0) (frac-ms 0) (off-s 0)) ;; -MM (when (and (< i len) (char=? (string-ref ts i) #\-) (digits-at ts (+ i 1) 2)) (set! month (digits-at ts (+ i 1) 2)) (set! i (+ i 3))) @@ -170,11 +182,14 @@ (y 1970) (mo 1) (d 1) (hh 0) (mi 0) (ss 0) (pm 'none)) (define (pfail) (error #f (string-append "ParseException: unparseable date \"" input "\""))) (define (run-len i c) (let loop ((j i)) (if (and (< j pn) (char=? (string-ref pattern j) c)) (loop (+ j 1)) (- j i)))) - (define (read-digits ii) ; -> (val . next), pfail if none - (let loop ((j ii) (acc 0) (any #f)) - (if (and (< j inn) (digit? (string-ref input j))) - (loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref input j)) 48)) #t) + ;; read up to `maxw` digits (#f = unbounded). A fixed-width field (k>=2, e.g. + ;; HHmm) caps the read at its run length so adjacent numeric fields split. + (define (read-digits-w ii maxw) ; -> (val . next), pfail if none + (let loop ((j ii) (acc 0) (n 0) (any #f)) + (if (and (< j inn) (digit? (string-ref input j)) (or (not maxw) (< n maxw))) + (loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref input j)) 48)) (+ n 1) #t) (if any (cons acc j) (pfail))))) + (define (read-digits ii) (read-digits-w ii #f)) (define (read-alpha ii) ; -> (str . next) (let loop ((j ii)) (if (and (< j inn) (char-alphabetic? (string-ref input j))) (loop (+ j 1)) (cons (substring input ii j) j)))) @@ -195,23 +210,23 @@ ((char-alphabetic? c) (let ((k (run-len pi c))) (cond - ((char=? c #\y) (let ((r (read-digits ii))) + ((char=? c #\y) (let ((r (read-digits-w ii (if (>= k 3) #f k)))) ;; 2-digit year (value < 100): JVM sliding window — 00-68 -> 20xx, ;; 69-99 -> 19xx (rfc1036 HTTP dates). A full year stays as-is. - (set! y (let ((v (car r))) (if (< v 100) (if (< v 69) (+ 2000 v) (+ 1900 v)) v))) + (set! y (let ((v (car r))) (if (and (= k 2) (< v 100)) (if (< v 69) (+ 2000 v) (+ 1900 v)) v))) (loop (+ pi k) (cdr r)))) ((char=? c #\M) (if (>= k 3) (let ((r (read-alpha ii))) (set! mo (or (month-from-name (car r)) (pfail))) (loop (+ pi k) (cdr r))) - (let ((r (read-digits ii))) (set! mo (car r)) (loop (+ pi k) (cdr r))))) - ((char=? c #\d) (let ((r (read-digits ii))) (set! d (car r)) (loop (+ pi k) (cdr r)))) - ((or (char=? c #\H) (char=? c #\h)) (let ((r (read-digits ii))) (set! hh (car r)) (loop (+ pi k) (cdr r)))) - ((char=? c #\m) (let ((r (read-digits ii))) (set! mi (car r)) (loop (+ pi k) (cdr r)))) - ((char=? c #\s) (let ((r (read-digits ii))) (set! ss (car r)) (loop (+ pi k) (cdr r)))) + (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! mo (car r)) (loop (+ pi k) (cdr r))))) + ((char=? c #\d) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! d (car r)) (loop (+ pi k) (cdr r)))) + ((or (char=? c #\H) (char=? c #\h)) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! hh (car r)) (loop (+ pi k) (cdr r)))) + ((char=? c #\m) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! mi (car r)) (loop (+ pi k) (cdr r)))) + ((char=? c #\s) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! ss (car r)) (loop (+ pi k) (cdr r)))) ((char=? c #\E) (loop (+ pi k) (cdr (read-alpha ii)))) ((char=? c #\a) (let ((r (read-alpha ii))) (set! pm (if (string=? (ascii-string-down (car r)) "pm") 'pm 'am)) (loop (+ pi k) (cdr r)))) - ((or (char=? c #\z) (char=? c #\Z) (char=? c #\X)) (loop (+ pi k) (read-tz ii))) + ((or (char=? c #\z) (char=? c #\Z) (char=? c #\X) (char=? c #\x) (char=? c #\V) (char=? c #\v)) (loop (+ pi k) (read-tz ii))) (else (loop (+ pi k) ii))))) ((char=? c #\') (if (and (< (+ pi 1) pn) (char=? (string-ref pattern (+ pi 1)) #\')) @@ -393,6 +408,9 @@ (list (cons "getDefault" (lambda () (make-jhost "locale" (vector "default")))) (cons "ENGLISH" (make-jhost "locale" (vector "en"))) (cons "US" (make-jhost "locale" (vector "en-US"))) + (cons "FRENCH" (make-jhost "locale" (vector "fr"))) + (cons "FRANCE" (make-jhost "locale" (vector "fr-FR"))) + (cons "GERMAN" (make-jhost "locale" (vector "de"))) (cons "ROOT" (make-jhost "locale" (vector "root"))))) ;; java.util.Date / java.sql.Timestamp: #inst's classes. (Date.) = now, (Date. ms) @@ -404,6 +422,10 @@ (register-class-ctor! "java.util.Date" date-ctor) (register-class-ctor! "Timestamp" date-ctor) (register-class-ctor! "java.sql.Timestamp" date-ctor) +;; Date/from(Instant) -> a java.util.Date at the instant's epoch-ms. +(let ((date-statics (list (cons "from" (lambda (inst) (make-jinst (ms->exact (ms-of inst)))))))) + (register-class-statics! "Date" date-statics) + (register-class-statics! "java.util.Date" date-statics)) ;; java.sql.Date: a distinct class from java.util.Date (a "sql-date" jhost over ;; epoch-ms) so a protocol extended to both routes a sql.Date to its own impl. ;; (Date. year-1900 month0 day) builds UTC midnight of that civil date; valueOf diff --git a/host/chez/java-time.ss b/host/chez/java-time.ss index b5ae1b1..f57f694 100644 --- a/host/chez/java-time.ss +++ b/host/chez/java-time.ss @@ -395,8 +395,8 @@ (cons "compareTo" (lambda (x o) (ldt-cmp x o))) (cons "equals" (lambda (x o) (and (jhost? o) (string=? (jhost-tag o) "local-date-time") (ldt=? x o)))) (cons "hashCode" (lambda (x) (+ (* (ldt-epoch-day x) 31) (ldt-nano-of-day x)))) - (cons "atZone" (lambda (x zone) (mk-zoned (ldt->ms x)))) - (cons "atOffset" (lambda (x off) (mk-zoned (ldt->ms x)))) + (cons "atZone" (lambda (x zone) (zoned-of-ldt x zone))) + (cons "atOffset" (lambda (x off) (offset-of-ldt x off))) (cons "toInstant" (lambda (x . _) (mk-instant (ldt->ms x)))) (cons "toString" (lambda (x) (iso-datetime-str (ldt-epoch-day x) (ldt-nano-of-day x)))))) @@ -449,7 +449,8 @@ ((and unit (string-ci=? unit "MINUTES")) 60000) ((and unit (string-ci=? unit "SECONDS")) 1000) (else 1))))))) - (cons "atOffset" (lambda (x off) (mk-zoned (inst-ms x)))) + (cons "atOffset" (lambda (x off) (offset-of-instant-ms (inst-ms x) off))) + (cons "atZone" (lambda (x zone) (zoned-of-instant-ms (inst-ms x) zone))) (cons "toString" (lambda (x) (iso-instant-str (inst-ms x)))))) ;; --- Month / DayOfWeek enums (returned by getMonth / getDayOfWeek) ----------- @@ -600,7 +601,9 @@ (cons "toDays" (lambda (d) (quotient (dur-secs d) 86400))) (cons "toHours" (lambda (d) (quotient (dur-secs d) 3600))) (cons "toMinutes" (lambda (d) (quotient (dur-secs d) 60))) - (cons "toMillis" (lambda (d) (+ (* (dur-secs d) 1000) (quotient (dur-nanos d) 1000000)))) + ;; toMillis/toSeconds truncate the TOTAL toward zero (JVM rounds the whole + ;; value, not per-field): -1001 micros -> -1 ms, not -2. + (cons "toMillis" (lambda (d) (quotient (dur-total-nanos d) 1000000))) (cons "toNanos" (lambda (d) (dur-total-nanos d))) (cons "plus" (lambda (d o) (cond ((and (jhost? o) (string=? (jhost-tag o) "duration")) (dur-plus d o)) (else (error #f "Duration.plus: expected Duration"))))) @@ -632,6 +635,12 @@ ;; TemporalAmount: addTo/subtractFrom apply this duration to a temporal. (cons "addTo" (lambda (d t) (temporal-plus-nanos t (dur-total-nanos d)))) (cons "subtractFrom" (lambda (d t) (temporal-plus-nanos t (- (dur-total-nanos d))))) + ;; TemporalAmount: a Duration is measured in SECONDS + NANOS. + (cons "getUnits" (lambda (d) (make-pvec (vector (jt-chrono-unit "SECONDS") (jt-chrono-unit "NANOS"))))) + (cons "get" (lambda (d u) (let ((nm (string-upcase (arg-unit-name u)))) + (cond ((string=? nm "SECONDS") (dur-secs d)) + ((string=? nm "NANOS") (dur-nanos d)) + (else (error #f (string-append "Duration has no unit " nm))))))) (cons "toString" (lambda (d) (dur->string d))))) ;; "PT…" parse: PnDTnHnMn.nS (we accept the time part; days fold into hours). @@ -749,6 +758,13 @@ ;; TemporalAmount: a Period adds its y/m/d to a date-bearing temporal. (cons "addTo" (lambda (p t) (temporal-plus-period t p 1))) (cons "subtractFrom" (lambda (p t) (temporal-plus-period t p -1))) + ;; TemporalAmount: a Period is measured in YEARS + MONTHS + DAYS. + (cons "getUnits" (lambda (p) (make-pvec (vector (jt-chrono-unit "YEARS") (jt-chrono-unit "MONTHS") (jt-chrono-unit "DAYS"))))) + (cons "get" (lambda (p u) (let ((nm (string-upcase (arg-unit-name u)))) + (cond ((string=? nm "YEARS") (per-years p)) + ((string=? nm "MONTHS") (per-months p)) + ((string=? nm "DAYS") (per-days p)) + (else (error #f (string-append "Period has no unit " nm))))))) (cons "toString" (lambda (p) (per->string p))))) ;; "PnYnMnWnD" -> a Period (weeks fold into days). (define (parse-iso-period s) @@ -827,9 +843,13 @@ (list (cons "of" (lambda (y m) (jt-year-month (jt->exact y) (jt->exact m)))) (cons "now" (lambda _ (call-with-values (lambda () (epoch-day->ymd (jt-floor-div (exact (truncate (now-ms))) 86400000))) (lambda (y m d) (jt-year-month y m))))) - (cons "parse" (lambda (s . _) (let ((str (jt-str s))) - (jt-year-month (or (digits-at str 0 4) (error #f "could not parse YearMonth")) - (or (digits-at str 5 2) (error #f "could not parse YearMonth")))))) + (cons "parse" (lambda (s . fmt) + (if (null? fmt) + (let ((str (jt-str s))) + (jt-year-month (or (digits-at str 0 4) (error #f "could not parse YearMonth")) + (or (digits-at str 5 2) (error #f "could not parse YearMonth")))) + (call-with-values (lambda () (formatter-parse-fields (car fmt) s)) + (lambda (ed nod) (call-with-values (lambda () (epoch-day->ymd ed)) (lambda (y m d) (jt-year-month y m)))))))) (cons "from" (lambda (t) (ym-from-temporal t))))) (register-host-methods! "year-month" (list (cons "getYear" (lambda (x) (ym-year x))) @@ -1130,7 +1150,9 @@ (cons "until" (lambda (t o u) (unit-between (arg-unit-name u) t o))) (cons "get" (lambda (t f) (temporal-get-field t (arg-field-name f)))) (cons "getLong" (lambda (t f) (temporal-get-field t (arg-field-name f)))) - (cons "with" (lambda (t f v) (temporal-with-field t (arg-field-name f) (jt->exact v)))) + (cons "with" (case-lambda + ((t adj) (apply-adjuster t adj)) ; (.with t adjuster) + ((t f v) (temporal-with-field t (arg-field-name f) (jt->exact v))))) (cons "isSupported" (lambda (t x) (cond ((arg-is-unit? x) (temporal-supports-unit? t (cu-name x))) ((arg-is-field? x) (temporal-supports-field? t (cf-name x))) (else #f)))) @@ -1140,6 +1162,64 @@ (register-host-methods! "local-date-time" (mk-temporal-methods)) (register-host-methods! "instant" (mk-temporal-methods)) +;; --- TemporalAdjuster: a date->date transform applied via (.with t adjuster) -- +;; Stored as a jhost over a procedure that takes/returns a LocalDate; for a +;; LocalDateTime the date part is adjusted and the time kept. +(define (jt-adjuster proc) (make-jhost "temporal-adjuster" (vector proc))) +(define (adjuster-proc a) (vector-ref (jhost-state a) 0)) +(define (apply-adjuster t adj) + (let ((proc (cond ((and (jhost? adj) (string=? (jhost-tag adj) "temporal-adjuster")) (adjuster-proc adj)) + ((procedure? adj) adj) + (else (error #f "with: expected a TemporalAdjuster"))))) + (cond ((jt-date? t) (proc t)) + ((jt-dt? t) (ldt-combine (proc (ldt-date t)) (ldt-time t))) + (else (proc t))))) +;; the next/previous day-of-week adjusters (dow target 1=Mon..7=Sun). +(define (adj-next-dow d target same?) + (let* ((cur (ld-dow (ld-epoch-day d))) + (delta (jt-floor-mod (- target cur) 7)) + (step (if (and same? (= delta 0)) 0 (if (= delta 0) 7 delta)))) + (jt-local-date (+ (ld-epoch-day d) step)))) +(define (adj-prev-dow d target same?) + (let* ((cur (ld-dow (ld-epoch-day d))) + (delta (jt-floor-mod (- cur target) 7)) + (step (if (and same? (= delta 0)) 0 (if (= delta 0) 7 delta)))) + (jt-local-date (- (ld-epoch-day d) step)))) +(define (dow-target dow) (cond ((and (jhost? dow) (string=? (jhost-tag dow) "dow-enum")) (dow-val dow)) + (else (jt->exact dow)))) +(define (adj-first-day-of-month d) + (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) (jt-local-date (ymd->epoch-day y m 1))))) +(define (adj-last-day-of-month d) + (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) (jt-local-date (ymd->epoch-day y m (jt-len-of-month y m)))))) +(define (adj-day-of-week-in-month d ordinal target) + ;; the ordinal-th (1-based) `target` weekday in d's month (negative counts from end). + (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) + (lambda (y m dd) + (if (>= ordinal 0) + (let* ((first (jt-local-date (ymd->epoch-day y m 1))) + (first-match (adj-next-dow first target #t))) + (jt-local-date (+ (ld-epoch-day first-match) (* 7 (- (max 1 ordinal) 1))))) + (let* ((last (adj-last-day-of-month d)) + (last-match (adj-prev-dow last target #t))) + (jt-local-date (- (ld-epoch-day last-match) (* 7 (- (- ordinal) 1))))))))) +(register-class-statics! "TemporalAdjusters" + (list (cons "firstDayOfMonth" (lambda () (jt-adjuster adj-first-day-of-month))) + (cons "lastDayOfMonth" (lambda () (jt-adjuster adj-last-day-of-month))) + (cons "firstDayOfNextMonth" (lambda () (jt-adjuster (lambda (d) (jt-local-date (+ (ld-epoch-day (adj-last-day-of-month d)) 1)))))) + (cons "firstDayOfYear" (lambda () (jt-adjuster (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) (jt-local-date (ymd->epoch-day y 1 1)))))))) + (cons "lastDayOfYear" (lambda () (jt-adjuster (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) (jt-local-date (ymd->epoch-day y 12 31)))))))) + (cons "firstDayOfNextYear" (lambda () (jt-adjuster (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) (jt-local-date (ymd->epoch-day (+ y 1) 1 1)))))))) + (cons "dayOfWeekInMonth" (lambda (ordinal dow) (jt-adjuster (lambda (d) (adj-day-of-week-in-month d (jt->exact ordinal) (dow-target dow)))))) + (cons "firstInMonth" (lambda (dow) (jt-adjuster (lambda (d) (adj-day-of-week-in-month d 1 (dow-target dow)))))) + (cons "lastInMonth" (lambda (dow) (jt-adjuster (lambda (d) (adj-day-of-week-in-month d -1 (dow-target dow)))))) + (cons "next" (lambda (dow) (jt-adjuster (lambda (d) (adj-next-dow d (dow-target dow) #f))))) + (cons "nextOrSame" (lambda (dow) (jt-adjuster (lambda (d) (adj-next-dow d (dow-target dow) #t))))) + (cons "previous" (lambda (dow) (jt-adjuster (lambda (d) (adj-prev-dow d (dow-target dow) #f))))) + (cons "previousOrSame" (lambda (dow) (jt-adjuster (lambda (d) (adj-prev-dow d (dow-target dow) #t))))) + (cons "ofDateAdjuster" (lambda (f) (jt-adjuster (lambda (d) (jolt-invoke f d))))))) +(register-host-methods! "temporal-adjuster" + (list (cons "adjustInto" (lambda (a t) (apply-adjuster t a))))) + ;; range(field): a ValueRange. A small set of common fields; others fall back to a ;; generous range so callers that only read min/max don't crash. (define (temporal-range t field) @@ -1238,3 +1318,755 @@ ((jt-tagged-as? val "chrono-unit") (if (member tn '("ChronoUnit" "TemporalUnit")) #t 'pass)) ((jt-tagged-as? val "chrono-field") (if (member tn '("ChronoField" "TemporalField")) #t 'pass)) (else 'pass))))) + +;; ==================================================================== +;; Phase 3: zones, offset/zoned date-times, clocks, formatter integration. +;; ==================================================================== +;; +;; Chez exposes local + UTC + fixed offsets, not an IANA tz database. Fixed-offset +;; and UTC zones are exact. A named zone (America/New_York) maps to a representative +;; fixed offset from a small table; arbitrary-instant DST transitions are NOT modeled. +;; +;; zone-offset (vector total-seconds) +;; zone-id (vector id offset-seconds) offset-seconds: resolved fixed offset +;; offset-time (vector nano-of-day offset-seconds) +;; offset-date-time (vector epoch-day nano-of-day offset-seconds) +;; zoned-date-time (vector epoch-day nano-of-day offset-seconds zone-id) +;; clock (vector kind fixed-ms zone-id [base-clock]) kind: 'system | 'fixed | 'offset | 'tick + +;; --- ZoneOffset -------------------------------------------------------------- +(define (jt-zone-offset secs) (make-jhost "zone-offset" (vector secs))) +(define (zo-secs z) (vector-ref (jhost-state z) 0)) +(define (jt-zone-offset? x) (and (jhost? x) (string=? (jhost-tag x) "zone-offset"))) +;; ZoneOffset id: "Z" for 0, else ±HH:mm[:ss] with the seconds field elided at :00. +(define (zo-id secs) + (if (= secs 0) "Z" + (let* ((neg (< secs 0)) (a (abs secs)) + (h (quotient a 3600)) (m (quotient (modulo a 3600) 60)) (s (modulo a 60))) + (string-append (if neg "-" "+") (pad2 h) ":" (pad2 m) + (if (= s 0) "" (string-append ":" (pad2 s))))))) +;; parse a ZoneOffset id: "Z"/"+00:00" -> 0, "+HH:mm[:ss]" / "+HHmm" / "+HH". +(define (parse-zone-offset s) + (let ((str (jt-str s))) + (cond + ((or (string=? str "Z") (string=? str "z") (string=? str "UTC") (string=? str "GMT") (string=? str "+00:00")) 0) + (else + (let* ((sign (cond ((char=? (string-ref str 0) #\-) -1) (else 1))) + (body (if (memv (string-ref str 0) '(#\+ #\-)) (substring str 1 (string-length str)) str)) + (parts (let loop ((i 0) (cur '()) (acc '())) + (cond ((>= i (string-length body)) + (reverse (cons (list->string (reverse cur)) acc))) + ((char=? (string-ref body i) #\:) (loop (+ i 1) '() (cons (list->string (reverse cur)) acc))) + (else (loop (+ i 1) (cons (string-ref body i) cur) acc)))))) + (if (and (= (length parts) 1) (> (string-length (car parts)) 2)) + ;; "+HHmm" / "+HHmmss" compact form + (let ((b (car parts))) + (* sign (+ (* (or (string->number (substring b 0 2)) 0) 3600) + (* (if (>= (string-length b) 4) (or (string->number (substring b 2 4)) 0) 0) 60) + (if (>= (string-length b) 6) (or (string->number (substring b 4 6)) 0) 0)))) + (* sign (+ (* (or (string->number (list-ref parts 0)) 0) 3600) + (* (if (> (length parts) 1) (or (string->number (list-ref parts 1)) 0) 0) 60) + (if (> (length parts) 2) (or (string->number (list-ref parts 2)) 0) 0))))))))) + +(register-class-statics! "ZoneOffset" + (list (cons "of" (lambda (s) (jt-zone-offset (parse-zone-offset s)))) + (cons "ofTotalSeconds" (lambda (n) (jt-zone-offset (jt->exact n)))) + (cons "ofHours" (lambda (h) (jt-zone-offset (* (jt->exact h) 3600)))) + ;; java.time requires h/m/s to share a sign; the total is the plain sum. + (cons "ofHoursMinutes" (lambda (h m) (jt-zone-offset (+ (* (jt->exact h) 3600) (* (jt->exact m) 60))))) + (cons "ofHoursMinutesSeconds" (lambda (h m s) (jt-zone-offset (+ (* (jt->exact h) 3600) (* (jt->exact m) 60) (jt->exact s))))) + (cons "from" (lambda (t) (cond ((jt-zone-offset? t) t) + ((jt-offset-dt? t) (jt-zone-offset (odt-offset t))) + ((jt-zoned-dt? t) (jt-zone-offset (zdt-offset t))) + (else (error #f "ZoneOffset/from: unsupported"))))) + (cons "UTC" (jt-zone-offset 0)) + (cons "MIN" (jt-zone-offset (* -18 3600))) + (cons "MAX" (jt-zone-offset (* 18 3600))))) +(register-host-methods! "zone-offset" + (list (cons "getId" (lambda (z) (zo-id (zo-secs z)))) + (cons "getTotalSeconds" (lambda (z) (zo-secs z))) + (cons "getRules" (lambda (z) (make-jhost "zone-rules" (vector (zo-secs z))))) + (cons "normalized" (lambda (z) z)) + (cons "compareTo" (lambda (z o) (let ((a (zo-secs z)) (b (zo-secs o))) (cond ((< a b) -1) ((> a b) 1) (else 0))))) + (cons "equals" (lambda (z o) (and (jt-zone-offset? o) (= (zo-secs z) (zo-secs o))))) + (cons "hashCode" (lambda (z) (zo-secs z))) + (cons "toString" (lambda (z) (zo-id (zo-secs z)))))) + +;; --- ZoneId ------------------------------------------------------------------ +;; Named-zone offsets the corpus/tick set the JVM tz to. A fixed best-effort offset; +;; arbitrary-instant DST is not modeled. +(define zone-offset-table + '(("UTC" . 0) ("GMT" . 0) ("Z" . 0) ("Etc/UTC" . 0) ("Etc/GMT" . 0) + ("America/New_York" . -18000) ("America/Chicago" . -21600) ("America/Denver" . -25200) + ("America/Los_Angeles" . -28800) ("America/Toronto" . -18000) ("America/Sao_Paulo" . -10800) + ("Europe/London" . 0) ("Europe/Paris" . 3600) ("Europe/Berlin" . 3600) ("Europe/Madrid" . 3600) + ("Europe/Moscow" . 10800) ("Asia/Tokyo" . 32400) ("Asia/Shanghai" . 28800) + ("Asia/Kolkata" . 19800) ("Australia/Sydney" . 36000) ("Pacific/Auckland" . 43200))) +;; java.time ZoneId.SHORT_IDS: 3-letter ids -> region/offset ids. +(define short-ids-pairs + '(("ACT" . "Australia/Darwin") ("AET" . "Australia/Sydney") ("AGT" . "America/Argentina/Buenos_Aires") + ("ART" . "Africa/Cairo") ("AST" . "America/Anchorage") ("BET" . "America/Sao_Paulo") + ("BST" . "Asia/Dhaka") ("CAT" . "Africa/Harare") ("CNT" . "America/St_Johns") + ("CST" . "America/Chicago") ("CTT" . "Asia/Shanghai") ("EAT" . "Africa/Addis_Ababa") + ("ECT" . "Europe/Paris") ("IET" . "America/Indiana/Indianapolis") ("IST" . "Asia/Kolkata") + ("JST" . "Asia/Tokyo") ("MIT" . "Pacific/Apia") ("NET" . "Asia/Yerevan") + ("NST" . "Pacific/Auckland") ("PLT" . "Asia/Karachi") ("PNT" . "America/Phoenix") + ("PRT" . "America/Puerto_Rico") ("PST" . "America/Los_Angeles") ("SST" . "Pacific/Guadalcanal") + ("VST" . "Asia/Ho_Chi_Minh") ("EST" . "-05:00") ("MST" . "-07:00") ("HST" . "-10:00"))) +(define (jt-zone-id id off) (make-jhost "zone-id" (vector id off))) +(define (zid-id z) (vector-ref (jhost-state z) 0)) +(define (zid-off z) (vector-ref (jhost-state z) 1)) +(define (jt-zone-id? x) (and (jhost? x) (string=? (jhost-tag x) "zone-id"))) +;; system zone offset. The inst/SimpleDateFormat layer is UTC-centric (tz-free, +;; machine-independent by design), so systemDefault resolves to UTC: a LocalDateTime +;; round-tripped through atZone/toInstant stays aligned with the UTC #inst model. +;; (Chez's real machine offset is available via date-zone-offset, but using it would +;; make results machine-tz-dependent and break that round-trip.) +(define (system-zone-offset-secs) 0) +;; resolve any zone designator (string / ZoneId / ZoneOffset) to a (id . offset). +(define (resolve-zone z) + (cond + ((jt-zone-offset? z) (cons (zo-id (zo-secs z)) (zo-secs z))) + ((jt-zone-id? z) (cons (zid-id z) (zid-off z))) + (else + (let ((id (jt-str z))) + (cond + ((string=? id "system") (cons (zo-id (system-zone-offset-secs)) (system-zone-offset-secs))) + ((or (string=? id "Z") (string=? id "UTC") (string=? id "GMT")) (cons "Z" 0)) + ((and (> (string-length id) 0) (memv (string-ref id 0) '(#\+ #\-))) + (let ((s (parse-zone-offset id))) (cons (zo-id s) s))) + ((assoc id zone-offset-table) (cons id (cdr (assoc id zone-offset-table)))) + (else (cons id 0))))))) ; unknown named zone: treat as UTC, id preserved +(define (zone-id-of z) + (let ((r (resolve-zone z))) (jt-zone-id (car r) (cdr r)))) + +(register-class-statics! "ZoneId" + (list (cons "of" (lambda (id . _) (zone-id-of id))) + (cons "systemDefault" (lambda () (let ((s (system-zone-offset-secs))) (jt-zone-id (zo-id s) s)))) + (cons "getAvailableZoneIds" (lambda () (fold-left pset-conj empty-pset (map car zone-offset-table)))) + (cons "SHORT_IDS" (apply jolt-hash-map (apply append (map (lambda (p) (list (car p) (cdr p))) short-ids-pairs)))) + (cons "from" (lambda (t) (cond ((jt-zone-id? t) t) ((jt-zone-offset? t) (jt-zone-id (zo-id (zo-secs t)) (zo-secs t))) + ((jt-zoned-dt? t) (zdt-zone t)) (else (error #f "ZoneId/from: unsupported"))))))) +(register-host-methods! "zone-id" + (list (cons "getId" (lambda (z) (zid-id z))) + (cons "getRules" (lambda (z) (make-jhost "zone-rules" (vector (zid-off z))))) + (cons "normalized" (lambda (z) (if (and (> (string-length (zid-id z)) 0) (memv (string-ref (zid-id z) 0) '(#\+ #\- #\Z))) + (jt-zone-offset (zid-off z)) z))) + (cons "getDisplayName" (lambda (z . _) (zid-id z))) + (cons "equals" (lambda (z o) (and (jt-zone-id? o) (string=? (zid-id z) (zid-id o))))) + (cons "hashCode" (lambda (z) (string-hash (zid-id z)))) + (cons "toString" (lambda (z) (zid-id z))))) +;; ZoneRules stub: only getOffset/isFixedOffset are exercised; the offset is fixed. +(register-host-methods! "zone-rules" + (list (cons "getOffset" (lambda (r . _) (jt-zone-offset (vector-ref (jhost-state r) 0)))) + (cons "isFixedOffset" (lambda (r) #t)) + (cons "getStandardOffset" (lambda (r . _) (jt-zone-offset (vector-ref (jhost-state r) 0)))) + (cons "toString" (lambda (r) "ZoneRules[fixed]")))) + +;; --- OffsetTime -------------------------------------------------------------- +(define (jt-offset-time nod off) (make-jhost "offset-time" (vector nod off))) +(define (ot-nod x) (vector-ref (jhost-state x) 0)) +(define (ot-offset x) (vector-ref (jhost-state x) 1)) +(define (jt-offset-time? x) (and (jhost? x) (string=? (jhost-tag x) "offset-time"))) +(define (ot->string x) (string-append (iso-time-str (ot-nod x)) (offset-suffix (ot-offset x)))) +;; the offset suffix used in ISO offset/zoned rendering: "Z" for 0 else ±HH:mm[:ss]. +(define (offset-suffix secs) (zo-id secs)) + +;; --- OffsetDateTime ---------------------------------------------------------- +(define (jt-offset-dt ed nod off) (make-jhost "offset-date-time" (vector ed nod off))) +(define (odt-epoch-day x) (vector-ref (jhost-state x) 0)) +(define (odt-nano-of-day x) (vector-ref (jhost-state x) 1)) +(define (odt-offset x) (vector-ref (jhost-state x) 2)) +(define (jt-offset-dt? x) (and (jhost? x) (string=? (jhost-tag x) "offset-date-time"))) +(define (odt-ldt x) (jt-local-dt (odt-epoch-day x) (odt-nano-of-day x))) +;; epoch-ms of the instant this offset-dt denotes (subtract the offset to reach UTC). +(define (odt->ms x) (- (ldt->ms (odt-ldt x)) (* (odt-offset x) 1000))) +(define (odt->string x) (string-append (iso-datetime-str (odt-epoch-day x) (odt-nano-of-day x)) (offset-suffix (odt-offset x)))) + +;; --- ZonedDateTime ----------------------------------------------------------- +(define (jt-zoned-dt ed nod off zone) (make-jhost "zoned-date-time" (vector ed nod off zone))) +(define (zdt-epoch-day x) (vector-ref (jhost-state x) 0)) +(define (zdt-nano-of-day x) (vector-ref (jhost-state x) 1)) +(define (zdt-offset x) (vector-ref (jhost-state x) 2)) +(define (zdt-zone x) (vector-ref (jhost-state x) 3)) +(define (jt-zoned-dt? x) (and (jhost? x) (string=? (jhost-tag x) "zoned-date-time"))) +(define (zdt-ldt x) (jt-local-dt (zdt-epoch-day x) (zdt-nano-of-day x))) +(define (zdt->ms x) (- (ldt->ms (zdt-ldt x)) (* (zdt-offset x) 1000))) +;; ISO zoned: local + offset, then [zone-id] unless the zone IS the offset. +(define (zdt->string x) + (let* ((zid (zdt-zone x)) (id (zid-id zid))) + (string-append (iso-datetime-str (zdt-epoch-day x) (zdt-nano-of-day x)) (offset-suffix (zdt-offset x)) + (if (or (string=? id (offset-suffix (zdt-offset x))) + (and (> (string-length id) 0) (memv (string-ref id 0) '(#\+ #\- #\Z)))) + "" (string-append "[" id "]"))))) + +;; build a ZonedDateTime/OffsetDateTime from a LocalDateTime + zone designator. The +;; offset is the zone's fixed offset (no DST resolution). +(define (zoned-of-ldt ldt zone) + (let ((r (resolve-zone zone))) + (jt-zoned-dt (ldt-epoch-day ldt) (ldt-nano-of-day ldt) (cdr r) (jt-zone-id (car r) (cdr r))))) +(define (offset-of-ldt ldt off) + (let ((secs (cond ((jt-zone-offset? off) (zo-secs off)) ((jt-zone-id? off) (zid-off off)) (else (parse-zone-offset off))))) + (jt-offset-dt (ldt-epoch-day ldt) (ldt-nano-of-day ldt) secs))) +;; from an epoch-ms instant + zone: apply the zone offset to get the local fields. +(define (zoned-of-instant-ms ms zone) + (let* ((r (resolve-zone zone)) (off (cdr r)) + (local-ms (+ (exact (truncate ms)) (* off 1000))) + (ed (jt-floor-div local-ms 86400000)) (nod (* (jt-floor-mod local-ms 86400000) 1000000))) + (jt-zoned-dt ed nod off (jt-zone-id (car r) off)))) +(define (offset-of-instant-ms ms off-or-zone) + (let* ((secs (cond ((jt-zone-offset? off-or-zone) (zo-secs off-or-zone)) + ((jt-zone-id? off-or-zone) (zid-off off-or-zone)) + (else (cdr (resolve-zone off-or-zone))))) + (local-ms (+ (exact (truncate ms)) (* secs 1000))) + (ed (jt-floor-div local-ms 86400000)) (nod (* (jt-floor-mod local-ms 86400000) 1000000))) + (jt-offset-dt ed nod secs))) + +;; redefine mk-zoned (used by Phase-1/2 atZone/atOffset) to yield a real +;; ZonedDateTime at UTC. Older inst-time.ss "zoned-dt" callers route through here. +(set! mk-zoned (lambda (ms) (zoned-of-instant-ms ms (jt-zone-id "Z" 0)))) + +;; --- now / Clock-aware statics ----------------------------------------------- +;; A Clock yields an instant (epoch-ms) and a zone. now-from-clock reads ms. +(define (clock-now-ms clk) + (cond ((not (jhost? clk)) (now-ms)) + ((string=? (jhost-tag clk) "clock") (clk-millis clk)) + (else (now-ms)))) +(define (clock-zone clk) + (if (and (jhost? clk) (string=? (jhost-tag clk) "clock")) (vector-ref (jhost-state clk) 2) + (jt-zone-id "Z" 0))) +;; now-ms-arg: an optional first arg may be a Clock or a ZoneId; pick the ms. +(define (now-ms* args) + (if (and (pair? args) (jhost? (car args)) (string=? (jhost-tag (car args)) "clock")) + (clock-now-ms (car args)) + (now-ms))) + +;; rewire the Phase-1/2 now statics to accept an optional Clock/ZoneId argument. +(register-class-statics! "Instant" + (list (cons "now" (lambda args (mk-instant (now-ms* args)))))) +(register-class-statics! "LocalDate" + (list (cons "now" (lambda args (mk-local-date (now-ms* args)))))) +(register-class-statics! "LocalTime" + (list (cons "now" (lambda args (jt-local-time (* (jt-floor-mod (exact (truncate (now-ms* args))) 86400000) 1000000)))))) +(register-class-statics! "LocalDateTime" + (list (cons "now" (lambda args (mk-local (now-ms* args)))))) + +;; --- Clock ------------------------------------------------------------------- +;; (vector kind fixed-ms zone [base]) kind 'system | 'fixed | 'offset | 'tick +(define (jt-clock kind ms zone . base) (make-jhost "clock" (vector kind ms zone (and (pair? base) (car base))))) +(define (clk-millis clk) + (let ((kind (vector-ref (jhost-state clk) 0))) + (case kind + ((fixed) (vector-ref (jhost-state clk) 1)) + ((offset) (+ (clk-millis (vector-ref (jhost-state clk) 3)) (vector-ref (jhost-state clk) 1))) + ((tick) (let* ((base (vector-ref (jhost-state clk) 3)) (dur-ms (vector-ref (jhost-state clk) 1)) + (m (clk-millis base))) + (if (> dur-ms 0) (* (jt-floor-div m dur-ms) dur-ms) m))) + (else (now-ms))))) +(register-class-statics! "Clock" + (list (cons "systemUTC" (lambda () (jt-clock 'system 0 (jt-zone-id "Z" 0)))) + (cons "systemDefaultZone" (lambda () (let ((s (system-zone-offset-secs))) (jt-clock 'system 0 (jt-zone-id (zo-id s) s))))) + (cons "system" (lambda (zone) (jt-clock 'system 0 (zone-id-of zone)))) + (cons "fixed" (lambda (inst zone) (jt-clock 'fixed (exact (truncate (ms-of inst))) (zone-id-of zone)))) + (cons "offset" (lambda (clk dur) (jt-clock 'offset (quotient (dur-total-nanos dur) 1000000) (clock-zone clk) clk))) + (cons "tick" (lambda (clk dur) (jt-clock 'tick (quotient (dur-total-nanos dur) 1000000) (clock-zone clk) clk))) + (cons "tickMinutes" (lambda (zone) (jt-clock 'tick 60000 (zone-id-of zone) (jt-clock 'system 0 (zone-id-of zone))))) + (cons "tickSeconds" (lambda (zone) (jt-clock 'tick 1000 (zone-id-of zone) (jt-clock 'system 0 (zone-id-of zone))))))) +(register-host-methods! "clock" + (list (cons "instant" (lambda (clk) (mk-instant (clk-millis clk)))) + (cons "millis" (lambda (clk) (clk-millis clk))) + (cons "getZone" (lambda (clk) (vector-ref (jhost-state clk) 2))) + (cons "withZone" (lambda (clk zone) (make-jhost "clock" (vector (vector-ref (jhost-state clk) 0) + (vector-ref (jhost-state clk) 1) + (zone-id-of zone) + (vector-ref (jhost-state clk) 3))))) + (cons "equals" (lambda (clk o) (and (jhost? o) (string=? (jhost-tag o) "clock") (equal? (jhost-state clk) (jhost-state o))))) + (cons "toString" (lambda (clk) "Clock")))) + +;; --- ZonedDateTime statics + methods ----------------------------------------- +(register-class-statics! "ZonedDateTime" + (list (cons "of" (case-lambda + ((ldt zone) (zoned-of-ldt ldt zone)) + ((d t zone) (zoned-of-ldt (jt-local-dt (ld-epoch-day d) (lt-nano-of-day t)) zone)) + ((y mo d h mi s nano zone) + (zoned-of-ldt (jt-local-dt (ymd->epoch-day (jt->exact y) (jt->exact mo) (jt->exact d)) + (hmsn->nano (jt->exact h) (jt->exact mi) (jt->exact s) (jt->exact nano))) zone)))) + (cons "ofInstant" (case-lambda + ((inst zone) (zoned-of-instant-ms (ms-of inst) zone)) + ((ldt off zone) (zoned-of-ldt ldt zone)))) + (cons "ofLocal" (lambda (ldt zone . _) (zoned-of-ldt ldt zone))) + (cons "now" (lambda args (let ((ms (now-ms* args))) + (zoned-of-instant-ms ms (if (and (pair? args) (jhost? (car args)) (string=? (jhost-tag (car args)) "clock")) + (clock-zone (car args)) (jt-zone-id "Z" 0)))))) + (cons "parse" (lambda (s . fmt) + (if (null? fmt) (parse-zoned-date-time (jt-str s)) + (call-with-values (lambda () (formatter-parse-fields (car fmt) s)) + (lambda (ed nod) (jt-zoned-dt ed nod 0 (jt-zone-id "Z" 0))))))) + (cons "from" (lambda (t) (cond ((jt-zoned-dt? t) t) + ((jt-offset-dt? t) (jt-zoned-dt (odt-epoch-day t) (odt-nano-of-day t) (odt-offset t) (jt-zone-id (zo-id (odt-offset t)) (odt-offset t)))) + (else (zoned-of-instant-ms (ms-of t) (jt-zone-id "Z" 0)))))))) + +;; apply nano arithmetic to a zoned/offset value, keeping its offset & zone. +(define (zdt-plus-nanos x nanos) + (let ((nldt (ldt-plus-nanos (zdt-ldt x) nanos))) + (jt-zoned-dt (ldt-epoch-day nldt) (ldt-nano-of-day nldt) (zdt-offset x) (zdt-zone x)))) +(define (zdt-with-ldt x ldt) (jt-zoned-dt (ldt-epoch-day ldt) (ldt-nano-of-day ldt) (zdt-offset x) (zdt-zone x))) + +(register-host-methods! "zoned-date-time" + (list (cons "getYear" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (zdt-epoch-day x))) (lambda (y m d) y)))) + (cons "getMonthValue" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (zdt-epoch-day x))) (lambda (y m d) m)))) + (cons "getMonth" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (zdt-epoch-day x))) (lambda (y m d) (jt-month m))))) + (cons "getDayOfMonth" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (zdt-epoch-day x))) (lambda (y m d) d)))) + (cons "getDayOfWeek" (lambda (x) (jt-dow (ld-dow (zdt-epoch-day x))))) + (cons "getDayOfYear" (lambda (x) (ld-day-of-year (zdt-epoch-day x)))) + (cons "getHour" (lambda (x) (lt-hour (zdt-ldt x)))) + (cons "getMinute" (lambda (x) (lt-minute (zdt-ldt x)))) + (cons "getSecond" (lambda (x) (lt-second (zdt-ldt x)))) + (cons "getNano" (lambda (x) (lt-nano (zdt-ldt x)))) + (cons "getOffset" (lambda (x) (jt-zone-offset (zdt-offset x)))) + (cons "getZone" (lambda (x) (zdt-zone x))) + (cons "toInstant" (lambda (x) (mk-instant (zdt->ms x)))) + (cons "toLocalDate" (lambda (x) (jt-local-date (zdt-epoch-day x)))) + (cons "toLocalTime" (lambda (x) (jt-local-time (zdt-nano-of-day x)))) + (cons "toLocalDateTime" (lambda (x) (zdt-ldt x))) + (cons "toOffsetDateTime" (lambda (x) (jt-offset-dt (zdt-epoch-day x) (zdt-nano-of-day x) (zdt-offset x)))) + (cons "toEpochSecond" (lambda (x) (jt-floor-div (zdt->ms x) 1000))) + (cons "plusDays" (lambda (x n) (zdt-with-ldt x (jt-local-dt (+ (zdt-epoch-day x) (jt->exact n)) (zdt-nano-of-day x))))) + (cons "minusDays" (lambda (x n) (zdt-with-ldt x (jt-local-dt (- (zdt-epoch-day x) (jt->exact n)) (zdt-nano-of-day x))))) + (cons "plusWeeks" (lambda (x n) (zdt-with-ldt x (jt-local-dt (+ (zdt-epoch-day x) (* 7 (jt->exact n))) (zdt-nano-of-day x))))) + (cons "minusWeeks" (lambda (x n) (zdt-with-ldt x (jt-local-dt (- (zdt-epoch-day x) (* 7 (jt->exact n))) (zdt-nano-of-day x))))) + (cons "plusMonths" (lambda (x n) (zdt-with-ldt x (ldt-combine (ld-plus-months (ldt-date (zdt-ldt x)) (jt->exact n)) (ldt-time (zdt-ldt x)))))) + (cons "minusMonths" (lambda (x n) (zdt-with-ldt x (ldt-combine (ld-plus-months (ldt-date (zdt-ldt x)) (- (jt->exact n))) (ldt-time (zdt-ldt x)))))) + (cons "plusYears" (lambda (x n) (zdt-with-ldt x (ldt-combine (ld-plus-years (ldt-date (zdt-ldt x)) (jt->exact n)) (ldt-time (zdt-ldt x)))))) + (cons "minusYears" (lambda (x n) (zdt-with-ldt x (ldt-combine (ld-plus-years (ldt-date (zdt-ldt x)) (- (jt->exact n))) (ldt-time (zdt-ldt x)))))) + (cons "plusHours" (lambda (x n) (zdt-plus-nanos x (* (jt->exact n) 3600 nanos-per-sec)))) + (cons "minusHours" (lambda (x n) (zdt-plus-nanos x (- (* (jt->exact n) 3600 nanos-per-sec))))) + (cons "plusMinutes" (lambda (x n) (zdt-plus-nanos x (* (jt->exact n) 60 nanos-per-sec)))) + (cons "minusMinutes" (lambda (x n) (zdt-plus-nanos x (- (* (jt->exact n) 60 nanos-per-sec))))) + (cons "plusSeconds" (lambda (x n) (zdt-plus-nanos x (* (jt->exact n) nanos-per-sec)))) + (cons "minusSeconds" (lambda (x n) (zdt-plus-nanos x (- (* (jt->exact n) nanos-per-sec))))) + (cons "plusNanos" (lambda (x n) (zdt-plus-nanos x (jt->exact n)))) + (cons "minusNanos" (lambda (x n) (zdt-plus-nanos x (- (jt->exact n))))) + (cons "withYear" (lambda (x v) (zdt-with-ldt x (ldt-combine (ld-with-field (ldt-date (zdt-ldt x)) 'year (jt->exact v)) (ldt-time (zdt-ldt x)))))) + (cons "withMonth" (lambda (x v) (zdt-with-ldt x (ldt-combine (ld-with-field (ldt-date (zdt-ldt x)) 'month (jt->exact v)) (ldt-time (zdt-ldt x)))))) + (cons "withDayOfMonth" (lambda (x v) (zdt-with-ldt x (ldt-combine (ld-with-field (ldt-date (zdt-ldt x)) 'day (jt->exact v)) (ldt-time (zdt-ldt x)))))) + (cons "withDayOfYear" (lambda (x v) (zdt-with-ldt x (ldt-combine (ld-with-field (ldt-date (zdt-ldt x)) 'day-of-year (jt->exact v)) (ldt-time (zdt-ldt x)))))) + (cons "withHour" (lambda (x v) (zdt-with-ldt x (ldt-combine (ldt-date (zdt-ldt x)) (lt-with (ldt-time (zdt-ldt x)) 'hour (jt->exact v)))))) + (cons "withMinute" (lambda (x v) (zdt-with-ldt x (ldt-combine (ldt-date (zdt-ldt x)) (lt-with (ldt-time (zdt-ldt x)) 'minute (jt->exact v)))))) + (cons "withSecond" (lambda (x v) (zdt-with-ldt x (ldt-combine (ldt-date (zdt-ldt x)) (lt-with (ldt-time (zdt-ldt x)) 'second (jt->exact v)))))) + (cons "withNano" (lambda (x v) (zdt-with-ldt x (ldt-combine (ldt-date (zdt-ldt x)) (lt-with (ldt-time (zdt-ldt x)) 'nano (jt->exact v)))))) + (cons "truncatedTo" (lambda (x u) (zdt-with-ldt x (ldt-combine (ldt-date (zdt-ldt x)) (lt-truncate (ldt-time (zdt-ldt x)) u))))) + (cons "withZoneSameInstant" (lambda (x zone) (zoned-of-instant-ms (zdt->ms x) zone))) + (cons "withZoneSameLocal" (lambda (x zone) (zoned-of-ldt (zdt-ldt x) zone))) + (cons "withFixedOffsetZone" (lambda (x) (jt-zoned-dt (zdt-epoch-day x) (zdt-nano-of-day x) (zdt-offset x) (jt-zone-id (zo-id (zdt-offset x)) (zdt-offset x))))) + (cons "plus" (case-lambda ((x a) (zdt-plus-amount x a 1)) ((x n u) (zdt-with-ldt x (temporal-plus-unit (zdt-ldt x) (jt->exact n) (arg-unit-name u)))))) + (cons "minus" (case-lambda ((x a) (zdt-plus-amount x a -1)) ((x n u) (zdt-with-ldt x (temporal-plus-unit (zdt-ldt x) (- (jt->exact n)) (arg-unit-name u)))))) + (cons "until" (lambda (x o u) (unit-between (arg-unit-name u) (zdt-ldt x) (zdt-ldt o)))) + (cons "get" (lambda (x f) (zdt-get-field x (arg-field-name f)))) + (cons "getLong" (lambda (x f) (zdt-get-field x (arg-field-name f)))) + (cons "with" (case-lambda ((x adj) (zdt-with-ldt x (apply-adjuster (zdt-ldt x) adj))) + ((x f v) (zdt-with-ldt x (temporal-with-field (zdt-ldt x) (arg-field-name f) (jt->exact v)))))) + (cons "isSupported" (lambda (x a) (cond ((arg-is-unit? a) (not (string-ci=? (cu-name a) "FOREVER"))) + ((arg-is-field? a) #t) (else #f)))) + (cons "range" (lambda (x f) (temporal-range (zdt-ldt x) (arg-field-name f)))) + (cons "isBefore" (lambda (x o) (< (zdt->ms x) (time-ms o)))) + (cons "isAfter" (lambda (x o) (> (zdt->ms x) (time-ms o)))) + (cons "isEqual" (lambda (x o) (= (zdt->ms x) (time-ms o)))) + (cons "compareTo" (lambda (x o) (let ((a (zdt->ms x)) (b (zdt->ms o))) (cond ((< a b) -1) ((> a b) 1) (else 0))))) + (cons "equals" (lambda (x o) (and (jt-zoned-dt? o) (equal? (jhost-state x) (jhost-state o))))) + (cons "hashCode" (lambda (x) (jolt-hash (zdt->ms x)))) + (cons "format" (lambda (x fmt) (fmt-format fmt x))) + (cons "toString" (lambda (x) (zdt->string x))))) +(define (zdt-plus-amount x a sign) + (cond ((arg-is-amount? a) (if (string=? (jhost-tag a) "duration") + (zdt-plus-nanos x (* sign (dur-total-nanos a))) + (zdt-with-ldt x (temporal-plus-period (zdt-ldt x) a sign)))) + (else (error #f "ZonedDateTime.plus: bad amount")))) +(define (zdt-get-field x field) + (let ((f (string-upcase field))) + (cond ((string=? f "OFFSET_SECONDS") (zdt-offset x)) + ((string=? f "INSTANT_SECONDS") (jt-floor-div (zdt->ms x) 1000)) + (else (temporal-get-field (zdt-ldt x) f))))) +;; epoch-ms of any time-bearing value (for cross-type before/after). +(define (time-ms o) + (cond ((jt-zoned-dt? o) (zdt->ms o)) ((jt-offset-dt? o) (odt->ms o)) ((jt-instant? o) (inst-ms o)) + ((jt-dt? o) (ldt->ms o)) (else (ms-of o)))) + +;; --- OffsetDateTime statics + methods ---------------------------------------- +(register-class-statics! "OffsetDateTime" + (list (cons "of" (case-lambda + ((ldt off) (offset-of-ldt ldt off)) + ((d t off) (offset-of-ldt (jt-local-dt (ld-epoch-day d) (lt-nano-of-day t)) off)) + ((y mo d h mi s nano off) + (offset-of-ldt (jt-local-dt (ymd->epoch-day (jt->exact y) (jt->exact mo) (jt->exact d)) + (hmsn->nano (jt->exact h) (jt->exact mi) (jt->exact s) (jt->exact nano))) off)))) + (cons "ofInstant" (lambda (inst zone) (offset-of-instant-ms (ms-of inst) zone))) + (cons "now" (lambda args (offset-of-instant-ms (now-ms* args) (jt-zone-offset 0)))) + (cons "parse" (lambda (s . fmt) + (if (null? fmt) (parse-offset-date-time (jt-str s)) + (call-with-values (lambda () (formatter-parse-fields (car fmt) s)) + (lambda (ed nod) (jt-offset-dt ed nod 0)))))) + (cons "from" (lambda (t) (cond ((jt-offset-dt? t) t) + ((jt-zoned-dt? t) (jt-offset-dt (zdt-epoch-day t) (zdt-nano-of-day t) (zdt-offset t))) + (else (offset-of-instant-ms (ms-of t) (jt-zone-offset 0)))))) + (cons "MIN" (jt-offset-dt (ymd->epoch-day -999999999 1 1) 0 (* 18 3600))) + (cons "MAX" (jt-offset-dt (ymd->epoch-day 999999999 12 31) (- nanos-per-day 1) (* -18 3600))))) +(define (odt-with-ldt x ldt) (jt-offset-dt (ldt-epoch-day ldt) (ldt-nano-of-day ldt) (odt-offset x))) +(define (odt-plus-nanos x nanos) (odt-with-ldt x (ldt-plus-nanos (odt-ldt x) nanos))) +(register-host-methods! "offset-date-time" + (list (cons "getYear" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (odt-epoch-day x))) (lambda (y m d) y)))) + (cons "getMonthValue" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (odt-epoch-day x))) (lambda (y m d) m)))) + (cons "getMonth" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (odt-epoch-day x))) (lambda (y m d) (jt-month m))))) + (cons "getDayOfMonth" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (odt-epoch-day x))) (lambda (y m d) d)))) + (cons "getDayOfWeek" (lambda (x) (jt-dow (ld-dow (odt-epoch-day x))))) + (cons "getDayOfYear" (lambda (x) (ld-day-of-year (odt-epoch-day x)))) + (cons "getHour" (lambda (x) (lt-hour (odt-ldt x)))) + (cons "getMinute" (lambda (x) (lt-minute (odt-ldt x)))) + (cons "getSecond" (lambda (x) (lt-second (odt-ldt x)))) + (cons "getNano" (lambda (x) (lt-nano (odt-ldt x)))) + (cons "getOffset" (lambda (x) (jt-zone-offset (odt-offset x)))) + (cons "toInstant" (lambda (x) (mk-instant (odt->ms x)))) + (cons "toLocalDate" (lambda (x) (jt-local-date (odt-epoch-day x)))) + (cons "toLocalTime" (lambda (x) (jt-local-time (odt-nano-of-day x)))) + (cons "toLocalDateTime" (lambda (x) (odt-ldt x))) + (cons "toOffsetTime" (lambda (x) (jt-offset-time (odt-nano-of-day x) (odt-offset x)))) + (cons "toZonedDateTime" (lambda (x) (jt-zoned-dt (odt-epoch-day x) (odt-nano-of-day x) (odt-offset x) (jt-zone-id (zo-id (odt-offset x)) (odt-offset x))))) + (cons "toEpochSecond" (lambda (x) (jt-floor-div (odt->ms x) 1000))) + (cons "atZoneSameInstant" (lambda (x zone) (zoned-of-instant-ms (odt->ms x) zone))) + (cons "atZoneSimilarLocal" (lambda (x zone) (zoned-of-ldt (odt-ldt x) zone))) + (cons "withOffsetSameInstant" (lambda (x off) (offset-of-instant-ms (odt->ms x) off))) + (cons "withOffsetSameLocal" (lambda (x off) (offset-of-ldt (odt-ldt x) off))) + (cons "plusDays" (lambda (x n) (odt-with-ldt x (jt-local-dt (+ (odt-epoch-day x) (jt->exact n)) (odt-nano-of-day x))))) + (cons "minusDays" (lambda (x n) (odt-with-ldt x (jt-local-dt (- (odt-epoch-day x) (jt->exact n)) (odt-nano-of-day x))))) + (cons "plusWeeks" (lambda (x n) (odt-with-ldt x (jt-local-dt (+ (odt-epoch-day x) (* 7 (jt->exact n))) (odt-nano-of-day x))))) + (cons "minusWeeks" (lambda (x n) (odt-with-ldt x (jt-local-dt (- (odt-epoch-day x) (* 7 (jt->exact n))) (odt-nano-of-day x))))) + (cons "plusMonths" (lambda (x n) (odt-with-ldt x (ldt-combine (ld-plus-months (ldt-date (odt-ldt x)) (jt->exact n)) (ldt-time (odt-ldt x)))))) + (cons "minusMonths" (lambda (x n) (odt-with-ldt x (ldt-combine (ld-plus-months (ldt-date (odt-ldt x)) (- (jt->exact n))) (ldt-time (odt-ldt x)))))) + (cons "plusYears" (lambda (x n) (odt-with-ldt x (ldt-combine (ld-plus-years (ldt-date (odt-ldt x)) (jt->exact n)) (ldt-time (odt-ldt x)))))) + (cons "minusYears" (lambda (x n) (odt-with-ldt x (ldt-combine (ld-plus-years (ldt-date (odt-ldt x)) (- (jt->exact n))) (ldt-time (odt-ldt x)))))) + (cons "plusHours" (lambda (x n) (odt-plus-nanos x (* (jt->exact n) 3600 nanos-per-sec)))) + (cons "minusHours" (lambda (x n) (odt-plus-nanos x (- (* (jt->exact n) 3600 nanos-per-sec))))) + (cons "plusMinutes" (lambda (x n) (odt-plus-nanos x (* (jt->exact n) 60 nanos-per-sec)))) + (cons "minusMinutes" (lambda (x n) (odt-plus-nanos x (- (* (jt->exact n) 60 nanos-per-sec))))) + (cons "plusSeconds" (lambda (x n) (odt-plus-nanos x (* (jt->exact n) nanos-per-sec)))) + (cons "minusSeconds" (lambda (x n) (odt-plus-nanos x (- (* (jt->exact n) nanos-per-sec))))) + (cons "plusNanos" (lambda (x n) (odt-plus-nanos x (jt->exact n)))) + (cons "minusNanos" (lambda (x n) (odt-plus-nanos x (- (jt->exact n))))) + (cons "withYear" (lambda (x v) (odt-with-ldt x (ldt-combine (ld-with-field (ldt-date (odt-ldt x)) 'year (jt->exact v)) (ldt-time (odt-ldt x)))))) + (cons "withMonth" (lambda (x v) (odt-with-ldt x (ldt-combine (ld-with-field (ldt-date (odt-ldt x)) 'month (jt->exact v)) (ldt-time (odt-ldt x)))))) + (cons "withDayOfMonth" (lambda (x v) (odt-with-ldt x (ldt-combine (ld-with-field (ldt-date (odt-ldt x)) 'day (jt->exact v)) (ldt-time (odt-ldt x)))))) + (cons "withDayOfYear" (lambda (x v) (odt-with-ldt x (ldt-combine (ld-with-field (ldt-date (odt-ldt x)) 'day-of-year (jt->exact v)) (ldt-time (odt-ldt x)))))) + (cons "withHour" (lambda (x v) (odt-with-ldt x (ldt-combine (ldt-date (odt-ldt x)) (lt-with (ldt-time (odt-ldt x)) 'hour (jt->exact v)))))) + (cons "withMinute" (lambda (x v) (odt-with-ldt x (ldt-combine (ldt-date (odt-ldt x)) (lt-with (ldt-time (odt-ldt x)) 'minute (jt->exact v)))))) + (cons "withSecond" (lambda (x v) (odt-with-ldt x (ldt-combine (ldt-date (odt-ldt x)) (lt-with (ldt-time (odt-ldt x)) 'second (jt->exact v)))))) + (cons "withNano" (lambda (x v) (odt-with-ldt x (ldt-combine (ldt-date (odt-ldt x)) (lt-with (ldt-time (odt-ldt x)) 'nano (jt->exact v)))))) + (cons "truncatedTo" (lambda (x u) (odt-with-ldt x (ldt-combine (ldt-date (odt-ldt x)) (lt-truncate (ldt-time (odt-ldt x)) u))))) + (cons "plus" (case-lambda ((x a) (odt-plus-amount x a 1)) ((x n u) (odt-with-ldt x (temporal-plus-unit (odt-ldt x) (jt->exact n) (arg-unit-name u)))))) + (cons "minus" (case-lambda ((x a) (odt-plus-amount x a -1)) ((x n u) (odt-with-ldt x (temporal-plus-unit (odt-ldt x) (- (jt->exact n)) (arg-unit-name u)))))) + (cons "until" (lambda (x o u) (unit-between (arg-unit-name u) (odt-ldt x) (odt-ldt o)))) + (cons "get" (lambda (x f) (odt-get-field x (arg-field-name f)))) + (cons "getLong" (lambda (x f) (odt-get-field x (arg-field-name f)))) + (cons "with" (case-lambda ((x adj) (odt-with-ldt x (apply-adjuster (odt-ldt x) adj))) + ((x f v) (odt-with-ldt x (temporal-with-field (odt-ldt x) (arg-field-name f) (jt->exact v)))))) + (cons "isSupported" (lambda (x a) (cond ((arg-is-unit? a) (not (string-ci=? (cu-name a) "FOREVER"))) ((arg-is-field? a) #t) (else #f)))) + (cons "range" (lambda (x f) (temporal-range (odt-ldt x) (arg-field-name f)))) + (cons "isBefore" (lambda (x o) (< (odt->ms x) (time-ms o)))) + (cons "isAfter" (lambda (x o) (> (odt->ms x) (time-ms o)))) + (cons "isEqual" (lambda (x o) (= (odt->ms x) (time-ms o)))) + (cons "compareTo" (lambda (x o) (let ((a (odt->ms x)) (b (odt->ms o))) (cond ((< a b) -1) ((> a b) 1) (else 0))))) + (cons "equals" (lambda (x o) (and (jt-offset-dt? o) (equal? (jhost-state x) (jhost-state o))))) + (cons "hashCode" (lambda (x) (jolt-hash (odt->ms x)))) + (cons "format" (lambda (x fmt) (fmt-format fmt x))) + (cons "toString" (lambda (x) (odt->string x))))) +(define (odt-plus-amount x a sign) + (cond ((arg-is-amount? a) (if (string=? (jhost-tag a) "duration") + (odt-plus-nanos x (* sign (dur-total-nanos a))) + (odt-with-ldt x (temporal-plus-period (odt-ldt x) a sign)))) + (else (error #f "OffsetDateTime.plus: bad amount")))) +(define (odt-get-field x field) + (let ((f (string-upcase field))) + (cond ((string=? f "OFFSET_SECONDS") (odt-offset x)) + ((string=? f "INSTANT_SECONDS") (jt-floor-div (odt->ms x) 1000)) + (else (temporal-get-field (odt-ldt x) f))))) + +;; --- OffsetTime statics + methods -------------------------------------------- +(register-class-statics! "OffsetTime" + (list (cons "of" (case-lambda + ((t off) (jt-offset-time (lt-nano-of-day t) (zo-secs* off))) + ((h m s nano off) (jt-offset-time (hmsn->nano (jt->exact h) (jt->exact m) (jt->exact s) (jt->exact nano)) (zo-secs* off))))) + (cons "ofInstant" (lambda (inst zone) (let ((od (offset-of-instant-ms (ms-of inst) zone))) + (jt-offset-time (odt-nano-of-day od) (odt-offset od))))) + (cons "now" (lambda args (jt-offset-time (* (jt-floor-mod (exact (truncate (now-ms* args))) 86400000) 1000000) 0))) + (cons "parse" (lambda (s . _) (parse-offset-time (jt-str s)))) + (cons "from" (lambda (t) (cond ((jt-offset-time? t) t) + ((jt-offset-dt? t) (jt-offset-time (odt-nano-of-day t) (odt-offset t))) + (else (error #f "OffsetTime/from: unsupported"))))) + (cons "MIN" (jt-offset-time 0 (* 18 3600))) + (cons "MAX" (jt-offset-time (- nanos-per-day 1) (* -18 3600))))) +(define (zo-secs* off) (cond ((jt-zone-offset? off) (zo-secs off)) ((jt-zone-id? off) (zid-off off)) (else (parse-zone-offset off)))) +(define (ot-with x nod) (jt-offset-time nod (ot-offset x))) +(register-host-methods! "offset-time" + (list (cons "getHour" (lambda (x) (lt-hour (jt-local-time (ot-nod x))))) + (cons "getMinute" (lambda (x) (lt-minute (jt-local-time (ot-nod x))))) + (cons "getSecond" (lambda (x) (lt-second (jt-local-time (ot-nod x))))) + (cons "getNano" (lambda (x) (lt-nano (jt-local-time (ot-nod x))))) + (cons "getOffset" (lambda (x) (jt-zone-offset (ot-offset x)))) + (cons "toLocalTime" (lambda (x) (jt-local-time (ot-nod x)))) + (cons "atDate" (lambda (x d) (jt-offset-dt (ld-epoch-day d) (ot-nod x) (ot-offset x)))) + (cons "plusHours" (lambda (x n) (ot-with x (jt-floor-mod (+ (ot-nod x) (* (jt->exact n) 3600 nanos-per-sec)) nanos-per-day)))) + (cons "minusHours" (lambda (x n) (ot-with x (jt-floor-mod (- (ot-nod x) (* (jt->exact n) 3600 nanos-per-sec)) nanos-per-day)))) + (cons "plusMinutes" (lambda (x n) (ot-with x (jt-floor-mod (+ (ot-nod x) (* (jt->exact n) 60 nanos-per-sec)) nanos-per-day)))) + (cons "minusMinutes" (lambda (x n) (ot-with x (jt-floor-mod (- (ot-nod x) (* (jt->exact n) 60 nanos-per-sec)) nanos-per-day)))) + (cons "plusSeconds" (lambda (x n) (ot-with x (jt-floor-mod (+ (ot-nod x) (* (jt->exact n) nanos-per-sec)) nanos-per-day)))) + (cons "minusSeconds" (lambda (x n) (ot-with x (jt-floor-mod (- (ot-nod x) (* (jt->exact n) nanos-per-sec)) nanos-per-day)))) + (cons "plusNanos" (lambda (x n) (ot-with x (jt-floor-mod (+ (ot-nod x) (jt->exact n)) nanos-per-day)))) + (cons "minusNanos" (lambda (x n) (ot-with x (jt-floor-mod (- (ot-nod x) (jt->exact n)) nanos-per-day)))) + (cons "withHour" (lambda (x v) (ot-with x (lt-nano-of-day (lt-with (jt-local-time (ot-nod x)) 'hour (jt->exact v)))))) + (cons "withMinute" (lambda (x v) (ot-with x (lt-nano-of-day (lt-with (jt-local-time (ot-nod x)) 'minute (jt->exact v)))))) + (cons "withSecond" (lambda (x v) (ot-with x (lt-nano-of-day (lt-with (jt-local-time (ot-nod x)) 'second (jt->exact v)))))) + (cons "withNano" (lambda (x v) (ot-with x (lt-nano-of-day (lt-with (jt-local-time (ot-nod x)) 'nano (jt->exact v)))))) + (cons "truncatedTo" (lambda (x u) (ot-with x (lt-nano-of-day (lt-truncate (jt-local-time (ot-nod x)) u))))) + (cons "withOffsetSameLocal" (lambda (x off) (jt-offset-time (ot-nod x) (zo-secs* off)))) + (cons "isBefore" (lambda (x o) (< (- (ot-nod x) (* (ot-offset x) nanos-per-sec)) (- (ot-nod o) (* (ot-offset o) nanos-per-sec))))) + (cons "isAfter" (lambda (x o) (> (- (ot-nod x) (* (ot-offset x) nanos-per-sec)) (- (ot-nod o) (* (ot-offset o) nanos-per-sec))))) + (cons "isEqual" (lambda (x o) (= (- (ot-nod x) (* (ot-offset x) nanos-per-sec)) (- (ot-nod o) (* (ot-offset o) nanos-per-sec))))) + (cons "compareTo" (lambda (x o) (let ((a (- (ot-nod x) (* (ot-offset x) nanos-per-sec))) (b (- (ot-nod o) (* (ot-offset o) nanos-per-sec)))) + (cond ((< a b) -1) ((> a b) 1) (else 0))))) + (cons "equals" (lambda (x o) (and (jt-offset-time? o) (equal? (jhost-state x) (jhost-state o))))) + (cons "hashCode" (lambda (x) (jolt-hash (ot-nod x)))) + (cons "format" (lambda (x fmt) (fmt-format fmt x))) + (cons "toString" (lambda (x) (ot->string x))))) + +;; --- ISO parse for the offset/zoned types ------------------------------------ +;; split off an offset/zone suffix at the end of an ISO datetime string; -> (values +;; local-part offset-secs zone-id-or-#f). offset starts at the first +/-/Z after T. +(define (split-offset-zone s) + (let ((len (string-length s)) + (ti (let loop ((i 0)) (cond ((>= i (string-length s)) #f) + ((or (char=? (string-ref s i) #\T) (char=? (string-ref s i) #\t)) i) + (else (loop (+ i 1))))))) + ;; bracket zone "[Region/City]" at the very end + (let* ((zone-id (and (> len 0) (char=? (string-ref s (- len 1)) #\]) + (let loop ((i (- len 2))) (cond ((< i 0) #f) + ((char=? (string-ref s i) #\[) (substring s (+ i 1) (- len 1))) + (else (loop (- i 1))))))) + (s2 (if zone-id (let loop ((i (- len 1))) (if (char=? (string-ref s i) #\[) (substring s 0 i) (loop (- i 1)))) s)) + (len2 (string-length s2)) + ;; find the offset start (after the T) + (oi (let loop ((i (if ti (+ ti 1) 0))) + (cond ((>= i len2) #f) + ((or (char=? (string-ref s2 i) #\Z) (char=? (string-ref s2 i) #\z)) i) + ((and (> i (if ti (+ ti 1) 0)) (or (char=? (string-ref s2 i) #\+) (char=? (string-ref s2 i) #\-))) i) + (else (loop (+ i 1))))))) + (if oi + (values (substring s2 0 oi) (parse-zone-offset (substring s2 oi len2)) zone-id) + (values s2 0 zone-id))))) +(define (parse-zoned-date-time s) + (call-with-values (lambda () (split-offset-zone s)) + (lambda (local off zone-id) + (call-with-values (lambda () (parse-iso-datetime local)) + (lambda (ed nod) + (let ((zid (if zone-id (zone-id-of zone-id) (jt-zone-id (zo-id off) off)))) + (jt-zoned-dt ed nod off zid))))))) +(define (parse-offset-date-time s) + (call-with-values (lambda () (split-offset-zone s)) + (lambda (local off zone-id) + (call-with-values (lambda () (parse-iso-datetime local)) (lambda (ed nod) (jt-offset-dt ed nod off)))))) +(define (parse-offset-time s) + ;; "HH:mm[:ss]±HH:mm" / "...Z" + (let ((oi (let loop ((i 0)) (cond ((>= i (string-length s)) #f) + ((or (char=? (string-ref s i) #\Z) (char=? (string-ref s i) #\z)) i) + ((and (> i 0) (or (char=? (string-ref s i) #\+) (char=? (string-ref s i) #\-))) i) + (else (loop (+ i 1))))))) + (if oi (jt-offset-time (parse-iso-time (substring s 0 oi)) (parse-zone-offset (substring s oi (string-length s)))) + (jt-offset-time (parse-iso-time s) 0)))) + +;; --- formatter integration --------------------------------------------------- +;; format any java.time value through a dt-formatter pattern. Builds the broken-down +;; fields from the value's local representation; X/Z/x render its offset, z its zone. +(define (jt-value-format-parts v) ; -> (vector y mo d hh mi se nano dow offset-secs zone-id) + (define (from-ed-nod ed nod off zid) + (call-with-values (lambda () (epoch-day->ymd ed)) + (lambda (y m d) + (let ((t (jt-local-time nod))) + (vector y m d (lt-hour t) (lt-minute t) (lt-second t) (lt-nano t) (jt-floor-mod (+ ed 4) 7) off zid))))) + (cond + ((jt-date? v) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day v))) + (lambda (y m d) (vector y m d 0 0 0 0 (jt-floor-mod (+ (ld-epoch-day v) 4) 7) 0 #f)))) + ((jt-time? v) (let ((t v)) (vector 1970 1 1 (lt-hour t) (lt-minute t) (lt-second t) (lt-nano t) 4 0 #f))) + ((jt-dt? v) (from-ed-nod (ldt-epoch-day v) (ldt-nano-of-day v) 0 #f)) + ((jt-zoned-dt? v) (from-ed-nod (zdt-epoch-day v) (zdt-nano-of-day v) (zdt-offset v) (zid-id (zdt-zone v)))) + ((jt-offset-dt? v) (from-ed-nod (odt-epoch-day v) (odt-nano-of-day v) (odt-offset v) #f)) + ((jt-offset-time? v) (let ((t (jt-local-time (ot-nod v)))) (vector 1970 1 1 (lt-hour t) (lt-minute t) (lt-second t) (lt-nano t) 4 (ot-offset v) #f))) + ((jt-instant? v) #f) ; instants render via format-ms (UTC) + (else #f))) +;; the pattern engine for java.time values (extends inst-time.ss's format-ms letters +;; with fractional S and real X/x/Z/z from the value's own offset/zone). +(define (jt-format-pattern pattern v) + (let ((parts (jt-value-format-parts v))) + (if (not parts) + (format-ms pattern (ms-of v)) ; instant: UTC engine + (let ((y (vector-ref parts 0)) (mo (vector-ref parts 1)) (d (vector-ref parts 2)) + (hh (vector-ref parts 3)) (mi (vector-ref parts 4)) (se (vector-ref parts 5)) + (nano (vector-ref parts 6)) (dow (vector-ref parts 7)) + (off (vector-ref parts 8)) (zid (vector-ref parts 9)) + (n (string-length pattern)) (out (open-output-string))) + (define (run-len i c) (let loop ((j i)) (if (and (< j n) (char=? (string-ref pattern j) c)) (loop (+ j 1)) (- j i)))) + (define (off-iso secs colon allow-z) + (if (and allow-z (= secs 0)) "Z" + (let* ((neg (< secs 0)) (a (abs secs)) (h (quotient a 3600)) (m (quotient (modulo a 3600) 60)) (s (modulo a 60))) + (string-append (if neg "-" "+") (pad2 h) (if colon ":" "") (pad2 m) + (if (= s 0) "" (string-append (if colon ":" "") (pad2 s))))))) + (let loop ((i 0)) + (when (< i n) + (let* ((c (string-ref pattern i)) (k (run-len i c))) + (cond + ((char=? c #\') + (if (and (< (+ i 1) n) (char=? (string-ref pattern (+ i 1)) #\')) + (begin (write-char #\' out) (loop (+ i 2))) + (let close ((j (+ i 1))) + (cond ((>= j n) (loop j)) + ((char=? (string-ref pattern j) #\') (loop (+ j 1))) + (else (write-char (string-ref pattern j) out) (close (+ j 1))))))) + ;; y = year-of-era, Y = week-based-year; for whole dates they agree, + ;; so render Y like y (no ISO-week calendar here). + ((or (char=? c #\y) (char=? c #\Y)) (display (if (>= k 4) (pad4 y) (pad2 (modulo y 100))) out) (loop (+ i k))) + ((char=? c #\M) + (display (cond ((= k 1) (number->string mo)) ((= k 2) (pad2 mo)) + ((= k 3) (substring (vector-ref month-names (- mo 1)) 0 3)) + (else (vector-ref month-names (- mo 1)))) out) (loop (+ i k))) + ((char=? c #\d) (display (if (= k 1) (number->string d) (pad2 d)) out) (loop (+ i k))) + ((char=? c #\E) (display (if (>= k 4) (vector-ref day-names dow) (substring (vector-ref day-names dow) 0 3)) out) (loop (+ i k))) + ((char=? c #\H) (display (if (= k 1) (number->string hh) (pad2 hh)) out) (loop (+ i k))) + ((char=? c #\h) (let ((h12 (let ((h (modulo hh 12))) (if (= h 0) 12 h)))) (display (if (= k 1) (number->string h12) (pad2 h12)) out)) (loop (+ i k))) + ((char=? c #\m) (display (if (= k 1) (number->string mi) (pad2 mi)) out) (loop (+ i k))) + ((char=? c #\s) (display (if (= k 1) (number->string se) (pad2 se)) out) (loop (+ i k))) + ((char=? c #\S) (let ((str (let ((p (number->string (quotient nano (expt 10 (max 0 (- 9 k))))))) p))) + (display (string-append (make-string (max 0 (- k (string-length str))) #\0) str) out)) (loop (+ i k))) + ((char=? c #\a) (display (if (< hh 12) "AM" "PM") out) (loop (+ i k))) + ((char=? c #\X) (display (off-iso off (>= k 3) #t) out) (loop (+ i k))) + ((char=? c #\x) (display (off-iso off (>= k 3) #f) out) (loop (+ i k))) + ((char=? c #\Z) (display (if (>= k 3) (off-iso off #t #f) (off-iso off #f #f)) out) (loop (+ i k))) + ((char=? c #\V) (display (or zid (off-iso off #t #t)) out) (loop (+ i k))) + ((char=? c #\z) (display (or zid (off-iso off #t #t)) out) (loop (+ i k))) + (else (write-char c out) (loop (+ i 1))))))) + (get-output-string out))))) + +;; .format on a dt-formatter applied to a java.time value. The pattern comes from the +;; formatter; ISO_* constants carry a literal pattern that round-trips through here. +(define (fmt-format fmt v) + (cond ((and (jhost? fmt) (string=? (jhost-tag fmt) "dt-formatter")) (jt-format-pattern (fmt-pat fmt) v)) + ((string? fmt) (jt-format-pattern fmt v)) + (else (jt-value->iso v)))) +(define (jt-value->iso v) + (cond ((jt-date? v) (iso-date-str (ld-epoch-day v))) ((jt-time? v) (iso-time-str (lt-nano-of-day v))) + ((jt-dt? v) (iso-datetime-str (ldt-epoch-day v) (ldt-nano-of-day v))) + ((jt-zoned-dt? v) (zdt->string v)) ((jt-offset-dt? v) (odt->string v)) + ((jt-offset-time? v) (ot->string v)) ((jt-instant? v) (iso-instant-str (inst-ms v))) + (else (jolt-str-render-one v)))) + +;; .format on the new value types reaches the per-tag method tables above. Add +;; .format to local-date/time/date-time too (they previously had none). +(register-host-methods! "local-date" (list (cons "format" (lambda (x fmt) (fmt-format fmt x))))) +(register-host-methods! "local-time" (list (cons "format" (lambda (x fmt) (fmt-format fmt x))))) +(register-host-methods! "local-date-time" (list (cons "format" (lambda (x fmt) (fmt-format fmt x))))) +(register-host-methods! "instant" (list (cons "format" (lambda (x fmt) (fmt-format fmt x))))) + +;; extend the dt-formatter method table: .format routes java.time values through the +;; richer engine; .parse picks the value type from the parsed fields. +(register-host-methods! "dt-formatter" + (list (cons "format" (lambda (self d) (jt-format-pattern (fmt-pat self) d))) + (cons "getZone" (lambda (self) (jt-zone-id "Z" 0))) + (cons "getLocale" (lambda (self) (make-jhost "locale" (vector "en-US")))) + (cons "toString" (lambda (self) (fmt-pat self))))) + +;; DateTimeFormatter ISO constants (richer engine; the pattern strings drive parse + +;; format). Re-registers ofPattern so the format-aware Local*/parse statics see them. +(register-class-statics! "DateTimeFormatter" + (list (cons "ofPattern" (lambda (p . _) (mk-formatter (jt-str p)))) + (cons "ISO_LOCAL_DATE" (mk-formatter "yyyy-MM-dd")) + (cons "ISO_LOCAL_TIME" (mk-formatter "HH:mm:ss")) + (cons "ISO_LOCAL_DATE_TIME" (mk-formatter "yyyy-MM-dd'T'HH:mm:ss")) + (cons "ISO_DATE" (mk-formatter "yyyy-MM-dd")) + (cons "ISO_TIME" (mk-formatter "HH:mm:ss")) + (cons "ISO_DATE_TIME" (mk-formatter "yyyy-MM-dd'T'HH:mm:ss")) + (cons "ISO_INSTANT" (mk-formatter "yyyy-MM-dd'T'HH:mm:ssX")) + (cons "ISO_OFFSET_DATE_TIME" (mk-formatter "yyyy-MM-dd'T'HH:mm:ssXXX")) + (cons "ISO_OFFSET_TIME" (mk-formatter "HH:mm:ssXXX")) + (cons "ISO_OFFSET_DATE" (mk-formatter "yyyy-MM-ddXXX")) + (cons "ISO_ZONED_DATE_TIME" (mk-formatter "yyyy-MM-dd'T'HH:mm:ssXXX")) + (cons "ISO_ORDINAL_DATE" (mk-formatter "yyyy-DDD")) + (cons "ISO_WEEK_DATE" (mk-formatter "yyyy-'W'ww-e")) + (cons "BASIC_ISO_DATE" (mk-formatter "yyyyMMdd")) + (cons "RFC_1123_DATE_TIME" (mk-formatter "EEE, dd MMM yyyy HH:mm:ss Z")))) + +;; Local*/parse with a formatter: parse via the pattern, then build the right value. +;; The parse path reuses inst-time.ss parse-ms (UTC) and reads back the fields. +(define (formatter-parse-fields fmt s) + (let ((ms (jinst-ms (parse-ms (fmt-pat fmt) (jt-str s))))) + (let ((ed (jt-floor-div (exact (truncate ms)) 86400000)) (nod (* (jt-floor-mod (exact (truncate ms)) 86400000) 1000000))) + (values ed nod)))) +(register-class-statics! "LocalDate" + (list (cons "parse" (lambda (s . fmt) + (if (null? fmt) (jt-local-date (parse-iso-date (jt-str s))) + (call-with-values (lambda () (formatter-parse-fields (car fmt) s)) (lambda (ed nod) (jt-local-date ed)))))))) +(register-class-statics! "LocalTime" + (list (cons "parse" (lambda (s . fmt) + (if (null? fmt) (jt-local-time (parse-iso-time (jt-str s))) + (call-with-values (lambda () (formatter-parse-fields (car fmt) s)) (lambda (ed nod) (jt-local-time nod)))))))) +(register-class-statics! "LocalDateTime" + (list (cons "parse" (lambda (s . fmt) + (if (null? fmt) + (call-with-values (lambda () (parse-iso-datetime (jt-str s))) (lambda (ed nod) (jt-local-dt ed nod))) + (call-with-values (lambda () (formatter-parse-fields (car fmt) s)) (lambda (ed nod) (jt-local-dt ed nod)))))))) + +;; --- ms-of / equality / hash / compare / print / instance? for Phase-3 types -- +;; extend ms-of so ZonedDateTime/OffsetDateTime/OffsetTime route through to an epoch-ms. +(define %p3-ms-of ms-of) +(set! ms-of (lambda (d) + (cond ((jt-zoned-dt? d) (zdt->ms d)) + ((jt-offset-dt? d) (odt->ms d)) + (else (%p3-ms-of d))))) + +(register-jt-value! "zone-offset" (lambda (x) (zo-id (zo-secs x))) (lambda (x) (jolt-hash (zo-secs x)))) +(register-jt-value! "zone-id" (lambda (x) (zid-id x)) (lambda (x) (jolt-hash (string-hash (zid-id x))))) +(register-str-render! jt-zoned-dt? zdt->string) (register-pr-arm! jt-zoned-dt? zdt->string) +(register-str-render! jt-offset-dt? odt->string) (register-pr-arm! jt-offset-dt? odt->string) +(register-str-render! jt-offset-time? ot->string) (register-pr-arm! jt-offset-time? ot->string) +(register-hash-arm! jt-zoned-dt? (lambda (x) (jolt-hash (zdt->ms x)))) +(register-hash-arm! jt-offset-dt? (lambda (x) (jolt-hash (odt->ms x)))) +(register-hash-arm! jt-offset-time? (lambda (x) (jolt-hash (ot-nod x)))) +(register-eq-arm! (lambda (a b) (or (jt-zoned-dt? a) (jt-zoned-dt? b))) + (lambda (a b) (and (jt-zoned-dt? a) (jt-zoned-dt? b) (equal? (jhost-state a) (jhost-state b))))) +(register-eq-arm! (lambda (a b) (or (jt-offset-dt? a) (jt-offset-dt? b))) + (lambda (a b) (and (jt-offset-dt? a) (jt-offset-dt? b) (equal? (jhost-state a) (jhost-state b))))) +(register-eq-arm! (lambda (a b) (or (jt-offset-time? a) (jt-offset-time? b))) + (lambda (a b) (and (jt-offset-time? a) (jt-offset-time? b) (equal? (jhost-state a) (jhost-state b))))) + +;; compare for Phase-3 types (same-type only). +(define %p3-prev-compare jolt-compare) +(set! jolt-compare + (lambda (a b) + (cond + ((and (jt-zoned-dt? a) (jt-zoned-dt? b)) (let ((x (zdt->ms a)) (y (zdt->ms b))) (cond ((< x y) -1) ((> x y) 1) (else 0)))) + ((and (jt-offset-dt? a) (jt-offset-dt? b)) (let ((x (odt->ms a)) (y (odt->ms b))) (cond ((< x y) -1) ((> x y) 1) (else 0)))) + ((and (jt-zone-offset? a) (jt-zone-offset? b)) (let ((x (zo-secs a)) (y (zo-secs b))) (cond ((< x y) -1) ((> x y) 1) (else 0)))) + ;; #inst (java.util.Date) values compare by epoch-ms. + ((and (jinst? a) (jinst? b)) (let ((x (jinst-ms a)) (y (jinst-ms b))) (cond ((< x y) -1) ((> x y) 1) (else 0)))) + (else (%p3-prev-compare a b))))) +(def-var! "clojure.core" "compare" jolt-compare) + +;; instance? for the Phase-3 tags. +(register-instance-check-arm! + (lambda (type-sym val) + (let ((tn (short-class-name (symbol-t-name type-sym)))) + (cond + ((jt-zone-offset? val) (if (member tn '("ZoneOffset" "ZoneId")) #t 'pass)) + ((jt-zone-id? val) (if (string=? tn "ZoneId") #t 'pass)) + ((jt-zoned-dt? val) (if (string=? tn "ZonedDateTime") #t 'pass)) + ((jt-offset-dt? val) (if (string=? tn "OffsetDateTime") #t 'pass)) + ((jt-offset-time? val) (if (string=? tn "OffsetTime") #t 'pass)) + ((and (jhost? val) (string=? (jhost-tag val) "clock")) (if (string=? tn "Clock") #t 'pass)) + ((and (jhost? val) (string=? (jhost-tag val) "dt-formatter")) (if (string=? tn "DateTimeFormatter") #t 'pass)) + ((and (jhost? val) (string=? (jhost-tag val) "temporal-adjuster")) (if (member tn '("TemporalAdjuster")) #t 'pass)) + (else 'pass))))) diff --git a/host/chez/records.ss b/host/chez/records.ss index 776fed6..aece738 100644 --- a/host/chez/records.ss +++ b/host/chez/records.ss @@ -152,6 +152,12 @@ ((and (jhost? obj) (string=? (jhost-tag obj) "year-month")) '("YearMonth" "java.time.YearMonth" "Object")) ((and (jhost? obj) (string=? (jhost-tag obj) "chrono-unit")) '("ChronoUnit" "java.time.temporal.ChronoUnit" "TemporalUnit" "java.time.temporal.TemporalUnit" "Object")) ((and (jhost? obj) (string=? (jhost-tag obj) "chrono-field")) '("ChronoField" "java.time.temporal.ChronoField" "TemporalField" "java.time.temporal.TemporalField" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "zone-offset")) '("ZoneOffset" "java.time.ZoneOffset" "ZoneId" "java.time.ZoneId" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "zone-id")) '("ZoneId" "java.time.ZoneId" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "zoned-date-time")) '("ZonedDateTime" "java.time.ZonedDateTime" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "offset-date-time")) '("OffsetDateTime" "java.time.OffsetDateTime" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "offset-time")) '("OffsetTime" "java.time.OffsetTime" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "clock")) '("Clock" "java.time.Clock" "Object")) ;; java.sql.Date — a distinct class from java.util.Date so a protocol ;; extended to both (data.json's JSONWriter) routes a sql.Date to its impl. ((and (jhost? obj) (string=? (jhost-tag obj) "sql-date")) '("java.sql.Date" "Date" "java.util.Date" "Object")) @@ -206,7 +212,12 @@ "ASeq" "ISeq" "IPersistentCollection" "Associative" "Sequential" "Map" "java.util.Map" "List" "java.util.List" "Set" "java.util.Set" "Collection" "java.util.Collection" - "UUID" "BigDecimal" "Date" "Timestamp" "Instant" "java.sql.Date")) + "UUID" "BigDecimal" "Date" "Timestamp" "Instant" "java.sql.Date" + ;; java.time value types (extend-protocol Duration / ZonedDateTime / …) + "Duration" "Period" "LocalDate" "LocalTime" "LocalDateTime" + "ZonedDateTime" "OffsetDateTime" "OffsetTime" "ZoneId" "ZoneOffset" + "Clock" "Year" "YearMonth" "Month" "DayOfWeek" + "ChronoUnit" "ChronoField" "TemporalAmount" "TemporalUnit" "TemporalField")) h)) (define (strip-prefix s p) (let ((pl (string-length p))) diff --git a/host/chez/seed/prelude.ss b/host/chez/seed/prelude.ss index 8268e14..fa339a6 100644 --- a/host/chez/seed/prelude.ss +++ b/host/chez/seed/prelude.ss @@ -47,7 +47,7 @@ (lambda syms (let fnrec4392 ((syms (list->cseq syms))) (let* ((_a$4397 (var-deref "clojure.core" "__sqcat")) (_a$4398 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "do"))) (_a$4399 (jolt-map (lambda (s) (let fnrec4393 ((s s)) (let* ((_a$4394 (var-deref "clojure.core" "__sqcat")) (_a$4395 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "def"))) (_a$4396 (jolt-invoke (var-deref "clojure.core" "__sq1") s))) (jolt-invoke _a$4394 _a$4395 _a$4396)))) syms))) (jolt-invoke _a$4397 _a$4398 _a$4399))))) (mark-macro! "clojure.core" "declare")) (guard (e (#t #f)) - (def-var! "clojure.core" "destructure" (letrec ((destructure (lambda (bindings) (let fnrec4400 ((bindings bindings)) (let* ((find-or (lambda (or-map nm) (let fnrec4401 ((or-map or-map) (nm nm)) (let* ((_a$4407 (lambda (acc k) (let fnrec4402 ((acc acc) (k k)) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "clojure.core" "symbol?") k))) (if (jolt-truthy? and__25__auto) (jolt= nm (jolt-invoke (var-deref "clojure.core" "name") k)) and__25__auto))) (let* ((_o$4403 #t) (_o$4404 (jolt-get or-map k))) (jolt-vector _o$4403 _o$4404)) acc)))) (_a$4408 (let* ((_o$4405 #f) (_o$4406 jolt-nil)) (jolt-vector _o$4405 _o$4406))) (_a$4409 (if (jolt-truthy? or-map) (jolt-keys or-map) (jolt-vector)))) (jolt-reduce _a$4407 _a$4408 _a$4409))))) (amp? (lambda (x) (let fnrec4410 ((x x)) (let* ((and__25__auto (jolt-invoke (var-deref "clojure.core" "symbol?") x))) (if (jolt-truthy? and__25__auto) (jolt= "&" (jolt-invoke (var-deref "clojure.core" "name") x)) and__25__auto))))) (proc (letrec ((proc (lambda (pat init acc) (let fnrec4411 ((pat pat) (init init) (acc acc)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "symbol?") pat)) (jolt-conj (jolt-conj acc pat) init) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "vector?") pat)) (let* ((g (jolt-invoke (var-deref "clojure.core" "symbol") (jolt-invoke (var-deref "clojure.core" "str") (jolt-invoke (var-deref "clojure.core" "gensym"))))) (n (jolt-count pat)) (vloop (letrec ((vloop (lambda (i idx a) (let fnrec4412 ((i i) (idx idx) (a a)) (if (< i n) (let* ((elem (jolt-nth pat i))) (if (jolt-truthy? (jolt-invoke amp? elem)) (let* ((_a$4421 vloop) (_a$4422 (+ i 2)) (_a$4423 idx) (_a$4424 (let* ((_a$4417 proc) (_a$4418 (jolt-nth pat (jolt-inc i))) (_a$4419 (let* ((_a$4413 (var-deref "clojure.core" "__sqcat")) (_a$4414 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "nthnext"))) (_a$4415 (jolt-invoke (var-deref "clojure.core" "__sq1") g)) (_a$4416 (jolt-invoke (var-deref "clojure.core" "__sq1") idx))) (jolt-invoke _a$4413 _a$4414 _a$4415 _a$4416))) (_a$4420 a)) (jolt-invoke _a$4417 _a$4418 _a$4419 _a$4420)))) (jolt-invoke _a$4421 _a$4422 _a$4423 _a$4424)) (if (jolt= elem (keyword #f "as")) (let* ((_a$4425 vloop) (_a$4426 (+ i 2)) (_a$4427 idx) (_a$4428 (jolt-invoke proc (jolt-nth pat (jolt-inc i)) g a))) (jolt-invoke _a$4425 _a$4426 _a$4427 _a$4428)) (if (jolt-truthy? (keyword #f "else")) (let* ((_a$4434 vloop) (_a$4435 (jolt-inc i)) (_a$4436 (jolt-inc idx)) (_a$4437 (jolt-invoke proc elem (let* ((_a$4429 (var-deref "clojure.core" "__sqcat")) (_a$4430 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "nth"))) (_a$4431 (jolt-invoke (var-deref "clojure.core" "__sq1") g)) (_a$4432 (jolt-invoke (var-deref "clojure.core" "__sq1") idx)) (_a$4433 (jolt-invoke (var-deref "clojure.core" "__sq1") jolt-nil))) (jolt-invoke _a$4429 _a$4430 _a$4431 _a$4432 _a$4433)) a))) (jolt-invoke _a$4434 _a$4435 _a$4436 _a$4437)) jolt-nil)))) a))))) vloop))) (jolt-invoke vloop 0 0 (jolt-conj (jolt-conj acc g) init))) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "map?") pat)) (let* ((g (jolt-invoke (var-deref "clojure.core" "symbol") (jolt-invoke (var-deref "clojure.core" "str") (jolt-invoke (var-deref "clojure.core" "gensym"))))) (gm (jolt-invoke (var-deref "clojure.core" "symbol") (jolt-invoke (var-deref "clojure.core" "str") (jolt-invoke (var-deref "clojure.core" "gensym"))))) (coerce (let* ((_a$4470 (var-deref "clojure.core" "__sqcat")) (_a$4471 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "if"))) (_a$4472 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4438 (var-deref "clojure.core" "__sqcat")) (_a$4439 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "sequential?"))) (_a$4440 (jolt-invoke (var-deref "clojure.core" "__sq1") g))) (jolt-invoke _a$4438 _a$4439 _a$4440)))) (_a$4473 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4465 (var-deref "clojure.core" "__sqcat")) (_a$4466 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "if"))) (_a$4467 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4454 (var-deref "clojure.core" "__sqcat")) (_a$4455 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "and"))) (_a$4456 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4444 (var-deref "clojure.core" "__sqcat")) (_a$4445 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "="))) (_a$4446 (jolt-invoke (var-deref "clojure.core" "__sq1") 1)) (_a$4447 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4441 (var-deref "clojure.core" "__sqcat")) (_a$4442 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "count"))) (_a$4443 (jolt-invoke (var-deref "clojure.core" "__sq1") g))) (jolt-invoke _a$4441 _a$4442 _a$4443))))) (jolt-invoke _a$4444 _a$4445 _a$4446 _a$4447)))) (_a$4457 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4451 (var-deref "clojure.core" "__sqcat")) (_a$4452 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "map?"))) (_a$4453 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4448 (var-deref "clojure.core" "__sqcat")) (_a$4449 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "first"))) (_a$4450 (jolt-invoke (var-deref "clojure.core" "__sq1") g))) (jolt-invoke _a$4448 _a$4449 _a$4450))))) (jolt-invoke _a$4451 _a$4452 _a$4453))))) (jolt-invoke _a$4454 _a$4455 _a$4456 _a$4457)))) (_a$4468 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4458 (var-deref "clojure.core" "__sqcat")) (_a$4459 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "first"))) (_a$4460 (jolt-invoke (var-deref "clojure.core" "__sq1") g))) (jolt-invoke _a$4458 _a$4459 _a$4460)))) (_a$4469 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4461 (var-deref "clojure.core" "__sqcat")) (_a$4462 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "apply"))) (_a$4463 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "hash-map"))) (_a$4464 (jolt-invoke (var-deref "clojure.core" "__sq1") g))) (jolt-invoke _a$4461 _a$4462 _a$4463 _a$4464))))) (jolt-invoke _a$4465 _a$4466 _a$4467 _a$4468 _a$4469)))) (_a$4474 (jolt-invoke (var-deref "clojure.core" "__sq1") g))) (jolt-invoke _a$4470 _a$4471 _a$4472 _a$4473 _a$4474))) (or-map (jolt-get pat (keyword #f "or"))) (as-sym (jolt-get pat (keyword #f "as"))) (bound (jolt-conj (jolt-conj (jolt-conj (jolt-conj acc g) init) gm) coerce)) (base (if (jolt-truthy? as-sym) (jolt-conj (jolt-conj bound as-sym) gm) bound)) (group (lambda (a kw kind) (let fnrec4475 ((a a) (kw kw) (kind kind)) (let* ((names (jolt-get pat kw))) (if (jolt-truthy? names) (jolt-reduce (lambda (aa s) (let fnrec4476 ((aa aa) (s s)) (let* ((local (jolt-invoke (var-deref "clojure.core" "name") s)) (nsp (jolt-invoke (var-deref "clojure.core" "namespace") s)) (keyform (if (jolt= kind (keyword #f "kw")) (jolt-invoke (var-deref "clojure.core" "keyword") (if (jolt-truthy? nsp) (jolt-invoke (var-deref "clojure.core" "str") nsp "/" local) local)) (if (jolt= kind (keyword #f "str")) local (if (jolt-truthy? (keyword #f "else")) (let* ((_a$4477 (var-deref "clojure.core" "__sqcat")) (_a$4478 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "quote"))) (_a$4479 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "symbol") nsp local)))) (jolt-invoke _a$4477 _a$4478 _a$4479)) jolt-nil)))) (fo (jolt-invoke find-or or-map local))) (let* ((_a$4489 (jolt-conj aa (jolt-invoke (var-deref "clojure.core" "symbol") local))) (_a$4490 (if (jolt-truthy? (jolt-nth fo 0)) (let* ((_a$4480 (var-deref "clojure.core" "__sqcat")) (_a$4481 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "get"))) (_a$4482 (jolt-invoke (var-deref "clojure.core" "__sq1") gm)) (_a$4483 (jolt-invoke (var-deref "clojure.core" "__sq1") keyform)) (_a$4484 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-nth fo 1)))) (jolt-invoke _a$4480 _a$4481 _a$4482 _a$4483 _a$4484)) (let* ((_a$4485 (var-deref "clojure.core" "__sqcat")) (_a$4486 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "get"))) (_a$4487 (jolt-invoke (var-deref "clojure.core" "__sq1") gm)) (_a$4488 (jolt-invoke (var-deref "clojure.core" "__sq1") keyform))) (jolt-invoke _a$4485 _a$4486 _a$4487 _a$4488))))) (jolt-conj _a$4489 _a$4490))))) a names) a))))) (g1 (jolt-invoke group base (keyword #f "keys") (keyword #f "kw"))) (g2 (jolt-invoke group g1 (keyword #f "strs") (keyword #f "str"))) (g3 (jolt-invoke group g2 (keyword #f "syms") (keyword #f "sym")))) (let* ((_a$4496 (lambda (a k) (let fnrec4491 ((a a) (k k)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "keyword?") k)) a (jolt-invoke proc k (let* ((_a$4492 (var-deref "clojure.core" "__sqcat")) (_a$4493 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "get"))) (_a$4494 (jolt-invoke (var-deref "clojure.core" "__sq1") gm)) (_a$4495 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-get pat k)))) (jolt-invoke _a$4492 _a$4493 _a$4494 _a$4495)) a))))) (_a$4497 g3) (_a$4498 (jolt-keys pat))) (jolt-reduce _a$4496 _a$4497 _a$4498))) (if (jolt-truthy? (keyword #f "else")) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "unsupported destructuring pattern: " (jolt-invoke (var-deref "clojure.core" "pr-str") pat))) jolt-nil)))))))) proc)) (ploop (letrec ((ploop (lambda (i acc) (let fnrec4499 ((i i) (acc acc)) (if (< i (jolt-count bindings)) (let* ((_a$4504 ploop) (_a$4505 (+ i 2)) (_a$4506 (let* ((_a$4500 proc) (_a$4501 (jolt-nth bindings i)) (_a$4502 (jolt-nth bindings (jolt-inc i))) (_a$4503 acc)) (jolt-invoke _a$4500 _a$4501 _a$4502 _a$4503)))) (jolt-invoke _a$4504 _a$4505 _a$4506)) acc))))) ploop))) (jolt-invoke ploop 0 (jolt-vector))))))) destructure))) + (def-var! "clojure.core" "destructure" (letrec ((destructure (lambda (bindings) (let fnrec4400 ((bindings bindings)) (let* ((find-or (lambda (or-map nm) (let fnrec4401 ((or-map or-map) (nm nm)) (let* ((_a$4407 (lambda (acc k) (let fnrec4402 ((acc acc) (k k)) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "clojure.core" "symbol?") k))) (if (jolt-truthy? and__25__auto) (jolt= nm (jolt-invoke (var-deref "clojure.core" "name") k)) and__25__auto))) (let* ((_o$4403 #t) (_o$4404 (jolt-get or-map k))) (jolt-vector _o$4403 _o$4404)) acc)))) (_a$4408 (let* ((_o$4405 #f) (_o$4406 jolt-nil)) (jolt-vector _o$4405 _o$4406))) (_a$4409 (if (jolt-truthy? or-map) (jolt-keys or-map) (jolt-vector)))) (jolt-reduce _a$4407 _a$4408 _a$4409))))) (amp? (lambda (x) (let fnrec4410 ((x x)) (let* ((and__25__auto (jolt-invoke (var-deref "clojure.core" "symbol?") x))) (if (jolt-truthy? and__25__auto) (jolt= "&" (jolt-invoke (var-deref "clojure.core" "name") x)) and__25__auto))))) (proc (letrec ((proc (lambda (pat init acc) (let fnrec4411 ((pat pat) (init init) (acc acc)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "symbol?") pat)) (jolt-conj (jolt-conj acc pat) init) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "vector?") pat)) (let* ((g (jolt-invoke (var-deref "clojure.core" "symbol") (jolt-invoke (var-deref "clojure.core" "str") (jolt-invoke (var-deref "clojure.core" "gensym"))))) (n (jolt-count pat)) (vloop (letrec ((vloop (lambda (i idx a) (let fnrec4412 ((i i) (idx idx) (a a)) (if (< i n) (let* ((elem (jolt-nth pat i))) (if (jolt-truthy? (jolt-invoke amp? elem)) (let* ((_a$4421 vloop) (_a$4422 (+ i 2)) (_a$4423 idx) (_a$4424 (let* ((_a$4417 proc) (_a$4418 (jolt-nth pat (jolt-inc i))) (_a$4419 (let* ((_a$4413 (var-deref "clojure.core" "__sqcat")) (_a$4414 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "nthnext"))) (_a$4415 (jolt-invoke (var-deref "clojure.core" "__sq1") g)) (_a$4416 (jolt-invoke (var-deref "clojure.core" "__sq1") idx))) (jolt-invoke _a$4413 _a$4414 _a$4415 _a$4416))) (_a$4420 a)) (jolt-invoke _a$4417 _a$4418 _a$4419 _a$4420)))) (jolt-invoke _a$4421 _a$4422 _a$4423 _a$4424)) (if (jolt= elem (keyword #f "as")) (let* ((_a$4425 vloop) (_a$4426 (+ i 2)) (_a$4427 idx) (_a$4428 (jolt-invoke proc (jolt-nth pat (jolt-inc i)) g a))) (jolt-invoke _a$4425 _a$4426 _a$4427 _a$4428)) (if (jolt-truthy? (keyword #f "else")) (let* ((_a$4434 vloop) (_a$4435 (jolt-inc i)) (_a$4436 (jolt-inc idx)) (_a$4437 (jolt-invoke proc elem (let* ((_a$4429 (var-deref "clojure.core" "__sqcat")) (_a$4430 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "nth"))) (_a$4431 (jolt-invoke (var-deref "clojure.core" "__sq1") g)) (_a$4432 (jolt-invoke (var-deref "clojure.core" "__sq1") idx)) (_a$4433 (jolt-invoke (var-deref "clojure.core" "__sq1") jolt-nil))) (jolt-invoke _a$4429 _a$4430 _a$4431 _a$4432 _a$4433)) a))) (jolt-invoke _a$4434 _a$4435 _a$4436 _a$4437)) jolt-nil)))) a))))) vloop))) (jolt-invoke vloop 0 0 (jolt-conj (jolt-conj acc g) init))) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "map?") pat)) (let* ((g (jolt-invoke (var-deref "clojure.core" "symbol") (jolt-invoke (var-deref "clojure.core" "str") (jolt-invoke (var-deref "clojure.core" "gensym"))))) (gm (jolt-invoke (var-deref "clojure.core" "symbol") (jolt-invoke (var-deref "clojure.core" "str") (jolt-invoke (var-deref "clojure.core" "gensym"))))) (coerce (let* ((_a$4470 (var-deref "clojure.core" "__sqcat")) (_a$4471 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "if"))) (_a$4472 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4438 (var-deref "clojure.core" "__sqcat")) (_a$4439 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "sequential?"))) (_a$4440 (jolt-invoke (var-deref "clojure.core" "__sq1") g))) (jolt-invoke _a$4438 _a$4439 _a$4440)))) (_a$4473 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4465 (var-deref "clojure.core" "__sqcat")) (_a$4466 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "if"))) (_a$4467 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4454 (var-deref "clojure.core" "__sqcat")) (_a$4455 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "and"))) (_a$4456 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4444 (var-deref "clojure.core" "__sqcat")) (_a$4445 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "="))) (_a$4446 (jolt-invoke (var-deref "clojure.core" "__sq1") 1)) (_a$4447 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4441 (var-deref "clojure.core" "__sqcat")) (_a$4442 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "count"))) (_a$4443 (jolt-invoke (var-deref "clojure.core" "__sq1") g))) (jolt-invoke _a$4441 _a$4442 _a$4443))))) (jolt-invoke _a$4444 _a$4445 _a$4446 _a$4447)))) (_a$4457 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4451 (var-deref "clojure.core" "__sqcat")) (_a$4452 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "map?"))) (_a$4453 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4448 (var-deref "clojure.core" "__sqcat")) (_a$4449 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "first"))) (_a$4450 (jolt-invoke (var-deref "clojure.core" "__sq1") g))) (jolt-invoke _a$4448 _a$4449 _a$4450))))) (jolt-invoke _a$4451 _a$4452 _a$4453))))) (jolt-invoke _a$4454 _a$4455 _a$4456 _a$4457)))) (_a$4468 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4458 (var-deref "clojure.core" "__sqcat")) (_a$4459 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "first"))) (_a$4460 (jolt-invoke (var-deref "clojure.core" "__sq1") g))) (jolt-invoke _a$4458 _a$4459 _a$4460)))) (_a$4469 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$4461 (var-deref "clojure.core" "__sqcat")) (_a$4462 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "apply"))) (_a$4463 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "hash-map"))) (_a$4464 (jolt-invoke (var-deref "clojure.core" "__sq1") g))) (jolt-invoke _a$4461 _a$4462 _a$4463 _a$4464))))) (jolt-invoke _a$4465 _a$4466 _a$4467 _a$4468 _a$4469)))) (_a$4474 (jolt-invoke (var-deref "clojure.core" "__sq1") g))) (jolt-invoke _a$4470 _a$4471 _a$4472 _a$4473 _a$4474))) (or-map (jolt-get pat (keyword #f "or"))) (as-sym (jolt-get pat (keyword #f "as"))) (bound (jolt-conj (jolt-conj (jolt-conj (jolt-conj acc g) init) gm) coerce)) (base (if (jolt-truthy? as-sym) (jolt-conj (jolt-conj bound as-sym) gm) bound)) (group (letrec ((group (lambda (a names kind dnsp) (let fnrec4475 ((a a) (names names) (kind kind) (dnsp dnsp)) (if (jolt-truthy? names) (jolt-reduce (lambda (aa s) (let fnrec4476 ((aa aa) (s s)) (let* ((local (jolt-invoke (var-deref "clojure.core" "name") s)) (nsp (let* ((or__26__auto (jolt-invoke (var-deref "clojure.core" "namespace") s))) (if (jolt-truthy? or__26__auto) or__26__auto dnsp))) (keyform (if (jolt= kind (keyword #f "kw")) (jolt-invoke (var-deref "clojure.core" "keyword") (if (jolt-truthy? nsp) (jolt-invoke (var-deref "clojure.core" "str") nsp "/" local) local)) (if (jolt= kind (keyword #f "str")) local (if (jolt-truthy? (keyword #f "else")) (let* ((_a$4477 (var-deref "clojure.core" "__sqcat")) (_a$4478 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "quote"))) (_a$4479 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "symbol") nsp local)))) (jolt-invoke _a$4477 _a$4478 _a$4479)) jolt-nil)))) (fo (jolt-invoke find-or or-map local))) (let* ((_a$4489 (jolt-conj aa (jolt-invoke (var-deref "clojure.core" "symbol") local))) (_a$4490 (if (jolt-truthy? (jolt-nth fo 0)) (let* ((_a$4480 (var-deref "clojure.core" "__sqcat")) (_a$4481 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "get"))) (_a$4482 (jolt-invoke (var-deref "clojure.core" "__sq1") gm)) (_a$4483 (jolt-invoke (var-deref "clojure.core" "__sq1") keyform)) (_a$4484 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-nth fo 1)))) (jolt-invoke _a$4480 _a$4481 _a$4482 _a$4483 _a$4484)) (let* ((_a$4485 (var-deref "clojure.core" "__sqcat")) (_a$4486 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "get"))) (_a$4487 (jolt-invoke (var-deref "clojure.core" "__sq1") gm)) (_a$4488 (jolt-invoke (var-deref "clojure.core" "__sq1") keyform))) (jolt-invoke _a$4485 _a$4486 _a$4487 _a$4488))))) (jolt-conj _a$4489 _a$4490))))) a names) a))))) group)) (g1 (jolt-invoke group base (jolt-get pat (keyword #f "keys")) (keyword #f "kw") jolt-nil)) (g2 (jolt-invoke group g1 (jolt-get pat (keyword #f "strs")) (keyword #f "str") jolt-nil)) (g3 (jolt-invoke group g2 (jolt-get pat (keyword #f "syms")) (keyword #f "sym") jolt-nil))) (let* ((_a$4496 (lambda (a k) (let fnrec4491 ((a a) (k k)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "keyword?") k)) (let* ((kn (jolt-invoke (var-deref "clojure.core" "name") k)) (kns (jolt-invoke (var-deref "clojure.core" "namespace") k))) (if (jolt-truthy? (let* ((and__25__auto kns)) (if (jolt-truthy? and__25__auto) (jolt= kn "keys") and__25__auto))) (jolt-invoke group a (jolt-get pat k) (keyword #f "kw") kns) (if (jolt-truthy? (let* ((and__25__auto kns)) (if (jolt-truthy? and__25__auto) (jolt= kn "strs") and__25__auto))) (jolt-invoke group a (jolt-get pat k) (keyword #f "str") kns) (if (jolt-truthy? (let* ((and__25__auto kns)) (if (jolt-truthy? and__25__auto) (jolt= kn "syms") and__25__auto))) (jolt-invoke group a (jolt-get pat k) (keyword #f "sym") kns) (if (jolt-truthy? (keyword #f "else")) a jolt-nil))))) (jolt-invoke proc k (let* ((_a$4492 (var-deref "clojure.core" "__sqcat")) (_a$4493 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "get"))) (_a$4494 (jolt-invoke (var-deref "clojure.core" "__sq1") gm)) (_a$4495 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-get pat k)))) (jolt-invoke _a$4492 _a$4493 _a$4494 _a$4495)) a))))) (_a$4497 g3) (_a$4498 (jolt-keys pat))) (jolt-reduce _a$4496 _a$4497 _a$4498))) (if (jolt-truthy? (keyword #f "else")) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "unsupported destructuring pattern: " (jolt-invoke (var-deref "clojure.core" "pr-str") pat))) jolt-nil)))))))) proc)) (ploop (letrec ((ploop (lambda (i acc) (let fnrec4499 ((i i) (acc acc)) (if (< i (jolt-count bindings)) (let* ((_a$4504 ploop) (_a$4505 (+ i 2)) (_a$4506 (let* ((_a$4500 proc) (_a$4501 (jolt-nth bindings i)) (_a$4502 (jolt-nth bindings (jolt-inc i))) (_a$4503 acc)) (jolt-invoke _a$4500 _a$4501 _a$4502 _a$4503)))) (jolt-invoke _a$4504 _a$4505 _a$4506)) acc))))) ploop))) (jolt-invoke ploop 0 (jolt-vector))))))) destructure))) (guard (e (#t #f)) (def-var! "clojure.core" "let" (lambda (bindings . body) (let fnrec4507 ((bindings bindings) (body (list->cseq body))) (let* ((_a$4508 (var-deref "clojure.core" "__sqcat")) (_a$4509 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "let*"))) (_a$4510 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") (jolt-invoke (var-deref "clojure.core" "destructure") bindings)))) (_a$4511 body)) (jolt-invoke _a$4508 _a$4509 _a$4510 _a$4511))))) diff --git a/jolt-core/clojure/core/00-syntax.clj b/jolt-core/clojure/core/00-syntax.clj index e92a8c0..4e3bad9 100644 --- a/jolt-core/clojure/core/00-syntax.clj +++ b/jolt-core/clojure/core/00-syntax.clj @@ -217,17 +217,19 @@ as-sym (get pat :as) bound (conj (conj (conj (conj acc g) init) gm) coerce) base (if as-sym (conj (conj bound as-sym) gm) bound) + ;; group binds a :keys/:strs/:syms list. dnsp is the destructuring + ;; namespace from a qualified key like :ns/keys — it both prefixes + ;; the lookup key and overrides a bare symbol's namespace. group - (fn* [a kw kind] - (let* [names (get pat kw)] - (if names + (fn* group [a names kind dnsp] + (if names (reduce ;; s is a symbol (a b) or a keyword (:a :b); name/ ;; namespace handle both, so :keys [:major] binds ;; `major` looking up :major (str would keep the colon). (fn* [aa s] (let* [local (name s) - nsp (namespace s) + nsp (or (namespace s) dnsp) keyform (cond (= kind :kw) (keyword (if nsp (str nsp "/" local) local)) (= kind :str) local @@ -238,13 +240,21 @@ `(get ~gm ~keyform ~(nth fo 1)) `(get ~gm ~keyform))))) a names) - a))) - g1 (group base :keys :kw) - g2 (group g1 :strs :str) - g3 (group g2 :syms :sym)] + a)) + g1 (group base (get pat :keys) :kw nil) + g2 (group g1 (get pat :strs) :str nil) + g3 (group g2 (get pat :syms) :sym nil)] + ;; remaining keys: a qualified :ns/keys|:ns/strs|:ns/syms groups under + ;; its namespace; any other keyword is skipped; a non-keyword is a + ;; nested binding pattern. (reduce (fn* [a k] (if (keyword? k) - a + (let* [kn (name k) kns (namespace k)] + (cond + (and kns (= kn "keys")) (group a (get pat k) :kw kns) + (and kns (= kn "strs")) (group a (get pat k) :str kns) + (and kns (= kn "syms")) (group a (get pat k) :sym kns) + :else a)) (proc k `(get ~gm ~(get pat k)) a))) g3 (keys pat))) :else (throw (str "unsupported destructuring pattern: " (pr-str pat))))) diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index f48333a..713ac64 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -3023,4 +3023,16 @@ {:suite "interop / java.time" :label "ChronoUnit DAYS between" :expected "14" :actual "(.between java.time.temporal.ChronoUnit/DAYS (java.time.LocalDate/of 2020 1 1) (java.time.LocalDate/of 2020 1 15))"} {:suite "interop / java.time" :label "LocalDate plus ChronoUnit DAYS" :expected "\"2020-01-04\"" :actual "(str (.plus (java.time.LocalDate/of 2020 1 1) 3 java.time.temporal.ChronoUnit/DAYS))"} {:suite "interop / java.time" :label "LocalDate until ChronoUnit DAYS" :expected "31" :actual "(.until (java.time.LocalDate/of 2020 1 1) (java.time.LocalDate/of 2020 2 1) java.time.temporal.ChronoUnit/DAYS)"} + {:suite "interop / java.time" :label "ZoneOffset ofHoursMinutes toString" :expected "\"+02:00\"" :actual "(str (java.time.ZoneOffset/ofHoursMinutes 2 0))"} + {:suite "interop / java.time" :label "ZoneOffset ofTotalSeconds toString" :expected "\"-04:30\"" :actual "(str (java.time.ZoneOffset/ofTotalSeconds -16200))"} + {:suite "interop / java.time" :label "ZoneOffset UTC toString" :expected "\"Z\"" :actual "(str java.time.ZoneOffset/UTC)"} + {:suite "interop / java.time" :label "ZoneOffset of getTotalSeconds" :expected "7200" :actual "(.getTotalSeconds (java.time.ZoneOffset/of \"+02:00\"))"} + {:suite "interop / java.time" :label "ZoneOffset ofHoursMinutes negative" :expected "\"-04:30\"" :actual "(.getId (java.time.ZoneOffset/ofHoursMinutes -4 -30))"} + {:suite "interop / java.time" :label "OffsetDateTime toInstant" :expected "\"2020-01-15T08:30:00Z\"" :actual "(str (.toInstant (java.time.OffsetDateTime/of 2020 1 15 10 30 0 0 (java.time.ZoneOffset/ofHours 2))))"} + {:suite "interop / java.time" :label "OffsetDateTime toString" :expected "\"2020-01-15T10:30+02:00\"" :actual "(str (java.time.OffsetDateTime/of 2020 1 15 10 30 0 0 (java.time.ZoneOffset/ofHours 2)))"} + {:suite "interop / java.time" :label "ZonedDateTime withZoneSameInstant UTC" :expected "\"2020-01-15T08:30Z\"" :actual "(str (.withZoneSameInstant (java.time.ZonedDateTime/parse \"2020-01-15T10:30:00+02:00[Europe/Paris]\") java.time.ZoneOffset/UTC))"} + {:suite "interop / java.time" :label "ZonedDateTime of toInstant fixed offset" :expected "\"2020-01-15T08:30:00Z\"" :actual "(str (.toInstant (java.time.ZonedDateTime/of 2020 1 15 10 30 0 0 (java.time.ZoneId/of \"+02:00\"))))"} + {:suite "interop / java.time" :label "DateTimeFormatter ofPattern format" :expected "\"2020-01-15 10:30:00\"" :actual "(.format (java.time.format.DateTimeFormatter/ofPattern \"yyyy-MM-dd HH:mm:ss\") (java.time.LocalDateTime/of 2020 1 15 10 30 0))"} + {:suite "interop / java.time" :label "ISO_LOCAL_DATE_TIME format" :expected "\"2020-01-15T10:30:00\"" :actual "(.format java.time.format.DateTimeFormatter/ISO_LOCAL_DATE_TIME (java.time.LocalDateTime/of 2020 1 15 10 30 0))"} + {:suite "interop / java.time" :label "ISO_OFFSET_DATE_TIME format" :expected "\"2020-01-15T10:30:00+02:00\"" :actual "(.format java.time.format.DateTimeFormatter/ISO_OFFSET_DATE_TIME (java.time.OffsetDateTime/of 2020 1 15 10 30 0 0 (java.time.ZoneOffset/ofHours 2)))"} ]