simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Compiler fixes surfaced porting the examples to Chez

Browse source 
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 2026-06-22 02:06:05 -04:00
parent 0d4f84e1f2
commit 85cec65937
3 changed files with 88 additions and 27 deletions
Download patch file Download diff file Expand all files Collapse all files

27
host/chez/reader.ss
View file

@ -285,17 +285,24 @@
new)) new))
(define (rdr-attach-meta target meta) (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) (make-symbol-t (symbol-t-ns target) (symbol-t-name target)
(rdr-merge-meta (symbol-t-meta target) meta)) (rdr-merge-meta (symbol-t-meta target) meta)))
;; non-symbol target (a collection): lower to a runtime (with-meta form meta) ;; A LIST form is code: ^Type (expr) is a compile-time hint on the FORM, not a
;; the analyzer compiles like any invoke, so e.g. ;; runtime operation. Attach the metadata to the form itself (so a quoted list
;; (meta ^{:tag :int} [1 2]) and ^:foo {} carry their meta at runtime. The meta ;; keeps it and the analyzer can read :tag) — never lower to a runtime
;; pmap doubles as its own map-literal form. Use the BARE `with-meta` symbol ;; (with-meta (expr) meta), which would mis-apply the hint to the call's RESULT
;; (ns #f) — the fn/defn macros unwrap a ;; and throw when that result is a string/number (e.g. ^String (to-str x)).
;; (with-meta <arglist-vec> _) return-hint by matching the unqualified head, ;; Matches Clojure: a tag hint on an evaluated form is discarded at runtime.
;; so a qualified clojure.core/with-meta would slip past them (^bytes [b]). ((cseq? target) (jolt-with-meta target meta))
(jolt-list (jolt-symbol #f "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 ------------------------------------------------------------- ;; --- # dispatch -------------------------------------------------------------
;; #(...) anonymous fn shorthand (jolt-qjr0): % -> p1, %N -> pN, %& -> rest. The ;; #(...) anonymous fn shorthand (jolt-qjr0): % -> p1, %N -> pN, %& -> rest. The

48
host/chez/records.ss
View file

@ -132,11 +132,13 @@
;; host type-tag candidates for a non-record value (extend-protocol on builtins). ;; host type-tag candidates for a non-record value (extend-protocol on builtins).
(define (value-host-tags obj) (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")) ((string? obj) '("String" "CharSequence" "Object"))
((boolean? obj) '("Boolean" "Object")) ((boolean? obj) '("Boolean" "Object"))
((keyword? obj) '("Keyword" "Object")) ((keyword? obj) '("Keyword" "Named" "Object"))
((jolt-symbol? obj) '("Symbol" "Object")) ((jolt-symbol? obj) '("Symbol" "Named" "Object"))
((pvec? obj) '("PersistentVector" "IPersistentVector" "IPersistentCollection" ((pvec? obj) '("PersistentVector" "IPersistentVector" "IPersistentCollection"
"List" "java.util.List" "Sequential" "Collection" "Object")) "List" "java.util.List" "Sequential" "Collection" "Object"))
((pmap? obj) '("PersistentArrayMap" "IPersistentMap" "Associative" ((pmap? obj) '("PersistentArrayMap" "IPersistentMap" "Associative"
@ -152,13 +154,19 @@
;; make-deftype-ctor: (name-sym field-kws field-tags field-muts) -> ctor closure. ;; 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). ;; The tag is baked at definition time in the type's ns (chez-current-ns).
(define (make-deftype-ctor name-sym field-kws . _ignored) (define (make-deftype-ctor name-sym field-kws . _ignored)
(let ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym))) (let* ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym)))
(kws (seq->list field-kws))) (kws (seq->list field-kws))
(lambda args (ctor (lambda args
(make-jrec tag (let loop ((ks kws) (as args) (acc '())) (make-jrec tag (let loop ((ks kws) (as args) (acc '()))
(if (null? ks) (reverse acc) (if (null? ks) (reverse acc)
(loop (cdr ks) (if (null? as) '() (cdr as)) (loop (cdr ks) (if (null? as) '() (cdr as))
(cons (cons (car ks) (if (null? as) jolt-nil (car as))) acc)))))))) (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). ;; make-protocol: a protocol value the overlay reads via (get p :name)/(get p :methods).
(define (make-protocol name-str methods) (define (make-protocol name-str methods)
@ -174,17 +182,23 @@
(define host-type-set (define host-type-set
(let ((h (make-hashtable string-hash string=?))) (let ((h (make-hashtable string-hash string=?)))
(for-each (lambda (n) (hashtable-set! h n #t)) (for-each (lambda (n) (hashtable-set! h n #t))
'("Long" "Integer" "Number" "Double" "String" "CharSequence" "Boolean" '("Long" "Integer" "Number" "Double" "Ratio" "BigInt" "BigInteger"
"Keyword" "Symbol" "Object" "nil" "PersistentVector" "IPersistentVector" "String" "CharSequence" "Boolean" "Character"
"Keyword" "Symbol" "Named" "Object" "nil"
"PersistentVector" "IPersistentVector"
"PersistentArrayMap" "IPersistentMap" "PersistentHashSet" "IPersistentSet" "PersistentArrayMap" "IPersistentMap" "PersistentHashSet" "IPersistentSet"
"ISeq" "IPersistentCollection" "Associative" "Sequential" "ISeq" "IPersistentCollection" "Associative" "Sequential"
"Map" "java.util.Map" "List" "java.util.List" "Set" "java.util.Set" "Map" "java.util.Map" "List" "java.util.List" "Set" "java.util.Set"
"Collection" "java.util.Collection")) "Collection" "java.util.Collection"))
h)) 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) (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))) (let ((base (or (strip-prefix type-name "java.lang.")
((and (> (string-length type-name) 10) (string=? (substring type-name 0 10) "java.util.")) (substring type-name 10 (string-length type-name))) (strip-prefix type-name "java.util.")
(else type-name)))) (strip-prefix type-name "clojure.lang.")
type-name)))
(and (hashtable-ref host-type-set base #f) base))) (and (hashtable-ref host-type-set base #f) base)))
;; An extend/extend-type/extend-protocol registration marks the tag as an ;; 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 ;; 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 ;; dot-dispatch fallback used by emit for (.method record args): find the method
;; in ANY protocol the record's type implements. ;; 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) (define (record-method-dispatch obj method-name rest-args)
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args)))) (let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
(cond (cond
@ -240,6 +258,14 @@
;; java.lang.String interop (jolt-nfca): defined in natives-str.ss, loaded ;; java.lang.String interop (jolt-nfca): defined in natives-str.ss, loaded
;; after this file (free reference, resolved at call time). ;; after this file (free reference, resolved at call time).
((string? obj) (jolt-string-method method-name obj rest)) ((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")))))) (else (error #f (string-append "No method " method-name " for value"))))))
;; reify: instance-local method table. obj is a jreify carrying a method ht + ;; reify: instance-local method table. obj is a jreify carrying a method ht +

30
host/chez/regex.ss
View file

@ -89,10 +89,38 @@
(write-char c out) (loop (fx+ i 1) #f)) (write-char c out) (loop (fx+ i 1) #f))
(else (write-char c out) (loop (fx+ i 1) in-class)))))))) (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 ;; A jolt regex value: the source string (for printing / str) + the compiled
;; irregex. regex? recognizes it; the printer renders #"source". ;; irregex. regex? recognizes it; the printer renders #"source".
(define-record-type regex-t (fields source irx) (nongenerative jolt-regex-v1)) (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-regex? x) (regex-t? x))
(define (jolt-re-pattern x) (if (regex-t? x) x (jolt-regex x))) (define (jolt-re-pattern x) (if (regex-t? x) x (jolt-regex x)))