source: project/release/4/datatypes/tags/1.3.3/tests/run.scm @ 33753

Last change on this file since 33753 was 33753, checked in by juergen, 2 years ago

datatypes 1.3.3 fixed typo

  • Property svn:mime-type set to application/zlib
File size: 4.4 KB
Line 
1(require-library datatypes cells simple-tests)
2(import datatypes cells simple-tests)
3
4(define-test (concrete-types?)
5  (check
6    "Immutable lists as concrete types"
7    (define-concrete-type LIST List?
8      (List-null)
9      (List-cons (first) (rest List?)))
10
11    (define (Null? obj)
12      (concrete-case (obj List?)
13        ((List-null) #t)
14        (else #f)))
15    (define (List-first obj)
16      (concrete-case (obj List?)
17        ((List-null)
18         (error 'List-first))
19        ((List-cons first rest)
20         first)))
21    (define (List-rest obj)
22      (concrete-case (obj List?)
23        ((List-null)
24         (error 'List-rest))
25        ((List-cons first rest)
26         rest)))
27    (define Lst (List-null))
28    (Null? Lst)
29    (set! Lst (List-cons 1 Lst))
30    (not (Null? Lst))
31    (Null? (List-rest Lst))
32    (= 1 (List-first Lst))
33
34    "Integers as chains"
35    (define-concrete-type CHAIN chain?
36      (Chain-link (item integer? (lambda (x) (>= x 0)))
37                  (next procedure?)))
38    (define (integers n)
39      (Chain-link n integers))
40    (not (chain? integers))
41    (chain? (integers 0))
42    (chain? (integers 10))
43    (define (chain-item n xpr)
44      (concrete-case (xpr chain?)
45        ((Chain-link i fn)
46         (if (= n 1)
47           i
48           (chain-item (- n 1) (fn (+ i 1)))))))
49    (= 0 (chain-item 1 (integers 0)))
50    (= 25 (chain-item 26 (integers 0)))
51    ))
52
53(define-test (abstract-types?)
54  (check
55    "Points as abstract types"
56    (define-abstract-type POINT point?
57      (Point (x number?) (y number?)) ; hidden
58      (with
59        ((make-point x y) (Point x y)) ; exported
60        ((point-x pt)
61         (concrete-case (pt point?)
62           ((Point x y) x)))
63        ((point-y pt)
64         (concrete-case (pt point?)
65           ((Point x y) y))))
66      (printer
67        (lambda (pt out)
68          (display "#,(POINT " out)
69          (display (point-x pt) out)
70          (display " " out)
71          (display (point-y pt) out)
72          (display ")\n" out)))
73      (reader Point)
74      )
75
76    (define pt (make-point 1 2))
77    (print pt)
78    (= (point-x pt) 1)
79    (point? pt)
80    (not (point? Lst))
81    ))
82
83(define-test (object-types?)
84  (check
85    (define-object-type COUPLE couple? make-couple
86      ((parent object?) (x (cell-of? number?)) (y (cell-of? number?)))
87       (override)
88       ; no overrides except those of base object
89      ;; new messages with handlers
90      ((First) (cell-ref x))
91      ((Second) (cell-ref y))
92      ((First-set! (arg number?))
93       (set! (cell-ref x) arg))
94      ((Second-set! (arg number?))
95       (set! (cell-ref y) arg))
96      )
97
98    (define-object-type TRIPLE triple? make-triple
99      ((parent couple?) (z (cell-of? number?)))
100      (override ((First) (* 2 (parent (First))))
101                ;; preconditions checked in parent
102                ;; hence no predicates in args
103                ((First-set! arg)
104                 (parent (First-set! (* 2 arg)))))
105      ((Third) (cell-ref z))
106      ((Third-set! (arg number?))
107       (set! (cell-ref z) arg))
108      )
109
110    (define-object-type FOO foo? make-foo
111      ((parent object?) (x (cell-of? integer?)))
112       (override)
113       ; no overrides except those of base object
114      ;; new messages with handlers
115      ((First) (cell-ref x))
116      ;; ueberschreibt die Argument-Typen von cpl und trp
117      ((First-set! (arg integer?))
118       (set! (cell-ref x) arg))
119      )
120
121    (define obj (make-base-object))
122    (object? obj)
123    (obj (Types))
124    (obj (Invariant))
125    (obj (Info))
126
127    (define foo (make-foo obj (cell 101)))
128    (= (foo (First)) 101)
129    (foo (First-set! 202))
130    (= (foo (First)) 202)
131   
132    (define cpl
133      (make-couple obj (cell 1) (cell 2)))
134    (couple? cpl)
135    (object? cpl)
136    (not (couple? First))
137    (cpl (Types))
138    (cpl (Info))
139    (cpl (Invariant))
140    (cpl (Ancestors))
141    (= (cpl (First)) 1)
142    (= (cpl (Second)) 2)
143    (cpl (First-set! 10))
144    (cpl (Second-set! 20))
145    (= (cpl (First)) 10)
146    (= (cpl (Second)) 20)
147   
148    (define trp (make-triple cpl (cell 3)))
149    (trp (Ancestors))
150    (trp (Info))
151    (= (trp (Third)) 3)
152    (trp (Third-set! 30))
153    (= (trp (Third)) 30)
154    (= (trp (First)) 20)
155    (= (trp (Second)) 20)
156    (trp (Second-set! 2))
157    (= (trp (Second)) 2)
158    (trp (First-set! 25))
159    (= (trp (First)) 100)
160    (triple? trp)
161    (not (triple? cpl))
162    (couple? trp)
163    (object? trp)
164    ))
165
166(compound-test (DATATYPES)
167  (concrete-types?)
168  (abstract-types?)
169  (object-types?)
170  )
171
Note: See TracBrowser for help on using the repository browser.