Merge pull request #247 from jolt-lang/conformance/lib-fixes

More conformance fixes: defn attr-map, set-in-macro, record interop, Byte/Short

host/chez/host-contract.ss

@@ -203,10 +203,22 @@
             dst))
       dst))
 
+;; A set literal reads as the tagged set-form {:jolt/type :jolt/set :value [...]}
+;; for the analyzer, but a macro must see a real set value (Clojure parity, so
+;; (set? arg) / seq / conj work — hiccup's compiler does this). Convert a set-form
+;; argument to a set; elements stay as read (a deeply-nested set literal inside
+;; another form is rarer and left for the analyzer).
+(define (hc-macro-arg x)
+  (if (rdr-set-form? x)
+      (let ((items (jolt-get x rdr-kw-value)))
+        (let loop ((i 0) (s empty-pset))
+          (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)
   (let* ((items (seq->list form))
          (head (car items))
-         (args (cdr items))
+         (args (map hc-macro-arg (cdr items)))
          (expander (var-cell-root (hc-resolve-cell ctx head))))
     (hc-propagate-pos form (apply jolt-invoke expander args))))
 

host/chez/java/host-class.ss

@@ -91,6 +91,7 @@
   '(("String" . "java.lang.String") ("Number" . "java.lang.Number")
     ("Boolean" . "java.lang.Boolean") ("Long" . "java.lang.Long")
     ("Integer" . "java.lang.Integer") ("Double" . "java.lang.Double")
+    ("Float" . "java.lang.Float") ("Byte" . "java.lang.Byte") ("Short" . "java.lang.Short")
     ("Object" . "java.lang.Object") ("Character" . "java.lang.Character")
     ("InputStream" . "java.io.InputStream") ("OutputStream" . "java.io.OutputStream")
     ("File" . "java.io.File") ("Reader" . "java.io.Reader") ("Writer" . "java.io.Writer")
@@ -160,6 +161,7 @@
 (for-each
   (lambda (nm) (def-var! "clojure.core" nm nm))
   '("java.lang.Long" "java.lang.Integer" "java.lang.Double" "java.lang.Float"
+    "java.lang.Byte" "java.lang.Short"
     "java.lang.Number" "java.lang.String" "java.lang.Boolean" "java.lang.Character"
     "java.lang.Object"
     ;; exception classes compared against (class e): (= java.net.SocketTimeoutException (class e))

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

@@ -136,6 +136,19 @@
         (cons "toBinaryString" (lambda (x) (number->string (int->u32 (jnum->exact x)) 2)))
         (cons "toString" (lambda (x . r) (number->string (jnum->exact x) (if (null? r) 10 (jnum->exact (car r))))))))
 
+;; Byte / Short bounds (their values are plain integers on jolt; the statics let
+;; libraries reference the JVM ranges — clojure.test.check generates over them).
+(register-class-statics! "Byte"
+  (list (cons "MAX_VALUE" (->num 127)) (cons "MIN_VALUE" (->num -128))
+        (cons "valueOf" (lambda (x . r) (->num (if (number? x) x (parse-int-or-throw x 10 "valueOf")))))
+        (cons "parseByte" (lambda (x . r) (parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "parseByte")))
+        (cons "toString" (lambda (x . r) (number->string (jnum->exact x))))))
+(register-class-statics! "Short"
+  (list (cons "MAX_VALUE" (->num 32767)) (cons "MIN_VALUE" (->num -32768))
+        (cons "valueOf" (lambda (x . r) (->num (if (number? x) x (parse-int-or-throw x 10 "valueOf")))))
+        (cons "parseShort" (lambda (x . r) (parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "parseShort")))
+        (cons "toString" (lambda (x . r) (number->string (jnum->exact x))))))
+
 (register-class-statics! "Boolean"
   (list (cons "parseBoolean" (lambda (s) (string=? "true" (ascii-string-down (if (string? s) s (jolt-str-render-one s))))))
         (cons "TRUE" #t) (cons "FALSE" #f)))

host/chez/records.ss

@@ -728,6 +728,28 @@
       ;; (above) wins, this is the field-accessor fallback.
       ((and (jrec? obj) (null? rest) (jrec-has? obj (keyword #f method-name)))
        (jrec-lookup obj (keyword #f method-name) jolt-nil))
+      ;; a defrecord is Associative / ILookup / IPersistentMap / Seqable / Counted,
+      ;; so its clojure.lang interface methods delegate to the map fns when not
+      ;; overridden by a declared method — reitit's impl calls (.assoc match k v),
+      ;; (.valAt …), (.without …) directly. A bare deftype implements these via its
+      ;; own declared methods (handled above), so this is record-only.
+      ((and (jrec-record? obj)
+            (member method-name '("valAt" "assoc" "without" "containsKey" "cons"
+                                  "count" "seq" "equiv" "entryAt" "empty")))
+       (cond
+         ((string=? method-name "valAt")
+          (if (null? (cdr rest)) (jolt-get obj (car rest) jolt-nil) (jolt-get obj (car rest) (cadr rest))))
+         ((string=? method-name "assoc") (jolt-assoc1 obj (car rest) (cadr rest)))
+         ((string=? method-name "without") (jolt-dissoc obj (car rest)))
+         ((string=? method-name "containsKey") (if (jolt-truthy? (jolt-contains? obj (car rest))) #t #f))
+         ((string=? method-name "cons") (jolt-conj1 obj (car rest)))
+         ((string=? method-name "count") (jolt-count obj))
+         ((string=? method-name "seq") (jolt-seq obj))
+         ((string=? method-name "equiv") (if (jolt= obj (car rest)) #t #f))
+         ((string=? method-name "entryAt")
+          (if (jolt-truthy? (jolt-contains? obj (car rest)))
+              (make-map-entry (car rest) (jolt-get obj (car rest) jolt-nil)) jolt-nil))
+         (else jolt-nil)))   ; .empty of a record is nil on the JVM
       ((reified-methods obj)
        => (lambda (rm) (let ((f (hashtable-ref rm method-name #f)))
                          (if f (apply jolt-invoke f obj rest) (error #f (string-append "No method " method-name))))))

jolt-core/clojure/core/00-syntax.clj

@@ -377,21 +377,31 @@
 ;; vector + body or a sequence of ([params] body) clauses, so no arity branching is
 ;; needed. (map? is true for symbol forms too, so guard the attr-map with symbol?.)
 ;; Defined before fresh-sym below, which is a defn-.
+;; defn lives in the earliest tier, so its macro body may only use primitives
+;; available before the seq/coll tiers — conj (which merges a map onto a map),
+;; assoc, meta, with-meta — not merge/last/butlast.
 (defmacro defn [fn-name & body]
   (let [docstring (when (and (seq body) (string? (first body))) (first body))
         body (if docstring (rest body) body)
-        body (if (and (seq body) (map? (first body)) (not (symbol? (first body))))
-               (rest body) body)
-        ;; ^{:map} metadata on the name reads as a (with-meta sym …) form, not an
-        ;; annotated symbol. def attaches the metadata, but fn needs a
-        ;; bare symbol, so unwrap it for the fn name.
-        fn-only-name (if (symbol? fn-name) fn-name (first (rest fn-name)))]
-    ;; pass the name through to fn: the compiled fn's host name carries it,
-    ;; so stack traces read app.deep/level3 instead of a gensym. A leading
-    ;; docstring rides the def's docstring slot so (:doc (meta #'f)) is set.
-    (if docstring
-      `(def ~fn-name ~docstring (fn ~fn-only-name ~@body))
-      `(def ~fn-name (fn ~fn-only-name ~@body)))))
+        ;; the attr-map after an optional docstring (or after the name) — its keys
+        ;; merge into the var metadata, like Clojure. A map in the first arity
+        ;; position is the attr-map only when more body follows (else it is a lone
+        ;; map body) and is never a symbol (a name carries its meta as a form).
+        attr-map (when (and (seq body) (next body) (map? (first body)) (not (symbol? (first body))))
+                   (first body))
+        body (if attr-map (rest body) body)
+        ;; the bare name + any ^{:map} metadata the reader attached to it.
+        fn-only-name (if (symbol? fn-name) fn-name (first (rest fn-name)))
+        name-meta (meta fn-only-name)
+        m1 (if attr-map (if name-meta (conj name-meta attr-map) attr-map) name-meta)
+        meta-map (if docstring (assoc (if m1 m1 {}) :doc docstring) m1)]
+    ;; pass the name through to fn: the compiled fn's host name carries it, so
+    ;; stack traces read app.deep/level3 instead of a gensym. All metadata
+    ;; (docstring + attr-map + the name's own) is attached to the def name symbol,
+    ;; which analyze-def reads and evaluates — so (meta #'f) reflects every source.
+    (if meta-map
+      `(def ~(with-meta fn-only-name meta-map) (fn ~(with-meta fn-only-name nil) ~@body))
+      `(def ~fn-only-name (fn ~fn-only-name ~@body)))))
 
 ;; Jolt doesn't enforce privacy, so defn- is just defn (matching how Clojure's own
 ;; defn- delegates to defn with :private metadata).

test/chez/corpus.edn

@@ -3296,4 +3296,10 @@
   {:suite "ifn / symbol as fn" :label "a symbol invokes as a map lookup" :expected "true" :actual "(= 5 ('a {(quote a) 5}))"}
   {:suite "ifn / symbol as fn" :label "a symbol fn takes a not-found default" :expected "true" :actual "(= :d ('a {} :d))"}
   {:suite "ifn / symbol as fn" :label "a symbol works as a mapping fn" :expected "true" :actual "(= [1 2] (vec (map (quote k) [{(quote k) 1} {(quote k) 2}])))"}
+  {:suite "defn / attr-map" :label "docstring + attr-map both land in var meta" :expected "true" :actual "(do (defn f \"doc\" {:my :attr} [] 1) (= [\"doc\" :attr] [(:doc (meta (var f))) (:my (meta (var f)))]))"}
+  {:suite "defn / attr-map" :label "attr-map without a docstring" :expected "true" :actual "(do (defn g {:my :attr} [] 1) (= :attr (:my (meta (var g)))))"}
+  {:suite "defn / attr-map" :label "attr-map on a multi-arity defn" :expected "true" :actual "(do (defn h \"d\" {:my :a} ([] 1) ([a] a)) (= :a (:my (meta (var h)))))"}
+  {:suite "defn / attr-map" :label "attr-map values are evaluated" :expected "true" :actual "(do (defn m {:val (+ 1 2)} [] 1) (= 3 (:val (meta (var m)))))"}
+  {:suite "records / clojure.lang interop" :label "a record's Associative/ILookup methods delegate to the map fns" :expected "[1 9 true true 2]" :actual "(do (defrecord M [a b]) (let [m (->M 1 2)] [(.valAt m :a) (.valAt m :z 9) (= {:a 1 :b 2 :c 3} (into {} (.assoc m :c 3))) (.containsKey m :a) (.count m)]))"}
+  {:suite "interop / number classes" :label "Byte/Short bounds + class tokens" :expected "[127 -128 32767 -32768 true]" :actual "[Byte/MAX_VALUE Byte/MIN_VALUE Short/MAX_VALUE Short/MIN_VALUE (= java.lang.Byte java.lang.Byte)]"}
 ]

test/chez/unit.edn

@@ -567,4 +567,7 @@
   {: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 (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"}
+  {:suite "macro-args" :expr "(do (defmacro vm [x] (vector? x)) (vm [1 2]))" :expected "true"}
 ]