source: project/release/5/procedural-macros/trunk/procedural-macros.scm @ 38044

Last change on this file since 38044 was 38044, checked in by juergen, 9 months ago

procedural-macros 2.0 simplified and streamlined

File size: 13.9 KB
Line 
1; Author: Juergen Lorenz ; ju (at jugilo (dot) de
2;
3; Copyright (c) 2013-2019, Juergen Lorenz
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without
7; modification, are permitted provided that the following conditions are
8; met:
9;
10; Redistributions of source code must retain the above copyright
11; notice, this list of conditions and the following dispasser.
12;
13; Redistributions in binary form must reproduce the above copyright
14; notice, this list of conditions and the following dispasser in the
15; documentation and/or other materials provided with the distribution.
16;
17; Neither the name of the author nor the names of its contributors may be
18; used to endorse or promote products derived from this software without
19; specific prior written permission.
20;
21; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
22; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
23; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
24; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33(module procedural-macros (
34  define-macro
35  macro-rules
36  macro-let
37  macro-letrec
38  once-only
39  with-renamed-symbols
40  with-gensyms
41  procedural-macros
42  )
43
44(import scheme
45        bindings
46        (only (chicken base) print error case-lambda))
47(import-for-syntax (only bindings bind bind-case)
48                   (only (chicken keyword) string->keyword))
49
50;;; (define-macro signature
51;;;   (with-renaming (compare? . %syms)
52;;;     xpr . xprs))
53;;; (define-macro signature
54;;;   xpr . xprs)
55;;; ---------------------------------
56;;; where with-renaming is either
57;;; with-implicit- or with-explicit-renaming.
58;;; If not given and no keys are needed, with-implict-renaming is used.
59;;; Defines an explicit- or implicit-renaming macro name
60;;; with use-form signature.
61(define-syntax define-macro
62  (er-macro-transformer
63    (lambda (f r c?)
64      (let ((signature (cadr f))
65            ;(transformer (caddr f)))
66            (first (caddr f))
67            (%compare? (r 'compare?))
68            (%with-explicit-renaming (r 'with-explicit-renaming))
69            (%with-implicit-renaming (r 'with-implicit-renaming))
70            )
71        (let ((transformer
72                (cond
73                  ((c? (car first) %with-explicit-renaming)
74                   first)
75                  ((c? (car first) %with-implicit-renaming)
76                   first)
77                  (else
78                    `(,%with-implicit-renaming (,%compare?)
79                                               ,@(cddr f))))))
80          ;(print "TTT " transformer)
81          (let ((with-renaming (car transformer)) 
82                (symbols (cadr transformer))
83                (xpr (caddr transformer))
84                (xprs (cdddr transformer))
85                (%let (r 'let))
86                (%cdr (r 'cdr))
87                (%bind (r 'bind))
88                (%lambda (r 'lambda))
89                (%form (r 'form))
90                (%rename (r 'rename))
91                (%inject (r 'inject))
92                (%er-macro-transformer (r 'er-macro-transformer))
93                (%ir-macro-transformer (r 'ir-macro-transformer))
94                (%define-syntax (r 'define-syntax))
95                (%with-renaming (r 'with-renaming))
96                )
97            (let ((transform
98                    (cond
99                      ((c? with-renaming %with-explicit-renaming)
100                       %rename)
101                      ((c? with-renaming %with-implicit-renaming)
102                       %inject)
103                      (else
104                        (error "invalid renaming type" with-renaming))))
105                  (macro-transformer
106                    (cond
107                      ((c? with-renaming %with-explicit-renaming)
108                       %er-macro-transformer)
109                      ((c? with-renaming %with-implicit-renaming)
110                       %ir-macro-transformer)
111                      (else
112                        (error "invalid renaming type" with-renaming))))
113                  )
114              `(,%define-syntax ,(car signature)
115                 (,macro-transformer
116                   (,%lambda (,%form ,transform ,%compare?)
117                     (,%bind ,(cdr signature) (,%cdr ,%form)
118                       (,%let ((,(car symbols) ,%compare?)
119                               ,@(map (lambda (s)
120                                        `(,s (,transform
121                                               ',(string->symbol
122                                                   (substring
123                                                     (symbol->string s) 1)))))
124                                      (cdr symbols)))
125                         ,xpr ,@xprs)))))
126              )))))))
127
128;;; (macro-rules sym ... (key ...) (pat tpl) ....)
129;;; ----------------------------------------------
130;;; where sym ... are injected non-hygienic symbols, key ... are
131;;; additional keywords, pat ....  are nested lambda-lists without
132;;; spezial meaning of ellipses and tpl .... usually evaluate to
133;;; quasiquoted templates. To be imported for syntax.
134;;; The implementation transfforms keys to keywords and uses bind-case's
135;;; property to match equal literals.
136(define-syntax macro-rules
137  (er-macro-transformer
138    (lambda (f r c?)
139      (receive (syms tail)
140        (let loop ((tail (cdr f)) (head '()))
141          (if (symbol? (car tail))
142            (loop (cdr tail) (cons (car tail) head))
143            (values (reverse head) tail)))
144        (let ((keys (car tail))
145              (rules (cdr tail))
146              (%let (r 'let))
147              (%form (r 'form))
148              (%lambda (r 'lambda))
149              (%inject (r 'inject))
150              (%compare? (r 'compare?))
151              (%bind-case (r 'bind-case))
152              (%ir-macro-transformer (r 'ir-macro-transformer))
153              (map*
154                (lambda (fn tree)
155                  (let recur ((tree tree))
156                    (cond
157                      ((pair? tree)
158                       (cons (recur (car tree))
159                             (recur (cdr tree))))
160                      ((symbol? tree) (fn tree))
161                      (else tree)))))
162              (symbol->keyword
163                (lambda (sym)
164                  (string->keyword (symbol->string sym))))
165              (memp
166                (lambda (ok? lst)
167                  (let loop ((lst lst))
168                    (cond
169                      ((null? lst) #f)
170                      ((ok? (car lst)) lst)
171                      (else (loop (cdr lst)))))))
172              )
173          (let* ((keys->keywords
174                  (lambda (sym)
175                    (let ((syms (memp (lambda (x)
176                                        (c? x (r sym)))
177                                      keys)))
178                      (if syms
179                        (symbol->keyword (car syms))
180                        ;(symbol->string (car syms))
181                        sym))))
182                 (rewrite-keys
183                   (lambda (form)
184                     (map* keys->keywords form))))
185            `(,%ir-macro-transformer
186               (,%lambda (,%form ,%inject ,%compare?)
187                 (,%let ,(map (lambda (s)
188                                `(,s (,%inject ',s)))
189                         syms)
190               ;(print "FFF " ,%form)
191               ;(print "SSS " (,rewrite-keys ,%form))
192                     (,%bind-case ;,%form ,@rules)
193                       ;,%form
194                       (,rewrite-keys ,%form)
195                       ,@(map (lambda (c d)
196                                (cons (rewrite-keys c)
197                                      d))
198                              (map car rules) (map cdr rules))))))
199            )))))) 
200
201
202#|[
203Now follow the local versions of define-macro, macro-let and
204macro-letrec.
205]|#
206
207;;; (macro-let (((signature body) ...) ...) xpr ....)
208;;; --------------------------------------------------
209;;; evaluates xpr ... in the context of parallel macros name ....
210;(define-macro (macro-let signature-body-list xpr . xprs)
211;  (with-explicit-renaming (compare? %let-syntax %macro-rules)
212(define-macro (macro-let signature-body-list xpr . xprs) 
213  (with-explicit-renaming (compare? %let-syntax %macro-rules)
214    (let ((signatures (map car signature-body-list))
215          (bodies (map cdr signature-body-list)))
216      `(,%let-syntax ,(map (lambda (sig body)
217                                `(,(car sig)
218                                  (,%macro-rules _ () 
219                                    (,(cons '_ (cdr sig)) ,@body))))
220                             signatures bodies)
221         ,xpr ,@xprs))))
222
223;;; (macro-letrec (((signature body) ...) ...) xpr ....)
224;;; ----------------------------------------------------
225;;; evaluates xpr ... in the context of recursive macros name ....
226(define-macro (macro-letrec signature-body-list xpr . xprs) 
227  (with-explicit-renaming (compare? %letrec-syntax %macro-rules)
228    (let ((signatures (map car signature-body-list))
229          (bodies (map cdr signature-body-list)))
230      `(,%letrec-syntax ,(map (lambda (sig body)
231                                `(,(car sig)
232                                  (,%macro-rules _ () 
233                                    (,(cons '_ (cdr sig)) ,@body))))
234                             signatures bodies)
235         ,xpr ,@xprs))))
236
237;;; (once-only (x ....) xpr ....)
238;;; -----------------------------
239;;; macro-arguments x .... are only evaluated once and from left to
240;;; right in the body xpr ....
241;;; The code is more or less due to
242;;; P. Seibel, Practical Common Lisp, p. 102
243(define-syntax once-only
244  (er-macro-transformer
245    (lambda (form rename compare?)
246      (let ((syms (cadr form))
247            (xpr (caddr form))
248            (xprs (cdddr form)))
249        (let ((%syms (map rename syms))
250              (%let (rename 'let))
251              (%list (rename 'list)))
252          `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) %syms)
253             `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
254                                   %syms syms))
255                ,(,%let ,(map (lambda (n g) `(,n ,g))
256                            syms %syms)
257                   ,xpr ,@xprs))))))))
258
259;;; (with-renamed-symbols (renamer . %syms) xpr . xprs)
260;;; ---------------------------------------------------
261(define-syntax with-renamed-symbols
262  (er-macro-transformer
263    (lambda (form rename compare?)
264      (let ((syms (cadr form))
265            (xpr (caddr form))
266            (xprs (cdddr form))
267            )
268        (let ((renamer (car syms))
269              (%syms (cdr syms))
270              (%let (rename 'let))
271              )
272          `(,%let ,(map (lambda (s)
273                          ;`(,(symbol-append prefix s) (,renamer ',s)))
274                          `(,s (,renamer
275                            ',(string->symbol
276                               (substring (symbol->string s) 1)))))
277                        %syms)
278             ,xpr ,@xprs))))))
279
280;;; (with-gensyms (name ....) xpr ....)
281;;; -----------------------------------
282;;; binds name ... to (gensym 'name) ... in body xpr ...
283(define-syntax with-gensyms
284  (ir-macro-transformer
285    (lambda (form inject compare?)
286      `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
287         ,@(cddr form)))))
288
289;;; (procedural-macros sym ..)
290;;; --------------------------
291;;; documentation procedure.
292(define procedural-macros
293  (let ((alst '(
294    (macro-rules
295      macro:
296      (macro-rules literal ... (keyword ...) (pat tpl) ....)
297      "procedural version of syntax-rules"
298      "with optional injected literals"
299      "and quasiquoted templates"
300      "To be imported for syntax")
301    (define-macro
302      macro:
303      (define-macro (name . args) (with-renaming (compare? %x ...) xpr ....))
304      (define-macro (name . args) xpr ....)
305      "where with-renaming is one of with-explicit- or with-implicit-renaming"
306      "and %x ... is the symbol x prefixed with one letter only."
307      "Defines an explicit- or implicit-renaming macro name,"
308      "automatically destructuring args with bind and creating local bindings"
309      "for compare? and %x ... to x ... renamed or injected respectively,"
310      "evaluating xpr ... in this context."
311      "The latter version is used if no keys are needed and nothing is"
312      "to be injected")
313    (macro-let
314      macro:
315      (macro-let (((name args) xpr ...) ...) body ....)
316      "evaluates body ... in the context of parallel macros name ....")
317    (macro-letrec
318      macro:
319      (macro-letrec (((name args) xpr ...) ...) body ....)
320      "evaluates body ... in the context of recursive macros name ....")
321    (once-only
322      macro:
323      (once-only (x ....) xpr ....)
324      "arguments x ... are evaluated only once and"
325      "from left to right in the body xpr ...."
326      "To be imported for syntax")
327    (with-renamed-symbols
328      macro:
329      (with-renamed-symbols (renamer %x ....) xpr ....)
330      "binds a series of names prefixed with one letter, e.g. %,
331      %x .... to the images of the original names, x ....,"
332      "under renamer and evaluates xpr .... in this context"
333      "To be imported for syntax")
334    (with-gensyms
335      macro:
336      (with-gensyms (x ....) xpr ....)
337      "binds x ... to (gensym 'x) ... in body xpr ...")
338    (procedural-macros
339      procedure:
340      "documaentation procedure: returns the list of exported symbols"
341      "if called with no arguments, or the documentation of its only"
342      "symbol argument")
343    )))
344    (case-lambda
345      (()
346       (map car alst))
347      ((sym)
348       (let ((lst (assq sym alst)))
349         (if lst
350           (for-each print (cdr lst))
351           (error 'procedural-macros
352                  "not exported" sym)))))))
353
354) ; module procedural-macros
355
Note: See TracBrowser for help on using the repository browser.