From a53e878435d3e18d4c58f96d058ef82278f83c6c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 27 Mar 2017 07:01:15 +0200 Subject: [PATCH] scm: Add assoc-set! * module/mes/scm.mes (assoc-set!): New function. * tests/scm.test ("assoc-set!", "assoc-set! new"): New tests. --- module/mes/scm.mes | 6 ++++++ tests/scm.test | 2 ++ 2 files changed, 8 insertions(+) diff --git a/module/mes/scm.mes b/module/mes/scm.mes index e04e982c..a171da4e 100644 --- a/module/mes/scm.mes +++ b/module/mes/scm.mes @@ -120,6 +120,12 @@ (if entry (cdr entry) #f))) +(define (assoc-set! alist key value) + (let ((entry (assoc key alist))) + (if (not entry) (acons key value alist) + (let ((entry (set-cdr! entry value))) + alist)))) + (define (memq x lst) (if (null? lst) #f ;; IF (if (eq? x (car lst)) lst diff --git a/tests/scm.test b/tests/scm.test index 904c4b10..ee1c38ce 100755 --- a/tests/scm.test +++ b/tests/scm.test @@ -90,6 +90,8 @@ exit $? (pass-if "assq-set!" (sequal? (assq-set! '((b . 1)) 'a 0) '((a . 0) (b . 1)))) (pass-if "assq-set! 2" (sequal? (assq-set! '((a . 0)) 'a 1) '((a . 1)))) (pass-if "assoc" (sequal? (assoc '(a . 0) '((a . 0) (b . 1) ((a . 0) aa))) '((a . 0) aa))) +(pass-if-equal "assoc-set!" '((a . 0) (b . 2)) (assoc-set! '((a . 0) (b . 1)) 'b 2)) +(pass-if-equal "assoc-set! new" '((b . 2) (a . 0)) (assoc-set! '((a . 0)) 'b 2)) (pass-if "builtin? car" (builtin? car)) (pass-if "builtin? cdr" (builtin? cdr))