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

Last change on this file since 38710 was 38710, checked in by juergen, 4 months ago

procedural-macros 3.0.1 with simplyfied code

File size: 21.5 KB
Line 
1; Author: Juergen Lorenz ; ju (at jugilo (dot) de
2;
3; Copyright (c) 2013-2020, 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  define-er-macro
36  define-ir-macro
37  macro-rules
38  macro-let
39  macro-letrec
40  once-only
41  with-renamed-symbols
42  with-gensyms
43  procedural-macros
44  )
45
46(import scheme
47        bindings
48        (only (chicken base) print error case-lambda))
49(import-for-syntax (only bindings bind bind-case)
50                   (only (chicken keyword) string->keyword))
51
52;;; (define-macro signature
53;;;   (with-renaming (compare? . %syms)
54;;;     xpr . xprs))
55;;; (define-macro signature
56;;;   xpr . xprs)
57;;; ---------------------------------
58;;; where with-renaming is either
59;;; with-implicit- or with-explicit-renaming.
60;;; If not given and no keys are needed, with-implict-renaming is used.
61;;; Defines an explicit- or implicit-renaming macro name
62;;; with use-form signature.
63(define-syntax define-macro
64  (er-macro-transformer
65    (lambda (f r c?)
66      (let ((signature (cadr f))
67            ;(transformer (caddr f)))
68            (first (caddr f))
69            (%compare? (r 'compare?))
70            (%with-explicit-renaming (r 'with-explicit-renaming))
71            (%with-implicit-renaming (r 'with-implicit-renaming))
72            )
73        (let ((transformer
74                (cond
75                  ((c? (car first) %with-explicit-renaming)
76                   first)
77                  ((c? (car first) %with-implicit-renaming)
78                   first)
79                  (else
80                    `(,%with-implicit-renaming (,%compare?)
81                                               ,@(cddr f))))))
82          ;(print "TTT " transformer)
83          (let ((with-renaming (car transformer)) 
84                (symbols (cadr transformer))
85                (xpr (caddr transformer))
86                (xprs (cdddr transformer))
87                (%let (r 'let))
88                (%cdr (r 'cdr))
89                (%bind (r 'bind))
90                (%lambda (r 'lambda))
91                (%form (r 'form))
92                (%rename (r 'rename))
93                (%inject (r 'inject))
94                (%er-macro-transformer (r 'er-macro-transformer))
95                (%ir-macro-transformer (r 'ir-macro-transformer))
96                (%define-syntax (r 'define-syntax))
97                (%with-renaming (r 'with-renaming))
98                )
99            (let ((transform
100                    (cond
101                      ((c? with-renaming %with-explicit-renaming)
102                       %rename)
103                      ((c? with-renaming %with-implicit-renaming)
104                       %inject)
105                      (else
106                        (error "invalid renaming type" with-renaming))))
107                  (macro-transformer
108                    (cond
109                      ((c? with-renaming %with-explicit-renaming)
110                       %er-macro-transformer)
111                      ((c? with-renaming %with-implicit-renaming)
112                       %ir-macro-transformer)
113                      (else
114                        (error "invalid renaming type" with-renaming))))
115                  )
116              `(,%define-syntax ,(car signature)
117                 (,macro-transformer
118                   (,%lambda (,%form ,transform ,%compare?)
119                     (,%bind ,(cdr signature) (,%cdr ,%form)
120                       (,%let ((,(car symbols) ,%compare?)
121                               ,@(map (lambda (s)
122                                        `(,s (,transform
123                                               ',(string->symbol
124                                                   (substring
125                                                     (symbol->string s) 1)))))
126                                      (cdr symbols)))
127                         ,xpr ,@xprs)))))
128              )))))))
129
130(define-syntax define-key-macro ;; internal
131  (er-macro-transformer
132    (lambda (f r c?)
133      (let ((key (cadr f))
134            (adjoin
135              (lambda (sym syms)
136                (if (memq sym syms)
137                  syms
138                  (cons sym syms))))
139            (prefixed?
140              (lambda (fix sym)
141                (and (symbol? sym)
142                  (let ((sfix (symbol->string fix))
143                        (ssym (symbol->string sym)))
144                    (let ((fixlen (string-length sfix))
145                          (symlen (string-length ssym)))
146                      (and (< fixlen symlen)
147                           (string=? sfix (substring ssym 0 fixlen))))))))
148            (%form (r 'form))
149            (%rename (r 'rename))
150            (%inject (r 'inject))
151            (%compare? (r 'compare?))
152            (%lambda (r 'lambda))
153            (%let (r 'let))
154            (%bind-case (r 'bind-case))
155            (%define-syntax (r 'define-syntax))
156            (%er-macro-transformer (r 'er-macro-transformer))
157            (%ir-macro-transformer (r 'ir-macro-transformer))
158            (%_ (r '_))
159            (%define-key-macro (r 'define-key-macro))
160            (%where (r 'where))
161            (%key? (r 'key?))
162            )
163        (let ((transformer
164                (case key
165                  ((#:er) %er-macro-transformer)
166                  ((#:ir) %ir-macro-transformer)))
167              (mapper
168                (case key
169                  ((#:er) %rename)
170                  ((#:ir) %inject)))
171              (strip-prefix
172                (lambda (fix sym)
173                  (and (prefixed? fix sym)
174                       (string->symbol
175                         (substring (symbol->string sym)
176                                    (string-length (symbol->string
177                                                     fix)))))))
178              (extract-prefixed
179                (lambda (fix xss)
180                  (let ((prefixed '()))
181                    (let recur ((xss xss))
182                    ;(print "PPP " prefixed)
183                      (cond
184                        ((pair? xss)
185                         (let ((first (car xss)) (rest (cdr xss)))
186                           (cond
187                             ((pair? first)
188                              (recur (car first))
189                              (recur (cdr first)))
190                             ((null? first)
191                              (error 'define-er-macro
192                                     "no nil in car position"))
193                             (else
194                              (set! prefixed
195                                (if (prefixed? fix first)
196                                  (adjoin first prefixed)
197                                  prefixed))))
198                           (recur rest)))
199                        ((null? xss) prefixed)
200                        (else
201                          (recur
202                            (if (prefixed? fix xss)
203                              (adjoin xss prefixed)
204                              prefixed)))))))))
205          (let ((insert-mapped-symbols
206                  (lambda (pat fend fix tpl) ;(fix pat tpl)
207                    `(,pat ,fend
208                    ;`(,(cons '_ (cdr pat)) ;pat
209                       (,%let ,(map (lambda (t)
210                                      `(,t (,mapper ',(strip-prefix fix t))))
211                                                                    ;(car pat) t))))
212                                    (extract-prefixed fix tpl));(car pat) tpl))
213                                  ,@tpl)))))
214(bind-case (cddr f)
215  (((name . args) (where . fenders) prefix xpr . xprs)
216   `(,%define-key-macro ,(cadr f)
217      ,name ((,%_ ,@args) (,%where ,@fenders) ,prefix ,xpr ,@xprs)))
218  (((name . args) prefix xpr . xprs)
219   `(,%define-key-macro ,(cadr f)
220      ,name ((,%_ ,@args) (,%where) ,prefix ,xpr ,@xprs)))
221  ;((name . pat-fend-fix-tpls)
222  ((name . pat-rest)
223   (let ((pat-fend-fix-tpls
224           ;; check for where clause
225           (map (lambda (lst)
226                  (cond
227                    ((and (pair? (cadr lst))
228                          (c? (caadr lst) %where)
229                          (symbol? (caddr lst)))
230                     lst)
231                    ((and (pair? (cadr lst))
232                          (c? (caadr lst) %where))
233                     (error 'er/ir-macro "prefix missing"))
234                    (else
235                      (apply list
236                             (car lst)
237                             `(,%where)
238                             (if (symbol? (cadr lst))
239                               (cadr lst)
240                               (error 'er/ir-macro "prefix missing"))
241                             (cddr lst)))))
242               pat-rest)))
243     `(,%define-syntax ,name
244        (,transformer
245          (,%lambda (,%form ,mapper ,%compare?)
246            (,%bind-case ,%form
247              ,@(map insert-mapped-symbols
248                  (map car pat-fend-fix-tpls)
249                  (map (lambda (fend)
250                         (if (null? (cdr fend))
251                           ;; no keyword-checks
252                           fend
253                           ;; do keyword-checks
254                           `(,(car fend)
255                             ,@(map (lambda (p)
256                                      (if (c? (car p) %key?) 
257                                        `(,%compare? ,(cadr p)
258                                                     (,mapper ',(cadr p)))
259                                        p))
260                                    (cdr fend)))))
261                       (map cadr pat-fend-fix-tpls))
262                  (map caddr pat-fend-fix-tpls)
263                  (map cdddr pat-fend-fix-tpls))))))))
264    )))))))
265
266;;; (define-er-macro (name . args) (where . fenders) prefix xpr . xprs)
267;;; (define-er-macro (name . args) prefix xpr . xprs)
268;;; (define-er-macro name (pat (where . fenders) prefix xpr . xprs) . others)
269;;; (define-er-macro name (pat prefix xpr . xprs) . others)
270;;; -------------------------------------------------------------------------
271;;; where fenders check for keywords via key?
272;;; Version of define-macro, where symbols prefixed with prefix
273;;; are automatically renamed
274(define-syntax define-er-macro
275  (syntax-rules (where)
276    ((_ (name . args) (where . fenders) prefix xpr . xprs)
277     (define-key-macro #:er (name . args) (where . fenders)
278       prefix xpr . xprs))
279    ((_ (name . args) prefix xpr . xprs)
280     (define-key-macro #:er (name . args)
281       prefix xpr . xprs))
282    ((_ name . pat-rest)
283     (define-key-macro #:er name . pat-rest))
284    ))
285
286;;; (define-ir-macro (name . args) (where . fenders) prefix xpr . xprs)
287;;; (define-ir-macro (name . args) prefix xpr . xprs)
288;;; (define-ir-macro name (pat (where . fenders) prefix xpr . xprs) . others)
289;;; (define-ir-macro name (pat prefix xpr . xprs) . others)
290;;; -------------------------------------------------------------------------
291;;; where fenders check for keywords via key?
292;;; Version of define-macro, where symbols prefixed with prefix
293;;; are automatically injected.
294(define-syntax define-ir-macro
295  (syntax-rules (where)
296    ((_ (name . args) (where . fenders) prefix xpr . xprs)
297     (define-key-macro #:ir (name . args) (where . fenders)
298       prefix xpr . xprs))
299    ((_ (name . args) prefix xpr . xprs)
300     (define-key-macro #:ir (name . args)
301       prefix xpr . xprs))
302    ((_ name . pat-rest)
303     (define-key-macro #:ir name . pat-rest))
304    ))
305
306;;; (macro-rules sym ... (key ...) (pat tpl) ....)
307;;; ----------------------------------------------
308;;; where sym ... are injected non-hygienic symbols, key ... are
309;;; additional keywords, pat ....  are nested lambda-lists without
310;;; spezial meaning of ellipses and tpl .... usually evaluate to
311;;; quasiquoted templates. To be imported for syntax.
312;;; The implementation transfforms keys to keywords and uses bind-case's
313;;; property to match equal literals.
314(define-syntax macro-rules
315  (er-macro-transformer
316    (lambda (f r c?)
317      (receive (syms tail)
318        (let loop ((tail (cdr f)) (head '()))
319          (if (symbol? (car tail))
320            (loop (cdr tail) (cons (car tail) head))
321            (values (reverse head) tail)))
322        (let ((keys (car tail))
323              (rules (cdr tail))
324              (%let (r 'let))
325              (%form (r 'form))
326              (%lambda (r 'lambda))
327              (%inject (r 'inject))
328              (%compare? (r 'compare?))
329              (%bind-case (r 'bind-case))
330              (%ir-macro-transformer (r 'ir-macro-transformer))
331              (map*
332                (lambda (fn tree)
333                  (let recur ((tree tree))
334                    (cond
335                      ((pair? tree)
336                       (cons (recur (car tree))
337                             (recur (cdr tree))))
338                      ((symbol? tree) (fn tree))
339                      (else tree)))))
340              (symbol->keyword
341                (lambda (sym)
342                  (string->keyword (symbol->string sym))))
343              (memp
344                (lambda (ok? lst)
345                  (let loop ((lst lst))
346                    (cond
347                      ((null? lst) #f)
348                      ((ok? (car lst)) lst)
349                      (else (loop (cdr lst)))))))
350              )
351          (let* ((keys->keywords
352                  (lambda (sym)
353                    (let ((syms (memp (lambda (x)
354                                        (c? x (r sym)))
355                                      keys)))
356                      (if syms
357                        (symbol->keyword (car syms))
358                        sym))))
359                 (rewrite-keys
360                   (lambda (form)
361                     (map* keys->keywords form)))
362                 )
363            `(,%ir-macro-transformer
364               (,%lambda (,%form ,%inject ,%compare?)
365                 (,%let ,(map (lambda (s)
366                                `(,s (,%inject ',s)))
367                         syms)
368                     (,%bind-case ;,%form ,@rules)
369                       ;,%form
370                       (,rewrite-keys ,%form)
371                       ;,(rewrite-keys %form)
372                       ,@(map (lambda (c d)
373                                (cons (rewrite-keys c)
374                                      d))
375                              (map car rules) (map cdr rules))))))
376            )))))) 
377
378
379#|[
380Now follow the local versions of define-macro, macro-let and
381macro-letrec.
382]|#
383
384;;; (macro-let (((signature body) ...) ...) xpr ....)
385;;; --------------------------------------------------
386;;; evaluates xpr ... in the context of parallel macros name ....
387(define-macro (macro-let signature-body-list xpr . xprs) 
388  (with-explicit-renaming (compare? %let-syntax %macro-rules)
389    (let ((signatures (map car signature-body-list))
390          (bodies (map cdr signature-body-list)))
391      `(,%let-syntax ,(map (lambda (sig body)
392                                `(,(car sig)
393                                  (,%macro-rules () 
394                                    (,(cons '_ (cdr sig)) ,@body))))
395                             signatures bodies)
396         ,xpr ,@xprs))))
397
398;;; (macro-letrec (((signature body) ...) ...) xpr ....)
399;;; ----------------------------------------------------
400;;; evaluates xpr ... in the context of recursive macros name ....
401(define-macro (macro-letrec signature-body-list xpr . xprs) 
402  (with-explicit-renaming (compare? %letrec-syntax %macro-rules)
403    (let ((signatures (map car signature-body-list))
404          (bodies (map cdr signature-body-list)))
405      `(,%letrec-syntax ,(map (lambda (sig body)
406                                `(,(car sig)
407                                  (,%macro-rules () 
408                                    (,(cons '_ (cdr sig)) ,@body))))
409                             signatures bodies)
410         ,xpr ,@xprs))))
411
412;;; (once-only (x ....) xpr ....)
413;;; -----------------------------
414;;; macro-arguments x .... are only evaluated once and from left to
415;;; right in the body xpr ....
416;;; The code is more or less due to
417;;; P. Seibel, Practical Common Lisp, p. 102
418(define-macro (once-only (x . xs) xpr . xprs)
419  (let ((syms (cons x xs)) (body (cons xpr xprs)))
420    (let ((gensyms (map (lambda (n) (gensym)) syms)))
421      `(let ,(map (lambda (g) `(,g ',(gensym))) gensyms)
422         `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
423                             gensyms syms))
424            ,(let ,(map (lambda (n g) `(,n ,g))
425                        syms gensyms)
426               ,@body))))))
427
428;;; (with-renamed-symbols (renamer . %syms) xpr . xprs)
429;;; ---------------------------------------------------
430(define-er-macro (with-renamed-symbols (renamer . syms) xpr . xprs)
431  %
432  `(,%let ,(map (lambda (s)
433                  `(,s (,renamer
434                    ',(string->symbol
435                       (substring (symbol->string s) 1)))))
436                syms)
437     ,xpr ,@xprs))
438
439;;; (with-gensyms (name ....) xpr ....)
440;;; -----------------------------------
441;;; binds name ... to (gensym 'name) ... in body xpr ...
442(define-macro (with-gensyms (name . names) xpr . xprs)
443  (let ((names (cons name names)) (body (cons xpr xprs)))
444    `(let ,(map (lambda (n) `(,n (gensym ',n))) names)
445       ,@body)))
446
447;;; (procedural-macros sym ..)
448;;; --------------------------
449;;; documentation procedure.
450(define procedural-macros
451  (let ((alst '(
452    (macro-rules
453      macro:
454      (macro-rules literal ... (keyword ...) (pat tpl) ....)
455      "procedural version of syntax-rules"
456      "with optional injected literals"
457      "and quasiquoted templates"
458      "To be imported for syntax")
459    (define-macro
460      macro:
461      (define-macro (name . args) (with-renaming (compare? %x ...) xpr ....))
462      (define-macro (name . args) xpr ....)
463      "where with-renaming is one of with-explicit- or with-implicit-renaming"
464      "and %x ... is the symbol x prefixed with one letter only."
465      "Defines an explicit- or implicit-renaming macro name,"
466      "automatically destructuring args with bind and creating local bindings"
467      "for compare? and %x ... to x ... renamed or injected respectively,"
468      "evaluating xpr ... in this context."
469      "The latter version is used if no keys are needed and nothing is"
470      "to be injected")
471    (define-er-macro
472      macro:
473      (define-er-macro (name . args) (where . fenders) prefix xpr . xprs)
474      (define-er-macro (name . args) prefix xpr . xprs)
475      (define-er-macro name (pat (where . fenders) prefix xpr . xprs) . others)
476      (define-er-macro name (pat prefix xpr . xprs) . others)
477      "where fenders check for keywords via key? predicate."
478      "Version of define-macro, where symbols prefixed with prefix"
479      "are automatically renamed.")
480    (define-ir-macro
481      macro:
482      (define-ir-macro (name . args) (where . fenders) prefix xpr . xprs)
483      (define-ir-macro (name . args) prefix xpr . xprs)
484      (define-ir-macro name (pat (where . fenders) prefix xpr . xprs) . others)
485      (define-ir-macro name (pat prefix xpr . xprs) . others)
486      "where fenders check for keywords via key? predicate."
487      "Version of define-macro, where symbols prefixed with prefix"
488      "are automatically injected.")
489    (macro-let
490      macro:
491      (macro-let (((name args) xpr ...) ...) body ....)
492      "evaluates body ... in the context of parallel macros name ....")
493    (macro-letrec
494      macro:
495      (macro-letrec (((name args) xpr ...) ...) body ....)
496      "evaluates body ... in the context of recursive macros name ....")
497    (once-only
498      macro:
499      (once-only (x ....) xpr ....)
500      "arguments x ... are evaluated only once and"
501      "from left to right in the body xpr ...."
502      "To be imported for syntax")
503    (with-renamed-symbols
504      macro:
505      (with-renamed-symbols (renamer %x ....) xpr ....)
506      "binds a series of names prefixed with one letter, e.g. %,
507      %x .... to the images of the original names, x ....,"
508      "under renamer and evaluates xpr .... in this context"
509      "To be imported for syntax")
510    (with-gensyms
511      macro:
512      (with-gensyms (x ....) xpr ....)
513      "binds x ... to (gensym 'x) ... in body xpr ...")
514    (procedural-macros
515      procedure:
516      "documaentation procedure: returns the list of exported symbols"
517      "if called with no arguments, or the documentation of its only"
518      "symbol argument")
519    )))
520    (case-lambda
521      (()
522       (map car alst))
523      ((sym)
524       (let ((lst (assq sym alst)))
525         (if lst
526           (for-each print (cdr lst))
527           (error 'procedural-macros
528                  "not exported" sym)))))))
529
530) ; module procedural-macros
531
Note: See TracBrowser for help on using the repository browser.