Add Gerbil v0.19 compatibility: spinlock, list ops, alist/plist ops
ober
427f1aad428ecc1a403c1dc93346cf02ec97e9c8
--- a/lib/jerboa/prelude.sls +++ b/lib/jerboa/prelude.sls @@ -49,6 +49,13 @@ ;; ---- std/sugar ---- chain chain-and assert! + unwind-protect with-id with-lock with-catch + cut cute <> <...> + awhen aif when-let if-let + -> ->> as-> some-> some->> cond-> cond->> + ->? ->>? + with-resource str alist defn defrecord + let-alist define-enum capture dotimes define-values ;; ---- std/text/json ---- read-json write-json json-object->string string->json-object @@ -71,12 +78,35 @@ filter-map group-by zip + ;; Gerbil v0.19 compat + append-map append1 flatten1 + push! pop! + for-each! + take-while take-until drop-while drop-until + butlast slice split + length=? length<? length<=? length>? length>=? + length=n? length<n? length<=n? length>n? length>=n? + group-consecutive group-n-consecutive group-same + rassoc every-consecutive? + map/car first-and-only when/list + with-list-builder call-with-list-builder + duplicates delete-duplicates/hash ;; ---- std/misc/alist ---- agetq agetv aget asetq! asetv! aset! pgetq pgetv pget alist->hash-table + ;; Gerbil v0.19 compat + alist? acons + asetq asetv aset + aremq aremv arem + aremq! aremv! arem! + psetq psetv pset + psetq! psetv! pset! + premq premv prem + premq! premv! prem! + plist->alist* alist->plist* ;; ---- std/misc/ports ---- read-all-as-string read-all-as-lines @@ -95,7 +125,8 @@ printf fprintf path-extension path-absolute? with-input-from-string with-output-to-string - iota 1+ 1-) + iota 1+ 1- + partition) (only (jerboa core) def def* defrule defrules defstruct defclass defmethod @@ -112,9 +143,15 @@ (std format) (except (std error) error-message error-irritants error-trace error? with-exception-handler) - (except (std sugar) try catch finally while until - hash-literal hash-eq-literal let-hash - defrule defrules) + (only (std sugar) + assert! chain chain-and + unwind-protect with-id with-lock with-catch + cut cute <> <...> + awhen aif when-let if-let + -> ->> as-> some-> some->> cond-> cond->> + ->? ->>? + with-resource str alist defn defrecord + let-alist define-enum capture dotimes define-values) (std text json) (std os path) (std misc string) --- a/lib/std/misc/alist.sls +++ b/lib/std/misc/alist.sls @@ -5,7 +5,17 @@ (export agetq agetv aget asetq! asetv! aset! pgetq pgetv pget - alist->hash-table) + alist->hash-table + ;; Gerbil v0.19 compatibility + alist? acons + asetq asetv aset ; pure functional set + aremq aremv arem ; pure remove + aremq! aremv! arem! ; destructive remove + psetq psetv pset ; pure plist set + psetq! psetv! pset! ; destructive plist set + premq premv prem ; pure plist remove + premq! premv! prem! ; destructive plist remove + plist->alist* alist->plist*) (import (except (chezscheme) make-hash-table hash-table? iota 1+ 1-) (jerboa runtime)) @@ -81,4 +91,193 @@ (for-each (lambda (p) (hash-put! ht (car p) (cdr p))) alist) ht)) + ;; ---- Gerbil v0.19 compatibility ---- + + ;; alist? predicate: proper list of pairs + (define (alist? obj) + (let loop ((lst obj)) + (cond + ((null? lst) #t) + ((and (pair? lst) (pair? (car lst))) + (loop (cdr lst))) + (else #f)))) + + ;; acons: prepend a key-value pair + (define (acons key val alist) + (cons (cons key val) alist)) + + ;; Pure functional alist set (returns new alist, replaces existing key) + (define (asetq key val alist) + (%aset eq? key val alist)) + + (define (asetv key val alist) + (%aset eqv? key val alist)) + + (define (aset key val alist) + (%aset equal? key val alist)) + + (define (%aset cmp key val alist) + (let loop ((rest alist) (acc '())) + (cond + ((null? rest) + (cons (cons key val) alist)) ; not found, prepend + ((cmp (caar rest) key) + (append (reverse acc) (cons (cons key val) (cdr rest)))) + (else + (loop (cdr rest) (cons (car rest) acc)))))) + + ;; Pure alist remove (returns new alist without key) + (define (aremq key alist) + (%arem eq? key alist)) + + (define (aremv key alist) + (%arem eqv? key alist)) + + (define (arem key alist) + (%arem equal? key alist)) + + (define (%arem cmp key alist) + (let loop ((rest alist) (acc '())) + (cond + ((null? rest) alist) ; not found, return original + ((cmp (caar rest) key) + (append (reverse acc) (cdr rest))) + (else + (loop (cdr rest) (cons (car rest) acc)))))) + + ;; Destructive alist remove + (define (aremq! key alist) + (%arem! eq? key alist)) + + (define (aremv! key alist) + (%arem! eqv? key alist)) + + (define (arem! key alist) + (%arem! equal? key alist)) + + (define (%arem! cmp key alist) + (cond + ((null? alist) alist) + ((cmp (caar alist) key) (cdr alist)) + (else + (let loop ((prev alist) (rest (cdr alist))) + (cond + ((null? rest) alist) + ((cmp (caar rest) key) + (set-cdr! prev (cdr rest)) + alist) + (else (loop rest (cdr rest)))))))) + + ;; Pure plist set (with comparison variants) + (define (psetq key val plist) + (%pset eq? key val plist)) + + (define (psetv key val plist) + (%pset eqv? key val plist)) + + (define (pset key val plist) + (%pset equal? key val plist)) + + (define (%pset cmp key val plist) + (let loop ((rest plist) (acc '())) + (cond + ((null? rest) + (append (reverse acc) (list key val))) ; not found, append + ((and (pair? (cdr rest)) (cmp (car rest) key)) + (append (reverse acc) (cons key (cons val (cddr rest))))) + ((pair? (cdr rest)) + (loop (cddr rest) (cons (cadr rest) (cons (car rest) acc)))) + (else + (append (reverse acc) (list key val)))))) + + ;; Destructive plist set + (define (psetq! key val plist) + (%pset! eq? key val plist)) + + (define (psetv! key val plist) + (%pset! eqv? key val plist)) + + (define (pset! key val plist) + (%pset! equal? key val plist)) + + (define (%pset! cmp key val plist) + (let loop ((rest plist)) + (cond + ((null? rest) + (error '%pset! "cannot destructively set on empty plist" key val)) + ((and (pair? (cdr rest)) (cmp (car rest) key)) + (set-car! (cdr rest) val) + plist) + ((pair? (cdr rest)) + (loop (cddr rest))) + (else + ;; Key not found — prepend by mutation + (let ((old-key (car plist)) + (old-rest (cdr plist))) + (set-car! plist key) + (set-cdr! plist (cons val (cons old-key old-rest))) + plist))))) + + ;; Pure plist remove + (define (premq key plist) + (%prem eq? key plist)) + + (define (premv key plist) + (%prem eqv? key plist)) + + (define (prem key plist) + (%prem equal? key plist)) + + (define (%prem cmp key plist) + (let loop ((rest plist) (acc '())) + (cond + ((null? rest) plist) ; not found + ((and (pair? (cdr rest)) (cmp (car rest) key)) + (append (reverse acc) (cddr rest))) + ((pair? (cdr rest)) + (loop (cddr rest) (cons (cadr rest) (cons (car rest) acc)))) + (else plist)))) + + ;; Destructive plist remove + (define (premq! key plist) + (%prem! eq? key plist)) + + (define (premv! key plist) + (%prem! eqv? key plist)) + + (define (prem! key plist) + (%prem! equal? key plist)) + + (define (%prem! cmp key plist) + (cond + ((null? plist) plist) + ((and (pair? (cdr plist)) (cmp (car plist) key)) + (cddr plist)) ; remove head pair + (else + (let loop ((prev plist) (rest (cddr plist))) + (cond + ((null? rest) plist) + ((and (pair? (cdr rest)) (cmp (car rest) key)) + (set-cdr! (cdr prev) (cddr rest)) + plist) + ((pair? (cdr rest)) + (loop (cdr rest) (cddr rest))) + (else plist)))))) + + ;; plist->alist conversion (any key type, uses comparison) + (define (plist->alist* plist) + (let loop ((rest plist) (acc '())) + (if (or (null? rest) (null? (cdr rest))) + (reverse acc) + (loop (cddr rest) + (cons (cons (car rest) (cadr rest)) acc))))) + + ;; alist->plist conversion + (define (alist->plist* alist) + (let loop ((rest alist) (acc '())) + (if (null? rest) + (reverse acc) + (loop (cdr rest) + (cons (cdar rest) (cons (caar rest) acc)))))) + ) ;; end library --- a/lib/std/misc/list.sls +++ b/lib/std/misc/list.sls @@ -19,7 +19,28 @@ iterate-n reductions take-last drop-last - split-at split-with) + split-at split-with + ;; Gerbil v0.19 compatibility + append-map append1 + flatten1 + push! pop! + for-each! + take-while take-until + drop-while drop-until + butlast + slice + split + length=? length<? length<=? length>? length>=? + length=n? length<n? length<=n? length>n? length>=n? + group-consecutive group-n-consecutive group-same + rassoc + every-consecutive? + map/car + first-and-only + when/list + call-with-list-builder with-list-builder + duplicates + delete-duplicates/hash) (import (except (chezscheme) partition)) (define (flatten lst) @@ -221,4 +242,302 @@ (loop (cdr rest) (cons (car rest) acc))] [else (list (reverse acc) rest)]))) + ;; ---- Gerbil v0.19 compatibility ---- + + ;; append-map: map then append (same as mapcat, Gerbil name) + (define (append-map proc lst) + (apply append (map proc lst))) + + ;; append1: append one element at end (same as snoc, Gerbil name) + (define (append1 lst x) (append lst (list x))) + + ;; flatten1: remove one layer of nesting + ;; (flatten1 '(1 (2 3) ((4)))) => (1 2 3 (4)) + (define (flatten1 lst) + (let loop ((rest lst) (acc '())) + (cond + ((null? rest) (reverse acc)) + ((pair? (car rest)) + (loop (cdr rest) (fold-left (lambda (a x) (cons x a)) acc (car rest)))) + (else + (loop (cdr rest) (cons (car rest) acc)))))) + + ;; push!/pop! macros — CL-style mutation + (define-syntax push! + (lambda (stx) + (syntax-case stx () + ((_ elem lst) + #'(set! lst (cons elem lst)))))) + + (define-syntax pop! + (lambda (stx) + (syntax-case stx () + ((_ lst) + #'(let ((l lst)) + (and (pair? l) + (let ((v (car l))) + (set! lst (cdr l)) + v))))))) + + ;; for-each! — like for-each but works on improper lists + (define (for-each! lst proc) + (let loop ((rest lst)) + (when (pair? rest) + (proc (car rest)) + (loop (cdr rest))))) + + ;; take-while / take-until + (define (take-while pred lst) + (let loop ((rest lst) (acc '())) + (cond + ((null? rest) (reverse acc)) + ((pred (car rest)) + (loop (cdr rest) (cons (car rest) acc))) + (else (reverse acc))))) + + (define (take-until pred lst) + (take-while (lambda (x) (not (pred x))) lst)) + + ;; drop-while / drop-until + (define (drop-while pred lst) + (let loop ((rest lst)) + (cond + ((null? rest) '()) + ((pred (car rest)) (loop (cdr rest))) + (else rest)))) + + (define (drop-until pred lst) + (drop-while (lambda (x) (not (pred x))) lst)) + + ;; butlast: all but the last element + ;; (butlast '(1 2 3)) => (1 2) + (define (butlast lst) + (if (or (null? lst) (null? (cdr lst))) '() + (cons (car lst) (butlast (cdr lst))))) + + ;; slice: sublist from start with optional limit + ;; (slice '(1 2 3 4) 2) => (3 4) + ;; (slice '(1 2 3 4) 2 1) => (3) + (define slice + (case-lambda + ((lst start) (drop lst start)) + ((lst start limit) (take (drop lst start) limit)))) + + ;; split: split list by value or predicate, with optional limit + ;; (split '(1 2 0 3 4 0 5 6) 0) => ((1 2) (3 4) (5 6)) + ;; (split '(1 2 0 3 4 0 5 6) 0 1) => ((1 2) (3 4 0 5 6)) + (define split + (case-lambda + ((lst stop) (split lst stop #f)) + ((lst stop limit) + (let ((test (if (procedure? stop) stop (lambda (x) (equal? x stop))))) + (let loop ((rest lst) (current '()) (n (or limit -1))) + (cond + ((null? rest) + (if (null? current) '() + (list (reverse current)))) + ((zero? n) + (list (append (reverse current) rest))) + ((test (car rest)) + (cons (reverse current) + (loop (cdr rest) '() (- n 1)))) + (else + (loop (cdr rest) (cons (car rest) current) n)))))))) + + ;; Efficient length comparisons (no full traversal needed) + (define (length=? x y) + (let loop ((x x) (y y)) + (let ((nx (not (pair? x))) + (ny (not (pair? y)))) + (cond + (nx ny) + (ny #f) + (else (loop (cdr x) (cdr y))))))) + + (define (length<? x y) + (let loop ((x x) (y y)) + (let ((nx (not (pair? x))) + (ny (not (pair? y)))) + (cond + (nx (not ny)) + (ny #f) + (else (loop (cdr x) (cdr y))))))) + + (define (length<=? x y) (not (length<? y x))) + (define (length>? x y) (length<? y x)) + (define (length>=? x y) (not (length<? x y))) + + (define (length=n? x n) + (and (fixnum? n) (fx>= n 0) + (let loop ((x x) (n n)) + (cond + ((not (pair? x)) (fxzero? n)) + ((fxzero? n) #f) + (else (loop (cdr x) (fx- n 1))))))) + + (define (length<=n? x n) + (and (fixnum? n) (fx>= n 0) + (let loop ((x x) (n n)) + (cond + ((not (pair? x)) #t) + ((fxzero? n) #f) + (else (loop (cdr x) (fx- n 1))))))) + + (define (length<n? x n) + (and (fixnum? n) (fxpositive? n) + (length<=n? x (fx- n 1)))) + + (define (length>n? x n) (not (length<=n? x n))) + (define (length>=n? x n) (not (length<n? x n))) + + ;; group-consecutive: group runs of equal elements + ;; (group-consecutive '(1 1 2 2 3 1 1)) => ((1 1) (2 2) (3) (1 1)) + (define group-consecutive + (case-lambda + ((lst) (group-consecutive lst equal?)) + ((lst test) + (if (null? lst) '() + (let loop ((rest (cdr lst)) + (latest (car lst)) + (inner (list (car lst))) + (outer '())) + (cond + ((null? rest) + (reverse (cons (reverse inner) outer))) + ((test latest (car rest)) + (loop (cdr rest) (car rest) (cons (car rest) inner) outer)) + (else + (loop (cdr rest) (car rest) (list (car rest)) + (cons (reverse inner) outer))))))))) + + ;; group-n-consecutive: group into chunks of n + ;; (group-n-consecutive 2 '(1 2 3 4 5)) => ((1 2) (3 4) (5)) + (define (group-n-consecutive n lst) + (cond + ((null? lst) '()) + ((length<=n? lst n) (list lst)) + (else + (let-values (((hd tl) (let loop ((l lst) (i n) (acc '())) + (if (or (fxzero? i) (null? l)) + (values (reverse acc) l) + (loop (cdr l) (fx- i 1) (cons (car l) acc)))))) + (cons hd (group-n-consecutive n tl)))))) + + ;; group-same: group by key function into sublists + ;; (group-same '(1 2 3 4) key: odd?) => ((1 3) (2 4)) + (define group-same + (case-lambda + ((lst) (group-same lst values)) + ((lst key) + (let ((ht (make-hashtable equal-hash equal?)) + (order '())) + (for-each + (lambda (x) + (let* ((k (key x)) + (prev (hashtable-ref ht k #f))) + (if prev + (hashtable-set! ht k (cons x prev)) + (begin + (hashtable-set! ht k (list x)) + (set! order (cons k order)))))) + lst) + (map (lambda (k) (reverse (hashtable-ref ht k '()))) + (reverse order)))))) + + ;; rassoc: reverse assoc — find pair by cdr + ;; (rassoc 2 '((a . 1) (b . 2))) => (b . 2) + (define rassoc + (case-lambda + ((x alist) (rassoc x alist eqv?)) + ((x alist cmp) + (let loop ((lst alist)) + (cond + ((null? lst) #f) + ((and (pair? (car lst)) (cmp x (cdar lst))) + (car lst)) + (else (loop (cdr lst)))))))) + + ;; every-consecutive?: pairwise predicate check + ;; (every-consecutive? < '(1 2 3 4)) => #t + (define (every-consecutive? pred lst) + (or (null? lst) + (let loop ((x (car lst)) (rest (cdr lst))) + (cond + ((null? rest) #t) + ((pred x (car rest)) + (loop (car rest) (cdr rest))) + (else #f))))) + + ;; map/car: apply f to car of a pair + ;; (map/car add1 '(1 . 2)) => (2 . 2) + (define (map/car f p) + (cons (f (car p)) (cdr p))) + + ;; first-and-only: assert exactly one element + (define (first-and-only lst) + (unless (and (pair? lst) (null? (cdr lst))) + (error 'first-and-only "expected single-element list" lst)) + (car lst)) + + ;; when/list: like when but returns '() instead of void when false + (define-syntax when/list + (lambda (stx) + (syntax-case stx () + ((_ test body ...) + #'(if test (begin body ...) '()))))) + + ;; with-list-builder / call-with-list-builder + ;; Efficient tail-cons list building + (define-syntax with-list-builder + (lambda (stx) + (syntax-case stx () + ((_ (c) body ...) + #'(let* ((head (list #f)) + (tail head)) + (define (c val) + (let ((new-tail (list val))) + (set-cdr! tail new-tail) + (set! tail new-tail))) + body ... + (cdr head)))))) + + (define (call-with-list-builder proc) + (with-list-builder (c) (proc c))) + + ;; duplicates: elements appearing more than once with counts + ;; (duplicates '(a b a c b a)) => ((a . 3) (b . 2)) + (define duplicates + (case-lambda + ((lst) (duplicates lst equal?)) + ((lst test) + (if (null? lst) '() + (let ((ht (make-hashtable + (if (eq? test eq?) symbol-hash equal-hash) + test))) + (for-each (lambda (x) + (hashtable-update! ht x (lambda (n) (+ n 1)) 0)) + lst) + (let-values (((keys vals) (hashtable-entries ht))) + (let loop ((i 0) (acc '())) + (if (= i (vector-length keys)) acc + (loop (+ i 1) + (if (> (vector-ref vals i) 1) + (cons (cons (vector-ref keys i) (vector-ref vals i)) acc) + acc)))))))))) + + ;; delete-duplicates/hash: O(n) deduplication using hash table + (define delete-duplicates/hash + (case-lambda + ((lst) (delete-duplicates/hash lst equal?)) + ((lst test) + (let ((ht (make-hashtable + (if (eq? test eq?) symbol-hash equal-hash) + test))) + (with-list-builder (c) + (for-each (lambda (x) + (unless (hashtable-contains? ht x) + (hashtable-set! ht x #t) + (c x))) + lst)))))) + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/spinlock.sls @@ -0,0 +1,59 @@ +#!chezscheme +;;; (std misc spinlock) -- CAS-based spin locks +;;; +;;; Ported from Gerbil v0.19 (vyzo). Uses Chez box-cas! instead of +;;; Gambit ##vector-cas!. Suitable for very short critical sections +;;; where mutex overhead is undesirable (e.g., object caches). + +(library (std misc spinlock) + (export make-spinlock spinlock? spin-lock! spin-unlock! with-spinlock) + (import (chezscheme)) + + ;; Internal record — constructor is %make-spinlock + (define-record-type (%spinlock %make-spinlock spinlock?) + (nongenerative spinlock-8f3a2b1c) + (sealed #t) + (fields (immutable lock) ; box: #f or owner-thread-id + (immutable max-spin))) ; fixnum + + (define make-spinlock + (case-lambda + (() (%make-spinlock (box #f) 10)) + ((max-spin) (%make-spinlock (box #f) max-spin)))) + + (define (spin-lock! lock) + (let ((lk (%spinlock-lock lock)) + (max-spin (%spinlock-max-spin lock)) + (me (get-thread-id))) + (let again ((spin 0)) + (cond + ((box-cas! lk #f me) + (void)) ; acquired + ((fx< spin max-spin) + (again (fx+ spin 1))) + (else + ;; Deadlock check: if we own it, error + (let ((owner (unbox lk))) + (when (eqv? owner me) + (error 'spin-lock! "deadlock: current thread already holds spinlock" lock))) + (sleep (make-time 'time-duration 0 0)) + (again 0)))))) + + (define (spin-unlock! lock) + (set-box! (%spinlock-lock lock) #f)) + + ;; Macro: acquire, run body, release (even on exception). + (define-syntax with-spinlock + (lambda (stx) + (syntax-case stx () + ((_ lock expr) + #'(let ((lk lock)) + (spin-lock! lk) + (let ((result (guard (e (else (spin-unlock! lk) (raise e))) + expr))) + (spin-unlock! lk) + result))) + ((_ lock expr rest ...) + #'(with-spinlock lock (begin expr rest ...)))))) + +) ;; end library --- a/lib/std/repl.sls +++ b/lib/std/repl.sls @@ -92,7 +92,7 @@ repl-history-ref) (import (except (chezscheme) cpu-time box?) - (std misc list)) + (except (std misc list) partition)) ;;; ========== REPL Configuration ========== (define-record-type repl-config @@ -1505,12 +1505,11 @@ (install-history-bindings! env) ;; Make repl-history-ref available in env - (eval '(define repl-history-ref #f) env) - (eval `(set! repl-history-ref ,repl-history-ref) env) + (define-top-level-value 'repl-history-ref repl-history-ref env) ;; Welcome banner (display (c-bold cfg "Jerboa REPL")) - (display (c-dim cfg (format " v1.0 [Chez Scheme ~a]" (scheme-version)))) + (display (c-dim cfg (format " v1.0 [~a]" (scheme-version)))) (newline) (display (c-dim cfg " Type ,help for commands, ,quit to exit\n")) (display (c-dim cfg " Results stored as $1, $2, ... and *, **, ***\n"))