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:
parent
524d4cd8d1
commit
14547bd1d5
11 changed files with 642 additions and 616 deletions
|
|
@ -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)
|
||||||
|
|
|
||||||
|
|
@ -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)
|
||||||
|
|
|
||||||
|
|
@ -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)
|
||||||
|
|
|
||||||
|
|
@ -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
|
|
@ -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)
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
|
|
@ -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"})
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
|
|
@ -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)
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue