JVM-semantics fixes and small cleanups

- take-last / drop-last return seqs, not vectors: take-last wraps in seq; drop-last
  is the JVM (map (fn [x _] x) coll (drop n coll)) form (lazy, () when empty).
- cycle is lazy ((lazy-seq (concat coll (cycle coll)))) so it no longer counts its
  argument and terminates on a lazy/infinite input.
- fold's foldable-call catch uses :default, matching the rest of jolt-core and
  also catching a raw host condition from a folding primitive.
- alts! rejects non-channel ports with a clear error (put specs / :default are
  unsupported) instead of crashing inside ac-poll!.
- Misc: drop the unreachable second getCause clause; jolt-nth on a string raises
  'nth "index out of bounds" like the vector branch; name the inline fixpoint cap;
  bld-sh-capture rejoins lines with newlines; clarify a couple of comments.
This commit is contained in:
Yogthos 2026-06-23 01:36:51 -04:00
parent 524d4cd8d1
commit 14547bd1d5
11 changed files with 642 additions and 616 deletions

View file

@ -152,11 +152,19 @@
(else ac-poll-empty)))) (else ac-poll-empty))))
;; (alts! [ch ...]) — take from whichever channel is ready first; returns ;; (alts! [ch ...]) — take from whichever channel is ready first; returns
;; [value channel] (value nil if that channel closed). Take-only. ;; [value channel] (value nil if that channel closed). Take-only: every port must
;; be a channel — put specs [ch val] and the :default option are not supported, so
;; reject them with a clear error instead of crashing inside ac-poll!.
;; Polls with a 1ms backoff — no cross-channel wait-set yet. ;; Polls with a 1ms backoff — no cross-channel wait-set yet.
(define ac-1ms (make-time 'time-duration 1000000 0)) (define ac-1ms (make-time 'time-duration 1000000 0))
(define (jolt-async-alts chans) (define (jolt-async-alts chans)
(let ((cs (seq->list (jolt-seq chans)))) (let ((cs (seq->list (jolt-seq chans))))
(for-each (lambda (c)
(unless (async-chan? c)
(jolt-throw (jolt-ex-info
"alts! supports channel ports only (put specs [ch val] and :default are not supported)"
(jolt-hash-map)))))
cs)
(let loop () (let loop ()
(let try ((rest cs)) (let try ((rest cs))
(if (null? rest) (if (null? rest)

View file

@ -27,9 +27,12 @@
(let ((l (get-line in))) (let ((l (get-line in)))
(if (eof-object? l) (if (eof-object? l)
(begin (close-port in) (begin (close-port in)
(let ((s (apply string-append (reverse acc)))) ;; rejoin with newlines (get-line stripped them). Callers use
;; trim a trailing newline-equivalent (we joined without them) ;; single-line output; this just avoids silently concatenating
s)) ;; two lines into one corrupt token if a command emits more.
(let ((ls (reverse acc)))
(if (null? ls) ""
(fold-left (lambda (s x) (string-append s "\n" x)) (car ls) (cdr ls)))))
(loop (cons l acc))))))) (loop (cons l acc)))))))
(define (bld-system cmd) (define (bld-system cmd)

View file

@ -243,7 +243,8 @@
(cond ((pvec? coll) (let ((v (pvec-v coll))) (cond ((pvec? coll) (let ((v (pvec-v coll)))
(if (and (fx>=? i 0) (fx<? i (vector-length v))) (vector-ref v i) (if (and (fx>=? i 0) (fx<? i (vector-length v))) (vector-ref v i)
(error 'nth "index out of bounds")))) (error 'nth "index out of bounds"))))
((string? coll) (string-ref coll i)) ((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i)
(error 'nth "index out of bounds")))
((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #f jolt-nil)) ((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #f jolt-nil))
(else (error 'nth "unsupported collection"))))) (else (error 'nth "unsupported collection")))))
((coll i d) ((coll i d)

View file

@ -174,7 +174,9 @@
(keyword #f "name") (jolt-symbol jolt-nil name-str) (keyword #f "name") (jolt-symbol jolt-nil name-str)
(keyword #f "methods") methods)) (keyword #f "methods") methods))
;; register-protocol-methods!: a no-op for Chez dispatch. ;; register-protocol-methods!: intentional no-op. Chez dispatches a protocol method
;; by the receiver's type tag at call time, so there is no method table to register;
;; this binding exists only because defprotocol-emitted code calls it.
(define (register-protocol-methods! proto-name method-names) jolt-nil) (define (register-protocol-methods! proto-name method-names) jolt-nil)
;; register-method: extend-type/extend register an impl. Host type names keep a ;; register-method: extend-type/extend register an impl. Host type names keep a
@ -329,7 +331,7 @@
((string=? method-name "toString") (condition->message-string obj)) ((string=? method-name "toString") (condition->message-string obj))
((string=? method-name "getCause") jolt-nil) ((string=? method-name "getCause") jolt-nil)
;; java.sql.SQLException chaining — jolt errors don't chain (nil). ;; java.sql.SQLException chaining — jolt errors don't chain (nil).
((or (string=? method-name "getNextException") (string=? method-name "getCause")) jolt-nil) ((string=? method-name "getNextException") jolt-nil)
((string=? method-name "getStackTrace") (jolt-vector)) ((string=? method-name "getStackTrace") (jolt-vector))
((string=? method-name "printStackTrace") jolt-nil) ((string=? method-name "printStackTrace") jolt-nil)
(else (error #f (string-append "No method " method-name " on Throwable"))))) (else (error #f (string-append "No method " method-name " on Throwable")))))

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

View file

@ -188,13 +188,15 @@
(defn replicate [n x] (map (fn [_] x) (range n))) (defn replicate [n x] (map (fn [_] x) (range n)))
;; Returns a seq (JVM does), nil when n<=0 or coll is empty.
(defn take-last [n coll] (defn take-last [n coll]
(let [c (vec coll) len (count c)] (let [c (vec coll) len (count c)]
(when (pos? len) (subvec c (max 0 (- len n)))))) (when (pos? len) (seq (subvec c (max 0 (- len n)))))))
;; The JVM definition: a lazy seq (() when empty), not a vector.
(defn drop-last (defn drop-last
([coll] (drop-last 1 coll)) ([coll] (drop-last 1 coll))
([n coll] (let [c (vec coll)] (subvec c 0 (max 0 (- (count c) n)))))) ([n coll] (map (fn [x _] x) coll (drop n coll))))
(defn distinct? (defn distinct?
([x] true) ([x] true)

View file

@ -76,13 +76,11 @@
(mapi 0 coll)))) (mapi 0 coll))))
;; --- cycle --- ;; --- cycle ---
;; Lazy, like the JVM: never counts coll, so it terminates on a lazy/infinite
;; argument instead of forcing it.
(defn cycle [coll] (defn cycle [coll]
(if-let [vals (seq coll)] (if (seq coll)
(let [n (count vals)] (lazy-seq (concat coll (cycle coll)))
(letfn [(cstep [i]
(lazy-seq
(cons (nth vals (mod i n)) (cstep (inc i)))))]
(cstep 0)))
())) ()))
;; --- repeatedly --- ((f) throws on a non-fn; (take n …) throws on a non-number ;; --- repeatedly --- ((f) throws on a non-fn; (take n …) throws on a non-number

View file

@ -32,6 +32,10 @@
(declare analyze) (declare analyze)
;; Special forms analyze-special has a dispatch arm for — the subset of the host
;; contract's reserved words (jolt.host/form-special?) the analyzer lowers itself.
;; The two differ deliberately (e.g. interop heads like `new`/`.` are reserved but
;; analyzed in analyze-list), so keep them in sync by intent, not by equality.
(def ^:private handled (def ^:private handled
#{"quote" "if" "do" "def" "fn*" "let*" "loop*" "recur" "throw" "try" #{"quote" "if" "do" "def" "fn*" "let*" "loop*" "recur" "throw" "try"
"syntax-quote" "var" "letfn" "set!" "defmacro"}) "syntax-quote" "var" "letfn" "set!" "defmacro"})

View file

@ -23,6 +23,10 @@
reset-escapes! collected-escapes reset-escapes! collected-escapes
set-check-mode! take-diags!]])) set-check-mode! take-diags!]]))
;; Cap on inline -> flatten -> scalar-replace -> const-fold iterations. Each pass
;; sets `dirty` when it rewrote something; the loop stops at a clean pass or here.
(def ^:private inline-fixpoint-cap 8)
(defn run-passes (defn run-passes
"All passes, in order. The back end applies this to every analyzed form. When "All passes, in order. The back end applies this to every analyzed form. When
inlining is enabled for the unit (user code under direct-linking), inlining is enabled for the unit (user code under direct-linking),
@ -41,7 +45,7 @@
opt (loop [i 0 n (const-fold node)] opt (loop [i 0 n (const-fold node)]
(reset! dirty false) (reset! dirty false)
(let [n2 (const-fold (scalar-replace (flatten-lets (inline-node n ctx))))] (let [n2 (const-fold (scalar-replace (flatten-lets (inline-node n ctx))))]
(if (and @dirty (< i 8)) (if (and @dirty (< i inline-fixpoint-cap))
(recur (inc i) n2) (recur (inc i) n2)
n2)))] n2)))]
;; a final const-fold after inference propagates any predicate folded to a ;; a final const-fold after inference propagates any predicate folded to a

View file

@ -46,7 +46,9 @@
folded (when (and ff (pos? (count args)) (every? const-num? args)) folded (when (and ff (pos? (count args)) (every? const-num? args))
(try (try
{:op :const :val (apply ff (mapv (fn [a] (get a :val)) args))} {:op :const :val (apply ff (mapv (fn [a] (get a :val)) args))}
(catch Exception e nil)))] ;; :default (not Exception) — match the rest of jolt-core and
;; also catch a raw host condition from a folding primitive.
(catch :default e nil)))]
(or folded n)) (or folded n))
(= op :if) (= op :if)