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

;;;; environments.test                                    -*- scheme -*-
;;;; Copyright (C) 2000 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program 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 General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;;
;;;; As a special exception, the Free Software Foundation gives permission
;;;; for additional uses of the text contained in its release of GUILE.
;;;;
;;;; The exception is that, if you link the GUILE library with other files
;;;; to produce an executable, this does not by itself cause the
;;;; resulting executable to be covered by the GNU General Public License.
;;;; Your use of that executable is in no way restricted on account of
;;;; linking the GUILE library code into it.
;;;;
;;;; This exception does not however invalidate any other reasons why
;;;; the executable file might be covered by the GNU General Public License.
;;;;
;;;; This exception applies only to the code released by the
;;;; Free Software Foundation under the name GUILE.  If you copy
;;;; code from other Free Software Foundation releases into a copy of
;;;; GUILE, as the General Public License permits, the exception does
;;;; not apply to the code that you add in this way.  To avoid misleading
;;;; anyone as to the status of such modified files, you must delete
;;;; this exception notice from them.
;;;;
;;;; If you write modifications of your own for GUILE, it is your choice
;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice.

(use-modules (ice-9 documentation))


;;;
;;; miscellaneous
;;;


(define (documented? object)
  (object-documentation object))

(define (make-adder)
  (let* ((counter 0))
    (lambda increment
      (if (not (null? increment))
	  (set! counter (+ counter (car increment))))
      counter)))

(define (folder sym val res)
  (cons (cons sym val) res))


;;;
;;; leaf-environments
;;;

(with-test-prefix "leaf-environments"

  (with-test-prefix "leaf-environment?"

    (pass-if "documented?"
      (documented? leaf-environment?))

    (pass-if "non-environment-object"
      (not (leaf-environment? #f))))


  (with-test-prefix "make-leaf-environment"

    (pass-if "documented?"
      (documented? make-leaf-environment))

    (pass-if "produces an environment"
      (environment? (make-leaf-environment)))

    (pass-if "produces a leaf-environment"
      (leaf-environment? (make-leaf-environment)))

    (pass-if "produces always a new environment"
      (not (eq? (make-leaf-environment) (make-leaf-environment)))))


  (with-test-prefix "bound, define, ref, set!, cell"

    (let* ((env (make-leaf-environment))
	   (ctr (make-adder)))

      (pass-if "unbound by default"
	(and (not (environment-bound? env 'a))
	     (not (environment-bound? env 'b))
	     (not (environment-bound? env 'c))))

      (pass-if "bound after define"
	(environment-define env 'a (ctr 1))
	(environment-bound? env 'a))

      (pass-if "ref defined"
	(and (begin
	       (environment-define env 'a (ctr 1))
	       (eq? (environment-ref env 'a) (ctr)))
	     (begin
	       (environment-define env 'a (ctr 1))
	       (eq? (environment-ref env 'a) (ctr)))))

      (pass-if "set! defined"
	(and (begin
	       (environment-set! env 'a (ctr 1))
	       (eq? (environment-ref env 'a) (ctr)))
	     (begin
	       (environment-set! env 'a (ctr 1))
	       (eq? (environment-ref env 'a) (ctr)))))

      (pass-if "read-only cell"
	(let* ((cell (environment-cell env 'a #f)))
	  (and (begin
		 (environment-set! env 'a (ctr 1))
		 (eq? (cdr cell) (ctr))))))

      (pass-if "read-only cell rebound after define"
	(let* ((cell (environment-cell env 'a #f)))
	  (environment-define env 'a (ctr 1))
	  (not (eq? (environment-cell env 'a #f) cell))))

      (pass-if "writable cell"
	(let* ((readable (environment-cell env 'a #f))
	       (writable (environment-cell env 'a #t)))
	  (and (eq? readable writable)
	       (begin
		 (environment-set! env 'a (ctr 1))
		 (eq? (cdr writable) (ctr)))
	       (begin
		 (set-cdr! writable (ctr 1))
		 (eq? (environment-ref env 'a) (ctr)))
	       (begin
		 (set-cdr! (environment-cell env 'a #t) (ctr 1))
		 (eq? (cdr writable) (ctr))))))

      (pass-if "writable cell rebound after define"
	(let* ((cell (environment-cell env 'a #t)))
	  (environment-define env 'a (ctr 1))
	  (not (eq? (environment-cell env 'a #t) cell))))

      (pass-if "referencing undefined"
	(catch #t
	  (lambda ()
	    (environment-ref env 'b)
	    #f)
	  (lambda args
	    #t)))

      (pass-if "set!ing undefined"
	(catch #t
	  (lambda ()
	    (environment-set! env 'b)
	    #f)
	  (lambda args
	    #t)))

      (pass-if "readable cell from undefined"
	(catch #t
	  (lambda ()
	    (environment-cell env 'b #f)
	    #f)
	  (lambda args
	    #t)))

      (pass-if "writable cell from undefined"
	(catch #t
	  (lambda ()
	    (environment-cell env 'b #t)
	    #f)
	  (lambda args
	    #t)))))


  (with-test-prefix "undefine"

    (let* ((env (make-leaf-environment)))

      (pass-if "undefine defined"
	(environment-define env 'a 1)
	(and (environment-bound? env 'a)
	     (begin
	       (environment-undefine env 'a)
	       (not (environment-bound? env 'a)))))

      (pass-if "undefine undefined"
	(and (not (environment-bound? env 'a))
	     (begin
	       (environment-undefine env 'a)
	       (not (environment-bound? env 'a)))))))


  (with-test-prefix "fold"

    (let* ((env (make-leaf-environment))
	   (ctr (make-adder)))

      (pass-if "fold empty"
	(eq? 'success (environment-fold env folder 'success)))

      (pass-if "after define"
	(environment-define env 'a (ctr 1))
	(equal? `((a . ,(ctr))) (environment-fold env folder '())))

      (pass-if "after undefine"
	(environment-undefine env 'a)
	(eq? 'success (environment-fold env folder 'success)))

      (pass-if "after two defines"
	(let* ((i (ctr 1))
	       (j (+ i 1)))
	  (environment-define env 'a i)
	  (environment-define env 'b j)
	  (let ((folded (environment-fold env folder '())))
	    (or (equal? folded `((a . ,i) (b . ,j)))
		(equal? folded `((b . ,j) (a . ,i)))))))

      (pass-if "after set!"
	(let* ((i (environment-ref env 'a)))
	  (environment-set! env 'b i)
	  (let ((folded (environment-fold env folder '())))
	    (or (equal? folded `((a . ,i) (b . ,i)))
		(equal? folded `((b . ,i) (a . ,i)))))))))


  (with-test-prefix "observe"

    (let* ((env (make-leaf-environment))
	   (tag #f)
	   (func (lambda (env) (set! tag (not tag))))
	   (observer #f))

      (pass-if "observe unobserved"
	(set! observer (environment-observe env func))
	#t)

      (pass-if "define undefined"
	(set! tag #f)
	(environment-define env 'a 1)
	tag)

      (pass-if "define defined"
	(set! tag #f)
	(environment-define env 'a 1)
	tag)

      (pass-if "set! defined"
	(set! tag #t)
	(environment-set! env 'a 1)
	tag)

      (pass-if "undefine defined"
	(set! tag #f)
	(environment-undefine env 'a)
	tag)

      (pass-if "undefine undefined"
	(set! tag #t)
	(environment-undefine env 'a)
	tag)

      (pass-if "unobserve observed"
	(set! tag #t)
	(environment-unobserve observer)
	(environment-define env 'a 1)
	tag)

      (pass-if "unobserve unobserved"
	(environment-unobserve observer)
	#t)))


  (with-test-prefix "observe-weak"

    (let* ((env (make-leaf-environment))
	   (tag #f)
	   (func (lambda (env) (set! tag (not tag))))
	   (observer #f))

      (pass-if "weak-observe unobserved"
	(set! observer (environment-observe-weak env func))
	#t)

      (pass-if "define undefined"
	(set! tag #f)
	(environment-define env 'a 1)
	tag)

      (pass-if "define defined"
	(set! tag #f)
	(environment-define env 'a 1)
	tag)

      (pass-if "set! defined"
	(set! tag #t)
	(environment-set! env 'a 1)
	tag)

      (pass-if "undefine defined"
	(set! tag #f)
	(environment-undefine env 'a)
	tag)

      (pass-if "undefine undefined"
	(set! tag #t)
	(environment-undefine env 'a)
	tag)

      (pass-if "unobserve observed"
	(set! tag #t)
	(environment-unobserve observer)
	(environment-define env 'a 1)
	tag)

      (pass-if "unobserve unobserved"
	(environment-unobserve observer)
	#t)

      (pass-if "weak observer gets collected"
	(gc)
	(environment-observe-weak env func)
	(set! tag #f)
	(environment-define env 'a 1)
	(and tag
	     (begin
	       (gc)
	       (environment-define env 'a 1)
	       tag)))))


  (with-test-prefix "observer-errors"

    (let* ((env (make-leaf-environment))
	   (tag-1 #f)
	   (tag-2 #f)
	   (func-1 (lambda (env) 
		     (set! tag-1 (not tag-1))
		     (error)))
	   (func-2 (lambda (env)
		     (set! tag-2 (not tag-2))
		     (error))))

      (pass-if "update continues after error"
	(environment-observe env func-1)
	(environment-observe env func-2)
	(catch #t
	  (lambda () 
	    (environment-define env 'a 1)
	    #f)
	  (lambda args
	    (and tag-1 tag-2)))))))
Commit	Line	Data
5d3e2388 DH	1	;;;; environments.test -- scheme --
	2	;;;; Copyright (C) 2000 Free Software Foundation, Inc.
	3	;;;;
	4	;;;; This program is free software; you can redistribute it and/or modify
	5	;;;; it under the terms of the GNU General Public License as published by
	6	;;;; the Free Software Foundation; either version 2, or (at your option)
	7	;;;; any later version.
	8	;;;;
	9	;;;; This program is distributed in the hope that it will be useful,
	10	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	11	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	12	;;;; GNU General Public License for more details.
	13	;;;;
	14	;;;; You should have received a copy of the GNU General Public License
	15	;;;; along with this software; see the file COPYING. If not, write to
	16	;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
	17	;;;; Boston, MA 02111-1307 USA
	18	;;;;
	19	;;;; As a special exception, the Free Software Foundation gives permission
	20	;;;; for additional uses of the text contained in its release of GUILE.
	21	;;;;
	22	;;;; The exception is that, if you link the GUILE library with other files
	23	;;;; to produce an executable, this does not by itself cause the
	24	;;;; resulting executable to be covered by the GNU General Public License.
	25	;;;; Your use of that executable is in no way restricted on account of
	26	;;;; linking the GUILE library code into it.
	27	;;;;
	28	;;;; This exception does not however invalidate any other reasons why
	29	;;;; the executable file might be covered by the GNU General Public License.
	30	;;;;
	31	;;;; This exception applies only to the code released by the
	32	;;;; Free Software Foundation under the name GUILE. If you copy
	33	;;;; code from other Free Software Foundation releases into a copy of
	34	;;;; GUILE, as the General Public License permits, the exception does
	35	;;;; not apply to the code that you add in this way. To avoid misleading
	36	;;;; anyone as to the status of such modified files, you must delete
	37	;;;; this exception notice from them.
	38	;;;;
	39	;;;; If you write modifications of your own for GUILE, it is your choice
	40	;;;; whether to permit this exception to apply to your modifications.
	41	;;;; If you do not wish that, delete this exception notice.
	42
	43	(use-modules (ice-9 documentation))
	44
	45
	46	;;;
	47	;;; miscellaneous
	48	;;;
	49
	50
	51	(define (documented? object)
	52	(object-documentation object))
	53
	54	(define (make-adder)
	55	(let* ((counter 0))
	56	(lambda increment
	57	(if (not (null? increment))
	58	(set! counter (+ counter (car increment))))
	59	counter)))
	60
	61	(define (folder sym val res)
	62	(cons (cons sym val) res))
	63
	64
65	;;;
66	;;; leaf-environments
67	;;;
68
69	(with-test-prefix "leaf-environments"
70
71	(with-test-prefix "leaf-environment?"
72
73	(pass-if "documented?"
74	(documented? leaf-environment?))
75
76	(pass-if "non-environment-object"
77	(not (leaf-environment? #f))))
78
79
80	(with-test-prefix "make-leaf-environment"
81
82	(pass-if "documented?"
83	(documented? make-leaf-environment))
84
85	(pass-if "produces an environment"
86	(environment? (make-leaf-environment)))
87
88	(pass-if "produces a leaf-environment"
89	(leaf-environment? (make-leaf-environment)))
90
91	(pass-if "produces always a new environment"
92	(not (eq? (make-leaf-environment) (make-leaf-environment)))))
93
94
95	(with-test-prefix "bound, define, ref, set!, cell"
96
97	(let* ((env (make-leaf-environment))
98	(ctr (make-adder)))
99
100	(pass-if "unbound by default"
101	(and (not (environment-bound? env 'a))
102	(not (environment-bound? env 'b))
103	(not (environment-bound? env 'c))))
104
105	(pass-if "bound after define"
106	(environment-define env 'a (ctr 1))
107	(environment-bound? env 'a))
108
109	(pass-if "ref defined"
110	(and (begin
111	(environment-define env 'a (ctr 1))
112	(eq? (environment-ref env 'a) (ctr)))
113	(begin
114	(environment-define env 'a (ctr 1))
115	(eq? (environment-ref env 'a) (ctr)))))
116
117	(pass-if "set! defined"
118	(and (begin
119	(environment-set! env 'a (ctr 1))
120	(eq? (environment-ref env 'a) (ctr)))
121	(begin
122	(environment-set! env 'a (ctr 1))
123	(eq? (environment-ref env 'a) (ctr)))))
124
125	(pass-if "read-only cell"
126	(let* ((cell (environment-cell env 'a #f)))
127	(and (begin
128	(environment-set! env 'a (ctr 1))
129	(eq? (cdr cell) (ctr))))))
130
131	(pass-if "read-only cell rebound after define"
132	(let* ((cell (environment-cell env 'a #f)))
133	(environment-define env 'a (ctr 1))
134	(not (eq? (environment-cell env 'a #f) cell))))
135
136	(pass-if "writable cell"
137	(let* ((readable (environment-cell env 'a #f))
138	(writable (environment-cell env 'a #t)))
139	(and (eq? readable writable)
140	(begin
141	(environment-set! env 'a (ctr 1))
142	(eq? (cdr writable) (ctr)))
143	(begin
144	(set-cdr! writable (ctr 1))
145	(eq? (environment-ref env 'a) (ctr)))
146	(begin
147	(set-cdr! (environment-cell env 'a #t) (ctr 1))
148	(eq? (cdr writable) (ctr))))))
149
150	(pass-if "writable cell rebound after define"
151	(let* ((cell (environment-cell env 'a #t)))
152	(environment-define env 'a (ctr 1))
153	(not (eq? (environment-cell env 'a #t) cell))))
154
155	(pass-if "referencing undefined"
156	(catch #t
157	(lambda ()
158	(environment-ref env 'b)
159	#f)
160	(lambda args
161	#t)))
162
163	(pass-if "set!ing undefined"
164	(catch #t
165	(lambda ()
166	(environment-set! env 'b)
167	#f)
168	(lambda args
169	#t)))
170
171	(pass-if "readable cell from undefined"
172	(catch #t
173	(lambda ()
174	(environment-cell env 'b #f)
175	#f)
176	(lambda args
177	#t)))
178
179	(pass-if "writable cell from undefined"
180	(catch #t
181	(lambda ()
182	(environment-cell env 'b #t)
183	#f)
184	(lambda args
185	#t)))))
186
187
188	(with-test-prefix "undefine"
189
190	(let* ((env (make-leaf-environment)))
191
192	(pass-if "undefine defined"
193	(environment-define env 'a 1)
194	(and (environment-bound? env 'a)
195	(begin
196	(environment-undefine env 'a)
197	(not (environment-bound? env 'a)))))
198
199	(pass-if "undefine undefined"
200	(and (not (environment-bound? env 'a))
201	(begin
202	(environment-undefine env 'a)
203	(not (environment-bound? env 'a)))))))
204
205
206	(with-test-prefix "fold"
207
208	(let* ((env (make-leaf-environment))
209	(ctr (make-adder)))
210
211	(pass-if "fold empty"
212	(eq? 'success (environment-fold env folder 'success)))
213
214	(pass-if "after define"
215	(environment-define env 'a (ctr 1))
216	(equal? `((a . ,(ctr))) (environment-fold env folder '())))
217
218	(pass-if "after undefine"
219	(environment-undefine env 'a)
220	(eq? 'success (environment-fold env folder 'success)))
221
222	(pass-if "after two defines"
223	(let* ((i (ctr 1))
224	(j (+ i 1)))
225	(environment-define env 'a i)
226	(environment-define env 'b j)
227	(let ((folded (environment-fold env folder '())))
228	(or (equal? folded `((a . ,i) (b . ,j)))
229	(equal? folded `((b . ,j) (a . ,i)))))))
230
231	(pass-if "after set!"
232	(let* ((i (environment-ref env 'a)))
233	(environment-set! env 'b i)
234	(let ((folded (environment-fold env folder '())))
235	(or (equal? folded `((a . ,i) (b . ,i)))
236	(equal? folded `((b . ,i) (a . ,i)))))))))
237
238
239	(with-test-prefix "observe"
240
241	(let* ((env (make-leaf-environment))
242	(tag #f)
243	(func (lambda (env) (set! tag (not tag))))
244	(observer #f))
245
246	(pass-if "observe unobserved"
247	(set! observer (environment-observe env func))
248	#t)
249
250	(pass-if "define undefined"
251	(set! tag #f)
252	(environment-define env 'a 1)
253	tag)
254
255	(pass-if "define defined"
256	(set! tag #f)
257	(environment-define env 'a 1)
258	tag)
259
260	(pass-if "set! defined"
261	(set! tag #t)
262	(environment-set! env 'a 1)
263	tag)
264
265	(pass-if "undefine defined"
266	(set! tag #f)
267	(environment-undefine env 'a)
268	tag)
269
270	(pass-if "undefine undefined"
271	(set! tag #t)
272	(environment-undefine env 'a)
273	tag)
274
275	(pass-if "unobserve observed"
276	(set! tag #t)
277	(environment-unobserve observer)
278	(environment-define env 'a 1)
279	tag)
280
281	(pass-if "unobserve unobserved"
282	(environment-unobserve observer)
283	#t)))
284
285
286	(with-test-prefix "observe-weak"
287
288	(let* ((env (make-leaf-environment))
289	(tag #f)
290	(func (lambda (env) (set! tag (not tag))))
291	(observer #f))
292
293	(pass-if "weak-observe unobserved"
294	(set! observer (environment-observe-weak env func))
295	#t)
296
297	(pass-if "define undefined"
298	(set! tag #f)
299	(environment-define env 'a 1)
300	tag)
301
302	(pass-if "define defined"
303	(set! tag #f)
304	(environment-define env 'a 1)
305	tag)
306
307	(pass-if "set! defined"
308	(set! tag #t)
309	(environment-set! env 'a 1)
310	tag)
311
312	(pass-if "undefine defined"
313	(set! tag #f)
314	(environment-undefine env 'a)
315	tag)
316
317	(pass-if "undefine undefined"
318	(set! tag #t)
319	(environment-undefine env 'a)
320	tag)
321
322	(pass-if "unobserve observed"
323	(set! tag #t)
324	(environment-unobserve observer)
325	(environment-define env 'a 1)
326	tag)
327
328	(pass-if "unobserve unobserved"
329	(environment-unobserve observer)
330	#t)
331
332	(pass-if "weak observer gets collected"
333	(gc)
334	(environment-observe-weak env func)
335	(set! tag #f)
336	(environment-define env 'a 1)
337	(and tag
338	(begin
339	(gc)
340	(environment-define env 'a 1)
341	tag)))))
342
343
344	(with-test-prefix "observer-errors"
345
346	(let* ((env (make-leaf-environment))
347	(tag-1 #f)
348	(tag-2 #f)
349	(func-1 (lambda (env)
350	(set! tag-1 (not tag-1))
351	(error)))
352	(func-2 (lambda (env)
353	(set! tag-2 (not tag-2))
354	(error))))
355
356	(pass-if "update continues after error"
357	(environment-observe env func-1)
358	(environment-observe env func-2)
359	(catch #t
360	(lambda ()
361	(environment-define env 'a 1)
362	#f)
363	(lambda args
364	(and tag-1 tag-2)))))))