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

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

[typed-records] Initial C5 port

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