source: project/release/4/record-variants/trunk/record-variants.scm @ 13861

Last change on this file since 13861 was 13861, checked in by Jim Ursetto, 12 years ago

add record-variants egg

File size: 11.9 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    (lambda (x r c)
70      (define (any p L)
71        (and (pair? L)
72             (or (p (car L))
73                 (any p (cdr L)))))
74      (##sys#check-syntax 'define-record-variant x
75                          '(_ _ #(symbol 0) . #(symbol 0)))
76      (let* ((name-spec (cadr x))
77             (name (if (pair? name-spec) (car name-spec) name-spec))
78             (original-name (if (pair? name-spec) (cadr name-spec) name-spec))
79             (prefix (symbol->string name))
80             (constructor? (or #t   ; force #t -- always generate constructor
81                               (eq? name original-name)))
82
83             (variant? (lambda (type) (any (lambda (x) (c x (r type)))
84                                   (caddr x))))
85             (unsafe? (variant? 'unsafe))
86             (unchecked? (variant? 'unchecked))
87             (inline? (variant? 'inline))
88
89             (slots (cdddr x))
90             (setters (memq #:record-setters ##sys#features))
91             (%begin (r 'begin))
92             (%define (if inline?
93                          (r 'define-inline)
94                          (r 'define)))
95             (%getter-with-setter (r 'getter-with-setter))
96             (%lambda (r 'lambda)))
97        `(,%begin
98           ,(if constructor?
99                `(,%define
100                   ,(string->symbol (string-append "make-" prefix))
101                   (,%lambda ,slots
102                     (##sys#make-structure ',original-name ,@slots)))
103                `(,%begin))
104           (,%define
105              ,(string->symbol (string-append prefix "?"))
106             (,%lambda (x) (##sys#structure? x ',original-name)))
107           (,%define
108             ,(string->symbol (string-append "check-" prefix))
109             (,%lambda (x)
110               (##core#check (##sys#check-structure x ',original-name))
111               x))
112           ,@(let loop ((slots slots) (i 1))
113               (if (eq? slots '())
114                   slots
115                   (let* ((slotname (symbol->string (car slots)))
116                          (setr (string->symbol (string-append
117                                                 prefix "-" slotname "-set!")))
118                          (getr (string->symbol (string-append
119                                                 prefix "-" slotname))))
120                     (cons
121                      `(,%begin
122                         (,%define
123                           ,setr
124                           (,%lambda (x val)
125                             ,(if unchecked?
126                                  `(,%begin)
127                                  `(##core#check (##sys#check-structure
128                                                  x ',original-name)))
129                             ,(if unsafe?
130                                  `(##sys#setslot x ,i val)
131                                  `(##sys#block-set! x ,i val))))
132                         (,%define
133                           ,getr
134                           ,(if setters
135                                `(,%getter-with-setter
136                                  (,%lambda (x)
137                                    ,(if unchecked?
138                                         `(,%begin)
139                                         `(##core#check (##sys#check-structure
140                                                         x ',original-name)))
141                                    ,(if unsafe?
142                                         `(##sys#slot x ,i)
143                                         `(##sys#block-ref x ,i)))
144                                  ,setr)
145                                `(,%lambda (x)
146                                   ,(if unchecked?
147                                        `(,%begin)
148                                        `(##core#check (##sys#check-structure
149                                                        x ',original-name)))
150                                   ,(if unsafe?
151                                        `(##sys#slot x ,i)
152                                        `(##sys#block-ref x ,i))))))
153                      (loop (cdr slots) (add1 i))))))))))
154
155  (define-syntax define-record-type-variant
156    (lambda (form r c)
157      (define (any p L)
158        (and (pair? L)
159             (or (p (car L))
160                 (any p (cdr L)))))     
161      (##sys#check-syntax 'define-record-type-variant form
162                          '(_ _ #(variable 0)
163                              #(variable 1) _ . _))
164      (let* ((name-spec (cadr form))
165             (name (if (pair? name-spec) (car name-spec) name-spec))
166             (t (if (pair? name-spec) (cadr name-spec) name-spec))
167             (variant? (lambda (type) (any (lambda (x) (c x (r type)))
168                                      (caddr form))))
169             (unsafe? (variant? 'unsafe))
170             (unchecked? (variant? 'unchecked))
171             (inline? (variant? 'inline))
172             (constructor? (eq? name t))
173             
174             (conser (cadddr form))
175             (predspec (car (cddddr form)))
176             (pred (if (pair? predspec) (car predspec) predspec))
177             (checker (if (and (pair? predspec)
178                               (pair? (cdr predspec)))
179                          (cadr predspec) #f))
180             (slots (cdr (cddddr form)))
181             (%begin (r 'begin))
182             (%lambda (r 'lambda))
183             (%define (if inline? (r 'define-inline) (r 'define)))
184             (vars (cdr conser))
185             (x (r 'x))
186             (y (r 'y))
187             (%getter-with-setter (r 'getter-with-setter))
188             (slotnames (map car slots)))
189        `(,%begin
190           ,(if constructor?
191                `(,%define ,conser
192                   (##sys#make-structure 
193                    ',t 
194                    ,@(map (lambda (sname)
195                             (if (memq sname vars)
196                                 sname
197                                 '(##core#undefined)))
198                           slotnames)))
199                `(,%begin))
200           (,%define (,pred ,x) (##sys#structure? ,x ',t))
201           ,(if checker
202                `(,%define (,checker ,x)
203                   (##core#check (##sys#check-structure ,x ',t)))
204                `(,%begin))
205           ,@(let loop ([slots slots] [i 1])
206               (if (null? slots)
207                   '()
208                   (let* ([slot (car slots)]
209                          (setters (memq #:record-setters ##sys#features))
210                          (setr? (pair? (cddr slot))) 
211                          (getr `(,%lambda (,x)
212                                   ,(if unchecked?
213                                        `(,%begin)
214                                        `(##core#check
215                                          (##sys#check-structure ,x ',t)))
216                                   ,(if unsafe?
217                                        `(##sys#slot ,x ,i)
218                                        `(##sys#block-ref ,x ,i)))))
219                     `(,@(if setr?
220                             `((,%define (,(caddr slot) ,x ,y)
221                                 ,(if unchecked?
222                                       `(,%begin)
223                                       `(##core#check
224                                         (##sys#check-structure ,x ',t)))
225                                 ,(if unsafe?
226                                      `(##sys#setslot ,x ,i ,y)
227                                      `(##sys#block-set! ,x ,i ,y))))
228                             '())
229                       (,%define ,(cadr slot) 
230                         ,(if (and setr? setters)
231                              `(,%getter-with-setter ,getr ,(caddr slot))
232                              getr) )
233                       ,@(loop (cdr slots) (add1 i))))))))))
234
235  )
236
237
238;; Copyright (c) 2009 Jim Ursetto.  All rights reserved.
239;;
240;; Redistribution and use in source and binary forms, with or without
241;; modification, are permitted provided that the following conditions are met:
242;;
243;;  Redistributions of source code must retain the above copyright notice,
244;;   this list of conditions and the following disclaimer.
245;;  Redistributions in binary form must reproduce the above copyright notice,
246;;   this list of conditions and the following disclaimer in the documentation
247;;   and/or other materials provided with the distribution.
248;;  Neither the name of the author nor the names of its contributors
249;;   may be used to endorse or promote products derived from this software
250;;   without specific prior written permission.
251;;
252;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
253;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
254;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
255;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
256;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
257;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
258;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
259;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
260;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
261;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
262;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
263
Note: See TracBrowser for help on using the repository browser.