[bpt/guile.git] / test-suite / tests / alist.test

;;;; alist.test --- tests guile's alists     -*- scheme -*-
;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(use-modules (test-suite lib))

;;; (gbh) some of these are duplicated in r4rs. This is probably a bit
;;;       more thorough, though (maybe overkill? I need it, anyway).
;;;                        
;;;       
;;;       Also: it will fail on the ass*-ref & remove functions. 
;;;       Sloppy versions should be added with the current behaviour
;;;       (it's the only set of 'ref functions that won't cause an 
;;;       error on an incorrect arg); they aren't actually used anywhere
;;;       so changing's not a big deal.

;;; Misc

(define-macro (pass-if-not str form)
  `(pass-if ,str (not ,form)))

(define (safe-assq-ref alist elt)
  (let ((x (assq elt alist)))
    (if x (cdr x) x)))

(define (safe-assv-ref alist elt)
  (let ((x (assv elt alist)))
    (if x (cdr x) x)))

(define (safe-assoc-ref alist elt)
  (let ((x (assoc elt alist)))
    (if x (cdr x) x)))
  
;;; Creators, getters
(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f '()))))
      (b (acons "this" "is" (acons "a" "test" '())))
      (deformed '(a b c d e f g)))
  (pass-if "acons"
	   (and (equal? a '((a . b) (c . d) (e . f)))
		(equal? b '(("this" . "is") ("a" . "test")))))
  (pass-if "sloppy-assq"
	   (let ((x (sloppy-assq 'c a)))
	     (and (pair? x)
		  (eq? (car x) 'c)
		  (eq? (cdr x) 'd))))
  (pass-if "sloppy-assq not"
	   (let ((x (sloppy-assq "this" b)))
	     (not x)))
  (pass-if "sloppy-assv"
	   (let ((x (sloppy-assv 'c a)))
	     (and (pair? x)
		  (eq? (car x) 'c)
		  (eq? (cdr x) 'd))))
  (pass-if "sloppy-assv not"
	   (let ((x (sloppy-assv "this" b)))
	     (not x)))
  (pass-if "sloppy-assoc"
	   (let ((x (sloppy-assoc "this" b)))
	     (and (pair? x)
		  (string=? (cdr x) "is"))))
  (pass-if "sloppy-assoc not"
	   (let ((x (sloppy-assoc "heehee" b)))
	     (not x)))
  (pass-if "assq"
	   (let ((x (assq 'c a)))
	     (and (pair? x)
		  (eq? (car x) 'c)
		  (eq? (cdr x) 'd))))
  (pass-if-exception "assq deformed"
    exception:wrong-type-arg
    (assq 'x deformed))
  (pass-if-not "assq not" (assq 'r a))
  (pass-if "assv"
	   (let ((x (assv 'a a)))
	     (and (pair? x)
		  (eq? (car x) 'a)
		  (eq? (cdr x) 'b))))
  (pass-if-exception "assv deformed"
    exception:wrong-type-arg
    (assv 'x deformed))
  (pass-if-not "assv not" (assq "this" b))

  (pass-if "assoc"
	   (let ((x (assoc "this" b)))
	     (and (pair? x)
		  (string=? (car x) "this")
		  (string=? (cdr x) "is"))))
  (pass-if-exception "assoc deformed"
    exception:wrong-type-arg
    (assoc 'x deformed))
  (pass-if-not "assoc not" (assoc "this isn't" b)))


;;; Refers
(let ((a '((foo bar) (baz quux)))
      (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
      (deformed '(thats a real sloppy assq you got there)))
  (pass-if "assq-ref"
	   (let ((x (assq-ref a 'foo)))
	     (and (list? x)
		  (eq? (car x) 'bar))))

  (pass-if-not "assq-ref not" (assq-ref b "one"))
  (pass-if "assv-ref"
	   (let ((x (assv-ref a 'baz)))
	     (and (list? x)
		  (eq? (car x) 'quux))))

  (pass-if-not "assv-ref not" (assv-ref b "one"))

  (pass-if "assoc-ref"
	   (let ((x (assoc-ref b "one")))
	     (and (list? x)
		  (eqv? (car x) 2)
		  (eqv? (cadr x) 3))))


  (pass-if-not "assoc-ref not" (assoc-ref a 'testing))

  (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) 

    (pass-if-exception "assv-ref deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assv-ref deformed 'sloppy))

    (pass-if-exception "assoc-ref deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assoc-ref deformed 'sloppy))

    (pass-if-exception "assq-ref deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assq-ref deformed 'sloppy))))


;;; Setters
(let ((a '((another . silly) (alist . test-case)))
      (b '(("this" "one" "has") ("strings" "!")))
      (deformed '(canada is a cold nation)))
  (pass-if "assq-set!"
	   (begin
	     (set! a (assq-set! a 'another 'stupid))
	     (let ((x (safe-assq-ref a 'another)))
	       (and x
		    (symbol? x) (eq? x 'stupid)))))

  (pass-if "assq-set! add"
	   (begin
	     (set! a (assq-set! a 'fickle 'pickle))
	     (let ((x (safe-assq-ref a 'fickle)))
	       (and x (symbol? x)
		    (eq? x 'pickle)))))

  (pass-if "assv-set!"
	   (begin
	     (set! a (assv-set! a 'another 'boring))
	     (let ((x (safe-assv-ref a 'another)))
		   (and x
			(eq? x 'boring)))))
  (pass-if "assv-set! add"
	   (begin
	     (set! a (assv-set! a 'whistle '(while you work)))
	     (let ((x (safe-assv-ref a 'whistle)))
	       (and x (equal? x '(while you work))))))

  (pass-if "assoc-set!"
	   (begin
	     (set! b (assoc-set! b "this" "has"))
	     (let ((x (safe-assoc-ref b "this")))
	       (and x (string? x)
		    (string=? x "has")))))
  (pass-if "assoc-set! add"
	   (begin
	     (set! b (assoc-set! b "flugle" "horn"))
	     (let ((x (safe-assoc-ref b "flugle")))
	       (and x (string? x)
		    (string=? x "horn")))))

  (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) 

    (pass-if-exception "assq-set! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assq-set! deformed 'cold '(very cold)))   

    (pass-if-exception "assv-set! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assv-set! deformed 'canada 'Canada))

    (pass-if-exception "assoc-set! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assoc-set! deformed 'canada '(Iceland hence the name)))))

;;; Removers

(let ((a '((a b) (c d) (e boring)))
      (b '(("what" .  "else") ("could" . "I") ("say" . "here")))
      (deformed 1))
  (pass-if "assq-remove!"
	   (begin 
	     (set! a (assq-remove! a 'a))
	     (equal? a '((c d) (e boring)))))
  (pass-if "assv-remove!"
	   (begin
	     (set! a (assv-remove! a 'c))
	     (equal? a '((e boring)))))
  (pass-if "assoc-remove!"
	   (begin
	     (set! b (assoc-remove! b "what"))
	     (equal? b '(("could" . "I") ("say" . "here")))))

  (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove))) 

    (pass-if-exception "assq-remove! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assq-remove?) (throw 'unsupported))
      (assq-remove! deformed 'puddle))

    (pass-if-exception "assv-remove! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assq-remove?) (throw 'unsupported))
      (assv-remove! deformed 'splashing))

    (pass-if-exception "assoc-remove! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assq-remove?) (throw 'unsupported))
      (assoc-remove! deformed 'fun))))
Commit	Line	Data
dcf8fb3e	1	;;;; alist.test --- tests guile's alists -- scheme --
6e7d5622	2	;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
dcf8fb3e	3	;;;;
73be1d9e MV	4	;;;; This library is free software; you can redistribute it and/or
	5	;;;; modify it under the terms of the GNU Lesser General Public
	6	;;;; License as published by the Free Software Foundation; either
53befeb7	7	;;;; version 3 of the License, or (at your option) any later version.
dcf8fb3e	8	;;;;
73be1d9e	9	;;;; This library is distributed in the hope that it will be useful,
dcf8fb3e	10	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e MV	11	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
73be1d9e MV	12	;;;; Lesser General Public License for more details.
dcf8fb3e	13	;;;;
73be1d9e MV	14	;;;; You should have received a copy of the GNU Lesser General Public
73be1d9e MV	15	;;;; License along with this library; if not, write to the Free Software
92205699	16	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
dcf8fb3e MD	17
	18	(use-modules (test-suite lib))
	19
	20	;;; (gbh) some of these are duplicated in r4rs. This is probably a bit
	21	;;; more thorough, though (maybe overkill? I need it, anyway).
	22	;;;
	23	;;;
	24	;;; Also: it will fail on the ass*-ref & remove functions.
	25	;;; Sloppy versions should be added with the current behaviour
	26	;;; (it's the only set of 'ref functions that won't cause an
	27	;;; error on an incorrect arg); they aren't actually used anywhere
	28	;;; so changing's not a big deal.
	29
	30	;;; Misc
	31
	32	(define-macro (pass-if-not str form)
	33	`(pass-if ,str (not ,form)))
	34
	35	(define (safe-assq-ref alist elt)
	36	(let ((x (assq elt alist)))
	37	(if x (cdr x) x)))
	38
	39	(define (safe-assv-ref alist elt)
	40	(let ((x (assv elt alist)))
	41	(if x (cdr x) x)))
	42
	43	(define (safe-assoc-ref alist elt)
	44	(let ((x (assoc elt alist)))
	45	(if x (cdr x) x)))
	46
	47	;;; Creators, getters
c8e39a67 MV	48	(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f '()))))
c8e39a67 MV	49	(b (acons "this" "is" (acons "a" "test" '())))
57e7f270	50	(deformed '(a b c d e f g)))
9d372117	51	(pass-if "acons"
57e7f270 DH	52	(and (equal? a '((a . b) (c . d) (e . f)))
57e7f270 DH	53	(equal? b '(("this" . "is") ("a" . "test")))))
9d372117	54	(pass-if "sloppy-assq"
57e7f270 DH	55	(let ((x (sloppy-assq 'c a)))
	56	(and (pair? x)
	57	(eq? (car x) 'c)
	58	(eq? (cdr x) 'd))))
9d372117	59	(pass-if "sloppy-assq not"
57e7f270 DH	60	(let ((x (sloppy-assq "this" b)))
57e7f270 DH	61	(not x)))
9d372117	62	(pass-if "sloppy-assv"
57e7f270 DH	63	(let ((x (sloppy-assv 'c a)))
	64	(and (pair? x)
	65	(eq? (car x) 'c)
	66	(eq? (cdr x) 'd))))
9d372117	67	(pass-if "sloppy-assv not"
57e7f270 DH	68	(let ((x (sloppy-assv "this" b)))
57e7f270 DH	69	(not x)))
9d372117	70	(pass-if "sloppy-assoc"
57e7f270 DH	71	(let ((x (sloppy-assoc "this" b)))
	72	(and (pair? x)
	73	(string=? (cdr x) "is"))))
9d372117	74	(pass-if "sloppy-assoc not"
57e7f270 DH	75	(let ((x (sloppy-assoc "heehee" b)))
57e7f270 DH	76	(not x)))
9d372117	77	(pass-if "assq"
57e7f270 DH	78	(let ((x (assq 'c a)))
	79	(and (pair? x)
	80	(eq? (car x) 'c)
	81	(eq? (cdr x) 'd))))
6b4113af DH	82	(pass-if-exception "assq deformed"
	83	exception:wrong-type-arg
	84	(assq 'x deformed))
9d372117 DH	85	(pass-if-not "assq not" (assq 'r a))
9d372117 DH	86	(pass-if "assv"
57e7f270 DH	87	(let ((x (assv 'a a)))
	88	(and (pair? x)
	89	(eq? (car x) 'a)
	90	(eq? (cdr x) 'b))))
6b4113af DH	91	(pass-if-exception "assv deformed"
	92	exception:wrong-type-arg
	93	(assv 'x deformed))
9d372117	94	(pass-if-not "assv not" (assq "this" b))
57e7f270	95
9d372117	96	(pass-if "assoc"
57e7f270 DH	97	(let ((x (assoc "this" b)))
	98	(and (pair? x)
	99	(string=? (car x) "this")
	100	(string=? (cdr x) "is"))))
6b4113af DH	101	(pass-if-exception "assoc deformed"
	102	exception:wrong-type-arg
	103	(assoc 'x deformed))
9d372117	104	(pass-if-not "assoc not" (assoc "this isn't" b)))
dcf8fb3e MD	105
	106
	107	;;; Refers
57e7f270 DH	108	(let ((a '((foo bar) (baz quux)))
	109	(b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
	110	(deformed '(thats a real sloppy assq you got there)))
9d372117	111	(pass-if "assq-ref"
57e7f270 DH	112	(let ((x (assq-ref a 'foo)))
	113	(and (list? x)
	114	(eq? (car x) 'bar))))
	115
9d372117 DH	116	(pass-if-not "assq-ref not" (assq-ref b "one"))
9d372117 DH	117	(pass-if "assv-ref"
57e7f270 DH	118	(let ((x (assv-ref a 'baz)))
	119	(and (list? x)
	120	(eq? (car x) 'quux))))
	121
9d372117	122	(pass-if-not "assv-ref not" (assv-ref b "one"))
57e7f270	123
9d372117	124	(pass-if "assoc-ref"
57e7f270 DH	125	(let ((x (assoc-ref b "one")))
57e7f270 DH	126	(and (list? x)
764246cf DH	127	(eqv? (car x) 2)
764246cf DH	128	(eqv? (cadr x) 3))))
57e7f270 DH	129
57e7f270 DH	130
9d372117	131	(pass-if-not "assoc-ref not" (assoc-ref a 'testing))
57e7f270 DH	132
	133	(let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
	134
6b4113af DH	135	(pass-if-exception "assv-ref deformed"
	136	exception:wrong-type-arg
	137	(if (not have-sloppy-assv-ref?) (throw 'unsupported))
	138	(assv-ref deformed 'sloppy))
	139
	140	(pass-if-exception "assoc-ref deformed"
	141	exception:wrong-type-arg
	142	(if (not have-sloppy-assv-ref?) (throw 'unsupported))
	143	(assoc-ref deformed 'sloppy))
	144
	145	(pass-if-exception "assq-ref deformed"
	146	exception:wrong-type-arg
	147	(if (not have-sloppy-assv-ref?) (throw 'unsupported))
	148	(assq-ref deformed 'sloppy))))
57e7f270	149
dcf8fb3e MD	150
dcf8fb3e MD	151	;;; Setters
57e7f270 DH	152	(let ((a '((another . silly) (alist . test-case)))
	153	(b '(("this" "one" "has") ("strings" "!")))
	154	(deformed '(canada is a cold nation)))
9d372117	155	(pass-if "assq-set!"
57e7f270 DH	156	(begin
	157	(set! a (assq-set! a 'another 'stupid))
	158	(let ((x (safe-assq-ref a 'another)))
	159	(and x
	160	(symbol? x) (eq? x 'stupid)))))
	161
9d372117	162	(pass-if "assq-set! add"
57e7f270 DH	163	(begin
	164	(set! a (assq-set! a 'fickle 'pickle))
	165	(let ((x (safe-assq-ref a 'fickle)))
	166	(and x (symbol? x)
	167	(eq? x 'pickle)))))
	168
9d372117	169	(pass-if "assv-set!"
57e7f270 DH	170	(begin
	171	(set! a (assv-set! a 'another 'boring))
	172	(let ((x (safe-assv-ref a 'another)))
	173	(and x
	174	(eq? x 'boring)))))
9d372117	175	(pass-if "assv-set! add"
57e7f270 DH	176	(begin
	177	(set! a (assv-set! a 'whistle '(while you work)))
	178	(let ((x (safe-assv-ref a 'whistle)))
	179	(and x (equal? x '(while you work))))))
	180
9d372117	181	(pass-if "assoc-set!"
57e7f270 DH	182	(begin
	183	(set! b (assoc-set! b "this" "has"))
	184	(let ((x (safe-assoc-ref b "this")))
	185	(and x (string? x)
	186	(string=? x "has")))))
9d372117	187	(pass-if "assoc-set! add"
57e7f270 DH	188	(begin
	189	(set! b (assoc-set! b "flugle" "horn"))
	190	(let ((x (safe-assoc-ref b "flugle")))
	191	(and x (string? x)
	192	(string=? x "horn")))))
	193
	194	(let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
	195
6b4113af DH	196	(pass-if-exception "assq-set! deformed"
	197	exception:wrong-type-arg
	198	(if (not have-sloppy-assv-ref?) (throw 'unsupported))
	199	(assq-set! deformed 'cold '(very cold)))
	200
	201	(pass-if-exception "assv-set! deformed"
	202	exception:wrong-type-arg
	203	(if (not have-sloppy-assv-ref?) (throw 'unsupported))
	204	(assv-set! deformed 'canada 'Canada))
	205
	206	(pass-if-exception "assoc-set! deformed"
	207	exception:wrong-type-arg
	208	(if (not have-sloppy-assv-ref?) (throw 'unsupported))
	209	(assoc-set! deformed 'canada '(Iceland hence the name)))))
57e7f270	210
dcf8fb3e MD	211	;;; Removers
dcf8fb3e MD	212
57e7f270 DH	213	(let ((a '((a b) (c d) (e boring)))
	214	(b '(("what" . "else") ("could" . "I") ("say" . "here")))
	215	(deformed 1))
9d372117	216	(pass-if "assq-remove!"
57e7f270 DH	217	(begin
	218	(set! a (assq-remove! a 'a))
	219	(equal? a '((c d) (e boring)))))
9d372117	220	(pass-if "assv-remove!"
57e7f270 DH	221	(begin
	222	(set! a (assv-remove! a 'c))
	223	(equal? a '((e boring)))))
9d372117	224	(pass-if "assoc-remove!"
57e7f270 DH	225	(begin
	226	(set! b (assoc-remove! b "what"))
	227	(equal? b '(("could" . "I") ("say" . "here")))))
	228
	229	(let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove)))
	230
6b4113af DH	231	(pass-if-exception "assq-remove! deformed"
	232	exception:wrong-type-arg
	233	(if (not have-sloppy-assq-remove?) (throw 'unsupported))
	234	(assq-remove! deformed 'puddle))
	235
	236	(pass-if-exception "assv-remove! deformed"
	237	exception:wrong-type-arg
	238	(if (not have-sloppy-assq-remove?) (throw 'unsupported))
	239	(assv-remove! deformed 'splashing))
	240
	241	(pass-if-exception "assoc-remove! deformed"
	242	exception:wrong-type-arg
	243	(if (not have-sloppy-assq-remove?) (throw 'unsupported))
	244	(assoc-remove! deformed 'fun))))