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

Last change on this file since 38814 was 38814, checked in by juergen, 10 months ago

bindings 4.1 with bugfix

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