Merge pull request #263 from jolt-lang/conformance/spec-alpha
spec.alpha: symbol-of-var, demunge, MultiFn methods, fn class names, namespaced maps
This commit is contained in:
Dmitri Sotnikov
GitHub
commit
92368b49f1
16 changed files with 184 additions and 21 deletions
|
|
@ -44,8 +44,37 @@
|
|||
(fold-left (lambda (m s) (jolt-assoc1 m (jolt-symbol #f s) #t))
|
||||
(jolt-assoc1 (jolt-hash-map) (jolt-symbol "clojure.core" "import*") #t)
|
||||
unq)))
|
||||
;; clojure.lang.Compiler/demunge — reverse the name munging Clojure applies to
|
||||
;; build JVM class/method names, so "clojure.core$odd_QMARK_" -> clojure.core/odd?.
|
||||
;; clojure.spec.alpha's fn-sym uses it to recover a symbol from a fn's class name.
|
||||
;; Longest tokens first; a standalone _ is a hyphen; $ separates ns from name.
|
||||
(define demunge-token-map
|
||||
'(("_DOUBLEQUOTE_" . "\"") ("_SINGLEQUOTE_" . "'") ("_AMPERSAND_" . "&") ("_PERCENT_" . "%")
|
||||
("_LBRACE_" . "{") ("_RBRACE_" . "}") ("_LBRACK_" . "[") ("_RBRACK_" . "]")
|
||||
("_BSLASH_" . "\\") ("_TILDE_" . "~") ("_CIRCA_" . "@") ("_SHARP_" . "#") ("_BANG_" . "!")
|
||||
("_CARET_" . "^") ("_COLON_" . ":") ("_QMARK_" . "?") ("_SLASH_" . "/") ("_PLUS_" . "+")
|
||||
("_STAR_" . "*") ("_BAR_" . "|") ("_GT_" . ">") ("_LT_" . "<") ("_EQ_" . "=") ("_DOT_" . ".")))
|
||||
(define (compiler-demunge s)
|
||||
(let* ((s (if (string? s) s (jolt-str-render-one s)))
|
||||
(n (string-length s))
|
||||
(out (open-output-string)))
|
||||
(let loop ((i 0))
|
||||
(if (>= i n) (get-output-string out)
|
||||
(let ((tok (let scan ((ts demunge-token-map))
|
||||
(cond ((null? ts) #f)
|
||||
((let ((t (caar ts)))
|
||||
(and (<= (+ i (string-length t)) n)
|
||||
(string=? (substring s i (+ i (string-length t))) t)))
|
||||
(car ts))
|
||||
(else (scan (cdr ts)))))))
|
||||
(cond
|
||||
(tok (display (cdr tok) out) (loop (+ i (string-length (car tok)))))
|
||||
((char=? (string-ref s i) #\_) (write-char #\- out) (loop (+ i 1)))
|
||||
((char=? (string-ref s i) #\$) (write-char #\/ out) (loop (+ i 1)))
|
||||
(else (write-char (string-ref s i) out) (loop (+ i 1)))))))))
|
||||
(let ((members (list (cons "LINE" compiler-line-cell) (cons "COLUMN" compiler-column-cell)
|
||||
(cons "specials" compiler-specials))))
|
||||
(cons "specials" compiler-specials)
|
||||
(cons "demunge" compiler-demunge))))
|
||||
(register-class-statics! "Compiler" members)
|
||||
(register-class-statics! "clojure.lang.Compiler" members))
|
||||
|
||||
|
|
|
|||
|
|
@ -132,6 +132,8 @@
|
|||
(jolt-symbol (substring a 0 i) (substring a (+ i 1) slen)))
|
||||
(else (loop (- i 1))))))))
|
||||
((keyword? a) (jolt-symbol (keyword-t-ns a) (keyword-t-name a)))
|
||||
;; (symbol a-var) -> the var's qualified symbol (clojure.spec.alpha/->sym).
|
||||
((var-cell? a) (jolt-symbol (var-cell-ns a) (var-cell-name a)))
|
||||
(else (error #f "symbol: requires string/symbol" a)))))
|
||||
;; (symbol ns name): a nil namespace is the no-ns sentinel #f (NOT jolt-nil),
|
||||
;; so (symbol nil "x") equals (symbol "x") and the reader literal 'x — jolt=
|
||||
|
|
|
|||
|
|
@ -96,6 +96,21 @@
|
|||
;; (.getClass x) universal — the class token for any value, before the
|
||||
;; collection/map field-lookup arms below would read it as a missing key.
|
||||
((string=? method-name "getClass") (jolt-class obj))
|
||||
;; clojure.lang.MultiFn .dispatchFn / .getMethod — clojure.spec.alpha's
|
||||
;; multi-spec walks a multimethod through these.
|
||||
((jolt-multifn? obj)
|
||||
(cond
|
||||
((string=? mname "dispatchFn") (jolt-multifn-dispatch-fn obj))
|
||||
((string=? mname "getMethod")
|
||||
(let ((methods (jolt-multifn-methods obj)) (dv (car rest)))
|
||||
(or (hashtable-ref methods dv #f)
|
||||
(mm-find-isa obj dv)
|
||||
(hashtable-ref methods (jolt-multifn-default obj) #f)
|
||||
jolt-nil)))
|
||||
(else (%dot-rmd obj method-name rest-args))))
|
||||
;; (.applyTo f args): apply a fn to a seq of args (clojure.spec instrument).
|
||||
((and (procedure? obj) (string=? mname "applyTo"))
|
||||
(apply jolt-invoke obj (seq->list (jolt-seq (car rest)))))
|
||||
;; a transient (ITransientCollection/Set/Map): .contains / .valAt / .count —
|
||||
;; test.check's distinct-collection gen uses (.contains transient-set k).
|
||||
((jolt-transient? obj)
|
||||
|
|
|
|||
|
|
@ -35,7 +35,11 @@
|
|||
((jolt-atom? x) "clojure.lang.Atom")
|
||||
((char? x) "java.lang.Character")
|
||||
((regex-t? x) "java.util.regex.Pattern")
|
||||
((procedure? x) "clojure.lang.IFn")
|
||||
;; an anonymous / unregistered fn — like the JVM, where (class #(..)) is a
|
||||
;; concrete ns$fn__N subclass. The $fn marker lets clojure.spec.alpha's fn-sym
|
||||
;; recognize it as anonymous and return ::s/unknown. A named fn is registered
|
||||
;; (proc-name-tbl) and handled by a class-arm with its real ns$name.
|
||||
((procedure? x) "clojure.lang.AFunction$fn")
|
||||
;; an exception value (ex-info / host-constructed throwable) reports its JVM
|
||||
;; class, so (= clojure.lang.ExceptionInfo (class e)) and clojure.test's
|
||||
;; (thrown? Class …) match (records.ss ex-info-map?/ex-info-class).
|
||||
|
|
@ -59,9 +63,28 @@
|
|||
;; (thrown? ArityException …) test match — not the opaque :object fallback.
|
||||
(register-class-arm!
|
||||
(lambda (x) (and (chez-condition-exc-class x) #t))
|
||||
(lambda (x) (if (string=? (chez-condition-exc-class x) "ArityException")
|
||||
"clojure.lang.ArityException"
|
||||
"java.lang.IllegalArgumentException")))
|
||||
(lambda (x) (let ((p (assoc (chez-condition-exc-class x) class-token-alist)))
|
||||
(if p (cdr p) "java.lang.IllegalArgumentException"))))
|
||||
;; A fn def'd into a var reports a JVM-style class name "ns$munged-name" (the
|
||||
;; forward CHAR_MAP), so clojure.spec.alpha's fn-sym (which splits on $ and
|
||||
;; demunges) recovers the predicate's symbol. Anonymous / unregistered fns stay
|
||||
;; clojure.lang.IFn (fn-sym yields :unknown, as on the JVM).
|
||||
(define class-munge-map
|
||||
'((#\? . "_QMARK_") (#\! . "_BANG_") (#\* . "_STAR_") (#\+ . "_PLUS_")
|
||||
(#\> . "_GT_") (#\< . "_LT_") (#\= . "_EQ_") (#\/ . "_SLASH_") (#\- . "_")
|
||||
(#\& . "_AMPERSAND_") (#\% . "_PERCENT_") (#\~ . "_TILDE_") (#\^ . "_CARET_")
|
||||
(#\| . "_BAR_") (#\: . "_COLON_")))
|
||||
(define (class-munge-name s)
|
||||
(let ((out (open-output-string)))
|
||||
(string-for-each
|
||||
(lambda (c) (let ((t (assv c class-munge-map))) (if t (display (cdr t) out) (write-char c out))))
|
||||
s)
|
||||
(get-output-string out)))
|
||||
(register-class-arm!
|
||||
(lambda (x) (and (procedure? x) (hashtable-ref proc-name-tbl x #f)))
|
||||
(lambda (x) (let ((p (hashtable-ref proc-name-tbl x #f)))
|
||||
(string-append (car p) "$" (class-munge-name (cdr p))))))
|
||||
|
||||
(define (jolt-class-name x)
|
||||
(let loop ((as jolt-class-arms))
|
||||
(cond ((null? as) (jolt-class-base x))
|
||||
|
|
|
|||
|
|
@ -953,12 +953,21 @@
|
|||
(reg-class-supers! "clojure.lang.LazySeq" '("clojure.lang.ISeq" "clojure.lang.IPersistentCollection" "clojure.lang.Sequential" "clojure.lang.Seqable" "java.lang.Iterable"))
|
||||
(reg-class-supers! "clojure.lang.Cons" '("clojure.lang.ASeq" "clojure.lang.ISeq" "clojure.lang.Sequential" "clojure.lang.Seqable" "java.lang.Iterable"))
|
||||
|
||||
;; A munged fn class name "ns$name" (jolt-class for a def'd fn) isn't in the table;
|
||||
;; like the JVM (a fn extends clojure.lang.AFunction) its super is AFunction, whose
|
||||
;; registered supers give AFn / IFn / Fn / Runnable / Callable transitively.
|
||||
(define (str-has-dollar? s)
|
||||
(let loop ((i 0)) (and (< i (string-length s)) (or (char=? (string-ref s i) #\$) (loop (+ i 1))))))
|
||||
(define (class-direct-supers name)
|
||||
(or (hashtable-ref class-supers-tbl name #f)
|
||||
(and (str-has-dollar? name) '("clojure.lang.AFunction"))
|
||||
'()))
|
||||
;; transitive closure of direct supers (set semantics via an accumulator list)
|
||||
(define (class-ancestors-list name)
|
||||
(let loop ((pending (hashtable-ref class-supers-tbl name '())) (seen '()))
|
||||
(let loop ((pending (class-direct-supers name)) (seen '()))
|
||||
(cond ((null? pending) (reverse seen))
|
||||
((member (car pending) seen) (loop (cdr pending) seen))
|
||||
(else (loop (append (hashtable-ref class-supers-tbl (car pending) '()) (cdr pending))
|
||||
(else (loop (append (class-direct-supers (car pending)) (cdr pending))
|
||||
(cons (car pending) seen))))))
|
||||
|
||||
;; (instance? Class e) on a throwable tagged-table carrying a JVM :class matches the
|
||||
|
|
|
|||
|
|
@ -487,6 +487,11 @@
|
|||
(register-host-methods! "thread"
|
||||
(list (cons "getContextClassLoader" (lambda (self) the-classloader))
|
||||
(cons "getName" (lambda (self) "main"))
|
||||
;; no reified call stack (jolt does TCO, so caller frames are erased) — an
|
||||
;; empty StackTraceElement[]. clojure.spec.test.alpha's instrument reads it
|
||||
;; to name the caller var; it degrades to no ::caller, the conform error
|
||||
;; (the ExceptionInfo) is still thrown.
|
||||
(cons "getStackTrace" (lambda (self) (jolt-vector)))
|
||||
(cons "interrupt" (lambda (self)
|
||||
(when (box? (jhost-state self)) (set-box! (jhost-state self) #t))
|
||||
jolt-nil))
|
||||
|
|
|
|||
|
|
@ -68,6 +68,18 @@
|
|||
(and (string? m)
|
||||
(cond ((ri-substring? "incorrect number of arguments" m) "ArityException")
|
||||
((ri-substring? "not seqable" m) "IllegalArgumentException")
|
||||
;; Chez's numeric ops raise "~s is not a real number" on a bad
|
||||
;; operand. The JVM throws NullPointerException for a nil operand
|
||||
;; (null deref) and ClassCastException for a non-number (can't
|
||||
;; cast to Number) — clojure.spec.alpha's conform-explain relies
|
||||
;; on the distinction. The offending value rides in the irritants.
|
||||
((or (ri-substring? "is not a real number" m)
|
||||
(ri-substring? "is not a number" m))
|
||||
(if (and (irritants-condition? v)
|
||||
(let loop ((xs (condition-irritants v)))
|
||||
(and (pair? xs) (or (jolt-nil? (car xs)) (loop (cdr xs))))))
|
||||
"NullPointerException"
|
||||
"ClassCastException"))
|
||||
(else #f))))))
|
||||
|
||||
;; instance-check: (type-sym val) — type/protocol membership. Host shims loaded
|
||||
|
|
|
|||
|
|
@ -495,6 +495,43 @@
|
|||
(string-append "Unreadable constructor form: #" tok)
|
||||
(empty-pmap)))))))
|
||||
|
||||
;; #:ns{…} namespaced map literal: a bare keyword/symbol key gets `ns`, a `:_/x`
|
||||
;; key is un-namespaced, an already-qualified key stays. #::{…} uses the current
|
||||
;; ns; #::alias{…} resolves the alias.
|
||||
(define (rdr-nsmap-key mapns k)
|
||||
(cond
|
||||
((keyword? k)
|
||||
(let ((kns (keyword-t-ns k)) (kn (keyword-t-name k)))
|
||||
(cond ((and (string? kns) (string=? kns "_")) (keyword #f kn))
|
||||
(kns k)
|
||||
(else (keyword mapns kn)))))
|
||||
((symbol-t? k)
|
||||
(let ((kns (symbol-t-ns k)) (kn (symbol-t-name k)))
|
||||
(cond ((and (string? kns) (string=? kns "_")) (jolt-symbol #f kn))
|
||||
(kns k)
|
||||
(else (jolt-symbol mapns kn)))))
|
||||
(else k)))
|
||||
(define (rdr-nsmap-kvs mapns es)
|
||||
(cond ((null? es) '())
|
||||
((null? (cdr es)) es)
|
||||
(else (cons (rdr-nsmap-key mapns (car es))
|
||||
(cons (cadr es) (rdr-nsmap-kvs mapns (cddr es)))))))
|
||||
(define (rdr-read-ns-map s i end) ; i points just past "#:"
|
||||
(let* ((auto? (and (< i end) (char=? (string-ref s i) #\:)))
|
||||
(i2 (if auto? (+ i 1) i)))
|
||||
(let loop ((j i2))
|
||||
(cond
|
||||
((>= j end) (jolt-throw (jolt-ex-info "EOF in namespaced map literal" (empty-pmap))))
|
||||
((char=? (string-ref s j) #\{)
|
||||
(let* ((nstok (substring s i2 j))
|
||||
(mapns (if auto?
|
||||
(if (string=? nstok "") (chez-current-ns)
|
||||
(let ((a (chez-resolve-alias (chez-current-ns) nstok))) (if a a nstok)))
|
||||
nstok)))
|
||||
(let-values (((es k) (rdr-read-seq s (+ j 1) end #\})))
|
||||
(values (rdr-make-map (rdr-nsmap-kvs mapns es)) k))))
|
||||
(else (loop (+ j 1)))))))
|
||||
|
||||
(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)))
|
||||
|
|
@ -533,6 +570,8 @@
|
|||
j)))
|
||||
((char=? c #\?) ; #?(...) / #?@(...) reader conditional
|
||||
(rdr-read-reader-cond s (+ i 1) end))
|
||||
((char=? c #\:) ; #:ns{...} namespaced map literal
|
||||
(rdr-read-ns-map s (+ i 1) end))
|
||||
(else ; #tag form -> tagged {:tag :#tag :form ...}
|
||||
(let-values (((tok j) (rdr-read-token s i end)))
|
||||
(let-values (((form k) (rdr-read-form s j end)))
|
||||
|
|
|
|||
|
|
@ -926,6 +926,12 @@
|
|||
;; the protocol short-names it implements (for satisfies?/instance?).
|
||||
(define-record-type jreify (fields methods protos) (nongenerative chez-jreify-v1))
|
||||
(define (reified-methods obj) (and (jreify? obj) (jreify-methods obj)))
|
||||
;; (get reify k) / (:k reify) routes to a reify's ILookup valAt — clojure.spec.alpha
|
||||
;; reifies fspec/regex specs as clojure.lang.ILookup and reads (:args spec) off them.
|
||||
(register-get-arm! jreify?
|
||||
(lambda (coll k d)
|
||||
(let ((m (and (reified-methods coll) (hashtable-ref (reified-methods coll) "valAt" #f))))
|
||||
(if m (jolt-invoke m coll k d) d))))
|
||||
(define (make-reified methods-map . proto-names)
|
||||
(let ((ht (make-hashtable string-hash string=?))
|
||||
(protos (if (and (pair? proto-names) (null? (cdr proto-names)) (jolt-coll-pred? (car proto-names)))
|
||||
|
|
|
|||
|
|
@ -114,7 +114,16 @@
|
|||
;; evaluates to #'ns/name (a first-class var), so (var? (def x 1)) is true and
|
||||
;; (pr-str (def x 1)) is "#'ns/x". The prelude's def-var! forms discard the
|
||||
;; return, so this is transparent there.
|
||||
(define (def-var! ns name v) (let ((c (jolt-var ns name))) (var-cell-root-set! c v) (var-cell-defined?-set! c #t) c))
|
||||
;; proc -> (ns . name) for the var it was def'd into, so (class a-fn) can report a
|
||||
;; JVM-style class name and clojure.spec.alpha's fn-sym can recover the symbol of a
|
||||
;; bare-fn predicate. Weak so GC'd fns drop out. Last def of a given proc wins.
|
||||
(define proc-name-tbl (make-weak-eq-hashtable))
|
||||
(define (def-var! ns name v)
|
||||
;; first def of a given proc wins, so an alias like (def inc' inc) — which binds
|
||||
;; the SAME proc to a second var — doesn't rename inc.
|
||||
(when (and (procedure? v) (not (hashtable-contains? proc-name-tbl v)))
|
||||
(hashtable-set! proc-name-tbl v (cons ns name)))
|
||||
(let ((c (jolt-var ns name))) (var-cell-root-set! c v) (var-cell-defined?-set! c #t) c))
|
||||
;; jolt.host/throwable — build a typed throwable a library can throw so (class …),
|
||||
;; instance?, .getMessage and ex-message all reflect the named JVM class (e.g. an
|
||||
;; http client throwing java.net.ConnectException). Strictly better than a
|
||||
|
|
|
|||
|
|
@ -209,7 +209,7 @@
|
|||
(guard (e (#t #f))
|
||||
(def-var-with-meta! "jolt.backend-scheme" "emit-quoted-map-value" (letrec ((emit-quoted-map-value (lambda (m) (let fnrec7679 ((m m)) (let* ((pairs (jolt-invoke (var-deref "clojure.core" "sort") (let* ((_a$7685 (lambda (k) (let fnrec7680 ((k k)) (let* ((_a$7681 (var-deref "clojure.core" "str")) (_a$7682 (jolt-invoke (var-deref "jolt.backend-scheme" "emit-quoted") k)) (_a$7683 " ") (_a$7684 (jolt-invoke (var-deref "jolt.backend-scheme" "emit-quoted") (jolt-get m k)))) (jolt-invoke _a$7681 _a$7682 _a$7683 _a$7684))))) (_a$7686 (jolt-keys m))) (jolt-map _a$7685 _a$7686))))) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-hash-map " (jolt-invoke (var-deref "clojure.string" "join") " " pairs) ")")))))) emit-quoted-map-value) (let* ((_o$7687 (keyword #f "private")) (_o$7688 #t)) (jolt-hash-map _o$7687 _o$7688))))
|
||||
(guard (e (#t #f))
|
||||
(def-var-with-meta! "jolt.backend-scheme" "emit-quoted" (letrec ((emit-quoted (lambda (form) (let fnrec7689 ((form form)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-char?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-const") form) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-literal?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-const") form) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-sym?") form)) (let* ((m (jolt-invoke (var-deref "jolt.host" "form-sym-meta") form)) (sns (jolt-invoke (var-deref "jolt.host" "form-sym-ns") form)) (nm (jolt-invoke (var-deref "jolt.host" "form-sym-name") form))) (if (jolt-truthy? (let* ((and__25__auto m)) (if (jolt-truthy? and__25__auto) (jolt-pos? (jolt-count m)) and__25__auto))) (let* ((_a$7690 (var-deref "clojure.core" "str")) (_a$7691 "(jolt-symbol/meta ") (_a$7692 (if (jolt-truthy? sns) (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") sns) "#f")) (_a$7693 " ") (_a$7694 (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") nm)) (_a$7695 " ") (_a$7696 (emit-quoted m)) (_a$7697 ")")) (jolt-invoke _a$7690 _a$7691 _a$7692 _a$7693 _a$7694 _a$7695 _a$7696 _a$7697)) (let* ((_a$7698 (var-deref "clojure.core" "str")) (_a$7699 "(jolt-symbol ") (_a$7700 (if (jolt-truthy? sns) (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") sns) "#f")) (_a$7701 " ") (_a$7702 (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") nm)) (_a$7703 ")")) (jolt-invoke _a$7698 _a$7699 _a$7700 _a$7701 _a$7702 _a$7703)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-set?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-hash-set " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-invoke (var-deref "clojure.core" "sort") (jolt-map emit-quoted (jolt-invoke (var-deref "jolt.host" "form-set-items") form)))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-list?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-list " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted (jolt-invoke (var-deref "jolt.host" "form-elements") form))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-vec?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-vector " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted (jolt-invoke (var-deref "jolt.host" "form-vec-items") form))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-map?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-quoted-map") (jolt-invoke (var-deref "jolt.host" "form-map-pairs") form)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-regex?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-regex " (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") (jolt-invoke (var-deref "jolt.host" "form-regex-source") form)) ")") (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "map?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-quoted-map-value") form) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "vector?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-vector " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted form)) ")") (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "set?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-hash-set " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-invoke (var-deref "clojure.core" "sort") (jolt-map emit-quoted form))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "seq?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-list " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted form)) ")") (if (jolt-truthy? (keyword #f "else")) (jolt-throw (let* ((_a$7704 (jolt-invoke (var-deref "clojure.core" "str") "emit-quoted: unsupported quoted form " (jolt-invoke (var-deref "clojure.core" "pr-str") form))) (_a$7705 (jolt-hash-map))) (jolt-ex-info _a$7704 _a$7705))) jolt-nil))))))))))))))))) emit-quoted) (let* ((_o$7706 (keyword #f "private")) (_o$7707 #t)) (jolt-hash-map _o$7706 _o$7707))))
|
||||
(def-var-with-meta! "jolt.backend-scheme" "emit-quoted" (letrec ((emit-quoted (lambda (form) (let fnrec7689 ((form form)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-char?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-const") form) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-literal?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-const") form) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-sym?") form)) (let* ((m (jolt-invoke (var-deref "jolt.host" "form-sym-meta") form)) (sns (jolt-invoke (var-deref "jolt.host" "form-sym-ns") form)) (nm (jolt-invoke (var-deref "jolt.host" "form-sym-name") form))) (if (jolt-truthy? (let* ((and__25__auto m)) (if (jolt-truthy? and__25__auto) (jolt-pos? (jolt-count m)) and__25__auto))) (let* ((_a$7690 (var-deref "clojure.core" "str")) (_a$7691 "(jolt-symbol/meta ") (_a$7692 (if (jolt-truthy? sns) (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") sns) "#f")) (_a$7693 " ") (_a$7694 (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") nm)) (_a$7695 " ") (_a$7696 (emit-quoted m)) (_a$7697 ")")) (jolt-invoke _a$7690 _a$7691 _a$7692 _a$7693 _a$7694 _a$7695 _a$7696 _a$7697)) (let* ((_a$7698 (var-deref "clojure.core" "str")) (_a$7699 "(jolt-symbol ") (_a$7700 (if (jolt-truthy? sns) (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") sns) "#f")) (_a$7701 " ") (_a$7702 (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") nm)) (_a$7703 ")")) (jolt-invoke _a$7698 _a$7699 _a$7700 _a$7701 _a$7702 _a$7703)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-set?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-hash-set " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-invoke (var-deref "clojure.core" "sort") (jolt-map emit-quoted (jolt-invoke (var-deref "jolt.host" "form-set-items") form)))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-list?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-list " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted (jolt-invoke (var-deref "jolt.host" "form-elements") form))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-vec?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-vector " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted (jolt-invoke (var-deref "jolt.host" "form-vec-items") form))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-map?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-quoted-map") (jolt-invoke (var-deref "jolt.host" "form-map-pairs") form)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-regex?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-regex " (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") (jolt-invoke (var-deref "jolt.host" "form-regex-source") form)) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-inst?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-inst-from-string " (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") (jolt-invoke (var-deref "jolt.host" "form-inst-source") form)) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-uuid?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-uuid-from-string " (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") (jolt-invoke (var-deref "jolt.host" "form-uuid-source") form)) ")") (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "map?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-quoted-map-value") form) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "vector?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-vector " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted form)) ")") (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "set?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-hash-set " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-invoke (var-deref "clojure.core" "sort") (jolt-map emit-quoted form))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "seq?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-list " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted form)) ")") (if (jolt-truthy? (keyword #f "else")) (jolt-throw (let* ((_a$7704 (jolt-invoke (var-deref "clojure.core" "str") "emit-quoted: unsupported quoted form " (jolt-invoke (var-deref "clojure.core" "pr-str") form))) (_a$7705 (jolt-hash-map))) (jolt-ex-info _a$7704 _a$7705))) jolt-nil))))))))))))))))))) emit-quoted) (let* ((_o$7706 (keyword #f "private")) (_o$7707 #t)) (jolt-hash-map _o$7706 _o$7707))))
|
||||
(guard (e (#t #f))
|
||||
(def-var-with-meta! "jolt.backend-scheme" "jmeta-nonempty?" (letrec ((jmeta-nonempty? (lambda (m) (let fnrec7708 ((m m)) (let* ((and__25__auto (jolt-invoke (var-deref "clojure.core" "map?") m))) (if (jolt-truthy? and__25__auto) (jolt-pos? (jolt-count m)) and__25__auto)))))) jmeta-nonempty?) (let* ((_o$7709 (keyword #f "private")) (_o$7710 #t)) (jolt-hash-map _o$7709 _o$7710))))
|
||||
(guard (e (#t #f))
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -212,16 +212,16 @@
|
|||
(let* [g (symbol (str (gensym)))
|
||||
gm (symbol (str (gensym)))
|
||||
;; kwargs: a map pattern may bind against the sequential rest
|
||||
;; of a fn — (& {:keys [...]}) — which is a seq of alternating
|
||||
;; k/v args, or a single trailing map. Coerce like Clojure (and
|
||||
;; like the interpreter's destructure-bind, so interpret/compile
|
||||
;; agree): a sequential value with one map element is that map,
|
||||
;; otherwise (apply hash-map). A real map value is used as-is, so
|
||||
;; ordinary map destructuring is unaffected. g holds init once;
|
||||
;; gm is the coerced map every lookup (and :as) reads from.
|
||||
;; of a fn — (& {:keys [...]}) — a seq of alternating k/v args,
|
||||
;; optionally with a trailing map (Clojure 1.11: (f :a 1 {:b 2})
|
||||
;; merges the map over the pairs; (f {:a 1}) is just the map).
|
||||
;; An odd count means the last arg is that trailing map. A real
|
||||
;; map value is used as-is, so ordinary map destructuring is
|
||||
;; unaffected. g holds init once; gm is the coerced map every
|
||||
;; lookup (and :as) reads from.
|
||||
coerce `(if (sequential? ~g)
|
||||
(if (and (= 1 (count ~g)) (map? (first ~g)))
|
||||
(first ~g)
|
||||
(if (odd? (count ~g))
|
||||
(merge (apply hash-map (butlast ~g)) (last ~g))
|
||||
(apply hash-map ~g))
|
||||
~g)
|
||||
or-map (get pat :or)
|
||||
|
|
|
|||
|
|
@ -12,7 +12,8 @@
|
|||
form-list? form-vec? form-map? form-set? form-char?
|
||||
form-literal? form-elements form-vec-items
|
||||
form-map-pairs form-set-items form-char-code
|
||||
form-regex? form-regex-source]]))
|
||||
form-regex? form-regex-source
|
||||
form-inst? form-inst-source form-uuid? form-uuid-source]]))
|
||||
|
||||
;; Hot clojure.core primitives lowered to native Scheme.
|
||||
;; `=` is the exactness-aware jolt= from values.ss; inc/dec/
|
||||
|
|
@ -335,6 +336,11 @@
|
|||
(form-map? form) (emit-quoted-map (form-map-pairs form))
|
||||
;; a quoted #"…" regex value -> reconstruct it (same as the :regex IR leaf).
|
||||
(form-regex? form) (str "(jolt-regex " (chez-str-lit (form-regex-source form)) ")")
|
||||
;; quoted #inst / #uuid literals construct their value, like the JVM reader
|
||||
;; (which builds the Date/UUID at read time, so a quoted/macro form carries the
|
||||
;; value, not the raw tagged form). Same emit as the :inst / :uuid IR leaves.
|
||||
(form-inst? form) (str "(jolt-inst-from-string " (chez-str-lit (form-inst-source form)) ")")
|
||||
(form-uuid? form) (str "(jolt-uuid-from-string " (chez-str-lit (form-uuid-source form)) ")")
|
||||
;; plain jolt VALUES (metadata maps and anything nested in them)
|
||||
(map? form) (emit-quoted-map-value form)
|
||||
(vector? form) (str "(jolt-vector " (str/join " " (map emit-quoted form)) ")")
|
||||
|
|
|
|||
|
|
@ -1,4 +1,8 @@
|
|||
[
|
||||
{:suite "host-interop / reify ILookup" :label "(get reify k) / (:k reify) / (get reify k d) route to valAt" :expected "[1 1 :dflt]" :actual "(let [r (reify clojure.lang.ILookup (valAt [_ k] (get {:a 1} k)) (valAt [_ k d] (get {:a 1} k d)))] [(:a r) (get r :a) (get r :z :dflt)])"}
|
||||
{:suite "numbers / comparison error class" :label "nil operand is NPE, non-number is CCE" :expected "[\"java.lang.NullPointerException\" \"java.lang.ClassCastException\"]" :actual "[(try (> nil 5) (catch Throwable e (.getName (class e)))) (try (> :k 5) (catch Throwable e (.getName (class e))))]"}
|
||||
{:suite "reader / quoted #inst constructs a value" :label "a quoted #inst literal is the constructed Date, not a tagged form" :expected "\"(f #inst \\\"1939-01-01T00:00:00.000-00:00\\\")\"" :actual "(pr-str (quote (f #inst \"1939\")))"}
|
||||
{:suite "fn / kwargs trailing map" :label "(f :k v {map}) and (f {map}) both bind & {:as m}" :expected "[{:x 1 :y 2} {:x 1 :y 2}]" :actual "[((fn [a & {:as m}] m) 1 :x 1 {:y 2}) ((fn [a & {:as m}] m) 1 {:x 1 :y 2})]"}
|
||||
{:suite "destructure / :or" :label "map default when key absent" :expected "9" :actual "(let [{x :x :or {x 9}} {}] x)"}
|
||||
{:suite "destructure / :or" :label "kwargs default when key absent" :expected "9" :actual "((fn [& {x :x :or {x 9}}] x))"}
|
||||
{:suite "destructure / :or" :label "default not used when key present" :expected "5" :actual "(let [{x :x :or {x 9}} {:x 5}] x)"}
|
||||
|
|
@ -3386,4 +3390,8 @@
|
|||
{:suite "seq / take infinite count" :label "(take +Infinity coll) takes the whole coll" :expected "7" :actual "(count (take (/ 1.0 0.0) (range 7)))"}
|
||||
{:suite "host-interop / UUID + Long + shiftLeft" :label "(UUID. msb lsb), .shiftLeft, (Long. n)" :expected "[\"00000000-0000-007b-0000-0000000001c8\" 40 10 42]" :actual "[(str (java.util.UUID. 123 456)) (.shiftLeft 5 3) (.shiftRight 40 2) (Long. 42)]"}
|
||||
{:suite "host-interop / ThreadLocal proxy" :label "(proxy [ThreadLocal] [] (initialValue [] v)) get/set" :expected "[42 7]" :actual "(let [tl (proxy [ThreadLocal] [] (initialValue [] 42))] [(.get tl) (do (.set tl 7) (.get tl))])"}
|
||||
{:suite "host-interop / Compiler/demunge" :label "demunge reverses name munging" :expected "\"a/b?\"" :actual "(clojure.lang.Compiler/demunge \"a$b_QMARK_\")"}
|
||||
{:suite "host-interop / a fn reports its munged class" :label "(class a-def'd-fn) is ns$munged-name, with the IFn hierarchy as ancestors" :expected "[\"clojure.core$odd_QMARK_\" true]" :actual "[(.getName (class odd?)) (boolean (some #{java.lang.Runnable} (ancestors (class odd?))))]"}
|
||||
{:suite "host-interop / MultiFn methods" :label ".getMethod / .dispatchFn on a multimethod" :expected "[true true true]" :actual "(do (defmulti mmc identity) (defmethod mmc :a [_] 1) [(some? (.getMethod mmc :a)) (nil? (.getMethod mmc :z)) (ifn? (.dispatchFn mmc))])"}
|
||||
{:suite "reader / namespaced map literal" :label "#:ns{...} qualifies bare keys; :_/x stays unqualified" :expected "[:search 2 nil]" :actual "[(:event/type #:event{:type :search :id 5}) (count #:x{:a 1 :b 2}) (:k #:_{:k 9})]"}
|
||||
]
|
||||
|
|
|
|||
|
|
@ -479,7 +479,7 @@
|
|||
{:suite "type" :expr "(type (filter odd? [1 2 3]))" :expected "clojure.lang.PersistentList"}
|
||||
{:suite "type" :expr "(type (lazy-seq (cons 1 nil)))" :expected "clojure.lang.LazySeq"}
|
||||
{:suite "type" :expr "(type (take 2 (iterate inc 0)))" :expected "clojure.lang.PersistentList"}
|
||||
{:suite "type" :expr "(type inc)" :expected "clojure.lang.IFn"}
|
||||
{:suite "type" :expr "(type inc)" :expected "clojure.core$inc"}
|
||||
{:suite "type" :expr "(type (sorted-map :a 1))" :expected ":map"}
|
||||
{:suite "type" :expr "(type (sorted-set 1))" :expected ":jolt/sorted-set"}
|
||||
{:suite "type" :expr "(type (with-meta [1] {:type :custom}))" :expected ":custom"}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue