defstruct: support inheritance via parent-rtd, migrate deque + chaperone
ober
44238ed3bbb05d6b1ed123f04ea96d951b33fad7
--- a/lib/jerboa/core.sls +++ b/lib/jerboa/core.sls @@ -430,6 +430,8 @@ (with-syntax ([tid (datum->syntax #'name type-id)] [mid (datum->syntax #'name make-id)] [pid (datum->syntax #'name pred-id)] + [rcd-id (datum->syntax #'name + (string->symbol (string-append ns "-rcd")))] [(acc ...) (datum->syntax #'name accs)] [(mut ...) (datum->syntax #'name muts)] [(idx ...) (datum->syntax #'name @@ -440,14 +442,15 @@ (gensym (symbol->string name-sym)))]) #'(begin (define-record-type (hidden-name mid pid) - (sealed #t) (fields (mutable field iacc imut) ...)) (define tid (record-type-descriptor hidden-name)) + (define rcd-id (record-constructor-descriptor hidden-name)) (define acc iacc) ... (define mut imut) ...)))))] [(_ (name parent) (field ...)) (and (identifier? #'name) (identifier? #'parent)) (let* ([name-sym (syntax->datum #'name)] + [parent-sym (syntax->datum #'parent)] [fields-list (syntax->datum #'(field ...))] [ns (symbol->string name-sym)]) (let-values ([(type-id make-id pred-id accs muts) @@ -461,6 +464,14 @@ (with-syntax ([tid (datum->syntax #'name type-id)] [mid (datum->syntax #'name make-id)] [pid (datum->syntax #'name pred-id)] + [rcd-id (datum->syntax #'name + (string->symbol (string-append ns "-rcd")))] + [parent-tid (datum->syntax #'parent + (string->symbol + (string-append (symbol->string parent-sym) "::t")))] + [parent-rcd-id (datum->syntax #'parent + (string->symbol + (string-append (symbol->string parent-sym) "-rcd")))] [(acc ...) (datum->syntax #'name accs)] [(mut ...) (datum->syntax #'name muts)] [(idx ...) (datum->syntax #'name @@ -471,9 +482,10 @@ (gensym (symbol->string name-sym)))]) #'(begin (define-record-type (hidden-name mid pid) - (parent parent) + (parent-rtd parent-tid parent-rcd-id) (fields (mutable field iacc imut) ...)) (define tid (record-type-descriptor hidden-name)) + (define rcd-id (record-constructor-descriptor hidden-name)) (define acc iacc) ... (define mut imut) ...)))))] ;; Keyword options: warn about unsupported ones, handle what we can. deleted file mode 100644 --- a/lib/std/misc/chaperone.sls +++ /dev/null @@ -1,278 +0,0 @@ -#!chezscheme -;;; (std misc chaperone) — Impersonators/chaperones (contract proxies) -;;; -;;; Transparent proxies that intercept operations on values. -;;; Chaperones enforce contracts via interceptors; impersonators can freely transform. -;;; -;;; (chaperone-procedure proc args-interceptor result-interceptor) -;;; (impersonate-procedure proc args-interceptor result-interceptor) -;;; (chaperone-vector vec ref-interceptor set-interceptor) -;;; (chaperone-hashtable ht ref-interceptor set-interceptor delete-interceptor) -;;; (chaperone? v) — is v a chaperone/impersonator? -;;; (chaperone-of? v1 v2) — is v1 a chaperone wrapping v2 (directly or transitively)? - -(library (std misc chaperone) - (export chaperone-procedure - impersonate-procedure - chaperone-vector - chaperone-hashtable - chaperone? - chaperone-of? - chaperone-vector-ref - chaperone-vector-set! - chaperone-hashtable-ref - chaperone-hashtable-set! - chaperone-hashtable-delete! - chaperone-unwrap) - (import (chezscheme)) - - ;; --------------------------------------------------------------- - ;; Core record types - ;; --------------------------------------------------------------- - - ;; Base record type for all chaperones/impersonators - (define-record-type chaperone-base - (fields - (immutable inner) ; the wrapped value (or another chaperone) - (immutable kind))) ; symbol: procedure, vector, hashtable - - ;; Procedure chaperone/impersonator - (define-record-type procedure-chaperone - (parent chaperone-base) - (fields - (immutable args-interceptor) ; #f or (lambda args -> args-list) - (immutable result-interceptor) ; #f or (lambda results -> results-list) - (immutable impersonator?) ; #t if impersonator - (mutable wrapper))) ; the lambda returned to the user - - ;; Vector chaperone - (define-record-type vector-chaperone - (parent chaperone-base) - (fields - (immutable ref-interceptor) ; #f or (lambda (vec idx val) -> val) - (immutable set-interceptor))) ; #f or (lambda (vec idx val) -> val) - - ;; Hashtable chaperone - (define-record-type hashtable-chaperone - (parent chaperone-base) - (fields - (immutable ref-interceptor) ; #f or (lambda (ht key val) -> val) - (immutable set-interceptor) ; #f or (lambda (ht key val) -> val) - (immutable delete-interceptor))) ; #f or (lambda (ht key) -> key) - - ;; --------------------------------------------------------------- - ;; Mapping from wrapper procedures back to their chaperone records - ;; --------------------------------------------------------------- - - ;; We use an eq-hashtable with weak keys so that GC can collect - ;; wrapper procedures that are no longer referenced. - (define *proc-chaperone-table* - (make-weak-eq-hashtable)) - - (define (register-proc-chaperone! wrapper chap) - (hashtable-set! *proc-chaperone-table* wrapper chap)) - - (define (lookup-proc-chaperone wrapper) - (hashtable-ref *proc-chaperone-table* wrapper #f)) - - ;; --------------------------------------------------------------- - ;; Unwrap — get the innermost (non-chaperone) value - ;; --------------------------------------------------------------- - - (define (chaperone-unwrap v) - (cond - [(chaperone-base? v) - (chaperone-unwrap (chaperone-base-inner v))] - [(and (procedure? v) (lookup-proc-chaperone v)) - => (lambda (chap) (chaperone-unwrap (chaperone-base-inner chap)))] - [else v])) - - ;; --------------------------------------------------------------- - ;; Resolve — get the chaperone record for any chaperoned value - ;; --------------------------------------------------------------- - - (define (resolve-chaperone v) - (cond - [(chaperone-base? v) v] - [(and (procedure? v) (lookup-proc-chaperone v)) - => (lambda (chap) chap)] - [else #f])) - - ;; --------------------------------------------------------------- - ;; Predicates - ;; --------------------------------------------------------------- - - (define (chaperone? v) - (or (chaperone-base? v) - (and (procedure? v) (lookup-proc-chaperone v) #t))) - - ;; Is v1 a chaperone of v2? (directly or transitively) - (define (chaperone-of? v1 v2) - (let ([c1 (resolve-chaperone v1)]) - (and c1 - (let ([inner (chaperone-base-inner c1)]) - (or (eq? inner v2) - ;; For procedure chaperones, the inner might be a wrapper proc - (and (procedure-chaperone? c1) - (procedure-chaperone-wrapper c1) - ;; inner is the original proc or another wrapper - #f) - ;; Check if both unwrap to the same base value - (let ([c2 (resolve-chaperone v2)]) - (and c2 - (eq? (chaperone-unwrap v1) (chaperone-unwrap v2)))) - ;; Check transitively - (chaperone-of? inner v2)))))) - - ;; --------------------------------------------------------------- - ;; Procedure chaperones/impersonators - ;; --------------------------------------------------------------- - - (define (call-through-chain chap args) - ;; Walk the chain: intercept args at each layer, call base proc, intercept results - ;; We collect interceptors in outside-in order, then apply them. - (let loop ([c chap] [current-args args] [result-interceptors '()]) - (let ([intercepted-args - (if (procedure-chaperone-args-interceptor c) - (apply (procedure-chaperone-args-interceptor c) current-args) - current-args)] - [ri (if (procedure-chaperone-result-interceptor c) - (cons (procedure-chaperone-result-interceptor c) result-interceptors) - result-interceptors)]) - (let ([inner (chaperone-base-inner c)]) - (let ([inner-chap (resolve-chaperone inner)]) - (if (and inner-chap (procedure-chaperone? inner-chap)) - ;; Inner is also a procedure chaperone, continue chain - (loop inner-chap intercepted-args ri) - ;; Inner is the base procedure - (let ([results (call-with-values - (lambda () (apply inner intercepted-args)) - list)]) - ;; Apply result interceptors innermost-first (reverse of collection order) - (let apply-results ([rs ri] [vals results]) - (if (null? rs) - (apply values vals) - (apply-results - (cdr rs) - (apply (car rs) vals))))))))))) - - (define chaperone-procedure - (case-lambda - [(proc args-interceptor result-interceptor) - (unless (procedure? (chaperone-unwrap proc)) - (error 'chaperone-procedure "expected a procedure" proc)) - (let* ([chap (make-procedure-chaperone - proc 'procedure - args-interceptor result-interceptor #f #f)] - [wrapper (lambda args - (call-through-chain chap args))]) - (procedure-chaperone-wrapper-set! chap wrapper) - (register-proc-chaperone! wrapper chap) - wrapper)] - [(proc args-interceptor) - (chaperone-procedure proc args-interceptor #f)])) - - (define impersonate-procedure - (case-lambda - [(proc args-interceptor result-interceptor) - (unless (procedure? (chaperone-unwrap proc)) - (error 'impersonate-procedure "expected a procedure" proc)) - (let* ([chap (make-procedure-chaperone - proc 'procedure - args-interceptor result-interceptor #t #f)] - [wrapper (lambda args - (call-through-chain chap args))]) - (procedure-chaperone-wrapper-set! chap wrapper) - (register-proc-chaperone! wrapper chap) - wrapper)] - [(proc args-interceptor) - (impersonate-procedure proc args-interceptor #f)])) - - ;; --------------------------------------------------------------- - ;; Vector chaperones - ;; --------------------------------------------------------------- - - (define chaperone-vector - (case-lambda - [(vec ref-interceptor set-interceptor) - (unless (vector? (chaperone-unwrap vec)) - (error 'chaperone-vector "expected a vector" vec)) - (make-vector-chaperone vec 'vector ref-interceptor set-interceptor)] - [(vec ref-interceptor) - (chaperone-vector vec ref-interceptor #f)])) - - (define (chaperone-vector-ref cv idx) - (if (vector-chaperone? cv) - (let* ([inner (chaperone-base-inner cv)] - [raw-val (if (vector-chaperone? inner) - (chaperone-vector-ref inner idx) - (vector-ref inner idx))]) - (if (vector-chaperone-ref-interceptor cv) - ((vector-chaperone-ref-interceptor cv) cv idx raw-val) - raw-val)) - (vector-ref cv idx))) - - (define (chaperone-vector-set! cv idx val) - (if (vector-chaperone? cv) - (let* ([intercepted-val - (if (vector-chaperone-set-interceptor cv) - ((vector-chaperone-set-interceptor cv) cv idx val) - val)] - [inner (chaperone-base-inner cv)]) - (if (vector-chaperone? inner) - (chaperone-vector-set! inner idx intercepted-val) - (vector-set! inner idx intercepted-val))) - (vector-set! cv idx val))) - - ;; --------------------------------------------------------------- - ;; Hashtable chaperones - ;; --------------------------------------------------------------- - - (define chaperone-hashtable - (case-lambda - [(ht ref-interceptor set-interceptor delete-interceptor) - (unless (hashtable? (chaperone-unwrap ht)) - (error 'chaperone-hashtable "expected a hashtable" ht)) - (make-hashtable-chaperone - ht 'hashtable ref-interceptor set-interceptor delete-interceptor)] - [(ht ref-interceptor set-interceptor) - (chaperone-hashtable ht ref-interceptor set-interceptor #f)] - [(ht ref-interceptor) - (chaperone-hashtable ht ref-interceptor #f #f)])) - - (define (chaperone-hashtable-ref ch key default) - (if (hashtable-chaperone? ch) - (let* ([inner (chaperone-base-inner ch)] - [raw-val (if (hashtable-chaperone? inner) - (chaperone-hashtable-ref inner key default) - (hashtable-ref inner key default))]) - (if (hashtable-chaperone-ref-interceptor ch) - ((hashtable-chaperone-ref-interceptor ch) ch key raw-val) - raw-val)) - (hashtable-ref ch key default))) - - (define (chaperone-hashtable-set! ch key val) - (if (hashtable-chaperone? ch) - (let* ([intercepted-val - (if (hashtable-chaperone-set-interceptor ch) - ((hashtable-chaperone-set-interceptor ch) ch key val) - val)] - [inner (chaperone-base-inner ch)]) - (if (hashtable-chaperone? inner) - (chaperone-hashtable-set! inner key intercepted-val) - (hashtable-set! inner key intercepted-val))) - (hashtable-set! ch key val))) - - (define (chaperone-hashtable-delete! ch key) - (if (hashtable-chaperone? ch) - (let* ([intercepted-key - (if (hashtable-chaperone-delete-interceptor ch) - ((hashtable-chaperone-delete-interceptor ch) ch key) - key)] - [inner (chaperone-base-inner ch)]) - (if (hashtable-chaperone? inner) - (chaperone-hashtable-delete! inner intercepted-key) - (hashtable-delete! inner intercepted-key))) - (hashtable-delete! ch key))) - -) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/chaperone.ss @@ -0,0 +1,207 @@ +;;; (std misc chaperone) — Impersonators/chaperones (contract proxies) +;;; +;;; Transparent proxies that intercept operations on values. +;;; Chaperones enforce contracts via interceptors; impersonators can freely transform. + +(library (std misc chaperone) + (export chaperone-procedure + impersonate-procedure + chaperone-vector + chaperone-hashtable + chaperone? + chaperone-of? + chaperone-vector-ref + chaperone-vector-set! + chaperone-hashtable-ref + chaperone-hashtable-set! + chaperone-hashtable-delete! + chaperone-unwrap) + (import (except (chezscheme) define-record-type) + (only (jerboa core) def defstruct)) + + (defstruct chaperone-base (inner kind)) + + (defstruct (procedure-chaperone chaperone-base) + (args-interceptor result-interceptor impersonator? wrapper)) + + (defstruct (vector-chaperone chaperone-base) + (ref-interceptor set-interceptor)) + + (defstruct (hashtable-chaperone chaperone-base) + (ref-interceptor set-interceptor delete-interceptor)) + + (def *proc-chaperone-table* (make-weak-eq-hashtable)) + + (def (register-proc-chaperone! wrapper chap) + (hashtable-set! *proc-chaperone-table* wrapper chap)) + + (def (lookup-proc-chaperone wrapper) + (hashtable-ref *proc-chaperone-table* wrapper #f)) + + (def (chaperone-unwrap v) + (cond + [(chaperone-base? v) + (chaperone-unwrap (chaperone-base-inner v))] + [(and (procedure? v) (lookup-proc-chaperone v)) + => (lambda (chap) (chaperone-unwrap (chaperone-base-inner chap)))] + [else v])) + + (def (resolve-chaperone v) + (cond + [(chaperone-base? v) v] + [(and (procedure? v) (lookup-proc-chaperone v)) + => (lambda (chap) chap)] + [else #f])) + + (def (chaperone? v) + (or (chaperone-base? v) + (and (procedure? v) (lookup-proc-chaperone v) #t))) + + (def (chaperone-of? v1 v2) + (let ([c1 (resolve-chaperone v1)]) + (and c1 + (let ([inner (chaperone-base-inner c1)]) + (or (eq? inner v2) + (and (procedure-chaperone? c1) + (procedure-chaperone-wrapper c1) + #f) + (let ([c2 (resolve-chaperone v2)]) + (and c2 + (eq? (chaperone-unwrap v1) (chaperone-unwrap v2)))) + (chaperone-of? inner v2)))))) + + (def (call-through-chain chap args) + (let loop ([c chap] [current-args args] [result-interceptors '()]) + (let ([intercepted-args + (if (procedure-chaperone-args-interceptor c) + (apply (procedure-chaperone-args-interceptor c) current-args) + current-args)] + [ri (if (procedure-chaperone-result-interceptor c) + (cons (procedure-chaperone-result-interceptor c) result-interceptors) + result-interceptors)]) + (let ([inner (chaperone-base-inner c)]) + (let ([inner-chap (resolve-chaperone inner)]) + (if (and inner-chap (procedure-chaperone? inner-chap)) + (loop inner-chap intercepted-args ri) + (let ([results (call-with-values + (lambda () (apply inner intercepted-args)) + list)]) + (let apply-results ([rs ri] [vals results]) + (if (null? rs) + (apply values vals) + (apply-results + (cdr rs) + (apply (car rs) vals))))))))))) + + (def chaperone-procedure + (case-lambda + [(proc args-interceptor result-interceptor) + (unless (procedure? (chaperone-unwrap proc)) + (error 'chaperone-procedure "expected a procedure" proc)) + (let* ([chap (make-procedure-chaperone + proc 'procedure + args-interceptor result-interceptor #f #f)] + [wrapper (lambda args + (call-through-chain chap args))]) + (procedure-chaperone-wrapper-set! chap wrapper) + (register-proc-chaperone! wrapper chap) + wrapper)] + [(proc args-interceptor) + (chaperone-procedure proc args-interceptor #f)])) + + (def impersonate-procedure + (case-lambda + [(proc args-interceptor result-interceptor) + (unless (procedure? (chaperone-unwrap proc)) + (error 'impersonate-procedure "expected a procedure" proc)) + (let* ([chap (make-procedure-chaperone + proc 'procedure + args-interceptor result-interceptor #t #f)] + [wrapper (lambda args + (call-through-chain chap args))]) + (procedure-chaperone-wrapper-set! chap wrapper) + (register-proc-chaperone! wrapper chap) + wrapper)] + [(proc args-interceptor) + (impersonate-procedure proc args-interceptor #f)])) + + (def chaperone-vector + (case-lambda + [(vec ref-interceptor set-interceptor) + (unless (vector? (chaperone-unwrap vec)) + (error 'chaperone-vector "expected a vector" vec)) + (make-vector-chaperone vec 'vector ref-interceptor set-interceptor)] + [(vec ref-interceptor) + (chaperone-vector vec ref-interceptor #f)])) + + (def (chaperone-vector-ref cv idx) + (if (vector-chaperone? cv) + (let* ([inner (chaperone-base-inner cv)] + [raw-val (if (vector-chaperone? inner) + (chaperone-vector-ref inner idx) + (vector-ref inner idx))]) + (if (vector-chaperone-ref-interceptor cv) + ((vector-chaperone-ref-interceptor cv) cv idx raw-val) + raw-val)) + (vector-ref cv idx))) + + (def (chaperone-vector-set! cv idx val) + (if (vector-chaperone? cv) + (let* ([intercepted-val + (if (vector-chaperone-set-interceptor cv) + ((vector-chaperone-set-interceptor cv) cv idx val) + val)] + [inner (chaperone-base-inner cv)]) + (if (vector-chaperone? inner) + (chaperone-vector-set! inner idx intercepted-val) + (vector-set! inner idx intercepted-val))) + (vector-set! cv idx val))) + + (def chaperone-hashtable + (case-lambda + [(ht ref-interceptor set-interceptor delete-interceptor) + (unless (hashtable? (chaperone-unwrap ht)) + (error 'chaperone-hashtable "expected a hashtable" ht)) + (make-hashtable-chaperone + ht 'hashtable ref-interceptor set-interceptor delete-interceptor)] + [(ht ref-interceptor set-interceptor) + (chaperone-hashtable ht ref-interceptor set-interceptor #f)] + [(ht ref-interceptor) + (chaperone-hashtable ht ref-interceptor #f #f)])) + + (def (chaperone-hashtable-ref ch key default) + (if (hashtable-chaperone? ch) + (let* ([inner (chaperone-base-inner ch)] + [raw-val (if (hashtable-chaperone? inner) + (chaperone-hashtable-ref inner key default) + (hashtable-ref inner key default))]) + (if (hashtable-chaperone-ref-interceptor ch) + ((hashtable-chaperone-ref-interceptor ch) ch key raw-val) + raw-val)) + (hashtable-ref ch key default))) + + (def (chaperone-hashtable-set! ch key val) + (if (hashtable-chaperone? ch) + (let* ([intercepted-val + (if (hashtable-chaperone-set-interceptor ch) + ((hashtable-chaperone-set-interceptor ch) ch key val) + val)] + [inner (chaperone-base-inner ch)]) + (if (hashtable-chaperone? inner) + (chaperone-hashtable-set! inner key intercepted-val) + (hashtable-set! inner key intercepted-val))) + (hashtable-set! ch key val))) + + (def (chaperone-hashtable-delete! ch key) + (if (hashtable-chaperone? ch) + (let* ([intercepted-key + (if (hashtable-chaperone-delete-interceptor ch) + ((hashtable-chaperone-delete-interceptor ch) ch key) + key)] + [inner (chaperone-base-inner ch)]) + (if (hashtable-chaperone? inner) + (chaperone-hashtable-delete! inner intercepted-key) + (hashtable-delete! inner intercepted-key))) + (hashtable-delete! ch key))) + +) deleted file mode 100644 --- a/lib/std/misc/deque.sls +++ /dev/null @@ -1,168 +0,0 @@ -#!chezscheme -;;; (std misc deque) -- Double-Ended Queue -;;; -;;; Efficient deque using two lists (front/back). O(1) amortized push/pop -;;; on both ends. -;;; -;;; Usage: -;;; (import (std misc deque)) -;;; (define dq (make-deque)) -;;; (deque-push-back! dq 1) -;;; (deque-push-back! dq 2) -;;; (deque-push-front! dq 0) -;;; (deque-pop-front! dq) ; => 0 -;;; (deque-pop-back! dq) ; => 2 -;;; (deque->list dq) ; => (1) -;;; -;;; ;; Bounded mode -;;; (define bq (make-bounded-deque 3)) -;;; ;; push-back! returns evicted element when full - -(library (std misc deque) - (export - make-deque - deque? - deque-empty? - deque-size - deque-push-front! - deque-push-back! - deque-pop-front! - deque-pop-back! - deque-peek-front - deque-peek-back - deque-clear! - deque->list - list->deque - deque-for-each - deque-map - deque-filter - - ;; Bounded deque - make-bounded-deque - bounded-deque? - bounded-deque-capacity) - - (import (chezscheme)) - - ;; ========== Deque Record ========== - ;; front: list in order, back: list in reverse order - ;; deque = front ++ (reverse back) - (define-record-type deque-rec - (fields (mutable front) - (mutable back) - (mutable size)) - (protocol (lambda (new) - (lambda () (new '() '() 0))))) - - (define (deque? x) (deque-rec? x)) - (define (make-deque) (make-deque-rec)) - - (define (deque-empty? dq) - (= (deque-rec-size dq) 0)) - - (define (deque-size dq) - (deque-rec-size dq)) - - ;; ========== Rebalance ========== - (define (ensure-front! dq) - (when (null? (deque-rec-front dq)) - (deque-rec-front-set! dq (reverse (deque-rec-back dq))) - (deque-rec-back-set! dq '()))) - - (define (ensure-back! dq) - (when (null? (deque-rec-back dq)) - (deque-rec-back-set! dq (reverse (deque-rec-front dq))) - (deque-rec-front-set! dq '()))) - - ;; ========== Push ========== - (define (deque-push-front! dq val) - (deque-rec-front-set! dq (cons val (deque-rec-front dq))) - (deque-rec-size-set! dq (+ (deque-rec-size dq) 1))) - - (define (deque-push-back! dq val) - (deque-rec-back-set! dq (cons val (deque-rec-back dq))) - (deque-rec-size-set! dq (+ (deque-rec-size dq) 1))) - - ;; ========== Pop ========== - (define (deque-pop-front! dq) - (when (deque-empty? dq) - (error 'deque-pop-front! "deque is empty")) - (ensure-front! dq) - (let ([val (car (deque-rec-front dq))]) - (deque-rec-front-set! dq (cdr (deque-rec-front dq))) - (deque-rec-size-set! dq (- (deque-rec-size dq) 1)) - val)) - - (define (deque-pop-back! dq) - (when (deque-empty? dq) - (error 'deque-pop-back! "deque is empty")) - (ensure-back! dq) - (let ([val (car (deque-rec-back dq))]) - (deque-rec-back-set! dq (cdr (deque-rec-back dq))) - (deque-rec-size-set! dq (- (deque-rec-size dq) 1)) - val)) - - ;; ========== Peek ========== - (define (deque-peek-front dq) - (when (deque-empty? dq) - (error 'deque-peek-front "deque is empty")) - (ensure-front! dq) - (car (deque-rec-front dq))) - - (define (deque-peek-back dq) - (when (deque-empty? dq) - (error 'deque-peek-back "deque is empty")) - (ensure-back! dq) - (car (deque-rec-back dq))) - - ;; ========== Utilities ========== - (define (deque-clear! dq) - (deque-rec-front-set! dq '()) - (deque-rec-back-set! dq '()) - (deque-rec-size-set! dq 0)) - - (define (deque->list dq) - (append (deque-rec-front dq) (reverse (deque-rec-back dq)))) - - (define (list->deque lst) - (let ([dq (make-deque)]) - (deque-rec-front-set! dq lst) - (deque-rec-size-set! dq (length lst)) - dq)) - - (define (deque-for-each proc dq) - (for-each proc (deque->list dq))) - - (define (deque-map proc dq) - (list->deque (map proc (deque->list dq)))) - - (define (deque-filter pred dq) - (list->deque (filter pred (deque->list dq)))) - - ;; ========== Bounded Deque ========== - (define-record-type bounded-deque-rec - (parent deque-rec) - (fields (immutable capacity)) - (protocol (lambda (pnew) - (lambda (cap) - ((pnew) cap))))) - - (define (bounded-deque? x) (bounded-deque-rec? x)) - (define (bounded-deque-capacity x) (bounded-deque-rec-capacity x)) - - (define (make-bounded-deque cap) - (make-bounded-deque-rec cap)) - - ;; Override push for bounded - not possible with records, so we - ;; provide the bounded check in the same push-front!/push-back! by - ;; checking type. The base functions work; users should use - ;; bounded-deque-push-back! etc if they want eviction behavior. - ;; For simplicity, bounded deque reuses the same interface and - ;; the user checks size manually, or we provide wrapper: - - ;; Actually, let's keep it simple - bounded deque is just a deque - ;; with a capacity field. Users can check and evict: - ;; This is more Scheme-like than overriding. - - -) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/deque.ss @@ -0,0 +1,125 @@ +;;; (std misc deque) -- Double-Ended Queue +;;; +;;; Efficient deque using two lists (front/back). O(1) amortized push/pop +;;; on both ends. + +(library (std misc deque) + (export + make-deque + deque? + deque-empty? + deque-size + deque-push-front! + deque-push-back! + deque-pop-front! + deque-pop-back! + deque-peek-front + deque-peek-back + deque-clear! + deque->list + list->deque + deque-for-each + deque-map + deque-filter + + make-bounded-deque + bounded-deque? + bounded-deque-capacity) + + (import (except (chezscheme) define-record-type) + (only (jerboa core) def defstruct)) + + ;; front: list in order, back: list in reverse order + ;; deque = front ++ (reverse back) + (defstruct deque-rec (front back size)) + + (def (deque? x) (deque-rec? x)) + (def (make-deque) (make-deque-rec '() '() 0)) + + (def (deque-empty? dq) + (= (deque-rec-size dq) 0)) + + (def (deque-size dq) + (deque-rec-size dq)) + + (def (ensure-front! dq) + (when (null? (deque-rec-front dq)) + (deque-rec-front-set! dq (reverse (deque-rec-back dq))) + (deque-rec-back-set! dq '()))) + + (def (ensure-back! dq) + (when (null? (deque-rec-back dq)) + (deque-rec-back-set! dq (reverse (deque-rec-front dq))) + (deque-rec-front-set! dq '()))) + + (def (deque-push-front! dq val) + (deque-rec-front-set! dq (cons val (deque-rec-front dq))) + (deque-rec-size-set! dq (+ (deque-rec-size dq) 1))) + + (def (deque-push-back! dq val) + (deque-rec-back-set! dq (cons val (deque-rec-back dq))) + (deque-rec-size-set! dq (+ (deque-rec-size dq) 1))) + + (def (deque-pop-front! dq) + (when (deque-empty? dq) + (error 'deque-pop-front! "deque is empty")) + (ensure-front! dq) + (let ([val (car (deque-rec-front dq))]) + (deque-rec-front-set! dq (cdr (deque-rec-front dq))) + (deque-rec-size-set! dq (- (deque-rec-size dq) 1)) + val)) + + (def (deque-pop-back! dq) + (when (deque-empty? dq) + (error 'deque-pop-back! "deque is empty")) + (ensure-back! dq) + (let ([val (car (deque-rec-back dq))]) + (deque-rec-back-set! dq (cdr (deque-rec-back dq))) + (deque-rec-size-set! dq (- (deque-rec-size dq) 1)) + val)) + + (def (deque-peek-front dq) + (when (deque-empty? dq) + (error 'deque-peek-front "deque is empty")) + (ensure-front! dq) + (car (deque-rec-front dq))) + + (def (deque-peek-back dq) + (when (deque-empty? dq) + (error 'deque-peek-back "deque is empty")) + (ensure-back! dq) + (car (deque-rec-back dq))) + + (def (deque-clear! dq) + (deque-rec-front-set! dq '()) + (deque-rec-back-set! dq '()) + (deque-rec-size-set! dq 0)) + + (def (deque->list dq) + (append (deque-rec-front dq) (reverse (deque-rec-back dq)))) + + (def (list->deque lst) + (let ([dq (make-deque)]) + (deque-rec-front-set! dq lst) + (deque-rec-size-set! dq (length lst)) + dq)) + + (def (deque-for-each proc dq) + (for-each proc (deque->list dq))) + + (def (deque-map proc dq) + (list->deque (map proc (deque->list dq)))) + + (def (deque-filter pred dq) + (list->deque (filter pred (deque->list dq)))) + + ;; Bounded deque: deque with a capacity field + (defstruct (bounded-deque-rec deque-rec) (capacity)) + + (def (bounded-deque? x) (bounded-deque-rec? x)) + (def (bounded-deque-capacity x) (bounded-deque-rec-capacity x)) + + (def (make-bounded-deque cap) + (make-bounded-deque-rec '() '() 0 cap)) + +)