source: project/release/5/bindings/tags/3.2/bindings.scm @ 38642

Last change on this file since 38642 was 38642, checked in by juergen, 5 months ago

bindings-3.2 improved

File size: 26.7 KB
Line 
1; Author: Juergen Lorenz, ju (at) jugilo (dot) de
2;
3; Copyright (c) 2013-2020, 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#|[
34Yet another implementation of the bindings egg.
35It's based on the bind macro, which is a variant of Common Lisp's
36destructuring bind.
37
38It not only destructures nested pseudolists but nested sequences as
39well, which can be vectors, strings, biglists or what have you, provided
40you have added support for those datatypes. But that's as simple as
41adding a triple seq? seq-car and seq-cdr to the generic transformer
42procedure bind-listify*. As this name suggests, every sequence is
43transformed to an ordinary list at each nesting level. Moreover, this
44routine handles literals and dotted ends as well.
45
46The bind macro itself uses bind-list*, a nested version of bind-list,
47after having processed all literals and the wildcard, an underscore. The
48rule is, the wildcard matches everything but doesn't bind anything,
49whereas the literals match only itself, and, of course, don't bind
50anything.
51
52All other macros, in particular bind-case, a variant of match in the
53matchable egg, are based on bind and are implemented as declarative
54macros.
55
56One difference to former versions of bind is, that it can be called
57without a body which results in setting the pattern variables to
58correspondig values in the nested sequence argument. In other words,
59this is what was called bind! before. Hence bind! and
60bind-define are expendable and code duplication is avoided. But for
61convenience of use, this version is aliased bind!
62]|#
63
64(module bindings (
65  bind-listify*
66  bind-list
67  bind-list!
68  bind-list*
69  bind
70  bind!
71  bindrec
72  bind-case
73  bindable?
74  bind-lambda
75  bind-lambda*
76  bind-case-lambda
77  bind-case-lambda*
78  bind*
79  bind-loop
80  bind-let*
81  bind-let
82  bind-letrec
83  bind/cc
84  bindings
85  vector-car
86  vector-cdr
87  string-car
88  string-cdr
89  )
90
91(import scheme
92        (only (chicken condition) condition-case)
93        (only (chicken base) cut subvector gensym void receive identity print case-lambda error)
94        (only (chicken keyword) keyword?)
95        (only (chicken format) format)
96        )
97
98(import-for-syntax (only (chicken keyword) keyword?)
99                   (only (chicken format) format))
100
101(define vector-car (cut vector-ref <> 0))
102(define vector-cdr (cut subvector <> 1))
103(define string-car (cut string-ref <> 0))
104(define string-cdr (cut substring <> 1))
105
106;;; (bind-listify*)
107;;; (bind-listify* seq)
108;;; (bind-listify* pat seq)
109;;; (bind-listify* seq? seq-car seq-cdr)
110;;; ------------------------------------
111;;; the first version resets the internal database,
112;;; the second returns the car-cdr-pair corresponding to seq,
113;;; the third does the actual work transforming seq to a nested list
114;;; and the last adds support for a new sequence type.
115(define bind-listify*
116  (let ((db (list (cons (lambda (x) #t)
117                        (cons car cdr)))))
118    (case-lambda
119      (() (set! db ; reset
120            (list (cons (lambda (x) #t)
121                        (cons car cdr)))))
122      ((seq)
123       (let loop ((db db))
124         (if ((caar db) seq)
125           (cdar db)
126           (loop (cdr db)))))
127      ((pat seq)
128       (let ((gstop (gensym 'stop))
129             (seq-car (car (bind-listify* seq)))
130             (seq-cdr (cdr (bind-listify* seq)))
131             (literal? (lambda (x)
132                         (or (boolean? x)
133                             (string? x)
134                             (char? x)
135                             (number? x)
136                             (keyword? x))))
137             )
138         (let ((seq-null?
139                 (lambda (seq)
140                   (eq? (condition-case (seq-car seq)
141                          ((exn) gstop)) gstop))))
142           (let loop ((pat pat) (seq seq) (result '()))
143             (cond
144               ((null? pat)
145                (if (seq-null? seq)
146                  (reverse result)
147                  (error 'bind-listify* "length mismatch" pat seq)))
148               ;(reverse (cons seq result))))
149               ((pair? pat)
150                (let ((pfirst (car pat))
151                      (prest (cdr pat))
152                      (sfirst (seq-car seq))
153                      (srest (seq-cdr seq)))
154                  (cond
155                    ((and (symbol? pfirst) (eq? pfirst '_))
156                     (loop prest srest result))
157                    ((symbol? pfirst)
158                     (loop prest srest (cons sfirst result)))
159                    ((null? pfirst) ;;;
160                     (if (seq-null? sfirst)
161                       (loop prest
162                             srest
163                             (cons (bind-listify* pfirst sfirst) result))
164                       (error 'bind-listify* "length mismatch"
165                              pfirst sfirst)))
166                    ((pair? pfirst)
167                     (loop prest
168                           srest
169                           (cons (bind-listify* pfirst sfirst) result)))
170                    ((literal? pfirst)
171                     (if (equal? pfirst sfirst)
172                       (loop prest srest result)
173                       (error 'bind-listify*
174                              (format #f "literals ~s and ~s not equal?~%"
175                                      pfirst sfirst))))
176                    (else (error 'bind-listify*
177                                 (format #f "~s is not a valid literal~%")
178                                 pfirst))
179                    )))
180               (else
181                 (cond
182                   ((and (symbol? pat) (eq? pat '_))
183                    (reverse result))
184                   ((symbol? pat)
185                    (reverse (cons seq result)))
186                   ((literal? pat)
187                    (if (equal? pat seq)
188                      (reverse result)
189                      (error 'bind-listify*
190                              (format #f "literals ~s and ~s not equal?~%"
191                                      pat seq))))
192                   (else (error 'bind-listify*
193                                (format #f "~s is not a valid literal~%")
194                                pat))
195                   )))))))
196      ((seq? seq-car seq-cdr)
197       (set! db (cons (cons seq?
198                            (cons seq-car seq-cdr)) db)))
199      )))
200       
201
202;;; (bind-list pat lst . body)
203;;; --------------------------
204;;; flat versions of bind (symbol-lists only)
205(define-syntax bind-list
206  (ir-macro-transformer
207    (lambda (form inject compare?)
208      (let ((pat (cadr form)))
209        (if (null? (cddr form))
210          `(begin ,@(map (lambda (var)
211                           `(set! ,var ',var))
212                         pat))
213          (let ((lst (caddr form))); (seq (gensym)))
214            (if (null? (cdddr form))
215              ;`(begin ,@(map (lambda (var val)
216              ;                 `(set! ,var ,val))
217              ;               pat (eval lst)))
218              `(if (= ,(length pat) (length ,lst))
219                (begin
220                   ,@(let loop ((pat pat) (lst lst))
221                       (if (null? pat)
222                         '()
223                         (cons `(set! ,(car pat) (car ,lst))
224                               (loop (cdr pat) `(cdr ,lst))))))
225                (error 'bind-list "length mismatch" ',pat ,lst))
226              `(apply (lambda ,pat ,@(cdddr form))
227                      ,lst))))))))
228;(define-syntax bind-list
229;  (syntax-rules ()
230;    ((_ () ls)
231;     (if (null? ls)
232;       (if #f #f)
233;       (error 'bind-list "length mismatch" '() ls)))
234;    ((_ (a . as) ls)
235;     (begin (set! a (car ls)) (bind-list as (cdr ls))))
236;    ((_ pat)
237;     (bind-list pat 'pat))
238;    ((_ xs ls . body)
239;     (apply (lambda xs . body) ls))
240;    ))
241
242;;; (bind-list! pat lst)
243;;; (bind-list! pat)
244;;; --------------------
245;;; list version of bind!
246(define-syntax bind-list!
247  (syntax-rules ()
248    ((_ pat lst)
249     (bind-list pat lst))
250    ((_ pat)
251     (bind-list pat 'pat))
252    ))
253
254;;; (bind-list* pat seq . body)
255;;; ---------------------------
256;;; nested versions of bind (symbol-lists only)
257(define-syntax bind-list*
258  (er-macro-transformer
259    (lambda (form rename compare?)
260      (let ((pat (cadr form))
261            (seq (caddr form))
262            (body (cdddr form))
263            (%_ (rename '_))
264            (%let (rename 'let))
265            (%set! (rename 'set!))
266            (%bind (rename 'bind))
267            (%apply (rename 'apply))
268            (%begin (rename 'begin))
269            (%lambda (rename 'lambda))
270            (%bind-list (rename 'bind-list))
271            (%bind-list* (rename 'bind-list*))
272            )
273          (let* ((pat* (map (lambda (s)
274                          (if (symbol? s)
275                            s
276                            (cons (gensym) s)))
277                        pat))
278                 (flat-pat* (map (lambda (s)
279                                   (if (symbol? s)
280                                     s
281                                     (car s)))
282                                 pat*)))
283            (receive (pairs syms)
284              (let loop ((lst pat*) (yes '()) (no '()))
285                (cond
286                  ((null? lst)
287                   (values (reverse yes) (reverse no)))
288                  ((pair? (car lst))
289                   (loop (cdr lst) (cons (car lst) yes) no))
290                  ((symbol? (car lst))
291                   (loop (cdr lst) yes (cons (car lst) no)))
292                  (else (error 'bind "can't happen"))))
293              (if (null? body)
294                ;; without body
295                (if (null? pairs) ; flat list
296                  `(,%bind-list ,syms ,seq)
297                  ;; (bind-list* (a (b c)) '(1 (2 3)))
298                  ;; ->
299                  ;; (begin (bind-list (a g) seq)
300                  ;;        (bind-list* (b c) g))
301                  `(,%begin (,%bind-list ,flat-pat* ,seq)
302                            ,@(map (lambda (pair)
303                                     `(,%bind ,(cdr pair) ,(car pair)))
304                                   pairs)))
305                ;; with body
306                (let ((xpr (car body)) (xprs (cdr body)))
307                  (if (null? pairs) ; flat list
308                    ;`(,%apply (,%lambda ,syms ,xpr ,@xprs) ,seq)
309                    `(,%bind-list ,syms ,seq ,xpr ,@xprs)
310                    ;; (bind-list* (a (b c)) '(1 (2 3)) body)
311                    ;; ->
312                    ;; (apply (lambda (a g) (bind-list* (b c) g body))
313                    ;; seq)
314                    `(,%apply
315                       (,%lambda ,flat-pat*
316                                 ,(let loop ((pairs pairs))
317                                     (if (null? pairs)
318                                       `(,%begin ,xpr ,@xprs)
319                                       `(,%bind-list* ,(cdar pairs)
320                                                      ,(caar pairs)
321                                                      ,(loop (cdr pairs))))))
322                       ,seq)
323                     )))))))))
324
325;;; (bind pat seq . body)
326;;; ---------------------
327(define-syntax bind
328  (er-macro-transformer
329    (lambda (form rename compare?)
330      (let (
331        (pat (cadr form))
332        (seq (caddr form))
333        (body (cdddr form))
334        (%_ (rename '_))
335        (%bind-list* (rename 'bind-list*))
336        (%bind-listify* (rename 'bind-listify*))
337        (literal? (lambda (x)
338                    (or (boolean? x)
339                        (string? x)
340                        (char? x)
341                        (number? x)
342                        (keyword? x))))
343        )
344        (letrec (
345          (listify*
346            (lambda (pat)
347              (let loop ((pat pat) (result '()))
348                (cond
349                  ((null? pat)
350                   (reverse result))
351                  ((and (symbol? pat) (compare? pat %_))
352                   (reverse result))
353                  ((symbol? pat)
354                   (reverse (cons pat result)))
355                  ((literal? pat)
356                   (reverse result))
357                  ((pair? pat)
358                   (let ((first (car pat))
359                         (rest (cdr pat)))
360                     (cond
361                       ((and (symbol? first)
362                             (compare? first %_))
363                        (loop rest result))
364                       ((symbol? first)
365                        (loop rest (cons first result)))
366                       ((null? first) ;;;
367                        (loop rest (cons first result)))
368                       ((pair? first)
369                        (loop rest (cons (listify* first) result)))
370                       ((literal? first)
371                        (loop rest result))
372                       )))))))
373          )
374          (if (null? body)
375            ;; without body
376            `(,%bind-list* ,(listify* pat)
377                           (,%bind-listify* ',pat ,seq))
378            ;; with body
379            (let ((xpr (car body)) (xprs (cdr body)))
380              `(,%bind-list* ,(listify* pat)
381                             (,%bind-listify* ',pat ,seq)
382                             ,xpr ,@xprs)))
383          )))))
384
385;;; (bind! pat seq)
386;;; (bind! pat)
387;;; ---------------
388;;; alias to bind without body
389(define-syntax bind!
390  (syntax-rules ()
391    ((_ pat seq)
392     (bind pat seq))
393    ((_ pat)
394     (bind pat 'pat))))
395
396;;; (bindable? pat (where . fenders) seq)
397;;; (bindable? pat (where . fenders))
398;;; (bindable? pat seq)
399;;; (bindable? pat)
400;;; -------------------------------------
401(define-syntax bindable?
402  (syntax-rules (where)
403    ((_ pat (where fender ...) seq)
404     (condition-case (bind pat seq (and fender ...))
405       ((exn) #f)))
406    ((_ pat seq)
407     (condition-case (bind pat seq #t)
408       ((exn) #f)))
409    ;; curried versions
410    ((_ pat (where fender ...))
411     (lambda (seq)
412       (bindable? pat (where fender ...) seq)))
413    ((_ pat)
414     (lambda (seq)
415       (bindable? pat seq)))
416    ))
417
418#|[
419The following macro does more or less the same what the match macro from
420the matchable package does, for example
421
422  (bind-case '(1 (2 3))
423    ((x y) (>> y list?) (list x y))
424    ((x (y . z)) (list x y z))
425    ((x (y z)) (list x y z))) ;-> '(1 2 (3))
426
427or, to give a more realistic example, mapping:
428
429  (define (my-map fn lst)
430    (bind-case lst
431      (() '())
432      ((x . xs) (cons (fn x) (my-map fn xs)))))
433]|#
434
435;;; (bind-case seq (pat (where fender ...) xpr ....) ....)
436;;; (bind-case seq (pat xpr ....) ....)
437;;; ------------------------------------------------------
438;;; Checks if seq matches patterns pat  ....
439;;; in sequence, binds the pattern variables of the first matching
440;;; pattern to corresponding subexpressions of seq and executes
441;;; body expressions xpr .... in this context
442(define-syntax bind-case
443  (syntax-rules (where)
444    ((_ seq)
445     (error 'bind-case "no pattern to match" seq))
446    ((_ seq (pat (where fender ...) xpr . xprs))
447     (if (bindable? pat (where fender ...) seq)
448       (bind pat seq xpr . xprs)
449       (error 'bind-seq "sequence doesn't match pattern with fenders"
450              seq 'pat 'fender ...)))
451    ((_ seq (pat xpr . xprs))
452     (if (bindable? pat seq)
453       (bind pat seq xpr . xprs)
454       (error 'bind-seq "sequence doesn't match pattern" seq 'pat)))
455    ((_ seq (pat (where fender ...) xpr . xprs) . clauses)
456     (if (bindable? pat (where fender ...) seq)
457       (bind pat seq xpr . xprs)
458       (bind-case seq . clauses)))
459    ((_ seq (pat xpr . xprs) . clauses)
460     (if (bindable? pat seq)
461       (bind pat seq xpr . xprs)
462       (bind-case seq . clauses)))
463    ))
464
465#|[
466Now we can define two macros, which simply combine lambda with
467bind, the first destructures simply one argument, the second a
468whole list. An example of a call and its result is
469
470  ((bind-lambda (a (b . c) . d) (list a b c d))
471   '(1 #(20 30 40) 2 3))
472  -> '(1 20 #(30 40) (2 3)))))
473
474  ((bind-lambda* ((a (b . c) . d) (e . f))
475     (list a b c d e f))
476   '(1 #(20 30 40) 2 3) '#(4 5 6))
477  -> '(1 20 #(30 40) (2 3) 4 #(5 6)))
478]|#
479
480;;; (bind-lambda pat xpr ....)
481;;; --------------------------
482;;; combination of lambda and bind, one pattern argument
483(define-syntax bind-lambda
484  (syntax-rules ()
485    ((_ pat xpr . xprs)
486     (lambda (x) (bind pat x xpr . xprs)))
487    ))
488
489;;; (bind-lambda* pat xpr ....)
490;;; ---------------------------
491;;; combination of lambda and bind, multiple pattern arguments
492(define-syntax bind-lambda*
493  (syntax-rules ()
494    ((_ pat xpr . xprs)
495     (lambda x (bind pat x xpr . xprs)))
496     ))
497
498#|[
499The next two macros combine lambda and bind-case and do more or less the
500same as match-lambda and match-lambda* in the matchable package. The
501first destructures one argument, the second a list of arguments.
502Here is an example together with its result (note the >> fender):
503
504  ((bind-case-lambda
505     ((a (b . c) . d) (list a b c d))
506     ((e . f) (>> e zero?) e)
507     ((e . f) (list e f)))
508   '(1 2 3 4 5))
509  -> '(1 (2 3 4 5))
510
511  ((bind-case-lambda*
512     (((a (b . c) . d) (e . f))
513      (list a b c d e f)))
514   '(1 #(20 30 40) 2 3) '(4 5 6))
515  -> '(1 20 (30 40) (2 3) 4 (5 6))
516]|#
517
518;;; (bind-case-lambda (pat (where fender ...) xpr ....) ....)
519;;; (bind-case-lambda (pat xpr ....) ....)
520;;; ---------------------------------------------------------
521;;; combination of lambda and bind-case, one pattern argument
522(define-syntax bind-case-lambda
523  (syntax-rules (where)
524    ((_ (pat (where fender ...) xpr . xprs))
525     (lambda (x)
526       (bind-case x (pat (where fender ...) xpr . xprs))))
527    ((_ (pat xpr . xprs))
528     (lambda (x)
529       (bind-case x (pat xpr . xprs))))
530    ((_ clause . clauses)
531     (lambda (x)
532       (bind-case x clause . clauses)))
533    ))
534
535;;; (bind-case-lambda* (pat (where fender ...) xpr ....) ....)
536;;; (bind-case-lambda* (pat xpr ....) ....)
537;;; ----------------------------------------------------------
538;;; combination of lambda and bind-case, multiple pattern arguments
539(define-syntax bind-case-lambda*
540  (syntax-rules (where)
541    ((_ (pat (where fender ...) xpr . xprs))
542     (lambda x
543       (bind-case x (pat (where fender ...) xpr . xprs))))
544    ((_ (pat xpr . xprs))
545     (lambda x
546       (bind-case x (pat xpr . xprs))))
547    ((_ clause . clauses)
548     (lambda x
549       (bind-case x clause . clauses)))
550    ))
551
552#|[
553The following macro, bind-loop, is an anaphoric version of bind.
554It introduces an unrenamed symbol, loop, behind the scene and binds it
555to a procedure, which can be used in the body.
556For example
557
558  (bind-loop (x y) '(5 0)
559    (if (zero? x)
560      (list x y)
561      (loop (list (sub1 x) (add1 y)))))
562  -> '(0 5)
563]|#
564
565;;; (bind-loop pat seq xpr ....)
566;;; ---- ------------------------
567;;; anaphoric version of bind, introducing loop routine behind the scene
568(define-syntax bind-loop
569  (er-macro-transformer
570    (lambda (form rename compare?)
571      (let ((pat (cadr form))
572            (seq (caddr form))
573            (xpr (cadddr form))
574            (xprs (cddddr form))
575            (%letrec (rename 'letrec))
576            (%bind-lambda (rename 'bind-lambda)))
577        `((,%letrec ((loop (,%bind-lambda ,pat ,xpr ,@xprs)))
578            loop)
579          ,seq)))))
580
581#|[
582The following macro, bind*, is a named version of bind. It takes an
583additional argument besides those of bind, which is bound to a
584recursive procedure, which can be called in bind's body. The pattern
585variables are initialised with the corresponding subexpressions in seq.
586For example
587
588  (bind* loop (x y) '(5 0)
589    (if (zero? x)
590      (list x y)
591      (loop (list (sub1 x) (add1 y)))))
592  -> '(0 5)
593]|#
594
595;;; (bind* name pat seq xpr ....)
596;;; ---- ------------------------
597;;; named version of bind
598(define-syntax bind*
599  (syntax-rules ()
600    ((_ name pat seq xpr . xprs)
601     ((letrec ((name (bind-lambda pat xpr . xprs)))
602        name)
603      seq))))
604
605#|[
606The following three macros are analoga of the standard base macros let,
607let* and letrec, the first named or unnamed. For example
608
609(bind-let loop (((a b) '(5 0)))
610  (if (zero? a)
611    (list a b)
612    (loop (list (sub1 a) (add1 b)))))
613-> '(0 5)
614
615A recursive version of bind follows
616]|#
617
618;;; (bind-let* ((pat seq) ...) xpr . xprs)
619;;; --------------------------------------
620;;; sequentually binding patterns to sequences
621(define-syntax bind-let*
622  (syntax-rules ()
623    ((_ () xpr . xprs)
624     (let () xpr . xprs))
625    ((_ ((pat seq)) xpr . xprs)
626     (bind pat seq xpr . xprs))
627    ((_ ((pat seq) (pat1 seq1) ...) xpr . xprs)
628     (bind pat seq (bind-let* ((pat1 seq1) ...) xpr . xprs)))
629     ))
630
631;;; (bind-let name .. ((pat seq) ...) xpr . xprs)
632;;; ---------------------------------------------
633;;; binding patterns to sequences in parallel, whith or without a
634;;; recursive name procedure
635(define-syntax bind-let
636  (syntax-rules ()
637    ((_ ((pat seq) ...) xpr . xprs)
638     (bind (pat ...) (list seq ...) xpr . xprs))
639    ((_ name ((pat seq) ...) xpr . xprs)
640     ((letrec ((name (bind-lambda* (pat ...) xpr . xprs)))
641        name)
642      seq ...))
643    ))
644
645;;; (bind-letrec ((pat seq) ...) xpr . xprs)
646;;; ----------------------------------------
647;;; binding patterns to sequences recursively
648(define-syntax bind-letrec
649  (syntax-rules ()
650    ((_ ((pat seq) ...) xpr . xprs)
651     (bind-let ((pat 'pat) ...)
652       (bind! (pat ...) (list seq ...))
653       xpr . xprs))))
654   
655;;; (bindrec pat seq xpr . xprs)
656;;; ----------------------------
657;;; recursive version of bind
658(define-syntax bindrec
659  (syntax-rules ()
660    ((_ pat seq xpr . xprs)
661     (bind pat 'pat
662       (bind! pat seq)
663       xpr . xprs))))
664
665#|[
666I don't like the let/cc syntax, because it differs from let syntax,
667here is bind/cc, which does the same.
668]|#
669
670;;; (bind/cc cc xpr ....)
671;;; ---------------------
672;;; captures the current continuation, binds it to cc and executes
673;;; xpr .... in this context
674(define-syntax bind/cc
675  (syntax-rules ()
676    ((_ cc xpr . xprs)
677     (call-with-current-continuation
678       (lambda (cc) xpr . xprs)))))
679
680(define (symbol-dispatcher alist) ; internal
681  (case-lambda
682    (()
683     (map car alist))
684    ((sym)
685     (let ((pair (assq sym alist)))
686       (if pair
687         (for-each print (cdr pair))
688         (error "Not in list"
689                sym
690                (map car alist)))))))
691
692;;; (bindings sym ..)
693;;; -----------------
694;;; documentation procedure
695(define bindings
696  (symbol-dispatcher '(
697    (bindings
698      procedure:
699      (bindings sym ..)
700      "documentation procedure")
701    (bind-listify*
702      generic procedure:
703      (bind-listify*)
704      "resets the internal database for lists only"
705      (bind-listify* seq)
706      "returns the car-cdr-pair corresponding to seq"
707      (bind-listify* pat seq)
708      "transforms the nested pseudolist seq to a nested list"
709      (bind-listify* seq? seq-car seq-cdr)
710      "adds support for a new sequence type to the"
711      "internal database")
712    (bind-list
713      macro:
714      (bind-list pat lst . body)
715      "flat version of bind: destructure symbol-lists only")
716    (bind-list!
717      macro:
718      (bind-list! pat lst)
719      "alias to bind-list wtihout body"
720      (bind-list! pat)
721      "alias to (bind-list! pat 'pat)")
722    (bind-list*
723      macro:
724      (bind-list* pat seq . body)
725      "nested version of bind: destructure symbol-lists only"
726      "multiple set!s without")
727    (bind
728      macro:
729      (bind pat seq . body)
730      "a variant of Common Lisp's destructuring-bind with body"
731      "multiple set!s without")
732    (bind-case
733      macro:
734      (bind-case seq (pat (where fender ...) xpr ....) ....)
735      (bind-case seq (pat xpr ....) ....)
736      "matches seq against pat with optional fenders in a case regime")
737    (bindable?
738      macro:
739      (bindable? pat (where fender ...) seq)
740      (bindable? pat seq)
741      (bindable? pat (where fender ...))
742      (bindable? pat)
743      "The first two check if sequence seq matches pattern pat"
744      "with optional fenders."
745      "The second two are curried versions of the first two")
746    (bind!
747      macro:
748      (bind! pat seq)
749      "sets multiple variables by destructuring its sequence arguments")
750    (bind-lambda
751      macro:
752      (bind-lambda pat xpr ....)
753      "combination of lambda and bind, one pattern argument")
754    (bind-lambda*
755      macro:
756      (bind-lambda* pat xpr ....)
757      "combination of lambda and bind, multiple pattern arguments")
758    (bind*
759      macro:
760      (bind* loop pat seq xpr ....)
761      "named version of bind,"
762      "deprecated, use bind-loop instead")
763    (bind-loop
764      macro:
765      (bind-loop pat seq xpr ....)
766      "anaphoric version of bind,"
767      "introduces a routine named loop behind the scene,"
768      "to be used in the body xpr ....")
769    (bind-let
770      macro:
771      (bind-let loop .. ((pat seq) ...) xpr ....)
772      "nested version of let, named and unnamed")
773    (bind-let*
774      macro:
775      (bind-let* ((pat seq) ...) xpr ....)
776      "nested version of let*")
777    (bindrec
778      macro:
779      (bindrec pat seq xpr ....)
780      "recursive version of bind")
781    (bind-letrec
782      macro:
783      (bind-letrec ((pat seq) ...) xpr ....)
784      "recursive version of bind-let")
785    (bind-case-lambda
786      macro:
787      (bind-case-lambda (pat (where fender ...) xpr ....) ....)
788      (bind-case-lambda (pat xpr ....) ....)
789      "combination of lambda and bind-case with one pattern argument")
790    (bind-case-lambda*
791      macro:
792      (bind-case-lambda* (pat (where fender ...) xpr ....) ....)
793      (bind-case-lambda* (pat xpr ....) ....)
794      "combination of lambda and bind-case with multiple pattern arguments")
795    (bind/cc
796      macro:
797      (bind/cc cc xpr ....)
798      "binds cc to the current contiunation"
799      "and execute xpr ... in this context")
800    (vector-car
801      procedure:
802      (vector-car vec)
803      "vector-analog of car")
804    (vector-cdr
805      procedure:
806      (vector-cdr vec)
807      "vector-analog of cdr")
808    (string-car
809      procedure:
810      (string-car vec)
811      "string-analog of car")
812    (string-cdr
813      procedure:
814      (string-cdr vec)
815      "string-analog of cdr")
816    )))
817
818) ; module
819
Note: See TracBrowser for help on using the repository browser.