source: project/release/4/typed-records/trunk/typed-records.scm @ 27291

Last change on this file since 27291 was 27291, checked in by felix winkelmann, 9 years ago

typed-records 0.3: appled fix for #899 (by megane)

File size: 7.3 KB
Line 
1;;;; typed-records.scm
2
3
4(module typed-records (define-record
5                          define-record-type
6                        defstruct)
7
8(import scheme 
9        (rename chicken
10                (define-record-type define-record-type1)
11                (define-record define-record1))
12        (rename defstruct (defstruct defstruct1)))
13
14(import-for-syntax srfi-1 chicken)
15
16
17(define-syntax define-record
18  (er-macro-transformer
19   (lambda (x r c)
20     (##sys#check-syntax 'define-record x '(_ symbol . #(_ 0)))
21     (let* ((name (strip-syntax (cadr x)))
22            (slots (cddr x))
23            (%define-record (r 'define-record1))
24            (%begin (r 'begin))
25            (%setter (r 'setter))
26            (%colon (r ':))
27            (slots (map (lambda (slot)
28                          (if (symbol? slot) `(,slot ,%colon *) slot))
29                        slots))
30            (names/types
31             (map (lambda (slot)
32                    (##sys#check-syntax 'define-record slot '(_ _ _))
33                    (assert (c %colon (r (second slot)))
34                            "invalid syntax in slot specification" slot)
35                    (cond ((symbol? (car slot))
36                           (cons (car slot) (third slot)))
37                          ((and (pair? (car slot))
38                                (c %setter (caar slot))
39                                (symbol? (second (car slot))))
40                           (cons (second (car slot)) (third slot)))
41                          (else
42                           (syntax-error
43                            'define-record
44                            "invalid syntax in slot specification" slot))))
45                  slots)))
46       `(,%begin
47         (,%colon ,(r (symbol-append 'make- name))
48                  (,@(map cdr names/types) -> (struct ,name))
49                  (,(map cdr names/types)
50                   (##sys#make-structure 
51                    ',name 
52                    ,@(list-tabulate 
53                       (length names/types) 
54                       (lambda (i) `#(,(add1 i)))))))
55         (,%colon ,(r (symbol-append name '?))
56                  (* -> boolean : (struct ,name)))
57         ,@(append-map
58            (lambda (n/t slot i)
59              (let ((sname (strip-syntax (car n/t)))
60                    (slot (if (symbol? slot) `(,slot ,%colon *) slot)))
61                (cond ((symbol? (car slots)) ; explicit setter procedure?
62                       `((,%colon ,(r (symbol-append name '- sname))
63                                  ((struct ,name) -> ,(cdr n/t))
64                                  (((struct ,name)) (##sys#slot #(1) ',i)))
65                         (,%colon ,(r (symbol-append name '- sname '-set!))
66                                  ((struct ,name) ,(cdr n/t) -> undefined)
67                                  (((struct ,name) *) (##sys#setslot #(1) ',i #(2))))))
68                      (else
69                       `((,%colon ,(r (symbol-append name '- sname))
70                                  ((struct ,name) -> ,(cdr n/t))
71                                  (((struct ,name)) (##sys#slot #(1) ',i))))))))
72            names/types slots (iota (length names/types)))
73         (,%define-record ,name ,@(unzip1 slots)))))))
74
75(define-syntax define-record-type
76  (er-macro-transformer
77   (lambda (x r c)
78     (##sys#check-syntax
79      'define-record-type x
80      '(_ symbol (symbol . #(symbol 0)) symbol . #(_ 0)))
81     (let* ((name (strip-syntax (second x)))
82            (ctor (third x))
83            (pred (fourth x))
84            (fields (cddddr x))
85            (%define-record-type (r 'define-record-type1))
86            (%begin (r 'begin))
87            (%setter (r 'setter))
88            (%colon (r ':))
89            (accs/mods/types
90             (map (lambda (field)
91                    (let* ((len (length field)))
92                      (assert 
93                       (and (list? field)
94                            (>= len 2)
95                            (symbol? (first field))
96                            (symbol? (second field))
97                            (case len
98                              ((4) (c %colon (third field)))
99                              ((5) (and (c %colon (fourth field))
100                                        (or (symbol? (third field))
101                                            (and (pair? (third field))
102                                                 (c %setter (r (car (third field))))
103                                                 (symbol? (second (third field)))))))
104                              ((2) #t)
105                              ((3) (symbol? (third field)))
106                              (else #f)))
107                       "invalid syntax in field specification" field)
108                      (cons*
109                       (first field)
110                       (second field)
111                       (case len
112                         ((2) (list #f '*))
113                         ((3) (list (third field) '*))
114                         ((4) (list #f (fourth field)))
115                         ((5) (list (third field) (fifth field)))))))
116                  fields)))
117       `(,%begin
118         (,%colon ,(car ctor)
119                  (,@(map (lambda (tag)
120                            (let loop ((fields accs/mods/types))
121                              (cond ((null? fields)
122                                     (syntax-error
123                                      'define-record-type
124                                      "constructor tag refers to nonexistent record field"
125                                      ctor))
126                                    ((c tag (caar fields)) (fourth (car fields)))
127                                    (else (loop (cdr fields))))))
128                          (cdr ctor))
129                   -> (struct ,name))
130                  (,(map (lambda (fname)
131                           (cond ((assq fname accs/mods/types) => fourth)
132                                 (else (error 
133                                        'define-record-type
134                                        "contructor tag refers to unknown field"
135                                        ctor))))
136                         (cdr ctor))
137                   (##sys#make-structure
138                    ',name
139                    ,@(let lp [(names (map first accs/mods/types))
140                               (l '())]
141                        (if (null? names)
142                            (begin
143                              (reverse l))
144                            (cond ((list-index (cute eq? <> (first names)) (cdr ctor)) =>
145                                   (lambda (ctor-idx) (lp (cdr names) (cons (vector (add1 ctor-idx)) l))))
146                                  (else
147                                   ;; XXX this indicates a problem: the initial value
148                                   ;;     of the slot is not necessarily of type
149                                   ;;     undefined - should be make this an error?
150                                   (lp (cdr names) (cons '(##core#undefined) l)))))))))
151         (,%colon ,pred (* -> boolean : (struct ,name)))
152         ,@(append-map
153            (lambda (a/m/t i)
154              (let ((mod (third a/m/t)))
155                `((,%colon ,(second a/m/t)
156                           ((struct ,name) -> ,(fourth a/m/t))
157                           (((struct ,name)) (##sys#slot #(1) ',(add1 i))))
158                  ,@(if (symbol? mod)
159                        `((,%colon ,(third a/m/t) 
160                                   ((struct ,name) ,(fourth a/m/t) -> undefined)
161                                   (((struct ,name) *)
162                                    (##sys#setslot #(1) ',(add1 i) #(2)))))
163                        '()))))
164            accs/mods/types (iota (length accs/mods/types)))
165         (,%define-record-type 
166          ,name 
167          ,ctor
168          ,pred
169          ,@(map (lambda (a/m/t)
170                   (if (third a/m/t)
171                       (list (first a/m/t) (second a/m/t) (third a/m/t))
172                       (list (first a/m/t) (second a/m/t))))
173                 accs/mods/types)))))))
174
175(define-syntax defstruct
176  (er-macro-transformer
177   (lambda (x r c)
178     (##sys#check-syntax 'defstruct x '(_ symbol . #(_ 0)))
179     (let* ((name (strip-syntax (cadr x)))
180            (%colon (r ':))
181            (slots (map (lambda (slot)
182                          (cond ((symbol? slot) `(,slot ,%colon *))
183                                ((and (list? slot) (= 2 (length slot)))
184                                 (cons slot `(,%colon *)))
185                                (else slot)))
186                        (cddr x)))
187            (%defstruct (r 'defstruct1))
188            (%begin (r 'begin))
189            (names/types
190             (map (lambda (slot)
191                    (##sys#check-syntax 'defstruct slot '(_ _ _))
192                    (assert (c %colon (r (second slot)))
193                            "invalid syntax in slot specification" slot)
194                    (cond ((symbol? (car slot))
195                           (cons (car slot) (third slot)))
196                          ((and (pair? (car slot))
197                                (symbol? (caar slot)))
198                           (cons (caar slot) (third slot)))
199                          (else
200                           (syntax-error
201                            'defstruct
202                            "invalid syntax in slot specification" slot))))
203                  slots)))
204       `(,%begin
205         (,%colon ,(r (symbol-append 'make- name))
206                  (#!rest -> (struct ,name)))
207         (,%colon ,(r (symbol-append name '?))
208                  (* -> boolean : (struct ,name)))
209         (,%colon ,(r (symbol-append 'update- name))
210                  ((struct ,name) #!rest -> (struct ,name)))
211         (,%colon ,(r (symbol-append 'set- name '!))
212                  ((struct ,name) #!rest -> undefined))
213         (,%colon ,(r (symbol-append name '->alist))
214                  ((struct ,name) -> (list-of (pair symbol *))))
215         (,%colon ,(r (symbol-append 'alist-> name))
216                  ((list-of (pair symbol *)) -> (struct ,name)))
217         ,@(append-map
218            (lambda (n/t slot i)
219              (let ((sname (strip-syntax (car n/t))))
220                `((,%colon ,(r (symbol-append name '- sname))
221                           ((struct ,name) -> ,(cdr n/t))
222                           (((struct ,name)) (##sys#slot #(1) ',(add1 i))))
223                  (,%colon ,(r (symbol-append name '- sname '-set!))
224                           ((struct ,name) ,(cdr n/t) -> undefined)
225                           (((struct ,name) *) (##sys#setslot #(1) ',(add1 i) #(2)))))))
226            names/types slots (iota (length slots)))
227         (,%defstruct ,name ,@(unzip1 slots)))))))
228
229)
Note: See TracBrowser for help on using the repository browser.