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

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

bindings 1.4 with dependency on checks removed

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