ec9fde9e7e
The host/chez directory mixed jolt's own runtime (value model, seq, reader, vars, ns, multimethods) with the shims that emulate the JVM: java.* / javax.* classes, clojure.lang interfaces, and the host-class registry they hang off. Move that JVM-emulation layer into host/chez/java/ so it reads as a distinct unit instead of being interleaved with the platform runtime. Moved (content unchanged): host-static, host-static-methods, host-static-classes, host-class, dot-forms, records-interop, byte-buffer, io, io-streams, inst-time, java-time, bigdec, natives-queue, natives-str, natives-array, math, concurrency, async, ffi. The load paths in rt.ss/cli.ss and the build.ss runtime manifest are updated to point at java/; the build inliner follows the (load ...) strings, so the AOT path needs no other change. All runtime shims, no seed source touched (the three .clj edits are doc comments), so no re-mint. Gate green: make test (selfhost fixpoint, certify 0-new, sci 211, infer), shakesmoke (4 apps byte-identical).
366 lines
14 KiB
Clojure
366 lines
14 KiB
Clojure
;; clojure.core — collection tier, part 2 (rand/sort host seams, the
|
|
;; clojure.test runner, fn combinators). Continues 20-coll.clj; same constraints
|
|
;; (pure, eager, no macros), loaded in the 20 slot before 25-sorted.
|
|
|
|
;; --- leaves over the rand / sort host seams ----------------------------------
|
|
|
|
;; Canonical truncation toward zero via int (the kernel fn floored, which is
|
|
;; wrong for a negative n).
|
|
(defn rand-int [n] (int (rand n)))
|
|
|
|
;; Pure-functional Fisher-Yates over vector assoc; returns a vector, as in
|
|
;; Clojure. Collections only — a string is seqable but not shuffleable, as on
|
|
;; the JVM (Collections/shuffle wants a Collection).
|
|
(defn shuffle [coll]
|
|
(when-not (coll? coll)
|
|
(throw (ex-info (str "shuffle requires a collection, got: " coll) {})))
|
|
(loop [v (vec coll) i (dec (count v))]
|
|
(if (pos? i)
|
|
(let [j (rand-int (inc i))
|
|
t (nth v i)]
|
|
(recur (assoc (assoc v i (nth v j)) j t) (dec i)))
|
|
v)))
|
|
|
|
;; Canonical sort-by: the default comparator is compare (so nil sorts first,
|
|
;; like Clojure — the kernel fn used host ordering, which put nil last); the
|
|
;; comparator compares KEYS and may be 3-way or a boolean predicate (the host
|
|
;; sort seam normalizes).
|
|
(defn sort-by
|
|
([keyfn coll] (sort-by keyfn compare coll))
|
|
([keyfn comp coll]
|
|
(sort (fn [x y] (comp (keyfn x) (keyfn y))) coll)))
|
|
|
|
;; parse-uuid: nil unless s is a canonical 8-4-4-4-12 hex UUID string; throws
|
|
;; on a non-string (Clojure 1.11). __make-uuid is the host constructor for the
|
|
;; tagged value (overlay source can't write :jolt/type map literals — the
|
|
;; reader treats them as tagged forms).
|
|
(defn parse-uuid [s]
|
|
(if (string? s)
|
|
(when (re-matches
|
|
#"[0-9a-fA-F]{8}-[0-9a-fA-F]{4}-[0-9a-fA-F]{4}-[0-9a-fA-F]{4}-[0-9a-fA-F]{12}" s)
|
|
(__make-uuid s))
|
|
(throw (str "parse-uuid requires a string, got: " s))))
|
|
|
|
;; Version-4 UUID (RFC 4122): zero-padded hex groups 8-4-4-4-12, version
|
|
;; nibble 4, variant 8-b — built over rand-int and validated by parse-uuid.
|
|
(defn random-uuid []
|
|
(let [hx4 (fn [] (format "%04x" (rand-int 0x10000)))
|
|
hx3 (fn [] (format "%03x" (rand-int 0x1000)))]
|
|
(parse-uuid (str (hx4) (hx4) "-" (hx4) "-4" (hx3)
|
|
"-" (format "%x" (+ 8 (rand-int 4))) (hx3)
|
|
"-" (hx4) (hx4) (hx4)))))
|
|
|
|
;; The char escape/name tables, as char-keyed maps (Clojure's shape).
|
|
(def ^:private char-escape-strings
|
|
{\newline "\\n" \tab "\\t" \return "\\r" \formfeed "\\f"
|
|
\backspace "\\b" \" "\\\"" \\ "\\\\"})
|
|
(defn char-escape-string [c] (get char-escape-strings c))
|
|
|
|
(def ^:private char-name-strings
|
|
{\newline "newline" \tab "tab" \return "return" \formfeed "formfeed"
|
|
\backspace "backspace" \space "space"})
|
|
(defn char-name-string [c] (get char-name-strings c))
|
|
|
|
;; Random selection over the host rand primitives.
|
|
(defn rand-nth [coll]
|
|
(let [v (vec coll)] (nth v (rand-int (count v)))))
|
|
|
|
(defn random-sample
|
|
([prob] (filter (fn [_] (< (rand) prob))))
|
|
([prob coll] (filter (fn [_] (< (rand) prob)) coll)))
|
|
|
|
(defn comparator [pred]
|
|
(fn [a b] (cond (pred a b) -1 (pred b a) 1 :else 0)))
|
|
|
|
;; Lazy: the running accumulators, one at a time (matches Clojure).
|
|
(defn reductions
|
|
([f coll]
|
|
(lazy-seq
|
|
(let [s (seq coll)]
|
|
(if s
|
|
(reductions f (first s) (rest s))
|
|
(list (f))))))
|
|
([f init coll]
|
|
(cons init
|
|
(lazy-seq
|
|
(when-let [s (seq coll)]
|
|
(reductions f (f init (first s)) (rest s)))))))
|
|
|
|
;; Lazy pre-order DFS (matches Clojure): node, then its children's walks spliced
|
|
;; via the (now lazy) mapcat.
|
|
(defn tree-seq [branch? children root]
|
|
(let [walk (fn walk [node]
|
|
(lazy-seq
|
|
(cons node
|
|
(when (branch? node)
|
|
(mapcat walk (children node))))))]
|
|
(walk root)))
|
|
|
|
;; file-seq: the tree of paths under root (root included), directories walked
|
|
;; via the host dir primitives. Paths (strings), not File objects. (Lives below
|
|
;; tree-seq: forward references are analysis errors.)
|
|
(defn file-seq [root]
|
|
(if (__file? root)
|
|
;; java.io.File tree: walk via the File method surface so leaves are File
|
|
;; values callers can invoke .isFile/.getName/slurp on.
|
|
(tree-seq (fn [f] (.isDirectory f)) (fn [f] (seq (.listFiles f))) root)
|
|
(tree-seq __dir? __list-dir root)))
|
|
|
|
;; Canonical flatten via tree-seq: the leaves (non-sequential nodes) in order.
|
|
;; Flattens lists too (sequential?), matching Clojure/CLJS.
|
|
(defn flatten [coll]
|
|
(filter (complement sequential?) (rest (tree-seq sequential? seq coll))))
|
|
|
|
;; xml-seq: tree-seq over XML element trees. Elements are maps with :content.
|
|
(defn xml-seq [root]
|
|
(tree-seq (complement string?) (comp seq :content) root))
|
|
|
|
;; Lazy interleave: round-robin one element from each coll until any exhausts.
|
|
(defn interleave
|
|
([] ())
|
|
([c1] (lazy-seq c1))
|
|
([c1 c2]
|
|
(lazy-seq
|
|
(let [s1 (seq c1) s2 (seq c2)]
|
|
(when (and s1 s2)
|
|
(cons (first s1)
|
|
(cons (first s2)
|
|
(interleave (rest s1) (rest s2))))))))
|
|
([c1 c2 & cs]
|
|
(lazy-seq
|
|
(let [ss (map seq (list* c1 c2 cs))]
|
|
(when (every? identity ss)
|
|
(concat (map first ss)
|
|
(apply interleave (map rest ss))))))))
|
|
|
|
;; No ratio type on Jolt, so rationalize is identity.
|
|
(defn rationalize [x] x)
|
|
|
|
;; 0-arg: a stateful transducer (tracks [seen? prev] in a volatile, so no sentinel
|
|
;; value is needed). 1-arg: eager dedupe of consecutive equal elements.
|
|
(defn dedupe
|
|
([]
|
|
(fn [rf]
|
|
(let [pv (volatile! [false nil])]
|
|
(fn
|
|
([] (rf))
|
|
([result] (rf result))
|
|
([result input]
|
|
(let [[seen prior] @pv]
|
|
(vreset! pv [true input])
|
|
(if (and seen (= prior input)) result (rf result input))))))))
|
|
([coll]
|
|
(let [step (fn step [s prev]
|
|
(make-lazy-seq
|
|
(fn* []
|
|
(let [s (seq s)]
|
|
(if s
|
|
(let [x (first s)]
|
|
(if (= x prev)
|
|
(coll->cells (step (rest s) prev))
|
|
(coll->cells (cons x (step (rest s) x)))))
|
|
nil)))))]
|
|
(let [s (seq coll)]
|
|
(if s
|
|
(make-lazy-seq
|
|
(fn* [] (coll->cells (cons (first s) (step (rest s) (first s))))))
|
|
())))))
|
|
|
|
;; Internal helper for {:keys [...]} destructuring over a seq of k/v pairs —
|
|
;; canonical Clojure 1.11 shape (core.clj seq-to-map-for-destructuring):
|
|
;; even pairs build a map (later keys win, as createAsIfByAssoc), a SINGLE
|
|
;; element is returned as-is (the trailing-map calling convention), and an
|
|
;; unpaired key past pairs throws.
|
|
(defn seq-to-map-for-destructuring [s]
|
|
(if (next s)
|
|
(loop [m {} xs (seq s)]
|
|
(if xs
|
|
(if (next xs)
|
|
(recur (assoc m (first xs) (second xs)) (nnext xs))
|
|
(throw (str "No value supplied for key: " (first xs))))
|
|
m))
|
|
(if (seq s) (first s) {})))
|
|
|
|
;; Host-coupled fns that are pure logic over existing core primitives, so they
|
|
;; need no new jolt.host surface.
|
|
|
|
;; vary-meta: f applied to obj's metadata (+ extra args), reattached. meta and
|
|
;; with-meta are the irreducible host primitives; vary-meta is just their compose.
|
|
(defn vary-meta [obj f & args]
|
|
(with-meta obj (apply f (meta obj) args)))
|
|
|
|
;; namespace-munge: Clojure namespace name -> legal Java package name (- -> _).
|
|
(defn namespace-munge [s]
|
|
(apply str (map (fn [c] (if (= c \-) \_ c)) (seq (str s)))))
|
|
|
|
;; reduce-kv over a map (k v) or vector (index v). Both branches go through reduce,
|
|
;; so reduced short-circuits — and the vector path indexes correctly. nil folds
|
|
;; to init, matching Clojure.
|
|
(defn reduce-kv [f init coll]
|
|
(cond
|
|
(vector? coll) (reduce (fn [acc i] (f acc i (nth coll i))) init (range (count coll)))
|
|
(map? coll) (reduce (fn [acc k] (f acc k (get coll k))) init (keys coll))
|
|
(nil? coll) init
|
|
:else (throw (str "reduce-kv not supported on: " coll))))
|
|
|
|
;; ex-info accessors. The constructor (ex-info) stays native — it builds the tagged
|
|
;; value and wires into throw — but the value exposes :jolt/type/:message/:data/
|
|
;; :cause via get, so the accessors are pure over get. A thrown non-ex-info arrives
|
|
;; wrapped as {:jolt/type :jolt/exception :value v}; unwrap that first.
|
|
(defn- ex-info-val? [x] (= (get x :jolt/type) :jolt/ex-info))
|
|
(defn- ex-unwrap [e]
|
|
(if (= (get e :jolt/type) :jolt/exception) (get e :value) e))
|
|
(defn ex-data [e]
|
|
(let [e (ex-unwrap e)] (if (ex-info-val? e) (get e :data) nil)))
|
|
(defn ex-message [e]
|
|
(let [e (ex-unwrap e)]
|
|
(cond (ex-info-val? e) (get e :message)
|
|
:else nil)))
|
|
(defn ex-cause [e]
|
|
(let [e (ex-unwrap e)] (if (ex-info-val? e) (get e :cause) nil)))
|
|
|
|
;; inst-ms: epoch milliseconds of an instant; throws on a non-inst (Clojure
|
|
;; protocol behavior).
|
|
(defn inst-ms [x]
|
|
(if (inst? x) (get x :ms) (throw (str "inst-ms requires an inst, got: " x))))
|
|
|
|
;; Clojure 1.11 map transformers. PHM base so transformed keys canonicalize
|
|
;; (collisions: last entry in seq order wins, matching the reference).
|
|
(defn update-keys [m f]
|
|
(reduce-kv (fn [acc k v] (assoc acc (f k) v)) (hash-map) m))
|
|
|
|
(defn update-vals [m f]
|
|
(reduce-kv (fn [acc k v] (assoc acc k (f v))) (hash-map) m))
|
|
|
|
;; Vector-returning partition variants (1.11): lazy seqs OF vectors.
|
|
(defn partitionv
|
|
([n coll] (map vec (partition n coll)))
|
|
([n step coll] (map vec (partition n step coll)))
|
|
([n step pad coll] (map vec (partition n step pad coll))))
|
|
|
|
;; partition-all is a lazy-tier fn (40-lazy) — declared so partitionv-all
|
|
;; compiles; bound by the time anything calls it.
|
|
(declare partition-all)
|
|
|
|
(defn partitionv-all
|
|
([n coll] (map vec (partition-all n coll)))
|
|
([n step coll] (map vec (partition-all n step coll))))
|
|
|
|
;; First part a vector, rest a seq — matching the reference implementation.
|
|
(defn splitv-at [n coll]
|
|
[(vec (take n coll)) (drop n coll)])
|
|
|
|
;; with-redefs-fn: temporarily set each var's root to the mapped value, run
|
|
;; the thunk, restore the saved roots even on throw. The with-redefs macro
|
|
;; (30-macros) builds the {var val} map from names.
|
|
(defn with-redefs-fn [binding-map func]
|
|
(let [vars (vec (keys binding-map))
|
|
saved (mapv var-get vars)]
|
|
(doseq [v vars] (var-set v (get binding-map v)))
|
|
(try
|
|
(func)
|
|
(finally
|
|
;; loop/recur, not dotimes: dotimes is a 30-macros macro and this tier
|
|
;; compiles before it exists (a forward ref would resolve to the macro
|
|
;; fn at runtime and mis-apply it).
|
|
(loop [i 0]
|
|
(when (< i (count vars))
|
|
(var-set (nth vars i) (nth saved i))
|
|
(recur (inc i))))))))
|
|
;; Jolt has no chunked seqs, so this is always false.
|
|
(defn chunked-seq? [x] false)
|
|
|
|
;; Atom peripheral operations. atom/swap!/reset!/deref stay native — the compiler
|
|
;; depends on them and they're hot. swap-vals!/reset-vals!/compare-and-set! compose
|
|
;; the native ops (which already validate and notify watches); get-validator reads a
|
|
;; slot; add-watch/remove-watch/set-validator! mutate the atom (or its watches
|
|
;; sub-table) through the one host primitive jolt.host/ref-put! — the minimal
|
|
;; mutation kernel the overlay can't express over core fns (a nil value removes the
|
|
;; key). compare-and-set! compares by value.
|
|
(defn swap-vals! [a f & args]
|
|
(let [old (deref a)] [old (apply swap! a f args)]))
|
|
(defn reset-vals! [a newval]
|
|
(let [old (deref a)] (reset! a newval) [old newval]))
|
|
(defn compare-and-set! [a oldval newval]
|
|
(if (= oldval (deref a)) (do (reset! a newval) true) false))
|
|
(defn get-validator [a] (get a :validator))
|
|
(defn add-watch [a key f]
|
|
(jolt.host/ref-put! (get a :watches) key f) a)
|
|
(defn remove-watch [a key]
|
|
(jolt.host/ref-put! (get a :watches) key nil) a)
|
|
(defn set-validator! [a f]
|
|
(jolt.host/ref-put! a :validator f) nil)
|
|
|
|
;; vreset!/vswap! live in the seq tier (10-seq.clj): its transducers use them.
|
|
|
|
;; Future status predicates — pure reads of the future's :cached/:cancelled slots.
|
|
;; future? stays native (deref/future-cancel/realized? call it); future-call and
|
|
;; future-cancel stay native too (OS threads).
|
|
(defn future-done? [x]
|
|
(if (future? x) (boolean (get x :cached)) (throw "future-done? requires a future")))
|
|
(defn future-cancelled? [x]
|
|
(and (future? x) (boolean (get x :cancelled))))
|
|
|
|
;; ns-name: a namespace object's :name as a symbol. Pure over get + symbol.
|
|
(defn ns-name [ns]
|
|
(let [nm (get ns :name)] (if nm (symbol (str nm)) nil)))
|
|
|
|
;; Java-array element access. Jolt arrays are mutable backing arrays; aget/alength
|
|
;; read them (nth/count) and aset writes a slot through ref-put!. Both handle the
|
|
;; multi-dimensional form (aget a i j ... / aset a i j ... v) by walking. The array
|
|
;; constructors (object-array/make-array/to-array/...) stay native — they build the
|
|
;; mutable backing.
|
|
(defn aget [arr & idxs]
|
|
(reduce (fn [v i] (nth v i)) arr idxs))
|
|
(defn alength [arr] (count arr))
|
|
(defn aset [arr & idxs+val]
|
|
(let [n (count idxs+val)
|
|
val (nth idxs+val (dec n))
|
|
target (reduce (fn [t k] (nth t k)) arr (take (- n 2) idxs+val))]
|
|
(jolt.host/ref-put! target (nth idxs+val (- n 2)) val)
|
|
val))
|
|
|
|
;; --- fn combinators + host-free stubs ----------------------------------------
|
|
|
|
(defn complement
|
|
"Takes a fn f and returns a fn that takes the same arguments as f, has the
|
|
same effects, if any, and returns the opposite truth value."
|
|
[f]
|
|
(fn [& args] (not (apply f args))))
|
|
|
|
;; Canonical Clojure fnil: patches only the FIRST 1-3 arguments.
|
|
(defn fnil
|
|
([f x]
|
|
(fn [a & args] (apply f (if (nil? a) x a) args)))
|
|
([f x y]
|
|
(fn [a b & args] (apply f (if (nil? a) x a) (if (nil? b) y b) args)))
|
|
([f x y z]
|
|
(fn [a b c & args]
|
|
(apply f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c) args))))
|
|
|
|
(defn clojure-version [] "1.11.0-jolt")
|
|
|
|
;; bigdec is a host fn (host/chez/java/bigdec.ss) — a real BigDecimal value type.
|
|
(defn numerator [x] (throw (ex-info "numerator requires a ratio (Jolt has no ratios)" {})))
|
|
(defn denominator [x] (throw (ex-info "denominator requires a ratio (Jolt has no ratios)" {})))
|
|
|
|
;; jolt has no reflection, but a few common JVM interfaces carry a modeled
|
|
;; ancestry (jolt.host/class-supers) so reflective checks like
|
|
;; (ancestors (class f)) answer like the JVM.
|
|
(defn supers [x]
|
|
(let [s (jolt.host/class-supers x)]
|
|
(if s (set s) #{})))
|
|
|
|
;; Like Clojure's munge: rewrite dashes to underscores, preserving the argument's
|
|
;; type — a symbol munges to a symbol, anything else to a string. (jolt only
|
|
;; rewrites dashes, not the full Compiler CHAR_MAP.)
|
|
(defn munge [s]
|
|
(let [m (str-replace-all "-" "_" (str s))]
|
|
(if (symbol? s) (symbol m) m)))
|
|
|
|
(defn test
|
|
"Calls the :test fn from v's metadata; :ok if it runs, :no-test if absent."
|
|
[v]
|
|
(let [t (:test (meta v))]
|
|
(if t (do (t) :ok) :no-test)))
|
|
|