source: project/release/4/list-bindings/trunk/list-bindings.scm @ 29858

Last change on this file since 29858 was 29858, checked in by juergen, 8 years ago

bind-lambda and bind-case-lambda added

File size: 21.7 KB
Line 
1#|[
2Author: Juergen Lorenz
3ju (at) jugilo (dot) de
4
5Copyright (c) 2013, Juergen Lorenz
6All rights reserved.
7
8Redistribution and use in source and binary forms, with or without
9modification, are permitted provided that the following conditions are
10met:
11
12Redistributions of source code must retain the above copyright
13notice, this list of conditions and the following disclaimer.
14
15Redistributions in binary form must reproduce the above copyright
16notice, this list of conditions and the following disclaimer in the
17documentation and/or other materials provided with the distribution.
18
19Neither the name of the author nor the names of its contributors may be
20used to endorse or promote products derived from this software without
21specific prior written permission.
22
23THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
26PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
27HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
29TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34
35This module provides simplyfied versions of some of the bindings
36macros, restricting destructuring to nested list expressions, as well
37as macros making the writing of low-level-macros easy.
38]|# 
39
40(module list-bindings
41  (export list-bindings bind-define bind-set! bind bindable? bind-lambda
42          bind-case bind-case-lambda bind/cc bind-let bind-let*
43          define-syntax-rule define-macro let-macro letrec-macro)
44  (import scheme
45          (only chicken condition-case error)
46          (only extras format))
47
48#|[
49Binding macros
50==============
51]|# 
52
53;;; (bindable? pat)
54;;; ---------------
55;;; returns a procedure, which checks, if subexpressions of its only
56;;; agument, tpl, are bindable to the pattern variables of pat.
57(define-syntax bindable?
58  (syntax-rules ()
59    ((_ (a . b))
60     (lambda (seq)
61       (and (pair? seq)
62            ((bindable? a) (car seq))
63            ((bindable? b) (cdr seq)))))
64    ((_ ())
65     (lambda (seq) (null? seq)))
66    ((_ a) (lambda (seq) #t))))
67
68;;; (bind pat seq . body)
69;;; --------------------------
70;;; Common Lisp's destructuring-bind:
71;;; binds pattern variables of pat to corresponding subexpression of
72;;; seq and evalueates body in this context
73(define-syntax bind
74  (syntax-rules ()
75    ((_(a . b) seq xpr . xprs)
76     (if (pair? seq)
77       (bind a (car seq) (bind b (cdr seq) xpr . xprs))
78       (error 'bind
79              (format #f "template ~s doesn't match pattern ~s"
80                      seq '(a . b)))))
81    ((_ () seq xpr . xprs)
82     (if (null? seq)
83       (let () xpr . xprs)
84       (error 'bind
85              (format #f "template ~s doesn't match pattern ~s"
86                      seq '()))))
87    ((_ a seq xpr . xprs)
88     (let ((a seq)) xpr . xprs))))
89;(define-syntax bind
90;  (ir-macro-transformer
91;    (lambda (form inject compare?)
92;      (let ((pat (cadr form))
93;            (seq (caddr form))
94;            (xpr (cadddr form))
95;            (xprs (cddddr form)))
96;        `(if ((bindable? ,pat) ,seq)
97;          (let
98;             ,(map (lambda (ks)
99;                     `(,(apply tree-ref pat ks)
100;                        (tree-ref ,seq ,@(quote-last ks))))
101;                   (pindex pat))
102;             ,xpr ,@xprs)
103;          (error 'bind
104;                 (format #f "template ~s doesn't match pattern ~s"
105;                         ,seq ',pat)))))))
106;(define-syntax bind
107;  (er-macro-transformer
108;    (lambda (form rename compare?)
109;      (let ((pat (cadr form))
110;            (seq (caddr form))
111;            (xpr (cadddr form))
112;            (xprs (cddddr form))
113;            (%if (rename 'if))
114;            (%let (rename 'let))
115;            (%error (rename 'error))
116;            (%format (rename 'format))
117;            (%bindable? (rename 'bindable?))
118;            (%tree-ref (rename 'tree-ref)))
119;        `(,%if ((,%bindable? ,pat) ,seq)
120;          (,%let
121;             ,(map (lambda (ks)
122;                     `(,(apply tree-ref pat ks)
123;                        (,%tree-ref ,seq ,@(quote-last ks))))
124;                   (pindex pat))
125;             ,xpr ,@xprs)
126;          (,%error 'bind
127;                   (,%format #f "template ~s doesn't match pattern ~s"
128;                             ,seq ',pat)))))))
129
130;;; (bind-lambda pat xpr . xprs)
131;;; ------------------------------
132;;; Combination of bind and lambda
133(define-syntax bind-lambda
134  (syntax-rules ()
135    ((_ pat xpr . xprs)
136     (lambda (x)
137       (bind pat x xpr . xprs)))))
138
139;;; (bind-case seq (pat xpr . xprs) ....)
140;;; -------------------------------------
141;;; Checks if seq matches pattern pat in sequence, binds the pattern
142;;; variables of the first matching pattern to corresponding sublists of
143;;; seq and executes corresponding body xpr . xprs
144(define-syntax bind-case
145  (syntax-rules ()
146    ((_ seq (pat0  xpr0 . xprs0) (pat1 xpr1 . xprs1) ...)
147     (cond
148       (((bindable? pat0) seq)
149        (bind pat0 seq  xpr0 . xprs0))
150       (((bindable? pat1) seq)
151        (bind pat1 seq  xpr1 . xprs1))
152       ...
153       (else
154         (error 'bind-case (format #f "template ~s doesn't match any of the patterns ~s"
155                                   seq '(pat0 pat1 ...))))))))
156
157;;; (bind-case-lambda (pat  xpr . xprs) ....)
158;;; -----------------------------------------
159;;; combination of lambda and bind-case
160(define-syntax bind-case-lambda
161  (syntax-rules ()
162    ((_ (pat xpr . xprs))
163     (lambda (x) (bind pat x xpr . xprs)))
164    ((_ clause . clauses)
165     (lambda (x)
166       (bind-case x clause . clauses)))))
167
168
169#|[
170The next two macros provide simultaneous setting and defining of pattern
171variables to subexpressions of a template. The following first try would
172perfectly work, if seq is simply a list, but not if it is a list wrapped
173by a let storing common state. But the latter is the most often used
174case of bind-define.
175
176(define-syntax bind-define
177  (syntax-rules ()
178    ((_ (a . b) seq)
179     (begin
180       (bind-define a (car seq))
181       (bind-define b (cdr seq))))
182    ((_ () seq)
183     (if (null? seq) (void) (error 'bind-define "match error")))
184    ((_ a seq)
185     (define a seq))))
186
187What we need is one further indirection provided in the following
188versions, which first map the pattern, pat, to some auxiliary pattern,
189aux, of the same form with gensym.
190In bind-set! the template, seq, is then bound to some variable x which
191in turn can be bound to aux in the macro expansion. Since we used gensym
192instead of rename above, there will be no name-clash - rename is
193referentially transparent!
194We could have used implicit-renaming macros as well, but then the
195gensyms would be automatically renamed again, which isn't necessary.
196Note, that there is some code duplication in the two macros below, which
197could have been avoided by defining two helpers, pmap and pflatten, in a
198separate helper module which must be imported for syntax. I've done this
199in a former version.
200]|#
201
202;;; (bind-set! pat seq)
203;;; -------------------
204;;; sets pattern variables of the pattern pat to corresponding
205;;; subexpressions of the template seq
206(define-syntax bind-set!
207  (er-macro-transformer
208    (lambda (form rename compare?)
209      (let ((pat (cadr form)) (seq (caddr form)))
210        (let ((aux (let recur ((pat pat))
211                     (cond
212                       ((null? pat) '())
213                       ((symbol? pat) (gensym))
214                       ((pair? pat)
215                        (cons (recur (car pat)) (recur (cdr pat)))))))
216              ; rename would potentially clash with the %x below
217              (%bind (rename 'bind))
218              (%set! (rename 'set!))
219              (%let (rename 'let))
220              (%x (rename 'x)))
221          `(,%let ((,%x ,seq))
222             (,%bind ,aux ,%x
223               ,@(let recur ((pat pat) (aux aux))
224                   (cond
225                     ((null? pat) '())
226                     ((symbol? pat) `((set! ,pat ,aux)))
227                     ((pair? pat)
228                      (append (recur (car pat) (car aux))
229                              (recur (cdr pat) (cdr aux)))))))))))))
230;(define-syntax bind-set!
231;  (ir-macro-transformer
232;    (lambda (form inject compare?)
233;      (let ((pat (cadr form)) (seq (caddr form)))
234;        (let ((aux (pmap gensym pat)))
235;          `(let ((x ,seq))
236;             (bind ,aux x
237;               ,@(map (lambda (p a) `(set! ,p ,a))
238;                      (pflatten pat) (pflatten aux)))))))))
239
240;;; (bind-define pat seq)
241;;; ---------------------
242;;; defines pattern variables of the pattern pat by setting them to
243;;; corresponding subexpressions of the template seq
244(define-syntax bind-define
245  (er-macro-transformer
246    (lambda (form rename compare?)
247      (let ((pat (cadr form)) (seq (caddr form)))
248        (let ((aux (let recur ((pat pat))
249                     (cond
250                       ((null? pat) '())
251                       ((symbol? pat) (gensym))
252                       ((pair? pat)
253                        (cons (recur (car pat)) (recur (cdr pat)))))))
254              (%bind-set! (rename 'bind-set!))
255              (%define (rename 'define))
256              (%begin (rename 'begin)))
257          `(,%begin
258             (,%bind-set! ,aux ,seq)
259             ,@(let recur ((pat pat) (aux aux))
260                 (cond
261                   ((null? pat) '())
262                   ((symbol? pat) `((set! ,pat ,aux)))
263                   ((pair? pat)
264                    (append (recur (car pat) (car aux))
265                            (recur (cdr pat) (cdr aux))))))))))))
266;(define-syntax bind-define
267;  (ir-macro-transformer
268;    (lambda (form inject compare?)
269;      (let ((pat (cadr form)) (seq (caddr form)))
270;        (let ((aux (pmap gensym pat)))
271;          `(begin
272;             (bind-set! ,aux ,seq)
273;             ,@(map (lambda (p a) `(define ,p ,a))
274;                    (pflatten pat) (pflatten aux))))))))
275
276;;; (bind-let* ((pat seq) ...) xpr . xprs)
277;;; --------------------------------------
278(define-syntax bind-let*
279  (syntax-rules ()
280    ((_ () xpr . xprs)
281     (let () xpr . xprs))
282    ((_ ((pat0 seq0) (pat1 seq1) ...) xpr . xprs)
283     (bind pat0 seq0
284       (bind-let* ((pat1 seq1) ...) xpr . xprs)))))
285
286;;; (bind-let ((pat seq) ...) xpr . xprs)
287;;; -------------------------------------
288(define-syntax bind-let
289  (ir-macro-transformer
290    (lambda (form inject compare?)
291      (let ((binds (cadr form))
292            (xpr (caddr form))
293            (xprs (cdddr form)))
294        (let ((syms (map (lambda (x) (gensym)) binds)))
295          `(bind ,syms ,(cons 'list (map cadr binds))
296             (bind-let* ,(map (lambda (p s) `(,p ,s))
297                              (map car binds)
298                              syms)
299               ,xpr ,@xprs)))))))
300
301;;; (bind/cc k xpr . xprs)
302;;; ----------------------
303(define-syntax bind/cc
304  (syntax-rules ()
305    ((_ k xpr . xprs)
306     (call-with-current-continuation
307       (lambda (k) xpr . xprs)))))
308
309#|[
310Low-level-macros made easy
311==========================
312As an application of our binding macros, especially bind, we will now
313provide macros define-macro, letrec-macro and let-macro to make
314low-level macros easy.
315
316The following two macros are internal. They are only used in
317define-macro below
318]|#
319
320;;; (define-ir-macro (name . args)
321;;;   (injecting (identifier ...)
322;;;     (comparing ()|(suffix . suffixed-keywords)
323;;;       . body)))
324;;; -------------------------------------------------
325;;; where transformer is a unary procedure accepting
326;;; ir-macro-transformer' s last parameter, compare?
327(define-syntax define-ir-macro
328  (ir-macro-transformer
329    (lambda (f i c?)
330      (let ((macro-code (cadr f))
331            (inject-xpr (caddr f))
332            (strip-suffix
333              (lambda (suf id)
334                (let ((sufstring (symbol->string suf))
335                      (idstring (symbol->string id)))
336                  (string->symbol
337                    (substring idstring
338                               0 
339                               (- (string-length idstring)
340                                  (string-length sufstring))))))))
341        (let ((name (car macro-code))
342              (args (cdr macro-code))
343              (identifiers (cadr inject-xpr))
344              (compare-xpr (caddr inject-xpr)))
345          (let ((predicates (cadr compare-xpr))
346                (body (caddr compare-xpr)))
347            (cond
348              ((and (null? identifiers) (null? predicates))
349               `(define-syntax ,name
350                  (ir-macro-transformer
351                    (lambda (form inject compare?)
352                      (bind ,args (cdr form)
353                        ,body)))))
354              ((null? predicates)
355               `(define-syntax ,name
356                  (ir-macro-transformer
357                    (lambda (form inject compare?)
358                      (bind ,args (cdr form)
359                        (bind ,identifiers (map inject ',identifiers)
360                          ,body))))))
361              (else
362                (let ((suffix (car predicates))
363                      (suffixed-keywords (cdr predicates)))
364                  (let ((syms (map (lambda (id) (strip-suffix suffix id))
365                                   suffixed-keywords)))
366                    (if (null? identifiers)
367                      `(define-syntax ,name
368                         (ir-macro-transformer
369                           (lambda (form inject compare?)
370                             (bind ,args (cdr form)
371                               (bind ,suffixed-keywords
372                                 (list ,@(map (lambda (s)
373                                                `(lambda (n)
374                                                   (compare? n ',(i s))))
375                                              syms))
376                                 ,body)))))
377                      `(define-syntax ,name
378                         (ir-macro-transformer
379                           (lambda (form inject compare?)
380                             (bind ,args (cdr form)
381                               (bind ,identifiers (map inject ',identifiers)
382                                 (bind ,suffixed-keywords
383                                   (list ,@(map (lambda (s)
384                                                  `(lambda (n)
385                                                     (compare? n ',(i s))))
386                                                syms))
387                                   ,body)))))))))))))))))
388
389;;; (define-er-macro (name . args)
390;;;   (renaming (prefix . prefixed-identifiers)
391;;;     (comparing ()|(suffix . suffixed-keywords)
392;;;     . body)))
393;;; -------------------------------------------------
394;;; where transformer is a unary procedure accepting
395;;; er-macro-transformer' s last parameter, compare?
396(define-syntax define-er-macro
397  (er-macro-transformer
398    (lambda (f r c?)
399      (let ((macro-code (cadr f))
400            (rename-xpr (caddr f))
401            (strip-prefix (lambda (pre id)
402                            (string->symbol
403                              (substring (symbol->string id)
404                                         (string-length
405                                           (symbol->string pre))))))
406            (strip-suffix
407              (lambda (suf id)
408                (let ((sufstring (symbol->string suf))
409                      (idstring (symbol->string id)))
410                  (string->symbol
411                    (substring idstring
412                               0 
413                               (- (string-length idstring)
414                                  (string-length sufstring))))))))
415        (let ((name (car macro-code))
416              (args (cdr macro-code))
417              (prefix (caadr rename-xpr))
418              (prefixed-identifiers (cdadr rename-xpr))
419              (compare-xpr (caddr rename-xpr)))
420          (let ((identifiers (map (lambda (id) (strip-prefix prefix id))
421                                  prefixed-identifiers))
422                (predicates (cadr compare-xpr))
423                (body (caddr compare-xpr))
424                (%er-macro-transformer (r 'er-macro-transformer))
425                (%define-syntax (r 'define-syntax))
426                (%compare? (r 'compare?))
427                (%rename (r 'rename))
428                (%lambda (r 'lambda))
429                (%bind (r 'bind))
430                (%list (r 'list))
431                (%form (r 'form))
432                (%cdr (r 'cdr))
433                (%map (r 'map)))
434            (if (null? predicates)
435              `(,%define-syntax ,name
436                  (,%er-macro-transformer
437                    (,%lambda (,%form ,%rename ,%compare?)
438                      (,%bind ,args (,%cdr ,%form)
439                              (,%bind ,prefixed-identifiers
440                                      (,%map ,%rename ',identifiers)
441                                ,body)))))
442              (let ((suffix (car predicates))
443                    (suffixed-keywords (cdr predicates)))
444                (let ((syms (map (lambda (id) (strip-suffix suffix id))
445                                 suffixed-keywords)))
446                  `(,%define-syntax ,name
447                      (,%er-macro-transformer
448                        (,%lambda (,%form ,%rename ,%compare?)
449                          (,%bind ,args (,%cdr ,%form)
450                            (,%bind ,prefixed-identifiers
451                                    (,%map ,%rename ',identifiers)
452                              (,%bind ,suffixed-keywords
453                                      (,%list ,@(map (lambda (s)
454                                                       `(lambda (n)
455                                                          (,%compare? n (,%rename ',s))))
456                                                     syms))
457                                      ,body)))))))))))))))
458
459;;; (define-macro (name . args)
460;;;   [(injecting (identifier ...) | (renaming (prefix . prefixed-identifiers))]
461;;;     [(comaring (suffix . suffixed-keywords)]
462;;;       . body)))
463;;; ----------------------------------------------------------------------------
464(define-syntax define-macro
465  (ir-macro-transformer 
466    (lambda (form inject compare?)
467      (if (not (= (length form) 3))
468        (error 'define-macro "macro-code doesn't match pattern"
469               '(_ macro-code body))
470        (let ((macro-code (cadr form)) (body (caddr form)))
471          ;; create standard body
472          (let ((body (if (and (list? body)
473                               (= (length body) 3)
474                               (list? (cadr body)))
475                        (cond
476                          ((compare? (car body) 'comparing)
477                           `(injecting () ,body))
478                          ((compare? (car body) 'injecting)
479                           (let ((rest (caddr body)))
480                             (if (and (list? rest)
481                                      (= (length rest) 3)
482                                      (list? (cadr rest))
483                                      (compare? (car rest) 'comparing))
484                               body
485                               `(injecting ,(cadr body)
486                                  (comparing () ,(caddr body))))))
487                          ((compare? (car body) 'renaming)
488                           (let ((rest (caddr body)))
489                             (if (and (list? rest)
490                                      (= (length rest) 3)
491                                      (list? (cadr rest))
492                                      (compare? (car rest) 'comparing))
493                               body
494                               `(renaming ,(cadr body)
495                                 (comparing () ,(caddr body))))))
496                          (else
497                            (error 'define-macro "not a macro body" body)))
498                        `(injecting ()
499                          (comparing () ,body)))))
500            (if (compare? (car body) 'injecting)
501              `(define-ir-macro ,macro-code ,body)
502              `(define-er-macro ,macro-code ,body))))))))
503
504;;; (letrec-macro ((macro-code tpl) ...) . body)
505;;; --------------------------------------------
506;;; defines local macros by binding recursively macro-codes to templates
507;;; and evaluating body in this context.
508(define-syntax letrec-macro
509  (er-macro-transformer
510    (lambda (f r c?)
511      (let ((binds (cadr f))
512            (body (cddr f))
513            (%letrec-syntax (r 'letrec-syntax)))
514        `(,%letrec-syntax
515           ,(map (lambda (m)
516                   `(,(cadr m) ,(caddr m)))
517                 (map (lambda (b)
518                        (expand `(define-macro ,@b)))
519                      binds))
520           ,@body)))))
521
522;;; (let-macro ((macro-code tpl) ...) . body)
523;;; -----------------------------------------
524;;; defines local macros by binding in parallel macro-codes to templates
525;;; and evaluating body in this context.
526(define-syntax let-macro
527  (er-macro-transformer
528    (lambda (f r c?)
529      (let ((binds (cadr f))
530            (body (cddr f))
531            (%let-syntax (r 'let-syntax)))
532        `(,%let-syntax
533           ,(map (lambda (m)
534                   `(,(cadr m) ,(caddr m)))
535                 (map (lambda (b)
536                        (expand `(define-macro ,@b)))
537                      binds))
538           ,@body)))))
539
540;;; (define-syntax-rule (macro-code) tpl)
541;;; -------------------------------------
542;;; simplyfies define-syntax in case there are no auxiliary keywords
543;;; and only one syntax-rule.
544(define-syntax define-syntax-rule
545  (syntax-rules ()
546    ((_ (name . args) tpl)
547     (define-syntax name
548       (syntax-rules ()
549         ((_ . args) tpl))))))
550
551(define (list-bindings)
552  '(bind-define bind-set! bind bind-lambda bind-let* bind-let bind-case bindable? bind/cc
553    define-macro let-macro letrec-macro define-syntax-rule))
554
555) ; module list-bindings
Note: See TracBrowser for help on using the repository browser.