From 07256cf26bdf31c7d65e74b464e00a95fd21ba08 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau Date: Sun, 30 Jul 2023 13:03:29 -0400 Subject: [PATCH] std/misc/walist -- wrapped alists Pure and stateful wrapped alists, carry with them the equality predicate and, for the stateful ones, correctly handle the case of empty alists. --- src/std/build-deps | 1 + src/std/build-spec.ss | 1 + src/std/misc/walist-test.ss | 44 ++++++++++++++++++ src/std/misc/walist.ss | 91 +++++++++++++++++++++++++++++++++++++ 4 files changed, 137 insertions(+) create mode 100644 src/std/misc/walist-test.ss create mode 100644 src/std/misc/walist.ss diff --git a/src/std/build-deps b/src/std/build-deps index f361b5c9d2..5773a07826 100644 --- a/src/std/build-deps +++ b/src/std/build-deps @@ -174,6 +174,7 @@ (std/misc/list-builder "misc/list-builder" (gerbil/core)) (std/misc/alist "misc/alist" (gerbil/core std/sugar)) (std/misc/plist "misc/plist" (gerbil/core std/sugar)) + (std/misc/walist "misc/walist" (gerbil/core std/sugar std/misc/alist)) (std/misc/rtd "misc/rtd" (gerbil/core)) (std/misc/shuffle "misc/shuffle" (gerbil/core gerbil/gambit/random)) (std/event diff --git a/src/std/build-spec.ss b/src/std/build-spec.ss index 5b45139058..02db7d31a7 100644 --- a/src/std/build-spec.ss +++ b/src/std/build-spec.ss @@ -254,6 +254,7 @@ "misc/list" "misc/alist" "misc/plist" + "misc/walist" "misc/rtd" "misc/shuffle" "misc/uuid" diff --git a/src/std/misc/walist-test.ss b/src/std/misc/walist-test.ss new file mode 100644 index 0000000000..5e3fcb630e --- /dev/null +++ b/src/std/misc/walist-test.ss @@ -0,0 +1,44 @@ +(export walist-test) + +(import + :gerbil/gambit/exceptions + :std/error :std/misc/walist :std/test) + +(def walist-test + (test-suite "test :std/misc/walist" + (def (test-walist-ro make a1b2) + (check-equal? (walist-alist (a1b2)) '((a . 1) (b . 2))) + (check-equal? {key? (a1b2) 'a} #t) + (check-equal? {key? (a1b2) 'b} #t) + (check-equal? {key? (a1b2) 'c} #f) + (check-equal? {get (a1b2) 'a} 1) + (check-equal? {get (a1b2) 'b} 2) + (check-exception {get (a1b2) 'c} true)) + (def (test-walist make) + (def (a1b2) {acons {acons (make '()) 'b 2} 'a 1}) + (test-walist-ro make a1b2) + (check-equal? {put (a1b2) 'a 3} (make '((a . 3) (b . 2)))) + (check-equal? {put (a1b2) 'c 3} (make '((c . 3) (a . 1) (b . 2)))) + (check-equal? {put (a1b2) 'b 4} (make '((a . 1) (b . 4)))) + (check-equal? {remove (a1b2) 'a} (make '((b . 2)))) + (check-equal? {remove (a1b2) 'b} (make '((a . 1)))) + (check-equal? {remove (a1b2) 'c} (a1b2)) + (check-equal? {remove (make '()) 'a} (make '())) + (check-equal? {remove (make '((a . 1))) 'a} (make '()))) + (def (test-walist! make) + (def (a1b2) (def w (make '())) {acons! w 'b 2} {acons! w 'a 1} w) + (test-walist-ro make a1b2) + (check-equal? (let (w (a1b2)) {put! w 'a 3} w) (make '((a . 3) (b . 2)))) + (check-equal? (let (w (a1b2)) {put! w 'c 3} w) (make '((c . 3) (a . 1) (b . 2)))) + (check-equal? (let (w (a1b2)) {put! w 'b 4} w) (make '((a . 1) (b . 4)))) + (check-equal? (let (w (a1b2)) {remove! w 'a} w) (make '((b . 2)))) + (check-equal? (let (w (a1b2)) {remove! w 'b} w) (make '((a . 1)))) + (check-equal? (let (w (a1b2)) {remove! w 'c} w) (a1b2)) + (check-equal? (let (w (make '())) {remove! w 'a} w) (make '())) + (check-equal? (let (w (make [['a . 1]])) {remove! w 'a} w) (make '()))) + (test-walist make-walist) + (test-walist make-walistq) + (test-walist make-walistv) + (test-walist! make-walist!) + (test-walist! make-walistq!) + (test-walist! make-walistv!))) diff --git a/src/std/misc/walist.ss b/src/std/misc/walist.ss new file mode 100644 index 0000000000..70b47148ef --- /dev/null +++ b/src/std/misc/walist.ss @@ -0,0 +1,91 @@ +(import + :std/misc/alist + :std/sugar) + +(export + _walist_ _walist_? + walist walistq walistv walist! walistq! walistv! + walist? walistq? walistv? walist!? walistq!? walistv!? + make-walist make-walistq make-walistv make-walist! make-walistq! make-walistv! + walist-alist walist-alist-set! + walist-acons walistq-acons walistv-acons walist-acons! + walist-key? walistq-key? walistv-key? + walist-get walistq-get walistv-get + walist-put walistv-put walistq-put walist!-put! walistv!-put! walistq!-put! + walist-remove walistv-remove walistq-remove walist!-remove! walistv!-remove! walistq!-remove!) + +(defstruct _walist_ (alist) transparent: #t) +(defstruct (_walist _walist_) () transparent: #t) ;; equal? +(defstruct (_walistq _walist_) () transparent: #t) ;; eq? +(defstruct (_walistv _walist_) () transparent: #t) ;; eqv? +(defstruct (walist _walist) () transparent: #t final: #t) ;; equal?, pure +(defstruct (walistq _walistq) () transparent: #t final: #t) ;; eq?, pure +(defstruct (walistv _walistv) () transparent: #t final: #t) ;; eqv?, pure +(defstruct (walist! _walist) () transparent: #t final: #t) ;; equal?, stateful +(defstruct (walistq! _walistq) () transparent: #t final: #t) ;; eq?, stateful +(defstruct (walistv! _walistv) () transparent: #t final: #t) ;; eqv?, stateful + +(def walist-alist _walist_-alist) +(def (walist-alist-set! w a) (set! (_walist_-alist w) a)) + +(def (walist-acons w k v) (make-walist (acons k v (walist-alist w)))) +(def (walistq-acons w k v) (make-walistq (acons k v (walist-alist w)))) +(def (walistv-acons w k v) (make-walistv (acons k v (walist-alist w)))) +(def (walist-acons! w k v) (set! (_walist_-alist w) (acons k v (_walist_-alist w)))) +(defmethod {acons walist} walist-acons) +(defmethod {acons walistq} walistq-acons) +(defmethod {acons walistv} walistv-acons) +(defmethod {acons! _walist_} walist-acons!) + +(def (walist-key? w k) (pair? (assoc k (walist-alist w)))) +(def (walistq-key? w k) (pair? (assq k (walist-alist w)))) +(def (walistv-key? w k) (pair? (assv k (walist-alist w)))) +(defmethod {key? _walist} walist-key?) +(defmethod {key? _walistq} walistq-key?) +(defmethod {key? _walistv} walistv-key?) + +(def (walist-get w k) (cdr (assoc k (walist-alist w)))) +(def (walistq-get w k) (cdr (assq k (walist-alist w)))) +(def (walistv-get w k) (cdr (assv k (walist-alist w)))) +(defmethod {get _walist} walist-get) +(defmethod {get _walistq} walistq-get) +(defmethod {get _walistv} walistv-get) + +(def (walist-put w k v) (make-walist (aset (walist-alist w) k v))) +(def (walistq-put w k v) (make-walistq (asetq (walist-alist w) k v))) +(def (walistv-put w k v) (make-walistv (asetv (walist-alist w) k v))) +(defmethod {put walist} walist-put) +(defmethod {put walistq} walistq-put) +(defmethod {put walistv} walistv-put) + +(def (walist-remove w k) (make-walist (arem k (walist-alist w)))) +(def (walistq-remove w k) (make-walistq (aremq k (walist-alist w)))) +(def (walistv-remove w k) (make-walistv (aremv k (walist-alist w)))) +(defmethod {remove walist} walist-remove) +(defmethod {remove walistq} walistq-remove) +(defmethod {remove walistv} walistv-remove) + +(def (walist!-put! w k v) (aset! (walist-alist w) k v)) +(def (walistq!-put! w k v) (asetq! (walist-alist w) k v)) +(def (walistv!-put! w k v) (asetv! (walist-alist w) k v)) +(defmethod {put! walist!} walist!-put!) +(defmethod {put! walistv!} walistv!-put!) +(defmethod {put! walistq!} walistq!-put!) + +(defrule (define-remove! struct! fun cmp) + (begin + (def (fun w key) + (let lp ((p (walist-alist w)) (prev #f)) + (match p + ([[k . _] . r] + (cond + ((not (cmp key k)) (lp r p)) + (prev (set-cdr! prev r)) + (else (set! (_walist_-alist w) r)))) + ([] (void)) ; key not found: NOP + (_ (error "Invalid walist" 'struct! w key))))) + (defmethod {remove! struct!} fun))) + +(define-remove! walist! walist!-remove! equal?) +(define-remove! walistq! walistq!-remove! eq?) +(define-remove! walistv! walistv!-remove! eqv?)