source: project/release/4/bindings/trunk/bindings.scm @ 34875

Last change on this file since 34875 was 34875, checked in by juergen, 2 years ago

bindings 7.1 with procedural bind-case to improve error message

File size: 33.6 KB
Line 
1; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
2;
3; Copyright (c) 2013-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
34#|[
35
36The fundamental macro defined in this library is bind. It's like
37destructuring-bind in Common Lisp and dbind in Graham's classic On Lisp,
38but with some extensions, in particular, wildcards, non-symbol literals
39and fenders.
40
41The syntax is as follows
42
43  (bind pat seq [(where . fenders)] . body)
44
45It destructures the seq argument according to the pat argument, binds
46pattern variables to corresponding sequence items and executes body in
47this context. For example
48
49  (bind (x (y z) . w) '(1 #(2 3) 4 5) (where (y even?)) (list x y z w))
50
51will return '(1 2 3 (4 5)).
52
53(Note that the position of the optional fenders, supplied in a where
54clause, has changed again in this version: It's now always on top of the body.
55This simplyfies implementation and usage of the library).
56
57This version of the library is a complete rewrite. The code no longer
58uses Graham's dbind implementation. Instead, a direct implementation of
59bind is given, which doesn't need gensyms. The internal destructure
60routine transforms the pattern and sequence arguments into three lists,
61pairs, literals and tails. Pairs is a list of pattern-variable and
62corresponding sequence-accesscode pairs to be used in a let at runtime,
63literals and tails check for equality of literals and their
64corresponding sequence values, and the emptyness of sequence tails
65corresponding to null patterns respectively. So, contrary to Graham's
66dbind, an exception is raised if the lengths of a pattern and its
67corresponding sequence don't match. Fenders are supplied in a where
68clause at the very beginning of the macro body: A list of
69pattern-variable predicates pairs is internally transformed into a list
70of predicate calls.
71
72Sequences are either lists, psuedolists, tagged-vectors, vectors or
73strings by default.  The sequence operators needed are seq-ref, seq-tail
74and seq-null? with the same syntax as the likely named list routines.
75But there is a procedure, seq-db, which allows to add a pair consisting
76of a type predicate and a vector containing the needed operators to a
77database. All these are implemented in the basic-sequences egg, on which
78this version of the library depends.  The database routine, seq-db, is
79reexported from there.
80
81This version of the library adds algebraic types, to be accessed with
82the binding routines, thus avoiding define-datatype or
83define-concrete-type.
84
85]|#
86
87(require-library basic-sequences simple-exceptions)
88
89(module bindings
90  (bind bind-case bind-lambda bind-lambda* bind-case-lambda
91   bind-case-lambda* bind-named bind-let bind-let* bind-letrec bindrec
92   bindable? bind-define bind-set! bind/cc bindings
93   define-algebraic-type)
94
95  (import scheme basic-sequences
96          (only chicken condition-case receive error)
97          (only simple-exceptions raise <<)
98          )
99  (import-for-syntax (only chicken receive)
100                     (only data-structures chop))
101
102  (reexport (only basic-sequences seq-db))
103 
104;;; simple explicit-renaming  macros
105;;; ---------------------------------
106(define-syntax define-er-macro-transformer
107  (syntax-rules ()
108    ((_ (name form rename compare?) xpr . xprs)
109     (define-syntax name
110       (er-macro-transformer
111         (lambda (form rename compare?) xpr . xprs))))))
112
113#|[
114First, a helper macro, which allows to implement bind as well
115as a recursive version of it, bindrec, in one go.
116It does all of the dirty work,
117]|#
118
119;;; (bind-with binder pat seq xpr . xprs)
120;;; -------------------------------------
121;;; where binder is let or letrec
122(define-er-macro-transformer (bind-with form rename compare?)
123  (let ((binder (cadr form))
124        (pat (caddr form))
125        (seq (cadddr form))
126        (xpr (car (cddddr form)))
127        (xprs (cdr (cddddr form)))
128        (%and (rename 'and))
129        (%where (rename 'where))
130        (%_ (rename '_))
131        (%if (rename 'if))
132        (%raise (rename 'raise))
133        (%begin (rename 'begin))
134        (%error (rename 'error))
135        (%equal? (rename 'equal?))
136        (%seq-ref (rename 'seq-ref))
137        (%seq-tail (rename 'seq-tail))
138        (%seq-null? (rename 'seq-null?))
139        (%seq-exception (rename 'seq-exception)))
140    (let* ((fenders? (and (pair? xpr)
141                        (compare? (car xpr) %where)))
142           (where-clause (if fenders? 
143                             xpr                 
144                             '(where)))
145           (fenders
146             (apply append
147                    (map (lambda (pair)
148                           (map (lambda (p?)
149                                  `(,p?  ,(car pair)))
150                                (cdr pair)))
151                         (cdr where-clause))))
152           (body (if fenders?
153                   `(,%if (,%and ,@fenders)
154                      (,%begin ,@xprs)
155                      (,%raise (,%seq-exception
156                                 'bind
157                                 "fenders not passed"
158                                 ',fenders)))
159                   `(,%begin ,xpr ,@xprs))))
160      (letrec (
161        (no-dups?
162          (lambda (lst)
163            (call-with-current-continuation
164              (lambda (cc)
165                (let loop ((lst lst) (result '()))
166                  (if (null? lst)
167                    #t
168                    (loop (cdr lst)
169                          ;(if (memq (car lst) result)
170                          ;; keywords can be used as literals
171                          (if (and (not (keyword? (car lst)))
172                                   (memq (car lst) result))
173                            (cc #f)
174                            (cons (car lst) result)))))))))
175        (destructure
176           (lambda (pat seq)
177             (let ((len (let loop ((pat pat) (result 0))
178                          (cond
179                            ((null? pat) result)
180                            ((pair? pat)
181                             (loop (cdr pat) (+ 1 result)))
182                            (else result)))))
183               (let loop ((k 0) (pairs '()) (literals '()) (tails '()))
184                 (if (= k len)
185                   (let ((sentinel
186                           ;last dotted item or '()
187                           (let loop ((result pat) (k len))
188                             (if (zero? k)
189                               result
190                               (loop (cdr result) (- k 1))))))
191                     (cond
192                       ((null? sentinel)
193                        (values pairs literals
194                                (cons `(,%seq-null?
195                                         (,%seq-tail ,seq ,k))
196                                      tails)))
197                       ((symbol? sentinel)
198                        (if (compare? sentinel %_)
199                          (values pairs literals tails)
200                          (values (cons (list sentinel
201                                              `(,%seq-tail ,seq ,k))
202                                        pairs)
203                                  literals tails)))
204                       (else
205                         (values pairs
206                                 (cons `(,%equal? ',sentinel
207                                                  (,%seq-tail ,seq ,k))
208                                       literals)
209                                 tails))))
210                   (let ((item (list-ref pat k)))
211                     (cond
212                       ;((symbol? item)
213                       ((and (symbol? item) (not (keyword? item)))
214                        (if (compare? item %_)
215                          (loop (+ k 1) pairs literals tails)
216                          (loop (+ k 1)
217                                (cons (list item `(,%seq-ref ,seq ,k)) pairs)
218                                literals
219                                tails)))
220                       ((atom? item) ; literal
221                        (loop (+ k 1)
222                              pairs
223                              (cons `(,%equal? ',item
224                                               (,%seq-ref ,seq ,k))
225                                    literals)
226                              tails))
227                       ((pair? item)
228                        (receive (ps ls ts)
229                          (destructure item `(,%seq-ref ,seq ,k))
230                          (loop (+ k 1)
231                                (append ps pairs)
232                                (append ls literals)
233                                (append ts tails))))
234                       )))))))
235        )
236        (receive (pairs literals tails)
237          (destructure pat seq)
238          (if (no-dups? (map car pairs))
239            `(,%if (,%and ,@tails)
240               (,%if (,%and ,@literals)
241                 (,(rename binder) ,pairs ,body)
242                 (,%raise (,%seq-exception
243                            'bind
244                            "literals don't match"
245                            ',literals)))
246               (,%raise (,%seq-exception
247                          'bind
248                          "length mismatch"
249                          ',tails)))
250            `(,%error 'bind-with
251                      "duplicate pattern variables"
252                      ',(map car pairs))
253          ))))))
254
255#|[
256The following is Graham's dbind extended with fenders, wildcards,
257non-symbol literals and length-checks. For example
258
259  (bind (x (y z)) '(1 #(2 3)) (where (x integer?)) (list x y z))
260
261will result in '(1 2 3) while
262
263  (bind (_ ("y" z)) '(1 #("y" z)) z)
264
265will produce 3.
266]|#
267
268;;; (bind pat seq (where . fenders) .. xpr ....)
269;;; ---------------------------------------------
270;;; binds pattern variables of pat to corresponding subexpressions of
271;;; seq and executes body xpr .... in this context, provided all
272;;; fenders pass
273(define-er-macro-transformer (bind form rename compare?)
274  (let ((pat (cadr form))
275        (seq (caddr form))
276        (xpr (cadddr form))
277        (xprs (cddddr form))
278        (%let (rename 'let))
279        (%where (rename 'where))
280        (%bind-with (rename 'bind-with))
281        (%seq (rename 'seq)))
282    (let ((fenders? (and (pair? xpr) (compare? (car xpr) %where))))
283      (let ((body (if fenders?
284                     `(,xpr ,@xprs)
285                     `((,%where) ,xpr ,@xprs))))
286        `(,%let ((,%seq ,seq))
287           ,(cons %bind-with
288                  (cons %let
289                        (cons pat
290                              (cons %seq body)))))))))
291
292#|[
293And here is the recursive version of bind, which is used in bind-letrec.
294
295  (bindrec ((o?) e?)
296    (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
297          (lambda (n) (if (zero? n) #t (o? (- n 1)))))
298    (list (o? 95) (e? 95)))
299  -> '(#t #f)
300]|#
301
302;;; (bindrec pat seq (where fender ...) .. xpr ....)
303;;; ------------------------------------------------
304;;; recursive version of bind
305(define-syntax bindrec
306  (syntax-rules ()
307    ((_ pat seq xpr . xprs)
308     (bind-with letrec pat seq xpr . xprs))))
309
310#|[
311The following macro does more or less the same what the match macro from
312the matchable package does, for example
313
314  (bind-case '(1 (2 3))
315    ((x y) (where (y list?)) (list x y))
316    ((x (y . z)) (list x y z))
317    ((x (y z)) (list x y z))) ;-> '(1 2 (3))
318
319or, to give a more realistic example, mapping:
320
321  (define (my-map fn lst)
322    (bind-case lst
323      (() '())
324      ((x . xs) (cons (fn x) (my-map fn xs)))))
325]|#
326
327;;; (bind-case seq (pat (where fender ...) .. xpr ....) ....)
328;;; ---------------------------------------------------------
329;;; Checks if seq matches pattern pat [satisfying fender ...] ....
330;;; in sequence, binds the pattern variables of the first matching
331;;; pattern to corresponding subexpressions of seq and executes
332;;; corresponding body xpr ....
333(define-syntax bind-case
334  (ir-macro-transformer
335    (lambda (form inject compare?)
336  (let ((seq (cadr form))
337        (rules (cddr form))
338        (insert-where-clause
339          (lambda (rule)
340            (if (and (pair? (cadr rule))
341                     (compare? (caadr rule) 'where))
342              rule
343              `(,(car rule) (,(inject 'where)) ,@(cdr rule))))))
344    (let ((rules (map insert-where-clause rules))
345          (rule->bind
346            (lambda (rule)
347              `(bind ,(car rule) ,seq ,(cadr rule) ,@(cddr rule)))))
348      (let loop ((binds (map rule->bind rules)) (pats '()))
349        (if (null? binds)
350           `(raise (seq-exception 'bind-case "no match"
351                                  ,seq
352                                  ',(reverse pats)))
353           `(condition-case ,(car binds)
354              ((exn)
355               ,(loop (cdr binds)
356                      (cons (list (cadar binds) (car (cdddar binds)))
357                            pats)))))))))))
358; the procedural version above improves the error message
359;(define-syntax bind-case
360;  (syntax-rules ()
361;    ((_ seq)
362;     (raise (seq-exception 'bind-case "no match for" seq)))
363;    ((_ seq (pat (where . fenders) xpr . xprs))
364;     (condition-case (bind pat seq (where . fenders) xpr . xprs)
365;       ((exn sequence) (bind-case seq))))
366;    ((_ seq (pat xpr . xprs))
367;     (bind-case seq (pat (where) xpr . xprs)))
368;    ((_ seq clause . clauses)
369;     (condition-case (bind-case seq clause)
370;       ((exn sequence) (bind-case seq . clauses))))
371;    ))
372
373#|[
374The next macro, bindable?, can be used to check, if a
375sequence-expression matches a pattern and passes all fenders.
376]|#
377
378;;; (bindable? pat (where fender ...) ..)
379;;; -------------------------------------
380;;; returns a unary predicate which checks, if its argument matches pat
381;;; and fulfills the predicates in the list fender ...
382;;; Mostly used in fenders of macro-rules and define-macro-transformer, but must
383;;; then be imported for-syntax.
384(define-syntax bindable?
385  (syntax-rules (where)
386    ((_ pat (where . fenders))
387     (lambda (seq)
388        (condition-case (bind pat seq (where . fenders) #t)
389          ((exn sequence) #f))))
390    ((_ pat)
391     (bindable? pat (where)))))
392
393#|[
394The following two macros, bind-define and bind-set!, destructure their
395sequence arguments with respect to their pattern argument and define or
396set! the pattern variables correspondingly.  For example, one can define
397multiple procedures operating on a common state
398
399  (bind-define (push top pop)
400    (let ((state '()))
401      (list
402        (lambda (arg) (set! state (cons arg state)))
403        (lambda () (car state))
404        (lambda () (set! state (cdr state))))))
405
406]|#
407
408;;; (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
409;;; -------------------------------------------------------
410;;; sets pattern variables of pat pat1 ... to corresponding sub-expressins of
411;;; seq seq1 ..., provided the fenders are satisfied
412(define-er-macro-transformer (bind-set! form rename compare?)
413  (let ((pairs (reverse (chop (cdr form) 2)))
414        (%_ (rename '_))
415        (%let (rename 'let))
416        (%list (rename 'list))
417        (%where (rename 'where))
418        (%bind (rename 'bind))
419        (%set! (rename 'set!))
420        (%seq (rename 'seq)))
421    (let ((where-clause?
422            (and (null? (cdar pairs))
423                 (pair? (caar pairs))
424                 (compare? (caaar pairs) %where))))
425      (let ((where-clause (if where-clause?
426                            (caar pairs)
427                            `(,%where)))
428            (pairs (if where-clause?
429                     ;(reverse (cdr pairs))
430                     (cdr pairs)
431                     ;(reverse pairs))))
432                     pairs)))
433        (let ((pat (map car pairs))
434              (seq `(,%list ,@(map cadr pairs)))
435              (sym? (lambda (x)
436                      (and (symbol? x)
437                           (not (compare? x %_))))))
438    (letrec (
439      (pflatten (lambda (pls)
440                  (cond
441                    ((null? pls) pls)
442                    ((pair? pls)
443                     (append (pflatten (car pls))
444                             (pflatten (cdr pls))))
445                    (else (list pls)))))
446      (filter (lambda (ok? lst)
447                 (compress (map ok? lst) lst)))
448      (reduce (lambda (pat)
449                 (filter sym? (pflatten pat))))
450      )
451      (let ((aux (let copy ((pat pat))
452                    (cond
453                      ((sym? pat) (rename pat))
454                      ((pair? pat)
455                       (cons (copy (car pat)) (copy (cdr pat))))
456                      (else pat))))
457            (%where-clause
458              (cons %where
459                    (map (lambda (c)
460                           (cons (rename (car c))
461                                 (cdr c)))
462                         (cdr where-clause)))))
463        `(,%let ((,%seq ,seq))
464           (,%bind ,aux ,%seq ,%where-clause
465                   ,@(map (lambda (p a) `(,%set! ,p ,a))
466                          (reduce pat)
467                          (reduce aux))))
468        )))))))
469
470;;; (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
471;;; ---------------------------------------------------------
472;;; destructures the sequences seq seq1 ... according to the patterns
473;;; pat pat1 ...  and sets pattern variables with values corresponding
474;;; to subexpressions of seq seq1 ..., provided the fenders are
475;;; satisfied
476(define-er-macro-transformer (bind-define form rename compare?)
477  (let ((pairs (reverse (chop (cdr form) 2)))
478        (%_ (rename '_))
479        (%list (rename 'list))
480        (%where (rename 'where))
481        (%bind-set! (rename 'bind-set!))
482        (%define (rename 'define))
483        (%begin (rename 'begin)))
484    (let ((where-clause?
485            (and (null? (cdar pairs))
486                 (pair? (caar pairs))
487                 (compare? (caaar pairs) %where))))
488      (let ((where-clause (if where-clause?
489                            (caar pairs)
490                            `(,%where)))
491            (pairs (if where-clause?
492                     ;(reverse (cdr pairs))
493                     (cdr pairs)
494                     ;(reverse pairs))))
495                     pairs)))
496        (let ((pat (map car pairs))
497              (seq `(,%list ,@(map cadr pairs)))
498              (sym? (lambda (x)
499                      (and (symbol? x)
500                           (not (compare? x %_))))))
501    (letrec (
502      (map-flatten (lambda (pls)
503                     (cond
504                       ((null? pls) pls)
505                       ((pair? pls)
506                        (append (map-flatten (car pls))
507                                (map-flatten (cdr pls))))
508                       (else (list `(,%define ,pls #f))))))
509      (filter (lambda (ok? lst)
510                (compress (map ok? lst) lst)))
511      )
512      `(,%begin
513         ,@(filter sym?
514                   (map-flatten pat))
515         (,%bind-set! ,pat ,seq ,where-clause))))))))
516
517#|[
518Now we can define two macros, which simply combine lambda with
519bind, the first destructures simply one argument, the second a
520whole list. An example of a call and its result is
521
522  ((bind-lambda (a (b . c) . d) (list a b c d))
523   '(1 #(20 30 40) 2 3))
524  -> '(1 20 #(30 40) (2 3)))))
525
526  ((bind-lambda* ((a (b . c) . d) (e . f))
527     (list a b c d e f))
528   '(1 #(20 30 40) 2 3) '#(4 5 6))
529  -> '(1 20 #(30 40) (2 3) 4 #(5 6)))
530]|#
531
532;;; (bind-lambda pat (where fender ...) .. xpr ....)
533;;; ------------------------------------------------
534;;; combination of lambda and bind, one pattern argument
535(define-syntax bind-lambda
536  (syntax-rules (where)
537    ((_ pat (where . fenders) xpr . xprs)
538     (lambda (x) (bind pat x (where . fenders) xpr . xprs)))
539    ((_ pat xpr . xprs)
540     (bind-lambda pat (where) xpr . xprs))))
541
542;;; (bind-lambda* pat (where fender ...) .. xpr ....)
543;;; -------------------------------------------------
544;;; combination of lambda and bind, multiple pattern arguments
545(define-syntax bind-lambda*
546  (syntax-rules (where)
547    ((_ pat (where . fenders) xpr . xprs)
548     (lambda x (bind pat x (where . fenders) xpr . xprs)))
549    ((_ pat xpr . xprs)
550     (bind-lambda* pat (where) xpr . xprs))))
551
552#|[
553The next two macros combine lambda and bind-case and do more or less the
554same as match-lambda and match-lambda* in the matchable package. The
555first destructures one argument, the second a list of arguments.
556Here is an example together with its result:
557
558  ((bind-case-lambda
559     ((a (b . c) . d) (list a b c d))
560     ((e . f) (where (e zero?)) e)
561     ((e . f) (list e f)))
562   '(1 2 3 4 5))
563  -> '(1 (2 3 4 5))
564
565  ((bind-case-lambda*
566     (((a (b . c) . d) (e . f))
567      (list a b c d e f)))
568   '(1 #(20 30 40) 2 3) '(4 5 6))
569  -> '(1 20 #(30 40) (2 3) 4 (5 6))
570]|#
571
572;;; (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
573;;; ------------------------------------------------------------
574;;; combination of lambda and bind-case, one pattern argument
575(define-syntax bind-case-lambda
576  (syntax-rules (where)
577    ((_ (pat (where . fenders) xpr . xprs))
578     (lambda (x)
579       (bind-case x (pat (where . fenders) xpr . xprs))))
580    ((_ (pat xpr . xprs))
581     (lambda (x)
582       (bind-case x (pat xpr . xprs))))
583    ((_ clause . clauses)
584     (lambda (x)
585       (bind-case x clause . clauses)))))
586
587;;; (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
588;;; -------------------------------------------------------------
589;;; combination of lambda and bind-case, multiple pattern arguments
590(define-syntax bind-case-lambda*
591  (syntax-rules (where)
592    ((_ (pat (where . fenders) xpr . xprs))
593     (lambda x
594       (bind-case x (pat (where . fenders) xpr . xprs))))
595    ((_ (pat xpr . xprs))
596     (lambda x
597       (bind-case x (pat xpr . xprs))))
598    ((_ clause . clauses)
599     (lambda x
600       (bind-case x clause . clauses)))))
601
602#|[
603The following macro, bind-named, is a named version of bind. It takes an
604additional argument besides those of bind, which is bound to a
605recursive procedure, which can be called in bind's body. The pattern
606variables are initialised with the corresponding subexpressions in seq.
607For example
608
609  (bind-named loop (x y) '(5 0)
610    (if (zero? x)
611      (list x y)
612      (loop (list (sub1 x) (add1 y)))))
613  -> '(0 5)
614]|#
615
616;;; (bind-named name pat seq (where fender ...) .. xpr ....)
617;;; ---- ---------------------------------------------------
618;;; named version of bind
619(define-syntax bind-named
620  (syntax-rules (where)
621    ((_ name pat seq (where . fenders) xpr . xprs)
622     ((letrec ((name 
623                  (bind-lambda pat (where . fenders) xpr . xprs)))
624         name)
625       seq))
626    ((_ name pat seq xpr . xprs)
627     (bind-named name pat seq (where) xpr . xprs))))
628
629#|[
630Now the implementation of a nested version of let, named and unnamed,
631is easy: Simply combine bind and bind-named. For example
632
633  (bind-let (
634     (((x y) z) '((1 2) 3))
635     (u (+ 2 2))
636     ((v w) '(5 6))
637     )
638     (list x y z u v w))
639  -> '(1 2 3 4 5 6)
640
641  (bind-let loop (((a b) '(5 0)))
642    (if (zero? a)
643      (list a b)
644      (loop (list (sub1 a) (add1 b)))))
645      ;(loop (list (list (sub1 a) (add1 b))))))
646      ;version with bind-named
647  -> '(0 5)
648]|#
649
650;;; (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
651;;; -----------------------------------------------------------------
652;;; nested version of let, named and unnamed
653(define-er-macro-transformer (bind-let form rename compare?)
654  (let ((named? (symbol? (cadr form))))
655    (let ((name (if named? (cadr form) (gensym)))
656          (binds (if named? (caddr form) (cadr form)))
657          (xpr (if named? (cadddr form) (caddr form)))
658          (xprs (if named? (cddddr form) (cdddr form))))
659      (let ((pats (map car binds))
660            (seqs (map cadr binds))
661            (%list (rename 'list))
662            (%bind (rename 'bind))
663            ;(%bind-named (rename 'bind-named)))
664            (%letrec (rename 'letrec))
665            (%bind-lambda* (rename 'bind-lambda*)))
666        (if named?
667          `(,%letrec ((,name (,%bind-lambda* ,pats ,xpr ,@xprs)))
668             (,name ,@seqs))
669          ;`(,%bind-named ,name ,pats (,%list ,@seqs) ,xpr ,@xprs)
670          `(,%bind ,pats (,%list ,@seqs) ,xpr ,@xprs))))))
671
672#|[
673The sequential version of bind-let should work as follows
674
675  (bind-let* (
676     (((x y) z) '((1 2) 3))
677     (u (+ 1 2 x))
678     ((v w) (list (+ z 2) 6))
679     )
680     (list x y z u v w))
681  -> '(1 2 3 4 5 6)
682]|#
683
684;;; (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
685;;; ----------------------------------------------------------
686;;; sequential version of bind-let
687(define-syntax bind-let*
688  (syntax-rules (where)
689    ((_ () xpr . xprs)
690     (begin xpr . xprs))
691    ((_ ((pat seq)) (where . fenders) xpr . xprs)
692     (bind pat seq (where . fenders) xpr . xprs))
693    ((_ ((pat seq)) xpr . xprs)
694     (bind pat seq xpr . xprs))
695    ((_ ((pat seq) binds ...) (where . fenders) xpr . xprs)
696     (bind pat seq (bind-let* (binds ...)
697                     (where . fenders) xpr . xprs)))
698    ((_ ((pat seq) binds ...) xpr . xprs)
699     (bind pat seq
700       (bind-let* (binds ...) xpr . xprs)))))
701
702#|[
703The recursive version of bind-let works as follows
704 
705  (bind-letrec (
706    ((o? (e?))
707     (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
708           (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
709    )
710    (list (o? 95) (e? 95)))
711  -> '(#t #f)
712]|#
713
714;;; (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
715;;; ------------------------------------------------------------
716;;; recursive version of bind-let
717(define-er-macro-transformer (bind-letrec form rename compare?)
718  (let ((binds (cadr form)) (xpr (caddr form)) (xprs (cdddr form)))
719    (let ((pats (map car binds))
720          (seqs (map cadr binds))
721          (%list (rename 'list))
722          (%bindrec (rename 'bindrec)))
723      `(,%bindrec ,pats (,%list ,@seqs) ,xpr ,@xprs))))
724
725#|[
726The following macro is sometimes named let/cc or let-cc
727]|#
728
729;;; (bind/cc cc xpr ....)
730;;; ---------------------
731;;; captures the current continuation, binds it to cc and executes
732;;; xpr .... in this context
733(define-syntax bind/cc
734  (syntax-rules ()
735    ((_ cc xpr . xprs)
736     (call-with-current-continuation
737       (lambda (cc) xpr . xprs)))))
738
739;;; (define-algebraic-type NAME Name?
740;;;   (Name0 (arg0 arg0? ...) ... [args0 args0? ...])
741;;;   (Name1 (arg1 arg1? ...) ... [args1 args1? ...])
742;;;   ...
743;;;   )
744;;; -------------------------------------------------
745;;; defines an algebraic type, NAME, with type predicate Name?
746;;; and constructors
747;;; (Name (arg arg? ...) ...) | (Name (arg arg? ...) ... args args? ...)
748;;; to be accessed via bind, bind-case and friends
749(define-er-macro-transformer
750  (define-algebraic-type form rename compare?)
751  (let ((type (cadr form))
752        (pred (caddr form))
753        (constructors (cdddr form))
754        (symbol->keyword
755          (lambda (sym)
756            (string->keyword
757              (symbol->string sym))))
758        (split
759          (lambda (lst)
760            (let loop ((head '()) (tail lst))
761              (cond
762                ((null? tail)
763                 (values (reverse head) tail))
764                ((symbol? (car tail))
765                 (values (reverse head) tail))
766                (else
767                  (loop (cons (car tail) head)
768                        (cdr tail)))))))
769        (%x (rename 'x))
770        (%<< (rename '<<))
771        (%if (rename 'if))
772        (%exn (rename 'exn))
773        (%xpr (rename 'xpr))
774        (%map (rename 'map))
775        (%and (rename 'and))
776        (%memq (rename 'memq))
777        (%begin (rename 'begin))
778        (%apply (rename 'apply))
779        (%lambda (rename 'lambda))
780        (%define (rename 'define))
781        (%sequence (rename 'sequence))
782        (%tagged-vector (rename 'tagged-vector))
783        (%tagged-vector? (rename 'tagged-vector?))
784        (%condition-case (rename 'condition-case))
785        (%tagged-vector-ref (rename 'tagged-vector-ref)))
786    `(,%begin
787       (,%define ,type ;',(map rename
788                       ',(map symbol->keyword
789                               (map car constructors)))
790       ,@(map (lambda (con)
791                (receive (head tail) (split (cdr con))
792                  (cond
793                    ((null? tail)
794                     `(,%define (,(car con) ,@(map car head))
795                         (,%tagged-vector
796                           ,(symbol->keyword (car con))
797                           ,@(map (lambda (arg)
798                                    `(,%<< ,(car arg) ,@(cdr arg)))
799                                  head))))
800                    ((null? head)
801                     `(,%define (,(car con) . ,(car tail))
802                         (,%apply ,%tagged-vector
803                                  ,(symbol->keyword (car con))
804                                  (,%map (,%lambda (,%x)
805                                         (,%<< ,%x ,@(cdr tail)))
806                                       ,(car tail)))))
807                    (else
808                      `(,%define (,(car con) ,@(map car head)
809                                             . ,(car tail))
810                          (,%apply ,%tagged-vector
811                                   ,(symbol->keyword (car con))
812                                   ,@(map (lambda (arg)
813                                            `(,%<< ,(car arg) ,@(cdr arg)))
814                                          head)
815                                   (,%map (,%lambda (,%x)
816                                         (,%<< ,%x ,@(cdr tail)))
817                                       ,(car tail)))))
818
819                    )))
820              constructors)
821       (,%define (,pred ,%xpr)
822         (,%and (,%tagged-vector? ,%xpr)
823                (,%if (,%condition-case
824                        (,%memq (,%tagged-vector-ref ,%xpr 0) ,type)
825                        ((,%exn ,%sequence) #t))
826                      #t #f)))
827       )))
828
829
830;;; (bindings sym ..)
831;;; ----------------------
832;;; documentation procedure
833(define bindings
834  (symbol-dispatcher '(
835    (bindings
836      procedure:
837      (bindings sym ..)
838      "documentation procedure")
839    (seq-db
840      procedure:
841      (seq-db)
842      "shows the sequence database"
843      (seq-db type ref: ref tail: tail maker: maker ra?: random-access?)
844      "adds a new sequence type to the database where the keywords"
845      "name arguments being accessed as seq-ref and seq-tail seq-maker"
846      "and seq-random-access? respectively")
847    (bind
848      macro:
849      (bind pat seq (where fender ...) .. xpr ....)
850      "a variant of Common Lisp's destructuring-bind")
851    (bind-case
852      macro:
853      (bind-case seq (pat (where fender ...) .. xpr ....) ....)
854      "matches seq against pat with optional fenders in a case regime")
855    (bindable?
856      macro:
857      (bindable? pat (where fender ...) ..)
858      "returns a unary predicate, which checks"
859      "if its argument matches pat and passes all fenders")
860    (bind-set!
861      macro:
862      (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
863      "sets multiple variables by destructuring its sequence arguments")
864    (bind-define
865      macro:
866      (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
867      "defines multiple variables by destructuring its sequence arguments")
868    (bind-lambda
869      macro:
870      (bind-lambda pat (where fender ...) .. xpr ....)
871      "combination of lambda and bind, one pattern argument")
872    (bind-lambda*
873      macro:
874      (bind-lambda* pat (where fender ...) .. xpr ....)
875      "combination of lambda and bind, multiple pattern arguments")
876    (bind-named
877      macro:
878      (bind-named loop pat (where fender ...) .. seq xpr ....)
879      "named version of bind")
880    (bind-let
881      macro:
882      (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
883      "nested version of let, named and unnamed")
884    (bind-let*
885      macro:
886      (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
887      "nested version of let*")
888    (bindrec
889      macro:
890      (bindrec pat seq (where fender ...) .. xpr ....)
891      "recursive version of bind")
892    (bind-letrec
893      macro:
894      (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
895      "recursive version of bind-let")
896    (bind-case-lambda
897      macro:
898      (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
899      "combination of lambda and bind-case with one pattern argument")
900    (bind-case-lambda*
901      macro:
902      (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
903      "combination of lambda and bind-case with multiple pattern arguments")
904    (bind/cc
905      macro:
906      (bind/cc cc xpr ....)
907      "binds cc to the current contiunation"
908      "and execute xpr ... in this context")
909    (define-algebraic-type
910      macro:
911      (define-algebraic-type NAME Name?
912        (Name0 (arg0 arg0? ...) ... [args0 args0? ...])
913        (Name1 (arg1 arg1? ...) ... [args1 args1? ...])
914        ...
915        )
916      "defines an algebraic type, NAME, with type predicate Name?"
917      "and constructors Name0, Name1 ... of the form"
918      "(Name (arg arg? ...) ...)|(Name (arg arg? ...) ... args args?  ...)"
919      "to be accessed via bind, bind-case and friends")
920    )))
921  ) ; bindings
922
923;(import bindings)
Note: See TracBrowser for help on using the repository browser.