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

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

Add improved port to hygienic-chicken of defstruct

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      (receive (init-fields no-init-fields)
71        (partition pair? fields)
72        `(,%begin
73          (,%define-record ,type-name ,@no-init-fields ,@(map car init-fields))
74          (,%define ,make
75            (,%let ((old-make ,make))
76              (,%lambda (,%#!key ,@fields)
77                (old-make ,@no-init-fields ,@(map car init-fields)))))
78          (,%define ,set
79            (,%let ((uninitialized (,%list)))
80             (lambda (obj ,%#!key ,@(map (lambda (f)
81                                           (list f 'uninitialized))
82                                         field-names))
83               ,@(map
84                  (lambda (f)
85                    `(,%if (,%not (,%eq? ,f uninitialized))
86                           (,(string->symbol (conc type-name "-" f "-set!"))
87                            obj ,f)))
88                  field-names)
89               obj)))
90          (,%define ,copy
91            (,%let ((uninitialized (,%list)))
92             (lambda (old ,%#!key ,@(map (lambda (f)
93                                           (list f 'uninitialized))
94                                         field-names))
95               (let ((new (,make
96                           ,@(fold (lambda (f rest)
97                                    (cons (string->keyword (symbol->string f))
98                                          (cons 'uninitialized rest)))
99                                  '() field-names))))
100                ,@(map
101                   (lambda (f)
102                     `(,%if (,%eq? ,f uninitialized)
103                            (,(string->symbol (conc type-name "-" f "-set!"))
104                             new
105                             (,(string->symbol (conc type-name "-" f)) old))
106                            (,(string->symbol (conc type-name "-" f "-set!"))
107                             new ,f)))
108                   field-names)
109                new)))))))))
110)
Note: See TracBrowser for help on using the repository browser.