From e3c14e656c9ab4b612c61978eade49bb64be5bff Mon Sep 17 00:00:00 2001 From: Yogthos Date: Wed, 24 Jun 2026 18:10:40 -0400 Subject: [PATCH] java.time Phase 2: Duration/Period, enums, ChronoUnit/Field machinery MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Duration (ISO PT.. toString, between, full arithmetic), Period (between with borrow, P.. toString, normalized), full Month/DayOfWeek enums (named constants, print as their name — fixes the Phase-1 raw-jhost print), Year, YearMonth (2020-02 toString, leap, atDay/atEndOfMonth), ChronoUnit (between/getDuration) and ChronoField. The temporal machinery on the Phase-1 types now works with ChronoUnit/ChronoField: (.plus t n DAYS), (.until t1 t2 unit), (.get/.getLong t field), (.with t field v), (.isSupported ..), (.truncatedTo ..). Analyzer: (. Class method args) with a class target lowers to a static call (Class/method args) instead of mis-dispatching as an instance call on the arg — matches JVM; needed by cljc.java-time.year. Seed re-minted; selfhost holds. The Phase-2 cljc.java-time namespaces load; tick.core advances to a Phase-3 zone gap. 10 corpus rows certified vs JVM. make test + shakesmoke green, 0 new divergences, data.json stays 138/139. --- host/chez/java-time.ss | 743 +++++++++++++++++++++++++++++++++++- host/chez/records.ss | 8 + host/chez/seed/image.ss | 12 +- jolt-core/jolt/analyzer.clj | 15 +- test/chez/corpus.edn | 12 + 5 files changed, 773 insertions(+), 17 deletions(-) diff --git a/host/chez/java-time.ss b/host/chez/java-time.ss index 7e6837e..b5ae1b1 100644 --- a/host/chez/java-time.ss +++ b/host/chez/java-time.ss @@ -453,17 +453,707 @@ (cons "toString" (lambda (x) (iso-instant-str (inst-ms x)))))) ;; --- Month / DayOfWeek enums (returned by getMonth / getDayOfWeek) ----------- -;; minimal: name / getValue / toString, plus the static value fields cljc.java-time -;; might def at load (java.time.Month/JANUARY etc. — not needed by the four core nses -;; but harmless to provide). +(define (jt-month n) (make-jhost "month-enum" (vector n))) +(define (jt-dow n) (make-jhost "dow-enum" (vector n))) +(define (month-val e) (vector-ref (jhost-state e) 0)) +(define (dow-val e) (vector-ref (jhost-state e) 0)) +(define (month-name n) (vector-ref jt-month-names (- n 1))) +(define (dow-name n) (vector-ref jt-day-names (- n 1))) +;; quarter starts: Jan/Apr/Jul/Oct. +(define (month-quarter-start m) (+ 1 (* 3 (quotient (- m 1) 3)))) +;; day-of-year of the first day of month m (non-leap base; +1 from March on a leap year). +(define (month-first-day-of-year m leap) + (let ((cum (vector 0 0 31 59 90 120 151 181 212 243 273 304 334))) + (+ 1 (vector-ref cum m) (if (and leap (> m 2)) 1 0)))) + (register-host-methods! "month-enum" - (list (cons "getValue" (lambda (e) (vector-ref (jhost-state e) 0))) - (cons "name" (lambda (e) (vector-ref jt-month-names (- (vector-ref (jhost-state e) 0) 1)))) - (cons "toString" (lambda (e) (vector-ref jt-month-names (- (vector-ref (jhost-state e) 0) 1)))))) + (list (cons "getValue" (lambda (e) (month-val e))) + (cons "ordinal" (lambda (e) (- (month-val e) 1))) + (cons "name" (lambda (e) (month-name (month-val e)))) + (cons "toString" (lambda (e) (month-name (month-val e)))) + (cons "getDisplayName" (lambda (e . _) (month-name (month-val e)))) + (cons "plus" (lambda (e n) (jt-month (+ 1 (jt-floor-mod (+ (- (month-val e) 1) (jt->exact n)) 12))))) + (cons "minus" (lambda (e n) (jt-month (+ 1 (jt-floor-mod (- (- (month-val e) 1) (jt->exact n)) 12))))) + (cons "length" (lambda (e leap) (jt-len-of-month (if (jolt-truthy? leap) 4 1) (month-val e)))) + (cons "minLength" (lambda (e) (if (= (month-val e) 2) 28 (jt-len-of-month 1 (month-val e))))) + (cons "maxLength" (lambda (e) (if (= (month-val e) 2) 29 (jt-len-of-month 1 (month-val e))))) + (cons "firstMonthOfQuarter" (lambda (e) (jt-month (month-quarter-start (month-val e))))) + (cons "firstDayOfYear" (lambda (e leap) (month-first-day-of-year (month-val e) (jolt-truthy? leap)))) + (cons "compareTo" (lambda (e o) (- (month-val e) (month-val o)))) + (cons "equals" (lambda (e o) (and (jhost? o) (string=? (jhost-tag o) "month-enum") (= (month-val e) (month-val o))))) + (cons "hashCode" (lambda (e) (month-val e))))) (register-host-methods! "dow-enum" - (list (cons "getValue" (lambda (e) (vector-ref (jhost-state e) 0))) - (cons "name" (lambda (e) (vector-ref jt-day-names (- (vector-ref (jhost-state e) 0) 1)))) - (cons "toString" (lambda (e) (vector-ref jt-day-names (- (vector-ref (jhost-state e) 0) 1)))))) + (list (cons "getValue" (lambda (e) (dow-val e))) + (cons "ordinal" (lambda (e) (- (dow-val e) 1))) + (cons "name" (lambda (e) (dow-name (dow-val e)))) + (cons "toString" (lambda (e) (dow-name (dow-val e)))) + (cons "getDisplayName" (lambda (e . _) (dow-name (dow-val e)))) + (cons "plus" (lambda (e n) (jt-dow (+ 1 (jt-floor-mod (+ (- (dow-val e) 1) (jt->exact n)) 7))))) + (cons "minus" (lambda (e n) (jt-dow (+ 1 (jt-floor-mod (- (- (dow-val e) 1) (jt->exact n)) 7))))) + (cons "compareTo" (lambda (e o) (- (dow-val e) (dow-val o)))) + (cons "equals" (lambda (e o) (and (jhost? o) (string=? (jhost-tag o) "dow-enum") (= (dow-val e) (dow-val o))))) + (cons "hashCode" (lambda (e) (dow-val e))))) + +(define (month-from-temporal t) + (cond ((and (jhost? t) (string=? (jhost-tag t) "month-enum")) t) + ((jt-date? t) (jt-month (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) (lambda (y m d) m)))) + ((jt-dt? t) (jt-month (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day t))) (lambda (y m d) m)))) + (else (error #f "Month/from: unsupported")))) +(register-class-statics! "Month" + (append + (list (cons "of" (lambda (n) (jt-month (jt->exact n)))) + (cons "valueOf" (lambda (s) (let ((nm (jt-str s))) + (let loop ((i 0)) (cond ((= i 12) (error #f (string-append "No enum constant Month." nm))) + ((string=? (vector-ref jt-month-names i) nm) (jt-month (+ i 1))) + (else (loop (+ i 1)))))))) + (cons "from" (lambda (t) (month-from-temporal t))) + (cons "values" (lambda () (make-pvec (list->vector (map jt-month '(1 2 3 4 5 6 7 8 9 10 11 12))))))) + (map (lambda (i) (cons (vector-ref jt-month-names (- i 1)) (jt-month i))) '(1 2 3 4 5 6 7 8 9 10 11 12)))) +(define (dow-from-temporal t) + (cond ((and (jhost? t) (string=? (jhost-tag t) "dow-enum")) t) + ((jt-date? t) (jt-dow (ld-dow (ld-epoch-day t)))) + ((jt-dt? t) (jt-dow (ld-dow (ldt-epoch-day t)))) + (else (error #f "DayOfWeek/from: unsupported")))) +(register-class-statics! "DayOfWeek" + (append + (list (cons "of" (lambda (n) (jt-dow (jt->exact n)))) + (cons "valueOf" (lambda (s) (let ((nm (jt-str s))) + (let loop ((i 0)) (cond ((= i 7) (error #f (string-append "No enum constant DayOfWeek." nm))) + ((string=? (vector-ref jt-day-names i) nm) (jt-dow (+ i 1))) + (else (loop (+ i 1)))))))) + (cons "from" (lambda (t) (dow-from-temporal t))) + (cons "values" (lambda () (make-pvec (list->vector (map jt-dow '(1 2 3 4 5 6 7))))))) + (map (lambda (i) (cons (vector-ref jt-day-names (- i 1)) (jt-dow i))) '(1 2 3 4 5 6 7)))) + +;; --- Duration: (vector seconds nanos), nanos in [0, 1e9) ---------------------- +(define (dur-normalize secs nanos) + (let* ((carry (jt-floor-div nanos nanos-per-sec)) + (n (jt-floor-mod nanos nanos-per-sec))) + (make-jhost "duration" (vector (+ secs carry) n)))) +(define (dur-secs d) (vector-ref (jhost-state d) 0)) +(define (dur-nanos d) (vector-ref (jhost-state d) 1)) +(define (dur-total-nanos d) (+ (* (dur-secs d) nanos-per-sec) (dur-nanos d))) +(define (dur-of-total-nanos tn) (dur-normalize (jt-floor-div tn nanos-per-sec) (jt-floor-mod tn nanos-per-sec))) +(define dur-zero (make-jhost "duration" (vector 0 0))) + +;; ISO-8601: PTnHnMnS. Components come from the normalized (secs,nanos>=0) state; +;; each H/M/S field carries its own sign (java.time prints them per-component). The +;; seconds field folds in the fractional nanos: a negative second with nanos shows +;; e.g. "-0.5" (rem-sec -1 + nanos 5e8 -> -0.5). +(define (dur->string d) + (let ((secs (dur-secs d)) (nanos (dur-nanos d))) + (if (and (= secs 0) (= nanos 0)) "PT0S" + (let* ((hours (quotient secs 3600)) + (mins (quotient (remainder secs 3600) 60)) + (rem-secs (remainder secs 60)) + (out (open-output-string))) + (display "PT" out) + (unless (= hours 0) (display (number->string hours) out) (write-char #\H out)) + (unless (= mins 0) (display (number->string mins) out) (write-char #\M out)) + (when (or (not (= rem-secs 0)) (not (= nanos 0)) (and (= hours 0) (= mins 0))) + (if (= nanos 0) + (display (number->string rem-secs) out) + ;; whole second + fraction; a negative rem-sec with positive nanos + ;; rolls toward zero (rem+1) and shows fraction as 1e9-nanos. + (let* ((neg (< rem-secs 0)) + (whole (if neg (+ rem-secs 1) rem-secs)) + (frac (if neg (- nanos-per-sec nanos) nanos))) + (when (and neg (= whole 0)) (write-char #\- out)) + (display (number->string whole) out) + (write-char #\. out) + (display (dur-frac-digits frac) out))) + (write-char #\S out)) + (get-output-string out))))) +;; nanos -> a 9-digit fraction with all trailing zeros stripped (Duration shows the +;; minimal fraction, e.g. .5, unlike LocalTime which pads to 3/6/9). +(define (dur-frac-digits nano) + (let ((s9 (let ((s (number->string nano))) (string-append (make-string (max 0 (- 9 (string-length s))) #\0) s)))) + (let loop ((i 9)) (cond ((<= i 1) (substring s9 0 1)) + ((char=? (string-ref s9 (- i 1)) #\0) (loop (- i 1))) + (else (substring s9 0 i)))))) + +(define (dur-temporal-nanos t) ; instant/ldt/lt -> a nanos-since-epoch-ish count + (cond ((jt-instant? t) (* (inst-ms t) 1000000)) + ((jt-dt? t) (+ (* (ldt-epoch-day t) nanos-per-day) (ldt-nano-of-day t))) + ((jt-time? t) (lt-nano-of-day t)) + ((jt-date? t) (* (ld-epoch-day t) nanos-per-day)) + (else (error #f "Duration/between: unsupported temporal")))) +(register-class-statics! "Duration" + (list (cons "ZERO" dur-zero) + (cons "of" (lambda (n unit) (dur-of-total-nanos (* (jt->exact n) (chrono-unit-nanos unit))))) + (cons "ofDays" (lambda (n) (dur-normalize (* (jt->exact n) 86400) 0))) + (cons "ofHours" (lambda (n) (dur-normalize (* (jt->exact n) 3600) 0))) + (cons "ofMinutes" (lambda (n) (dur-normalize (* (jt->exact n) 60) 0))) + (cons "ofSeconds" (case-lambda + ((s) (dur-normalize (jt->exact s) 0)) + ((s na) (dur-normalize (jt->exact s) (jt->exact na))))) + (cons "ofMillis" (lambda (n) (dur-of-total-nanos (* (jt->exact n) 1000000)))) + (cons "ofNanos" (lambda (n) (dur-of-total-nanos (jt->exact n)))) + (cons "between" (lambda (a b) (dur-of-total-nanos (- (dur-temporal-nanos b) (dur-temporal-nanos a))))) + (cons "from" (lambda (t) (if (and (jhost? t) (string=? (jhost-tag t) "duration")) t (error #f "Duration/from")))) + (cons "parse" (lambda (s) (parse-iso-duration (jt-str s)))))) + +(define (dur-plus a b) (dur-of-total-nanos (+ (dur-total-nanos a) (dur-total-nanos b)))) +(register-host-methods! "duration" + (list (cons "getSeconds" (lambda (d) (dur-secs d))) + (cons "getNano" (lambda (d) (dur-nanos d))) + (cons "toDays" (lambda (d) (quotient (dur-secs d) 86400))) + (cons "toHours" (lambda (d) (quotient (dur-secs d) 3600))) + (cons "toMinutes" (lambda (d) (quotient (dur-secs d) 60))) + (cons "toMillis" (lambda (d) (+ (* (dur-secs d) 1000) (quotient (dur-nanos d) 1000000)))) + (cons "toNanos" (lambda (d) (dur-total-nanos d))) + (cons "plus" (lambda (d o) (cond ((and (jhost? o) (string=? (jhost-tag o) "duration")) (dur-plus d o)) + (else (error #f "Duration.plus: expected Duration"))))) + (cons "minus" (lambda (d o) (dur-of-total-nanos (- (dur-total-nanos d) (dur-total-nanos o))))) + (cons "plusDays" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) 86400 nanos-per-sec))))) + (cons "plusHours" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) 3600 nanos-per-sec))))) + (cons "plusMinutes" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) 60 nanos-per-sec))))) + (cons "plusSeconds" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) nanos-per-sec))))) + (cons "plusMillis" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) 1000000))))) + (cons "plusNanos" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (jt->exact n))))) + (cons "minusDays" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) 86400 nanos-per-sec))))) + (cons "minusHours" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) 3600 nanos-per-sec))))) + (cons "minusMinutes" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) 60 nanos-per-sec))))) + (cons "minusSeconds" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) nanos-per-sec))))) + (cons "minusMillis" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) 1000000))))) + (cons "minusNanos" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (jt->exact n))))) + (cons "multipliedBy" (lambda (d n) (dur-of-total-nanos (* (dur-total-nanos d) (jt->exact n))))) + (cons "dividedBy" (lambda (d n) (dur-of-total-nanos (quotient (dur-total-nanos d) (jt->exact n))))) + (cons "negated" (lambda (d) (dur-of-total-nanos (- (dur-total-nanos d))))) + (cons "abs" (lambda (d) (dur-of-total-nanos (abs (dur-total-nanos d))))) + (cons "withSeconds" (lambda (d s) (dur-normalize (jt->exact s) (dur-nanos d)))) + (cons "withNanos" (lambda (d na) (dur-normalize (dur-secs d) (jt->exact na)))) + (cons "isZero" (lambda (d) (and (= (dur-secs d) 0) (= (dur-nanos d) 0)))) + (cons "isNegative" (lambda (d) (< (dur-total-nanos d) 0))) + (cons "compareTo" (lambda (d o) (let ((a (dur-total-nanos d)) (b (dur-total-nanos o))) + (cond ((< a b) -1) ((> a b) 1) (else 0))))) + (cons "equals" (lambda (d o) (and (jhost? o) (string=? (jhost-tag o) "duration") (= (dur-total-nanos d) (dur-total-nanos o))))) + (cons "hashCode" (lambda (d) (jolt-hash (dur-total-nanos d)))) + ;; TemporalAmount: addTo/subtractFrom apply this duration to a temporal. + (cons "addTo" (lambda (d t) (temporal-plus-nanos t (dur-total-nanos d)))) + (cons "subtractFrom" (lambda (d t) (temporal-plus-nanos t (- (dur-total-nanos d))))) + (cons "toString" (lambda (d) (dur->string d))))) + +;; "PT…" parse: PnDTnHnMn.nS (we accept the time part; days fold into hours). +(define (parse-iso-duration s) + (let ((len (string-length s)) (neg #f) (i 0) (total 0)) + (define (sign-at j) (cond ((>= j len) (values 1 j)) + ((char=? (string-ref s j) #\-) (values -1 (+ j 1))) + ((char=? (string-ref s j) #\+) (values 1 (+ j 1))) + (else (values 1 j)))) + (when (and (< i len) (char=? (string-ref s i) #\-)) (set! neg #t) (set! i (+ i 1))) + (unless (and (< i len) (or (char=? (string-ref s i) #\P) (char=? (string-ref s i) #\p))) + (error #f (string-append "could not parse Duration: " s))) + (set! i (+ i 1)) + (let loop ((in-time #f)) + (when (< i len) + (let ((c (string-ref s i))) + (cond + ((or (char=? c #\T) (char=? c #\t)) (set! i (+ i 1)) (loop #t)) + (else + (call-with-values (lambda () (sign-at i)) + (lambda (sg j) + ;; read number (with optional fraction) + (let num ((k j) (acc 0) (frac 0) (fdigits 0) (in-frac #f) (any #f)) + (cond + ((and (< k len) (digit? (string-ref s k))) + (if in-frac + (num (+ k 1) acc (+ (* frac 10) (- (char->integer (string-ref s k)) 48)) (+ fdigits 1) #t #t) + (num (+ k 1) (+ (* acc 10) (- (char->integer (string-ref s k)) 48)) frac fdigits #f #t))) + ((and (< k len) (char=? (string-ref s k) #\.)) (num (+ k 1) acc frac fdigits #t any)) + ((and any (< k len)) + (let* ((unit (char-upcase (string-ref s k))) + (nanos (* (+ (* acc nanos-per-sec) (* frac (expt 10 (max 0 (- 9 fdigits))))) sg)) + (mult (cond ((char=? unit #\D) 86400) ((char=? unit #\H) 3600) + ((char=? unit #\M) (if in-time 60 (error #f "Duration months unsupported"))) + ((char=? unit #\S) 1) + (else (error #f (string-append "bad Duration unit: " s)))))) + (set! total (+ total (* nanos mult))) + (set! i (+ k 1)) + (loop in-time))) + (else (error #f (string-append "could not parse Duration: " s)))))))))))) + (dur-of-total-nanos (if neg (- total) total)))) + +;; --- Period: (vector years months days) -------------------------------------- +(define (jt-period y m d) (make-jhost "period" (vector y m d))) +(define (per-years p) (vector-ref (jhost-state p) 0)) +(define (per-months p) (vector-ref (jhost-state p) 1)) +(define (per-days p) (vector-ref (jhost-state p) 2)) +(define per-zero (jt-period 0 0 0)) +(define (per->string p) + (let ((y (per-years p)) (m (per-months p)) (d (per-days p))) + (if (and (= y 0) (= m 0) (= d 0)) "P0D" + (let ((out (open-output-string))) + (write-char #\P out) + (unless (= y 0) (display (number->string y) out) (write-char #\Y out)) + (unless (= m 0) (display (number->string m) out) (write-char #\M out)) + (unless (= d 0) (display (number->string d) out) (write-char #\D out)) + (get-output-string out))))) +;; Period/between counts whole years/months/days from a to b (java.time semantics). +(define (per-between a b) + (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day a))) + (lambda (y1 m1 d1) + (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day b))) + (lambda (y2 m2 d2) + (let* ((total-months (- (+ (* y2 12) m2) (+ (* y1 12) m1))) + (days (- d2 d1))) + ;; if days go negative, borrow a month (using the prior month length of b) + (let-values (((tm dd) + (if (and (> total-months 0) (< days 0)) + (let* ((tm (- total-months 1)) + (bm (+ (* y1 12) (- m1 1) tm)) + (by (jt-floor-div bm 12)) (bmo (+ 1 (jt-floor-mod bm 12))) + (len (jt-len-of-month by bmo))) + (values tm (+ days len))) + (if (and (< total-months 0) (> days 0)) + (values (+ total-months 1) (- days (jt-len-of-month y2 m2))) + (values total-months days))))) + (jt-period (jt-floor-div tm 12) (jt-floor-mod tm 12) dd)))))))) +(define (per-normalize p) + (let ((tm (+ (* (per-years p) 12) (per-months p)))) + (jt-period (jt-floor-div tm 12) (jt-floor-mod tm 12) (per-days p)))) +(register-class-statics! "Period" + (list (cons "ZERO" per-zero) + (cons "of" (lambda (y m d) (jt-period (jt->exact y) (jt->exact m) (jt->exact d)))) + (cons "ofYears" (lambda (y) (jt-period (jt->exact y) 0 0))) + (cons "ofMonths" (lambda (m) (jt-period 0 (jt->exact m) 0))) + (cons "ofWeeks" (lambda (w) (jt-period 0 0 (* 7 (jt->exact w))))) + (cons "ofDays" (lambda (d) (jt-period 0 0 (jt->exact d)))) + (cons "between" (lambda (a b) (per-between a b))) + (cons "from" (lambda (t) (if (and (jhost? t) (string=? (jhost-tag t) "period")) t (error #f "Period/from")))) + (cons "parse" (lambda (s) (parse-iso-period (jt-str s)))))) +(register-host-methods! "period" + (list (cons "getYears" (lambda (p) (per-years p))) + (cons "getMonths" (lambda (p) (per-months p))) + (cons "getDays" (lambda (p) (per-days p))) + (cons "toTotalMonths" (lambda (p) (+ (* (per-years p) 12) (per-months p)))) + (cons "plusYears" (lambda (p n) (jt-period (+ (per-years p) (jt->exact n)) (per-months p) (per-days p)))) + (cons "plusMonths" (lambda (p n) (jt-period (per-years p) (+ (per-months p) (jt->exact n)) (per-days p)))) + (cons "plusDays" (lambda (p n) (jt-period (per-years p) (per-months p) (+ (per-days p) (jt->exact n))))) + (cons "minusYears" (lambda (p n) (jt-period (- (per-years p) (jt->exact n)) (per-months p) (per-days p)))) + (cons "minusMonths" (lambda (p n) (jt-period (per-years p) (- (per-months p) (jt->exact n)) (per-days p)))) + (cons "minusDays" (lambda (p n) (jt-period (per-years p) (per-months p) (- (per-days p) (jt->exact n))))) + (cons "withYears" (lambda (p n) (jt-period (jt->exact n) (per-months p) (per-days p)))) + (cons "withMonths" (lambda (p n) (jt-period (per-years p) (jt->exact n) (per-days p)))) + (cons "withDays" (lambda (p n) (jt-period (per-years p) (per-months p) (jt->exact n)))) + (cons "plus" (lambda (p o) (jt-period (+ (per-years p) (per-years o)) (+ (per-months p) (per-months o)) (+ (per-days p) (per-days o))))) + (cons "minus" (lambda (p o) (jt-period (- (per-years p) (per-years o)) (- (per-months p) (per-months o)) (- (per-days p) (per-days o))))) + (cons "multipliedBy" (lambda (p n) (jt-period (* (per-years p) (jt->exact n)) (* (per-months p) (jt->exact n)) (* (per-days p) (jt->exact n))))) + (cons "negated" (lambda (p) (jt-period (- (per-years p)) (- (per-months p)) (- (per-days p))))) + (cons "normalized" (lambda (p) (per-normalize p))) + (cons "isZero" (lambda (p) (and (= (per-years p) 0) (= (per-months p) 0) (= (per-days p) 0)))) + (cons "isNegative" (lambda (p) (or (< (per-years p) 0) (< (per-months p) 0) (< (per-days p) 0)))) + (cons "equals" (lambda (p o) (and (jhost? o) (string=? (jhost-tag o) "period") + (= (per-years p) (per-years o)) (= (per-months p) (per-months o)) (= (per-days p) (per-days o))))) + (cons "hashCode" (lambda (p) (+ (per-years p) (bitwise-arithmetic-shift-left (per-months p) 8) (bitwise-arithmetic-shift-left (per-days p) 16)))) + ;; TemporalAmount: a Period adds its y/m/d to a date-bearing temporal. + (cons "addTo" (lambda (p t) (temporal-plus-period t p 1))) + (cons "subtractFrom" (lambda (p t) (temporal-plus-period t p -1))) + (cons "toString" (lambda (p) (per->string p))))) +;; "PnYnMnWnD" -> a Period (weeks fold into days). +(define (parse-iso-period s) + (let ((len (string-length s)) (sign 1) (i 0) (y 0) (m 0) (d 0)) + (when (and (< i len) (char=? (string-ref s i) #\-)) (set! sign -1) (set! i (+ i 1))) + (unless (and (< i len) (or (char=? (string-ref s i) #\P) (char=? (string-ref s i) #\p))) + (error #f (string-append "could not parse Period: " s))) + (set! i (+ i 1)) + (let loop () + (when (< i len) + (let ((vsign (cond ((char=? (string-ref s i) #\-) (set! i (+ i 1)) -1) + ((char=? (string-ref s i) #\+) (set! i (+ i 1)) 1) + (else 1)))) + (let num ((k i) (acc 0) (any #f)) + (cond + ((and (< k len) (digit? (string-ref s k))) (num (+ k 1) (+ (* acc 10) (- (char->integer (string-ref s k)) 48)) #t)) + ((and any (< k len)) + (let ((u (char-upcase (string-ref s k))) (val (* vsign acc))) + (cond ((char=? u #\Y) (set! y val)) ((char=? u #\M) (set! m val)) + ((char=? u #\W) (set! d (+ d (* 7 val)))) ((char=? u #\D) (set! d (+ d val))) + (else (error #f (string-append "bad Period unit: " s)))) + (set! i (+ k 1)) (loop))) + (else (error #f (string-append "could not parse Period: " s)))))))) + (jt-period (* sign y) (* sign m) (* sign d)))) + +;; --- Year -------------------------------------------------------------------- +(define (jt-year y) (make-jhost "year" (vector y))) +(define (year-val y) (vector-ref (jhost-state y) 0)) +(define (year-from-temporal t) + (cond ((and (jhost? t) (string=? (jhost-tag t) "year")) t) + ((jt-date? t) (jt-year (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) (lambda (y m d) y)))) + ((jt-dt? t) (jt-year (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day t))) (lambda (y m d) y)))) + ((and (jhost? t) (string=? (jhost-tag t) "year-month")) (jt-year (ym-year t))) + (else (error #f "Year/from: unsupported")))) +(register-class-statics! "Year" + (list (cons "of" (lambda (y) (jt-year (jt->exact y)))) + (cons "now" (lambda _ (jt-year (call-with-values (lambda () (epoch-day->ymd (jt-floor-div (exact (truncate (now-ms))) 86400000))) (lambda (y m d) y))))) + (cons "isLeap" (lambda (y) (jt-leap? (jt->exact y)))) + (cons "parse" (lambda (s . _) (jt-year (or (string->number (jt-str s)) (error #f "could not parse Year"))))) + (cons "from" (lambda (t) (year-from-temporal t))) + (cons "MIN_VALUE" -999999999) + (cons "MAX_VALUE" 999999999))) +(register-host-methods! "year" + (list (cons "getValue" (lambda (y) (year-val y))) + (cons "isLeap" (lambda (y) (jt-leap? (year-val y)))) + (cons "length" (lambda (y) (if (jt-leap? (year-val y)) 366 365))) + (cons "plusYears" (lambda (y n) (jt-year (+ (year-val y) (jt->exact n))))) + (cons "minusYears" (lambda (y n) (jt-year (- (year-val y) (jt->exact n))))) + (cons "atMonth" (lambda (y m) (jt-year-month (year-val y) (jt->exact m)))) + (cons "atDay" (lambda (y doy) (jt-local-date (+ (ymd->epoch-day (year-val y) 1 1) (- (jt->exact doy) 1))))) + (cons "atMonthDay" (lambda (y md) (error #f "Year.atMonthDay: MonthDay unsupported"))) + (cons "isBefore" (lambda (y o) (< (year-val y) (year-val o)))) + (cons "isAfter" (lambda (y o) (> (year-val y) (year-val o)))) + (cons "isValidMonthDay" (lambda (y md) #f)) + (cons "compareTo" (lambda (y o) (let ((a (year-val y)) (b (year-val o))) (cond ((< a b) -1) ((> a b) 1) (else 0))))) + (cons "equals" (lambda (y o) (and (jhost? o) (string=? (jhost-tag o) "year") (= (year-val y) (year-val o))))) + (cons "hashCode" (lambda (y) (year-val y))) + (cons "toString" (lambda (y) (number->string (year-val y)))))) + +;; --- YearMonth: (vector year month) ------------------------------------------ +(define (jt-year-month y m) + (let* ((ym (+ (* y 12) (- m 1))) (y2 (jt-floor-div ym 12)) (m2 (+ 1 (jt-floor-mod ym 12)))) + (make-jhost "year-month" (vector y2 m2)))) +(define (ym-year x) (vector-ref (jhost-state x) 0)) +(define (ym-month x) (vector-ref (jhost-state x) 1)) +(define (ym-plus-months x n) + (let ((tm (+ (* (ym-year x) 12) (- (ym-month x) 1) n))) + (make-jhost "year-month" (vector (jt-floor-div tm 12) (+ 1 (jt-floor-mod tm 12)))))) +(define (ym->string x) (string-append (pad4 (ym-year x)) "-" (pad2 (ym-month x)))) +(define (ym-from-temporal t) + (cond ((and (jhost? t) (string=? (jhost-tag t) "year-month")) t) + ((jt-date? t) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) (lambda (y m d) (jt-year-month y m)))) + ((jt-dt? t) (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day t))) (lambda (y m d) (jt-year-month y m)))) + (else (error #f "YearMonth/from: unsupported")))) +(register-class-statics! "YearMonth" + (list (cons "of" (lambda (y m) (jt-year-month (jt->exact y) (jt->exact m)))) + (cons "now" (lambda _ (call-with-values (lambda () (epoch-day->ymd (jt-floor-div (exact (truncate (now-ms))) 86400000))) + (lambda (y m d) (jt-year-month y m))))) + (cons "parse" (lambda (s . _) (let ((str (jt-str s))) + (jt-year-month (or (digits-at str 0 4) (error #f "could not parse YearMonth")) + (or (digits-at str 5 2) (error #f "could not parse YearMonth")))))) + (cons "from" (lambda (t) (ym-from-temporal t))))) +(register-host-methods! "year-month" + (list (cons "getYear" (lambda (x) (ym-year x))) + (cons "getMonthValue" (lambda (x) (ym-month x))) + (cons "getMonth" (lambda (x) (jt-month (ym-month x)))) + (cons "lengthOfMonth" (lambda (x) (jt-len-of-month (ym-year x) (ym-month x)))) + (cons "lengthOfYear" (lambda (x) (if (jt-leap? (ym-year x)) 366 365))) + (cons "isLeapYear" (lambda (x) (jt-leap? (ym-year x)))) + (cons "plusMonths" (lambda (x n) (ym-plus-months x (jt->exact n)))) + (cons "minusMonths" (lambda (x n) (ym-plus-months x (- (jt->exact n))))) + (cons "plusYears" (lambda (x n) (jt-year-month (+ (ym-year x) (jt->exact n)) (ym-month x)))) + (cons "minusYears" (lambda (x n) (jt-year-month (- (ym-year x) (jt->exact n)) (ym-month x)))) + (cons "withYear" (lambda (x v) (jt-year-month (jt->exact v) (ym-month x)))) + (cons "withMonth" (lambda (x v) (jt-year-month (ym-year x) (jt->exact v)))) + (cons "atDay" (lambda (x d) (jt-local-date (ymd->epoch-day (ym-year x) (ym-month x) (jt->exact d))))) + (cons "atEndOfMonth" (lambda (x) (jt-local-date (ymd->epoch-day (ym-year x) (ym-month x) (jt-len-of-month (ym-year x) (ym-month x)))))) + (cons "isValidDay" (lambda (x d) (let ((dd (jt->exact d))) (and (>= dd 1) (<= dd (jt-len-of-month (ym-year x) (ym-month x))))))) + (cons "isBefore" (lambda (x o) (< (ym-cmp x o) 0))) + (cons "isAfter" (lambda (x o) (> (ym-cmp x o) 0))) + (cons "compareTo" (lambda (x o) (ym-cmp x o))) + (cons "equals" (lambda (x o) (and (jhost? o) (string=? (jhost-tag o) "year-month") (= (ym-cmp x o) 0)))) + (cons "hashCode" (lambda (x) (+ (* (ym-year x) 13) (ym-month x)))) + (cons "toString" (lambda (x) (ym->string x))))) +(define (ym-cmp x o) + (cond ((< (ym-year x) (ym-year o)) -1) ((> (ym-year x) (ym-year o)) 1) + ((< (ym-month x) (ym-month o)) -1) ((> (ym-month x) (ym-month o)) 1) (else 0))) + +;; --- ChronoUnit / ChronoField ------------------------------------------------ +;; Each ChronoUnit is a jhost (vector name nanos-or-#f) — nanos is the fixed +;; duration in nanoseconds for time-based units, or an estimate for date-based ones. +;; The conversion lets Duration/of and unit-based between/plus/until work. +(define seconds-per-year (* (/ 146097 400) 86400)) ; 365.2425 days +(define chrono-unit-table + ;; (name . nanos-per-unit) month/year use the average-length estimate java.time uses. + (list (cons "NANOS" 1) + (cons "MICROS" 1000) + (cons "MILLIS" 1000000) + (cons "SECONDS" nanos-per-sec) + (cons "MINUTES" (* 60 nanos-per-sec)) + (cons "HOURS" (* 3600 nanos-per-sec)) + (cons "HALF_DAYS" (* 43200 nanos-per-sec)) + (cons "DAYS" (* 86400 nanos-per-sec)) + (cons "WEEKS" (* 7 86400 nanos-per-sec)) + (cons "MONTHS" (exact (round (* (/ seconds-per-year 12) nanos-per-sec)))) + (cons "YEARS" (exact (round (* seconds-per-year nanos-per-sec)))) + (cons "DECADES" (exact (round (* 10 seconds-per-year nanos-per-sec)))) + (cons "CENTURIES" (exact (round (* 100 seconds-per-year nanos-per-sec)))) + (cons "MILLENNIA" (exact (round (* 1000 seconds-per-year nanos-per-sec)))) + (cons "ERAS" (exact (round (* 1000000000 seconds-per-year nanos-per-sec)))) + (cons "FOREVER" #f))) +(define (jt-chrono-unit name) (make-jhost "chrono-unit" (vector name))) +(define (cu-name u) (vector-ref (jhost-state u) 0)) +(define (chrono-unit-nanos u) + (let* ((nm (chrono-unit-name u)) (row (and nm (assoc (string-upcase nm) chrono-unit-table)))) + (if (and row (cdr row)) (cdr row) (error #f (string-append "no fixed duration for unit " (or nm "?")))))) +;; register the 16 unit constants under ChronoUnit statics. +(register-class-statics! "ChronoUnit" + (append + (map (lambda (row) (cons (car row) (jt-chrono-unit (car row)))) chrono-unit-table) + (list (cons "valueOf" (lambda (s) (jt-chrono-unit (jt-str s)))) + (cons "values" (lambda () (make-pvec (list->vector (map (lambda (r) (jt-chrono-unit (car r))) chrono-unit-table)))))))) +(register-host-methods! "chrono-unit" + (list (cons "name" (lambda (u) (cu-name u))) + (cons "toString" (lambda (u) (cu-name u))) + (cons "ordinal" (lambda (u) (let loop ((t chrono-unit-table) (i 0)) + (cond ((null? t) -1) ((string=? (caar t) (cu-name u)) i) (else (loop (cdr t) (+ i 1))))))) + (cons "getDuration" (lambda (u) (dur-of-total-nanos (chrono-unit-nanos u)))) + (cons "isDateBased" (lambda (u) (and (member (cu-name u) '("DAYS" "WEEKS" "MONTHS" "YEARS" "DECADES" "CENTURIES" "MILLENNIA" "ERAS")) #t))) + (cons "isTimeBased" (lambda (u) (and (member (cu-name u) '("NANOS" "MICROS" "MILLIS" "SECONDS" "MINUTES" "HOURS" "HALF_DAYS")) #t))) + (cons "isDurationEstimated" (lambda (u) (and (member (cu-name u) '("DAYS" "WEEKS" "MONTHS" "YEARS" "DECADES" "CENTURIES" "MILLENNIA" "ERAS" "FOREVER")) #t))) + (cons "between" (lambda (u a b) (unit-between (cu-name u) a b))) + (cons "addTo" (lambda (u t n) (temporal-plus-unit t (jt->exact n) (cu-name u)))) + (cons "equals" (lambda (u o) (and (jhost? o) (string=? (jhost-tag o) "chrono-unit") (string=? (cu-name u) (cu-name o))))) + (cons "hashCode" (lambda (u) (string-hash (cu-name u)))))) + +;; ChronoField: a jhost (vector name). get/getLong/with project the field onto a +;; temporal via the field-projection table below. +;; the full ChronoField enum (the cljc wrapper defs every constant at load). Only +;; the common ones are projected by temporal-get-field; the rest exist as tokens. +(define chrono-field-names + '("NANO_OF_SECOND" "NANO_OF_DAY" "MICRO_OF_SECOND" "MICRO_OF_DAY" "MILLI_OF_SECOND" "MILLI_OF_DAY" + "SECOND_OF_MINUTE" "SECOND_OF_DAY" "MINUTE_OF_HOUR" "MINUTE_OF_DAY" + "HOUR_OF_AMPM" "CLOCK_HOUR_OF_AMPM" "HOUR_OF_DAY" "CLOCK_HOUR_OF_DAY" "AMPM_OF_DAY" + "DAY_OF_WEEK" "ALIGNED_DAY_OF_WEEK_IN_MONTH" "ALIGNED_DAY_OF_WEEK_IN_YEAR" + "DAY_OF_MONTH" "DAY_OF_YEAR" "EPOCH_DAY" + "ALIGNED_WEEK_OF_MONTH" "ALIGNED_WEEK_OF_YEAR" + "MONTH_OF_YEAR" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "YEAR" "ERA" + "INSTANT_SECONDS" "OFFSET_SECONDS")) +(define (jt-chrono-field name) (make-jhost "chrono-field" (vector name))) +(define (cf-name f) (vector-ref (jhost-state f) 0)) +(register-class-statics! "ChronoField" + (append + (map (lambda (n) (cons n (jt-chrono-field n))) chrono-field-names) + (list (cons "valueOf" (lambda (s) (jt-chrono-field (jt-str s)))) + (cons "values" (lambda () (make-pvec (list->vector (map jt-chrono-field chrono-field-names)))))))) +(register-host-methods! "chrono-field" + (list (cons "name" (lambda (f) (cf-name f))) + (cons "toString" (lambda (f) (cf-name f))) + (cons "getDisplayName" (lambda (f . _) (cf-name f))) + (cons "isDateBased" (lambda (f) (and (member (cf-name f) '("DAY_OF_WEEK" "DAY_OF_MONTH" "DAY_OF_YEAR" "EPOCH_DAY" "MONTH_OF_YEAR" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "YEAR" "ERA")) #t))) + (cons "isTimeBased" (lambda (f) (not (member (cf-name f) '("DAY_OF_WEEK" "DAY_OF_MONTH" "DAY_OF_YEAR" "EPOCH_DAY" "MONTH_OF_YEAR" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "YEAR" "ERA" "INSTANT_SECONDS" "OFFSET_SECONDS"))))) + (cons "getFrom" (lambda (f t) (temporal-get-field t (cf-name f)))) + (cons "equals" (lambda (f o) (and (jhost? o) (string=? (jhost-tag o) "chrono-field") (string=? (cf-name f) (cf-name o))))) + (cons "hashCode" (lambda (f) (string-hash (cf-name f)))))) + +;; --- ValueRange (minimal min/max holder) ------------------------------------- +(define (jt-value-range smin lmin smax lmax) (make-jhost "value-range" (vector smin lmin smax lmax))) +(register-host-methods! "value-range" + (list (cons "getMinimum" (lambda (r) (vector-ref (jhost-state r) 1))) + (cons "getLargestMinimum" (lambda (r) (vector-ref (jhost-state r) 1))) + (cons "getSmallestMaximum" (lambda (r) (vector-ref (jhost-state r) 2))) + (cons "getMaximum" (lambda (r) (vector-ref (jhost-state r) 3))) + (cons "isFixed" (lambda (r) (and (= (vector-ref (jhost-state r) 0) (vector-ref (jhost-state r) 1)) + (= (vector-ref (jhost-state r) 2) (vector-ref (jhost-state r) 3))))) + (cons "isValidValue" (lambda (r v) (let ((x (jt->exact v))) (and (>= x (vector-ref (jhost-state r) 1)) (<= x (vector-ref (jhost-state r) 3)))))) + (cons "toString" (lambda (r) (string-append (number->string (vector-ref (jhost-state r) 1)) " - " (number->string (vector-ref (jhost-state r) 3))))))) + +;; --- temporal field/unit machinery: plus/minus/until/get/with on core types -- +;; These power the generic cljc.java-time.temporal dispatchers, which forward to +;; the receiver's plus/minus/until/get/getLong/with/range/isSupported. + +;; add n of `unit` to a temporal (local-date / local-time / local-date-time / instant). +(define (temporal-plus-unit t n unit) + (let ((u (string-upcase unit))) + (cond + ((jt-date? t) + (cond ((string=? u "DAYS") (jt-local-date (+ (ld-epoch-day t) n))) + ((string=? u "WEEKS") (jt-local-date (+ (ld-epoch-day t) (* 7 n)))) + ((string=? u "MONTHS") (ld-plus-months t n)) + ((string=? u "YEARS") (ld-plus-years t n)) + ((string=? u "DECADES") (ld-plus-years t (* 10 n))) + ((string=? u "CENTURIES") (ld-plus-years t (* 100 n))) + ((string=? u "MILLENNIA") (ld-plus-years t (* 1000 n))) + (else (error #f (string-append "LocalDate plus unsupported unit " u))))) + ((jt-time? t) (lt-plus t (* n (chrono-unit-nanos (jt-chrono-unit u))))) + ((jt-dt? t) + (cond ((string=? u "DAYS") (jt-local-dt (+ (ldt-epoch-day t) n) (ldt-nano-of-day t))) + ((string=? u "WEEKS") (jt-local-dt (+ (ldt-epoch-day t) (* 7 n)) (ldt-nano-of-day t))) + ((string=? u "MONTHS") (ldt-combine (ld-plus-months (ldt-date t) n) (ldt-time t))) + ((string=? u "YEARS") (ldt-combine (ld-plus-years (ldt-date t) n) (ldt-time t))) + ((string=? u "DECADES") (ldt-combine (ld-plus-years (ldt-date t) (* 10 n)) (ldt-time t))) + ((string=? u "CENTURIES") (ldt-combine (ld-plus-years (ldt-date t) (* 100 n)) (ldt-time t))) + ((string=? u "MILLENNIA") (ldt-combine (ld-plus-years (ldt-date t) (* 1000 n)) (ldt-time t))) + (else (ldt-plus-nanos t (* n (chrono-unit-nanos (jt-chrono-unit u))))))) + ((jt-instant? t) + (cond ((string=? u "DAYS") (mk-instant (+ (inst-ms t) (* n 86400000)))) + (else (mk-instant (+ (inst-ms t) (quotient (* n (chrono-unit-nanos (jt-chrono-unit u))) 1000000)))))) + (else (error #f "plus: unsupported temporal"))))) + +;; add raw nanos (for Duration.addTo). +(define (temporal-plus-nanos t nanos) + (cond ((jt-time? t) (lt-plus t nanos)) + ((jt-dt? t) (ldt-plus-nanos t nanos)) + ((jt-instant? t) (mk-instant (+ (inst-ms t) (quotient nanos 1000000)))) + ((jt-date? t) (jt-local-date (+ (ld-epoch-day t) (quotient nanos (* 86400 nanos-per-sec))))) + (else (error #f "plus(Duration): unsupported temporal")))) + +;; add a Period (scaled by sign) to a date-bearing temporal. +(define (temporal-plus-period t p sign) + (let ((y (* sign (per-years p))) (m (* sign (per-months p))) (d (* sign (per-days p)))) + (cond ((jt-date? t) (jt-local-date (+ (ld-epoch-day (ld-plus-months (ld-plus-years t y) m)) d))) + ((jt-dt? t) (let ((nd (ld-plus-months (ld-plus-years (ldt-date t) y) m))) + (jt-local-dt (+ (ld-epoch-day nd) d) (ldt-nano-of-day t)))) + (else (error #f "plus(Period): unsupported temporal"))))) + +;; count whole `unit`s from a to b. +(define (unit-between unit a b) + (let ((u (string-upcase unit))) + (cond + ((and (jt-date? a) (jt-date? b)) + (let ((da (ld-epoch-day a)) (db (ld-epoch-day b))) + (cond ((string=? u "DAYS") (- db da)) + ((string=? u "WEEKS") (quotient (- db da) 7)) + ((string=? u "MONTHS") (date-months-between da db)) + ((string=? u "YEARS") (quotient (date-months-between da db) 12)) + ((string=? u "DECADES") (quotient (date-months-between da db) 120)) + ((string=? u "CENTURIES") (quotient (date-months-between da db) 1200)) + (else (error #f (string-append "between unsupported unit " u)))))) + ((and (jt-time? a) (jt-time? b)) (quotient (- (lt-nano-of-day b) (lt-nano-of-day a)) (chrono-unit-nanos (jt-chrono-unit u)))) + ((and (jt-dt? a) (jt-dt? b)) + (cond ((member u '("YEARS" "MONTHS" "DECADES" "CENTURIES" "MILLENNIA")) + (unit-between u (ldt-date a) (ldt-date b))) ; date-based: ignore time-of-day below months on LDT? use date months adjusted + (else (quotient (- (+ (* (ldt-epoch-day b) nanos-per-day) (ldt-nano-of-day b)) + (+ (* (ldt-epoch-day a) nanos-per-day) (ldt-nano-of-day a))) + (chrono-unit-nanos (jt-chrono-unit u)))))) + ((and (jt-instant? a) (jt-instant? b)) + (quotient (* (- (inst-ms b) (inst-ms a)) 1000000) (chrono-unit-nanos (jt-chrono-unit u)))) + (else (error #f "between: unsupported temporals"))))) +;; whole months between two epoch-days (java.time: months, then -1 if day-of-month +;; of b hasn't reached a's). +(define (date-months-between da db) + (call-with-values (lambda () (epoch-day->ymd da)) + (lambda (y1 m1 d1) + (call-with-values (lambda () (epoch-day->ymd db)) + (lambda (y2 m2 d2) + (let ((months (- (+ (* y2 12) m2) (+ (* y1 12) m1)))) + (cond ((and (> months 0) (< d2 d1)) (- months 1)) + ((and (< months 0) (> d2 d1)) (+ months 1)) + (else months)))))))) + +;; field get: project a ChronoField onto a temporal. +(define (temporal-get-field t field) + (let ((f (string-upcase field))) + (cond + ((jt-date? t) + (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) + (lambda (y m d) + (cond ((string=? f "YEAR") y) ((string=? f "MONTH_OF_YEAR") m) ((string=? f "DAY_OF_MONTH") d) + ((string=? f "DAY_OF_WEEK") (ld-dow (ld-epoch-day t))) + ((string=? f "DAY_OF_YEAR") (ld-day-of-year (ld-epoch-day t))) + ((string=? f "EPOCH_DAY") (ld-epoch-day t)) + ((string=? f "PROLEPTIC_MONTH") (+ (* y 12) (- m 1))) + ((string=? f "YEAR_OF_ERA") (if (>= y 1) y (- 1 y))) + ((string=? f "ERA") (if (>= y 1) 1 0)) + (else (error #f (string-append "LocalDate has no field " f))))))) + ((jt-time? t) + (cond ((string=? f "HOUR_OF_DAY") (lt-hour t)) ((string=? f "MINUTE_OF_HOUR") (lt-minute t)) + ((string=? f "SECOND_OF_MINUTE") (lt-second t)) ((string=? f "NANO_OF_SECOND") (lt-nano t)) + ((string=? f "NANO_OF_DAY") (lt-nano-of-day t)) + ((string=? f "MILLI_OF_DAY") (quotient (lt-nano-of-day t) 1000000)) + ((string=? f "SECOND_OF_DAY") (quotient (lt-nano-of-day t) nanos-per-sec)) + ((string=? f "MINUTE_OF_DAY") (quotient (lt-nano-of-day t) (* 60 nanos-per-sec))) + ((string=? f "MILLI_OF_SECOND") (quotient (lt-nano t) 1000000)) + ((string=? f "MICRO_OF_SECOND") (quotient (lt-nano t) 1000)) + ((string=? f "AMPM_OF_DAY") (quotient (lt-hour t) 12)) + (else (error #f (string-append "LocalTime has no field " f))))) + ((jt-dt? t) + (if (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_WEEK" "DAY_OF_YEAR" "EPOCH_DAY" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "ERA")) + (temporal-get-field (ldt-date t) f) + (temporal-get-field (ldt-time t) f))) + ((jt-instant? t) + (cond ((string=? f "INSTANT_SECONDS") (jt-floor-div (exact (truncate (inst-ms t))) 1000)) + ((string=? f "NANO_OF_SECOND") (* (jt-floor-mod (exact (truncate (inst-ms t))) 1000) 1000000)) + ((string=? f "MILLI_OF_SECOND") (jt-floor-mod (exact (truncate (inst-ms t))) 1000)) + (else (error #f (string-append "Instant has no field " f))))) + (else (error #f "get(field): unsupported temporal"))))) + +;; field set: (with temporal ChronoField value) -> a new temporal. +(define (temporal-with-field t field v) + (let ((f (string-upcase field))) + (cond + ((jt-date? t) + (cond ((string=? f "YEAR") (ld-with-field t 'year v)) ((string=? f "MONTH_OF_YEAR") (ld-with-field t 'month v)) + ((string=? f "DAY_OF_MONTH") (ld-with-field t 'day v)) ((string=? f "DAY_OF_YEAR") (ld-with-field t 'day-of-year v)) + ((string=? f "EPOCH_DAY") (jt-local-date v)) + (else (error #f (string-append "LocalDate.with unsupported field " f))))) + ((jt-time? t) + (cond ((string=? f "HOUR_OF_DAY") (lt-with t 'hour v)) ((string=? f "MINUTE_OF_HOUR") (lt-with t 'minute v)) + ((string=? f "SECOND_OF_MINUTE") (lt-with t 'second v)) ((string=? f "NANO_OF_SECOND") (lt-with t 'nano v)) + ((string=? f "NANO_OF_DAY") (jt-local-time v)) + (else (error #f (string-append "LocalTime.with unsupported field " f))))) + ((jt-dt? t) + (if (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_YEAR" "EPOCH_DAY")) + (ldt-combine (temporal-with-field (ldt-date t) f v) (ldt-time t)) + (ldt-combine (ldt-date t) (temporal-with-field (ldt-time t) f v)))) + (else (error #f "with(field): unsupported temporal"))))) + +(define (temporal-supports-unit? t unit) + (let ((u (string-upcase unit))) + (cond ((jt-date? t) (and (member u '("DAYS" "WEEKS" "MONTHS" "YEARS" "DECADES" "CENTURIES" "MILLENNIA" "ERAS")) #t)) + ((jt-time? t) (and (member u '("NANOS" "MICROS" "MILLIS" "SECONDS" "MINUTES" "HOURS" "HALF_DAYS")) #t)) + ((or (jt-dt? t) (jt-instant? t)) (not (member u '("FOREVER")))) + (else #f)))) +(define (temporal-supports-field? t field) + (let ((f (string-upcase field))) + (cond ((jt-date? t) (and (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_WEEK" "DAY_OF_YEAR" "EPOCH_DAY" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "ERA")) #t)) + ((jt-time? t) (and (member f '("HOUR_OF_DAY" "MINUTE_OF_HOUR" "SECOND_OF_MINUTE" "NANO_OF_SECOND" "NANO_OF_DAY" "MILLI_OF_DAY" "SECOND_OF_DAY" "MINUTE_OF_DAY" "MILLI_OF_SECOND" "MICRO_OF_SECOND" "AMPM_OF_DAY")) #t)) + ((jt-dt? t) (or (temporal-supports-field? (ldt-date t) field) (temporal-supports-field? (ldt-time t) field))) + ((jt-instant? t) (and (member f '("INSTANT_SECONDS" "NANO_OF_SECOND" "MILLI_OF_SECOND" "MICRO_OF_SECOND")) #t)) + (else #f)))) + +;; isSupported / get / getLong / with / range / plus / minus / until accept a +;; chrono-unit OR chrono-field jhost (or a string). These method names extend the +;; existing per-tag tables. +(define (unit-or-field-arg x) x) +(define (arg-is-unit? x) (and (jhost? x) (string=? (jhost-tag x) "chrono-unit"))) +(define (arg-is-field? x) (and (jhost? x) (string=? (jhost-tag x) "chrono-field"))) +(define (arg-is-amount? x) (and (jhost? x) (member (jhost-tag x) '("duration" "period")))) +(define (arg-unit-name x) (cond ((arg-is-unit? x) (cu-name x)) ((string? x) x) ((keyword? x) (keyword-t-name x)) (else #f))) +(define (arg-field-name x) (cond ((arg-is-field? x) (cf-name x)) ((string? x) x) ((keyword? x) (keyword-t-name x)) (else #f))) + +;; the generic plus/minus/until/get/getLong/with/range/isSupported, shared by all +;; four core tags. plus/minus accept (n unit) or (amount); with accepts (field val). +(define (mk-temporal-methods) + (list + (cons "plus" (case-lambda + ((t a) (cond ((arg-is-amount? a) (if (string=? (jhost-tag a) "duration") + (temporal-plus-nanos t (dur-total-nanos a)) + (temporal-plus-period t a 1))) + (else (error #f "plus: bad amount")))) + ((t n u) (temporal-plus-unit t (jt->exact n) (arg-unit-name u))))) + (cons "minus" (case-lambda + ((t a) (cond ((arg-is-amount? a) (if (string=? (jhost-tag a) "duration") + (temporal-plus-nanos t (- (dur-total-nanos a))) + (temporal-plus-period t a -1))) + (else (error #f "minus: bad amount")))) + ((t n u) (temporal-plus-unit t (- (jt->exact n)) (arg-unit-name u))))) + (cons "until" (lambda (t o u) (unit-between (arg-unit-name u) t o))) + (cons "get" (lambda (t f) (temporal-get-field t (arg-field-name f)))) + (cons "getLong" (lambda (t f) (temporal-get-field t (arg-field-name f)))) + (cons "with" (lambda (t f v) (temporal-with-field t (arg-field-name f) (jt->exact v)))) + (cons "isSupported" (lambda (t x) (cond ((arg-is-unit? x) (temporal-supports-unit? t (cu-name x))) + ((arg-is-field? x) (temporal-supports-field? t (cf-name x))) + (else #f)))) + (cons "range" (lambda (t f) (temporal-range t (arg-field-name f)))))) +(register-host-methods! "local-date" (mk-temporal-methods)) +(register-host-methods! "local-time" (mk-temporal-methods)) +(register-host-methods! "local-date-time" (mk-temporal-methods)) +(register-host-methods! "instant" (mk-temporal-methods)) + +;; range(field): a ValueRange. A small set of common fields; others fall back to a +;; generous range so callers that only read min/max don't crash. +(define (temporal-range t field) + (let ((f (string-upcase field))) + (cond + ((and (jt-date? t) (string=? f "DAY_OF_MONTH")) + (jt-value-range 1 1 28 (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) (lambda (y m d) (jt-len-of-month y m))))) + ((string=? f "MONTH_OF_YEAR") (jt-value-range 1 1 12 12)) + ((string=? f "DAY_OF_WEEK") (jt-value-range 1 1 7 7)) + ((string=? f "HOUR_OF_DAY") (jt-value-range 0 0 23 23)) + ((string=? f "MINUTE_OF_HOUR") (jt-value-range 0 0 59 59)) + ((string=? f "SECOND_OF_MINUTE") (jt-value-range 0 0 59 59)) + ((string=? f "NANO_OF_SECOND") (jt-value-range 0 0 999999999 999999999)) + (else (jt-value-range 0 0 999999999999 999999999999))))) ;; --- equality / hash / compare / print / instance? -------------------------- (define (jt-date? x) (and (jhost? x) (string=? (jhost-tag x) "local-date"))) @@ -492,6 +1182,25 @@ (register-str-render! jt-instant? (lambda (x) (iso-instant-str (inst-ms x)))) (register-pr-arm! jt-instant? (lambda (x) (iso-instant-str (inst-ms x)))) +;; Phase-2 value types: amounts, enums, and the chrono-unit/field tokens. Each +;; prints as its java.time toString and is = / hashed on its canonical state. +(define (jt-tagged? tag) (lambda (x) (and (jhost? x) (string=? (jhost-tag x) tag)))) +(define (register-jt-value! tag str-fn hash-fn) + (let ((pred (jt-tagged? tag))) + (register-str-render! pred str-fn) + (register-pr-arm! pred str-fn) + (register-eq-arm! (lambda (a b) (or (pred a) (pred b))) + (lambda (a b) (and (pred a) (pred b) (equal? (jhost-state a) (jhost-state b))))) + (register-hash-arm! pred hash-fn))) +(register-jt-value! "duration" dur->string (lambda (x) (jolt-hash (dur-total-nanos x)))) +(register-jt-value! "period" per->string (lambda (x) (jolt-hash (+ (per-years x) (per-months x) (per-days x))))) +(register-jt-value! "month-enum" (lambda (x) (month-name (month-val x))) (lambda (x) (jolt-hash (month-val x)))) +(register-jt-value! "dow-enum" (lambda (x) (dow-name (dow-val x))) (lambda (x) (jolt-hash (dow-val x)))) +(register-jt-value! "year" (lambda (x) (number->string (year-val x))) (lambda (x) (jolt-hash (year-val x)))) +(register-jt-value! "year-month" ym->string (lambda (x) (jolt-hash (+ (* (ym-year x) 13) (ym-month x))))) +(register-jt-value! "chrono-unit" cu-name (lambda (x) (jolt-hash (cu-name x)))) +(register-jt-value! "chrono-field" cf-name (lambda (x) (jolt-hash (cf-name x)))) + ;; compare: same-type java.time values compare on their canonical state. (define %jt-prev-compare jolt-compare) (set! jolt-compare @@ -501,7 +1210,15 @@ ((and (jt-time? a) (jt-time? b)) (cond ((< (lt-nano-of-day a) (lt-nano-of-day b)) -1) ((> (lt-nano-of-day a) (lt-nano-of-day b)) 1) (else 0))) ((and (jt-dt? a) (jt-dt? b)) (ldt-cmp a b)) ((and (jt-instant? a) (jt-instant? b)) (cond ((< (inst-ms a) (inst-ms b)) -1) ((> (inst-ms a) (inst-ms b)) 1) (else 0))) + ((and (jt-tagged-as? a "duration") (jt-tagged-as? b "duration")) + (let ((x (dur-total-nanos a)) (y (dur-total-nanos b))) (cond ((< x y) -1) ((> x y) 1) (else 0)))) + ((and (jt-tagged-as? a "month-enum") (jt-tagged-as? b "month-enum")) (- (month-val a) (month-val b))) + ((and (jt-tagged-as? a "dow-enum") (jt-tagged-as? b "dow-enum")) (- (dow-val a) (dow-val b))) + ((and (jt-tagged-as? a "year") (jt-tagged-as? b "year")) + (let ((x (year-val a)) (y (year-val b))) (cond ((< x y) -1) ((> x y) 1) (else 0)))) + ((and (jt-tagged-as? a "year-month") (jt-tagged-as? b "year-month")) (ym-cmp a b)) (else (%jt-prev-compare a b))))) +(define (jt-tagged-as? x tag) (and (jhost? x) (string=? (jhost-tag x) tag))) (def-var! "clojure.core" "compare" jolt-compare) ;; instance? for the three new tags (inst-time.ss already answers "instant"). @@ -512,4 +1229,12 @@ ((jt-date? val) (if (string=? tn "LocalDate") #t 'pass)) ((jt-time? val) (if (string=? tn "LocalTime") #t 'pass)) ((jt-dt? val) (if (string=? tn "LocalDateTime") #t 'pass)) + ((jt-tagged-as? val "duration") (if (member tn '("Duration" "TemporalAmount")) #t 'pass)) + ((jt-tagged-as? val "period") (if (member tn '("Period" "TemporalAmount")) #t 'pass)) + ((jt-tagged-as? val "month-enum") (if (string=? tn "Month") #t 'pass)) + ((jt-tagged-as? val "dow-enum") (if (string=? tn "DayOfWeek") #t 'pass)) + ((jt-tagged-as? val "year") (if (string=? tn "Year") #t 'pass)) + ((jt-tagged-as? val "year-month") (if (string=? tn "YearMonth") #t 'pass)) + ((jt-tagged-as? val "chrono-unit") (if (member tn '("ChronoUnit" "TemporalUnit")) #t 'pass)) + ((jt-tagged-as? val "chrono-field") (if (member tn '("ChronoField" "TemporalField")) #t 'pass)) (else 'pass))))) diff --git a/host/chez/records.ss b/host/chez/records.ss index a1cb351..776fed6 100644 --- a/host/chez/records.ss +++ b/host/chez/records.ss @@ -144,6 +144,14 @@ ((and (jhost? obj) (string=? (jhost-tag obj) "local-date")) '("LocalDate" "java.time.LocalDate" "Object")) ((and (jhost? obj) (string=? (jhost-tag obj) "local-time")) '("LocalTime" "java.time.LocalTime" "Object")) ((and (jhost? obj) (string=? (jhost-tag obj) "local-date-time")) '("LocalDateTime" "java.time.LocalDateTime" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "duration")) '("Duration" "java.time.Duration" "TemporalAmount" "java.time.temporal.TemporalAmount" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "period")) '("Period" "java.time.Period" "TemporalAmount" "java.time.temporal.TemporalAmount" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "month-enum")) '("Month" "java.time.Month" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "dow-enum")) '("DayOfWeek" "java.time.DayOfWeek" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "year")) '("Year" "java.time.Year" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "year-month")) '("YearMonth" "java.time.YearMonth" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "chrono-unit")) '("ChronoUnit" "java.time.temporal.ChronoUnit" "TemporalUnit" "java.time.temporal.TemporalUnit" "Object")) + ((and (jhost? obj) (string=? (jhost-tag obj) "chrono-field")) '("ChronoField" "java.time.temporal.ChronoField" "TemporalField" "java.time.temporal.TemporalField" "Object")) ;; java.sql.Date — a distinct class from java.util.Date so a protocol ;; extended to both (data.json's JSONWriter) routes a sql.Date to its impl. ((and (jhost? obj) (string=? (jhost-tag obj) "sql-date")) '("java.sql.Date" "Date" "java.util.Date" "Object")) diff --git a/host/chez/seed/image.ss b/host/chez/seed/image.ss index 27ac600..17e8415 100644 --- a/host/chez/seed/image.ss +++ b/host/chez/seed/image.ss @@ -109,17 +109,17 @@ (guard (e (#t #f)) (def-var! "jolt.analyzer" "analyze-ffi-callable" (letrec ((analyze-ffi-callable (lambda (ctx items env) (let fnrec7244 ((ctx ctx) (items items) (env env)) (begin (if (jolt-not (<= 4 (jolt-count items) 5)) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "jolt.ffi/foreign-callable expects (foreign-callable f [argtypes] rettype [:collect-safe])")) jolt-nil) (let* ((_o$7245 (keyword #f "op")) (_o$7246 (keyword #f "ffi-callable")) (_o$7247 (keyword #f "fn")) (_o$7248 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-nth items 1) env)) (_o$7249 (keyword #f "argtypes")) (_o$7250 (jolt-invoke (var-deref "clojure.core" "mapv") (var-deref "clojure.core" "name") (jolt-invoke (var-deref "jolt.host" "form-vec-items") (jolt-nth items 2)))) (_o$7251 (keyword #f "rettype")) (_o$7252 (jolt-invoke (var-deref "clojure.core" "name") (jolt-nth items 3))) (_o$7253 (keyword #f "collect-safe")) (_o$7254 (let* ((and__25__auto (jolt= 5 (jolt-count items)))) (if (jolt-truthy? and__25__auto) (jolt= "collect-safe" (jolt-invoke (var-deref "clojure.core" "name") (jolt-nth items 4))) and__25__auto)))) (jolt-hash-map _o$7245 _o$7246 _o$7247 _o$7248 _o$7249 _o$7250 _o$7251 _o$7252 _o$7253 _o$7254))))))) analyze-ffi-callable))) (guard (e (#t #f)) - (def-var! "jolt.analyzer" "analyze-dot" (letrec ((analyze-dot (lambda (ctx items env) (let fnrec7255 ((ctx ctx) (items items) (env env)) (begin (if (< (jolt-count items) 3) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "Malformed (. target member ...) form")) jolt-nil) (let* ((member (jolt-nth items 2))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-sym?") member)) (let* ((_o$7260 (keyword #f "op")) (_o$7261 (keyword #f "host-call")) (_o$7262 (keyword #f "method")) (_o$7263 (jolt-invoke (var-deref "jolt.host" "form-sym-name") member)) (_o$7264 (keyword #f "target")) (_o$7265 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-nth items 1) env)) (_o$7266 (keyword #f "args")) (_o$7267 (let* ((_a$7257 (var-deref "clojure.core" "mapv")) (_a$7258 (lambda (p__91_) (let fnrec7256 ((p__91_ p__91_)) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx p__91_ env)))) (_a$7259 (jolt-drop 3 items))) (jolt-invoke _a$7257 _a$7258 _a$7259)))) (jolt-hash-map _o$7260 _o$7261 _o$7262 _o$7263 _o$7264 _o$7265 _o$7266 _o$7267)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-keyword?") member)) (let* ((_a$7268 (var-deref "jolt.ir" "invoke")) (_a$7269 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx member env)) (_a$7270 (jolt-vector (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-nth items 1) env)))) (jolt-invoke _a$7268 _a$7269 _a$7270)) (if (jolt-truthy? (keyword #f "else")) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") "special form . (non-symbol member)") jolt-nil))))))))) analyze-dot))) + (def-var! "jolt.analyzer" "analyze-dot" (letrec ((analyze-dot (lambda (ctx items env) (let fnrec7255 ((ctx ctx) (items items) (env env)) (begin (if (< (jolt-count items) 3) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "Malformed (. target member ...) form")) jolt-nil) (let* ((target (jolt-nth items 1)) (member (jolt-nth items 2)) (class-target (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") target))) (if (jolt-truthy? and__25__auto) (jolt-not (jolt-invoke (var-deref "jolt.analyzer" "local?") env (jolt-invoke (var-deref "jolt.host" "form-sym-name") target))) and__25__auto))) (let* ((r (jolt-invoke (var-deref "jolt.host" "resolve-global") ctx target))) (if (jolt= (keyword #f "class") (jolt-get r (keyword #f "kind"))) (jolt-get r (keyword #f "name")) jolt-nil)) jolt-nil))) (if (jolt-truthy? (let* ((and__25__auto class-target)) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-sym?") member) and__25__auto))) (let* ((_a$7260 (var-deref "jolt.ir" "invoke")) (_a$7261 (jolt-invoke (var-deref "jolt.ir" "host-static") class-target (jolt-invoke (var-deref "jolt.host" "form-sym-name") member))) (_a$7262 (let* ((_a$7257 (var-deref "clojure.core" "mapv")) (_a$7258 (lambda (p__91_) (let fnrec7256 ((p__91_ p__91_)) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx p__91_ env)))) (_a$7259 (jolt-drop 3 items))) (jolt-invoke _a$7257 _a$7258 _a$7259)))) (jolt-invoke _a$7260 _a$7261 _a$7262)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-sym?") member)) (let* ((_o$7267 (keyword #f "op")) (_o$7268 (keyword #f "host-call")) (_o$7269 (keyword #f "method")) (_o$7270 (jolt-invoke (var-deref "jolt.host" "form-sym-name") member)) (_o$7271 (keyword #f "target")) (_o$7272 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx target env)) (_o$7273 (keyword #f "args")) (_o$7274 (let* ((_a$7264 (var-deref "clojure.core" "mapv")) (_a$7265 (lambda (p__92_) (let fnrec7263 ((p__92_ p__92_)) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx p__92_ env)))) (_a$7266 (jolt-drop 3 items))) (jolt-invoke _a$7264 _a$7265 _a$7266)))) (jolt-hash-map _o$7267 _o$7268 _o$7269 _o$7270 _o$7271 _o$7272 _o$7273 _o$7274)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-keyword?") member)) (let* ((_a$7275 (var-deref "jolt.ir" "invoke")) (_a$7276 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx member env)) (_a$7277 (jolt-vector (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-nth items 1) env)))) (jolt-invoke _a$7275 _a$7276 _a$7277)) (if (jolt-truthy? (keyword #f "else")) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") "special form . (non-symbol member)") jolt-nil)))))))))) analyze-dot))) (guard (e (#t #f)) - (def-var! "jolt.analyzer" "analyze-field" (letrec ((analyze-field (lambda (ctx hname items env) (let fnrec7271 ((ctx ctx) (hname hname) (items items) (env env)) (begin (if (< (jolt-count items) 2) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "Malformed (.-field target) form")) jolt-nil) (let* ((_o$7272 (keyword #f "op")) (_o$7273 (keyword #f "host-call")) (_o$7274 (keyword #f "method")) (_o$7275 (jolt-invoke (var-deref "clojure.core" "subs") hname 1)) (_o$7276 (keyword #f "target")) (_o$7277 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-nth items 1) env)) (_o$7278 (keyword #f "args")) (_o$7279 (jolt-vector))) (jolt-hash-map _o$7272 _o$7273 _o$7274 _o$7275 _o$7276 _o$7277 _o$7278 _o$7279))))))) analyze-field))) + (def-var! "jolt.analyzer" "analyze-field" (letrec ((analyze-field (lambda (ctx hname items env) (let fnrec7278 ((ctx ctx) (hname hname) (items items) (env env)) (begin (if (< (jolt-count items) 2) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "Malformed (.-field target) form")) jolt-nil) (let* ((_o$7279 (keyword #f "op")) (_o$7280 (keyword #f "host-call")) (_o$7281 (keyword #f "method")) (_o$7282 (jolt-invoke (var-deref "clojure.core" "subs") hname 1)) (_o$7283 (keyword #f "target")) (_o$7284 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-nth items 1) env)) (_o$7285 (keyword #f "args")) (_o$7286 (jolt-vector))) (jolt-hash-map _o$7279 _o$7280 _o$7281 _o$7282 _o$7283 _o$7284 _o$7285 _o$7286))))))) analyze-field))) (guard (e (#t #f)) - (def-var! "jolt.analyzer" "analyze-symbol" (letrec ((analyze-symbol (lambda (ctx form env) (let fnrec7280 ((ctx ctx) (form form) (env env)) (let* ((nm (jolt-invoke (var-deref "jolt.host" "form-sym-name") form)) (ns (jolt-invoke (var-deref "jolt.host" "form-sym-ns") form))) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "clojure.core" "nil?") ns))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "local?") env nm) and__25__auto))) (let* ((h (jolt-get (jolt-get env (keyword #f "hints")) nm))) (if (jolt-truthy? h) (jolt-assoc (jolt-invoke (var-deref "jolt.ir" "local") nm) (keyword #f "hint") h) (jolt-invoke (var-deref "jolt.ir" "local") nm))) (if (jolt-truthy? ns) (let* ((r (jolt-invoke (var-deref "jolt.host" "resolve-global") ctx form))) (if (jolt= (keyword #f "var") (jolt-get r (keyword #f "kind"))) (let* ((G__134 (let* ((_a$7281 (var-deref "jolt.ir" "var-ref")) (_a$7282 (jolt-get r (keyword #f "ns"))) (_a$7283 (jolt-get r (keyword #f "name")))) (jolt-invoke _a$7281 _a$7282 _a$7283)))) (let* ((G__135 (if (jolt-truthy? (jolt-get r (keyword #f "num-ret"))) (jolt-assoc G__134 (keyword #f "num-ret") (jolt-get r (keyword #f "num-ret"))) G__134))) G__135)) (jolt-invoke (var-deref "jolt.ir" "host-static") ns nm))) (if (jolt-truthy? (keyword #f "else")) (let* ((r (jolt-invoke (var-deref "jolt.host" "resolve-global") ctx form))) (let* ((G__136 (jolt-get r (keyword #f "kind")))) (if (jolt= G__136 (keyword #f "var")) (let* ((G__137 (let* ((_a$7284 (var-deref "jolt.ir" "var-ref")) (_a$7285 (jolt-get r (keyword #f "ns"))) (_a$7286 (jolt-get r (keyword #f "name")))) (jolt-invoke _a$7284 _a$7285 _a$7286)))) (let* ((G__138 (if (jolt-truthy? (jolt-get r (keyword #f "num-ret"))) (jolt-assoc G__137 (keyword #f "num-ret") (jolt-get r (keyword #f "num-ret"))) G__137))) G__138)) (if (jolt= G__136 (keyword #f "host")) (jolt-invoke (var-deref "jolt.ir" "host-ref") (jolt-get r (keyword #f "name"))) (if (jolt= G__136 (keyword #f "class")) (jolt-invoke (var-deref "jolt.ir" "const") (jolt-get r (keyword #f "name"))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "late-bind?") ctx)) (jolt-invoke (var-deref "jolt.ir" "var-ref") (jolt-invoke (var-deref "jolt.host" "compile-ns") ctx) nm) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") (jolt-invoke (var-deref "clojure.core" "str") "Unable to resolve symbol: " nm " in this context")))))))) jolt-nil)))))))) analyze-symbol))) + (def-var! "jolt.analyzer" "analyze-symbol" (letrec ((analyze-symbol (lambda (ctx form env) (let fnrec7287 ((ctx ctx) (form form) (env env)) (let* ((nm (jolt-invoke (var-deref "jolt.host" "form-sym-name") form)) (ns (jolt-invoke (var-deref "jolt.host" "form-sym-ns") form))) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "clojure.core" "nil?") ns))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "local?") env nm) and__25__auto))) (let* ((h (jolt-get (jolt-get env (keyword #f "hints")) nm))) (if (jolt-truthy? h) (jolt-assoc (jolt-invoke (var-deref "jolt.ir" "local") nm) (keyword #f "hint") h) (jolt-invoke (var-deref "jolt.ir" "local") nm))) (if (jolt-truthy? ns) (let* ((r (jolt-invoke (var-deref "jolt.host" "resolve-global") ctx form))) (if (jolt= (keyword #f "var") (jolt-get r (keyword #f "kind"))) (let* ((G__134 (let* ((_a$7288 (var-deref "jolt.ir" "var-ref")) (_a$7289 (jolt-get r (keyword #f "ns"))) (_a$7290 (jolt-get r (keyword #f "name")))) (jolt-invoke _a$7288 _a$7289 _a$7290)))) (let* ((G__135 (if (jolt-truthy? (jolt-get r (keyword #f "num-ret"))) (jolt-assoc G__134 (keyword #f "num-ret") (jolt-get r (keyword #f "num-ret"))) G__134))) G__135)) (jolt-invoke (var-deref "jolt.ir" "host-static") ns nm))) (if (jolt-truthy? (keyword #f "else")) (let* ((r (jolt-invoke (var-deref "jolt.host" "resolve-global") ctx form))) (let* ((G__136 (jolt-get r (keyword #f "kind")))) (if (jolt= G__136 (keyword #f "var")) (let* ((G__137 (let* ((_a$7291 (var-deref "jolt.ir" "var-ref")) (_a$7292 (jolt-get r (keyword #f "ns"))) (_a$7293 (jolt-get r (keyword #f "name")))) (jolt-invoke _a$7291 _a$7292 _a$7293)))) (let* ((G__138 (if (jolt-truthy? (jolt-get r (keyword #f "num-ret"))) (jolt-assoc G__137 (keyword #f "num-ret") (jolt-get r (keyword #f "num-ret"))) G__137))) G__138)) (if (jolt= G__136 (keyword #f "host")) (jolt-invoke (var-deref "jolt.ir" "host-ref") (jolt-get r (keyword #f "name"))) (if (jolt= G__136 (keyword #f "class")) (jolt-invoke (var-deref "jolt.ir" "const") (jolt-get r (keyword #f "name"))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "late-bind?") ctx)) (jolt-invoke (var-deref "jolt.ir" "var-ref") (jolt-invoke (var-deref "jolt.host" "compile-ns") ctx) nm) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") (jolt-invoke (var-deref "clojure.core" "str") "Unable to resolve symbol: " nm " in this context")))))))) jolt-nil)))))))) analyze-symbol))) (guard (e (#t #f)) - (def-var! "jolt.analyzer" "analyze-list" (letrec ((analyze-list (lambda (ctx form env) (let fnrec7287 ((ctx ctx) (form form) (env env)) (let* ((items (jolt-invoke (var-deref "clojure.core" "vec") (jolt-invoke (var-deref "jolt.host" "form-elements") form)))) (if (jolt-zero? (jolt-count items)) (jolt-invoke (var-deref "jolt.ir" "quote-node") form) (let* ((head (jolt-first items)) (hname (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "clojure.core" "nil?") (jolt-invoke (var-deref "jolt.host" "form-sym-ns") head)) and__25__auto))) (jolt-invoke (var-deref "jolt.host" "form-sym-name") head) jolt-nil)) (shadowed (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "local?") env hname) and__25__auto)))) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-macro?") ctx head) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-invoke (var-deref "jolt.host" "form-expand-1") ctx form) env) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt= "jolt.ffi" (jolt-invoke (var-deref "jolt.host" "form-sym-ns") head)))) (if (jolt-truthy? and__25__auto) (jolt= "__cfn" (jolt-invoke (var-deref "jolt.host" "form-sym-name") head)) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-ffi-fn") ctx items env) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt= "jolt.ffi" (jolt-invoke (var-deref "jolt.host" "form-sym-ns") head)))) (if (jolt-truthy? and__25__auto) (jolt= "__ccallable" (jolt-invoke (var-deref "jolt.host" "form-sym-name") head)) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-ffi-callable") ctx items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (jolt-contains? (var-deref "jolt.analyzer" "handled") hname) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-special") ctx hname items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "method-head?") hname) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-host-call") ctx hname items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "ctor-head?") hname) and__25__auto)) and__25__auto))) (let* ((_a$7288 (var-deref "jolt.analyzer" "analyze-ctor")) (_a$7289 ctx) (_a$7290 (jolt-invoke (var-deref "clojure.core" "subs") hname 0 (jolt-dec (jolt-count hname)))) (_a$7291 (jolt-rest items)) (_a$7292 env)) (jolt-invoke _a$7288 _a$7289 _a$7290 _a$7291 _a$7292)) (if (jolt-truthy? (let* ((and__25__auto (jolt= hname "new"))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (>= (jolt-count items) 2))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-sym?") (jolt-nth items 1)) and__25__auto)) and__25__auto)) and__25__auto))) (let* ((_a$7293 (var-deref "jolt.analyzer" "analyze-ctor")) (_a$7294 ctx) (_a$7295 (jolt-invoke (var-deref "jolt.host" "form-sym-name") (jolt-nth items 1))) (_a$7296 (jolt-drop 2 items)) (_a$7297 env)) (jolt-invoke _a$7293 _a$7294 _a$7295 _a$7296 _a$7297)) (if (jolt-truthy? (let* ((and__25__auto (jolt= hname "."))) (if (jolt-truthy? and__25__auto) (jolt-not shadowed) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-dot") ctx items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "field-head?") hname) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-field") ctx hname items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-special?") hname) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") (jolt-invoke (var-deref "clojure.core" "str") "special form " hname)) (if (jolt-truthy? (keyword #f "else")) (let* ((n (let* ((_a$7302 (var-deref "jolt.ir" "invoke")) (_a$7303 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx head env)) (_a$7304 (let* ((_a$7299 (var-deref "clojure.core" "mapv")) (_a$7300 (lambda (p__92_) (let fnrec7298 ((p__92_ p__92_)) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx p__92_ env)))) (_a$7301 (jolt-rest items))) (jolt-invoke _a$7299 _a$7300 _a$7301)))) (jolt-invoke _a$7302 _a$7303 _a$7304))) (p (jolt-invoke (var-deref "jolt.host" "form-position") form))) (if (jolt-truthy? p) (jolt-assoc n (keyword #f "pos") p) n)) jolt-nil)))))))))))))))))) analyze-list))) + (def-var! "jolt.analyzer" "analyze-list" (letrec ((analyze-list (lambda (ctx form env) (let fnrec7294 ((ctx ctx) (form form) (env env)) (let* ((items (jolt-invoke (var-deref "clojure.core" "vec") (jolt-invoke (var-deref "jolt.host" "form-elements") form)))) (if (jolt-zero? (jolt-count items)) (jolt-invoke (var-deref "jolt.ir" "quote-node") form) (let* ((head (jolt-first items)) (hname (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "clojure.core" "nil?") (jolt-invoke (var-deref "jolt.host" "form-sym-ns") head)) and__25__auto))) (jolt-invoke (var-deref "jolt.host" "form-sym-name") head) jolt-nil)) (shadowed (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "local?") env hname) and__25__auto)))) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-macro?") ctx head) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx (jolt-invoke (var-deref "jolt.host" "form-expand-1") ctx form) env) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt= "jolt.ffi" (jolt-invoke (var-deref "jolt.host" "form-sym-ns") head)))) (if (jolt-truthy? and__25__auto) (jolt= "__cfn" (jolt-invoke (var-deref "jolt.host" "form-sym-name") head)) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-ffi-fn") ctx items env) (if (jolt-truthy? (let* ((and__25__auto (jolt-invoke (var-deref "jolt.host" "form-sym?") head))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt= "jolt.ffi" (jolt-invoke (var-deref "jolt.host" "form-sym-ns") head)))) (if (jolt-truthy? and__25__auto) (jolt= "__ccallable" (jolt-invoke (var-deref "jolt.host" "form-sym-name") head)) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-ffi-callable") ctx items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (jolt-contains? (var-deref "jolt.analyzer" "handled") hname) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-special") ctx hname items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "method-head?") hname) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-host-call") ctx hname items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "ctor-head?") hname) and__25__auto)) and__25__auto))) (let* ((_a$7295 (var-deref "jolt.analyzer" "analyze-ctor")) (_a$7296 ctx) (_a$7297 (jolt-invoke (var-deref "clojure.core" "subs") hname 0 (jolt-dec (jolt-count hname)))) (_a$7298 (jolt-rest items)) (_a$7299 env)) (jolt-invoke _a$7295 _a$7296 _a$7297 _a$7298 _a$7299)) (if (jolt-truthy? (let* ((and__25__auto (jolt= hname "new"))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (>= (jolt-count items) 2))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-sym?") (jolt-nth items 1)) and__25__auto)) and__25__auto)) and__25__auto))) (let* ((_a$7300 (var-deref "jolt.analyzer" "analyze-ctor")) (_a$7301 ctx) (_a$7302 (jolt-invoke (var-deref "jolt.host" "form-sym-name") (jolt-nth items 1))) (_a$7303 (jolt-drop 2 items)) (_a$7304 env)) (jolt-invoke _a$7300 _a$7301 _a$7302 _a$7303 _a$7304)) (if (jolt-truthy? (let* ((and__25__auto (jolt= hname "."))) (if (jolt-truthy? and__25__auto) (jolt-not shadowed) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-dot") ctx items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.analyzer" "field-head?") hname) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "analyze-field") ctx hname items env) (if (jolt-truthy? (let* ((and__25__auto hname)) (if (jolt-truthy? and__25__auto) (let* ((and__25__auto (jolt-not shadowed))) (if (jolt-truthy? and__25__auto) (jolt-invoke (var-deref "jolt.host" "form-special?") hname) and__25__auto)) and__25__auto))) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") (jolt-invoke (var-deref "clojure.core" "str") "special form " hname)) (if (jolt-truthy? (keyword #f "else")) (let* ((n (let* ((_a$7309 (var-deref "jolt.ir" "invoke")) (_a$7310 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx head env)) (_a$7311 (let* ((_a$7306 (var-deref "clojure.core" "mapv")) (_a$7307 (lambda (p__93_) (let fnrec7305 ((p__93_ p__93_)) (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx p__93_ env)))) (_a$7308 (jolt-rest items))) (jolt-invoke _a$7306 _a$7307 _a$7308)))) (jolt-invoke _a$7309 _a$7310 _a$7311))) (p (jolt-invoke (var-deref "jolt.host" "form-position") form))) (if (jolt-truthy? p) (jolt-assoc n (keyword #f "pos") p) n)) jolt-nil)))))))))))))))))) analyze-list))) (guard (e (#t #f)) - (def-var! "jolt.analyzer" "with-coll-meta" (letrec ((with-coll-meta (lambda (ctx form env node) (let fnrec7305 ((ctx ctx) (form form) (env env) (node node)) (let* ((m (jolt-invoke (var-deref "jolt.host" "form-coll-meta") form))) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "nil?") m)) node (let* ((_a$7308 (var-deref "jolt.ir" "invoke")) (_a$7309 (jolt-invoke (var-deref "jolt.ir" "var-ref") "clojure.core" "with-meta")) (_a$7310 (let* ((_o$7306 node) (_o$7307 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx m env))) (jolt-vector _o$7306 _o$7307)))) (jolt-invoke _a$7308 _a$7309 _a$7310)))))))) with-coll-meta))) + (def-var! "jolt.analyzer" "with-coll-meta" (letrec ((with-coll-meta (lambda (ctx form env node) (let fnrec7312 ((ctx ctx) (form form) (env env) (node node)) (let* ((m (jolt-invoke (var-deref "jolt.host" "form-coll-meta") form))) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "nil?") m)) node (let* ((_a$7315 (var-deref "jolt.ir" "invoke")) (_a$7316 (jolt-invoke (var-deref "jolt.ir" "var-ref") "clojure.core" "with-meta")) (_a$7317 (let* ((_o$7313 node) (_o$7314 (jolt-invoke (var-deref "jolt.analyzer" "analyze") ctx m env))) (jolt-vector _o$7313 _o$7314)))) (jolt-invoke _a$7315 _a$7316 _a$7317)))))))) with-coll-meta))) (guard (e (#t #f)) - (def-var! "jolt.analyzer" "analyze" (letrec ((analyze (case-lambda ((ctx form) (let fnrec7311 ((ctx ctx) (form form)) (jolt-invoke analyze ctx form (jolt-invoke (var-deref "jolt.analyzer" "empty-env"))))) ((ctx form env) (let fnrec7312 ((ctx ctx) (form form) (env env)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-literal?") form)) (jolt-invoke (var-deref "jolt.ir" "const") form) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-sym?") form)) (jolt-invoke (var-deref "jolt.analyzer" "analyze-symbol") ctx form env) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-vec?") form)) (jolt-invoke (var-deref "jolt.analyzer" "with-coll-meta") ctx form env (jolt-invoke (var-deref "jolt.ir" "vector-node") (let* ((_a$7314 (var-deref "clojure.core" "mapv")) (_a$7315 (lambda (p__93_) (let fnrec7313 ((p__93_ p__93_)) (jolt-invoke analyze ctx p__93_ env)))) (_a$7316 (jolt-invoke (var-deref "jolt.host" "form-vec-items") form))) (jolt-invoke _a$7314 _a$7315 _a$7316)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-map?") form)) (jolt-invoke (var-deref "jolt.analyzer" "with-coll-meta") ctx form env (jolt-invoke (var-deref "jolt.ir" "map-node") (let* ((_a$7320 (var-deref "clojure.core" "mapv")) (_a$7321 (lambda (p) (let fnrec7317 ((p p)) (let* ((_o$7318 (jolt-invoke analyze ctx (jolt-first p) env)) (_o$7319 (jolt-invoke analyze ctx (jolt-invoke (var-deref "clojure.core" "second") p) env))) (jolt-vector _o$7318 _o$7319))))) (_a$7322 (jolt-invoke (var-deref "jolt.host" "form-map-pairs") form))) (jolt-invoke _a$7320 _a$7321 _a$7322)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-set?") form)) (jolt-invoke (var-deref "jolt.analyzer" "with-coll-meta") ctx form env (jolt-invoke (var-deref "jolt.ir" "set-node") (let* ((_a$7324 (var-deref "clojure.core" "mapv")) (_a$7325 (lambda (p__94_) (let fnrec7323 ((p__94_ p__94_)) (jolt-invoke analyze ctx p__94_ env)))) (_a$7326 (jolt-invoke (var-deref "jolt.host" "form-set-items") form))) (jolt-invoke _a$7324 _a$7325 _a$7326)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-list?") form)) (jolt-invoke (var-deref "jolt.analyzer" "analyze-list") ctx form env) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-regex?") form)) (let* ((_o$7327 (keyword #f "op")) (_o$7328 (keyword #f "regex")) (_o$7329 (keyword #f "source")) (_o$7330 (jolt-invoke (var-deref "jolt.host" "form-regex-source") form))) (jolt-hash-map _o$7327 _o$7328 _o$7329 _o$7330)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-inst?") form)) (let* ((_o$7331 (keyword #f "op")) (_o$7332 (keyword #f "inst")) (_o$7333 (keyword #f "source")) (_o$7334 (jolt-invoke (var-deref "jolt.host" "form-inst-source") form))) (jolt-hash-map _o$7331 _o$7332 _o$7333 _o$7334)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-uuid?") form)) (let* ((_o$7335 (keyword #f "op")) (_o$7336 (keyword #f "uuid")) (_o$7337 (keyword #f "source")) (_o$7338 (jolt-invoke (var-deref "jolt.host" "form-uuid-source") form))) (jolt-hash-map _o$7335 _o$7336 _o$7337 _o$7338)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-bigdec?") form)) (let* ((_o$7339 (keyword #f "op")) (_o$7340 (keyword #f "bigdec")) (_o$7341 (keyword #f "source")) (_o$7342 (jolt-invoke (var-deref "jolt.host" "form-bigdec-source") form))) (jolt-hash-map _o$7339 _o$7340 _o$7341 _o$7342)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-ns-value?") form)) (let* ((_o$7343 (keyword #f "op")) (_o$7344 (keyword #f "the-ns")) (_o$7345 (keyword #f "name")) (_o$7346 (jolt-invoke (var-deref "jolt.host" "form-ns-value-name") form))) (jolt-hash-map _o$7343 _o$7344 _o$7345 _o$7346)) (if (jolt-truthy? (keyword #f "else")) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") "unsupported form") jolt-nil))))))))))))))))) analyze))) + (def-var! "jolt.analyzer" "analyze" (letrec ((analyze (case-lambda ((ctx form) (let fnrec7318 ((ctx ctx) (form form)) (jolt-invoke analyze ctx form (jolt-invoke (var-deref "jolt.analyzer" "empty-env"))))) ((ctx form env) (let fnrec7319 ((ctx ctx) (form form) (env env)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-literal?") form)) (jolt-invoke (var-deref "jolt.ir" "const") form) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-sym?") form)) (jolt-invoke (var-deref "jolt.analyzer" "analyze-symbol") ctx form env) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-vec?") form)) (jolt-invoke (var-deref "jolt.analyzer" "with-coll-meta") ctx form env (jolt-invoke (var-deref "jolt.ir" "vector-node") (let* ((_a$7321 (var-deref "clojure.core" "mapv")) (_a$7322 (lambda (p__94_) (let fnrec7320 ((p__94_ p__94_)) (jolt-invoke analyze ctx p__94_ env)))) (_a$7323 (jolt-invoke (var-deref "jolt.host" "form-vec-items") form))) (jolt-invoke _a$7321 _a$7322 _a$7323)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-map?") form)) (jolt-invoke (var-deref "jolt.analyzer" "with-coll-meta") ctx form env (jolt-invoke (var-deref "jolt.ir" "map-node") (let* ((_a$7327 (var-deref "clojure.core" "mapv")) (_a$7328 (lambda (p) (let fnrec7324 ((p p)) (let* ((_o$7325 (jolt-invoke analyze ctx (jolt-first p) env)) (_o$7326 (jolt-invoke analyze ctx (jolt-invoke (var-deref "clojure.core" "second") p) env))) (jolt-vector _o$7325 _o$7326))))) (_a$7329 (jolt-invoke (var-deref "jolt.host" "form-map-pairs") form))) (jolt-invoke _a$7327 _a$7328 _a$7329)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-set?") form)) (jolt-invoke (var-deref "jolt.analyzer" "with-coll-meta") ctx form env (jolt-invoke (var-deref "jolt.ir" "set-node") (let* ((_a$7331 (var-deref "clojure.core" "mapv")) (_a$7332 (lambda (p__95_) (let fnrec7330 ((p__95_ p__95_)) (jolt-invoke analyze ctx p__95_ env)))) (_a$7333 (jolt-invoke (var-deref "jolt.host" "form-set-items") form))) (jolt-invoke _a$7331 _a$7332 _a$7333)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-list?") form)) (jolt-invoke (var-deref "jolt.analyzer" "analyze-list") ctx form env) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-regex?") form)) (let* ((_o$7334 (keyword #f "op")) (_o$7335 (keyword #f "regex")) (_o$7336 (keyword #f "source")) (_o$7337 (jolt-invoke (var-deref "jolt.host" "form-regex-source") form))) (jolt-hash-map _o$7334 _o$7335 _o$7336 _o$7337)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-inst?") form)) (let* ((_o$7338 (keyword #f "op")) (_o$7339 (keyword #f "inst")) (_o$7340 (keyword #f "source")) (_o$7341 (jolt-invoke (var-deref "jolt.host" "form-inst-source") form))) (jolt-hash-map _o$7338 _o$7339 _o$7340 _o$7341)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-uuid?") form)) (let* ((_o$7342 (keyword #f "op")) (_o$7343 (keyword #f "uuid")) (_o$7344 (keyword #f "source")) (_o$7345 (jolt-invoke (var-deref "jolt.host" "form-uuid-source") form))) (jolt-hash-map _o$7342 _o$7343 _o$7344 _o$7345)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-bigdec?") form)) (let* ((_o$7346 (keyword #f "op")) (_o$7347 (keyword #f "bigdec")) (_o$7348 (keyword #f "source")) (_o$7349 (jolt-invoke (var-deref "jolt.host" "form-bigdec-source") form))) (jolt-hash-map _o$7346 _o$7347 _o$7348 _o$7349)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-ns-value?") form)) (let* ((_o$7350 (keyword #f "op")) (_o$7351 (keyword #f "the-ns")) (_o$7352 (keyword #f "name")) (_o$7353 (jolt-invoke (var-deref "jolt.host" "form-ns-value-name") form))) (jolt-hash-map _o$7350 _o$7351 _o$7352 _o$7353)) (if (jolt-truthy? (keyword #f "else")) (jolt-invoke (var-deref "jolt.analyzer" "uncompilable") "unsupported form") jolt-nil))))))))))))))))) analyze))) (guard (e (#t #f)) (def-var-with-meta! "jolt.backend-scheme" "native-ops" (let* ((_o$5919 "+") (_o$5920 "+") (_o$5921 "-") (_o$5922 "-") (_o$5923 "*") (_o$5924 "*") (_o$5925 "/") (_o$5926 "/") (_o$5927 "<") (_o$5928 "<") (_o$5929 ">") (_o$5930 ">") (_o$5931 "<=") (_o$5932 "<=") (_o$5933 ">=") (_o$5934 ">=") (_o$5935 "=") (_o$5936 "jolt=") (_o$5937 "inc") (_o$5938 "jolt-inc") (_o$5939 "dec") (_o$5940 "jolt-dec") (_o$5941 "not") (_o$5942 "jolt-not") (_o$5943 "min") (_o$5944 "min") (_o$5945 "max") (_o$5946 "max") (_o$5947 "mod") (_o$5948 "modulo") (_o$5949 "rem") (_o$5950 "remainder") (_o$5951 "quot") (_o$5952 "quotient") (_o$5953 "vector") (_o$5954 "jolt-vector") (_o$5955 "hash-map") (_o$5956 "jolt-hash-map") (_o$5957 "hash-set") (_o$5958 "jolt-hash-set") (_o$5959 "conj") (_o$5960 "jolt-conj") (_o$5961 "get") (_o$5962 "jolt-get") (_o$5963 "nth") (_o$5964 "jolt-nth") (_o$5965 "count") (_o$5966 "jolt-count") (_o$5967 "assoc") (_o$5968 "jolt-assoc") (_o$5969 "dissoc") (_o$5970 "jolt-dissoc") (_o$5971 "contains?") (_o$5972 "jolt-contains?") (_o$5973 "empty?") (_o$5974 "jolt-empty?") (_o$5975 "peek") (_o$5976 "jolt-peek") (_o$5977 "pop") (_o$5978 "jolt-pop") (_o$5979 "first") (_o$5980 "jolt-first") (_o$5981 "rest") (_o$5982 "jolt-rest") (_o$5983 "next") (_o$5984 "jolt-next") (_o$5985 "seq") (_o$5986 "jolt-seq") (_o$5987 "cons") (_o$5988 "jolt-cons") (_o$5989 "list") (_o$5990 "jolt-list") (_o$5991 "reverse") (_o$5992 "jolt-reverse") (_o$5993 "last") (_o$5994 "jolt-last") (_o$5995 "map") (_o$5996 "jolt-map") (_o$5997 "filter") (_o$5998 "jolt-filter") (_o$5999 "remove") (_o$6000 "jolt-remove") (_o$6001 "reduce") (_o$6002 "jolt-reduce") (_o$6003 "into") (_o$6004 "jolt-into") (_o$6005 "concat") (_o$6006 "jolt-concat") (_o$6007 "apply") (_o$6008 "jolt-apply") (_o$6009 "range") (_o$6010 "jolt-range") (_o$6011 "take") (_o$6012 "jolt-take") (_o$6013 "drop") (_o$6014 "jolt-drop") (_o$6015 "keys") (_o$6016 "jolt-keys") (_o$6017 "vals") (_o$6018 "jolt-vals") (_o$6019 "even?") (_o$6020 "jolt-even?") (_o$6021 "odd?") (_o$6022 "jolt-odd?") (_o$6023 "pos?") (_o$6024 "jolt-pos?") (_o$6025 "neg?") (_o$6026 "jolt-neg?") (_o$6027 "zero?") (_o$6028 "jolt-zero?") (_o$6029 "identity") (_o$6030 "jolt-identity") (_o$6031 "ex-info") (_o$6032 "jolt-ex-info")) (jolt-hash-map _o$5919 _o$5920 _o$5921 _o$5922 _o$5923 _o$5924 _o$5925 _o$5926 _o$5927 _o$5928 _o$5929 _o$5930 _o$5931 _o$5932 _o$5933 _o$5934 _o$5935 _o$5936 _o$5937 _o$5938 _o$5939 _o$5940 _o$5941 _o$5942 _o$5943 _o$5944 _o$5945 _o$5946 _o$5947 _o$5948 _o$5949 _o$5950 _o$5951 _o$5952 _o$5953 _o$5954 _o$5955 _o$5956 _o$5957 _o$5958 _o$5959 _o$5960 _o$5961 _o$5962 _o$5963 _o$5964 _o$5965 _o$5966 _o$5967 _o$5968 _o$5969 _o$5970 _o$5971 _o$5972 _o$5973 _o$5974 _o$5975 _o$5976 _o$5977 _o$5978 _o$5979 _o$5980 _o$5981 _o$5982 _o$5983 _o$5984 _o$5985 _o$5986 _o$5987 _o$5988 _o$5989 _o$5990 _o$5991 _o$5992 _o$5993 _o$5994 _o$5995 _o$5996 _o$5997 _o$5998 _o$5999 _o$6000 _o$6001 _o$6002 _o$6003 _o$6004 _o$6005 _o$6006 _o$6007 _o$6008 _o$6009 _o$6010 _o$6011 _o$6012 _o$6013 _o$6014 _o$6015 _o$6016 _o$6017 _o$6018 _o$6019 _o$6020 _o$6021 _o$6022 _o$6023 _o$6024 _o$6025 _o$6026 _o$6027 _o$6028 _o$6029 _o$6030 _o$6031 _o$6032)) (jolt-hash-map (keyword #f "private") #t))) (guard (e (#t #f)) diff --git a/jolt-core/jolt/analyzer.clj b/jolt-core/jolt/analyzer.clj index d16ca55..771fc4e 100644 --- a/jolt-core/jolt/analyzer.clj +++ b/jolt-core/jolt/analyzer.clj @@ -478,12 +478,23 @@ (defn- analyze-dot [ctx items env] (when (< (count items) 3) (throw (str "Malformed (. target member ...) form"))) - (let [member (nth items 2)] + (let [target (nth items 1) + member (nth items 2) + ;; (. Class method args*) with a class target is a static call — + ;; equivalent to (Class/method args*). resolve-global tags a class + ;; symbol :kind :class; a local of the same name shadows it. + class-target (when (and (form-sym? target) + (not (local? env (form-sym-name target)))) + (let [r (resolve-global ctx target)] + (when (= :class (:kind r)) (:name r))))] (cond + (and class-target (form-sym? member)) + (invoke (host-static class-target (form-sym-name member)) + (mapv #(analyze ctx % env) (drop 3 items))) (form-sym? member) {:op :host-call :method (form-sym-name member) - :target (analyze ctx (nth items 1) env) + :target (analyze ctx target env) :args (mapv #(analyze ctx % env) (drop 3 items))} ;; (. obj :kw) is a keyword lookup — invoke the keyword on the target. (form-keyword? member) diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index fe15c27..f48333a 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -3011,4 +3011,16 @@ {:suite "interop / java.time" :label "LocalDateTime toString" :expected "\"2020-01-15T10:30\"" :actual "(str (java.time.LocalDateTime/of 2020 1 15 10 30 0))"} {:suite "interop / java.time" :label "Instant ofEpochMilli toString" :expected "\"2020-01-15T10:30:00Z\"" :actual "(str (java.time.Instant/ofEpochMilli 1579084200000))"} {:suite "interop / java.time" :label "Instant ofEpochMilli round-trip" :expected "1579084200000" :actual "(.toEpochMilli (java.time.Instant/ofEpochMilli 1579084200000))"} + {:suite "interop / java.time" :label "Duration ofSeconds toString" :expected "\"PT1M30S\"" :actual "(str (java.time.Duration/ofSeconds 90))"} + {:suite "interop / java.time" :label "Duration between instants" :expected "\"PT1H1M1S\"" :actual "(str (java.time.Duration/between (java.time.Instant/ofEpochSecond 0) (java.time.Instant/ofEpochSecond 3661)))"} + {:suite "interop / java.time" :label "Period between dates" :expected "\"P1Y2M2D\"" :actual "(str (java.time.Period/between (java.time.LocalDate/of 2020 1 1) (java.time.LocalDate/of 2021 3 3)))"} + {:suite "interop / java.time" :label "Period parse round-trip" :expected "\"P1Y2M3D\"" :actual "(str (java.time.Period/parse \"P1Y2M3D\"))"} + {:suite "interop / java.time" :label "Period normalized" :expected "\"P2Y1M5D\"" :actual "(str (.normalized (java.time.Period/of 1 13 5)))"} + {:suite "interop / java.time" :label "Month of toString" :expected "\"FEBRUARY\"" :actual "(.toString (java.time.Month/of 2))"} + {:suite "interop / java.time" :label "Month length leap" :expected "29" :actual "(.length (java.time.Month/of 2) true)"} + {:suite "interop / java.time" :label "DayOfWeek constant prints name" :expected "\"MONDAY\"" :actual "(str java.time.DayOfWeek/MONDAY)"} + {:suite "interop / java.time" :label "YearMonth toString" :expected "\"2020-02\"" :actual "(str (java.time.YearMonth/of 2020 2))"} + {:suite "interop / java.time" :label "ChronoUnit DAYS between" :expected "14" :actual "(.between java.time.temporal.ChronoUnit/DAYS (java.time.LocalDate/of 2020 1 1) (java.time.LocalDate/of 2020 1 15))"} + {:suite "interop / java.time" :label "LocalDate plus ChronoUnit DAYS" :expected "\"2020-01-04\"" :actual "(str (.plus (java.time.LocalDate/of 2020 1 1) 3 java.time.temporal.ChronoUnit/DAYS))"} + {:suite "interop / java.time" :label "LocalDate until ChronoUnit DAYS" :expected "31" :actual "(.until (java.time.LocalDate/of 2020 1 1) (java.time.LocalDate/of 2020 2 1) java.time.temporal.ChronoUnit/DAYS)"} ]