artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

scm: Add assoc-set!

Browse source 
* module/mes/scm.mes (assoc-set!): New function.
* tests/scm.test ("assoc-set!", "assoc-set! new"): New tests.
This commit is contained in:
Jan Nieuwenhuizen 2017-03-27 07:01:15 +02:00
parent 58dfe0b7bd
commit a53e878435
2 changed files with 8 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
module/mes/scm.mes
View file

@ -120,6 +120,12 @@
(if entry (cdr entry) (if entry (cdr entry)
#f))) #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) (define (memq x lst)
(if (null? lst) #f ;; IF (if (null? lst) #f ;; IF
(if (eq? x (car lst)) lst (if (eq? x (car lst)) lst

2
tests/scm.test
View file

@ -90,6 +90,8 @@ exit $?
(pass-if "assq-set!" (sequal? (assq-set! '((b . 1)) 'a 0) '((a . 0) (b . 1)))) (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 "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 "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? car" (builtin? car))
(pass-if "builtin? cdr" (builtin? cdr)) (pass-if "builtin? cdr" (builtin? cdr))