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

General fixes shaken out by running core.logic

host/chez/host-contract.ss

@@ -320,6 +320,12 @@
           ;; a class token, not a var to namespace-qualify — leave it bare, as
           ;; Clojure's syntax-quote resolves it to the class.
           ((hc-fq-class-name? nm) form)
+          ;; the compile ns's OWN def shadows clojure.core — a name the ns
+          ;; excluded and redefined (e.g. core.logic's `==` after
+          ;; (:refer-clojure :exclude [==])), or any ns-local redefinition.
+          ;; 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))
           ((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

host/chez/java/dot-forms.ss

@@ -38,6 +38,17 @@
     ((or (string=? name "get") (string=? name "valAt"))
      (list (apply jolt-get obj args)))
     ((string=? name "containsKey") (list (jolt-contains? obj (car args))))
+    ;; java.util.Collection.contains(o): VALUE membership (a set is O(1) via
+    ;; contains?; a list/vector/seq is a linear scan — contains? on a vector tests
+    ;; an index, so it is wrong here).
+    ((string=? name "contains")
+     (list (if (pset? obj)
+               (jolt-contains? obj (car args))
+               (let ((x (car args)))
+                 (let loop ((s (jolt-seq obj)))
+                   (cond ((jolt-nil? s) #f)
+                         ((jolt=2 (seq-first s) x) #t)
+                         (else (loop (jolt-seq (seq-more s))))))))))
     ((string=? name "size")    (list (jolt-count obj)))
     ((string=? name "isEmpty") (list (jolt-empty? obj)))
     ;; java.util.Map views: keySet (a Set), values (a Collection), entrySet.

host/chez/java/host-static-classes.ss

@@ -745,6 +745,9 @@
         (cons "toString" (lambda (self) (string-append "class " (jclass-name self))))
         (cons "isArray" (lambda (self) (let ((n (jclass-name self)))
                                          (and (fx>? (string-length n) 0) (char=? (string-ref n 0) #\[)))))
+        ;; Class.isInstance(o) == (instance? class o); core.logic's deftype .equals
+        ;; uses (.. this getClass (isInstance o)).
+        (cons "isInstance" (lambda (self o) (if (instance-check self o) #t #f)))
         (cons "getClass" (lambda (self) (make-class-obj "java.lang.Class")))))
 
 ;; (jolt.host/table? x) — is x a host tagged-table?

host/chez/java/io.ss

@@ -460,6 +460,25 @@
 ;; is how libraries reach Clojure's base loader, e.g. aws-api's resources ns).
 (register-class-statics! "RT" (list (cons "baseLoader" (lambda () the-classloader))))
 (register-class-statics! "clojure.lang.RT" (list (cons "baseLoader" (lambda () the-classloader))))
+;; clojure.lang.RT/nextID — process-unique increasing id (AtomicInteger(1)
+;; getAndIncrement), used by id generators such as core.logic's lvar.
+(define rt-next-id-counter 1)
+(define (rt-next-id)
+  (let ((v rt-next-id-counter))
+    (set! rt-next-id-counter (+ rt-next-id-counter 1))
+    v))
+(register-class-statics! "RT" (list (cons "nextID" rt-next-id)))
+(register-class-statics! "clojure.lang.RT" (list (cons "nextID" rt-next-id)))
+;; clojure.lang.Util — hash/equality helpers libraries call directly (core.logic's
+;; LCons.hashCode uses Util/hash). hash = Java hashCode (0 for nil); hasheq = the
+;; value hash jolt's = uses; equiv = value equality; identical = reference identity.
+(let ((util-statics
+       (list (cons "hash" (lambda (x) (if (jolt-nil? x) 0 (record-method-dispatch x "hashCode" jolt-nil))))
+             (cons "hasheq" (lambda (x) (jolt-hash x)))
+             (cons "equiv" (lambda (a b) (if (jolt= a b) #t #f)))
+             (cons "identical" (lambda (a b) (if (eq? a b) #t #f))))))
+  (register-class-statics! "Util" util-statics)
+  (register-class-statics! "clojure.lang.Util" util-statics))
 ;; Thread/currentThread -> a fresh thread jhost wrapping THIS thread's interrupt
 ;; flag (the box from current-interrupt-box, host-static.ss), so .interrupt from
 ;; any thread sets the target thread's flag and .isInterrupted reads it without

host/chez/java/natives-str.ss

@@ -108,10 +108,30 @@
       ((string=? cs "utf-32le") (string->utf32 s (endianness little)))
       (else (string->utf8 s)))))
 
+;; Object.hashCode parity: Java's specified String hash and Clojure's Symbol hash
+;; (Util.hashCombine), so (.hashCode s) / (.hashCode sym) match the JVM. 32-bit int.
+(define (jolt-u32 x) (bitwise-and x #xFFFFFFFF))
+(define (jolt-s32 x) (let ((m (jolt-u32 x))) (if (>= m #x80000000) (- m #x100000000) m)))
+(define (java-string-hash s)
+  (let ((n (string-length s)))
+    (let loop ((i 0) (h 0))
+      (if (fx<? i n)
+          (loop (fx+ i 1) (jolt-s32 (+ (* 31 h) (char->integer (string-ref s i)))))
+          (jolt-s32 h)))))
+(define (java-hash-combine seed hash)
+  (let* ((su (jolt-u32 seed))
+         (sl (bitwise-arithmetic-shift-left su 6))
+         (sr (bitwise-arithmetic-shift-right (jolt-s32 su) 2))
+         (add (+ (jolt-u32 hash) #x9e3779b9 sl sr)))
+    (jolt-s32 (bitwise-xor su (jolt-u32 add)))))
+(define (java-symbol-hash name ns)
+  (java-hash-combine (java-string-hash name) (if ns (java-string-hash ns) 0)))
+
 (define (jolt-string-method method s rest)
   (define (arg n) (list-ref rest n))
   (cond
     ((string=? method "toString") s)
+    ((string=? method "hashCode") (java-string-hash s))
     ((string=? method "toLowerCase") (ascii-string-down s))
     ((string=? method "toUpperCase") (ascii-string-up s))
     ((string=? method "trim") (str-trim s))

host/chez/natives-meta.ss

@@ -22,6 +22,11 @@
        (jolt-assoc (if user user (jolt-hash-map))
                    jolt-kw-var-ns (var-cell-ns x)
                    jolt-kw-var-name (var-cell-name x))))
+    ;; a deftype implementing clojure.lang.IObj stores meta in a field and threads
+    ;; it through its own assoc/withMeta (core.logic's Substitutions/LVar/LCons),
+    ;; so dispatch to its meta method rather than the identity side-table — which
+    ;; the deftype's reconstructed instances would not share.
+    ((and (jrec? x) (jrec-cl x "meta")) => (lambda (m) (jolt-invoke m x)))
     ((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (jreify? x) (procedure? x))
      (hashtable-ref meta-table x jolt-nil))
     (else jolt-nil)))
@@ -53,6 +58,9 @@
 (define (jolt-with-meta x m)
   (cond
     ((symbol-t? x) (make-symbol-t (symbol-t-ns x) (symbol-t-name x) m))
+    ;; a deftype with an explicit clojure.lang.IObj withMeta carries meta in a
+    ;; field; dispatch to it (see jolt-meta) so the meta survives reconstruction.
+    ((and (jrec? x) (jrec-cl x "withMeta")) => (lambda (meth) (jolt-invoke meth x m)))
     ((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (jreify? x) (procedure? x))
      (let ((c (meta-copy x)))
        (if (jolt-nil? m) (hashtable-delete! meta-table c) (hashtable-set! meta-table c m))

host/chez/natives-seq.ss

@@ -182,9 +182,12 @@
     (if (jolt-nil? s) jolt-empty-list
         (list->cseq (list-sort less? (seq->list s))))))
 
-;; identical?: jolt reference identity, defined as (= a b) over the
+;; identical?: reference identity (Clojure ==). eq? gives pointer identity over
-;; value model, where interned keywords/small values compare equal.
+;; the value model — interned keywords/fixnums/nil compare equal, distinct
-(define (jolt-identical? a b) (jolt= a b))
+;; collections do not. Must NOT be value equality: a deftype whose .equals calls
+;; (identical? this o) to short-circuit (e.g. core.logic's Substitutions) would
+;; otherwise recur forever (identical? -> = -> equiv -> .equals -> identical?).
+(define (jolt-identical? a b) (eq? a b))
 
 ;; Give the seq.ss native procedures their transducer (1-arg) arity — the emitter
 ;; lowers (map f)/(filter p)/(take n) at the wrong arity to the bare procedure

host/chez/reader.ss

@@ -455,6 +455,30 @@
                      (values (cadr xs) j)))
                 (else (loop (cddr xs)))))))))
 
+(define (rdr-string-rindex-char str c)
+  (let loop ((i (- (string-length str) 1)))
+    (cond ((< i 0) #f) ((char=? (string-ref str i) c) i) (else (loop (- i 1))))))
+
+;; A record/type literal tag (#ns.Type{..} / #ns.Type[..]) is any tag containing
+;; a dot — Clojure routes those to a constructor instead of a data reader.
+(define (rdr-record-tag? tok) (and (rdr-string-rindex-char tok #\.) #t))
+
+;; #a.b.C{..} -> (a.b/map->C {..}); #a.b.C[..] -> (a.b/->C ..). The factory call
+;; compiles like any invoke; defrecord interns map->C/->C in the type's ns.
+(define (rdr-record-ctor-form tok form)
+  (let* ((di (rdr-string-rindex-char tok #\.))
+         (ns (substring tok 0 di))
+         (simple (substring tok (+ di 1) (string-length tok))))
+    (cond
+      ((pmap? form)
+       (jolt-list (jolt-symbol ns (string-append "map->" simple)) form))
+      ((pvec? form)
+       (apply jolt-list (jolt-symbol ns (string-append "->" simple))
+              (vector->list (pvec-v form))))
+      (else (jolt-throw (jolt-ex-info
+                         (string-append "Unreadable constructor form: #" tok)
+                         (empty-pmap)))))))
+
 (define (rdr-read-dispatch s i end)      ; i points just past the '#'
   (when (>= i end) (jolt-throw (jolt-ex-info "EOF after #" (empty-pmap))))
   (let ((c (string-ref s i)))
@@ -497,7 +521,9 @@
        (let-values (((tok j) (rdr-read-token s i end)))
          (let-values (((form k) (rdr-read-form s j end)))
            (when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after #tag" (empty-pmap))))
-           (values (rdr-make-tagged (keyword #f (string-append "#" tok)) form) k)))))))
+           (if (rdr-record-tag? tok)       ; #ns.Type{..}/[..] record literal
+               (values (rdr-record-ctor-form tok form) k)
+               (values (rdr-make-tagged (keyword #f (string-append "#" tok)) form) k))))))))
 
 ;; regex literal source: raw chars to the closing quote; \" is an escaped quote,
 ;; every other backslash sequence is kept verbatim (regex engine semantics).

host/chez/records.ss

@@ -52,11 +52,12 @@
   (and (jrec? x)
        (or (jrec-record? x)
            (let ((tag (jrec-tag x)))
-             (or (find-method-any-protocol tag "seq")
+             ;; coll? is instance? IPersistentCollection — its marker is `cons`
-                 (find-method-any-protocol tag "count")
+             ;; (and ISeq's `first`). ILookup(valAt) / Indexed(nth) / Counted(count)
-                 (find-method-any-protocol tag "nth")
+             ;; / Seqable(seq) alone do NOT make a value coll?, matching the JVM
-                 (find-method-any-protocol tag "valAt")
+             ;; (e.g. core.logic's LVar implements only valAt and is not coll?).
-                 (find-method-any-protocol tag "cons"))))
+             (or (find-method-any-protocol tag "cons")
+                 (find-method-any-protocol tag "first"))))
        #t))
 ;; a jrec that is map? — a record, or a deftype implementing clojure.lang
 ;; .IPersistentMap (clojure.core.cache's caches do). `without` (dissoc) is the
@@ -277,9 +278,20 @@
                   (lambda (a b)
                     (cond ((and (jrec? a) (jrec-cl a "equiv")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m a b)) #t #f)))
                           ((and (jrec? b) (jrec-cl b "equiv")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m b a)) #t #f)))
+                          ;; a deftype with a custom Object.equals (but no equiv) governs
+                          ;; its own value equality and map-key identity — core.logic's
+                          ;; LVar/LCons key substitutions on id, ignoring metadata, so
+                          ;; structural jrec=? (which sees the meta field) is wrong here.
+                          ((and (jrec? a) (jrec-cl a "equals")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m a b)) #t #f)))
+                          ((and (jrec? b) (jrec-cl b "equals")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m b a)) #t #f)))
                           ((and (jrec? a) (jrec? b)) (jrec=? a b))
                           (else #f))))
-(register-hash-arm! jrec? jrec-hash)
+;; a deftype's declared hashCode governs its map/set hashing (paired with the
+;; equals/equiv above so the hash/eq contract holds); a plain record hashes its
+;; fields structurally via jrec-hash.
+(register-hash-arm! jrec?
+  (lambda (x) (let ((m (jrec-cl x "hashCode")))
+                (if m (jolt-invoke m x) (jrec-hash x)))))
 ;; get on a jrec: a real field reads raw (so a deftype method's own field bindings,
 ;; compiled to (get inst :field), never recurse); a NON-field key on a deftype that
 ;; implements clojure.lang.ILookup routes to its valAt (core.match's pattern types
@@ -789,6 +801,8 @@
               (string-append (if (symbol-t-ns obj) (string-append (symbol-t-ns obj) "/") "")
                              (symbol-t-name obj)))
              ((string=? method-name "equals") (and (pair? rest) (jolt=2 obj (car rest))))
+             ((string=? method-name "hashCode")
+              (java-symbol-hash (symbol-t-name obj) (symbol-t-ns obj)))
              (else (error #f (string-append "No method " method-name " on Symbol")))))
       ;; clojure.lang.Namespace: name/getName yield the ns name as a Symbol (JVM:
       ;; Namespace.name is a Symbol). clojure.spec.alpha reads (.name *ns*).
@@ -838,6 +852,14 @@
                  ((jolt=2 (seq-first s) target)
                   (if last? (loop (jolt-seq (seq-more s)) (fx+ i 1) i) i))
                  (else (loop (jolt-seq (seq-more s)) (fx+ i 1) found))))))
+      ;; java.util.Collection.contains over a list/seq (vectors/sets handle it in
+      ;; dot-coll-method): value membership, like the JVM.
+      ((string=? method-name "contains")
+       (let ((target (car rest)))
+         (let loop ((s (jolt-seq obj)))
+           (cond ((jolt-nil? s) #f)
+                 ((jolt=2 (seq-first s) target) #t)
+                 (else (loop (jolt-seq (seq-more s))))))))
       ;; universal Object methods on any remaining value (boolean, etc.).
       ((string=? method-name "toString") (jolt-str-render-one obj))
       ((string=? method-name "hashCode") (jolt-hash obj))

jolt-core/clojure/core/22-coll.clj

@@ -34,6 +34,28 @@
       (recur (assoc m (first ks) (first vs)) (next ks) (next vs))
       m)))
 
+;; Structmaps (legacy). A struct basis is the ordered vector of slot keys; a
+;; struct map is a plain map carrying every basis key (nil when unset), in basis
+;; order, so it looks up and compares like any other map.
+(defn create-struct [& keys] (vec keys))
+
+(defn struct-map [basis & inits]
+  (let [base (loop [m {} ks (seq basis)]
+               (if ks (recur (assoc m (first ks) nil) (next ks)) m))]
+    (loop [m base kvs (seq inits)]
+      (if kvs
+        (recur (assoc m (first kvs) (first (next kvs))) (next (next kvs)))
+        m))))
+
+(defn struct [basis & vals]
+  (loop [m (struct-map basis) ks (seq basis) vs (seq vals)]
+    (if (and ks vs)
+      (recur (assoc m (first ks) (first vs)) (next ks) (next vs))
+      m)))
+
+(defn accessor [basis key]
+  (fn [m] (get m key)))
+
 ;; conj semantics per entry arg (a map merges, a [k v] pair adds); nil args are
 ;; no-ops; all-nil (or no args) is nil.
 (defn merge [& maps]

jolt-core/clojure/core/30-macros.clj

@@ -281,6 +281,10 @@
 ;; type's fields, bound from the instance (the method's first param), matching
 ;; Clojure's deftype scope. defrecord (below) expands to a bodyless (deftype …) and
 ;; handles its own methods, so this also serves the no-body case.
+;; Legacy structmap definer: binds a var to the struct basis (see create-struct).
+(defmacro defstruct [name & keys]
+  `(def ~name (create-struct ~@keys)))
+
 (defmacro deftype [tname fields & body]
   ;; strip ^meta off the type name and fields (the reader yields a (with-meta sym m)
   ;; form for e.g. (deftype ^{:doc …} Foo …)), so (name …) sees a bare symbol.

jolt-core/jolt/analyzer.clj

@@ -528,7 +528,14 @@
 (defn- analyze-dot [ctx items env]
   (when (< (count items) 3)
     (throw (str "Malformed (. target member ...) form")))
-  (let [target (nth items 1)
+  (let [member0 (nth items 2)
+        ;; (. target (member arg*)) is sugar for (. target member arg*) —
+        ;; flatten the list-member form so the rest of the dispatch is uniform.
+        items (if (form-list? member0)
+                (let [ml (vec (form-elements member0))]
+                  (into [(nth items 0) (nth items 1) (first ml)] (rest ml)))
+                items)
+        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

test/chez/corpus.edn

@@ -3335,4 +3335,12 @@
   {:suite "edn / deferred tags" :label "a normal #inst still constructs without an override" :expected "true" :actual "(= #inst \"2020-01-01T00:00:00.000-00:00\" (clojure.edn/read-string \"#inst \\\"2020-01-01T00:00:00.000-00:00\\\"\"))"}
   {:suite "vars / privacy" :label "defn- marks the var :private" :expected "true" :actual "(do (defn- p [] 1) (true? (:private (meta (var p)))))"}
   {:suite "vars / privacy" :label "ns-publics drops private vars; ns-interns keeps them" :expected "[true false true]" :actual "(do (defn pub [] 1) (defn- priv [] 2) [(contains? (ns-publics (quote user)) (quote pub)) (contains? (ns-publics (quote user)) (quote priv)) (contains? (ns-interns (quote user)) (quote priv))])"}
+  {:suite "host interop / dot form" :label "(. target (method args)) list-member sugar" :expected "\"HELLO\"" :actual "(. \"hello\" (toUpperCase))"}
+  {:suite "predicates / identical?" :label "reference identity, not value equality" :expected "[true false false]" :actual "[(identical? :a :a) (identical? (quote x) (quote x)) (identical? [1] [1])]"}
+  {:suite "host interop / hashCode" :label "Java String and Symbol hashCode" :expected "[120 -1634134448]" :actual "[(.hashCode \"x\") (.hashCode (quote foo/bar))]"}
+  {:suite "structmaps" :label "defstruct / struct-map / struct" :expected "[{:a 1 :b 2} {:a 1 :b 2} {:a 1 :b nil}]" :actual "(do (defstruct sx :a :b) [(struct-map sx :a 1 :b 2) (struct sx 1 2) (struct-map sx :a 1)])"}
+  {:suite "deftype / clojure.lang interfaces" :label "ILookup-only deftype is not coll? or seqable?" :expected "[false false]" :actual "(do (deftype Lk [x] clojure.lang.ILookup (valAt [_ k] nil) (valAt [_ k nf] nf)) [(coll? (->Lk 1)) (seqable? (->Lk 1))])"}
+  {: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})))"}
 ]

test/chez/unit.edn

@@ -565,7 +565,7 @@
   {:suite "bytes" :expr "(String. (.getBytes \"round\" \"UTF-8\") \"UTF-8\")" :expected "round"}
   {:suite "deftype-map" :expr "(do (deftype Mp [m] clojure.lang.IPersistentMap (without [_ k] m)) [(map? (->Mp 1)) (record? (->Mp 1))])" :expected "[true false]"}
   {:suite "deftype-map" :expr "(do (deftype Op [s]) [(map? (->Op 1)) (record? (->Op 1)) (coll? (->Op 1))])" :expected "[false false false]"}
-  {:suite "deftype-map" :expr "(do (deftype Lc [xs] clojure.lang.Counted (count [_] (count xs)) clojure.lang.Seqable (seq [_] (seq xs))) [(coll? (->Lc [1 2])) (count (->Lc [1 2])) (vec (seq (->Lc [1 2])))])" :expected "[true 2 [1 2]]"}
+  {:suite "deftype-map" :expr "(do (deftype Lc [xs] clojure.lang.Counted (count [_] (count xs)) clojure.lang.Seqable (seq [_] (seq xs))) [(coll? (->Lc [1 2])) (count (->Lc [1 2])) (vec (seq (->Lc [1 2])))])" :expected "[false 2 [1 2]]"}
   {:suite "deftype-map" :expr "(do (defrecord Dr [a b]) [(map? (->Dr 1 2)) (record? (->Dr 1 2)) (coll? (->Dr 1 2))])" :expected "[true true true]"}
   {:suite "macro-args" :expr "(do (defmacro sm [x] [(set? x) (map? x)]) (sm #{1 2}))" :expected "[true false]"}
   {:suite "macro-args" :expr "(do (defmacro ws [x] (conj x :z)) (= #{1 :z} (ws #{1})))" :expected "true"}