source: project/release/4/basic-macros/trunk/basic-macros.scm @ 34873

Last change on this file since 34873 was 34873, checked in by juergen, 4 years ago

basic-macros 1.2 with procedural bind-case to improve error message

File size: 25.6 KB
Line 
1;Author: Juergen Lorenz ; ju (at) jugilo (dot) de
2;
3; Copyright (c) 2017, 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#|[
34This library provides two modules, one with helper routines to be
35imported for syntax into the other with macros, which facilitate the
36writing of procedural-macros.
37
38Chicken provides two procedural macro-systems, implicit and explicit
39renaming macros. In both you have to destructure the use-form yourself
40and provide for the renaming or injecting of names which could or should
41be captured. Destructuring can be automated with the bind macro -- a
42simplified version of the equally named macro in the bindings library --
43and renaming resp. injecting can be almost automated with the help of
44either the macro with-mapped-symbols or two macro-generators, which
45replace the rename resp. inject parameter of the transformer with a
46prefix symbol. Note, that bind or with-mapped-symbols must be used
47for-syntax, if used in a macro body for destructuring or
48renaming/injecting.
49
50Usually an ambituous explicit renaming macro contains a long let
51defining the renamed symbols -- usually prefixed with some fixed symbol
52constant like % -- which is then executed in the macro's body by
53unquoting it. Both methods create the let automatically.
54
55Here are two simple examples, one the swap! macro, using
56define-er-macro-transformer and with-mapped-symbols, the other numeric if,
57using define-er-macro and and explicit prefix, %.
58In the latter case, the macro searches its body for symbols starting
59with this prefix, collects them in a list, removes duplicates and adds
60the necesary let with pairs of the form
61
62  (%name (rename 'name)
63
64to the front of the body. In other words it does what you usually do by
65hand.
66
67  (define-er-macro-transformer (swap! form rename compare?)
68    (let ((x (cadr form)) (y (caddr form)))
69      (with-mapped-symbols rename % (%tmp %let %set!)
70        `(,%let ((,%tmp ,x))
71           (,%set! ,x ,y)
72           (,%set! ,y ,%tmp)))))
73
74  (define-er-macro (nif form % compare?)
75    (bind (_ xpr pos zer neg) form
76      `(,%let ((,%result ,xpr))
77         (,%cond
78           ((,%positive? ,%result) ,pos)
79           ((,%negative? ,%result) ,neg)
80           (,%else ,zer)))))
81
82Note, that one of the standard arguments of an er-macro-transformer,
83rename, is replaced by the prefix, which characterize the symbols in the
84body to be renamed. The other arguments, form and compare?, remain
85untouched.
86
87
88For implicit renaming macros the list of injected symbols is usually,
89but not allways, short, even empty for nif. Of course, the generated let
90replaces rename with inject in this case.
91For example, here is a version of alambda, an anaphoric version of
92lambda, which injects the name self:
93
94  (define-ir-macro (alambda form % compare?)
95    (bind (_ args xpr . xprs) form
96      `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
97         ,%self)))
98
99]|#
100
101(module basic-macro-helpers *
102  (import scheme
103          (only chicken case-lambda assert print error))
104
105(define (pseudo-list sentinel . args)
106  (let loop ((args args))
107    (if (null? args)
108      sentinel
109      (cons (car args) (loop (cdr args))))))
110
111(define (pseudo-list? xpr)
112  #t)
113
114(define (pseudo-null? xpr)
115  (not (pair? xpr)))
116
117(define (pseudo-length pl)
118;; sentinel doesn't count in length!
119  (if (pair? pl)
120    (+ 1 (pseudo-length (cdr pl)))
121    0))
122
123(define (pseudo-sentinel pl)
124  (if (pair? pl)
125    (let ((rest (cdr pl)))
126      (if (pair? rest)
127        (pseudo-sentinel rest)
128        rest))
129    pl))
130
131(define (pseudo-ref pl n)
132  (assert (< n (pseudo-length pl)))
133  (cond
134    ((not (pair? pl)) pl)
135    ((= n 0) (car pl))
136    (else
137     (pseudo-ref (cdr pl) (- n 1)))))
138
139(define (pseudo-tail pl n)
140  (assert (<= n (pseudo-length pl)))
141  (cond
142    ((not (pair? pl)) pl)
143    ((= n 0) pl)
144    (else
145     (pseudo-tail (cdr pl) (- n 1)))))
146
147(define (pseudo-head pl n)
148  (assert (<= n (pseudo-length pl)))
149  (if (not (pair? pl))
150    '()
151    (let loop ((k 0) (pl pl) (result '()))
152      (if (= k n)
153        (reverse result)
154        (loop (+ k 1) (cdr pl) (cons (car pl) result))))))
155
156(define (pseudo-flatten tree)
157  ; imported flatten doesn't work with pseudo-lists
158  (let loop ((tree tree) (result '()))
159    (cond
160      ((pair? tree)
161       (loop (car tree) (loop (cdr tree) result)))
162      ((null? tree) result)
163      (else
164        (cons tree result)))))
165
166(define (remove-duplicates lst)
167  (let loop ((lst lst) (result '()))
168    (if (null? lst)
169      (reverse result)
170      (loop (cdr lst) (adjoin (car lst) result)))))
171
172(define (adjoin obj lst)
173  (if (member obj lst) lst (cons obj lst)))
174
175(define (filter ok? lst)
176  (let loop ((lst lst) (result '()))
177    (cond
178      ((null? lst) (reverse result))
179      ((ok? (car lst))
180       (loop (cdr lst) (cons (car lst) result)))
181      (else
182        (loop (cdr lst) result)))))
183
184(define (sym-prepends? pre sym)
185  (assert (symbol? pre))
186  (assert (symbol? sym))
187  (let ((spre (symbol->string pre))
188        (ssym (symbol->string sym)))
189    (let ((prelen (string-length spre))
190          (symlen (string-length ssym)))
191      (and (< prelen symlen)
192           (equal? (string->list spre)
193                   (string->list (substring ssym 0 prelen)))))))
194
195(define (sym-tail pre sym)
196  (let ((spre (symbol->string pre))
197        (ssym (symbol->string sym)))
198    (let ((prelen (string-length spre))
199          (symlen (string-length ssym)))
200      (string->symbol (substring ssym prelen)))))
201
202;;; (basic-macro-helpers sym ..)
203;;; ----------------------------
204;;; documentation procedure.
205(define basic-macro-helpers
206  (let ((alst '(
207    (pseudo-list
208      procedure:
209        (pseudo-list sentinel . args)
210        "creates a new pseudo-list from args"
211        "and sentinel")
212    (pseudo-list?
213      procedure:
214        (pseudo-list? xpr)
215        "is xpr a pseudo-list?"
216        "returns always #t")
217    (pseudo-null?
218      procedure:
219        (pseudo-null? xpr)
220        "is xpr pseudo-null?, i.e. not a pair")
221    (pseudo-length
222      procedure:
223        (pseudo-length pl)
224        "length of a pseudo-list pl"
225        "the sentinel doesn't count")
226    (pseudo-sentinel
227      procedure:
228        (pseudo-sentinel pl)
229        "returns the sentinel of a pseudo-list, i.e '()"
230        "in the case of a proper list")
231    (pseudo-ref
232      procedure:
233        (pseudo-ref pl n)
234        "returns the nth item of pl, where n is less than"
235        "pl's pseudo-length")
236    (pseudo-tail
237      procedure:
238        (pseudo-tail pl n)
239        "returns the tail of pl starting with index n, where n is"
240        "less than or equal to pl's pseudo-length")
241    (pseudo-head
242      procedure:
243        (pseudo-head pl n)
244        "returns the head of pl up to but excluding index n,"
245        "where n is less than or equal to pl's pseudo-length")
246    (pseudo-flatten
247      procedure:
248        (pseudo-flatten tree)
249        "flattens the nested pseudo-list tree to a proper list")
250    (remove-duplicates
251      procedure:
252        (remove-duplicates lst)
253        "removes duplicates of a proper list")
254    (adjoin
255      procedure:
256        (adjoin obj lst)
257        "adds obj to a proper list, provided, it isn't already there")
258    (filter
259      procedure:
260        (filter ok? lst)
261        "filters a proper list by means of a predicate ok?")
262    (sym-prepends?
263      procedure:
264        (sym-prepends? pre sym)
265        "checks, if the symbol sym starts with the symbol pre")
266    (sym-tail
267      procedure:
268        (sym-tail pre sym)
269        "returns the tail of the symbol sym by"
270        "stripping its prefix pre")
271    )))
272    (case-lambda
273      (()
274       (map car alst))
275      ((sym)
276       (let ((lst (assq sym alst)))
277         (if lst
278           (for-each print (cdr lst))
279           (error 'basic-macros
280                  "not exported" sym)))))))
281) ; module basic-macro-helpers
282
283(module basic-macros ;*
284  (define-syntax-rule define-er-macro-transformer define-ir-macro-transformer
285   define-er-macro define-ir-macro bind bind-case once-only basic-macros
286   with-mapped-symbols with-gensyms)
287  (import scheme basic-macro-helpers
288          (only chicken condition-case case-lambda print error))
289  (import-for-syntax; basic-macro-helpers)
290                      (except basic-macro-helpers
291                              pseudo-list
292                              pseudo-length
293                              pseudo-sentinel
294                              pseudo-list?))
295
296#|[Let's start with a one syntax-rule]|#
297
298;;; (define-syntax-rule (name . args) xpr . xprs)
299;;; (define-syntax-rule (name . args) (keywords . keys) xpr . xprs)
300;;; ---------------------------------------------------------------
301;;; simplyfies define-syntax in case there is only one rule
302(define-syntax define-syntax-rule
303  (syntax-rules (keywords)
304    ((_ (name . args)
305        (keywords key ...) xpr . xprs)
306     (define-syntax name
307       (syntax-rules (key ...)
308         ((_ . args) xpr . xprs))))
309    ((_ (name . args) xpr . xprs)
310     (define-syntax name
311       (syntax-rules ()
312         ((_ . args) xpr . xprs))))))
313
314#|[
315Let's start with some helpers which might be occasionally useful
316]|#
317
318;;; (define-er-macro-transformer form rename compare?)
319;;; --------------------------------------------------
320;;; wrapper around er-macro-transformer
321(define-syntax define-er-macro-transformer
322  (syntax-rules ()
323    ((_ (name form rename compare?) xpr . xprs)
324     (define-syntax name
325       (er-macro-transformer
326         (lambda (form rename compare?) xpr . xprs))))))
327
328;;; (define-ir-macro-transformer form inject compare?)
329;;; --------------------------------------------------
330;;; wrapper around ir-macro-transformer
331(define-syntax define-ir-macro-transformer
332  (syntax-rules ()
333    ((_ (name form inject compare?) xpr . xprs)
334     (define-syntax name
335       (ir-macro-transformer
336         (lambda (form inject compare?) xpr . xprs))))))
337
338#|[
339The following is Graham's dbind extended with  wildcards,
340non-symbol literals and length-checks. For example
341
342  (bind (x (y z)) '(1 (2 3)) (list x y z))
343
344will result in '(1 2 3)
345]|#
346
347;;; (do-bind pat seq xpr . xprs)
348;;; ----------------------------
349;;; internal helper to be wrapped in bind:
350;;; binds pattern variables of pat to corresponding subexpressions of
351;;; seq and executes body xpr . xprs in this context.
352(define-er-macro-transformer (do-bind form rename compare?)
353;(define-syntax do-bind
354;  (er-macro-transformer
355;    (lambda (form rename compare?)
356  (let ((pat (cadr form))
357        (seq (caddr form))
358        (xpr (cadddr form))
359        (xprs (cddddr form))
360        (%_ (rename '_))
361        (%if (rename 'if))
362        (%seq (rename 'seq))
363        (%and (rename 'and))
364        (%let (rename 'let))
365        (%not (rename 'not))
366        (%pair? (rename 'pair?))
367        (%begin (rename 'begin))
368        (%error (rename 'error))
369        (%equal? (rename 'equal?))
370        (%pseudo-ref (rename 'pseudo-ref))
371        (%pseudo-tail (rename 'pseudo-tail)))
372    (let ((body `(,%begin ,xpr ,@xprs)))
373      (letrec (
374        (no-dups?
375          (lambda (lst)
376            (call-with-current-continuation
377              (lambda (cc)
378                (let loop ((lst lst) (result '()))
379                  (if (null? lst)
380                    #t
381                    (loop (cdr lst)
382                          ;(if (memq (car lst) result)
383                          ;; keywords can be used as literals
384                          (if (and (not (keyword? (car lst)))
385                                   (memq (car lst) result))
386                            (cc #f)
387                            (cons (car lst) result)))))))))
388        (destructure
389          (lambda (pat seq)
390            (let ((len (let loop ((pat pat) (result 0))
391                         (cond
392                           ((null? pat) result)
393                           ((pair? pat)
394                            (loop (cdr pat) (+ 1 result)))
395                           (else result)))))
396              (let loop ((k 0) (pairs '()) (literals '()) (tails '()))
397                (if (= k len)
398                  (let ((sentinel
399                          ;last dotted item or '()
400                          (let loop ((result pat) (k len))
401                            (if (zero? k)
402                              result
403                              (loop (cdr result) (- k 1))))))
404                    (cond
405                      ((null? sentinel)
406                       (values pairs literals
407                               (cons ;`(,%pseudo-null?
408                                     ;   (,%pseudo-tail ,seq ,k))
409                                     `(,%not
410                                        (,%pair?
411                                          (,%pseudo-tail ,seq ,k)))
412                                     tails)))
413                      ((symbol? sentinel)
414                       (if (compare? sentinel %_)
415                         (values pairs literals tails)
416                         (values (cons (list sentinel
417                                             `(,%pseudo-tail ,seq ,k))
418                                       pairs)
419                                 literals tails)))
420                      (else
421                        (values pairs
422                                (cons `(,%equal? ',sentinel
423                                                 (,%pseudo-tail ,seq ,k))
424                                      literals)
425                                tails))))
426                  (let ((item (pseudo-ref pat k)))
427                    (cond
428                      ((and (symbol? item) (not (keyword? item)))
429                       (if (compare? item %_)
430                         (loop (+ k 1) pairs literals tails)
431                         (loop (+ k 1)
432                               (cons (list item `(,%pseudo-ref ,seq ,k)) pairs)
433                               literals
434                               tails)))
435                      ((pair? item)
436                       (call-with-values
437                         (lambda ()
438                           (destructure item `(,%pseudo-ref ,seq ,k)))
439                         (lambda (ps ls ts)
440                           (loop (+ k 1)
441                                 (append ps pairs)
442                                 (append ls literals)
443                                 (append ts tails)))))
444                      (else ;(atom? item) ; literal
445                        (loop (+ k 1)
446                              pairs
447                              (cons `(,%equal? ',item
448                                               (,%pseudo-ref ,seq ,k))
449                                    literals)
450                              tails))
451                      )))))))
452        )
453        (call-with-values
454          (lambda () (destructure pat seq))
455          (lambda (pairs literals tails)
456            (if (no-dups? (map car pairs))
457              `(,%if (,%and ,@tails)
458                     (,%if (,%and ,@literals)
459                           (,%let ,pairs ,body)
460                           (,%error 'bind "literals don't match" ',literals))
461                     (,%error 'bind "length mismatch" ',tails))
462              `(,%error 'bind
463                        "duplicate pattern variables"
464                        ',(map car pairs)))))
465          ))));))
466
467;;;; (bind pat seq xpr . xprs)
468;;;; (bind pat seq (where (x x? ...) ...) xpr . xprs)
469;;;; ------------------------------------------------
470;;;; binds pattern variables of pat to corresponding subexpressions of
471;;;; seq and executes body xpr . xprs in this context
472(define-syntax bind
473  (syntax-rules (where)
474    ((_ pat seq (where (x x? ...) ...) xpr . xprs)
475     (let ((%seq seq))
476       (do-bind pat %seq
477         (if (and (and (x? x) ...) ...)
478           (begin xpr . xprs)
479           (error 'bind "where-clause violated")))))
480    ((_ pat seq xpr . xprs)
481     (let ((%seq seq))
482       (do-bind pat %seq xpr . xprs)))))
483
484;;; (bind-case seq (pat xpr . xprs) ...)
485;;; (bind-case seq (pat (where . fenders) xpr . xprs) ...)
486;;; -------------------------------------------------------
487;;; Checks if seq matches pattern pat [satisfying fenders]
488;;; in sequence, binds the pattern variables of the first matching
489;;; pattern to corresponding subexpressions of seq and executes
490;;; corresponding body xpr . xprs
491(define-ir-macro-transformer (bind-case form inject compare?)
492  (let ((seq (cadr form))
493        (rules (cddr form))
494        (insert-where-clause
495          (lambda (rule)
496            (if (and (pair? (cadr rule))
497                     (compare? (caadr rule) 'where))
498              rule
499              `(,(car rule) (,(inject 'where)) ,@(cdr rule))))))
500    (let ((rules (map insert-where-clause rules))
501          (rule->bind
502            (lambda (rule)
503              `(bind ,(car rule) ,seq ,(cadr rule) ,@(cddr rule)))))
504      (let loop ((binds (map rule->bind rules)) (pats '()))
505        (if (null? binds)
506           `(error 'bind-case "no match"
507                   ,seq
508                   ',(reverse pats))
509           `(condition-case ,(car binds)
510              ((exn)
511               ,(loop (cdr binds)
512                      (cons (list (cadar binds) (car (cdddar binds)))
513                            pats)))))))))
514; the procedural version above improves the error message
515;(define-syntax bind-case
516;  (syntax-rules ()
517;    ((_ seq)
518;     (error 'bind-case "no match, possibly caused by fenders, for" seq))
519;    ((_ seq (pat (where . fenders) xpr . xprs))
520;     (condition-case (bind pat seq (where . fenders) xpr . xprs)
521;       ((exn) (bind-case seq))))
522;    ((_ seq (pat xpr . xprs))
523;     (bind-case seq (pat (where) xpr . xprs)))
524;    ((_ seq clause . clauses)
525;     (condition-case (bind-case seq clause)
526;       ((exn) (bind-case seq . clauses))))
527;    ))
528
529;;; (once-only (x ....) xpr ....)
530;;; -----------------------------
531;;; macro-arguments x .... are only evaluated once and from left to
532;;; right in the body xpr ....
533;;; The code is more or less due to
534;;; P. Seibel, Practical Common Lisp, p. 102
535;(define-syntax once-only
536;  (er-macro-transformer
537;    (lambda (form rename compare?)
538(define-er-macro-transformer (once-only form rename compare?)
539  (let ((names (cadr form))
540        (body (cons (caddr form) (cdddr form)))
541        (%let (rename 'let))
542        (%list (rename 'list))
543        )
544    (let ((syms (map rename names)))
545      `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) syms)
546         `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
547                               syms names))
548            ,(,%let ,(map (lambda (n g) `(,n ,g))
549                        names syms)
550               ,@body))))));))
551;(define-ir-macro-transformer (once-only form inject compare?)
552;  (let ((names (cadr form))
553;        (body (cons (caddr form) (cdddr form))))
554;    (let ((gensyms (map (lambda (x) (gensym)) names)))
555;      `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
556;         `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
557;                             gensyms names))
558;            ,(let ,(map (lambda (n g) `(,n ,g))
559;                        names gensyms)
560;               ,@body))))))
561;
562
563;;; (define-macro-with (name form prefix compare? transformer) xpr . xprs)
564;;; ----------------------------------------------------------------------
565;;; internal helper
566(define-syntax define-macro-with
567  (er-macro-transformer
568    (lambda (form rename compare?)
569      (let (
570        (header (cadr form))
571        (body (cons (caddr form) (cdddr form)))
572        )
573        (let (
574          (name (car header))
575          (frm (cadr header))
576          (pre (caddr header))
577          (cmp? (cadddr header))
578          (transformer (car (cddddr header)))
579          (ren 'process)
580          (%let (rename 'let))
581          (%lambda (rename 'lambda))
582          (%define-syntax (rename 'define-syntax))
583          )
584          `(,%define-syntax ,name
585             (,transformer
586               (,%lambda (,frm ,ren ,cmp?)
587                 (,%let ,(map (lambda (sym)
588                                `(,sym (,ren ',(sym-tail pre sym))))
589                              (remove-duplicates
590                                (filter (lambda (sym)
591                                          (and (symbol? sym)
592                                               (sym-prepends? pre sym)))
593                                        (pseudo-flatten body))))
594                   ,@body)))))))))
595
596;;; (define-er-macro (name form rename-prefix compare?) xpr . xprs)
597;;; ---------------------------------------------------------------
598;;; defines an explicit-renaming macro name with use-form form,
599;;; automatically renaming symbols starting with inject-rpefix
600(define-syntax define-er-macro
601  (syntax-rules ()
602    ((_ (name form rename-prefix compare?) xpr . xprs)
603     (define-macro-with
604       (name form rename-prefix compare? er-macro-transformer)
605       xpr . xprs))))
606
607;;; (define-ir-macro (name form inject-prefix compare?) xpr . xprs)
608;;; ---------------------------------------------------------------
609;;; defines an implicit-renaming macro name with use-form form,
610;;; automatically injecting symbols starting with inject-rpefix
611(define-syntax define-ir-macro
612  (syntax-rules ()
613    ((_ (name form inject-prefix compare?) xpr . xprs)
614     (define-macro-with
615       (name form inject-prefix compare? ir-macro-transformer)
616       xpr . xprs))))
617
618;;; (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
619;;; -------------------------------------------------------------
620;;; binds a series of prefixed names, prefix-x ....
621;;; to the images of the original names, x ...., under mapper
622;;; and evaluates xpr .... in this context
623(define-syntax with-mapped-symbols
624  (er-macro-transformer
625    (lambda (form rename compare?)
626      (let ((mapper (cadr form))
627            (prefix (caddr form))
628            (syms (cadddr form))
629            (xpr (car (cddddr form)))
630            (xprs (cdr (cddddr form)))
631            (%let (rename 'let)))
632        `(,%let ,(map (lambda (s)
633                        `(,s (,mapper ',(sym-tail prefix s))))
634                      syms)
635           ,xpr ,@xprs)))))
636
637;;; (with-gensyms (name ....) xpr ....)
638;;; -----------------------------------
639;;; binds name ... to (gensym 'name) ... in body xpr ...
640(define-syntax with-gensyms
641  (ir-macro-transformer
642    (lambda (form inject compare?)
643      `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
644         ,@(cddr form)))))
645
646
647;;; (basic-macros sym ..)
648;;; ---------------------
649;;; documentation procedure.
650(define basic-macros
651  (let ((alst '(
652    (define-syntax-rule
653      macro:
654       (define-syntax-rule (name . args) xpr . xprs)
655       (define-syntax-rule (name . args) (keywords . keys) xpr . xprs)
656       "simplyfied version of syntax-rules,"
657       "if there is only one rule")
658    (bind
659      macro:
660      (bind pat seq (where fender ...) .. xpr ....)
661      "a variant of Common Lisp's destructuring-bind"
662      "where pat and seq are a nested pseudo-lists and"
663      "optional fenders of the form (x x? ...) are checked"
664      "before evaluating the body xpr ...")
665    (bind-case
666      macro:
667      (bind-case seq (pat (where fender ...) .. xpr ...) ....)
668      "matches a nested pseudo-list seq against nested pseudo-lists"
669      "pat ... with optional fenders ... in sequence in a case regime")
670    (once-only
671      macro:
672      (once-only (x ....) xpr ....)
673      "arguments x ... are evaluated only once and"
674      "from left to right in the body xpr ....")
675    (define-er-macro-transformer
676      macro:
677      (define-er-macro-tansformer name form rename compare?)
678      "wrapper around er-macro-transformer")
679    (define-ir-macro-transformer
680      macro:
681      (define-ir-macro-tansformer name form inject compare?)
682      "wrapper around ir-macro-transformer")
683    (define-er-macro
684      macro:
685      (define-er-macro name form rename-prefix compare?)
686      "creates an explicit-renaming macro, where all symbols"
687      "starting with rename-prefix are renamed automatically")
688    (define-ir-macro
689      macro:
690      (define-ir-macro name form inject-prefix compare?)
691      "creates an implicit-renaming macro, where all symbols"
692      "starting with inject-prefix are injected automatically")
693    (with-mapped-symbols
694      macro:
695      (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
696      "binds a series of prefixed names, prefix-x ...."
697      "to the images of the original names, x ...., under mapper"
698      "and evaluates xpr .... in this context")
699    (with-gensyms
700      macro:
701      (with-gensyms (x ....) xpr ....)
702      "generates a series of gensyms x .... to be used in body xpr ...")
703    )))
704    (case-lambda
705      (()
706       (map car alst))
707      ((sym)
708       (let ((lst (assq sym alst)))
709         (if lst
710           (for-each print (cdr lst))
711           (error 'basic-macros
712                  "not exported" sym)))))))
713
714) ; module basic-macros
Note: See TracBrowser for help on using the repository browser.