source: project/release/5/record-variants/tags/1.1/record-variants.scm @ 37651

Last change on this file since 37651 was 37651, checked in by felix, 6 weeks ago

record-variants 1.1: use tag-var instead of unqualified record type name

File size: 12.3 KB
Line 
1;; Copyright (c) 2009 Jim Ursetto.  All rights reserved.
2;; BSD license at end of file.
3
4;;; (define-record-variant name-spec variant-spec slot1 slot2 ...)
5
6;; name-spec := (variant-name original-name) | variant-name
7;; variant-spec := (variant-type ...)
8;; variant-type := unsafe | unchecked | inline
9
10;; Defines alternate accessor procedures to the existing record
11;; {{original-name}} according to {{variant-spec}}.  The accessors
12;; will be defined using {{variant-name}}, as if
13;; (define-record variant-name slot1 slot2 ...) had been invoked,
14;; but they will operate on records of type {{original-name}}.
15
16;; Variant type may be one of:
17;; * inline, so procedure definitions use {{define-inline}};
18;; * unchecked, so accessors do not check the record type;
19;; * unsafe, so accessors use {{##sys#slot}} and {{##sys#setslot}}
20;;   instead of the safe {{block-ref!}} and {{block-set!}}
21;; and any combination of {{variant-type}} is allowed in {{variant-spec}}.
22
23;; A constructor, {{make-VARIANT-NAME}}, is defined to create a record
24;; of the original type.  If you are defining a variant on an existing
25;; record, this is here essentially for completeness, as {{unsafe}}
26;; and {{unchecked}} don't have any effect on the constructor --
27;; though {{inline}} will inline it.  For new records the constructor
28;; is naturally required.
29
30;; Additionally, one new procedure over define-record is created:
31
32;; (check-VARIANT-NAME x): Checks that x is of the corresponding record type
33;; and returns x if so; otherwise throws an error.  When compiled
34;; in unsafe mode no check is performed, regardless of variant-type.
35
36;; Note that (define-record-variant foo () x y) is equivalent to
37;; (define-record foo x y) except that a check-foo procedure
38;; will be generated.
39
40;;; (define-record-type-variant name-spec variant-spec pred-spec constructor field-spec)
41
42;; name-spec := (variant-name original-name) | variant-name
43;; variant-spec := (variant-type ...)
44;; variant-type := unsafe | unchecked | inline
45;; pred-spec := (predicate checker) | (predicate) | predicate
46;; constructor, field-spec: as in SRFI 9
47
48;; Defines alternate accessor procedures to the existing SRFI 9
49;; record-type {{original-name}} according to {{variant-spec}}.
50
51;; {{name-spec}} acts as it does in {{define-record-variant}},
52;; including constructor generation behavior.
53
54;; {{pred-spec}} may be a predicate identifier or a list containing
55;; a predicate identifier and optionally a "checker" identifier.  The
56;; checker identifier is used as the name of the generated
57;; check-VARIANT-NAME procedure, which again behaves as in
58;; {{define-record-variant}}.  If the checker identifier is
59;; omitted, no check procedure is generated.
60
61;; See {{define-record-variant}} and SRFI 9 for further details.
62
63(module record-variants
64  (define-record-variant define-record-type-variant)
65
66  (import scheme)
67 
68  (define-syntax define-record-variant
69    (er-macro-transformer
70     (lambda (x r c)
71       (define (any p L)
72         (and (pair? L)
73              (or (p (car L))
74                  (any p (cdr L)))))
75       (##sys#check-syntax 'define-record-variant x
76                           '(_ _ #(symbol 0) . #(symbol 0)))
77       (let* ((name-spec (cadr x))
78              (name (if (pair? name-spec) (car name-spec) name-spec))
79              (original-name (if (pair? name-spec) (cadr name-spec) name-spec))
80              (prefix (symbol->string name))
81              (constructor? (or #t ; force #t -- always generate constructor
82                                (eq? name original-name)))
83
84              (variant? (lambda (type) (any (lambda (x) (c x (r type)))
85                                            (caddr x))))
86              (unsafe? (variant? 'unsafe))
87              (unchecked? (variant? 'unchecked))
88              (inline? (variant? 'inline))
89
90              (slots (cdddr x))
91              (setters (memq #:record-setters ##sys#features))
92              (%begin (r 'begin))
93              (%define (if inline?
94                           (r 'define-inline)
95                           (r 'define)))
96              (%getter-with-setter (r 'getter-with-setter))
97              (%lambda (r 'lambda)))
98         `(,%begin
99           ,(if constructor?
100                `(,%define
101                  ,(string->symbol (string-append "make-" prefix))
102                  (,%lambda ,slots
103                            (##sys#make-structure ,original-name ,@slots)))
104                `(,%begin))
105           (,%define
106            ,(string->symbol (string-append prefix "?"))
107            (,%lambda (x) (##sys#structure? x ,original-name)))
108           (,%define
109            ,(string->symbol (string-append "check-" prefix))
110            (,%lambda (x)
111                      (##core#check (##sys#check-structure x ,original-name))
112                      x))
113           ,@(let loop ((slots slots) (i 1))
114               (if (eq? slots '())
115                   slots
116                   (let* ((slotname (symbol->string (car slots)))
117                          (setr (string->symbol (string-append
118                                                 prefix "-" slotname "-set!")))
119                          (getr (string->symbol (string-append
120                                                 prefix "-" slotname))))
121                     (cons
122                      `(,%begin
123                        (,%define
124                         ,setr
125                         (,%lambda (x val)
126                                   ,(if unchecked?
127                                        `(,%begin)
128                                        `(##core#check (##sys#check-structure
129                                                        x ,original-name)))
130                                   ,(if unsafe?
131                                        `(##sys#setslot x ,i val)
132                                        `(##sys#block-set! x ,i val))))
133                        (,%define
134                         ,getr
135                         ,(if setters
136                              `(,%getter-with-setter
137                                (,%lambda (x)
138                                          ,(if unchecked?
139                                               `(,%begin)
140                                               `(##core#check (##sys#check-structure
141                                                               x ,original-name)))
142                                          ,(if unsafe?
143                                               `(##sys#slot x ,i)
144                                               `(##sys#block-ref x ,i)))
145                                ,setr)
146                              `(,%lambda (x)
147                                         ,(if unchecked?
148                                              `(,%begin)
149                                              `(##core#check (##sys#check-structure
150                                                              x ,original-name)))
151                                         ,(if unsafe?
152                                              `(##sys#slot x ,i)
153                                              `(##sys#block-ref x ,i))))))
154                      (loop (cdr slots) (add1 i)))))))))))
155
156  (define-syntax define-record-type-variant
157    (er-macro-transformer
158     (lambda (form r c)
159       (define (any p L)
160         (and (pair? L)
161              (or (p (car L))
162                  (any p (cdr L)))))     
163       (##sys#check-syntax 'define-record-type-variant form
164                           '(_ _ #(variable 0)
165                               #(variable 1) _ . _))
166       (let* ((name-spec (cadr form))
167              (name (if (pair? name-spec) (car name-spec) name-spec))
168              (t (if (pair? name-spec) (cadr name-spec) name-spec))
169              (variant? (lambda (type) (any (lambda (x) (c x (r type)))
170                                            (caddr form))))
171              (unsafe? (variant? 'unsafe))
172              (unchecked? (variant? 'unchecked))
173              (inline? (variant? 'inline))
174              (constructor? (eq? name t))
175             
176              (conser (cadddr form))
177              (predspec (car (cddddr form)))
178              (pred (if (pair? predspec) (car predspec) predspec))
179              (checker (if (and (pair? predspec)
180                                (pair? (cdr predspec)))
181                           (cadr predspec) #f))
182              (slots (cdr (cddddr form)))
183              (%begin (r 'begin))
184              (%lambda (r 'lambda))
185              (%define (if inline? (r 'define-inline) (r 'define)))
186              (vars (cdr conser))
187              (x (r 'x))
188              (y (r 'y))
189              (%getter-with-setter (r 'getter-with-setter))
190              (slotnames (map car slots)))
191         `(,%begin
192           ,(if constructor?
193                `(,%define ,conser
194                           (##sys#make-structure 
195                            ,t 
196                            ,@(map (lambda (sname)
197                                     (if (memq sname vars)
198                                         sname
199                                         '(##core#undefined)))
200                                   slotnames)))
201                `(,%begin))
202           (,%define (,pred ,x) (##sys#structure? ,x ,t))
203           ,(if checker
204                `(,%define (,checker ,x)
205                           (##core#check (##sys#check-structure ,x ,t)))
206                `(,%begin))
207           ,@(let loop ([slots slots] [i 1])
208               (if (null? slots)
209                   '()
210                   (let* ([slot (car slots)]
211                          (setters (memq #:record-setters ##sys#features))
212                          (setr? (pair? (cddr slot))) 
213                          (getr `(,%lambda (,x)
214                                           ,(if unchecked?
215                                                `(,%begin)
216                                                `(##core#check
217                                                  (##sys#check-structure ,x ,t)))
218                                           ,(if unsafe?
219                                                `(##sys#slot ,x ,i)
220                                                `(##sys#block-ref ,x ,i)))))
221                     `(,@(if setr?
222                             `((,%define (,(caddr slot) ,x ,y)
223                                         ,(if unchecked?
224                                              `(,%begin)
225                                              `(##core#check
226                                                (##sys#check-structure ,x ,t)))
227                                         ,(if unsafe?
228                                              `(##sys#setslot ,x ,i ,y)
229                                              `(##sys#block-set! ,x ,i ,y))))
230                             '())
231                       (,%define ,(cadr slot) 
232                                 ,(if (and setr? setters)
233                                      `(,%getter-with-setter ,getr ,(caddr slot))
234                                      getr) )
235                       ,@(loop (cdr slots) (add1 i)))))))))))
236
237  )
238
239
240;; Copyright (c) 2009 Jim Ursetto.  All rights reserved.
241;;
242;; Redistribution and use in source and binary forms, with or without
243;; modification, are permitted provided that the following conditions are met:
244;;
245;;  Redistributions of source code must retain the above copyright notice,
246;;   this list of conditions and the following disclaimer.
247;;  Redistributions in binary form must reproduce the above copyright notice,
248;;   this list of conditions and the following disclaimer in the documentation
249;;   and/or other materials provided with the distribution.
250;;  Neither the name of the author nor the names of its contributors
251;;   may be used to endorse or promote products derived from this software
252;;   without specific prior written permission.
253;;
254;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
255;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
256;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
257;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
258;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
259;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
260;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
261;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
262;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
263;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
264;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
265
Note: See TracBrowser for help on using the repository browser.