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 | ) |
---|