source: project/release/5/typed-records/trunk/typed-records.scm @ 37355

Last change on this file since 37355 was 37355, checked in by megane, 3 years ago

[typed-records] Add missing (chicken type) import

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