Compiler fixes surfaced porting the examples to Chez
Four runtime/reader gaps that blocked real libraries (hiccup, commonmark):
- reader: a type hint on a code form (^String (to-str x)) was lowered to a
runtime (with-meta (to-str x) {:tag String}), mis-applying the hint to the
call's RESULT and throwing when it's a string/number. A :tag hint on an
evaluated form is compile-time only in Clojure — attach it to the form
instead. Collection literals (^:foo [1 2 3]) still get runtime metadata.
- deftype: register the ctor globally by simple class name (like StringBuilder)
so (Name. ...) interop resolves ns-agnostically. host-new resolved the ctor
against the runtime current ns, which is the caller's, not the defining ns,
once a deftype is used across files.
- protocol dispatch: canonical-host-tag now strips the clojure.lang. prefix too
(clojure.lang.Keyword -> Keyword), and keywords/symbols carry the Named tag,
numbers a Ratio tag. An (extend-protocol P clojure.lang.Keyword ...) was
missing the dispatch, so e.g. hiccup rendered <:html> instead of <html>.
- regex: parse leading Java inline flags ((?s)/(?i)/(?m)) and pass the
equivalent irregex options (single-line/case-insensitive/multi-line); irregex
rejects the inline syntax. Adds a java.util.Iterator shim ((.iterator coll)/
.hasNext/.next) for the run!-style loop hiccup compiles.
This commit is contained in:
Yogthos
parent
0d4f84e1f2
commit
85cec65937
3 changed files with 88 additions and 27 deletions
|
|
@ -285,17 +285,24 @@
|
|||
new))
|
||||
|
||||
(define (rdr-attach-meta target meta)
|
||||
(if (symbol-t? target)
|
||||
(cond
|
||||
((symbol-t? target)
|
||||
(make-symbol-t (symbol-t-ns target) (symbol-t-name target)
|
||||
(rdr-merge-meta (symbol-t-meta target) meta))
|
||||
;; non-symbol target (a collection): lower to a runtime (with-meta form meta)
|
||||
;; the analyzer compiles like any invoke, so e.g.
|
||||
;; (meta ^{:tag :int} [1 2]) and ^:foo {} carry their meta at runtime. The meta
|
||||
;; pmap doubles as its own map-literal form. Use the BARE `with-meta` symbol
|
||||
;; (ns #f) — the fn/defn macros unwrap a
|
||||
;; (with-meta <arglist-vec> _) return-hint by matching the unqualified head,
|
||||
;; so a qualified clojure.core/with-meta would slip past them (^bytes [b]).
|
||||
(jolt-list (jolt-symbol #f "with-meta") target meta)))
|
||||
(rdr-merge-meta (symbol-t-meta target) meta)))
|
||||
;; A LIST form is code: ^Type (expr) is a compile-time hint on the FORM, not a
|
||||
;; runtime operation. Attach the metadata to the form itself (so a quoted list
|
||||
;; keeps it and the analyzer can read :tag) — never lower to a runtime
|
||||
;; (with-meta (expr) meta), which would mis-apply the hint to the call's RESULT
|
||||
;; and throw when that result is a string/number (e.g. ^String (to-str x)).
|
||||
;; Matches Clojure: a tag hint on an evaluated form is discarded at runtime.
|
||||
((cseq? target) (jolt-with-meta target meta))
|
||||
((empty-list-t? target) target)
|
||||
;; A vector/map/set LITERAL: Clojure attaches the metadata to the runtime value
|
||||
;; ((meta ^{:tag :int} [1 2]) / ^:foo {}), so lower to a runtime (with-meta form
|
||||
;; meta). Use the BARE `with-meta` symbol (ns #f) — the fn/defn macros unwrap a
|
||||
;; (with-meta <arglist-vec> _) return-hint by matching the unqualified head, so a
|
||||
;; qualified clojure.core/with-meta would slip past them (^bytes [b]).
|
||||
(else (jolt-list (jolt-symbol #f "with-meta") target meta))))
|
||||
|
||||
;; --- # dispatch -------------------------------------------------------------
|
||||
;; #(...) anonymous fn shorthand (jolt-qjr0): % -> p1, %N -> pN, %& -> rest. The
|
||||
|
|
|
|||
|
|
@ -132,11 +132,13 @@
|
|||
|
||||
;; host type-tag candidates for a non-record value (extend-protocol on builtins).
|
||||
(define (value-host-tags obj)
|
||||
(cond ((number? obj) '("Long" "Integer" "Number" "Double" "Object"))
|
||||
(cond ((and (number? obj) (and (exact? obj) (not (integer? obj))))
|
||||
'("Ratio" "Number" "Object"))
|
||||
((number? obj) '("Long" "Integer" "Number" "Double" "Object"))
|
||||
((string? obj) '("String" "CharSequence" "Object"))
|
||||
((boolean? obj) '("Boolean" "Object"))
|
||||
((keyword? obj) '("Keyword" "Object"))
|
||||
((jolt-symbol? obj) '("Symbol" "Object"))
|
||||
((keyword? obj) '("Keyword" "Named" "Object"))
|
||||
((jolt-symbol? obj) '("Symbol" "Named" "Object"))
|
||||
((pvec? obj) '("PersistentVector" "IPersistentVector" "IPersistentCollection"
|
||||
"List" "java.util.List" "Sequential" "Collection" "Object"))
|
||||
((pmap? obj) '("PersistentArrayMap" "IPersistentMap" "Associative"
|
||||
|
|
@ -152,13 +154,19 @@
|
|||
;; make-deftype-ctor: (name-sym field-kws field-tags field-muts) -> ctor closure.
|
||||
;; The tag is baked at definition time in the type's ns (chez-current-ns).
|
||||
(define (make-deftype-ctor name-sym field-kws . _ignored)
|
||||
(let ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym)))
|
||||
(kws (seq->list field-kws)))
|
||||
(lambda args
|
||||
(let* ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym)))
|
||||
(kws (seq->list field-kws))
|
||||
(ctor (lambda args
|
||||
(make-jrec tag (let loop ((ks kws) (as args) (acc '()))
|
||||
(if (null? ks) (reverse acc)
|
||||
(loop (cdr ks) (if (null? as) '() (cdr as))
|
||||
(cons (cons (car ks) (if (null? as) jolt-nil (car as))) acc))))))))
|
||||
;; Register the ctor globally by simple class name (like StringBuilder) so
|
||||
;; (Name. …) interop resolves ns-agnostically: a deftype used across files works
|
||||
;; even when the runtime current ns is the caller's, not the defining ns
|
||||
;; (host-new checks class-ctors-tbl before the current-ns var fallback).
|
||||
(register-class-ctor! (symbol-t-name name-sym) ctor)
|
||||
ctor))
|
||||
|
||||
;; make-protocol: a protocol value the overlay reads via (get p :name)/(get p :methods).
|
||||
(define (make-protocol name-str methods)
|
||||
|
|
@ -174,17 +182,23 @@
|
|||
(define host-type-set
|
||||
(let ((h (make-hashtable string-hash string=?)))
|
||||
(for-each (lambda (n) (hashtable-set! h n #t))
|
||||
'("Long" "Integer" "Number" "Double" "String" "CharSequence" "Boolean"
|
||||
"Keyword" "Symbol" "Object" "nil" "PersistentVector" "IPersistentVector"
|
||||
'("Long" "Integer" "Number" "Double" "Ratio" "BigInt" "BigInteger"
|
||||
"String" "CharSequence" "Boolean" "Character"
|
||||
"Keyword" "Symbol" "Named" "Object" "nil"
|
||||
"PersistentVector" "IPersistentVector"
|
||||
"PersistentArrayMap" "IPersistentMap" "PersistentHashSet" "IPersistentSet"
|
||||
"ISeq" "IPersistentCollection" "Associative" "Sequential"
|
||||
"Map" "java.util.Map" "List" "java.util.List" "Set" "java.util.Set"
|
||||
"Collection" "java.util.Collection"))
|
||||
h))
|
||||
(define (strip-prefix s p)
|
||||
(let ((pl (string-length p)))
|
||||
(and (> (string-length s) pl) (string=? (substring s 0 pl) p) (substring s pl (string-length s)))))
|
||||
(define (canonical-host-tag type-name)
|
||||
(let ((base (cond ((and (> (string-length type-name) 10) (string=? (substring type-name 0 10) "java.lang.")) (substring type-name 10 (string-length type-name)))
|
||||
((and (> (string-length type-name) 10) (string=? (substring type-name 0 10) "java.util.")) (substring type-name 10 (string-length type-name)))
|
||||
(else type-name))))
|
||||
(let ((base (or (strip-prefix type-name "java.lang.")
|
||||
(strip-prefix type-name "java.util.")
|
||||
(strip-prefix type-name "clojure.lang.")
|
||||
type-name)))
|
||||
(and (hashtable-ref host-type-set base #f) base)))
|
||||
;; An extend/extend-type/extend-protocol registration marks the tag as an
|
||||
;; extender of the protocol (recorded inside type-registry so the per-case prune
|
||||
|
|
@ -229,6 +243,10 @@
|
|||
|
||||
;; dot-dispatch fallback used by emit for (.method record args): find the method
|
||||
;; in ANY protocol the record's type implements.
|
||||
;; java.util.Iterator over a jolt seqable: (.iterator coll) returns a jiterator
|
||||
;; holding a mutable cursor over (seq coll); (.hasNext it)/(.next it) walk it.
|
||||
;; hiccup/compiler's run! loop iterates collections this way.
|
||||
(define-record-type jiterator (fields (mutable cur)) (nongenerative jolt-iterator-v1))
|
||||
(define (record-method-dispatch obj method-name rest-args)
|
||||
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
|
||||
(cond
|
||||
|
|
@ -240,6 +258,14 @@
|
|||
;; java.lang.String interop (jolt-nfca): defined in natives-str.ss, loaded
|
||||
;; after this file (free reference, resolved at call time).
|
||||
((string? obj) (jolt-string-method method-name obj rest))
|
||||
((jiterator? obj)
|
||||
(cond ((string=? method-name "hasNext") (not (jolt-nil? (jolt-seq (jiterator-cur obj)))))
|
||||
((string=? method-name "next")
|
||||
(let ((s (jolt-seq (jiterator-cur obj))))
|
||||
(if (jolt-nil? s) (error #f "iterator exhausted")
|
||||
(let ((v (jolt-first s))) (jiterator-cur-set! obj (jolt-rest s)) v))))
|
||||
(else (error #f (string-append "No method " method-name " on Iterator")))))
|
||||
((string=? method-name "iterator") (make-jiterator (jolt-seq obj)))
|
||||
(else (error #f (string-append "No method " method-name " for value"))))))
|
||||
|
||||
;; reify: instance-local method table. obj is a jreify carrying a method ht +
|
||||
|
|
|
|||
|
|
@ -89,10 +89,38 @@
|
|||
(write-char c out) (loop (fx+ i 1) #f))
|
||||
(else (write-char c out) (loop (fx+ i 1) in-class))))))))
|
||||
|
||||
;; Java/Clojure inline flags: a leading (?imsx…) group sets a flag over the whole
|
||||
;; pattern. irregex has the same semantics but as constructor OPTIONS, not inline
|
||||
;; syntax (it rejects (?s)/(?s:…)), so peel any leading flag groups off the source
|
||||
;; and pass the equivalent option symbols. Scoped groups ((?:…), (?=…), (?<n>…))
|
||||
;; and groups with a flag irregex can't express are left untouched for irregex.
|
||||
(define (regex-flag->opt c)
|
||||
(cond ((char=? c #\s) 'single-line) ; DOTALL — . matches newline
|
||||
((char=? c #\i) 'case-insensitive)
|
||||
((char=? c #\m) 'multi-line) ; ^/$ match at line boundaries
|
||||
(else #f)))
|
||||
(define (regex-parse-flags src)
|
||||
(let loop ((s src) (opts '()))
|
||||
(if (and (>= (string-length s) 4)
|
||||
(char=? (string-ref s 0) #\() (char=? (string-ref s 1) #\?))
|
||||
(let scan ((i 2) (fs '()))
|
||||
(cond
|
||||
((>= i (string-length s)) (values (reverse opts) s))
|
||||
((char=? (string-ref s i) #\))
|
||||
(let ((mapped (map regex-flag->opt fs)))
|
||||
(if (and (pair? fs) (for-all (lambda (x) x) mapped))
|
||||
(loop (substring s (+ i 1) (string-length s)) (append opts mapped))
|
||||
(values (reverse opts) s)))) ; unmappable flag — leave as-is
|
||||
((char=? (string-ref s i) #\:) (values (reverse opts) s)) ; scoped group
|
||||
(else (scan (+ i 1) (cons (string-ref s i) fs)))))
|
||||
(values (reverse opts) s))))
|
||||
|
||||
;; A jolt regex value: the source string (for printing / str) + the compiled
|
||||
;; irregex. regex? recognizes it; the printer renders #"source".
|
||||
(define-record-type regex-t (fields source irx) (nongenerative jolt-regex-v1))
|
||||
(define (jolt-regex source) (make-regex-t source (irregex (translate-prop-classes source))))
|
||||
(define (jolt-regex source)
|
||||
(let-values (((opts pat) (regex-parse-flags source)))
|
||||
(make-regex-t source (apply irregex (translate-prop-classes pat) opts))))
|
||||
(define (jolt-regex? x) (regex-t? x))
|
||||
(define (jolt-re-pattern x) (if (regex-t? x) x (jolt-regex x)))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue