simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge pull request #251 from jolt-lang/conformance/core-logic-clp

Browse source 
core.logic constraint layer: CLP/unifier fixes
This commit is contained in:
Dmitri Sotnikov 2026-06-27 15:07:32 +00:00 • committed by GitHub
commit 42c163bacb
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
9 changed files with 98 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

24
host/chez/converters.ss
View file

@ -27,6 +27,15 @@
((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
@ -49,10 +58,17 @@
(jolt-pr-readable v)
(jolt-str-render-one v)))
(define (jolt-str . xs)
(let loop ((xs xs) (acc '()))
(if (null? xs)
(apply string-append (reverse acc))
(loop (cdr xs) (cons (jolt-str-one (car xs)) acc)))))
(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)))

4
host/chez/host-contract.ss
View file

@ -326,6 +326,10 @@
;; Referred names live in a separate table, so this only hits a real
;; local intern, matching how the analyzer resolves the bare symbol.
((var-cell-lookup (chez-actx-cns ctx) nm) (jolt-symbol (chez-actx-cns ctx) nm))
;; a name the compile ns excluded from clojure.core (:refer-clojure
;; :exclude) is not clojure.core/nm even before the ns defines its own —
;; qualify to the compile ns, like Clojure (core.logic.fd's `==`).
((chez-core-excluded? (chez-actx-cns ctx) nm) (jolt-symbol (chez-actx-cns ctx) nm))
((var-cell-lookup "clojure.core" nm) (jolt-symbol "clojure.core" nm))
;; a name referred into the compile ns (:require :refer / :use :only)
;; qualifies to its SOURCE ns, not the compile ns — so a macro that

24
host/chez/ns.ss
View file

@ -281,7 +281,29 @@
(chez-register-refer! cns (var-cell-name c) target)))
(hashtable-values var-table))
jolt-nil))
(define (jolt-refer-clojure . _) jolt-nil)
;; (:refer-clojure :exclude [names…]) — clojure.core always resolves on Chez, so
;; the only thing to track is the EXCLUDE set: an excluded name is not
;; clojure.core/name, so syntax-quote qualifies it to the current ns instead (a ns
;; that excludes and defines its own, e.g. core.logic.fd's ==).
(define ns-core-exclude-table (make-hashtable equal-hash equal?)) ; cns -> (name -> #t)
(define (chez-register-core-exclude! cns name)
(let ((h (or (hashtable-ref ns-core-exclude-table cns #f)
(let ((h (make-hashtable string-hash string=?)))
(hashtable-set! ns-core-exclude-table cns h) h))))
(hashtable-set! h name #t)))
(define (chez-core-excluded? cns name)
(let ((h (hashtable-ref ns-core-exclude-table cns #f)))
(and h (hashtable-ref h name #f) #t)))
(define (jolt-refer-clojure . args)
(let ((cns (chez-current-ns)))
(let loop ((a args))
(when (and (pair? a) (pair? (cdr a)))
(when (and (keyword? (car a)) (string=? (keyword-t-name (car a)) "exclude"))
(for-each (lambda (n) (when (symbol-t? n)
(chez-register-core-exclude! cns (symbol-t-name n))))
(seq->list (cadr a))))
(loop (cddr a)))))
jolt-nil)
;; alter-meta! / reset-meta!: update a var's metadata (var-meta-table, rt.ss).
(define (jolt-alter-meta! ref f . args)

15
host/chez/records.ss
View file

@ -505,6 +505,21 @@
;; a bare procedure (fn) — extend-protocol to clojure.lang.{Fn,IFn,AFn}.
((procedure? obj) '("Fn" "IFn" "AFn" "Object"))
((jolt-nil? obj) '("nil"))
;; a defrecord IS the clojure.lang map/record interfaces, so a protocol
;; extended to IRecord / IPersistentMap / Associative / Seqable / … (and not
;; to the record's own type) dispatches to it — e.g. core.logic extends
;; IWalkTerm to clojure.lang.IRecord, and walking a record value must hit
;; that, not the Object default (which would recur forever). The record's
;; own type is tried first (dispatch checks jrec-tag before these tags).
((jrec-record? obj)
(cons (jrec-tag obj)
'("IRecord" "clojure.lang.IRecord" "IPersistentMap" "clojure.lang.IPersistentMap"
"APersistentMap" "Associative" "ILookup" "Seqable" "Counted"
"IPersistentCollection" "IObj" "IMeta" "Map" "java.util.Map"
"Iterable" "java.lang.Iterable" "Object")))
;; a bare deftype is opaque — its declared interfaces dispatch via the
;; inline methods registered under its own tag (tried before these tags).
((jrec? obj) (list (jrec-tag obj) "Object"))
(else '("Object"))))
(define (record-tag obj) (and (jrec? obj) (jrec-tag obj)))

2
host/chez/seed/image.ss
View file

File diff suppressed because one or more lines are too long

7
host/chez/transients.ss
View file

@ -171,8 +171,11 @@
;; persistent disj over sets (pset-disj already exists in collections.ss).
(define (jolt-disj s . xs)
(meta-carry s
(let loop ((s s) (xs xs)) (if (null? xs) s (loop (pset-disj s (car xs)) (cdr xs))))))
;; (disj nil ...) is nil on the JVM (disj is otherwise set-only).
(if (jolt-nil? s)
jolt-nil
(meta-carry s
(let loop ((s s) (xs xs)) (if (null? xs) s (loop (pset-disj s (car xs)) (cdr xs)))))))
;; --- see-through accessors ---------------------------------------------------
(define (tvec-in-bounds? t i) (and (fixnum? i) (fx>=? i 0) (fx<? i (jolt-transient-n t))))

16
host/chez/values.ss
View file

@ -47,9 +47,21 @@
(define (keyword? x) (keyword-t? x))
;; --- symbols: ns + name + meta; NOT interned (meta varies), = by ns/name ------
;; The ns/name STRINGS are pooled (like JVM Symbol.intern, which .intern()s them):
;; two separately-read `?a` symbols share one name-string object, so code that
;; compares symbol names by identity (core.logic's non-unique lvar equality, via
;; (str sym)) behaves like the JVM.
(define symbol-string-pool (make-hashtable string-hash string=?))
(define (intern-symbol-string s)
(if (string? s)
(or (hashtable-ref symbol-string-pool s #f)
(begin (hashtable-set! symbol-string-pool s s) s))
s))
(define-record-type symbol-t (fields ns name meta) (nongenerative symbol-v1))
(define (jolt-symbol ns name) (make-symbol-t ns name jolt-nil))
(define (jolt-symbol/meta ns name meta) (make-symbol-t ns name meta))
(define (jolt-symbol ns name)
(make-symbol-t (intern-symbol-string ns) (intern-symbol-string name) jolt-nil))
(define (jolt-symbol/meta ns name meta)
(make-symbol-t (intern-symbol-string ns) (intern-symbol-string name) meta))
(define (jolt-symbol? x) (symbol-t? x))
;; chars/strings: Chez natives (strings treated immutable).

15
jolt-core/jolt/analyzer.clj
View file

@ -611,6 +611,15 @@
(quote-node form)
(let [head (first items)
hname (when (and (form-sym? head) (nil? (form-sym-ns head))) (form-sym-name head))
;; a special-form head may arrive clojure.core-qualified: syntax-quote
;; namespace-qualifies a macro like `letfn` to `clojure.core/letfn`
;; (matching Clojure, where it is a macro), so a macro-emitted
;; (clojure.core/letfn …) must still dispatch to the special form.
sf-name (or hname
(when (and (form-sym? head)
(= "clojure.core" (form-sym-ns head))
(contains? handled (form-sym-name head)))
(form-sym-name head)))
shadowed (and hname (local? env hname))]
(cond
;; Canonical order (Clojure/CLJS analyze-seq): macroexpand FIRST, then
@ -619,7 +628,7 @@
;; the reference macroexpand1's isSpecial check — so a ns that redefs a
;; macro `def`/`and`/`or` (clojure.spec.alpha) keeps the special form `def`.
(and (form-sym? head) (not shadowed)
(not (contains? handled hname)) (form-macro? ctx head))
(not (contains? handled sf-name)) (form-macro? ctx head))
;; defn/defn- expand to (def name (fn …)); carry the ORIGINAL form's
;; source offset onto the resulting def, since the macro builds a fresh
;; (def …) with no metadata. So the back end can register fn defs.
@ -639,10 +648,10 @@
;; special-form heads are NOT shadowable (unlike macros): a local named
;; `if` does not change the meaning of (if …) in operator position, per
;; spec §3 and the reference. No (not shadowed) guard here.
(and hname (contains? handled hname))
(and sf-name (contains? handled sf-name))
;; stamp the form's source offset onto a top-level def so the back end
;; can register it (jv$ns$name -> source) for native stack traces.
(let [node (analyze-special ctx hname items env)
(let [node (analyze-special ctx sf-name items env)
p (form-position form)]
(if (and p (= :def (:op node))) (assoc node :pos p) node))
(and hname (not shadowed) (method-head? hname))

4
test/chez/corpus.edn
View file

@ -3343,4 +3343,8 @@
{:suite "host interop / Collection.contains" :label "value membership over vector/list/set" :expected "[true false true]" :actual "[(.contains [1 2 3] 2) (.contains (list :a :b) :z) (.contains #{1 2} 1)]"}
{:suite "host interop / clojure.lang.Util" :label "Util/hash is Java hashCode" :expected "120" :actual "(clojure.lang.Util/hash \"x\")"}
{:suite "deftype / IObj metadata" :label "deftype meta/withMeta govern (meta x)" :expected "{:a 1}" :actual "(do (deftype Sm [m] clojure.lang.IObj (meta [_] m) (withMeta [_ n] (Sm. n))) (meta (Sm. {:a 1})))"}
{:suite "collections / disj" :label "disj of nil is nil" :expected "nil" :actual "(disj nil :a)"}
{:suite "special forms / qualified" :label "clojure.core-qualified special form (from syntax-quote)" :expected "[:g 9]" :actual "(clojure.core/letfn [(g [x] [:g x])] (g 9))"}
{:suite "symbols / interning" :label "(str sym) is the symbol's interned name (identity-stable)" :expected "[true true]" :actual "(let [s (quote ?a)] [(identical? (name s) (str s)) (= (str s) \"?a\")])"}
{:suite "symbols / interning" :label "equal symbols share an interned name string" :expected "true" :actual "(let [a (quote ?foo) b (quote ?foo)] (identical? (name a) (name b)))"}
]