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

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

Forgot to checkin defstruct.scm

File size: 4.7 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(require-library srfi-1)
36
37(module defstruct
38  (defstruct)
39
40(import-for-syntax chicken scheme srfi-1)
41
42(define-syntax defstruct
43  (lambda (exp rename compare)
44    (let* ((type-name (cadr exp))
45           (fields (cddr exp))
46           (field-names (map (lambda (f)
47                               (if (pair? f)
48                                   (car f)
49                                   f)) fields))
50           (make (string->symbol (conc "make-" type-name)))
51           (copy (string->symbol (conc type-name "-copy")))
52           (set  (string->symbol (conc "set-" type-name "!")))
53           (predicate (string->symbol (conc type-name "?")))
54           (%begin (rename 'begin))
55           (%define-record (rename 'define-record))
56           (%define (rename 'define))
57           (%define-syntax (rename 'define-syntax))
58           (%syntax-rules (rename 'syntax-rules))
59           (%#!key (rename '#!key))
60           (%lambda (rename 'lambda))
61           (%list (rename 'list))
62           (%if (rename 'if))
63           (%not (rename 'not))
64           (%eq? (rename 'eq?))
65           (%let (rename 'let))
66           (%uninitialized (rename 'uninitialized)))
67      (receive (init-fields no-init-fields)
68        (partition pair? fields)
69        `(,%begin
70          (,%define-record ,type-name ,@no-init-fields ,@(map car init-fields))
71          (,%define ,make
72            (,%let ((old-make ,make))
73              (,%lambda (,%#!key ,@fields)
74                (old-make ,@no-init-fields ,@(map car init-fields)))))
75          (,%define ,set
76            (,%let ((uninitialized (,%list)))
77             (lambda (obj ,%#!key ,@(map (lambda (f)
78                                           (list f 'uninitialized))
79                                         field-names))
80               ,@(map
81                  (lambda (f)
82                    `(,%if (,%not (,%eq? ,f uninitialized))
83                           (,(string->symbol (conc type-name "-" f "-set!"))
84                            obj ,f)))
85                  field-names)
86               obj)))
87          (,%define ,copy
88            (,%let ((,%uninitialized (,%list)))
89             (lambda (old ,%#!key ,@(map (lambda (f)
90                                           (list f %uninitialized))
91                                         field-names))
92               (let ((new (,make
93                           ,@(fold (lambda (f rest)
94                                    (cons (string->keyword (symbol->string f))
95                                          (cons %uninitialized rest)))
96                                  '() field-names))))
97                ,@(map
98                   (lambda (f)
99                     `(,%if (,%eq? ,f ,%uninitialized)
100                            (,(string->symbol (conc type-name "-" f "-set!"))
101                             new
102                             (,(string->symbol (conc type-name "-" f)) old))
103                            (,(string->symbol (conc type-name "-" f "-set!"))
104                             new ,f)))
105                   field-names)
106                new)))))))))
107)
Note: See TracBrowser for help on using the repository browser.