source: project/release/5/defstruct/tags/2.0/defstruct.scm @ 35623

Last change on this file since 35623 was 35623, checked in by sjamaan, 17 months ago

Add CHICKEN 5 port of defstruct egg

File size: 6.2 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-2018, 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(module defstruct
36  (defstruct)
37
38(import scheme)
39(import-for-syntax (chicken string) (chicken keyword) srfi-1)
40
41(define-syntax defstruct
42  (er-macro-transformer
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 "update-" type-name)))
52            (set  (string->symbol (conc "set-" type-name "!")))
53            (predicate (string->symbol (conc type-name "?")))
54            (to-alist (string->symbol (conc type-name "->alist")))
55            (from-alist (string->symbol (conc "alist->" type-name)))
56            (%begin (rename 'begin))
57            (%define-record (rename 'define-record))
58            (%define (rename 'define))
59            (%lambda (rename 'lambda))
60            (%list (rename 'list))
61            (%cons (rename 'cons))
62            (%if (rename 'if))
63            (%not (rename 'not))
64            (%eq? (rename 'eq?))
65            (%let (rename 'let))
66            (%uninitialized (rename 'uninitialized))
67            (%case (rename 'case))
68            (%loop (rename 'loop))
69            (%obj (rename 'obj))
70            (%lst (rename 'lst))
71            (%car (rename 'car))
72            (%cdr (rename 'cdr)))
73       (receive (init-fields no-init-fields)
74         (partition pair? fields)
75         `(,%begin
76           (,%define-record ,type-name ,@no-init-fields ,@(map car init-fields))
77           (,%define ,make
78             (,%let ((old-make ,make))
79               (,%lambda (#!key ,@fields)
80                 (old-make ,@no-init-fields ,@(map car init-fields)))))
81           (,%define ,set
82             (,%let ((,%uninitialized (,%list 'uninitialized)))
83               (,%lambda (,%obj #!key ,@(map (lambda (f)
84                                                 (list f %uninitialized))
85                                               field-names))
86                 ,@(map
87                    (lambda (f)
88                      `(,%if (,%not (,%eq? ,f ,%uninitialized))
89                             (,(string->symbol (conc type-name "-" f "-set!"))
90                              ,%obj ,f)))
91                    field-names)
92                 ,%obj)))
93           (,%define ,copy
94             (,%let ((,%uninitialized (,%list 'uninitialized)))
95               (,%lambda (old #!key ,@(map (lambda (f)
96                                               (list f %uninitialized))
97                                             field-names))
98                  (let ((new (,make ,@(fold (lambda (f rest)
99                                              (cons (string->keyword
100                                                     (symbol->string f))
101                                                    (cons %uninitialized rest)))
102                                            '() field-names))))
103                    ,@(map
104                       (lambda (f)
105                         `(,%if (,%eq? ,f ,%uninitialized)
106                                (,(string->symbol (conc type-name "-" f "-set!"))
107                                 new
108                                 (,(string->symbol (conc type-name "-" f)) old))
109                                (,(string->symbol (conc type-name "-" f "-set!"))
110                                 new ,f)))
111                       field-names)
112                    new))))
113           (,%define ,to-alist
114             (,%lambda (,%obj)
115               (,%list . ,(map
116                           (lambda (f)
117                             `(,%cons
118                               ',f
119                               (,(string->symbol (conc type-name "-" f)) ,%obj)))
120                           field-names))))
121           (,%define ,from-alist
122             (,%lambda (alist)
123               (,%let ,%loop ((,%lst alist)
124                              (,%obj (,make)))
125                 (,%if (,%eq? ,%lst '())
126                       ,%obj
127                       (,%case (,%car (,%car ,%lst))
128                         ,@(map (lambda (f)
129                                    `((,f) (,(string->symbol
130                                              (conc type-name "-" f "-set!"))
131                                            ,%obj (,%cdr (,%car ,%lst)))
132                                      (,%loop (,%cdr ,%lst) ,%obj)))
133                                  field-names)
134                         ;; Unknown fields are ignored, like in the constructor
135                         (else (,%loop (,%cdr ,%lst) ,%obj)))))))))))))
136)
Note: See TracBrowser for help on using the repository browser.