source: project/release/4/defstruct/trunk/defstruct.scm @ 11590

Last change on this file since 11590 was 11590, checked in by sjamaan, 12 years ago

Add test and fix for breach of hygiene

File size: 4.8 KB
Line 
1;;
2;; defstruct - a more convenient form of define-record
3;;
4; Copyright (c) 2005, Dorai Sitaram
5; Copyright (c) 2005, Felix Winkelmann (Chicken port)
6; Copyright (c) 2008, Peter Bex (Hygienic Chicken port + extensions)
7; All rights reserved.
8;
9; Redistribution and use in source and binary forms, with or without
10; modification, are permitted provided that the following conditions
11; are met:
12;
13; 1. Redistributions of source code must retain the above copyright
14;    notice, this list of conditions and the following disclaimer.
15; 2. Redistributions in binary form must reproduce the above copyright
16;    notice, this list of conditions and the following disclaimer in the
17;    documentation and/or other materials provided with the distribution.
18; 3. Neither the name of the author nor the names of its
19;    contributors may be used to endorse or promote products derived
20;    from this software without specific prior written permission.
21;
22; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
27; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
28; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
29; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
30; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
31; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
32; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
33; OF THE POSSIBILITY OF SUCH DAMAGE.
34;
35; Please report bugs, suggestions and ideas to the Chicken Trac
36; ticket tracking system (assign tickets to user 'sjamaan'):
37; http://trac.callcc.org
38
39(require-library srfi-1)
40
41(module defstruct
42  (defstruct)
43
44(import-for-syntax chicken scheme srfi-1)
45
46(define-syntax defstruct
47  (lambda (exp rename compare)
48    (let* ((type-name (cadr exp))
49           (fields (cddr exp))
50           (field-names (map (lambda (f)
51                               (if (pair? f)
52                                   (car f)
53                                   f)) fields))
54           (make (string->symbol (conc "make-" type-name)))
55           (copy (string->symbol (conc "copy-" type-name)))
56           (set  (string->symbol (conc "set-" type-name "!")))
57           (predicate (string->symbol (conc type-name "?")))
58           (%begin (rename 'begin))
59           (%define-record (rename 'define-record))
60           (%define (rename 'define))
61           (%define-syntax (rename 'define-syntax))
62           (%syntax-rules (rename 'syntax-rules))
63           (%#!key (rename '#!key))
64           (%lambda (rename 'lambda))
65           (%list (rename 'list))
66           (%if (rename 'if))
67           (%not (rename 'not))
68           (%eq? (rename 'eq?))
69           (%let (rename 'let))
70           (%uninitialized (rename 'uninitialized)))
71      (receive (init-fields no-init-fields)
72        (partition pair? fields)
73        `(,%begin
74          (,%define-record ,type-name ,@no-init-fields ,@(map car init-fields))
75          (,%define ,make
76            (,%let ((old-make ,make))
77              (,%lambda (,%#!key ,@fields)
78                (old-make ,@no-init-fields ,@(map car init-fields)))))
79          (,%define ,set
80            (,%let ((uninitialized (,%list)))
81             (lambda (obj ,%#!key ,@(map (lambda (f)
82                                           (list f 'uninitialized))
83                                         field-names))
84               ,@(map
85                  (lambda (f)
86                    `(,%if (,%not (,%eq? ,f uninitialized))
87                           (,(string->symbol (conc type-name "-" f "-set!"))
88                            obj ,f)))
89                  field-names)
90               obj)))
91          (,%define ,copy
92            (,%let ((,%uninitialized (,%list)))
93             (lambda (old ,%#!key ,@(map (lambda (f)
94                                           (list f %uninitialized))
95                                         field-names))
96               (let ((new (,make
97                           ,@(fold (lambda (f rest)
98                                    (cons (string->keyword (symbol->string f))
99                                          (cons %uninitialized rest)))
100                                  '() field-names))))
101                ,@(map
102                   (lambda (f)
103                     `(,%if (,%eq? ,f ,%uninitialized)
104                            (,(string->symbol (conc type-name "-" f "-set!"))
105                             new
106                             (,(string->symbol (conc type-name "-" f)) old))
107                            (,(string->symbol (conc type-name "-" f "-set!"))
108                             new ,f)))
109                   field-names)
110                new)))))))))
111)
Note: See TracBrowser for help on using the repository browser.