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

Last change on this file since 36356 was 36356, checked in by juergen, 22 months ago

bindings 1.1 sequence routines prefixed

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