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

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

typed-records 0.2: shadow original definition forms

File size: 7.1 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                    ,@(map (lambda (a/m/t)
140                             (cond ((memq (first a/m/t) (cdr ctor)) (first a/m/t))
141                                   ;; XXX this indicates a problem: the initial value
142                                   ;;     of the slot is not necessarily of type
143                                   ;;     undefined - should be make this an error?
144                                   (else '(##core#undefined))))
145                           accs/mods/types))))
146         (,%colon ,pred (* -> boolean : (struct ,name)))
147         ,@(append-map
148            (lambda (a/m/t i)
149              (let ((mod (third a/m/t)))
150                `((,%colon ,(second a/m/t)
151                           ((struct ,name) -> ,(fourth a/m/t))
152                           (((struct ,name)) (##sys#slot #(1) ',(add1 i))))
153                  ,@(if (symbol? mod)
154                        `((,%colon ,(third a/m/t) 
155                                   ((struct ,name) ,(fourth a/m/t) -> undefined)
156                                   (((struct ,name) *)
157                                    (##sys#setslot #(1) ',(add1 i) #(2)))))
158                        '()))))
159            accs/mods/types (iota (length accs/mods/types)))
160         (,%define-record-type 
161          ,name 
162          ,ctor
163          ,pred
164          ,@(map (lambda (a/m/t)
165                   (if (third a/m/t)
166                       (list (first a/m/t) (second a/m/t) (third a/m/t))
167                       (list (first a/m/t) (second a/m/t))))
168                 accs/mods/types)))))))
169
170(define-syntax defstruct
171  (er-macro-transformer
172   (lambda (x r c)
173     (##sys#check-syntax 'defstruct x '(_ symbol . #(_ 0)))
174     (let* ((name (strip-syntax (cadr x)))
175            (%colon (r ':))
176            (slots (map (lambda (slot)
177                          (cond ((symbol? slot) `(,slot ,%colon *))
178                                ((and (list? slot) (= 2 (length slot)))
179                                 (cons slot `(,%colon *)))
180                                (else slot)))
181                        (cddr x)))
182            (%defstruct (r 'defstruct1))
183            (%begin (r 'begin))
184            (names/types
185             (map (lambda (slot)
186                    (##sys#check-syntax 'defstruct slot '(_ _ _))
187                    (assert (c %colon (r (second slot)))
188                            "invalid syntax in slot specification" slot)
189                    (cond ((symbol? (car slot))
190                           (cons (car slot) (third slot)))
191                          ((and (pair? (car slot))
192                                (symbol? (caar slot)))
193                           (cons (caar slot) (third slot)))
194                          (else
195                           (syntax-error
196                            'defstruct
197                            "invalid syntax in slot specification" slot))))
198                  slots)))
199       `(,%begin
200         (,%colon ,(r (symbol-append 'make- name))
201                  (#!rest -> (struct ,name)))
202         (,%colon ,(r (symbol-append name '?))
203                  (* -> boolean : (struct ,name)))
204         (,%colon ,(r (symbol-append 'update- name))
205                  ((struct ,name) #!rest -> (struct ,name)))
206         (,%colon ,(r (symbol-append 'set- name '!))
207                  ((struct ,name) #!rest -> undefined))
208         (,%colon ,(r (symbol-append name '->alist))
209                  ((struct ,name) -> (list-of (pair symbol *))))
210         (,%colon ,(r (symbol-append 'alist-> name))
211                  ((list-of (pair symbol *)) -> (struct ,name)))
212         ,@(append-map
213            (lambda (n/t slot i)
214              (let ((sname (strip-syntax (car n/t))))
215                `((,%colon ,(r (symbol-append name '- sname))
216                           ((struct ,name) -> ,(cdr n/t))
217                           (((struct ,name)) (##sys#slot #(1) ',(add1 i))))
218                  (,%colon ,(r (symbol-append name '- sname '-set!))
219                           ((struct ,name) ,(cdr n/t) -> undefined)
220                           (((struct ,name) *) (##sys#setslot #(1) ',(add1 i) #(2)))))))
221            names/types slots (iota (length slots)))
222         (,%defstruct ,name ,@(unzip1 slots)))))))
223
224)
Note: See TracBrowser for help on using the repository browser.