From a05eeefb0825e6a7d512a18d7e933809a3f48582 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Wed, 24 Jun 2026 18:45:46 -0400 Subject: [PATCH] =?UTF-8?q?java.time=20Phase=203:=20zones,=20offsets,=20Zo?= =?UTF-8?q?nedDateTime,=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)))"} ]