Merge pull request #197 from jolt-lang/spike/special-form-precedence
Make clojure.spec.alpha load and run
This commit is contained in:
Dmitri Sotnikov
GitHub
commit
462d53a28e
11 changed files with 598 additions and 532 deletions
|
|
@ -595,7 +595,7 @@
|
|||
;; values that carry metadata (mirrors jolt-with-meta's set in natives-meta.ss).
|
||||
(define (hsc-imeta? x)
|
||||
(or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x)
|
||||
(jolt-lazyseq? x) (jrec? x) (procedure? x) (symbol-t? x)))
|
||||
(jolt-lazyseq? x) (jrec? x) (jreify? x) (procedure? x) (symbol-t? x)))
|
||||
(register-instance-check-arm!
|
||||
(lambda (type-sym val)
|
||||
(let ((iface (hsc-last-segment (symbol-t-name type-sym))))
|
||||
|
|
|
|||
|
|
@ -90,13 +90,35 @@
|
|||
((string=? method "isInfinite") (and (flonum? n) (infinite? n)))
|
||||
(else (error #f (string-append "No method " method " for number")))))
|
||||
|
||||
;; Mutable static fields: "Class" -> (member -> 1-vector cell). A library that
|
||||
;; writes a static field — clojure.spec.alpha's (set! (. clojure.lang.RT
|
||||
;; checkSpecAsserts) flag) — lands here; the analyzer lowers the set! to a
|
||||
;; set-static-field! call and a plain Class/member read consults the cell first.
|
||||
(define mutable-statics-tbl (make-hashtable string-hash string=?))
|
||||
(define (mutable-static-cell class member create?)
|
||||
(let ((h (or (hashtable-ref mutable-statics-tbl class #f)
|
||||
(and create? (let ((nh (make-hashtable string-hash string=?)))
|
||||
(hashtable-set! mutable-statics-tbl class nh) nh)))))
|
||||
(and h (or (hashtable-ref h member #f)
|
||||
(and create? (let ((c (vector jolt-nil))) (hashtable-set! h member c) c))))))
|
||||
(def-var! "jolt.host" "set-static-field!"
|
||||
(lambda (class member val)
|
||||
(vector-set! (mutable-static-cell class member #t) 0 val)
|
||||
val))
|
||||
;; clojure.lang.RT.checkSpecAsserts — a JVM-internal flag clojure.spec.alpha reads
|
||||
;; and writes; default false. Pre-seed the cell so a read before any write works.
|
||||
(vector-set! (mutable-static-cell "clojure.lang.RT" "checkSpecAsserts" #t) 0 #f)
|
||||
|
||||
;; ---- emit entry points ------------------------------------------------------
|
||||
(define (host-static-ref class member)
|
||||
(let ((h (lookup-class class-statics-tbl class)))
|
||||
(if h
|
||||
(let ((v (hashtable-ref h member #f)))
|
||||
(if v v (error #f (string-append "No static " class "/" member))))
|
||||
(error #f (string-append "Unknown class " class)))))
|
||||
(let ((cell (mutable-static-cell class member #f)))
|
||||
(if cell
|
||||
(vector-ref cell 0)
|
||||
(let ((h (lookup-class class-statics-tbl class)))
|
||||
(if h
|
||||
(let ((v (hashtable-ref h member #f)))
|
||||
(if v v (error #f (string-append "No static " class "/" member))))
|
||||
(error #f (string-append "Unknown class " class)))))))
|
||||
|
||||
(define (host-static-call class member . args)
|
||||
(apply (host-static-ref class member) args))
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@
|
|||
(jolt-assoc (if user user (jolt-hash-map))
|
||||
jolt-kw-var-ns (var-cell-ns x)
|
||||
jolt-kw-var-name (var-cell-name x))))
|
||||
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (procedure? 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)))
|
||||
|
||||
|
|
@ -34,6 +34,10 @@
|
|||
((pmap? x) (make-pmap (pmap-root x) (pmap-cnt x)))
|
||||
((pset? x) (make-pset (pset-m x)))
|
||||
((jrec? x) (make-jrec (jrec-tag x) (jrec-pairs x)))
|
||||
;; a reify shares its (read-only) method table + protos but gets a fresh
|
||||
;; identity, so attaching meta leaves the original's meta untouched. Every
|
||||
;; Clojure reify implements IObj.
|
||||
((jreify? x) (make-jreify (jreify-methods x) (jreify-protos x)))
|
||||
;; () is a shared singleton — a fresh instance keeps meta off every other ().
|
||||
((empty-list-t? x) (fresh-empty-list))
|
||||
(else x))) ; cseq / procedure
|
||||
|
|
@ -41,7 +45,7 @@
|
|||
(define (jolt-with-meta x m)
|
||||
(cond
|
||||
((symbol-t? x) (make-symbol-t (symbol-t-ns x) (symbol-t-name x) m))
|
||||
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (procedure? x))
|
||||
((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))
|
||||
c))
|
||||
|
|
|
|||
|
|
@ -68,7 +68,9 @@
|
|||
(and (> (string-length tag) (string-length tname))
|
||||
(string=? (substring tag (- (string-length tag) (string-length tname)) (string-length tag)) tname)))))
|
||||
((jreify? val) (let ((short (last-dot tname)))
|
||||
(and (memp (lambda (p) (string=? (last-dot p) short)) (jreify-protos val)) #t)))
|
||||
;; every Clojure reify implements IObj/IMeta (carries metadata).
|
||||
(or (member short '("IObj" "IMeta"))
|
||||
(and (memp (lambda (p) (string=? (last-dot p) short)) (jreify-protos val)) #t))))
|
||||
((ex-info-map? val) (exception-isa? (last-dot (ex-info-class val)) (last-dot tname)))
|
||||
(else (case-string tname val)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -359,6 +359,23 @@
|
|||
(symbol-t-name obj)))
|
||||
((string=? method-name "equals") (and (pair? rest) (jolt=2 obj (car rest))))
|
||||
(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*).
|
||||
((jns? obj)
|
||||
(cond ((or (string=? method-name "name") (string=? method-name "getName"))
|
||||
(jolt-symbol #f (jns-name obj)))
|
||||
((string=? method-name "toString") (jns-name obj))
|
||||
(else (error #f (string-append "No method " method-name " on Namespace")))))
|
||||
;; clojure.lang.Var: ns -> its Namespace, sym -> the simple-name Symbol.
|
||||
;; clojure.spec.alpha's ->sym reads (.name (.ns v)) and (.sym v).
|
||||
((var-cell? obj)
|
||||
(cond ((string=? method-name "ns") (intern-ns! (var-cell-ns obj)))
|
||||
((or (string=? method-name "sym") (string=? method-name "name"))
|
||||
(jolt-symbol #f (var-cell-name obj)))
|
||||
((string=? method-name "getName")
|
||||
(jolt-symbol (var-cell-ns obj) (var-cell-name obj)))
|
||||
((string=? method-name "toString") (string-append "#'" (var-cell-ns obj) "/" (var-cell-name obj)))
|
||||
(else (error #f (string-append "No method " method-name " on Var")))))
|
||||
;; java.lang.Throwable interop over a Chez condition. A jolt host error
|
||||
;; (`error`/`assertion-violationf`) raises a Chez condition; Clojure code
|
||||
;; that catches it as a Throwable reads (.getMessage e) / (.toString e).
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
|
|
@ -448,15 +448,22 @@
|
|||
;; a reify can implement SEVERAL protocols; collect them all (each bare symbol
|
||||
;; switches the current protocol, like extend-type) and pass every protocol name
|
||||
;; to make-reified so (instance? Proto r)/satisfies? recognise all of them.
|
||||
(loop [items (seq forms) protos [] methods {}]
|
||||
;; Several bodies for the same method name are distinct arities (clojure.spec
|
||||
;; reifies (specize* [s]) and (specize* [s _])): group them into one multi-arity
|
||||
;; fn so dispatch picks the clause by arg count.
|
||||
(loop [items (seq forms) protos [] methods {} order []]
|
||||
(if (empty? items)
|
||||
`(make-reified ~methods ~@(vec (map name protos)))
|
||||
`(make-reified
|
||||
~(reduce (fn [m k] (assoc m k `(fn ~@(get methods k)))) {} order)
|
||||
~@(vec (map name protos)))
|
||||
(let [x (first items)]
|
||||
(if (symbol? x)
|
||||
(recur (rest items) (conj protos x) methods)
|
||||
(recur (rest items) protos
|
||||
(assoc methods (keyword (name (first x)))
|
||||
`(fn ~(nth x 1) ~@(drop 2 x)))))))))
|
||||
(recur (rest items) (conj protos x) methods order)
|
||||
(let [k (keyword (name (first x)))
|
||||
clause `(~(nth x 1) ~@(drop 2 x))]
|
||||
(recur (rest items) protos
|
||||
(assoc methods k (conj (get methods k []) clause))
|
||||
(if (contains? methods k) order (conj order k)))))))))
|
||||
|
||||
(defmacro defrecord [name-sym fields & body]
|
||||
(let [tn (name name-sym)
|
||||
|
|
|
|||
|
|
@ -331,6 +331,14 @@
|
|||
(and thead (field-head? thead))
|
||||
{:op :set-field :obj (analyze ctx (nth ti 1) env)
|
||||
:field (subs thead 2) :val val-node}
|
||||
;; (set! (. Class member) val) — a host static-field set. clojure.spec.alpha
|
||||
;; toggles clojure.lang.RT/checkSpecAsserts this way. Lowered to a runtime
|
||||
;; jolt.host/set-static-field! call (the read side is a :host-static ref).
|
||||
(and (= thead ".") (>= (count ti) 3) (form-sym? (nth ti 1)) (form-sym? (nth ti 2))
|
||||
(= :class (:kind (resolve-global ctx (nth ti 1)))))
|
||||
(invoke (var-ref "jolt.host" "set-static-field!")
|
||||
[(const (:name (resolve-global ctx (nth ti 1))))
|
||||
(const (form-sym-name (nth ti 2))) val-node])
|
||||
(form-sym? target)
|
||||
(do (when (local? env (form-sym-name target)) (uncompilable "set! of a local"))
|
||||
(let [r (resolve-global ctx target)]
|
||||
|
|
@ -557,11 +565,12 @@
|
|||
shadowed (and hname (local? env hname))]
|
||||
(cond
|
||||
;; Canonical order (Clojure/CLJS analyze-seq): macroexpand FIRST, then
|
||||
;; dispatch special forms / interop / invoke. Expanding before the
|
||||
;; special-form check means a head that is a macro always expands — even
|
||||
;; one whose name is also in the special-form set — matching reference
|
||||
;; read -> macroexpand -> analyze. A local shadows both.
|
||||
(and (form-sym? head) (not shadowed) (form-macro? ctx head))
|
||||
;; dispatch special forms / interop / invoke. A local shadows the macro.
|
||||
;; A true special form is NOT shadowable by a same-named macro, matching
|
||||
;; 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))
|
||||
(analyze ctx (form-expand-1 ctx form) env)
|
||||
;; jolt.ffi/__cfn — the foreign-function special form (always emitted
|
||||
;; fully-qualified by the jolt.ffi/foreign-fn macro, so aliases resolve).
|
||||
|
|
|
|||
|
|
@ -543,6 +543,9 @@
|
|||
{:suite "host-interop / ring-codec surface" :label "extend-protocol nil" :expected ":nil" :actual "(do (defprotocol Pn (pn [x])) (extend-protocol Pn nil (pn [n] :nil) Object (pn [o] :obj)) (pn nil))"}
|
||||
{:suite "host-interop / ring-codec surface" :label "extend-protocol Map covers sorted" :expected ":map" :actual "(do (defprotocol Ps (ps [x])) (extend-protocol Ps Map (ps [m] :map) Object (ps [o] :obj)) (ps (sorted-map 1 2)))"}
|
||||
{:suite "host-interop / ring-codec surface" :label "reduce over reified IReduceInit" :expected "42" :actual "(reduce + 0 (reify clojure.lang.IReduceInit (reduce [_ f init] (f (f init 40) 2))))"}
|
||||
{:suite "core / reify" :label "multi-arity method dispatches by arg count" :expected "[:z 9]" :actual "(do (defprotocol P (m [_] [_ a])) (let [r (reify P (m [_] :z) (m [_ x] x))] [(m r) (m r 9)]))"}
|
||||
{:suite "core / reify" :label "reify implements IObj and carries metadata" :expected "[true 2]" :actual "(do (defprotocol Q (qq [_])) (let [r (reify Q (qq [_] 1))] [(instance? clojure.lang.IObj r) (:k (meta (with-meta r {:k 2})))]))"}
|
||||
{:suite "core / reify" :label "with-meta leaves the original untouched and keeps dispatch" :expected "[nil {:k 2} 1]" :actual "(do (defprotocol Q (qq [_])) (let [r (reify Q (qq [_] 1)) r2 (with-meta r {:k 2})] [(meta r) (meta r2) (qq r2)]))"}
|
||||
{:suite "host-interop / class tokens & readers" :label "class name evaluates to canonical string" :expected "java.lang.String" :actual "String"}
|
||||
{:suite "host-interop / class tokens & readers" :label "dispatch-only class name" :expected "\"java.io.InputStream\"" :actual "InputStream"}
|
||||
{:suite "host-interop / class tokens & readers" :label "(class x) matches the token" :expected "true" :actual "(= String (class \"abc\"))"}
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
[
|
||||
{:suite "special-form precedence" :expr "(do (ns sftest (:refer-clojure :exclude [def])) (defmacro def [n v] :shadowed) (clojure.core/defn ff [] 99) (ff))" :expected "99"}
|
||||
{:suite "special-form precedence" :expr "(do (set! (. clojure.lang.RT checkSpecAsserts) true) clojure.lang.RT/checkSpecAsserts)" :expected "true"}
|
||||
{:suite "atomwatch" :expr "(let [a (atom 0) seen (atom 0)] (add-watch a :k (fn [k r o n] (reset! seen 1))) (reset! a 5) @seen)" :expected "1"}
|
||||
{:suite "atomwatch" :expr "(let [a (atom 0) seen (atom 0)] (add-watch a :k (fn [k r o n] (swap! seen inc))) (remove-watch a :k) (reset! a 5) @seen)" :expected "0"}
|
||||
{:suite "atomwatch" :expr "(let [a (atom 0) log (atom [])] (add-watch a :k (fn [k r o n] (swap! log conj [o n]))) (reset! a 1) (reset! a 2) @log)" :expected "[[0 1] [1 2]]"}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue