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

core.logic fd + &env: instance? boundary, ~ unquote, macro &form/&env

host/chez/host-contract.ss

@@ -215,12 +215,23 @@
           (if (fx>=? i (pvec-count items)) s
               (loop (fx+ i 1) (pset-conj s (pvec-nth-d items i jolt-nil))))))
       x))
-(define (hc-expand-1 ctx form)
+;; &form and &env are bound (as dynamic vars) around the expander call, so a
+;; macro body can read the call form / lexical env without changing the calling
+;; convention. The analyzer passes amp-env (the in-scope locals); macroexpand-1
+;; has none, so it defaults to {}.
+(define hc-amp-form-cell (declare-var! "clojure.core" "&form"))
+(define hc-amp-env-cell (declare-var! "clojure.core" "&env"))
+(define (hc-expand-1 ctx form . maybe-env)
   (let* ((items (seq->list form))
          (head (car items))
          (args (map hc-macro-arg (cdr items)))
-         (expander (var-cell-root (hc-resolve-cell ctx head))))
+         (expander (var-cell-root (hc-resolve-cell ctx head)))
-    (hc-propagate-pos form (apply jolt-invoke expander args))))
+         (amp-env (if (pair? maybe-env) (car maybe-env) (jolt-hash-map))))
+    (dynamic-wind
+      (lambda () (jolt-push-thread-bindings
+                  (jolt-hash-map hc-amp-form-cell form hc-amp-env-cell amp-env)))
+      (lambda () (hc-propagate-pos form (apply jolt-invoke expander args)))
+      (lambda () (jolt-pop-thread-bindings)))))
 
 ;; Classify a global (non-local) symbol reference against the var registry:
 ;;   {:kind :var :ns NS :name NAME}   — a defined var (compile ns / clojure.core)
@@ -298,10 +309,15 @@
 ;; Any seq counts, not just a proper list: a macro that builds the template with
 ;; map/for (e.g. deftype's rewrite-set) yields a LAZY seq, and its ~unquotes must
 ;; still be recognized.
+;; head symbol matches name nm, bare or clojure.core-qualified — the reader
+;; produces clojure.core/unquote(-splicing) for ~/~@ (JVM parity), and this is
+;; only used to spot those heads in syntax-quote templates.
 (define (hc-head-is? x nm)
   (and (cseq? x)
        (let ((h (seq-first x)))
-         (and (symbol-t? h) (jolt-nil? (hc-sym-ns h)) (string=? (symbol-t-name h) nm)))))
+         (and (symbol-t? h) (string=? (symbol-t-name h) nm)
+              (let ((ns (hc-sym-ns h)))
+                (or (jolt-nil? ns) (and (string? ns) (string=? ns "clojure.core"))))))))
 (define (hc-second x) (seq-first (jolt-seq (seq-more x))))
 
 (define (hc-sq-symbol ctx form gsmap)

host/chez/java/records-interop.ss

@@ -93,8 +93,13 @@
       ((jrec? val)
        (let ((tag (jrec-tag val)))
          (or (string=? tag tname)
-             (and (> (string-length tag) (string-length tname))
+             ;; a simple name matches a qualified tag only at a `.` boundary:
-                  (string=? (substring tag (- (string-length tag) (string-length tname)) (string-length tag)) tname))
+             ;; "a.b.IntervalFD" is an IntervalFD, but "a.b.MultiIntervalFD" is NOT
+             ;; (a raw string-suffix would wrongly match the latter).
+             (let ((tl (string-length tag)) (nl (string-length tname)))
+               (and (fx>? tl nl)
+                    (char=? (string-ref tag (fx- (fx- tl nl) 1)) #\.)
+                    (string=? (substring tag (fx- tl nl) tl) tname)))
              ;; a protocol/interface the type implements (defprotocol generates an
              ;; interface; (instance? SomeProtocol record) is true when the record
              ;; implements it — core.match dispatches on instance? IPatternCompile).

host/chez/reader.ss

@@ -589,10 +589,13 @@
                            (jolt-list (jolt-symbol #f "syntax-quote") form))
                        j)))
             ((char=? c #\@) (rdr-wrap s (+ i 1) end (jolt-symbol "clojure.core" "deref")))
+            ;; ~ / ~@ read as clojure.core/unquote(-splicing), like the JVM reader —
+            ;; so code that inspects pattern/template data (core.logic's defne) sees
+            ;; the qualified symbol it expects.
             ((char=? c #\~)
              (if (and (< (+ i 1) end) (char=? (string-ref s (+ i 1)) #\@))
-                 (rdr-wrap s (+ i 2) end (jolt-symbol #f "unquote-splicing"))
+                 (rdr-wrap s (+ i 2) end (jolt-symbol "clojure.core" "unquote-splicing"))
-                 (rdr-wrap s (+ i 1) end (jolt-symbol #f "unquote"))))
+                 (rdr-wrap s (+ i 1) end (jolt-symbol "clojure.core" "unquote"))))
             ((char=? c #\^)
              (let-values (((mform j) (rdr-read-form s (+ i 1) end)))
                (let-values (((target k) (rdr-read-form s j end)))

jolt-core/jolt/analyzer.clj

@@ -52,6 +52,11 @@
 (defn- empty-env [] {:locals #{} :hints {}})
 (defn- local? [env nm] (contains? (:locals env) nm))
 (defn- add-locals [env names] (update env :locals #(reduce conj % names)))
+;; &env value handed to a macro: a map of each in-scope local SYMBOL to nil
+;; (Clojure's &env maps locals to compiler binding objects; consumers like
+;; core.logic's matche only read its keys to tell locals from fresh pattern vars).
+(defn- amp-env-map [env]
+  (reduce (fn [m n] (assoc m (symbol n) nil)) {} (:locals env)))
 (defn- with-recur [env name] (assoc env :recur name))
 
 ;; Type hints. The reader keeps ^hint metadata on the binding symbol.
@@ -632,7 +637,7 @@
             ;; 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.
-            (let [node (analyze ctx (form-expand-1 ctx form) env)
+            (let [node (analyze ctx (form-expand-1 ctx form (amp-env-map env)) env)
                   p (form-position form)]
               (if (and p (= :def (:op node))) (assoc node :pos p) node))
           ;; jolt.ffi/__cfn — the foreign-function special form (always emitted

test/chez/corpus.edn

@@ -3347,4 +3347,6 @@
   {: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)))"}
+  {:suite "reader / unquote" :label "~x reads as clojure.core/unquote" :expected "true" :actual "(= (quote (clojure.core/unquote v)) (read-string \"~v\"))"}
+  {:suite "reader / unquote" :label "~@x reads as clojure.core/unquote-splicing" :expected "true" :actual "(= (quote clojure.core/unquote-splicing) (first (read-string \"~@xs\")))"}
 ]

test/chez/unit.edn

@@ -323,8 +323,8 @@
   {:suite "reader" :expr "(= [1 [2 3] {:k :v}] (read-string \"[1 [2 3] {:k :v}]\"))" :expected "true"}
   {:suite "reader" :expr "(= (quote (quote x)) (read-string \"'x\"))" :expected "true"}
   {:suite "reader" :expr "(= (quote (clojure.core/deref a)) (read-string \"@a\"))" :expected "true"}
-  {:suite "reader" :expr "(= (quote (syntax-quote (a (unquote b)))) (read-string \"`(a ~b)\"))" :expected "true"}
+  {:suite "reader" :expr "(= (quote (syntax-quote (a (clojure.core/unquote b)))) (read-string \"`(a ~b)\"))" :expected "true"}
-  {:suite "reader" :expr "(= (quote (unquote-splicing xs)) (read-string \"~@xs\"))" :expected "true"}
+  {:suite "reader" :expr "(= (quote (clojure.core/unquote-splicing xs)) (read-string \"~@xs\"))" :expected "true"}
   {:suite "reader" :expr "(= 42 (read-string \"; comment\\n42\"))" :expected "true"}
   {:suite "reader" :expr "(= [1 2] (read-string \"[1 #_ 9 2]\"))" :expected "true"}
   {:suite "reader" :expr "(nil? (read-string \"\"))" :expected "true"}