Changeset 32959 in project


Ignore:
Timestamp:
12/06/15 12:34:35 (5 years ago)
Author:
juergen
Message:

bindings 4.1 without macro-rules and friends

Location:
release/4/bindings
Files:
2 deleted
8 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/bindings/tags/4.1/bindings.meta

    r32912 r32959  
    11;;;; bindings.meta -*- Scheme -*-
    22
    3 ((synopsis "Procedural-macros and destructuring bindings made easy")
     3((synopsis "Pattern matching with destructuring bindings")
    44 (category lang-exts)
    55 (license "BSD")
  • release/4/bindings/tags/4.1/bindings.scm

    r32912 r32959  
    137137bind.
    138138
    139 bind-case is the macro, which is heavily used in macro-rules. It does
    140 all the destructuring there while implicit renaming cares for variable
    141 captures.
    142 
    143 bind and bind-case are implemented in the first module, on which the
    144 others rely.
    145 
    146 Note, that the implementation of define-macro and macro-rules in the
    147 macro-bindings module is surprisingly easy having implicit-renaming
    148 macros and binding routines at ones disposal.
    149 ]|#
    150 
    151 (module basic-bindings
    152   (bind bind-case
     139]|#
     140
     141(require-library procedural-macros)
     142
     143(module bindings
     144  (bind bind-case bind-lambda bind-lambda* bind-case-lambda
     145   bind-case-lambda* bind* bind-let bind-let* bind-letrec bindrec
     146   bindable? bind-define bind-set! bind/cc
    153147   bind-seq-length bind-seq-ref bind-seq-tail bind-table-show bind-table-add!
    154148   bind-exception bind-exception-handler signal-bind-exception
    155    list-of vector-of symbol-dispatcher basic-bindings)
     149   list-of vector-of symbol-dispatcher bindings)
    156150  (import scheme
    157151          (only chicken case-lambda condition-case define-values
    158                 error subvector
     152                error subvector define-for-syntax
    159153                current-exception-handler condition-predicate
    160154                get-condition-property make-property-condition
    161155                make-composite-condition signal abort print)
    162           (only data-structures conjoin list-of?))
     156          (only data-structures conjoin list-of?)
     157          (only procedural-macros define-macro)
     158          )
    163159  (import-for-syntax
     160    (only procedural-macros macro-rules)
    164161    (only data-structures compress))
    165162
     
    310307]|#
    311308
    312 ;;; (bind pat seq (where . fenders) .. xpr ....)
     309;;; (bind pat (where . fenders) .. seq xpr ....)
    313310;;; ---------------------------------------------
    314311;;; binds pattern variables of pat to corresponding subexpressions of
     
    316313;;; fenders pass
    317314(define-syntax bind
    318   (ir-macro-transformer
    319     (lambda (form inject compare?)
    320       (letrec (
    321         (len 'bind-seq-length)
    322         (ref 'bind-seq-ref)
    323         (tail 'bind-seq-tail)
    324         (filter2
    325           (lambda (ok? lst)
    326             (let loop ((lst lst) (yes '()) (no '()))
    327               (if (null? lst)
    328                 (list (reverse yes) (reverse no))
    329                 (let ((first (car lst)) (rest (cdr lst)))
    330                   (if (ok? first)
    331                     (loop rest (cons first yes) no)
    332                     (loop rest yes (cons first no))))))))
    333         (mappend
    334           (lambda (fn lists)
    335             (apply append (map fn lists))))
    336         (destruc
    337           (lambda (pat seq)
    338             (let loop ((pat pat) (seq seq) (n 0))
    339               (cond
    340                 ((pair? pat)
    341                  (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
    342                    (cond
    343                      ((symbol? p)
    344                       (if (compare? p '_)
    345                         ;; skip
    346                         recu
    347                         (cons `(,p (,ref ,seq ,n)) recu)))
    348                      ((pair? p)
    349                       (let ((g (gensym)))
    350                         (cons (cons `(,g (,ref ,seq ,n))
    351                                     (loop p g 0))
    352                               recu)))
    353                      (else
    354                        (cons `(,p (equal? ',p (,ref ,seq ,n)))
    355                              recu))
    356                      )))
    357                 ((symbol? pat)
    358                  `((,pat (,tail ,seq ,n))))
    359                 ((null? pat)
    360                  `((,pat (zero? (,len (,tail ,seq ,n))))))
    361                 ))))
    362         (dbind-ex
    363           (lambda (binds body)
    364             (if (null? binds)
    365               `(begin ,@body)
    366               (apply (lambda (defs checks)
    367                        `(let ,defs
    368                           (if (and ,@(map cadr checks))
    369                             ,(dbind-ex
    370                                (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
    371                                         binds)
    372                                body)
    373                             (signal-bind-exception
    374                               'bind
    375                               "match error"
    376                               ',(cons 'and (map cadr checks))))
    377                           ))
    378                      (filter2 (lambda (pair) (symbol? (car pair)))
    379                               (map (lambda (b) (if (pair? (car b)) (car b) b))
    380                                    binds)))
    381               )))
    382         )         
    383         (let ((pat (cadr form))
    384               (seq (caddr form))
    385               (xpr (cadddr form))
    386               (xprs (cddddr form))
    387               (gseq 'seq))
    388           (let ((fender? (and (pair? xpr)
    389                               (compare? 'where (car xpr))))
    390                 (destruc-pat-gseq (destruc pat gseq)))
    391             (if fender?
    392               `(let ((,gseq ,seq))
    393                  (if ,(dbind-ex destruc-pat-gseq
    394                                 (list (cons 'and (cdr xpr))))
    395                    ,(dbind-ex destruc-pat-gseq xprs)
    396                    (signal-bind-exception 'bind
    397                                           "match error"
    398                                           ,gseq
    399                                           ',pat
    400                                           ',xpr)))
    401               `(let ((,gseq ,seq))
    402                  ,(dbind-ex destruc-pat-gseq (cons xpr xprs))))
    403             ))))))
     315  (macro-rules _ (where)
     316    ((bind pat (where . fenders) seq xpr . xprs)
     317     (letrec (
     318       (len 'bind-seq-length)
     319       (ref 'bind-seq-ref)
     320       (tail 'bind-seq-tail)
     321       (filter
     322         (lambda (ok? lst)
     323           (let loop ((lst lst) (yes '()) (no '()))
     324             (if (null? lst)
     325               (values (reverse yes) (reverse no))
     326               (let ((first (car lst)) (rest (cdr lst)))
     327                 (if (ok? first)
     328                   (loop rest (cons first yes) no)
     329                   (loop rest yes (cons first no))))))))
     330       (mappend
     331         (lambda (fn lists)
     332           (apply append (map fn lists))))
     333       (destruc
     334         (lambda (pat seq)
     335           (let loop ((pat pat) (seq seq) (n 0))
     336             (cond
     337               ((pair? pat)
     338                (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
     339                  (cond
     340                    ((symbol? p)
     341                     (if (eq? p _)
     342                       ;; skip
     343                       recu
     344                       `((,p (,ref ,seq ,n)) ,@recu)))
     345                    ((pair? p)
     346                     (let ((g (gensym)))
     347                       `(((,g (,ref ,seq ,n)) ,@(loop p g 0))
     348                         ,@recu)))
     349                    (else
     350                      `((,p (equal? ',p (,ref ,seq ,n)))
     351                        ,@recu))
     352                    )))
     353               ((symbol? pat)
     354                `((,pat (,tail ,seq ,n))))
     355               ((null? pat)
     356                `((,pat (zero? (,len (,tail ,seq ,n))))))
     357               ))))
     358       (dbind-ex
     359         (lambda (binds body)
     360           (if (null? binds)
     361             `(begin ,@body)
     362             (call-with-values
     363               (lambda ()
     364                 (filter (lambda (pair) (symbol? (car pair)))
     365                          (map (lambda (b) (if (pair? (car b)) (car b) b))
     366                               binds)))
     367               (lambda (defs checks)
     368                 `(let ,defs
     369                    (if (and ,@(map cadr checks))
     370                      ,(dbind-ex
     371                         (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
     372                                  binds)
     373                         `((if ,(cons 'and fenders)
     374                             (begin ,@body)
     375                             (signal-bind-exception
     376                               'bind
     377                               "fenders not passed"
     378                               ,seq
     379                               ',pat
     380                               ',(cons 'where fenders)))))
     381                      (signal-bind-exception
     382                        'bind
     383                        "match error"
     384                        ,seq
     385                        ',pat
     386                        ',(cons 'and (map cadr checks))))))
     387             ))))
     388       )         
     389       (let ((gseq 'seq))
     390         `(let ((,gseq ,seq))
     391            ,(dbind-ex (destruc pat gseq)
     392                       (cons xpr xprs)))
     393           )))
     394    ((bind pat seq xpr . xprs)
     395     `(bind ,pat (where #t) ,seq ,xpr ,@xprs))))
    404396
    405397#|[
     
    425417;;; inner version, not exported
    426418(define-syntax bind-case-inner
    427   (ir-macro-transformer
    428     (lambda (form inject compare?)
    429       (let ((seq (cadr form)) (clauses (cddr form)))
    430         (if (null? clauses)
    431           `(signal-bind-exception 'bind-case-inner
    432                                   "no match for"
    433                                   ,seq
    434                                   )
    435 
    436           `(condition-case (bind ,(caar clauses) ,seq ,@(cdar clauses))
    437              ((exn type)
    438               (bind-case ,seq ,@(cdr clauses)))
    439              ((exn bind)
    440               (bind-case ,seq ,@(cdr clauses)))))))))
     419  (macro-rules (where)
     420    ((_ seq (pat (where . fenders) xpr . xprs))
     421     `(bind ,pat (where ,@fenders) ,seq ,xpr ,@xprs))
     422    ((_ seq (pat xpr . xprs))
     423     `(bind ,pat (where #t) ,seq ,xpr ,@xprs))
     424    ((_ seq clause . clauses)
     425     `(condition-case (bind-case-inner ,seq ,clause)
     426        ((exn type)
     427         (bind-case-inner ,seq ,@clauses))
     428        ((exn bind)
     429         (bind-case-inner ,seq ,@clauses))))))
    441430
    442431;;; (bind-case seq (pat (where fender ...) .. xpr ....) ....)
     
    446435;;; pattern to corresponding subexpressions of seq and executes
    447436;;; corresponding body xpr ....
    448 (define-syntax bind-case
    449   (ir-macro-transformer
    450     (lambda (form inject compare?)
    451       (let ((seq (cadr form)) (clauses (cddr form)))
    452         `(condition-case (bind-case-inner ,seq ,@clauses)
    453            ((exn bind)
    454             (signal-bind-exception 'bind-case
    455                                    "no match for"
    456                                    ,seq
    457                                    ',(cons 'in
    458                                            (map (lambda (clause)
    459                                                   (list (car clause)
    460                                                         (if (and (pair? (cadr clause))
    461                                                                  (compare? (caadr clause) 'where))
    462                                                           (cadr clause)
    463                                                           (list 'where #t))))
    464                                           clauses)))))))))
     437(define-macro (bind-case seq clause . clauses)
     438  `(condition-case
     439     (bind-case-inner ,seq ,clause ,@clauses)
     440     ((exn bind)
     441      (signal-bind-exception
     442        'bind-case
     443        "no match for"
     444        ,seq
     445        'in
     446        ',(map (lambda (cl)
     447                 (list (car cl) (cadr cl)))
     448               (cons clause clauses))))))
     449
     450#|[
     451The next macro, bindable?, can be used to check, if a
     452sequence-expression matches a pattern and passes all fenders.
     453]|#
     454
     455;;; (bindable? pat (where fender ...) ..)
     456;;; -------------------------------------
     457;;; returns a unary predicate which checks, if its argument matches pat
     458;;; and fulfills the predicates in the list fender ...
     459;;; Mostly used in fenders of macro-rules and define-macro, but must
     460;;; then be imported for-syntax.
     461(define-syntax bindable?
     462  (macro-rules (where)
     463    ((_ pat (where . fenders))
     464     `(lambda (seq)
     465        (condition-case (bind ,pat seq (and ,@fenders))
     466          ((exn bind) #f))))
     467    ((_ pat)
     468     `(bindable? ,pat (where #t)))))
     469
     470#|[
     471The following two macros, bind-define and bind-set!, destructure their
     472sequence arguments with respect to their pattern argument and define or
     473set! the pattern variables correspondingly.  For example, one can define
     474multiple procedures operating on a common state
     475
     476  (bind-define (push top pop)
     477    (let ((state '()))
     478      (list
     479        (lambda (arg) (set! state (cons arg state)))
     480        (lambda () (car state))
     481        (lambda () (set! state (cdr state))))))
     482
     483]|#
     484
     485;; helper macro for bind-define and bind-set!
     486(define-syntax bind-def-set!
     487  (macro-rules _ (where)
     488    ((bind-def-set! pat (where . fenders) seq def?)
     489     (let ((sym? (lambda (p)
     490                   (and (symbol? p)
     491                        (not (eq? p _))))))
     492        (let ((aux (let copy ((pat pat))
     493                     (cond
     494                       ((sym? pat) (gensym))
     495                       ((pair? pat)
     496                        (cons (copy (car pat)) (copy (cdr pat))))
     497                       (else pat))))
     498              (flatten*
     499                ; imported flatten doesn't work with pseudo-lists
     500                (lambda (tree)
     501                  (let loop ((tree tree) (result '()))
     502                    (cond
     503                      ((pair? tree)
     504                       (loop (car tree) (loop (cdr tree) result)))
     505                      ((null? tree) result)
     506                      (else
     507                        (cons tree result))))))
     508              (filter
     509                (lambda (ok? lst)
     510                  (compress (map ok? lst) lst))))
     511          (if def?
     512            `(if ((bindable? ,pat (where ,@fenders)) ,seq)
     513               (begin
     514                 ,@(map (lambda (p) `(define ,p ',p))
     515                        (filter sym? (flatten* pat)))
     516                 (bind ,aux ,seq
     517                   ,@(map (lambda (p a) `(set! ,p ,a))
     518                          (filter sym? (flatten* pat))
     519                          (filter sym? (flatten* aux)))))
     520               (signal-bind-exception 'bind-define
     521                                      "fenders not passed"
     522                                      ',seq
     523                                      ',pat
     524                                      '(where ,@fenders)))
     525            `(if ((bindable? ,pat (where ,@fenders)) ,seq)
     526               (bind ,aux ,seq
     527                 ,@(map (lambda (p a) `(set! ,p ,a))
     528                        (filter sym? (flatten* pat))
     529                        (filter sym? (flatten* aux))))
     530               (signal-bind-exception 'bind-set!
     531                                      "fenders not passed"
     532                                      ',seq
     533                                      ',pat
     534                                      '(where ,@fenders)))))))
     535    ))
     536
     537
     538;;; (bind-define pat (where fender ...) .. seq)
     539;;; -------------------------------------------
     540;;; destructures the sequence seq according to the pattern pat and sets
     541;;; pattern variables with values corresponding to subexpressions of
     542;;; seq, provided the fenders are satisfied
     543(define-syntax bind-define
     544  (macro-rules (where)
     545    ((_ pat (where . fenders) seq)
     546     `(bind-def-set! ,pat (where ,@fenders) ,seq #t))
     547    ((_ pat seq)
     548     `(bind-def-set! ,pat (where #t) ,seq #t))))
     549
     550;;; (bind-set! pat (where fender ...) .. seq)
     551;;; -----------------------------------------
     552;;; sets pattern variables of pat to corresponding sub-expressins of
     553;;; seq, provided the fenders are satisfied
     554(define-syntax bind-set!
     555  (macro-rules (where)
     556    ((_ pat (where . fenders) seq)
     557     `(bind-def-set! ,pat (where ,@fenders) ,seq #f))
     558    ((_ pat seq)
     559     `(bind-def-set! ,pat (where #t) ,seq #f))))
     560
     561#|[
     562Now we can define two macros, which simply combine lambda with
     563bind, the first destructures simply one argument, the second a
     564whole list. An example of a call and its result is
     565
     566  ((bind-lambda (a (b . c) . d) (list a b c d))
     567   '(1 #(20 30 40) 2 3))
     568  -> '(1 20 #(30 40) (2 3)))))
     569
     570  ((bind-lambda* ((a (b . c) . d) (e . f))
     571     (list a b c d e f))
     572   '(1 #(20 30 40) 2 3) '#(4 5 6))
     573  -> '(1 20 #(30 40) (2 3) 4 #(5 6)))
     574]|#
     575
     576;;; (bind-lambda pat (where fender ...) .. xpr ....)
     577;;; ------------------------------------------------
     578;;; combination of lambda and bind, one pattern argument
     579(define-syntax bind-lambda
     580  (macro-rules (where)
     581    ((_ pat (where . fenders) xpr . xprs)
     582     `(lambda (x) (bind ,pat (where ,@fenders) x ,xpr ,@xprs)))
     583    ((_ pat xpr . xprs)
     584     `(bind-lambda ,pat (where #t) ,xpr ,@xprs))))
     585
     586;;; (bind-lambda* pat (where fender ...) .. xpr ....)
     587;;; -------------------------------------------------
     588;;; combination of lambda and bind, multiple pattern arguments
     589(define-syntax bind-lambda*
     590  (macro-rules (where)
     591    ((_ pat (where . fenders) xpr . xprs)
     592     `(lambda x (bind ,pat (where ,@fenders) x ,xpr ,@xprs)))
     593    ((_ pat xpr . xprs)
     594     `(bind-lambda* ,pat (where #t) ,xpr ,@xprs))))
     595
     596#|[
     597The next two macros combine lambda and bind-case and do more or less the
     598same as match-lambda and match-lambda* in the matchable package. The
     599first destructures one argument, the second a list of arguments.
     600Here is an example together with its result:
     601
     602  ((bind-case-lambda
     603     ((a (b . c) . d) (list a b c d))
     604     ((e . f) (where (zero? e)) e)
     605     ((e . f) (list e f)))
     606   '(1 2 3 4 5))
     607  -> '(1 (2 3 4 5))
     608
     609  ((bind-case-lambda*
     610     (((a (b . c) . d) (e . f))
     611      (list a b c d e f)))
     612   '(1 #(20 30 40) 2 3) '(4 5 6))
     613  -> '(1 20 #(30 40) (2 3) 4 (5 6))
     614]|#
     615
     616;;; (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
     617;;; ------------------------------------------------------------
     618;;; combination of lambda and bind-case, one pattern argument
     619(define-syntax bind-case-lambda
     620  (macro-rules (where)
     621    ((_ (pat (where . fenders) xpr . xprs))
     622     `(lambda (x)
     623        (bind-case x (,pat (where ,@fenders) ,xpr ,@xprs))))
     624    ((_ (pat xpr . xprs))
     625     `(lambda (x)
     626        (bind-case x (,pat ,xpr ,@xprs))))
     627    ((_ clause . clauses)
     628     `(lambda (x)
     629        (bind-case x ,clause ,@clauses)))))
     630
     631;;; (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
     632;;; -------------------------------------------------------------
     633;;; combination of lambda and bind-case, multiple pattern arguments
     634(define-syntax bind-case-lambda*
     635  (macro-rules (where)
     636    ((_ (pat (where . fenders) xpr . xprs))
     637     `(lambda x
     638        (bind-case x (,pat (where ,@fenders) ,xpr ,@xprs))))
     639    ((_ (pat xpr . xprs))
     640     `(lambda x
     641        (bind-case x (,pat ,xpr ,@xprs))))
     642    ((_ clause . clauses)
     643     `(lambda x
     644        (bind-case x ,clause ,@clauses)))))
     645
     646#|[
     647The following macro, bind*, is a named version of bind. It takes an
     648additional argument besides those of bind, which is bound to a
     649recursive procedure, which can be called in bind's body. The pattern
     650variables are initialised with the corresponding subexpressions in seq.
     651For example
     652
     653  (bind* loop (x y) '(5 0)
     654    (if (zero? x)
     655      (list x y)
     656      (loop (list (sub1 x) (add1 y)))))
     657  -> '(0 5)
     658]|#
     659
     660;;; (bind* name pat seq (where fender ...) .. xpr ....)
     661;;; ---------------------------------------------------
     662;;; named version of bind
     663(define-syntax bind*
     664  (macro-rules (where)
     665    ((_ name pat (where . fenders) seq xpr . xprs)
     666     `((letrec ((,name
     667                  (bind-lambda ,pat (where ,@fenders) ,xpr ,@xprs)))
     668         ,name)
     669       ,seq))
     670    ((_ name pat seq xpr . xprs)
     671     `(bind* ,name ,pat (where #t) ,seq ,xpr ,@xprs))))
     672
     673#|[
     674Now the implementation of a nested version of let, named and unnamed,
     675is easy: Simply combine bind and bind*. For example
     676
     677  (bind-let (
     678     (((x y) z) '((1 2) 3))
     679     (u (+ 2 2))
     680     ((v w) '(5 6))
     681     )
     682     (list x y z u v w))
     683  -> '(1 2 3 4 5 6)
     684
     685  (bind-let loop (((a b) '(5 0)))
     686    (if (zero? a)
     687      (list a b)
     688      (loop (list (sub1 a) (add1 b)))))
     689  -> '(0 5)
     690]|#
     691
     692;;; (bind-let loop .. ((pat (where fender ...) .. seq) ...) xpr ....)
     693;;; -----------------------------------------------------------------
     694;;; nested version of let, named and unnamed
     695(define-syntax bind-let
     696  (let ((last (lambda (lst)
     697                (let loop ((lst lst))
     698                  (if (null? (cdr lst))
     699                    (car lst)
     700                    (loop (cdr lst))))))
     701        (extract-fenders
     702          (lambda (pairs)
     703            (apply append
     704                   (map cdadr
     705                        (compress
     706                          (map (lambda (pair)
     707                                 (= (length pair) 3))
     708                               pairs)
     709                          pairs))))))
     710    (macro-rules (where)
     711      ((_ loop () xpr . xprs)
     712       `(let ,loop () ,xpr ,@xprs))
     713      ((_ loop ((pat0 (where . fenders) seq0) . pat-seq-pairs) xpr . xprs)
     714       `(bind* ,loop
     715          ,(cons pat0 (map car pat-seq-pairs))
     716          (where ,@(append fenders
     717                           (extract-fenders pat-seq-pairs)))
     718          (list ,seq0 ,@(map last pat-seq-pairs))
     719          ,xpr ,@xprs))
     720      ((_ loop ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
     721       `(bind* ,loop
     722          ,(cons pat0 (map car pat-seq-pairs))
     723          (where ,@(extract-fenders pat-seq-pairs))
     724          (list ,seq0 ,@(map last pat-seq-pairs))
     725          ,xpr ,@xprs))
     726      ((_ () xpr . xprs)
     727       `(let () ,xpr ,@xprs))
     728      ((_ ((pat0 (where . fenders) seq0) . pat-seq-pairs) xpr . xprs)
     729       `(bind
     730          ,(cons pat0 (map car pat-seq-pairs))
     731          (where ,@(append fenders
     732                           (extract-fenders pat-seq-pairs)))
     733          (list ,seq0 ,@(map last pat-seq-pairs))
     734          ,xpr ,@xprs))
     735      ((_ ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
     736       `(bind
     737          ,(cons pat0 (map car pat-seq-pairs))
     738          (where ,@(extract-fenders pat-seq-pairs))
     739          (list ,seq0 ,@(map last pat-seq-pairs))
     740          ,xpr ,@xprs))
     741    )))
     742
     743#|[
     744The sequential version of bind-let should work as follows
     745
     746  (bind-let* (
     747     (((x y) z) '((1 2) 3))
     748     (u (+ 1 2 x))
     749     ((v w) (list (+ z 2) 6))
     750     )
     751     (list x y z u v w))
     752  -> '(1 2 3 4 5 6)
     753]|#
     754
     755;;; (bind-let* ((pat (where fender ...) .. seq) ...) xpr ....)
     756;;; ----------------------------------------------------------
     757;;; sequential version of bind-let
     758(define-syntax bind-let*
     759  (macro-rules (where)
     760    ((_ () xpr . xprs)
     761     `(let () ,xpr ,@xprs))
     762    ((_ ((pat (where . fenders) seq) . pat-seq-pairs) xpr . xprs)
     763     `(bind ,pat (where ,@fenders) ,seq
     764        (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))
     765    ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
     766     `(bind ,pat ,seq
     767        (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))))
     768
     769#|[
     770And here is the recursive version of bind, which is used in bind-letrec.
     771
     772  (bindrec ((o?) e?)
     773    (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     774          (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     775    (list (o? 95) (e? 95)))
     776  -> '(#t #f)
     777]|#
     778
     779;;; (bindrec pat (where fender ...) .. seq xpr ....)
     780;;; ------------------------------------------------
     781;;; recursive version of bind
     782(define-syntax bindrec
     783  (macro-rules (where)
     784    ((_ pat (where . fenders) seq xpr . xprs)
     785     `(if ((bindable? ,pat) ,seq)
     786        (bind ,pat ',pat
     787          ; bind pattern variables to auxiliary values
     788          ; so that they are in scope
     789          (bind-set! ,pat (where ,@fenders) ,seq)
     790          ; set! the real values
     791          ,xpr ,@xprs)
     792        (signal-bind-exception 'bindrec
     793                               "fenders not passed"
     794                               ',seq
     795                               ',pat
     796                               '(where ,@fenders))))
     797    ((_ pat seq xpr . xprs)
     798     `(bindrec ,pat (where #t) ,seq ,xpr ,@xprs))))
     799
     800#|[
     801The recursive version of bind-let works as follows
     802 
     803  (bind-letrec (
     804    ((o? (e?))
     805     (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
     806           (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
     807    )
     808    (list (o? 95) (e? 95)))
     809  -> '(#t #f)
     810]|#
     811
     812;;; (bind-letrec ((pat (where fender ...) .. seq) ...) xpr ....)
     813;;; ------------------------------------------------------------
     814;;; recursive version of bind-let
     815(define-syntax bind-letrec
     816  (let ((last (lambda (lst)
     817                (let loop ((lst lst))
     818                  (if (null? (cdr lst))
     819                    (car lst)
     820                    (loop (cdr lst))))))
     821        (extract-fenders
     822          (lambda (pairs)
     823            (apply append
     824                   (map cdadr
     825                        (compress
     826                          (map (lambda (pair)
     827                                 (= (length pair) 3))
     828                               pairs)
     829                          pairs))))))
     830    (macro-rules (where)
     831      ((_ ((pat (where . fenders) seq) . pat-seq-pairs) xpr . xprs)
     832       `(bindrec ,(cons pat (map car pat-seq-pairs))
     833          (where ,@(append fenders
     834                           (extract-fenders pat-seq-pairs)))
     835          (list ,seq ,@(map last pat-seq-pairs))
     836          ,xpr ,@xprs))
     837      ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
     838       `(bindrec ,(cons pat (map car pat-seq-pairs))
     839          (where ,@(extract-fenders pat-seq-pairs))
     840          (list ,seq ,@(map last pat-seq-pairs))
     841          ,xpr ,@xprs))
     842      ((_ () xpr . xprs)
     843       `(let () ,xpr ,@xprs))
     844    )))
     845
     846#|[
     847The following macro is sometimes named let/cc or let-cc
     848]|#
     849
     850;;; (bind/cc cc xpr ....)
     851;;; ---------------------
     852;;; captures the current continuation, binds it to cc and executes
     853;;; xpr .... in this context
     854(define-macro (bind/cc cc xpr . xprs)
     855  `(call-with-current-continuation
     856     (lambda (,cc) ,xpr ,@xprs)))
    465857
    466858#|[
     
    508900                (map car alist)))))))
    509901
    510 ;;; (basic-bindings sym ..)
    511 ;;; -----------------------
    512 ;;; documentation procedure of this module
    513 (define basic-bindings
     902;;; (bindings sym ..)
     903;;; ----------------------
     904;;; documentation procedure
     905(define bindings
    514906  (symbol-dispatcher '(
    515907    (bind
    516908      macro:
    517       (bind pat seq (where . fenders) .. xpr ....)
     909      (bind pat (where fender ...) .. seq xpr ....)
    518910      "a variant of Common Lisp's destructuring-bind")
    519911    (bind-case
    520912      macro:
    521       (bind-case seq (pat (where . fenders) .. xpr ....) ....)
     913      (bind-case seq (pat (where fender ...) .. xpr ....) ....)
    522914      "matches seq against pat with optional fenders in a case regime")
     915    (bindable?
     916      macro:
     917      (bindable? pat (where fender ...) ..)
     918      "returns a unary predicate, which checks"
     919      "if its argument matches pat and passes all fenders")
     920    (bind-set!
     921      macro:
     922      (bind-set! pat (where fender ...) .. seq)
     923      "sets multiple variables by destructuring its sequence argument")
     924    (bind-define
     925      macro:
     926      (bind-define pat (where fender ...) .. seq)
     927      "defines multiple variables by destructuring its sequence argument")
     928    (bind-lambda
     929      macro:
     930      (bind-lambda pat (where fender ...) .. xpr ....)
     931      "combination of lambda and bind, one pattern argument")
     932    (bind-lambda*
     933      macro:
     934      (bind-lambda* pat (where fender ...) .. xpr ....)
     935      "combination of lambda and bind, multiple pattern arguments")
     936    (bind*
     937      macro:
     938      (bind* loop pat (where fender ...) .. seq xpr ....)
     939      "named version of bind")
     940    (bind-let
     941      macro:
     942      (bind-let loop .. ((pat (where fender ...) .. seq) ...) xpr ....)
     943      "nested version of let, named and unnamed")
     944    (bind-let*
     945      macro:
     946      (bind-let* ((pat (where fender ...) .. seq) ...) xpr ....)
     947      "nested version of let*")
     948    (bindrec
     949      macro:
     950      (bindrec pat (where fender ...) .. seq xpr ....)
     951      "recursive version of bind")
     952    (bind-letrec
     953      macro:
     954      (bind-letrec ((pat (where fender ...) .. seq) ...) xpr ....)
     955      "recursive version of bind-let")
     956    (bind-case-lambda
     957      macro:
     958      (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
     959      "combination of lambda and bind-case with one pattern argument")
     960    (bind-case-lambda*
     961      macro:
     962      (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
     963      "combination of lambda and bind-case with multiple pattern arguments")
     964    (bind/cc
     965      macro:
     966      (bind/cc cc xpr ....)
     967      "binds cc to the current contiunation"
     968      "and execute xpr ... in this context")
    523969    (bind-exception
    524970      procedure:
     
    5691015      "cars or the cdr or the alist item with symbol as car")
    5701016    )))
    571 
    572 ) ; basic-bindings
    573 
    574 
    575 #|[
    576 Now we'll use bind-case to create procedural macros.  The first,
    577 macro-rules, is a procedural version of syntax-rules. It is as
    578 convenient as the latter, but much more powerfull. For example, it can
    579 use injected symbols and once pattern variables, do some of its work at
    580 compile-time, use local functions at compile-time and what have you.
    581 Contrary to syntax-rules the templates usually evaluate to quasiquoted
    582 expressions.
    583 Other procedural macro-building routines are provided as well, in
    584 particular, a hygienic define-macro, based on bind as well as local
    585 versions of it, macro-let and macro-letrec.
    586 ]|#
    587 
    588 (module macro-bindings
    589   (define-macro macro-rules macro-let macro-letrec once-only
    590     ;mac-rules
    591    with-gensyms macro-bindings)
    592   (import scheme basic-bindings)
    593   (import-for-syntax
    594     (only basic-bindings bind bind-case)
    595     (only data-structures compress))
    596 
    597 
    598 ;;; (macro-rules sym ... (key ...) (pat (where fender ...) .. tpl) ....)
    599 ;;; --------------------------------------------------------------------
    600 ;;; where sym ... are injected non-hygienig symbols, key ... are
    601 ;;; additional keywords, pat ....  are nested lambda-lists without
    602 ;;; spezial meaning of ellipses and tpl .... usually evaluate to
    603 ;;; quasiquoted templates. The optional fenders belong to the pattern
    604 ;;; matching process.
    605 (define-syntax macro-rules
    606   (ir-macro-transformer
    607     (lambda (f i c?)
    608       (let ((f* (let loop ((tail (cdr f)) (head '()))
    609                   (if (symbol? (car tail))
    610                     (loop (cdr tail) (cons (car tail) head))
    611                     (cons head tail)))))
    612         (let ((syms (car f*))
    613               (keys (cadr f*))
    614               (rules (cddr f*))
    615               (flatten*
    616                 ; imported flatten doesn't work with pseudo-lists
    617                 (lambda (tree)
    618                   (let loop ((tree tree) (result '()))
    619                     (cond
    620                       ((pair? tree)
    621                        (loop (car tree) (loop (cdr tree) result)))
    622                       ((null? tree) result)
    623                       (else
    624                         (cons tree result)))))))
    625           `(ir-macro-transformer
    626              (lambda (form inject compare?)
    627                (let ,(map (lambda (s)
    628                             `(,s (inject ',s)))
    629                           syms)
    630                  (bind-case form
    631                    ,@(map (lambda (rule)
    632                             (let* ((pat (car rule))
    633                                    (fpat (flatten* pat))
    634                                    (kpat (compress
    635                                            (map (lambda (x)
    636                                                   (memq x keys))
    637                                                 fpat)
    638                                            fpat))
    639                                    ;; compare? keywords with its names
    640                                    (key-checks
    641                                      (map (lambda (p s)
    642                                             `(compare? ,p ,s))
    643                                           kpat
    644                                           (map (lambda (x) `',x)
    645                                                kpat))))
    646                               (let ((tpl (cdr rule)))
    647                                 ;; add key-checks to where clause of tpl
    648                                 (if (and (pair? (car tpl))
    649                                          (c? (caar tpl) 'where))
    650                                   `(,pat (where ,@key-checks ,@(cdar tpl))
    651                                          ,@(cdr tpl))
    652                                   `(,pat (where ,@key-checks) ,@tpl)))))
    653                           rules))))))))))
    654 
    655 ;;; (define-macro (name . args) (where fender ...) .. xpr ....)
    656 ;;; -----------------------------------------------------------
    657 ;;; simple hygienic macro without injections and keywords, but with
    658 ;;; fenders and once arguments.
    659 (define-syntax define-macro
    660   (ir-macro-transformer
    661     (lambda (f i c?)
    662       (let ((code (cadr f))
    663             (xpr (caddr f))
    664             (xprs (cdddr f)))
    665         `(define-syntax ,(car code)
    666            (ir-macro-transformer
    667              (lambda (form inject compare?)
    668                (bind ,(cdr code) (cdr form) ,xpr ,@xprs))))))))
    669 
    670 #|[
    671 Now follow the local versions of define-macro, macro-let and
    672 macro-letrec. Since the syntax of both is identical, they are
    673 implemented by means of a helper macro.
    674 ]|#
    675 
    676 ;; helper for macro-let and macro-letrec
    677 (define-syntax macro
    678   (ir-macro-transformer
    679     (lambda (form inject compare?)
    680       (let ((op (cadr form))
    681             (pat-tpl-pairs (caddr form))
    682             (xpr (cadddr form))
    683             (xprs (cddddr form)))
    684         (let ((pats (map car pat-tpl-pairs))
    685               (tpls (map cdr pat-tpl-pairs)))
    686           `(,op ,(map (lambda (pat tpl)
    687                                `(,(car pat)
    688                                   (macro-rules ()
    689                                      ((_ ,@(cdr pat)) ,@tpl))))
    690                               pats tpls)
    691                        ,xpr ,@xprs))))))
    692 
    693 ;;; (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    694 ;;; -------------------------------------------------------------------------
    695 ;;; evaluates body ... in the context of parallel macros name ....
    696 (define-syntax macro-let
    697   (ir-macro-transformer
    698     (lambda (form inject compare?)
    699       (let ((pat-tpl-pairs (cadr form))
    700             (xpr (caddr form))
    701             (xprs (cdddr form)))
    702         `(macro let-syntax ,pat-tpl-pairs ,xpr ,@xprs)))))
    703 
    704 ;;; (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    705 ;;; ----------------------------------------------------------------------------
    706 ;;; evaluates body ... in the context of recursive macros name ....
    707 (define-syntax macro-letrec
    708   (ir-macro-transformer
    709     (lambda (form inject compare?)
    710       (let ((pat-tpl-pairs (cadr form))
    711             (xpr (caddr form))
    712             (xprs (cdddr form)))
    713         `(macro letrec-syntax ,pat-tpl-pairs ,xpr ,@xprs)))))
    714 
    715 ;;; (with-gensyms (name ....) xpr ....)
    716 ;;; -----------------------------------
    717 ;;; binds name ... to (gensym 'name) ... in body xpr ...
    718 (define-syntax with-gensyms
    719   (ir-macro-transformer
    720     (lambda (form inject compare?)
    721       `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
    722          ,@(cddr form)))))
    723 
    724 ;;; (once-only (x ....) xpr ....)
    725 ;;; -----------------------------
    726 ;;; macro-arguments x .... are only evaluated once and from left to
    727 ;;; right in the body xpr ....
    728 ;;; The code is more or less due to
    729 ;;; P. Seibel, Practical Common Lisp, p. 102
    730 (define-syntax once-only
    731   (ir-macro-transformer
    732     (lambda (form inject compare?)
    733       (let ((names (cadr form))
    734             (body (cddr form)))
    735         (let ((gensyms (map (lambda (x) (gensym)) names)))
    736           `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
    737              `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
    738                                  gensyms names))
    739                 ,(let ,(map (lambda (n g) `(,n ,g))
    740                             names gensyms)
    741                    ,@body))))))))
    742 
    743 ;;; (macro-bindings sym ..)
    744 ;;; -----------------------
    745 ;;; documentation procedure.
    746 (define macro-bindings
    747   (symbol-dispatcher '(
    748     (macro-rules
    749       macro:
    750       (macro-rules literal ... (keyword ...) (pat tpl) ....)
    751       "procedural version of syntax-rules"
    752       "with optional injected literals"
    753       "and quasiquoted templates")
    754     (define-macro
    755       macro:
    756       (define-macro (name . args) xpr ....)
    757       "a version of macro-rules with only one rule"
    758       "no injected symbols and no keywords")
    759     (macro-let
    760       macro:
    761       (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    762       "evaluates body ... in the context of parallel macros name ....")
    763     (macro-letrec
    764       macro:
    765       (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    766       "evaluates body ... in the context of recursive macros name ....")
    767     (once-only
    768       macro:
    769       (once-only (x ....) xpr ....)
    770       "arguments x ... are evaluated only once and"
    771       "from left to right in the body xpr ....")
    772     (with-gensyms
    773       macro:
    774       (with-gensyms (x ....) xpr ....)
    775       "generates a series of gensyms x .... to be used in body xpr ...")
    776     )))
    777 ) ; macro-bindings
    778 
    779 #|[
    780 The binding macros to follow are all implemented either with
    781 define-macro or with macro-rules, hence the latter must be
    782 imported for-syntax. Had we chosen the direct implementation of
    783 define-macro with bind instead of macro-rules, we had to import
    784 for-syntax bind as well. This is the reason, why separate modules are
    785 needed. Note, that the fundamental macros, bind and bind-case, know how
    786 to handle where clauses. Hence the derived macros do as well.
    787 ]|#
    788 
    789 (module more-bindings *
    790   (import scheme
    791           basic-bindings
    792           (except macro-bindings macro-rules)
    793           )
    794   (import-for-syntax (only basic-bindings bind)
    795                      (only macro-bindings macro-rules))
    796 
    797 #|[
    798 The next macro, bindable?, can be used to check, if a
    799 sequence-expression matches a pattern and passes all fenders.
    800 ]|#
    801 
    802 ;;; (bindable? pat (where fender ...) ..)
    803 ;;; -------------------------------------
    804 ;;; returns a unary predicate which checks, if its argument matches pat
    805 ;;; and fulfills the predicates in the list fender ...
    806 ;;; Mostly used in fenders of macro-rules and define-macro, but must
    807 ;;; then be imported for-syntax.
    808 (define-syntax bindable?
    809   (macro-rules (where)
    810     ((_ pat (where . fenders))
    811      `(lambda (seq)
    812         (condition-case (bind ,pat seq (and ,@fenders))
    813           ((exn bind) #f))))
    814     ((_ pat)
    815      `(bindable? ,pat (where)))))
    816 
    817 #|[
    818 The following two macros, bind-define and bind-set!, destructure their
    819 sequence arguments with respect to their pattern argument and define or
    820 set! the pattern variables correspondingly.  For example, one can define
    821 multiple procedures operating on a common state
    822 
    823   (bind-define (push top pop)
    824     (let ((state '()))
    825       (list
    826         (lambda (arg) (set! state (cons arg state)))
    827         (lambda () (car state))
    828         (lambda () (set! state (cdr state))))))
    829 
    830 ]|#
    831 
    832 ;; helper macro for bind-define and bind-set!
    833 (define-macro (bind-def-set! pat seq def?)
    834   (let ((sym? (lambda (p)
    835                 (and (symbol? p)
    836                      (not (compare? p '_))))))
    837     (let ((aux (let copy ((pat pat))
    838                  (cond
    839                    ((sym? pat) (gensym))
    840                    ((pair? pat)
    841                     (cons (copy (car pat)) (copy (cdr pat))))
    842                    (else pat))))
    843           (flatten*
    844             ; imported flatten doesn't work with pseudo-lists
    845             (lambda (tree)
    846               (let loop ((tree tree) (result '()))
    847                 (cond
    848                   ((pair? tree)
    849                    (loop (car tree) (loop (cdr tree) result)))
    850                   ((null? tree) result)
    851                   (else
    852                     (cons tree result))))))
    853           (filter
    854             (lambda (ok? lst)
    855               (compress (map ok? lst) lst))))
    856       (if def?
    857         `(begin
    858            ,@(map (lambda (p) `(define ,p ',p))
    859                   (filter sym? (flatten* pat)))
    860            (bind ,aux ,seq
    861              ,@(map (lambda (p a) `(set! ,p ,a))
    862                     (filter sym? (flatten* pat))
    863                     (filter sym? (flatten* aux)))))
    864         `(begin
    865            (bind ,aux ,seq
    866              ,@(map (lambda (p a) `(set! ,p ,a))
    867                     (filter sym? (flatten* pat))
    868                     (filter sym? (flatten* aux))))))
    869       )))
    870 
    871 
    872 ;;; (bind-define pat seq)
    873 ;;; ---------------------
    874 ;;; destructures the sequence seq according to the pattern pat and sets
    875 ;;; pattern variables with values corresponding to subexpressions of seq
    876 (define-macro (bind-define pat seq)
    877   `(bind-def-set! ,pat ,seq #t))
    878 
    879 ;;; (bind-set! pat seq)
    880 ;;; -------------------
    881 ;;; sets pattern variables of pat to corresponding sub-expressins of seq
    882 (define-macro (bind-set! pat seq)
    883   `(bind-def-set! ,pat ,seq #f))
    884 
    885 #|[
    886 Now we can define two macros, which simply combine lambda with
    887 bind, the first destructures simply one argument, the second a
    888 whole list. An example of a call and its result is
    889 
    890   ((bind-lambda (a (b . c) . d) (list a b c d))
    891    '(1 #(20 30 40) 2 3))
    892   -> '(1 20 #(30 40) (2 3)))))
    893 
    894   ((bind-lambda* ((a (b . c) . d) (e . f))
    895      (list a b c d e f))
    896    '(1 #(20 30 40) 2 3) '#(4 5 6))
    897   -> '(1 20 #(30 40) (2 3) 4 #(5 6)))
    898 ]|#
    899 
    900 ;;; (bind-lambda pat (where fender ...) .. xpr ....)
    901 ;;; ------------------------------------------------
    902 ;;; combination of lambda and bind, one pattern argument
    903 (define-macro (bind-lambda pat xpr . xprs)
    904   `(lambda (x) (bind ,pat x ,xpr ,@xprs)))
    905 
    906 ;;; (bind-lambda* pat (where fender ...) .. xpr ....)
    907 ;;; -------------------------------------------------
    908 ;;; combination of lambda and bind, multiple pattern arguments
    909 (define-macro (bind-lambda* pat xpr . xprs)
    910   `(lambda x (bind ,pat x ,xpr ,@xprs)))
    911 
    912 #|[
    913 The following macro, bind*, is a named version of bind. It takes an
    914 additional argument besides those of bind, which is bound to a
    915 recursive procedure, which can be called in bind's body. The pattern
    916 variables are initialised with the corresponding subexpressions in seq.
    917 For example
    918 
    919   (bind* loop (x y) '(5 0)
    920     (if (zero? x)
    921       (list x y)
    922       (loop (list (sub1 x) (add1 y)))))
    923   -> '(0 5)
    924 ]|#
    925 
    926 ;;; (bind* name pat seq (where . fenders) .. xpr ....)
    927 ;;; ---------------------------------------------------
    928 ;;; named version of bind
    929 (define-macro (bind* name pat seq xpr . xprs)
    930   `((letrec ((,name
    931                (bind-lambda ,pat ,xpr ,@xprs)))
    932       ,name)
    933     ,seq))
    934 
    935 #|[
    936 Now the implementation of a nested version of let, named and unnamed,
    937 is easy: Simply combine bind and bind*. For example
    938 
    939   (bind-let (
    940      (((x y) z) '((1 2) 3))
    941      (u (+ 2 2))
    942      ((v w) '(5 6))
    943      )
    944      (list x y z u v w))
    945   -> '(1 2 3 4 5 6)
    946 
    947   (bind-let loop (((a b) '(5 0)))
    948     (if (zero? a)
    949       (list a b)
    950       (loop (list (sub1 a) (add1 b)))))
    951   -> '(0 5)
    952 ]|#
    953 
    954 ;;; (bind-let loop .. ((pat seq) ...) xpr ....)
    955 ;;; --------------------------------------------
    956 ;;; nested version of let, named and unnamed
    957 (define-syntax bind-let
    958   (macro-rules ()
    959     ((_ loop () xpr . xprs)
    960      `(let ,loop () ,xpr ,@xprs))
    961     ((_ loop ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
    962      `(bind* ,loop
    963         ,(cons pat0 (map car pat-seq-pairs))
    964         (list ,seq0 ,@(map cadr pat-seq-pairs))
    965         ,xpr ,@xprs))
    966     ((_ () xpr . xprs)
    967      `(begin ,xpr ,@xprs))
    968     ((_ ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
    969      `(bind
    970         ,(cons pat0 (map car pat-seq-pairs))
    971         (list ,seq0 ,@(map cadr pat-seq-pairs))
    972         ,xpr ,@xprs))
    973     ))
    974 
    975 #|[
    976 The sequential version of bind-let should work as follows
    977 
    978   (bind-let* (
    979      (((x y) z) '((1 2) 3))
    980      (u (+ 1 2 x))
    981      ((v w) (list (+ z 2) 6))
    982      )
    983      (list x y z u v w))
    984   -> '(1 2 3 4 5 6)
    985 ]|#
    986 
    987 ;;; (bind-let* ((pat seq) ...) xpr ....)
    988 ;;; -------------------------------------
    989 ;;; sequential version of bind-let
    990 (define-syntax bind-let*
    991   (macro-rules ()
    992     ((_ () xpr . xprs)
    993      `(let () ,xpr ,@xprs))
    994     ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
    995      `(bind ,pat ,seq (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))))
    996 
    997 #|[
    998 And here is the recursive version of bind.
    999 
    1000   (bindrec ((o?) e?)
    1001     (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    1002           (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    1003     (list (o? 95) (e? 95)))
    1004   -> '(#t #f)
    1005 ]|#
    1006 
    1007 ;;; (bindrec pat seq (where . fenders) .. xpr ....)
    1008 ;;; -----------------------------------------------
    1009 ;;; recursive version of bind
    1010 (define-macro (bindrec pat seq xpr . xprs)
    1011   `(bind ,pat ',pat
    1012      ; bind pattern variables to auxiliary values
    1013      ; so that they are in scope
    1014      (bind-set! ,pat ,seq)
    1015      ; set! the real values
    1016      ,xpr ,@xprs))
    1017 
    1018 #|[
    1019 The recursive version of bind-let works as follows
    1020  
    1021   (bind-letrec (
    1022     ((o? (e?))
    1023      (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
    1024            (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    1025     )
    1026     (list (o? 95) (e? 95)))
    1027   -> '(#t #f)
    1028 ]|#
    1029 
    1030 ;;; (bind-letrec ((pat seq) ...) xpr ....)
    1031 ;;; ---------------------------------------
    1032 ;;; recursive version of bind-let
    1033 (define-macro (bind-letrec pat-seq-pairs xpr . xprs)
    1034   `(bindrec ,(map car pat-seq-pairs)
    1035      (list ,@(map cadr pat-seq-pairs))
    1036      ,xpr ,@xprs))
    1037 
    1038 #|[
    1039 The next two macros combine lambda and bind-case and do more or less the
    1040 same as match-lambda and match-lambda* in the matchable package. The
    1041 first destructures one argument, the second a list of arguments.
    1042 Here is an example together with its result:
    1043 
    1044   ((bind-case-lambda
    1045      ((a (b . c) . d) (list a b c d))
    1046      ((e . f) (where (zero? e)) e)
    1047      ((e . f) (list e f)))
    1048    '(1 2 3 4 5))
    1049   -> '(1 (2 3 4 5))
    1050 
    1051   ((bind-case-lambda*
    1052      (((a (b . c) . d) (e . f))
    1053       (list a b c d e f)))
    1054    '(1 #(20 30 40) 2 3) '(4 5 6))
    1055   -> '(1 20 #(30 40) (2 3) 4 (5 6))
    1056 ]|#
    1057 
    1058 ;;; (bind-case-lambda (pat (where . fenders) .. xpr ....) ....)
    1059 ;;; ------------------------------------------------------------
    1060 ;;; combination of lambda and bind-case, one pattern argument
    1061 (define-syntax bind-case-lambda
    1062   (macro-rules ()
    1063     ((_ (pat xpr . xprs))
    1064      `(lambda (x) (bind ,pat x ,xpr ,@xprs)))
    1065     ((_ clause . clauses)
    1066      `(lambda (x)
    1067        (bind-case x ,clause ,@clauses)))))
    1068 
    1069 ;;; (bind-case-lambda* (pat (where . fenders) .. xpr ....) ....)
    1070 ;;; -------------------------------------------------------------
    1071 ;;; combination of lambda and bind-case, multiple pattern arguments
    1072 (define-syntax bind-case-lambda*
    1073   (macro-rules ()
    1074     ((_ (pat xpr . xprs))
    1075      `(lambda x (bind ,pat x ,xpr ,@xprs)))
    1076     ((_ clause . clauses)
    1077      `(lambda x
    1078        (bind-case x ,clause ,@clauses)))))
    1079 
    1080 #|[
    1081 The following macro is sometimes named let/cc or let-cc
    1082 ]|#
    1083 
    1084 ;;; (bind/cc cc xpr ....)
    1085 ;;; ---------------------
    1086 ;;; captures the current continuation, binds it to cc and executes
    1087 ;;; xpr .... in this context
    1088 (define-macro (bind/cc cc xpr . xprs)
    1089   `(call-with-current-continuation
    1090      (lambda (,cc) ,xpr ,@xprs)))
    1091 
    1092 ;;; (more-bindings sym ..)
    1093 ;;; ----------------------
    1094 ;;; documentation procedure
    1095 (define more-bindings
    1096   (symbol-dispatcher '(
    1097     (bindable?
    1098       macro:
    1099       (bindable? pat (where . fenders) ..)
    1100       "returns a unary predicate, which checks"
    1101       "if its argument matches pat and passes all fenders")
    1102     (bind-set!
    1103       macro:
    1104       (bind-set! pat seq)
    1105       "sets multiple variables by destructuring its sequence argument")
    1106     (bind-define
    1107       macro:
    1108       (bind-define pat seq)
    1109       "defines multiple variables by destructuring its sequence argument")
    1110     (bind-lambda
    1111       macro:
    1112       (bind-lambda pat (where . fenders) .. xpr ....)
    1113       "combination of lambda and bind, one pattern argument")
    1114     (bind-lambda*
    1115       macro:
    1116       (bind-lambda* pat (where . fenders) .. xpr ....)
    1117       "combination of lambda and bind, multiple pattern arguments")
    1118     (bind*
    1119       macro:
    1120       (bind* loop pat seq (where . fenders) .. xpr ....)
    1121       "named version of bind")
    1122     (bind-let
    1123       macro:
    1124       (bind-let loop .. ((pat seq) ...) xpr ....)
    1125       "nested version of let, named and unnamed")
    1126     (bind-let*
    1127       macro:
    1128       (bind-let* ((pat seq) ...) xpr ....)
    1129       "nested version of let*")
    1130     (bindrec
    1131       macro:
    1132       (bindrec pat seq (where . fenders) .. xpr ....)
    1133       "recursive version of bind")
    1134     (bind-letrec
    1135       macro:
    1136       (bind-letrec ((pat seq) ...) xpr ....)
    1137       "recursive version of bind-let")
    1138     (bind-case-lambda
    1139       macro:
    1140       (bind-case-lambda (pat (where . fenders) .. xpr ....) ....)
    1141       "combination of lambda and bind-case with one pattern argument")
    1142     (bind-case-lambda*
    1143       macro:
    1144       (bind-case-lambda* (pat (where . fenders) .. xpr ....) ....)
    1145       "combination of lambda and bind-case with multiple pattern arguments")
    1146     (bind/cc
    1147       macro:
    1148       (bind/cc cc xpr ....)
    1149       "binds cc to the current contiunation"
    1150       "and execute xpr ... in this context")
    1151     )))
    1152 
    1153 ) ; more-bindings
    1154 
    1155 #|[
    1156 And now we put all three modules into one for convenience
    1157 ]|#
    1158 
    1159 (module bindings *
    1160   (import scheme
    1161           (only chicken case-lambda error)
    1162           basic-bindings macro-bindings more-bindings)
    1163   (reexport basic-bindings macro-bindings more-bindings)
    1164 
    1165 ;;; (bindings sym ..)
    1166 ;;; -----------------
    1167 ;;; documentation procedure.
    1168 (define bindings
    1169   (let ((lst (append (basic-bindings)
    1170                      (macro-bindings)
    1171                      (more-bindings))))
    1172     (case-lambda
    1173       (() lst)
    1174       ((sym)
    1175        (cond
    1176          ((memq sym (basic-bindings))
    1177           (basic-bindings sym))
    1178          ((memq sym (macro-bindings))
    1179           (macro-bindings sym))
    1180          ((memq sym (more-bindings))
    1181           (more-bindings sym))
    1182          (else
    1183            (error "Not in list" sym lst)))))))
    1184 ) ; bindings
    1185 
     1017  ) ; bindings
  • release/4/bindings/tags/4.1/bindings.setup

    r32912 r32959  
    22
    33(compile -O3 -s -d1 bindings.scm -J)
    4 (compile -O3 -d0 -s basic-bindings.import.scm)
    5 (compile -O3 -d0 -s macro-bindings.import.scm)
    6 (compile -O3 -d0 -s more-bindings.import.scm)
    74(compile -O3 -d0 -s bindings.import.scm)
    85
    96(install-extension
    107 'bindings
    11  '("bindings.so" "basic-bindings.import.so" "macro-bindings.import.so"
    12    "more-bindings.import.so" "bindings.import.so")
    13  '((version "4.0")))
     8 '("bindings.so" "bindings.import.so")
     9 '((version "4.1")))
  • release/4/bindings/tags/4.1/tests/run.scm

    r32912 r32959  
    66
    77(import simple-tests
     8        bindings
    89        (only arrays array array? array-length array-item array-drop
    910              array->list)
    10         (except bindings macro-rules once-only with-gensyms)
    1111        )
    12 (import-for-syntax (only bindings macro-rules once-only with-gensyms))
    13 
    1412
    1513(compound-test (bindings)
     
    1816    (check
    1917      (= (bind a 1 a) 1)
    20       (equal? (bind (a b) '(1 2) (where (odd? a)) (list a b)) '(1 2))
     18      (equal? (bind (a b) (where (odd? a)) '(1 2) (list a b)) '(1 2))
    2119      (equal?
    2220        (bind (x y z w) '(1 2 3 4) (list x y z w))
     
    4038        '(1 2 #\f #\o 4))
    4139      (equal? (bind (x (y (z . u) . v) . w)
     40                (where (odd? z))
    4241                '(1 (2 (3 4) 5) 6)
    43                 (where (odd? z))
    4442                (list x y z u v w))
    4543              '(1 2 3 (4) (5) (6)))
    4644      (condition-case
    4745        (bind (x (y (z . u) . v) . w)
     46          (where (even? z))
    4847          '(1 (2 (3 4) 5) 6)
    49           (where (even? z))
    5048          (list x y z u v w))
    5149        ((exn bind) #t))
     
    5553        '(1 2 #f #f 5 #(6)))
    5654      (equal?
     55        (bind (x (y (#f . u)) v . w)
     56          (vector 1 (list 2 (cons (odd? 4) #f)) 5 6)
     57          (list x y u v w))
     58        '(1 2 #f 5 #(6)))
     59      (equal?
    5760        (bind (x (y (z . u)) v . w) '#(1 (2 (3 . 4)) 5 6)
    5861          (list x y z u v w))
    5962        '(1 2 3 4 5 #(6)))
    6063      (equal?
    61         (bind* loop (x (a . b) y) '(5 #(1) 0)
     64        (bind* loop (x (a . b) y) (where (integer? x)) '(5 #(1) 0)
    6265          (if (zero? x)
    6366            (list x a b y)
     
    6568        '(0 1 (1 1 1 1 1 . #()) 5))
    6669      (equal?
    67         (bind* loop (x y) '#(5 0)
     70        (bind* loop (x y) (where (integer? x)) #(5 0)
    6871          (if (zero? x)
    6972            (vector x y)
     
    7780                        (lambda (seq k)
    7881                          (array-drop k seq)))
    79 
    8082      (equal?
    8183        (bind (x y z) (array 1 2 3) (list x y z))
    8284        '(1 2 3))
    83 
    8485      (equal?
    8586        (bind (x (y z)) (vector 0 (array 1 2)) (list x y z))
    8687        '(0 1 2))
    87 
    8888      (equal?
    8989        (bind (x (y . z)) (vector 0 (array 1 2 3 4))
     
    183183          ((a b C) (list a b C)))
    184184        '(1 2))
    185       (define (my-map fn vec)
    186         (bind-case vec
    187           (() '())
    188           ((x . xs) (cons (fn x)
    189                           (my-map fn xs)))))
    190       (equal? (my-map add1 '#(1 2 3)) '(2 3 4))
     185
     186      "LOCAL VARIABLES IN ALL RULES"
     187      (define (my-map fn lst)
     188        (let loop ((lst lst) (result '()))
     189          (bind-case lst
     190            (() (reverse result))
     191            ((x . xs)
     192             (loop xs (cons (fn x) result))))))
     193      (equal? (my-map add1 '(0 1 2 3)) '(1 2 3 4))
     194      (define (vector-map fn vec)
     195        (let* ((len (vector-length vec))
     196               (result (make-vector len #f)))
     197          (let loop ((vec vec))
     198            (bind-case vec
     199              (() result)
     200              ((x . xs)
     201               (vector-set! result
     202                            (- len (vector-length xs) 1)
     203                            (fn x))
     204               (loop (subvector vec 1)))))))
     205      (equal? (vector-map add1 #(0 1 2 3)) #(1 2 3 4))
     206      (define (vector-reverse vec)
     207        (let ((result (make-vector (vector-length vec) #f)))
     208          (let loop ((vec vec))
     209            (bind-case vec
     210              (() result)
     211              ((x . xs)
     212               (vector-set! result
     213                            (vector-length xs)
     214                            x)
     215               (loop (subvector vec 1)))))))
     216      (equal? (vector-reverse #(0 1 2 3)) #(3 2 1 0))
    191217
    192218      "NON-SYMBOL LITERALS"
    193       (bind-case '#("a") ((#f) #f) (("a") #t))
    194       (equal? (bind-case '#(1 (#f 3))
     219      (bind-case #("a") ((#f) #f) (("a") #t))
     220      (equal? (bind-case (vector 1 (list (odd? 2) 3))
    195221                ((x y) (where (number? y)) (list x y))
    196222                ((x ("y" . z)) (list x z))
     
    202228                ((x (#f z)) (list x z)))
    203229              '(1 (#f 3)))
    204       (equal? (bind-case '#(1 (#f 3))
     230      (equal? (bind-case #(1 ("y" 3))
    205231                ((x ("y" . z)) (list x z))
    206232                ((x (#f z)) (list x z)))
    207               '(1 3))
     233              '(1 (3)))
    208234      ))
    209235  (case?)
     
    243269      (equal?
    244270        ((bind-case-lambda
    245            ((a (b . C) . d) (list a b C d))
     271           ((a (b . C) . d) (where (integer? a)) (list a b C d))
    246272           ((e . f) (list e f)))
    247273         '(1 #(2 3 4) 5 6))
    248274        '(1 2 #(3 4) (5 6)))
     275      (equal?
     276        ((bind-case-lambda
     277           ((a (b . C) . d) (where (string? a)) (list a b C d))
     278           ((e . f) (list e f)))
     279         '(1 #(2 3 4) 5 6))
     280        '(1 (#(2 3 4) 5 6)))
    249281      (equal?
    250282        ((bind-case-lambda*
     
    261293      ))
    262294  (lambdas?)
    263 ;
     295
    264296  (define-test (lets?)
    265297    (check
    266298      (equal?
    267         (bind-let (((x y (z . w)) '(1 2 #(3 4 5))))
     299        (bind-let (
     300          ((x y (z . w)) (where (number? x)) '(1 2 #(3 4 5)))
     301          )
    268302          (list x y z w))
    269303        '(1 2 3 #(4 5)))
     
    271305        (bind-let (
    272306          (((x y) z) '(#(1 2) 3))
    273           (u (+ 2 2))
     307          (u (where (integer? u)) (+ 2 2))
    274308          ((v w) '#(5 6))
    275309          )
     
    283317        '(0 5))
    284318      (equal?
    285         (bind-let loop (((a b) '(5 0)))
     319        (bind-let loop (
     320          ((a b) (where (integer? a))'(5 0))
     321          )
    286322          (if (zero? a)
    287323            (list a b)
     
    290326      (equal?
    291327        (bind-let loop (
    292           ((x . y) '(1 2 3))
    293           ((z) '#(10))
     328          ((x . y) (where (integer? x) (integer? x)) '(1 2 3))
     329          ((z) (where (integer? z)) #(10))
    294330          )
    295331          (if (zero? z)
     
    300336        (bind-let* (
    301337          (((x y) z) '(#(1 2) 3))
    302           (u (+ 1 2 x))
     338          (u (where (integer? u)) (+ 1 2 x))
    303339          ((v w) (list (+ z 2) 6))
    304340          )
     
    306342        '(1 2 3 4 5 6))
    307343      (equal?
    308         (bindrec ((o?) e?)
     344        (bindrec ((o?) e?) (where "o? and e? are predicates")
    309345          (vector (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    310346                  (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     
    314350        (bind-letrec (
    315351          ((o? (e?))
     352           ;(where "o? and e? are predicates")
     353           (where (procedure? o?) (procedure? e?))
    316354           (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
    317355                 (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
     
    338376      (equal?
    339377        (let ((x #f) (y #f) (z #f))
    340           (bind-set! (x (y . z)) '(1 #(2 3 3)))
     378          (bind-set! (x (y . z))
     379            (where (integer? x))
     380            '(1 #(2 3 3)))
    341381          (list x y z))
    342382        '(1 2 #(3 3)))
     
    353393        (begin
    354394          (bind-define (push top pop)
     395            (where (procedure? push)
     396                   (procedure? top)
     397                   (procedure? pop))
    355398            (let ((lst '()))
    356399              (vector
     
    363406          (top))
    364407        0)
     408      (equal?
     409        (begin
     410          (bind-define (x (_ y (z _))) '(1 #(2 3 (4 5))))
     411          (list x y z))
     412        '(1 3 4))
     413      (equal?
     414        (begin
     415          (bind-define (x (#f y (z #t)))
     416            (where (integer? x))
     417            (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
     418          (list x y z))
     419        '(1 3 4))
    365420      ))
    366421  (defines?)
    367422
    368   (define-test (macros?)
    369     (check
    370       (define-macro (nif xpr pos zer neg)
    371         (once-only (xpr)
    372       ;(define-macro (nif (once xpr) pos zer neg)
    373           `(cond
    374              ((positive? ,xpr) ,pos)
    375              ((negative? ,xpr) ,neg)
    376              (else ,zer))))
    377       (eq? (nif 2 'positive 'zero 'negative) 'positive)
    378       (define-macro (freeze xpr)
    379         `(lambda () ,xpr))
    380       (= ((freeze 5)) 5)
    381       (define-macro (swap! x y)
    382         `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
    383       (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
    384               '(y x))
    385       (= (letrec-syntax (
    386            (sec (macro-rules ()
    387                      ((_ lst) `(car (res ,lst)))))
    388            (res (macro-rules ()
    389                    ((_ lst) `(cdr ,lst))))
    390            )
    391            (sec '(1 2 3)))
    392          2)
    393       (= (macro-letrec (
    394            ((sec lst) `(car (res ,lst)))
    395            ((res lst) `(cdr ,lst))
    396            )
    397            (sec '(1 2 3))))
    398       (= (macro-let (
    399            ((fir lst) (where (list? lst)) `(car ,lst))
    400            ((res lst) (where (list? lst)) `(cdr ,lst))
    401            )
    402            (fir (res '(1 2 3))))
    403          2)
    404 
    405       "LITERALS"
    406       (define-syntax foo
    407         (macro-rules ()
    408           ((_ "foo" x) x)
    409           ((_ #f x) `(list 'false))
    410           ((_ #f x) 'false)
    411           ((_ a b) (where (string? a)) `(list ,a ,b))
    412           ((_ a b) (where (odd? a)) `(list ,a ,b))
    413           ((_ a b) a)))
    414       (= (foo "foo" 1) 1)
    415       (equal? (foo "bar" 2) '("bar" 2))
    416       (equal? (foo #f 'blabla) '(false))
    417       (equal? (foo 1 2) '(1 2))
    418       (= (foo 2 3) 2)
    419 
    420       "IN?"
    421       (define-macro (in? what equ? . choices)
    422         (let ((insym 'in))
    423           `(let ((,insym ,what))
    424              (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
    425                         choices)))))
    426       (in? 2 = 1 2 3)
    427       (not (in? 5 = 1 2 3))
    428 
    429       "VERBOSE IFS"
    430       (define-syntax vif
    431         (macro-rules (then else)
    432           ((_ test (then xpr . xprs))
    433            `(if ,test
    434               (begin ,xpr ,@xprs)))
    435           ((_ test (else xpr . xprs))
    436            `(if ,(not test)
    437               (begin ,xpr ,@xprs)))
    438           ((_ test (then xpr . xprs) (else ypr . yprs))
    439            `(if ,test
    440               (begin ,xpr ,@xprs)
    441               (begin ,ypr ,@yprs)))))
    442       (pe '
    443         (macro-rules (then else)
    444           ((_ test (then xpr . xprs))
    445            `(if ,test
    446               (begin ,xpr ,@xprs)))
    447           ((_ test (else xpr . xprs))
    448            `(if ,(not test)
    449               (begin ,xpr ,@xprs)))
    450           ((_ test (then xpr . xprs) (else ypr . yprs))
    451            `(if ,test
    452               (begin ,xpr ,@xprs)
    453               (begin ,ypr ,@yprs)))))
    454       (define (oux)
    455         (vif #t (then 'true)))
    456       (define (pux)
    457         (vif #f (else 'false)))
    458       (eq? (oux) 'true)
    459       (eq? (pux) 'false)
    460      
    461       "PROCEDURAL COND"
    462       (define-syntax my-cond
    463         (macro-rules (else =>)
    464           ((_ (else xpr . xprs))
    465            `(begin ,xpr ,@xprs))
    466           ((_ (test => xpr))
    467            `(let ((tmp ,test))
    468               (if tmp (,xpr tmp))))
    469           ((_ (test => xpr) . clauses)
    470            `(let ((tmp ,test))
    471               (if tmp
    472                 (,xpr tmp)
    473                 (my-cond ,@clauses))))
    474           ((_ (test))
    475            `(,void))
    476           ((_ (test) . clauses)
    477            `(let ((tmp ,test))
    478               (if tmp
    479                 tmp
    480                 (my-cond ,@clauses))))
    481           ((_ (test xpr . xprs))
    482            `(if ,test (begin ,xpr ,@xprs)))
    483           ((_ (test xpr . xprs) . clauses)
    484            `(if ,test
    485               (begin ,xpr ,@xprs)
    486               (my-cond ,@clauses)))
    487           ))
    488       (my-cond ((> 3 2)))
    489       (eq? (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
    490            'greater)
    491       (eq? (my-cond ((> 3 3) 'greater)
    492                ((< 3 3) 'less)
    493                (else 'equal))
    494            'equal)
    495       (= (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
    496                (else #f))
    497          2)
    498       (not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
    499                (else #f)))
    500 
    501       "LETREC"
    502       (define-macro (my-letrec pairs . body)
    503         (let ((vars (map car pairs))
    504               (vals (map cadr pairs))
    505               (aux (map (lambda (x) (gensym)) pairs)))
    506           `(let ,(map (lambda (var) `(,var #f)) vars)
    507              (let ,(map (lambda (a v) `(,a ,v)) aux vals)
    508                ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
    509                ,@body))))
    510       (equal?
    511         (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    512                     (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
    513                    (list (o? 95) (e? 95)))
    514         '(#t #f))
    515 
    516       "ANAPHORIC MACROS"
    517       (define-syntax alambda
    518         (macro-rules self ()
    519           ((_ args xpr . xprs)
    520            `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
    521               ,self))))
    522       (define ! (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
    523       (= (! 5) 120)
    524       (define-syntax aif
    525         (macro-rules it ()
    526           ((_ test consequent)
    527            `(let ((,it ,test))
    528               (if ,it ,consequent)))
    529           ((_ test consequent alternative)
    530            `(let ((,it ,test))
    531               (if ,it ,consequent ,alternative)))))
    532       (define (mist x) (aif (! x) it))
    533       (= (mist 5) 120)
    534       ))
    535   (macros?)
    536 
    537   (define-test (etc?)
    538     (check
    539       "ONCE-ONLY"
    540       (define-macro (square x)
    541         (once-only (x)
    542       ;(define-macro (square (once x))
    543           `(* ,x ,x)))
    544       (let ((n 4))
    545         (= (square (begin (set! n (+ n 1)) n)) 25))
    546       (define counter ; used for side-effects
    547         (let ((state 0))
    548           (lambda ()
    549             (set! state (+ state 1))
    550             state)))
    551       (= (square (counter)) 1)
    552       (= (square (counter)) 4)
    553       (= (square (counter)) 9)
    554 
    555       (define-macro (for (var start end) . body)
    556         (once-only (start end)
    557           `(do ((,var ,start (add1 ,var)))
    558                  ((= ,var ,end))
    559                  ,@body)))
    560       (define-macro (times a b)
    561         (with-gensyms (x y)
    562           `(let ((,x ,a) (,y ,b))
    563              (* ,x ,y))))
    564       (= (times 3 5) 15)))
    565   (etc?)
    566423  )
    567424
  • release/4/bindings/trunk/bindings.meta

    r32912 r32959  
    11;;;; bindings.meta -*- Scheme -*-
    22
    3 ((synopsis "Procedural-macros and destructuring bindings made easy")
     3((synopsis "Pattern matching with destructuring bindings")
    44 (category lang-exts)
    55 (license "BSD")
  • release/4/bindings/trunk/bindings.scm

    r32912 r32959  
    137137bind.
    138138
    139 bind-case is the macro, which is heavily used in macro-rules. It does
    140 all the destructuring there while implicit renaming cares for variable
    141 captures.
    142 
    143 bind and bind-case are implemented in the first module, on which the
    144 others rely.
    145 
    146 Note, that the implementation of define-macro and macro-rules in the
    147 macro-bindings module is surprisingly easy having implicit-renaming
    148 macros and binding routines at ones disposal.
    149 ]|#
    150 
    151 (module basic-bindings
    152   (bind bind-case
     139]|#
     140
     141(require-library procedural-macros)
     142
     143(module bindings
     144  (bind bind-case bind-lambda bind-lambda* bind-case-lambda
     145   bind-case-lambda* bind* bind-let bind-let* bind-letrec bindrec
     146   bindable? bind-define bind-set! bind/cc
    153147   bind-seq-length bind-seq-ref bind-seq-tail bind-table-show bind-table-add!
    154148   bind-exception bind-exception-handler signal-bind-exception
    155    list-of vector-of symbol-dispatcher basic-bindings)
     149   list-of vector-of symbol-dispatcher bindings)
    156150  (import scheme
    157151          (only chicken case-lambda condition-case define-values
    158                 error subvector
     152                error subvector define-for-syntax
    159153                current-exception-handler condition-predicate
    160154                get-condition-property make-property-condition
    161155                make-composite-condition signal abort print)
    162           (only data-structures conjoin list-of?))
     156          (only data-structures conjoin list-of?)
     157          (only procedural-macros define-macro)
     158          )
    163159  (import-for-syntax
     160    (only procedural-macros macro-rules)
    164161    (only data-structures compress))
    165162
     
    310307]|#
    311308
    312 ;;; (bind pat seq (where . fenders) .. xpr ....)
     309;;; (bind pat (where . fenders) .. seq xpr ....)
    313310;;; ---------------------------------------------
    314311;;; binds pattern variables of pat to corresponding subexpressions of
     
    316313;;; fenders pass
    317314(define-syntax bind
    318   (ir-macro-transformer
    319     (lambda (form inject compare?)
    320       (letrec (
    321         (len 'bind-seq-length)
    322         (ref 'bind-seq-ref)
    323         (tail 'bind-seq-tail)
    324         (filter2
    325           (lambda (ok? lst)
    326             (let loop ((lst lst) (yes '()) (no '()))
    327               (if (null? lst)
    328                 (list (reverse yes) (reverse no))
    329                 (let ((first (car lst)) (rest (cdr lst)))
    330                   (if (ok? first)
    331                     (loop rest (cons first yes) no)
    332                     (loop rest yes (cons first no))))))))
    333         (mappend
    334           (lambda (fn lists)
    335             (apply append (map fn lists))))
    336         (destruc
    337           (lambda (pat seq)
    338             (let loop ((pat pat) (seq seq) (n 0))
    339               (cond
    340                 ((pair? pat)
    341                  (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
    342                    (cond
    343                      ((symbol? p)
    344                       (if (compare? p '_)
    345                         ;; skip
    346                         recu
    347                         (cons `(,p (,ref ,seq ,n)) recu)))
    348                      ((pair? p)
    349                       (let ((g (gensym)))
    350                         (cons (cons `(,g (,ref ,seq ,n))
    351                                     (loop p g 0))
    352                               recu)))
    353                      (else
    354                        (cons `(,p (equal? ',p (,ref ,seq ,n)))
    355                              recu))
    356                      )))
    357                 ((symbol? pat)
    358                  `((,pat (,tail ,seq ,n))))
    359                 ((null? pat)
    360                  `((,pat (zero? (,len (,tail ,seq ,n))))))
    361                 ))))
    362         (dbind-ex
    363           (lambda (binds body)
    364             (if (null? binds)
    365               `(begin ,@body)
    366               (apply (lambda (defs checks)
    367                        `(let ,defs
    368                           (if (and ,@(map cadr checks))
    369                             ,(dbind-ex
    370                                (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
    371                                         binds)
    372                                body)
    373                             (signal-bind-exception
    374                               'bind
    375                               "match error"
    376                               ',(cons 'and (map cadr checks))))
    377                           ))
    378                      (filter2 (lambda (pair) (symbol? (car pair)))
    379                               (map (lambda (b) (if (pair? (car b)) (car b) b))
    380                                    binds)))
    381               )))
    382         )         
    383         (let ((pat (cadr form))
    384               (seq (caddr form))
    385               (xpr (cadddr form))
    386               (xprs (cddddr form))
    387               (gseq 'seq))
    388           (let ((fender? (and (pair? xpr)
    389                               (compare? 'where (car xpr))))
    390                 (destruc-pat-gseq (destruc pat gseq)))
    391             (if fender?
    392               `(let ((,gseq ,seq))
    393                  (if ,(dbind-ex destruc-pat-gseq
    394                                 (list (cons 'and (cdr xpr))))
    395                    ,(dbind-ex destruc-pat-gseq xprs)
    396                    (signal-bind-exception 'bind
    397                                           "match error"
    398                                           ,gseq
    399                                           ',pat
    400                                           ',xpr)))
    401               `(let ((,gseq ,seq))
    402                  ,(dbind-ex destruc-pat-gseq (cons xpr xprs))))
    403             ))))))
     315  (macro-rules _ (where)
     316    ((bind pat (where . fenders) seq xpr . xprs)
     317     (letrec (
     318       (len 'bind-seq-length)
     319       (ref 'bind-seq-ref)
     320       (tail 'bind-seq-tail)
     321       (filter
     322         (lambda (ok? lst)
     323           (let loop ((lst lst) (yes '()) (no '()))
     324             (if (null? lst)
     325               (values (reverse yes) (reverse no))
     326               (let ((first (car lst)) (rest (cdr lst)))
     327                 (if (ok? first)
     328                   (loop rest (cons first yes) no)
     329                   (loop rest yes (cons first no))))))))
     330       (mappend
     331         (lambda (fn lists)
     332           (apply append (map fn lists))))
     333       (destruc
     334         (lambda (pat seq)
     335           (let loop ((pat pat) (seq seq) (n 0))
     336             (cond
     337               ((pair? pat)
     338                (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
     339                  (cond
     340                    ((symbol? p)
     341                     (if (eq? p _)
     342                       ;; skip
     343                       recu
     344                       `((,p (,ref ,seq ,n)) ,@recu)))
     345                    ((pair? p)
     346                     (let ((g (gensym)))
     347                       `(((,g (,ref ,seq ,n)) ,@(loop p g 0))
     348                         ,@recu)))
     349                    (else
     350                      `((,p (equal? ',p (,ref ,seq ,n)))
     351                        ,@recu))
     352                    )))
     353               ((symbol? pat)
     354                `((,pat (,tail ,seq ,n))))
     355               ((null? pat)
     356                `((,pat (zero? (,len (,tail ,seq ,n))))))
     357               ))))
     358       (dbind-ex
     359         (lambda (binds body)
     360           (if (null? binds)
     361             `(begin ,@body)
     362             (call-with-values
     363               (lambda ()
     364                 (filter (lambda (pair) (symbol? (car pair)))
     365                          (map (lambda (b) (if (pair? (car b)) (car b) b))
     366                               binds)))
     367               (lambda (defs checks)
     368                 `(let ,defs
     369                    (if (and ,@(map cadr checks))
     370                      ,(dbind-ex
     371                         (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
     372                                  binds)
     373                         `((if ,(cons 'and fenders)
     374                             (begin ,@body)
     375                             (signal-bind-exception
     376                               'bind
     377                               "fenders not passed"
     378                               ,seq
     379                               ',pat
     380                               ',(cons 'where fenders)))))
     381                      (signal-bind-exception
     382                        'bind
     383                        "match error"
     384                        ,seq
     385                        ',pat
     386                        ',(cons 'and (map cadr checks))))))
     387             ))))
     388       )         
     389       (let ((gseq 'seq))
     390         `(let ((,gseq ,seq))
     391            ,(dbind-ex (destruc pat gseq)
     392                       (cons xpr xprs)))
     393           )))
     394    ((bind pat seq xpr . xprs)
     395     `(bind ,pat (where #t) ,seq ,xpr ,@xprs))))
    404396
    405397#|[
     
    425417;;; inner version, not exported
    426418(define-syntax bind-case-inner
    427   (ir-macro-transformer
    428     (lambda (form inject compare?)
    429       (let ((seq (cadr form)) (clauses (cddr form)))
    430         (if (null? clauses)
    431           `(signal-bind-exception 'bind-case-inner
    432                                   "no match for"
    433                                   ,seq
    434                                   )
    435 
    436           `(condition-case (bind ,(caar clauses) ,seq ,@(cdar clauses))
    437              ((exn type)
    438               (bind-case ,seq ,@(cdr clauses)))
    439              ((exn bind)
    440               (bind-case ,seq ,@(cdr clauses)))))))))
     419  (macro-rules (where)
     420    ((_ seq (pat (where . fenders) xpr . xprs))
     421     `(bind ,pat (where ,@fenders) ,seq ,xpr ,@xprs))
     422    ((_ seq (pat xpr . xprs))
     423     `(bind ,pat (where #t) ,seq ,xpr ,@xprs))
     424    ((_ seq clause . clauses)
     425     `(condition-case (bind-case-inner ,seq ,clause)
     426        ((exn type)
     427         (bind-case-inner ,seq ,@clauses))
     428        ((exn bind)
     429         (bind-case-inner ,seq ,@clauses))))))
    441430
    442431;;; (bind-case seq (pat (where fender ...) .. xpr ....) ....)
     
    446435;;; pattern to corresponding subexpressions of seq and executes
    447436;;; corresponding body xpr ....
    448 (define-syntax bind-case
    449   (ir-macro-transformer
    450     (lambda (form inject compare?)
    451       (let ((seq (cadr form)) (clauses (cddr form)))
    452         `(condition-case (bind-case-inner ,seq ,@clauses)
    453            ((exn bind)
    454             (signal-bind-exception 'bind-case
    455                                    "no match for"
    456                                    ,seq
    457                                    ',(cons 'in
    458                                            (map (lambda (clause)
    459                                                   (list (car clause)
    460                                                         (if (and (pair? (cadr clause))
    461                                                                  (compare? (caadr clause) 'where))
    462                                                           (cadr clause)
    463                                                           (list 'where #t))))
    464                                           clauses)))))))))
     437(define-macro (bind-case seq clause . clauses)
     438  `(condition-case
     439     (bind-case-inner ,seq ,clause ,@clauses)
     440     ((exn bind)
     441      (signal-bind-exception
     442        'bind-case
     443        "no match for"
     444        ,seq
     445        'in
     446        ',(map (lambda (cl)
     447                 (list (car cl) (cadr cl)))
     448               (cons clause clauses))))))
     449
     450#|[
     451The next macro, bindable?, can be used to check, if a
     452sequence-expression matches a pattern and passes all fenders.
     453]|#
     454
     455;;; (bindable? pat (where fender ...) ..)
     456;;; -------------------------------------
     457;;; returns a unary predicate which checks, if its argument matches pat
     458;;; and fulfills the predicates in the list fender ...
     459;;; Mostly used in fenders of macro-rules and define-macro, but must
     460;;; then be imported for-syntax.
     461(define-syntax bindable?
     462  (macro-rules (where)
     463    ((_ pat (where . fenders))
     464     `(lambda (seq)
     465        (condition-case (bind ,pat seq (and ,@fenders))
     466          ((exn bind) #f))))
     467    ((_ pat)
     468     `(bindable? ,pat (where #t)))))
     469
     470#|[
     471The following two macros, bind-define and bind-set!, destructure their
     472sequence arguments with respect to their pattern argument and define or
     473set! the pattern variables correspondingly.  For example, one can define
     474multiple procedures operating on a common state
     475
     476  (bind-define (push top pop)
     477    (let ((state '()))
     478      (list
     479        (lambda (arg) (set! state (cons arg state)))
     480        (lambda () (car state))
     481        (lambda () (set! state (cdr state))))))
     482
     483]|#
     484
     485;; helper macro for bind-define and bind-set!
     486(define-syntax bind-def-set!
     487  (macro-rules _ (where)
     488    ((bind-def-set! pat (where . fenders) seq def?)
     489     (let ((sym? (lambda (p)
     490                   (and (symbol? p)
     491                        (not (eq? p _))))))
     492        (let ((aux (let copy ((pat pat))
     493                     (cond
     494                       ((sym? pat) (gensym))
     495                       ((pair? pat)
     496                        (cons (copy (car pat)) (copy (cdr pat))))
     497                       (else pat))))
     498              (flatten*
     499                ; imported flatten doesn't work with pseudo-lists
     500                (lambda (tree)
     501                  (let loop ((tree tree) (result '()))
     502                    (cond
     503                      ((pair? tree)
     504                       (loop (car tree) (loop (cdr tree) result)))
     505                      ((null? tree) result)
     506                      (else
     507                        (cons tree result))))))
     508              (filter
     509                (lambda (ok? lst)
     510                  (compress (map ok? lst) lst))))
     511          (if def?
     512            `(if ((bindable? ,pat (where ,@fenders)) ,seq)
     513               (begin
     514                 ,@(map (lambda (p) `(define ,p ',p))
     515                        (filter sym? (flatten* pat)))
     516                 (bind ,aux ,seq
     517                   ,@(map (lambda (p a) `(set! ,p ,a))
     518                          (filter sym? (flatten* pat))
     519                          (filter sym? (flatten* aux)))))
     520               (signal-bind-exception 'bind-define
     521                                      "fenders not passed"
     522                                      ',seq
     523                                      ',pat
     524                                      '(where ,@fenders)))
     525            `(if ((bindable? ,pat (where ,@fenders)) ,seq)
     526               (bind ,aux ,seq
     527                 ,@(map (lambda (p a) `(set! ,p ,a))
     528                        (filter sym? (flatten* pat))
     529                        (filter sym? (flatten* aux))))
     530               (signal-bind-exception 'bind-set!
     531                                      "fenders not passed"
     532                                      ',seq
     533                                      ',pat
     534                                      '(where ,@fenders)))))))
     535    ))
     536
     537
     538;;; (bind-define pat (where fender ...) .. seq)
     539;;; -------------------------------------------
     540;;; destructures the sequence seq according to the pattern pat and sets
     541;;; pattern variables with values corresponding to subexpressions of
     542;;; seq, provided the fenders are satisfied
     543(define-syntax bind-define
     544  (macro-rules (where)
     545    ((_ pat (where . fenders) seq)
     546     `(bind-def-set! ,pat (where ,@fenders) ,seq #t))
     547    ((_ pat seq)
     548     `(bind-def-set! ,pat (where #t) ,seq #t))))
     549
     550;;; (bind-set! pat (where fender ...) .. seq)
     551;;; -----------------------------------------
     552;;; sets pattern variables of pat to corresponding sub-expressins of
     553;;; seq, provided the fenders are satisfied
     554(define-syntax bind-set!
     555  (macro-rules (where)
     556    ((_ pat (where . fenders) seq)
     557     `(bind-def-set! ,pat (where ,@fenders) ,seq #f))
     558    ((_ pat seq)
     559     `(bind-def-set! ,pat (where #t) ,seq #f))))
     560
     561#|[
     562Now we can define two macros, which simply combine lambda with
     563bind, the first destructures simply one argument, the second a
     564whole list. An example of a call and its result is
     565
     566  ((bind-lambda (a (b . c) . d) (list a b c d))
     567   '(1 #(20 30 40) 2 3))
     568  -> '(1 20 #(30 40) (2 3)))))
     569
     570  ((bind-lambda* ((a (b . c) . d) (e . f))
     571     (list a b c d e f))
     572   '(1 #(20 30 40) 2 3) '#(4 5 6))
     573  -> '(1 20 #(30 40) (2 3) 4 #(5 6)))
     574]|#
     575
     576;;; (bind-lambda pat (where fender ...) .. xpr ....)
     577;;; ------------------------------------------------
     578;;; combination of lambda and bind, one pattern argument
     579(define-syntax bind-lambda
     580  (macro-rules (where)
     581    ((_ pat (where . fenders) xpr . xprs)
     582     `(lambda (x) (bind ,pat (where ,@fenders) x ,xpr ,@xprs)))
     583    ((_ pat xpr . xprs)
     584     `(bind-lambda ,pat (where #t) ,xpr ,@xprs))))
     585
     586;;; (bind-lambda* pat (where fender ...) .. xpr ....)
     587;;; -------------------------------------------------
     588;;; combination of lambda and bind, multiple pattern arguments
     589(define-syntax bind-lambda*
     590  (macro-rules (where)
     591    ((_ pat (where . fenders) xpr . xprs)
     592     `(lambda x (bind ,pat (where ,@fenders) x ,xpr ,@xprs)))
     593    ((_ pat xpr . xprs)
     594     `(bind-lambda* ,pat (where #t) ,xpr ,@xprs))))
     595
     596#|[
     597The next two macros combine lambda and bind-case and do more or less the
     598same as match-lambda and match-lambda* in the matchable package. The
     599first destructures one argument, the second a list of arguments.
     600Here is an example together with its result:
     601
     602  ((bind-case-lambda
     603     ((a (b . c) . d) (list a b c d))
     604     ((e . f) (where (zero? e)) e)
     605     ((e . f) (list e f)))
     606   '(1 2 3 4 5))
     607  -> '(1 (2 3 4 5))
     608
     609  ((bind-case-lambda*
     610     (((a (b . c) . d) (e . f))
     611      (list a b c d e f)))
     612   '(1 #(20 30 40) 2 3) '(4 5 6))
     613  -> '(1 20 #(30 40) (2 3) 4 (5 6))
     614]|#
     615
     616;;; (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
     617;;; ------------------------------------------------------------
     618;;; combination of lambda and bind-case, one pattern argument
     619(define-syntax bind-case-lambda
     620  (macro-rules (where)
     621    ((_ (pat (where . fenders) xpr . xprs))
     622     `(lambda (x)
     623        (bind-case x (,pat (where ,@fenders) ,xpr ,@xprs))))
     624    ((_ (pat xpr . xprs))
     625     `(lambda (x)
     626        (bind-case x (,pat ,xpr ,@xprs))))
     627    ((_ clause . clauses)
     628     `(lambda (x)
     629        (bind-case x ,clause ,@clauses)))))
     630
     631;;; (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
     632;;; -------------------------------------------------------------
     633;;; combination of lambda and bind-case, multiple pattern arguments
     634(define-syntax bind-case-lambda*
     635  (macro-rules (where)
     636    ((_ (pat (where . fenders) xpr . xprs))
     637     `(lambda x
     638        (bind-case x (,pat (where ,@fenders) ,xpr ,@xprs))))
     639    ((_ (pat xpr . xprs))
     640     `(lambda x
     641        (bind-case x (,pat ,xpr ,@xprs))))
     642    ((_ clause . clauses)
     643     `(lambda x
     644        (bind-case x ,clause ,@clauses)))))
     645
     646#|[
     647The following macro, bind*, is a named version of bind. It takes an
     648additional argument besides those of bind, which is bound to a
     649recursive procedure, which can be called in bind's body. The pattern
     650variables are initialised with the corresponding subexpressions in seq.
     651For example
     652
     653  (bind* loop (x y) '(5 0)
     654    (if (zero? x)
     655      (list x y)
     656      (loop (list (sub1 x) (add1 y)))))
     657  -> '(0 5)
     658]|#
     659
     660;;; (bind* name pat seq (where fender ...) .. xpr ....)
     661;;; ---------------------------------------------------
     662;;; named version of bind
     663(define-syntax bind*
     664  (macro-rules (where)
     665    ((_ name pat (where . fenders) seq xpr . xprs)
     666     `((letrec ((,name
     667                  (bind-lambda ,pat (where ,@fenders) ,xpr ,@xprs)))
     668         ,name)
     669       ,seq))
     670    ((_ name pat seq xpr . xprs)
     671     `(bind* ,name ,pat (where #t) ,seq ,xpr ,@xprs))))
     672
     673#|[
     674Now the implementation of a nested version of let, named and unnamed,
     675is easy: Simply combine bind and bind*. For example
     676
     677  (bind-let (
     678     (((x y) z) '((1 2) 3))
     679     (u (+ 2 2))
     680     ((v w) '(5 6))
     681     )
     682     (list x y z u v w))
     683  -> '(1 2 3 4 5 6)
     684
     685  (bind-let loop (((a b) '(5 0)))
     686    (if (zero? a)
     687      (list a b)
     688      (loop (list (sub1 a) (add1 b)))))
     689  -> '(0 5)
     690]|#
     691
     692;;; (bind-let loop .. ((pat (where fender ...) .. seq) ...) xpr ....)
     693;;; -----------------------------------------------------------------
     694;;; nested version of let, named and unnamed
     695(define-syntax bind-let
     696  (let ((last (lambda (lst)
     697                (let loop ((lst lst))
     698                  (if (null? (cdr lst))
     699                    (car lst)
     700                    (loop (cdr lst))))))
     701        (extract-fenders
     702          (lambda (pairs)
     703            (apply append
     704                   (map cdadr
     705                        (compress
     706                          (map (lambda (pair)
     707                                 (= (length pair) 3))
     708                               pairs)
     709                          pairs))))))
     710    (macro-rules (where)
     711      ((_ loop () xpr . xprs)
     712       `(let ,loop () ,xpr ,@xprs))
     713      ((_ loop ((pat0 (where . fenders) seq0) . pat-seq-pairs) xpr . xprs)
     714       `(bind* ,loop
     715          ,(cons pat0 (map car pat-seq-pairs))
     716          (where ,@(append fenders
     717                           (extract-fenders pat-seq-pairs)))
     718          (list ,seq0 ,@(map last pat-seq-pairs))
     719          ,xpr ,@xprs))
     720      ((_ loop ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
     721       `(bind* ,loop
     722          ,(cons pat0 (map car pat-seq-pairs))
     723          (where ,@(extract-fenders pat-seq-pairs))
     724          (list ,seq0 ,@(map last pat-seq-pairs))
     725          ,xpr ,@xprs))
     726      ((_ () xpr . xprs)
     727       `(let () ,xpr ,@xprs))
     728      ((_ ((pat0 (where . fenders) seq0) . pat-seq-pairs) xpr . xprs)
     729       `(bind
     730          ,(cons pat0 (map car pat-seq-pairs))
     731          (where ,@(append fenders
     732                           (extract-fenders pat-seq-pairs)))
     733          (list ,seq0 ,@(map last pat-seq-pairs))
     734          ,xpr ,@xprs))
     735      ((_ ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
     736       `(bind
     737          ,(cons pat0 (map car pat-seq-pairs))
     738          (where ,@(extract-fenders pat-seq-pairs))
     739          (list ,seq0 ,@(map last pat-seq-pairs))
     740          ,xpr ,@xprs))
     741    )))
     742
     743#|[
     744The sequential version of bind-let should work as follows
     745
     746  (bind-let* (
     747     (((x y) z) '((1 2) 3))
     748     (u (+ 1 2 x))
     749     ((v w) (list (+ z 2) 6))
     750     )
     751     (list x y z u v w))
     752  -> '(1 2 3 4 5 6)
     753]|#
     754
     755;;; (bind-let* ((pat (where fender ...) .. seq) ...) xpr ....)
     756;;; ----------------------------------------------------------
     757;;; sequential version of bind-let
     758(define-syntax bind-let*
     759  (macro-rules (where)
     760    ((_ () xpr . xprs)
     761     `(let () ,xpr ,@xprs))
     762    ((_ ((pat (where . fenders) seq) . pat-seq-pairs) xpr . xprs)
     763     `(bind ,pat (where ,@fenders) ,seq
     764        (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))
     765    ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
     766     `(bind ,pat ,seq
     767        (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))))
     768
     769#|[
     770And here is the recursive version of bind, which is used in bind-letrec.
     771
     772  (bindrec ((o?) e?)
     773    (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     774          (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     775    (list (o? 95) (e? 95)))
     776  -> '(#t #f)
     777]|#
     778
     779;;; (bindrec pat (where fender ...) .. seq xpr ....)
     780;;; ------------------------------------------------
     781;;; recursive version of bind
     782(define-syntax bindrec
     783  (macro-rules (where)
     784    ((_ pat (where . fenders) seq xpr . xprs)
     785     `(if ((bindable? ,pat) ,seq)
     786        (bind ,pat ',pat
     787          ; bind pattern variables to auxiliary values
     788          ; so that they are in scope
     789          (bind-set! ,pat (where ,@fenders) ,seq)
     790          ; set! the real values
     791          ,xpr ,@xprs)
     792        (signal-bind-exception 'bindrec
     793                               "fenders not passed"
     794                               ',seq
     795                               ',pat
     796                               '(where ,@fenders))))
     797    ((_ pat seq xpr . xprs)
     798     `(bindrec ,pat (where #t) ,seq ,xpr ,@xprs))))
     799
     800#|[
     801The recursive version of bind-let works as follows
     802 
     803  (bind-letrec (
     804    ((o? (e?))
     805     (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
     806           (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
     807    )
     808    (list (o? 95) (e? 95)))
     809  -> '(#t #f)
     810]|#
     811
     812;;; (bind-letrec ((pat (where fender ...) .. seq) ...) xpr ....)
     813;;; ------------------------------------------------------------
     814;;; recursive version of bind-let
     815(define-syntax bind-letrec
     816  (let ((last (lambda (lst)
     817                (let loop ((lst lst))
     818                  (if (null? (cdr lst))
     819                    (car lst)
     820                    (loop (cdr lst))))))
     821        (extract-fenders
     822          (lambda (pairs)
     823            (apply append
     824                   (map cdadr
     825                        (compress
     826                          (map (lambda (pair)
     827                                 (= (length pair) 3))
     828                               pairs)
     829                          pairs))))))
     830    (macro-rules (where)
     831      ((_ ((pat (where . fenders) seq) . pat-seq-pairs) xpr . xprs)
     832       `(bindrec ,(cons pat (map car pat-seq-pairs))
     833          (where ,@(append fenders
     834                           (extract-fenders pat-seq-pairs)))
     835          (list ,seq ,@(map last pat-seq-pairs))
     836          ,xpr ,@xprs))
     837      ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
     838       `(bindrec ,(cons pat (map car pat-seq-pairs))
     839          (where ,@(extract-fenders pat-seq-pairs))
     840          (list ,seq ,@(map last pat-seq-pairs))
     841          ,xpr ,@xprs))
     842      ((_ () xpr . xprs)
     843       `(let () ,xpr ,@xprs))
     844    )))
     845
     846#|[
     847The following macro is sometimes named let/cc or let-cc
     848]|#
     849
     850;;; (bind/cc cc xpr ....)
     851;;; ---------------------
     852;;; captures the current continuation, binds it to cc and executes
     853;;; xpr .... in this context
     854(define-macro (bind/cc cc xpr . xprs)
     855  `(call-with-current-continuation
     856     (lambda (,cc) ,xpr ,@xprs)))
    465857
    466858#|[
     
    508900                (map car alist)))))))
    509901
    510 ;;; (basic-bindings sym ..)
    511 ;;; -----------------------
    512 ;;; documentation procedure of this module
    513 (define basic-bindings
     902;;; (bindings sym ..)
     903;;; ----------------------
     904;;; documentation procedure
     905(define bindings
    514906  (symbol-dispatcher '(
    515907    (bind
    516908      macro:
    517       (bind pat seq (where . fenders) .. xpr ....)
     909      (bind pat (where fender ...) .. seq xpr ....)
    518910      "a variant of Common Lisp's destructuring-bind")
    519911    (bind-case
    520912      macro:
    521       (bind-case seq (pat (where . fenders) .. xpr ....) ....)
     913      (bind-case seq (pat (where fender ...) .. xpr ....) ....)
    522914      "matches seq against pat with optional fenders in a case regime")
     915    (bindable?
     916      macro:
     917      (bindable? pat (where fender ...) ..)
     918      "returns a unary predicate, which checks"
     919      "if its argument matches pat and passes all fenders")
     920    (bind-set!
     921      macro:
     922      (bind-set! pat (where fender ...) .. seq)
     923      "sets multiple variables by destructuring its sequence argument")
     924    (bind-define
     925      macro:
     926      (bind-define pat (where fender ...) .. seq)
     927      "defines multiple variables by destructuring its sequence argument")
     928    (bind-lambda
     929      macro:
     930      (bind-lambda pat (where fender ...) .. xpr ....)
     931      "combination of lambda and bind, one pattern argument")
     932    (bind-lambda*
     933      macro:
     934      (bind-lambda* pat (where fender ...) .. xpr ....)
     935      "combination of lambda and bind, multiple pattern arguments")
     936    (bind*
     937      macro:
     938      (bind* loop pat (where fender ...) .. seq xpr ....)
     939      "named version of bind")
     940    (bind-let
     941      macro:
     942      (bind-let loop .. ((pat (where fender ...) .. seq) ...) xpr ....)
     943      "nested version of let, named and unnamed")
     944    (bind-let*
     945      macro:
     946      (bind-let* ((pat (where fender ...) .. seq) ...) xpr ....)
     947      "nested version of let*")
     948    (bindrec
     949      macro:
     950      (bindrec pat (where fender ...) .. seq xpr ....)
     951      "recursive version of bind")
     952    (bind-letrec
     953      macro:
     954      (bind-letrec ((pat (where fender ...) .. seq) ...) xpr ....)
     955      "recursive version of bind-let")
     956    (bind-case-lambda
     957      macro:
     958      (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
     959      "combination of lambda and bind-case with one pattern argument")
     960    (bind-case-lambda*
     961      macro:
     962      (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
     963      "combination of lambda and bind-case with multiple pattern arguments")
     964    (bind/cc
     965      macro:
     966      (bind/cc cc xpr ....)
     967      "binds cc to the current contiunation"
     968      "and execute xpr ... in this context")
    523969    (bind-exception
    524970      procedure:
     
    5691015      "cars or the cdr or the alist item with symbol as car")
    5701016    )))
    571 
    572 ) ; basic-bindings
    573 
    574 
    575 #|[
    576 Now we'll use bind-case to create procedural macros.  The first,
    577 macro-rules, is a procedural version of syntax-rules. It is as
    578 convenient as the latter, but much more powerfull. For example, it can
    579 use injected symbols and once pattern variables, do some of its work at
    580 compile-time, use local functions at compile-time and what have you.
    581 Contrary to syntax-rules the templates usually evaluate to quasiquoted
    582 expressions.
    583 Other procedural macro-building routines are provided as well, in
    584 particular, a hygienic define-macro, based on bind as well as local
    585 versions of it, macro-let and macro-letrec.
    586 ]|#
    587 
    588 (module macro-bindings
    589   (define-macro macro-rules macro-let macro-letrec once-only
    590     ;mac-rules
    591    with-gensyms macro-bindings)
    592   (import scheme basic-bindings)
    593   (import-for-syntax
    594     (only basic-bindings bind bind-case)
    595     (only data-structures compress))
    596 
    597 
    598 ;;; (macro-rules sym ... (key ...) (pat (where fender ...) .. tpl) ....)
    599 ;;; --------------------------------------------------------------------
    600 ;;; where sym ... are injected non-hygienig symbols, key ... are
    601 ;;; additional keywords, pat ....  are nested lambda-lists without
    602 ;;; spezial meaning of ellipses and tpl .... usually evaluate to
    603 ;;; quasiquoted templates. The optional fenders belong to the pattern
    604 ;;; matching process.
    605 (define-syntax macro-rules
    606   (ir-macro-transformer
    607     (lambda (f i c?)
    608       (let ((f* (let loop ((tail (cdr f)) (head '()))
    609                   (if (symbol? (car tail))
    610                     (loop (cdr tail) (cons (car tail) head))
    611                     (cons head tail)))))
    612         (let ((syms (car f*))
    613               (keys (cadr f*))
    614               (rules (cddr f*))
    615               (flatten*
    616                 ; imported flatten doesn't work with pseudo-lists
    617                 (lambda (tree)
    618                   (let loop ((tree tree) (result '()))
    619                     (cond
    620                       ((pair? tree)
    621                        (loop (car tree) (loop (cdr tree) result)))
    622                       ((null? tree) result)
    623                       (else
    624                         (cons tree result)))))))
    625           `(ir-macro-transformer
    626              (lambda (form inject compare?)
    627                (let ,(map (lambda (s)
    628                             `(,s (inject ',s)))
    629                           syms)
    630                  (bind-case form
    631                    ,@(map (lambda (rule)
    632                             (let* ((pat (car rule))
    633                                    (fpat (flatten* pat))
    634                                    (kpat (compress
    635                                            (map (lambda (x)
    636                                                   (memq x keys))
    637                                                 fpat)
    638                                            fpat))
    639                                    ;; compare? keywords with its names
    640                                    (key-checks
    641                                      (map (lambda (p s)
    642                                             `(compare? ,p ,s))
    643                                           kpat
    644                                           (map (lambda (x) `',x)
    645                                                kpat))))
    646                               (let ((tpl (cdr rule)))
    647                                 ;; add key-checks to where clause of tpl
    648                                 (if (and (pair? (car tpl))
    649                                          (c? (caar tpl) 'where))
    650                                   `(,pat (where ,@key-checks ,@(cdar tpl))
    651                                          ,@(cdr tpl))
    652                                   `(,pat (where ,@key-checks) ,@tpl)))))
    653                           rules))))))))))
    654 
    655 ;;; (define-macro (name . args) (where fender ...) .. xpr ....)
    656 ;;; -----------------------------------------------------------
    657 ;;; simple hygienic macro without injections and keywords, but with
    658 ;;; fenders and once arguments.
    659 (define-syntax define-macro
    660   (ir-macro-transformer
    661     (lambda (f i c?)
    662       (let ((code (cadr f))
    663             (xpr (caddr f))
    664             (xprs (cdddr f)))
    665         `(define-syntax ,(car code)
    666            (ir-macro-transformer
    667              (lambda (form inject compare?)
    668                (bind ,(cdr code) (cdr form) ,xpr ,@xprs))))))))
    669 
    670 #|[
    671 Now follow the local versions of define-macro, macro-let and
    672 macro-letrec. Since the syntax of both is identical, they are
    673 implemented by means of a helper macro.
    674 ]|#
    675 
    676 ;; helper for macro-let and macro-letrec
    677 (define-syntax macro
    678   (ir-macro-transformer
    679     (lambda (form inject compare?)
    680       (let ((op (cadr form))
    681             (pat-tpl-pairs (caddr form))
    682             (xpr (cadddr form))
    683             (xprs (cddddr form)))
    684         (let ((pats (map car pat-tpl-pairs))
    685               (tpls (map cdr pat-tpl-pairs)))
    686           `(,op ,(map (lambda (pat tpl)
    687                                `(,(car pat)
    688                                   (macro-rules ()
    689                                      ((_ ,@(cdr pat)) ,@tpl))))
    690                               pats tpls)
    691                        ,xpr ,@xprs))))))
    692 
    693 ;;; (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    694 ;;; -------------------------------------------------------------------------
    695 ;;; evaluates body ... in the context of parallel macros name ....
    696 (define-syntax macro-let
    697   (ir-macro-transformer
    698     (lambda (form inject compare?)
    699       (let ((pat-tpl-pairs (cadr form))
    700             (xpr (caddr form))
    701             (xprs (cdddr form)))
    702         `(macro let-syntax ,pat-tpl-pairs ,xpr ,@xprs)))))
    703 
    704 ;;; (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    705 ;;; ----------------------------------------------------------------------------
    706 ;;; evaluates body ... in the context of recursive macros name ....
    707 (define-syntax macro-letrec
    708   (ir-macro-transformer
    709     (lambda (form inject compare?)
    710       (let ((pat-tpl-pairs (cadr form))
    711             (xpr (caddr form))
    712             (xprs (cdddr form)))
    713         `(macro letrec-syntax ,pat-tpl-pairs ,xpr ,@xprs)))))
    714 
    715 ;;; (with-gensyms (name ....) xpr ....)
    716 ;;; -----------------------------------
    717 ;;; binds name ... to (gensym 'name) ... in body xpr ...
    718 (define-syntax with-gensyms
    719   (ir-macro-transformer
    720     (lambda (form inject compare?)
    721       `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
    722          ,@(cddr form)))))
    723 
    724 ;;; (once-only (x ....) xpr ....)
    725 ;;; -----------------------------
    726 ;;; macro-arguments x .... are only evaluated once and from left to
    727 ;;; right in the body xpr ....
    728 ;;; The code is more or less due to
    729 ;;; P. Seibel, Practical Common Lisp, p. 102
    730 (define-syntax once-only
    731   (ir-macro-transformer
    732     (lambda (form inject compare?)
    733       (let ((names (cadr form))
    734             (body (cddr form)))
    735         (let ((gensyms (map (lambda (x) (gensym)) names)))
    736           `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
    737              `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
    738                                  gensyms names))
    739                 ,(let ,(map (lambda (n g) `(,n ,g))
    740                             names gensyms)
    741                    ,@body))))))))
    742 
    743 ;;; (macro-bindings sym ..)
    744 ;;; -----------------------
    745 ;;; documentation procedure.
    746 (define macro-bindings
    747   (symbol-dispatcher '(
    748     (macro-rules
    749       macro:
    750       (macro-rules literal ... (keyword ...) (pat tpl) ....)
    751       "procedural version of syntax-rules"
    752       "with optional injected literals"
    753       "and quasiquoted templates")
    754     (define-macro
    755       macro:
    756       (define-macro (name . args) xpr ....)
    757       "a version of macro-rules with only one rule"
    758       "no injected symbols and no keywords")
    759     (macro-let
    760       macro:
    761       (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    762       "evaluates body ... in the context of parallel macros name ....")
    763     (macro-letrec
    764       macro:
    765       (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
    766       "evaluates body ... in the context of recursive macros name ....")
    767     (once-only
    768       macro:
    769       (once-only (x ....) xpr ....)
    770       "arguments x ... are evaluated only once and"
    771       "from left to right in the body xpr ....")
    772     (with-gensyms
    773       macro:
    774       (with-gensyms (x ....) xpr ....)
    775       "generates a series of gensyms x .... to be used in body xpr ...")
    776     )))
    777 ) ; macro-bindings
    778 
    779 #|[
    780 The binding macros to follow are all implemented either with
    781 define-macro or with macro-rules, hence the latter must be
    782 imported for-syntax. Had we chosen the direct implementation of
    783 define-macro with bind instead of macro-rules, we had to import
    784 for-syntax bind as well. This is the reason, why separate modules are
    785 needed. Note, that the fundamental macros, bind and bind-case, know how
    786 to handle where clauses. Hence the derived macros do as well.
    787 ]|#
    788 
    789 (module more-bindings *
    790   (import scheme
    791           basic-bindings
    792           (except macro-bindings macro-rules)
    793           )
    794   (import-for-syntax (only basic-bindings bind)
    795                      (only macro-bindings macro-rules))
    796 
    797 #|[
    798 The next macro, bindable?, can be used to check, if a
    799 sequence-expression matches a pattern and passes all fenders.
    800 ]|#
    801 
    802 ;;; (bindable? pat (where fender ...) ..)
    803 ;;; -------------------------------------
    804 ;;; returns a unary predicate which checks, if its argument matches pat
    805 ;;; and fulfills the predicates in the list fender ...
    806 ;;; Mostly used in fenders of macro-rules and define-macro, but must
    807 ;;; then be imported for-syntax.
    808 (define-syntax bindable?
    809   (macro-rules (where)
    810     ((_ pat (where . fenders))
    811      `(lambda (seq)
    812         (condition-case (bind ,pat seq (and ,@fenders))
    813           ((exn bind) #f))))
    814     ((_ pat)
    815      `(bindable? ,pat (where)))))
    816 
    817 #|[
    818 The following two macros, bind-define and bind-set!, destructure their
    819 sequence arguments with respect to their pattern argument and define or
    820 set! the pattern variables correspondingly.  For example, one can define
    821 multiple procedures operating on a common state
    822 
    823   (bind-define (push top pop)
    824     (let ((state '()))
    825       (list
    826         (lambda (arg) (set! state (cons arg state)))
    827         (lambda () (car state))
    828         (lambda () (set! state (cdr state))))))
    829 
    830 ]|#
    831 
    832 ;; helper macro for bind-define and bind-set!
    833 (define-macro (bind-def-set! pat seq def?)
    834   (let ((sym? (lambda (p)
    835                 (and (symbol? p)
    836                      (not (compare? p '_))))))
    837     (let ((aux (let copy ((pat pat))
    838                  (cond
    839                    ((sym? pat) (gensym))
    840                    ((pair? pat)
    841                     (cons (copy (car pat)) (copy (cdr pat))))
    842                    (else pat))))
    843           (flatten*
    844             ; imported flatten doesn't work with pseudo-lists
    845             (lambda (tree)
    846               (let loop ((tree tree) (result '()))
    847                 (cond
    848                   ((pair? tree)
    849                    (loop (car tree) (loop (cdr tree) result)))
    850                   ((null? tree) result)
    851                   (else
    852                     (cons tree result))))))
    853           (filter
    854             (lambda (ok? lst)
    855               (compress (map ok? lst) lst))))
    856       (if def?
    857         `(begin
    858            ,@(map (lambda (p) `(define ,p ',p))
    859                   (filter sym? (flatten* pat)))
    860            (bind ,aux ,seq
    861              ,@(map (lambda (p a) `(set! ,p ,a))
    862                     (filter sym? (flatten* pat))
    863                     (filter sym? (flatten* aux)))))
    864         `(begin
    865            (bind ,aux ,seq
    866              ,@(map (lambda (p a) `(set! ,p ,a))
    867                     (filter sym? (flatten* pat))
    868                     (filter sym? (flatten* aux))))))
    869       )))
    870 
    871 
    872 ;;; (bind-define pat seq)
    873 ;;; ---------------------
    874 ;;; destructures the sequence seq according to the pattern pat and sets
    875 ;;; pattern variables with values corresponding to subexpressions of seq
    876 (define-macro (bind-define pat seq)
    877   `(bind-def-set! ,pat ,seq #t))
    878 
    879 ;;; (bind-set! pat seq)
    880 ;;; -------------------
    881 ;;; sets pattern variables of pat to corresponding sub-expressins of seq
    882 (define-macro (bind-set! pat seq)
    883   `(bind-def-set! ,pat ,seq #f))
    884 
    885 #|[
    886 Now we can define two macros, which simply combine lambda with
    887 bind, the first destructures simply one argument, the second a
    888 whole list. An example of a call and its result is
    889 
    890   ((bind-lambda (a (b . c) . d) (list a b c d))
    891    '(1 #(20 30 40) 2 3))
    892   -> '(1 20 #(30 40) (2 3)))))
    893 
    894   ((bind-lambda* ((a (b . c) . d) (e . f))
    895      (list a b c d e f))
    896    '(1 #(20 30 40) 2 3) '#(4 5 6))
    897   -> '(1 20 #(30 40) (2 3) 4 #(5 6)))
    898 ]|#
    899 
    900 ;;; (bind-lambda pat (where fender ...) .. xpr ....)
    901 ;;; ------------------------------------------------
    902 ;;; combination of lambda and bind, one pattern argument
    903 (define-macro (bind-lambda pat xpr . xprs)
    904   `(lambda (x) (bind ,pat x ,xpr ,@xprs)))
    905 
    906 ;;; (bind-lambda* pat (where fender ...) .. xpr ....)
    907 ;;; -------------------------------------------------
    908 ;;; combination of lambda and bind, multiple pattern arguments
    909 (define-macro (bind-lambda* pat xpr . xprs)
    910   `(lambda x (bind ,pat x ,xpr ,@xprs)))
    911 
    912 #|[
    913 The following macro, bind*, is a named version of bind. It takes an
    914 additional argument besides those of bind, which is bound to a
    915 recursive procedure, which can be called in bind's body. The pattern
    916 variables are initialised with the corresponding subexpressions in seq.
    917 For example
    918 
    919   (bind* loop (x y) '(5 0)
    920     (if (zero? x)
    921       (list x y)
    922       (loop (list (sub1 x) (add1 y)))))
    923   -> '(0 5)
    924 ]|#
    925 
    926 ;;; (bind* name pat seq (where . fenders) .. xpr ....)
    927 ;;; ---------------------------------------------------
    928 ;;; named version of bind
    929 (define-macro (bind* name pat seq xpr . xprs)
    930   `((letrec ((,name
    931                (bind-lambda ,pat ,xpr ,@xprs)))
    932       ,name)
    933     ,seq))
    934 
    935 #|[
    936 Now the implementation of a nested version of let, named and unnamed,
    937 is easy: Simply combine bind and bind*. For example
    938 
    939   (bind-let (
    940      (((x y) z) '((1 2) 3))
    941      (u (+ 2 2))
    942      ((v w) '(5 6))
    943      )
    944      (list x y z u v w))
    945   -> '(1 2 3 4 5 6)
    946 
    947   (bind-let loop (((a b) '(5 0)))
    948     (if (zero? a)
    949       (list a b)
    950       (loop (list (sub1 a) (add1 b)))))
    951   -> '(0 5)
    952 ]|#
    953 
    954 ;;; (bind-let loop .. ((pat seq) ...) xpr ....)
    955 ;;; --------------------------------------------
    956 ;;; nested version of let, named and unnamed
    957 (define-syntax bind-let
    958   (macro-rules ()
    959     ((_ loop () xpr . xprs)
    960      `(let ,loop () ,xpr ,@xprs))
    961     ((_ loop ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
    962      `(bind* ,loop
    963         ,(cons pat0 (map car pat-seq-pairs))
    964         (list ,seq0 ,@(map cadr pat-seq-pairs))
    965         ,xpr ,@xprs))
    966     ((_ () xpr . xprs)
    967      `(begin ,xpr ,@xprs))
    968     ((_ ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
    969      `(bind
    970         ,(cons pat0 (map car pat-seq-pairs))
    971         (list ,seq0 ,@(map cadr pat-seq-pairs))
    972         ,xpr ,@xprs))
    973     ))
    974 
    975 #|[
    976 The sequential version of bind-let should work as follows
    977 
    978   (bind-let* (
    979      (((x y) z) '((1 2) 3))
    980      (u (+ 1 2 x))
    981      ((v w) (list (+ z 2) 6))
    982      )
    983      (list x y z u v w))
    984   -> '(1 2 3 4 5 6)
    985 ]|#
    986 
    987 ;;; (bind-let* ((pat seq) ...) xpr ....)
    988 ;;; -------------------------------------
    989 ;;; sequential version of bind-let
    990 (define-syntax bind-let*
    991   (macro-rules ()
    992     ((_ () xpr . xprs)
    993      `(let () ,xpr ,@xprs))
    994     ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
    995      `(bind ,pat ,seq (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))))
    996 
    997 #|[
    998 And here is the recursive version of bind.
    999 
    1000   (bindrec ((o?) e?)
    1001     (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    1002           (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    1003     (list (o? 95) (e? 95)))
    1004   -> '(#t #f)
    1005 ]|#
    1006 
    1007 ;;; (bindrec pat seq (where . fenders) .. xpr ....)
    1008 ;;; -----------------------------------------------
    1009 ;;; recursive version of bind
    1010 (define-macro (bindrec pat seq xpr . xprs)
    1011   `(bind ,pat ',pat
    1012      ; bind pattern variables to auxiliary values
    1013      ; so that they are in scope
    1014      (bind-set! ,pat ,seq)
    1015      ; set! the real values
    1016      ,xpr ,@xprs))
    1017 
    1018 #|[
    1019 The recursive version of bind-let works as follows
    1020  
    1021   (bind-letrec (
    1022     ((o? (e?))
    1023      (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
    1024            (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    1025     )
    1026     (list (o? 95) (e? 95)))
    1027   -> '(#t #f)
    1028 ]|#
    1029 
    1030 ;;; (bind-letrec ((pat seq) ...) xpr ....)
    1031 ;;; ---------------------------------------
    1032 ;;; recursive version of bind-let
    1033 (define-macro (bind-letrec pat-seq-pairs xpr . xprs)
    1034   `(bindrec ,(map car pat-seq-pairs)
    1035      (list ,@(map cadr pat-seq-pairs))
    1036      ,xpr ,@xprs))
    1037 
    1038 #|[
    1039 The next two macros combine lambda and bind-case and do more or less the
    1040 same as match-lambda and match-lambda* in the matchable package. The
    1041 first destructures one argument, the second a list of arguments.
    1042 Here is an example together with its result:
    1043 
    1044   ((bind-case-lambda
    1045      ((a (b . c) . d) (list a b c d))
    1046      ((e . f) (where (zero? e)) e)
    1047      ((e . f) (list e f)))
    1048    '(1 2 3 4 5))
    1049   -> '(1 (2 3 4 5))
    1050 
    1051   ((bind-case-lambda*
    1052      (((a (b . c) . d) (e . f))
    1053       (list a b c d e f)))
    1054    '(1 #(20 30 40) 2 3) '(4 5 6))
    1055   -> '(1 20 #(30 40) (2 3) 4 (5 6))
    1056 ]|#
    1057 
    1058 ;;; (bind-case-lambda (pat (where . fenders) .. xpr ....) ....)
    1059 ;;; ------------------------------------------------------------
    1060 ;;; combination of lambda and bind-case, one pattern argument
    1061 (define-syntax bind-case-lambda
    1062   (macro-rules ()
    1063     ((_ (pat xpr . xprs))
    1064      `(lambda (x) (bind ,pat x ,xpr ,@xprs)))
    1065     ((_ clause . clauses)
    1066      `(lambda (x)
    1067        (bind-case x ,clause ,@clauses)))))
    1068 
    1069 ;;; (bind-case-lambda* (pat (where . fenders) .. xpr ....) ....)
    1070 ;;; -------------------------------------------------------------
    1071 ;;; combination of lambda and bind-case, multiple pattern arguments
    1072 (define-syntax bind-case-lambda*
    1073   (macro-rules ()
    1074     ((_ (pat xpr . xprs))
    1075      `(lambda x (bind ,pat x ,xpr ,@xprs)))
    1076     ((_ clause . clauses)
    1077      `(lambda x
    1078        (bind-case x ,clause ,@clauses)))))
    1079 
    1080 #|[
    1081 The following macro is sometimes named let/cc or let-cc
    1082 ]|#
    1083 
    1084 ;;; (bind/cc cc xpr ....)
    1085 ;;; ---------------------
    1086 ;;; captures the current continuation, binds it to cc and executes
    1087 ;;; xpr .... in this context
    1088 (define-macro (bind/cc cc xpr . xprs)
    1089   `(call-with-current-continuation
    1090      (lambda (,cc) ,xpr ,@xprs)))
    1091 
    1092 ;;; (more-bindings sym ..)
    1093 ;;; ----------------------
    1094 ;;; documentation procedure
    1095 (define more-bindings
    1096   (symbol-dispatcher '(
    1097     (bindable?
    1098       macro:
    1099       (bindable? pat (where . fenders) ..)
    1100       "returns a unary predicate, which checks"
    1101       "if its argument matches pat and passes all fenders")
    1102     (bind-set!
    1103       macro:
    1104       (bind-set! pat seq)
    1105       "sets multiple variables by destructuring its sequence argument")
    1106     (bind-define
    1107       macro:
    1108       (bind-define pat seq)
    1109       "defines multiple variables by destructuring its sequence argument")
    1110     (bind-lambda
    1111       macro:
    1112       (bind-lambda pat (where . fenders) .. xpr ....)
    1113       "combination of lambda and bind, one pattern argument")
    1114     (bind-lambda*
    1115       macro:
    1116       (bind-lambda* pat (where . fenders) .. xpr ....)
    1117       "combination of lambda and bind, multiple pattern arguments")
    1118     (bind*
    1119       macro:
    1120       (bind* loop pat seq (where . fenders) .. xpr ....)
    1121       "named version of bind")
    1122     (bind-let
    1123       macro:
    1124       (bind-let loop .. ((pat seq) ...) xpr ....)
    1125       "nested version of let, named and unnamed")
    1126     (bind-let*
    1127       macro:
    1128       (bind-let* ((pat seq) ...) xpr ....)
    1129       "nested version of let*")
    1130     (bindrec
    1131       macro:
    1132       (bindrec pat seq (where . fenders) .. xpr ....)
    1133       "recursive version of bind")
    1134     (bind-letrec
    1135       macro:
    1136       (bind-letrec ((pat seq) ...) xpr ....)
    1137       "recursive version of bind-let")
    1138     (bind-case-lambda
    1139       macro:
    1140       (bind-case-lambda (pat (where . fenders) .. xpr ....) ....)
    1141       "combination of lambda and bind-case with one pattern argument")
    1142     (bind-case-lambda*
    1143       macro:
    1144       (bind-case-lambda* (pat (where . fenders) .. xpr ....) ....)
    1145       "combination of lambda and bind-case with multiple pattern arguments")
    1146     (bind/cc
    1147       macro:
    1148       (bind/cc cc xpr ....)
    1149       "binds cc to the current contiunation"
    1150       "and execute xpr ... in this context")
    1151     )))
    1152 
    1153 ) ; more-bindings
    1154 
    1155 #|[
    1156 And now we put all three modules into one for convenience
    1157 ]|#
    1158 
    1159 (module bindings *
    1160   (import scheme
    1161           (only chicken case-lambda error)
    1162           basic-bindings macro-bindings more-bindings)
    1163   (reexport basic-bindings macro-bindings more-bindings)
    1164 
    1165 ;;; (bindings sym ..)
    1166 ;;; -----------------
    1167 ;;; documentation procedure.
    1168 (define bindings
    1169   (let ((lst (append (basic-bindings)
    1170                      (macro-bindings)
    1171                      (more-bindings))))
    1172     (case-lambda
    1173       (() lst)
    1174       ((sym)
    1175        (cond
    1176          ((memq sym (basic-bindings))
    1177           (basic-bindings sym))
    1178          ((memq sym (macro-bindings))
    1179           (macro-bindings sym))
    1180          ((memq sym (more-bindings))
    1181           (more-bindings sym))
    1182          (else
    1183            (error "Not in list" sym lst)))))))
    1184 ) ; bindings
    1185 
     1017  ) ; bindings
  • release/4/bindings/trunk/bindings.setup

    r32912 r32959  
    22
    33(compile -O3 -s -d1 bindings.scm -J)
    4 (compile -O3 -d0 -s basic-bindings.import.scm)
    5 (compile -O3 -d0 -s macro-bindings.import.scm)
    6 (compile -O3 -d0 -s more-bindings.import.scm)
    74(compile -O3 -d0 -s bindings.import.scm)
    85
    96(install-extension
    107 'bindings
    11  '("bindings.so" "basic-bindings.import.so" "macro-bindings.import.so"
    12    "more-bindings.import.so" "bindings.import.so")
    13  '((version "4.0")))
     8 '("bindings.so" "bindings.import.so")
     9 '((version "4.1")))
  • release/4/bindings/trunk/tests/run.scm

    r32912 r32959  
    66
    77(import simple-tests
     8        bindings
    89        (only arrays array array? array-length array-item array-drop
    910              array->list)
    10         (except bindings macro-rules once-only with-gensyms)
    1111        )
    12 (import-for-syntax (only bindings macro-rules once-only with-gensyms))
    13 
    1412
    1513(compound-test (bindings)
     
    1816    (check
    1917      (= (bind a 1 a) 1)
    20       (equal? (bind (a b) '(1 2) (where (odd? a)) (list a b)) '(1 2))
     18      (equal? (bind (a b) (where (odd? a)) '(1 2) (list a b)) '(1 2))
    2119      (equal?
    2220        (bind (x y z w) '(1 2 3 4) (list x y z w))
     
    4038        '(1 2 #\f #\o 4))
    4139      (equal? (bind (x (y (z . u) . v) . w)
     40                (where (odd? z))
    4241                '(1 (2 (3 4) 5) 6)
    43                 (where (odd? z))
    4442                (list x y z u v w))
    4543              '(1 2 3 (4) (5) (6)))
    4644      (condition-case
    4745        (bind (x (y (z . u) . v) . w)
     46          (where (even? z))
    4847          '(1 (2 (3 4) 5) 6)
    49           (where (even? z))
    5048          (list x y z u v w))
    5149        ((exn bind) #t))
     
    5553        '(1 2 #f #f 5 #(6)))
    5654      (equal?
     55        (bind (x (y (#f . u)) v . w)
     56          (vector 1 (list 2 (cons (odd? 4) #f)) 5 6)
     57          (list x y u v w))
     58        '(1 2 #f 5 #(6)))
     59      (equal?
    5760        (bind (x (y (z . u)) v . w) '#(1 (2 (3 . 4)) 5 6)
    5861          (list x y z u v w))
    5962        '(1 2 3 4 5 #(6)))
    6063      (equal?
    61         (bind* loop (x (a . b) y) '(5 #(1) 0)
     64        (bind* loop (x (a . b) y) (where (integer? x)) '(5 #(1) 0)
    6265          (if (zero? x)
    6366            (list x a b y)
     
    6568        '(0 1 (1 1 1 1 1 . #()) 5))
    6669      (equal?
    67         (bind* loop (x y) '#(5 0)
     70        (bind* loop (x y) (where (integer? x)) #(5 0)
    6871          (if (zero? x)
    6972            (vector x y)
     
    7780                        (lambda (seq k)
    7881                          (array-drop k seq)))
    79 
    8082      (equal?
    8183        (bind (x y z) (array 1 2 3) (list x y z))
    8284        '(1 2 3))
    83 
    8485      (equal?
    8586        (bind (x (y z)) (vector 0 (array 1 2)) (list x y z))
    8687        '(0 1 2))
    87 
    8888      (equal?
    8989        (bind (x (y . z)) (vector 0 (array 1 2 3 4))
     
    183183          ((a b C) (list a b C)))
    184184        '(1 2))
    185       (define (my-map fn vec)
    186         (bind-case vec
    187           (() '())
    188           ((x . xs) (cons (fn x)
    189                           (my-map fn xs)))))
    190       (equal? (my-map add1 '#(1 2 3)) '(2 3 4))
     185
     186      "LOCAL VARIABLES IN ALL RULES"
     187      (define (my-map fn lst)
     188        (let loop ((lst lst) (result '()))
     189          (bind-case lst
     190            (() (reverse result))
     191            ((x . xs)
     192             (loop xs (cons (fn x) result))))))
     193      (equal? (my-map add1 '(0 1 2 3)) '(1 2 3 4))
     194      (define (vector-map fn vec)
     195        (let* ((len (vector-length vec))
     196               (result (make-vector len #f)))
     197          (let loop ((vec vec))
     198            (bind-case vec
     199              (() result)
     200              ((x . xs)
     201               (vector-set! result
     202                            (- len (vector-length xs) 1)
     203                            (fn x))
     204               (loop (subvector vec 1)))))))
     205      (equal? (vector-map add1 #(0 1 2 3)) #(1 2 3 4))
     206      (define (vector-reverse vec)
     207        (let ((result (make-vector (vector-length vec) #f)))
     208          (let loop ((vec vec))
     209            (bind-case vec
     210              (() result)
     211              ((x . xs)
     212               (vector-set! result
     213                            (vector-length xs)
     214                            x)
     215               (loop (subvector vec 1)))))))
     216      (equal? (vector-reverse #(0 1 2 3)) #(3 2 1 0))
    191217
    192218      "NON-SYMBOL LITERALS"
    193       (bind-case '#("a") ((#f) #f) (("a") #t))
    194       (equal? (bind-case '#(1 (#f 3))
     219      (bind-case #("a") ((#f) #f) (("a") #t))
     220      (equal? (bind-case (vector 1 (list (odd? 2) 3))
    195221                ((x y) (where (number? y)) (list x y))
    196222                ((x ("y" . z)) (list x z))
     
    202228                ((x (#f z)) (list x z)))
    203229              '(1 (#f 3)))
    204       (equal? (bind-case '#(1 (#f 3))
     230      (equal? (bind-case #(1 ("y" 3))
    205231                ((x ("y" . z)) (list x z))
    206232                ((x (#f z)) (list x z)))
    207               '(1 3))
     233              '(1 (3)))
    208234      ))
    209235  (case?)
     
    243269      (equal?
    244270        ((bind-case-lambda
    245            ((a (b . C) . d) (list a b C d))
     271           ((a (b . C) . d) (where (integer? a)) (list a b C d))
    246272           ((e . f) (list e f)))
    247273         '(1 #(2 3 4) 5 6))
    248274        '(1 2 #(3 4) (5 6)))
     275      (equal?
     276        ((bind-case-lambda
     277           ((a (b . C) . d) (where (string? a)) (list a b C d))
     278           ((e . f) (list e f)))
     279         '(1 #(2 3 4) 5 6))
     280        '(1 (#(2 3 4) 5 6)))
    249281      (equal?
    250282        ((bind-case-lambda*
     
    261293      ))
    262294  (lambdas?)
    263 ;
     295
    264296  (define-test (lets?)
    265297    (check
    266298      (equal?
    267         (bind-let (((x y (z . w)) '(1 2 #(3 4 5))))
     299        (bind-let (
     300          ((x y (z . w)) (where (number? x)) '(1 2 #(3 4 5)))
     301          )
    268302          (list x y z w))
    269303        '(1 2 3 #(4 5)))
     
    271305        (bind-let (
    272306          (((x y) z) '(#(1 2) 3))
    273           (u (+ 2 2))
     307          (u (where (integer? u)) (+ 2 2))
    274308          ((v w) '#(5 6))
    275309          )
     
    283317        '(0 5))
    284318      (equal?
    285         (bind-let loop (((a b) '(5 0)))
     319        (bind-let loop (
     320          ((a b) (where (integer? a))'(5 0))
     321          )
    286322          (if (zero? a)
    287323            (list a b)
     
    290326      (equal?
    291327        (bind-let loop (
    292           ((x . y) '(1 2 3))
    293           ((z) '#(10))
     328          ((x . y) (where (integer? x) (integer? x)) '(1 2 3))
     329          ((z) (where (integer? z)) #(10))
    294330          )
    295331          (if (zero? z)
     
    300336        (bind-let* (
    301337          (((x y) z) '(#(1 2) 3))
    302           (u (+ 1 2 x))
     338          (u (where (integer? u)) (+ 1 2 x))
    303339          ((v w) (list (+ z 2) 6))
    304340          )
     
    306342        '(1 2 3 4 5 6))
    307343      (equal?
    308         (bindrec ((o?) e?)
     344        (bindrec ((o?) e?) (where "o? and e? are predicates")
    309345          (vector (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    310346                  (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     
    314350        (bind-letrec (
    315351          ((o? (e?))
     352           ;(where "o? and e? are predicates")
     353           (where (procedure? o?) (procedure? e?))
    316354           (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
    317355                 (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
     
    338376      (equal?
    339377        (let ((x #f) (y #f) (z #f))
    340           (bind-set! (x (y . z)) '(1 #(2 3 3)))
     378          (bind-set! (x (y . z))
     379            (where (integer? x))
     380            '(1 #(2 3 3)))
    341381          (list x y z))
    342382        '(1 2 #(3 3)))
     
    353393        (begin
    354394          (bind-define (push top pop)
     395            (where (procedure? push)
     396                   (procedure? top)
     397                   (procedure? pop))
    355398            (let ((lst '()))
    356399              (vector
     
    363406          (top))
    364407        0)
     408      (equal?
     409        (begin
     410          (bind-define (x (_ y (z _))) '(1 #(2 3 (4 5))))
     411          (list x y z))
     412        '(1 3 4))
     413      (equal?
     414        (begin
     415          (bind-define (x (#f y (z #t)))
     416            (where (integer? x))
     417            (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
     418          (list x y z))
     419        '(1 3 4))
    365420      ))
    366421  (defines?)
    367422
    368   (define-test (macros?)
    369     (check
    370       (define-macro (nif xpr pos zer neg)
    371         (once-only (xpr)
    372       ;(define-macro (nif (once xpr) pos zer neg)
    373           `(cond
    374              ((positive? ,xpr) ,pos)
    375              ((negative? ,xpr) ,neg)
    376              (else ,zer))))
    377       (eq? (nif 2 'positive 'zero 'negative) 'positive)
    378       (define-macro (freeze xpr)
    379         `(lambda () ,xpr))
    380       (= ((freeze 5)) 5)
    381       (define-macro (swap! x y)
    382         `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
    383       (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
    384               '(y x))
    385       (= (letrec-syntax (
    386            (sec (macro-rules ()
    387                      ((_ lst) `(car (res ,lst)))))
    388            (res (macro-rules ()
    389                    ((_ lst) `(cdr ,lst))))
    390            )
    391            (sec '(1 2 3)))
    392          2)
    393       (= (macro-letrec (
    394            ((sec lst) `(car (res ,lst)))
    395            ((res lst) `(cdr ,lst))
    396            )
    397            (sec '(1 2 3))))
    398       (= (macro-let (
    399            ((fir lst) (where (list? lst)) `(car ,lst))
    400            ((res lst) (where (list? lst)) `(cdr ,lst))
    401            )
    402            (fir (res '(1 2 3))))
    403          2)
    404 
    405       "LITERALS"
    406       (define-syntax foo
    407         (macro-rules ()
    408           ((_ "foo" x) x)
    409           ((_ #f x) `(list 'false))
    410           ((_ #f x) 'false)
    411           ((_ a b) (where (string? a)) `(list ,a ,b))
    412           ((_ a b) (where (odd? a)) `(list ,a ,b))
    413           ((_ a b) a)))
    414       (= (foo "foo" 1) 1)
    415       (equal? (foo "bar" 2) '("bar" 2))
    416       (equal? (foo #f 'blabla) '(false))
    417       (equal? (foo 1 2) '(1 2))
    418       (= (foo 2 3) 2)
    419 
    420       "IN?"
    421       (define-macro (in? what equ? . choices)
    422         (let ((insym 'in))
    423           `(let ((,insym ,what))
    424              (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
    425                         choices)))))
    426       (in? 2 = 1 2 3)
    427       (not (in? 5 = 1 2 3))
    428 
    429       "VERBOSE IFS"
    430       (define-syntax vif
    431         (macro-rules (then else)
    432           ((_ test (then xpr . xprs))
    433            `(if ,test
    434               (begin ,xpr ,@xprs)))
    435           ((_ test (else xpr . xprs))
    436            `(if ,(not test)
    437               (begin ,xpr ,@xprs)))
    438           ((_ test (then xpr . xprs) (else ypr . yprs))
    439            `(if ,test
    440               (begin ,xpr ,@xprs)
    441               (begin ,ypr ,@yprs)))))
    442       (pe '
    443         (macro-rules (then else)
    444           ((_ test (then xpr . xprs))
    445            `(if ,test
    446               (begin ,xpr ,@xprs)))
    447           ((_ test (else xpr . xprs))
    448            `(if ,(not test)
    449               (begin ,xpr ,@xprs)))
    450           ((_ test (then xpr . xprs) (else ypr . yprs))
    451            `(if ,test
    452               (begin ,xpr ,@xprs)
    453               (begin ,ypr ,@yprs)))))
    454       (define (oux)
    455         (vif #t (then 'true)))
    456       (define (pux)
    457         (vif #f (else 'false)))
    458       (eq? (oux) 'true)
    459       (eq? (pux) 'false)
    460      
    461       "PROCEDURAL COND"
    462       (define-syntax my-cond
    463         (macro-rules (else =>)
    464           ((_ (else xpr . xprs))
    465            `(begin ,xpr ,@xprs))
    466           ((_ (test => xpr))
    467            `(let ((tmp ,test))
    468               (if tmp (,xpr tmp))))
    469           ((_ (test => xpr) . clauses)
    470            `(let ((tmp ,test))
    471               (if tmp
    472                 (,xpr tmp)
    473                 (my-cond ,@clauses))))
    474           ((_ (test))
    475            `(,void))
    476           ((_ (test) . clauses)
    477            `(let ((tmp ,test))
    478               (if tmp
    479                 tmp
    480                 (my-cond ,@clauses))))
    481           ((_ (test xpr . xprs))
    482            `(if ,test (begin ,xpr ,@xprs)))
    483           ((_ (test xpr . xprs) . clauses)
    484            `(if ,test
    485               (begin ,xpr ,@xprs)
    486               (my-cond ,@clauses)))
    487           ))
    488       (my-cond ((> 3 2)))
    489       (eq? (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
    490            'greater)
    491       (eq? (my-cond ((> 3 3) 'greater)
    492                ((< 3 3) 'less)
    493                (else 'equal))
    494            'equal)
    495       (= (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
    496                (else #f))
    497          2)
    498       (not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
    499                (else #f)))
    500 
    501       "LETREC"
    502       (define-macro (my-letrec pairs . body)
    503         (let ((vars (map car pairs))
    504               (vals (map cadr pairs))
    505               (aux (map (lambda (x) (gensym)) pairs)))
    506           `(let ,(map (lambda (var) `(,var #f)) vars)
    507              (let ,(map (lambda (a v) `(,a ,v)) aux vals)
    508                ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
    509                ,@body))))
    510       (equal?
    511         (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    512                     (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
    513                    (list (o? 95) (e? 95)))
    514         '(#t #f))
    515 
    516       "ANAPHORIC MACROS"
    517       (define-syntax alambda
    518         (macro-rules self ()
    519           ((_ args xpr . xprs)
    520            `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
    521               ,self))))
    522       (define ! (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
    523       (= (! 5) 120)
    524       (define-syntax aif
    525         (macro-rules it ()
    526           ((_ test consequent)
    527            `(let ((,it ,test))
    528               (if ,it ,consequent)))
    529           ((_ test consequent alternative)
    530            `(let ((,it ,test))
    531               (if ,it ,consequent ,alternative)))))
    532       (define (mist x) (aif (! x) it))
    533       (= (mist 5) 120)
    534       ))
    535   (macros?)
    536 
    537   (define-test (etc?)
    538     (check
    539       "ONCE-ONLY"
    540       (define-macro (square x)
    541         (once-only (x)
    542       ;(define-macro (square (once x))
    543           `(* ,x ,x)))
    544       (let ((n 4))
    545         (= (square (begin (set! n (+ n 1)) n)) 25))
    546       (define counter ; used for side-effects
    547         (let ((state 0))
    548           (lambda ()
    549             (set! state (+ state 1))
    550             state)))
    551       (= (square (counter)) 1)
    552       (= (square (counter)) 4)
    553       (= (square (counter)) 9)
    554 
    555       (define-macro (for (var start end) . body)
    556         (once-only (start end)
    557           `(do ((,var ,start (add1 ,var)))
    558                  ((= ,var ,end))
    559                  ,@body)))
    560       (define-macro (times a b)
    561         (with-gensyms (x y)
    562           `(let ((,x ,a) (,y ,b))
    563              (* ,x ,y))))
    564       (= (times 3 5) 15)))
    565   (etc?)
    566423  )
    567424
Note: See TracChangeset for help on using the changeset viewer.