48908f3a9b
General fixes from clojure.spec.alpha's test suite.
- (symbol a-var) returns the var's qualified symbol (clojure.spec.alpha/->sym).
- clojure.lang.Compiler/demunge reverses Clojure's name munging
("clojure.core$odd_QMARK_" -> clojure.core/odd?); spec's fn-sym uses it.
- clojure.lang.MultiFn .dispatchFn / .getMethod — spec's multi-spec walks a
multimethod through them.
- (.applyTo f args) applies a fn to a seq of args (spec instrument).
Most of spec.alpha's conform/explain/describe suite passes. Remaining gaps:
explain-data's :pred for a BARE fn predicate (jolt fns don't carry their defining
symbol, so fn-sym can't recover it), #inst form rendering, and instrument — follow-up.
make test green (+3 corpus rows, 0 new divergences), runtime only (no re-mint).
210 lines
10 KiB
Scheme
210 lines
10 KiB
Scheme
;; converters + string ops — host-coupled natives def-var!'d into clojure.core,
|
|
;; resolved in prelude mode. Loaded last (after jolt-pr-str), since `str` reuses
|
|
;; the printer. int/long truncate toward zero to an exact integer; compare returns
|
|
;; an exact -1/0/1; double yields a flonum.
|
|
|
|
;; str rendering for the value types not handled by the fast arms below. A host
|
|
;; shim loaded later (records, host-table, inst-time, …) registers an arm with
|
|
;; register-str-render! instead of set!-wrapping jolt-str-render-one — the arms
|
|
;; are type-disjoint, so the full behavior is the base arms here plus the
|
|
;; registry, gathered in one place rather than scattered across a set! chain.
|
|
;; Newest registration is checked first (matches the old outermost-wins order).
|
|
(define str-render-registry '()) ; list of (pred . render), checked front-to-back
|
|
(define (register-str-render! pred render)
|
|
(set! str-render-registry (cons (cons pred render) str-render-registry)))
|
|
|
|
;; str: nil -> "", string raw, char bare (not \c), regex -> raw source, a
|
|
;; registered host type via its arm, else the printer (which renders collections
|
|
;; with readable elements).
|
|
(define (jolt-str-render-one v)
|
|
(cond
|
|
((jolt-nil? v) "")
|
|
((string? v) v)
|
|
((char? v) (string v))
|
|
((regex-t? v) (regex-t-source v))
|
|
;; str/print render the infinities and NaN long-form (Clojure .toString),
|
|
;; unlike the -e printer's inf/-inf/nan.
|
|
((and (flonum? v) (fl= v +inf.0)) "Infinity")
|
|
((and (flonum? v) (fl= v -inf.0)) "-Infinity")
|
|
((and (flonum? v) (not (fl= v v))) "NaN")
|
|
;; a symbol stringifies to its name (JVM Symbol.toString returns the interned
|
|
;; name), so (str sym) of a no-ns symbol is the SAME string object the symbol
|
|
;; holds — code that compares those by identity (core.logic's non-unique lvar
|
|
;; equality) depends on it.
|
|
((symbol-t? v)
|
|
(let ((ns (symbol-t-ns v)))
|
|
(if (or (not ns) (jolt-nil? ns))
|
|
(symbol-t-name v)
|
|
(string-append ns "/" (symbol-t-name v)))))
|
|
(else
|
|
(let loop ((rs str-render-registry))
|
|
(cond
|
|
((null? rs) (jolt-pr-str v))
|
|
(((caar rs) v) ((cdar rs) v))
|
|
(else (loop (cdr rs))))))))
|
|
;; print/println render non-readably: a nested string is raw. jolt-str-render-one
|
|
;; is exactly that (collections fall through to jolt-pr-str). The print family
|
|
;; uses this seam, NOT the str fn — which renders readably (below). A top-level nil
|
|
;; prints "nil" (str renders it ""), so the seam special-cases it.
|
|
(define (jolt-print-one v) (if (jolt-nil? v) "nil" (jolt-str-render-one v)))
|
|
(def-var! "clojure.core" "__print1" jolt-print-one)
|
|
|
|
;; str: a top-level string/scalar renders as jolt-str-render-one (raw string,
|
|
;; "Infinity"…), but a COLLECTION renders as its readable form — nested strings
|
|
;; are QUOTED ((str ["x"]) => "[\"x\"]"), matching the JVM (a collection's
|
|
;; toString is readable). jolt-pr-readable resolves at call time.
|
|
(define (jolt-str-one v)
|
|
(if (or (pvec? v) (pmap? v) (pset? v) (cseq? v) (empty-list-t? v) (jolt-lazyseq? v))
|
|
(jolt-pr-readable v)
|
|
(jolt-str-render-one v)))
|
|
(define (jolt-str . xs)
|
|
(cond
|
|
((null? xs) "")
|
|
;; single arg returns its rendering directly (no string-append copy), so
|
|
;; (str sym) hands back the symbol's own name string — JVM (str x) is
|
|
;; x.toString(), and core.logic's non-unique lvar equality compares those by
|
|
;; identity.
|
|
((null? (cdr xs)) (jolt-str-one (car xs)))
|
|
(else (let loop ((xs xs) (acc '()))
|
|
(if (null? xs)
|
|
(apply string-append (reverse acc))
|
|
(loop (cdr xs) (cons (jolt-str-one (car xs)) acc)))))))
|
|
|
|
;; jolt indices are flonums; substring etc. need exact ints.
|
|
(define (jolt->idx n) (exact (truncate n)))
|
|
|
|
(define (jolt-subs s start . end)
|
|
(substring s (jolt->idx start)
|
|
(if (null? end) (string-length s) (jolt->idx (car end)))))
|
|
|
|
;; vec: a pvec from any seqable (already-pvec returns itself).
|
|
(define (jolt-vec coll)
|
|
(cond
|
|
((jolt-nil? coll) (jolt-vector))
|
|
((pvec? coll) coll)
|
|
((string? coll) (apply jolt-vector (string->list coll)))
|
|
(else (apply jolt-vector (seq->list coll)))))
|
|
|
|
(define (jolt-keyword . args)
|
|
(cond
|
|
((= (length args) 1)
|
|
(let ((a (car args)))
|
|
(cond
|
|
((jolt-nil? a) jolt-nil)
|
|
((keyword? a) a)
|
|
;; a 1-arg string splits on the FIRST "/" into ns/name:
|
|
;; (keyword "x/y") => :x/y with ns "x" — destructure's {:keys [x/y]} builds
|
|
;; the key this way, so without the split the namespaced key never matches.
|
|
((string? a)
|
|
(let ((si (let loop ((i 0))
|
|
(cond ((>= i (string-length a)) #f)
|
|
((char=? (string-ref a i) #\/) i)
|
|
(else (loop (+ i 1)))))))
|
|
(if (and si (> si 0) (< si (- (string-length a) 1)))
|
|
(keyword (substring a 0 si) (substring a (+ si 1) (string-length a)))
|
|
(keyword #f a))))
|
|
((jolt-symbol? a)
|
|
(let ((ns (symbol-t-ns a)))
|
|
(keyword (if (or (jolt-nil? ns) (not ns) (eq? ns '())) #f ns) (symbol-t-name a))))
|
|
(else (error #f "keyword: requires string/symbol/keyword" a)))))
|
|
((= (length args) 2)
|
|
(keyword (let ((ns (car args))) (if (jolt-nil? ns) #f ns)) (cadr args)))
|
|
(else (error #f "keyword: wrong arity"))))
|
|
|
|
(define (jolt-symbol-new . args)
|
|
(cond
|
|
((= (length args) 1)
|
|
(let ((a (car args)))
|
|
(cond
|
|
((jolt-symbol? a) a)
|
|
;; (symbol "ns/name") splits the namespace at the LAST "/" (JVM
|
|
;; Symbol.intern), so (namespace (symbol "foo/bar")) => "foo". A lone "/"
|
|
;; or a leading slash has no namespace. The no-ns sentinel is #f — matches
|
|
;; emit's quoted-symbol lowering (jolt-symbol #f "x"), so (= 'x (symbol
|
|
;; "x")) holds (jolt= compares ns with strict equal?).
|
|
((string? a)
|
|
(let ((slen (string-length a)))
|
|
(if (string=? a "/")
|
|
(jolt-symbol #f "/")
|
|
(let loop ((i (- slen 1)))
|
|
(cond ((<= i 0) (jolt-symbol #f a))
|
|
((char=? (string-ref a i) #\/)
|
|
(jolt-symbol (substring a 0 i) (substring a (+ i 1) slen)))
|
|
(else (loop (- i 1))))))))
|
|
((keyword? a) (jolt-symbol (keyword-t-ns a) (keyword-t-name a)))
|
|
;; (symbol a-var) -> the var's qualified symbol (clojure.spec.alpha/->sym).
|
|
((var-cell? a) (jolt-symbol (var-cell-ns a) (var-cell-name a)))
|
|
(else (error #f "symbol: requires string/symbol" a)))))
|
|
;; (symbol ns name): a nil namespace is the no-ns sentinel #f (NOT jolt-nil),
|
|
;; so (symbol nil "x") equals (symbol "x") and the reader literal 'x — jolt=
|
|
;; compares ns with strict equal?, so a jolt-nil ns would differ from #f.
|
|
((= (length args) 2)
|
|
(let ((ns (car args)))
|
|
(jolt-symbol (if (jolt-nil? ns) #f ns) (cadr args))))
|
|
(else (error #f "symbol: wrong arity"))))
|
|
|
|
;; gensym: per-process counter.
|
|
(define jolt-gensym-counter 0)
|
|
(define (jolt-gensym . prefix)
|
|
(let ((p (if (null? prefix) "G__" (car prefix))))
|
|
(set! jolt-gensym-counter (+ jolt-gensym-counter 1))
|
|
(jolt-symbol #f
|
|
(string-append (if (string? p) p (jolt-str-render-one p))
|
|
(number->string jolt-gensym-counter)))))
|
|
|
|
;; int/long: truncate toward zero to an EXACT integer (= JVM long). char -> code
|
|
;; point (exact). double: always a flonum (= JVM double).
|
|
(define (jolt-int x) (if (char? x) (char->integer x) (exact (truncate x))))
|
|
(define (jolt-double x) (if (char? x) (exact->inexact (char->integer x)) (exact->inexact x)))
|
|
|
|
;; compare: 3-way, returns an EXACT integer (= JVM compare -> int).
|
|
(define (jolt-cmp3 x y) (cond ((< x y) -1) ((> x y) 1) (else 0)))
|
|
(define (jolt-strcmp a b) (cond ((string<? a b) -1) ((string>? a b) 1) (else 0)))
|
|
(define (jolt-kw->string k)
|
|
(let ((ns (keyword-t-ns k))) (if ns (string-append ns "/" (keyword-t-name k)) (keyword-t-name k))))
|
|
(define (jolt-sym-ns-string s)
|
|
(let ((n (symbol-t-ns s))) (if (or (jolt-nil? n) (not n) (eq? n '())) "" n)))
|
|
;; compare returns an EXACT integer -1/0/1 (= JVM compare -> int).
|
|
(define (jolt-compare a b)
|
|
(cond
|
|
((and (jolt-nil? a) (jolt-nil? b)) 0)
|
|
((jolt-nil? a) -1)
|
|
((jolt-nil? b) 1)
|
|
((and (number? a) (number? b)) (jolt-cmp3 a b))
|
|
((and (string? a) (string? b)) (jolt-strcmp a b))
|
|
((and (keyword? a) (keyword? b)) (jolt-strcmp (jolt-kw->string a) (jolt-kw->string b)))
|
|
((and (jolt-symbol? a) (jolt-symbol? b))
|
|
(let ((r (jolt-strcmp (jolt-sym-ns-string a) (jolt-sym-ns-string b))))
|
|
(if (= r 0) (jolt-strcmp (symbol-t-name a) (symbol-t-name b)) r)))
|
|
((and (boolean? a) (boolean? b)) (cond ((eq? a b) 0) ((eq? a #f) -1) (else 1)))
|
|
((and (char? a) (char? b)) (jolt-cmp3 (char->integer a) (char->integer b)))
|
|
((and (pvec? a) (pvec? b))
|
|
(let ((la (pvec-count a)) (lb (pvec-count b)))
|
|
(if (not (= la lb))
|
|
(jolt-cmp3 la lb)
|
|
(let loop ((i 0))
|
|
(if (>= i la)
|
|
0
|
|
(let ((r (jolt-compare (pvec-nth-d a i jolt-nil) (pvec-nth-d b i jolt-nil))))
|
|
(if (= r 0) (loop (+ i 1)) r)))))))
|
|
(else (error #f "compare: cannot compare these types" a b))))
|
|
|
|
(def-var! "clojure.core" "str" jolt-str)
|
|
(def-var! "clojure.core" "subs" jolt-subs)
|
|
(def-var! "clojure.core" "vec" jolt-vec)
|
|
(def-var! "clojure.core" "keyword" jolt-keyword)
|
|
(def-var! "clojure.core" "symbol" jolt-symbol-new)
|
|
(def-var! "clojure.core" "gensym" jolt-gensym)
|
|
(def-var! "clojure.core" "int" jolt-int)
|
|
;; char: coerce a code point (jolt's all-flonum number) to a Chez char; pass a
|
|
;; char through. Inverse of int on chars. The cross-compiled emitter's
|
|
;; chez-str-lit needs it for printable-ASCII escaping.
|
|
(define (jolt-char x) (if (char? x) x (integer->char (exact (round x)))))
|
|
(def-var! "clojure.core" "char" jolt-char)
|
|
;; long: same truncation as int in jolt's all-flonum model (seed core-long =
|
|
;; math/trunc; char -> code point). Distinct cell so (long ...) resolves.
|
|
(def-var! "clojure.core" "long" jolt-int)
|
|
(def-var! "clojure.core" "double" jolt-double)
|
|
;; float: Chez has no single-float type, so float coerces to a flonum like double.
|
|
(def-var! "clojure.core" "float" jolt-double)
|
|
(def-var! "clojure.core" "compare" jolt-compare)
|