source: project/release/5/bindings/trunk/bindings.scm @ 37352

Last change on this file since 37352 was 37352, checked in by juergen, 21 months ago

bindings 1.5 prepared for use in lazy-pairs

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