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

Last change on this file since 36471 was 36471, checked in by juergen, 18 months ago

bindings 7.2 fixes bug with null subpatterns

File size: 33.7 KB
Line 
1; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
2;
3; Copyright (c) 2013-2018, 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                                                                                         ((and (not (pair? item)) (not (null? item)))
222                        (loop (+ k 1)
223                              pairs
224                              (cons `(,%equal? ',item
225                                               (,%seq-ref ,seq ,k))
226                                    literals)
227                              tails))
228                       ;((pair? item)
229                                                                                         ((or (null? item) (pair? item)) ; list
230                        (receive (ps ls ts)
231                          (destructure item `(,%seq-ref ,seq ,k))
232                          (loop (+ k 1)
233                                (append ps pairs)
234                                (append ls literals)
235                                (append ts tails))))
236                       )))))))
237        )
238        (receive (pairs literals tails)
239          (destructure pat seq)
240          (if (no-dups? (map car pairs))
241            `(,%if (,%and ,@tails)
242               (,%if (,%and ,@literals)
243                 (,(rename binder) ,pairs ,body)
244                 (,%raise (,%seq-exception
245                            'bind
246                            "literals don't match"
247                            ',literals)))
248               (,%raise (,%seq-exception
249                          'bind
250                          "length mismatch"
251                          ',tails)))
252            `(,%error 'bind-with
253                      "duplicate pattern variables"
254                      ',(map car pairs))
255          ))))))
256
257#|[
258The following is Graham's dbind extended with fenders, wildcards,
259non-symbol literals and length-checks. For example
260
261  (bind (x (y z)) '(1 #(2 3)) (where (x integer?)) (list x y z))
262
263will result in '(1 2 3) while
264
265  (bind (_ ("y" z)) '(1 #("y" z)) z)
266
267will produce 3.
268]|#
269
270;;; (bind pat seq (where . fenders) .. xpr ....)
271;;; ---------------------------------------------
272;;; binds pattern variables of pat to corresponding subexpressions of
273;;; seq and executes body xpr .... in this context, provided all
274;;; fenders pass
275(define-er-macro-transformer (bind form rename compare?)
276  (let ((pat (cadr form))
277        (seq (caddr form))
278        (xpr (cadddr form))
279        (xprs (cddddr form))
280        (%let (rename 'let))
281        (%where (rename 'where))
282        (%bind-with (rename 'bind-with))
283        (%seq (rename 'seq)))
284    (let ((fenders? (and (pair? xpr) (compare? (car xpr) %where))))
285      (let ((body (if fenders?
286                     `(,xpr ,@xprs)
287                     `((,%where) ,xpr ,@xprs))))
288        `(,%let ((,%seq ,seq))
289           ,(cons %bind-with
290                  (cons %let
291                        (cons pat
292                              (cons %seq body)))))))))
293
294#|[
295And here is the recursive version of bind, which is used in bind-letrec.
296
297  (bindrec ((o?) e?)
298    (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
299          (lambda (n) (if (zero? n) #t (o? (- n 1)))))
300    (list (o? 95) (e? 95)))
301  -> '(#t #f)
302]|#
303
304;;; (bindrec pat seq (where fender ...) .. xpr ....)
305;;; ------------------------------------------------
306;;; recursive version of bind
307(define-syntax bindrec
308  (syntax-rules ()
309    ((_ pat seq xpr . xprs)
310     (bind-with letrec pat seq xpr . xprs))))
311
312#|[
313The following macro does more or less the same what the match macro from
314the matchable package does, for example
315
316  (bind-case '(1 (2 3))
317    ((x y) (where (y list?)) (list x y))
318    ((x (y . z)) (list x y z))
319    ((x (y z)) (list x y z))) ;-> '(1 2 (3))
320
321or, to give a more realistic example, mapping:
322
323  (define (my-map fn lst)
324    (bind-case lst
325      (() '())
326      ((x . xs) (cons (fn x) (my-map fn xs)))))
327]|#
328
329;;; (bind-case seq (pat (where fender ...) .. xpr ....) ....)
330;;; ---------------------------------------------------------
331;;; Checks if seq matches pattern pat [satisfying fender ...] ....
332;;; in sequence, binds the pattern variables of the first matching
333;;; pattern to corresponding subexpressions of seq and executes
334;;; corresponding body xpr ....
335(define-syntax bind-case
336  (ir-macro-transformer
337    (lambda (form inject compare?)
338  (let ((seq (cadr form))
339        (rules (cddr form))
340        (insert-where-clause
341          (lambda (rule)
342            (if (and (pair? (cadr rule))
343                     (compare? (caadr rule) 'where))
344              rule
345              `(,(car rule) (,(inject 'where)) ,@(cdr rule))))))
346    (let ((rules (map insert-where-clause rules))
347          (rule->bind
348            (lambda (rule)
349              `(bind ,(car rule) ,seq ,(cadr rule) ,@(cddr rule)))))
350      (let loop ((binds (map rule->bind rules)) (pats '()))
351        (if (null? binds)
352           `(raise (seq-exception 'bind-case "no match"
353                                  ,seq
354                                  ',(reverse pats)))
355           `(condition-case ,(car binds)
356              ((exn)
357               ,(loop (cdr binds)
358                      (cons (list (cadar binds) (car (cdddar binds)))
359                            pats)))))))))))
360; the procedural version above improves the error message
361;(define-syntax bind-case
362;  (syntax-rules ()
363;    ((_ seq)
364;     (raise (seq-exception 'bind-case "no match for" seq)))
365;    ((_ seq (pat (where . fenders) xpr . xprs))
366;     (condition-case (bind pat seq (where . fenders) xpr . xprs)
367;       ((exn sequence) (bind-case seq))))
368;    ((_ seq (pat xpr . xprs))
369;     (bind-case seq (pat (where) xpr . xprs)))
370;    ((_ seq clause . clauses)
371;     (condition-case (bind-case seq clause)
372;       ((exn sequence) (bind-case seq . clauses))))
373;    ))
374
375#|[
376The next macro, bindable?, can be used to check, if a
377sequence-expression matches a pattern and passes all fenders.
378]|#
379
380;;; (bindable? pat (where fender ...) ..)
381;;; -------------------------------------
382;;; returns a unary predicate which checks, if its argument matches pat
383;;; and fulfills the predicates in the list fender ...
384;;; Mostly used in fenders of macro-rules and define-macro-transformer, but must
385;;; then be imported for-syntax.
386(define-syntax bindable?
387  (syntax-rules (where)
388    ((_ pat (where . fenders))
389     (lambda (seq)
390        (condition-case (bind pat seq (where . fenders) #t)
391          ((exn sequence) #f))))
392    ((_ pat)
393     (bindable? pat (where)))))
394
395#|[
396The following two macros, bind-define and bind-set!, destructure their
397sequence arguments with respect to their pattern argument and define or
398set! the pattern variables correspondingly.  For example, one can define
399multiple procedures operating on a common state
400
401  (bind-define (push top pop)
402    (let ((state '()))
403      (list
404        (lambda (arg) (set! state (cons arg state)))
405        (lambda () (car state))
406        (lambda () (set! state (cdr state))))))
407
408]|#
409
410;;; (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
411;;; -------------------------------------------------------
412;;; sets pattern variables of pat pat1 ... to corresponding sub-expressins of
413;;; seq seq1 ..., provided the fenders are satisfied
414(define-er-macro-transformer (bind-set! form rename compare?)
415  (let ((pairs (reverse (chop (cdr form) 2)))
416        (%_ (rename '_))
417        (%let (rename 'let))
418        (%list (rename 'list))
419        (%where (rename 'where))
420        (%bind (rename 'bind))
421        (%set! (rename 'set!))
422        (%seq (rename 'seq)))
423    (let ((where-clause?
424            (and (null? (cdar pairs))
425                 (pair? (caar pairs))
426                 (compare? (caaar pairs) %where))))
427      (let ((where-clause (if where-clause?
428                            (caar pairs)
429                            `(,%where)))
430            (pairs (if where-clause?
431                     ;(reverse (cdr pairs))
432                     (cdr pairs)
433                     ;(reverse pairs))))
434                     pairs)))
435        (let ((pat (map car pairs))
436              (seq `(,%list ,@(map cadr pairs)))
437              (sym? (lambda (x)
438                      (and (symbol? x)
439                           (not (compare? x %_))))))
440    (letrec (
441      (pflatten (lambda (pls)
442                  (cond
443                    ((null? pls) pls)
444                    ((pair? pls)
445                     (append (pflatten (car pls))
446                             (pflatten (cdr pls))))
447                    (else (list pls)))))
448      (filter (lambda (ok? lst)
449                 (compress (map ok? lst) lst)))
450      (reduce (lambda (pat)
451                 (filter sym? (pflatten pat))))
452      )
453      (let ((aux (let copy ((pat pat))
454                    (cond
455                      ((sym? pat) (rename pat))
456                      ((pair? pat)
457                       (cons (copy (car pat)) (copy (cdr pat))))
458                      (else pat))))
459            (%where-clause
460              (cons %where
461                    (map (lambda (c)
462                           (cons (rename (car c))
463                                 (cdr c)))
464                         (cdr where-clause)))))
465        `(,%let ((,%seq ,seq))
466           (,%bind ,aux ,%seq ,%where-clause
467                   ,@(map (lambda (p a) `(,%set! ,p ,a))
468                          (reduce pat)
469                          (reduce aux))))
470        )))))))
471
472;;; (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
473;;; ---------------------------------------------------------
474;;; destructures the sequences seq seq1 ... according to the patterns
475;;; pat pat1 ...  and sets pattern variables with values corresponding
476;;; to subexpressions of seq seq1 ..., provided the fenders are
477;;; satisfied
478(define-er-macro-transformer (bind-define form rename compare?)
479  (let ((pairs (reverse (chop (cdr form) 2)))
480        (%_ (rename '_))
481        (%list (rename 'list))
482        (%where (rename 'where))
483        (%bind-set! (rename 'bind-set!))
484        (%define (rename 'define))
485        (%begin (rename 'begin)))
486    (let ((where-clause?
487            (and (null? (cdar pairs))
488                 (pair? (caar pairs))
489                 (compare? (caaar pairs) %where))))
490      (let ((where-clause (if where-clause?
491                            (caar pairs)
492                            `(,%where)))
493            (pairs (if where-clause?
494                     ;(reverse (cdr pairs))
495                     (cdr pairs)
496                     ;(reverse pairs))))
497                     pairs)))
498        (let ((pat (map car pairs))
499              (seq `(,%list ,@(map cadr pairs)))
500              (sym? (lambda (x)
501                      (and (symbol? x)
502                           (not (compare? x %_))))))
503    (letrec (
504      (map-flatten (lambda (pls)
505                     (cond
506                       ((null? pls) pls)
507                       ((pair? pls)
508                        (append (map-flatten (car pls))
509                                (map-flatten (cdr pls))))
510                       (else (list `(,%define ,pls #f))))))
511      (filter (lambda (ok? lst)
512                (compress (map ok? lst) lst)))
513      )
514      `(,%begin
515         ,@(filter sym?
516                   (map-flatten pat))
517         (,%bind-set! ,pat ,seq ,where-clause))))))))
518
519#|[
520Now we can define two macros, which simply combine lambda with
521bind, the first destructures simply one argument, the second a
522whole list. An example of a call and its result is
523
524  ((bind-lambda (a (b . c) . d) (list a b c d))
525   '(1 #(20 30 40) 2 3))
526  -> '(1 20 #(30 40) (2 3)))))
527
528  ((bind-lambda* ((a (b . c) . d) (e . f))
529     (list a b c d e f))
530   '(1 #(20 30 40) 2 3) '#(4 5 6))
531  -> '(1 20 #(30 40) (2 3) 4 #(5 6)))
532]|#
533
534;;; (bind-lambda pat (where fender ...) .. xpr ....)
535;;; ------------------------------------------------
536;;; combination of lambda and bind, one pattern argument
537(define-syntax bind-lambda
538  (syntax-rules (where)
539    ((_ pat (where . fenders) xpr . xprs)
540     (lambda (x) (bind pat x (where . fenders) xpr . xprs)))
541    ((_ pat xpr . xprs)
542     (bind-lambda pat (where) xpr . xprs))))
543
544;;; (bind-lambda* pat (where fender ...) .. xpr ....)
545;;; -------------------------------------------------
546;;; combination of lambda and bind, multiple pattern arguments
547(define-syntax bind-lambda*
548  (syntax-rules (where)
549    ((_ pat (where . fenders) xpr . xprs)
550     (lambda x (bind pat x (where . fenders) xpr . xprs)))
551    ((_ pat xpr . xprs)
552     (bind-lambda* pat (where) xpr . xprs))))
553
554#|[
555The next two macros combine lambda and bind-case and do more or less the
556same as match-lambda and match-lambda* in the matchable package. The
557first destructures one argument, the second a list of arguments.
558Here is an example together with its result:
559
560  ((bind-case-lambda
561     ((a (b . c) . d) (list a b c d))
562     ((e . f) (where (e zero?)) e)
563     ((e . f) (list e f)))
564   '(1 2 3 4 5))
565  -> '(1 (2 3 4 5))
566
567  ((bind-case-lambda*
568     (((a (b . c) . d) (e . f))
569      (list a b c d e f)))
570   '(1 #(20 30 40) 2 3) '(4 5 6))
571  -> '(1 20 #(30 40) (2 3) 4 (5 6))
572]|#
573
574;;; (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
575;;; ------------------------------------------------------------
576;;; combination of lambda and bind-case, one pattern argument
577(define-syntax bind-case-lambda
578  (syntax-rules (where)
579    ((_ (pat (where . fenders) xpr . xprs))
580     (lambda (x)
581       (bind-case x (pat (where . fenders) xpr . xprs))))
582    ((_ (pat xpr . xprs))
583     (lambda (x)
584       (bind-case x (pat xpr . xprs))))
585    ((_ clause . clauses)
586     (lambda (x)
587       (bind-case x clause . clauses)))))
588
589;;; (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
590;;; -------------------------------------------------------------
591;;; combination of lambda and bind-case, multiple pattern arguments
592(define-syntax bind-case-lambda*
593  (syntax-rules (where)
594    ((_ (pat (where . fenders) xpr . xprs))
595     (lambda x
596       (bind-case x (pat (where . fenders) xpr . xprs))))
597    ((_ (pat xpr . xprs))
598     (lambda x
599       (bind-case x (pat xpr . xprs))))
600    ((_ clause . clauses)
601     (lambda x
602       (bind-case x clause . clauses)))))
603
604#|[
605The following macro, bind-named, is a named version of bind. It takes an
606additional argument besides those of bind, which is bound to a
607recursive procedure, which can be called in bind's body. The pattern
608variables are initialised with the corresponding subexpressions in seq.
609For example
610
611  (bind-named loop (x y) '(5 0)
612    (if (zero? x)
613      (list x y)
614      (loop (list (sub1 x) (add1 y)))))
615  -> '(0 5)
616]|#
617
618;;; (bind-named name pat seq (where fender ...) .. xpr ....)
619;;; ---- ---------------------------------------------------
620;;; named version of bind
621(define-syntax bind-named
622  (syntax-rules (where)
623    ((_ name pat seq (where . fenders) xpr . xprs)
624     ((letrec ((name 
625                  (bind-lambda pat (where . fenders) xpr . xprs)))
626         name)
627       seq))
628    ((_ name pat seq xpr . xprs)
629     (bind-named name pat seq (where) xpr . xprs))))
630
631#|[
632Now the implementation of a nested version of let, named and unnamed,
633is easy: Simply combine bind and bind-named. For example
634
635  (bind-let (
636     (((x y) z) '((1 2) 3))
637     (u (+ 2 2))
638     ((v w) '(5 6))
639     )
640     (list x y z u v w))
641  -> '(1 2 3 4 5 6)
642
643  (bind-let loop (((a b) '(5 0)))
644    (if (zero? a)
645      (list a b)
646      (loop (list (sub1 a) (add1 b)))))
647      ;(loop (list (list (sub1 a) (add1 b))))))
648      ;version with bind-named
649  -> '(0 5)
650]|#
651
652;;; (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
653;;; -----------------------------------------------------------------
654;;; nested version of let, named and unnamed
655(define-er-macro-transformer (bind-let form rename compare?)
656  (let ((named? (symbol? (cadr form))))
657    (let ((name (if named? (cadr form) (gensym)))
658          (binds (if named? (caddr form) (cadr form)))
659          (xpr (if named? (cadddr form) (caddr form)))
660          (xprs (if named? (cddddr form) (cdddr form))))
661      (let ((pats (map car binds))
662            (seqs (map cadr binds))
663            (%list (rename 'list))
664            (%bind (rename 'bind))
665            ;(%bind-named (rename 'bind-named)))
666            (%letrec (rename 'letrec))
667            (%bind-lambda* (rename 'bind-lambda*)))
668        (if named?
669          `(,%letrec ((,name (,%bind-lambda* ,pats ,xpr ,@xprs)))
670             (,name ,@seqs))
671          ;`(,%bind-named ,name ,pats (,%list ,@seqs) ,xpr ,@xprs)
672          `(,%bind ,pats (,%list ,@seqs) ,xpr ,@xprs))))))
673
674#|[
675The sequential version of bind-let should work as follows
676
677  (bind-let* (
678     (((x y) z) '((1 2) 3))
679     (u (+ 1 2 x))
680     ((v w) (list (+ z 2) 6))
681     )
682     (list x y z u v w))
683  -> '(1 2 3 4 5 6)
684]|#
685
686;;; (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
687;;; ----------------------------------------------------------
688;;; sequential version of bind-let
689(define-syntax bind-let*
690  (syntax-rules (where)
691    ((_ () xpr . xprs)
692     (begin xpr . xprs))
693    ((_ ((pat seq)) (where . fenders) xpr . xprs)
694     (bind pat seq (where . fenders) xpr . xprs))
695    ((_ ((pat seq)) xpr . xprs)
696     (bind pat seq xpr . xprs))
697    ((_ ((pat seq) binds ...) (where . fenders) xpr . xprs)
698     (bind pat seq (bind-let* (binds ...)
699                     (where . fenders) xpr . xprs)))
700    ((_ ((pat seq) binds ...) xpr . xprs)
701     (bind pat seq
702       (bind-let* (binds ...) xpr . xprs)))))
703
704#|[
705The recursive version of bind-let works as follows
706 
707  (bind-letrec (
708    ((o? (e?))
709     (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
710           (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
711    )
712    (list (o? 95) (e? 95)))
713  -> '(#t #f)
714]|#
715
716;;; (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
717;;; ------------------------------------------------------------
718;;; recursive version of bind-let
719(define-er-macro-transformer (bind-letrec form rename compare?)
720  (let ((binds (cadr form)) (xpr (caddr form)) (xprs (cdddr form)))
721    (let ((pats (map car binds))
722          (seqs (map cadr binds))
723          (%list (rename 'list))
724          (%bindrec (rename 'bindrec)))
725      `(,%bindrec ,pats (,%list ,@seqs) ,xpr ,@xprs))))
726
727#|[
728The following macro is sometimes named let/cc or let-cc
729]|#
730
731;;; (bind/cc cc xpr ....)
732;;; ---------------------
733;;; captures the current continuation, binds it to cc and executes
734;;; xpr .... in this context
735(define-syntax bind/cc
736  (syntax-rules ()
737    ((_ cc xpr . xprs)
738     (call-with-current-continuation
739       (lambda (cc) xpr . xprs)))))
740
741;;; (define-algebraic-type NAME Name?
742;;;   (Name0 (arg0 arg0? ...) ... [args0 args0? ...])
743;;;   (Name1 (arg1 arg1? ...) ... [args1 args1? ...])
744;;;   ...
745;;;   )
746;;; -------------------------------------------------
747;;; defines an algebraic type, NAME, with type predicate Name?
748;;; and constructors
749;;; (Name (arg arg? ...) ...) | (Name (arg arg? ...) ... args args? ...)
750;;; to be accessed via bind, bind-case and friends
751(define-er-macro-transformer
752  (define-algebraic-type form rename compare?)
753  (let ((type (cadr form))
754        (pred (caddr form))
755        (constructors (cdddr form))
756        (symbol->keyword
757          (lambda (sym)
758            (string->keyword
759              (symbol->string sym))))
760        (split
761          (lambda (lst)
762            (let loop ((head '()) (tail lst))
763              (cond
764                ((null? tail)
765                 (values (reverse head) tail))
766                ((symbol? (car tail))
767                 (values (reverse head) tail))
768                (else
769                  (loop (cons (car tail) head)
770                        (cdr tail)))))))
771        (%x (rename 'x))
772        (%<< (rename '<<))
773        (%if (rename 'if))
774        (%exn (rename 'exn))
775        (%xpr (rename 'xpr))
776        (%map (rename 'map))
777        (%and (rename 'and))
778        (%memq (rename 'memq))
779        (%begin (rename 'begin))
780        (%apply (rename 'apply))
781        (%lambda (rename 'lambda))
782        (%define (rename 'define))
783        (%sequence (rename 'sequence))
784        (%tagged-vector (rename 'tagged-vector))
785        (%tagged-vector? (rename 'tagged-vector?))
786        (%condition-case (rename 'condition-case))
787        (%tagged-vector-ref (rename 'tagged-vector-ref)))
788    `(,%begin
789       (,%define ,type ;',(map rename
790                       ',(map symbol->keyword
791                               (map car constructors)))
792       ,@(map (lambda (con)
793                (receive (head tail) (split (cdr con))
794                  (cond
795                    ((null? tail)
796                     `(,%define (,(car con) ,@(map car head))
797                         (,%tagged-vector
798                           ,(symbol->keyword (car con))
799                           ,@(map (lambda (arg)
800                                    `(,%<< ,(car arg) ,@(cdr arg)))
801                                  head))))
802                    ((null? head)
803                     `(,%define (,(car con) . ,(car tail))
804                         (,%apply ,%tagged-vector
805                                  ,(symbol->keyword (car con))
806                                  (,%map (,%lambda (,%x)
807                                         (,%<< ,%x ,@(cdr tail)))
808                                       ,(car tail)))))
809                    (else
810                      `(,%define (,(car con) ,@(map car head)
811                                             . ,(car tail))
812                          (,%apply ,%tagged-vector
813                                   ,(symbol->keyword (car con))
814                                   ,@(map (lambda (arg)
815                                            `(,%<< ,(car arg) ,@(cdr arg)))
816                                          head)
817                                   (,%map (,%lambda (,%x)
818                                         (,%<< ,%x ,@(cdr tail)))
819                                       ,(car tail)))))
820
821                    )))
822              constructors)
823       (,%define (,pred ,%xpr)
824         (,%and (,%tagged-vector? ,%xpr)
825                (,%if (,%condition-case
826                        (,%memq (,%tagged-vector-ref ,%xpr 0) ,type)
827                        ((,%exn ,%sequence) #t))
828                      #t #f)))
829       )))
830
831
832;;; (bindings sym ..)
833;;; ----------------------
834;;; documentation procedure
835(define bindings
836  (symbol-dispatcher '(
837    (bindings
838      procedure:
839      (bindings sym ..)
840      "documentation procedure")
841    (seq-db
842      procedure:
843      (seq-db)
844      "shows the sequence database"
845      (seq-db type ref: ref tail: tail maker: maker ra?: random-access?)
846      "adds a new sequence type to the database where the keywords"
847      "name arguments being accessed as seq-ref and seq-tail seq-maker"
848      "and seq-random-access? respectively")
849    (bind
850      macro:
851      (bind pat seq (where fender ...) .. xpr ....)
852      "a variant of Common Lisp's destructuring-bind")
853    (bind-case
854      macro:
855      (bind-case seq (pat (where fender ...) .. xpr ....) ....)
856      "matches seq against pat with optional fenders in a case regime")
857    (bindable?
858      macro:
859      (bindable? pat (where fender ...) ..)
860      "returns a unary predicate, which checks"
861      "if its argument matches pat and passes all fenders")
862    (bind-set!
863      macro:
864      (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
865      "sets multiple variables by destructuring its sequence arguments")
866    (bind-define
867      macro:
868      (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
869      "defines multiple variables by destructuring its sequence arguments")
870    (bind-lambda
871      macro:
872      (bind-lambda pat (where fender ...) .. xpr ....)
873      "combination of lambda and bind, one pattern argument")
874    (bind-lambda*
875      macro:
876      (bind-lambda* pat (where fender ...) .. xpr ....)
877      "combination of lambda and bind, multiple pattern arguments")
878    (bind-named
879      macro:
880      (bind-named loop pat (where fender ...) .. seq xpr ....)
881      "named version of bind")
882    (bind-let
883      macro:
884      (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
885      "nested version of let, named and unnamed")
886    (bind-let*
887      macro:
888      (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
889      "nested version of let*")
890    (bindrec
891      macro:
892      (bindrec pat seq (where fender ...) .. xpr ....)
893      "recursive version of bind")
894    (bind-letrec
895      macro:
896      (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
897      "recursive version of bind-let")
898    (bind-case-lambda
899      macro:
900      (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
901      "combination of lambda and bind-case with one pattern argument")
902    (bind-case-lambda*
903      macro:
904      (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
905      "combination of lambda and bind-case with multiple pattern arguments")
906    (bind/cc
907      macro:
908      (bind/cc cc xpr ....)
909      "binds cc to the current contiunation"
910      "and execute xpr ... in this context")
911    (define-algebraic-type
912      macro:
913      (define-algebraic-type NAME Name?
914        (Name0 (arg0 arg0? ...) ... [args0 args0? ...])
915        (Name1 (arg1 arg1? ...) ... [args1 args1? ...])
916        ...
917        )
918      "defines an algebraic type, NAME, with type predicate Name?"
919      "and constructors Name0, Name1 ... of the form"
920      "(Name (arg arg? ...) ...)|(Name (arg arg? ...) ... args args?  ...)"
921      "to be accessed via bind, bind-case and friends")
922    )))
923  ) ; bindings
924
925;(import bindings)
Note: See TracBrowser for help on using the repository browser.