Changeset 38015 in project


Ignore:
Timestamp:
12/13/19 18:26:36 (4 months ago)
Author:
juergen
Message:

bindings 2.0 with new implementation

Location:
release/5/bindings
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/5/bindings/tags/2.0/bindings.egg

    r37352 r38015  
    22 (category lang-exts)
    33 (license "BSD")
    4  (dependencies simple-exceptions)
    5  (test-dependencies simple-tests)
     4 (test-dependencies simple-tests checks)
    65 (author "Juergen Lorenz")
    7  (version "1.5")
     6 (version "2.0")
    87 (components (extension bindings)))
  • release/5/bindings/tags/2.0/bindings.scm

    r37352 r38015  
    1 ; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
     1; Author: Juergen Lorenz, ju (at) jugilo (dot) de
    22;
    3 ; Copyright (c) 2013-2018, Juergen Lorenz
     3; Copyright (c) 2013-2019, Juergen Lorenz
    44; All rights reserved.
    55;
     
    3131; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    3232
     33(module bindings (
     34  bind
     35  bind-set!
     36  bindrec
     37  bind-case
     38  bindable?
     39  bind-lambda
     40  bind-lambda*
     41  bind-case-lambda
     42  bind-case-lambda*
     43  bind*
     44  bind-let*
     45  bind-let
     46  bind-letrec
     47  bind-define
     48  bind/cc
     49  bind-seq->list
     50  bind-pvars
     51  bindings
     52  )
     53
     54(import scheme
     55        (only (chicken condition) condition-case)
     56        (only (chicken base) void receive identity print case-lambda error)
     57        (only (chicken keyword) keyword?)
     58        (only (chicken format) format)
     59        )
     60
     61(import-for-syntax (only (chicken keyword) keyword?))
     62
     63(define (split-along pat lst) ; internal
     64  (let loop ((pat pat) (tail lst) (head '()))
     65    (if (pair? pat)
     66      (if (pair? tail)
     67        (loop (cdr pat) (cdr tail) (cons (car tail) head))
     68        (error 'bind-set!
     69               (format #f "template ~s doesn't match pattern ~s~%"
     70                       tail pat)))
     71      (values (reverse head) tail))))
     72
     73;;; (bind-seq->list)
     74;;; (bind-seq->list seq)
     75;;; (bind-seq->list pat seq)
     76;;; (bind-seq->list seq? seq->list list->seq)
     77;;; -----------------------------------------
     78;;; the first version resets the internal database,
     79;;; the second the two transformers corresponding to seq,
     80;;; the third the transformed list, where the value of the possible
     81;;; dotted pattern variable is retransformed to the type of seq,
     82;;; and the last adds support for a new sequence type.
     83(define bind-seq->list
     84  (let ((db (list (cons (lambda (x) #t)
     85                        (cons identity
     86                              identity)))))
     87    (case-lambda
     88      (() (set! db ; reset
     89            (list (cons (lambda (x) #t)
     90                        (cons identity identity)))))
     91      ((seq)
     92       (let loop ((db db))
     93         (if ((caar db) seq)
     94           (cdar db)
     95           (loop (cdr db)))))
     96      ((pat seq)
     97       (let ((transformers
     98               (bind-seq->list seq)))
     99         (receive (head tail)
     100           (split-along pat ((car transformers) seq))
     101           (append head ((cdr transformers) tail)))))
     102      ((seq? seq->list list->seq)
     103       (set! db (cons (cons seq?
     104                            (cons seq->list list->seq)) db)))
     105      )))
     106
     107;;; (bind-pvars pat)
     108;;; ----------------
     109;;; returns the list of pattern variables of the pattern
     110;;; or error in case of duplicates
     111(define (bind-pvars pat)
     112  (let ((result '()))
     113    (let loop ((pat pat))
     114      (cond
     115        ((pair? pat)
     116         (loop (car pat))
     117         (loop (cdr pat)))
     118        ((and (symbol? pat)
     119              (not (eq? pat '_)))
     120         (if (memq pat result)
     121             (error 'bind-pvars
     122                    (format #f "duplicates: ~s already in ~s~%"
     123                            pat result))
     124             (set! result (cons pat result))))
     125        (else (void))))
     126    (reverse result)))
     127
     128;#|[
     129;bind-set! is the macro, which does all the dirty work. It destructures
     130;the pattern and the template in parallel, checks if literals match and
     131;if length' are equal, checks for duplicate pattern variables, and
     132;handles the wildcard, which matches everything but binds nothing.
     133;Because of the wildcard, _, the macro will be unhygienic, hence must
     134;be implemented procedurally. This has the additional advantage, that
     135;some the branching code can be evaluated at compile time.
     136
     137;]|#
     138
     139;;; (bind-set! pat seq)
     140;;; -------------------
     141;;; sets pattern variables of pat to the corresponding subexpression of
     142;;; seq, which might be arbitrary nested sequences, if bind-seq->list is
     143;;; prepared accordingly
     144(define-syntax bind-set!
     145  (er-macro-transformer
     146    (lambda (form rename compare?)
     147      (let ((pat (cadr form))
     148            (seq (caddr form))
     149            (%_ (rename '_))
     150            (%if (rename 'if))
     151            (%pair? (rename 'pair?))
     152            (%bind-set! (rename 'bind-set!))
     153            (%error (rename 'error))
     154            (%format (rename 'format))
     155            (%null? (rename 'null?))
     156            (%let (rename 'let))
     157            (%begin (rename 'begin))
     158            (%seq (rename 'seq))
     159            (%pat (rename 'pat))
     160            (%car (rename 'car))
     161            (%cdr (rename 'cdr))
     162            (%void (rename 'void))
     163            (%set! (rename 'set!))
     164            (%char=? (rename 'char=?))
     165            (%string=? (rename 'string=?))
     166            (%= (rename '=))
     167            (%eq? (rename 'eq?))
     168            (%bind-pvars (rename 'bind-pvars))
     169            (%bind-seq->list (rename 'bind-seq->list))
     170            )
     171        `(,%let ((,%pat ',pat) (,%seq ,seq))
     172           (,%bind-pvars ,%pat) ;check for duplicates
     173           ,(cond
     174              ((pair? pat)
     175               `(,%let ((,%seq (,%bind-seq->list ,%pat ,%seq)))
     176                        ; transform seq to pseudolist
     177                  (,%if (,%pair? ,%seq)
     178                    (,%begin
     179                      (,%bind-set! ,(car pat) (,%car ,%seq))
     180                      (,%bind-set! ,(cdr pat) (,%cdr ,%seq)))
     181                    (,%error 'bind-set!
     182                             (,%format
     183                               #f
     184                               "template ~s doesn't match pattern ~s\n"
     185                               ;,seq ',pat)))))
     186                               ,seq ,%pat)))))
     187              ((null? pat)
     188               `(,%if (,%null?
     189                        ((,%car (,%bind-seq->list ,%seq)) ,%seq))
     190                 (,%void)
     191                 (,%error 'bind-set!
     192                        (,%format #f
     193                                "template ~s doesn't match pattern ~s"
     194                                ,seq '()))))
     195              ;; symbols
     196              ((symbol? pat)
     197               (if (compare? pat %_) ; wildcard
     198                 `(,%void)
     199                 `(,%set! ,pat ,%seq)))
     200              ;; literals
     201              ((char? pat)
     202               `(,%if (,%char=? ',pat ,%seq)
     203                  (,%if #f #f) ;(,%void)
     204                  (,%error 'bind-set!
     205                        (,%format #f "strings ~s and ~s not char=?~%"
     206                                ',pat ,%seq))))
     207              ((string? pat)
     208               `(,%if (,%string=? ',pat ,%seq)
     209                  (,%if #f #f) ;(,%void)
     210                  (,%error 'bind-set!
     211                        (,%format #f "strings ~s and ~s not string=?~%"
     212                                ',pat ,%seq))))
     213              ((number? pat)
     214               `(if (,%= ',pat ,%seq)
     215                  (,%if #f #f) ;(,%void)
     216                  (,%error 'bind-set!
     217                        (,%format #f "numbers ~s and ~s not =~%"
     218                                ',pat ,%seq))))
     219              ((boolean? pat)
     220               `(,%if (,%eq? ',pat ,%seq)
     221                 (,%if #f #f) ;(,%void)
     222                 (,%error 'bind-set!
     223                        (,%format #f "booleans ~s and ~s not eq?~%"
     224                                ',pat ,%seq))))
     225              ((keyword? pat)
     226               `(,%if (,%eq? ',pat ,%seq)
     227                  (,%if #f #f) ;(,%void)
     228                  (,%error 'bind-set!
     229                        (,%format #f "keywords ~s and ~s not eq?~%"
     230                                ',pat ,%seq))))
     231              ))))))
    33232
    34233#|[
    35 
    36 The fundamental macro defined in this library is bind. It's like
    37 destructuring-bind in Common Lisp and dbind in Graham's classic On Lisp,
    38 but with some extensions, in particular, wildcards, non-symbol literals
    39 and fenders.
    40 
    41 The syntax is as follows
    42 
    43   (bind pat seq [(where . fenders)] . body)
    44 
    45 It destructures the seq argument according to the pat argument, binds
    46 pattern variables to corresponding sequence items and executes body in
    47 this context. For example
    48 
    49   (bind (x (y z) . w) '(1 #(2 3) 4 5) (where (y even?)) (list x y z w))
    50 
    51 will return '(1 2 3 (4 5)).
    52 
    53 (Note that the position of the optional fenders, supplied in a where
    54 clause, has changed again in this version: It's now always on top of the body.
    55 This simplyfies implementation and usage of the library).
    56 
    57 This version of the library is a complete rewrite. The code no longer
    58 uses Graham's dbind implementation. Instead, a direct implementation of
    59 bind is given, which doesn't need gensyms. The internal destructure
    60 routine transforms the pattern and sequence arguments into three lists,
    61 pairs, literals and tails. Pairs is a list of pattern-variable and
    62 corresponding sequence-accesscode pairs to be used in a let at runtime,
    63 literals and tails check for equality of literals and their
    64 corresponding sequence values, and the emptyness of sequence tails
    65 corresponding to null patterns respectively. So, contrary to Graham's
    66 dbind, an exception is raised if the lengths of a pattern and its
    67 corresponding sequence don't match. Fenders are supplied in a where
    68 clause at the very beginning of the macro body: A list of
    69 pattern-variable predicates pairs is internally transformed into a list
    70 of predicate calls.
    71 
    72 Sequences are either lists, psuedolists, vectors or strings by default.
    73 The sequence operators needed are bind-seq-ref, bind-seq-tail and bind-seq-null? with
    74 the same syntax as the likely named list routines.  But there is a
    75 procedure, bind-seq-db, which allows to add a pair consisting of a type
    76 predicate and a vector containing the needed operators to a database.
    77 
    78 ]|#
    79 
    80 (module bindings
    81   (bind bind-case bind-lambda bind-lambda* bind-case-lambda
    82    bind-case-lambda* bind-named bind-let bind-let* bind-letrec bindrec
    83    bindable? bind-define bind-set! bind/cc bindings bind-seq-db
    84    bind-seq-ref bind-seq-tail bind-seq-null? bind-seq-exception
    85    bind-pseudo-list? eos)
    86 
    87   (import scheme
    88           (only (chicken base)
    89                 case-lambda receive error assert define-inline
    90                 subvector chop print gensym)
    91           (only (chicken condition) condition-case)
    92           (only (chicken fixnum) fx+ fx- fx= fx>=)
    93           (only simple-exceptions make-exception raise)
    94           )
    95   (import-for-syntax (only (chicken base) receive chop)
    96                      (only (chicken keyword) keyword?))
    97 
    98 ;;; needed in lazy-pairs
    99 (define eos (gensym 'eos))
    100 
    101 ;;; exceptions
    102 ;;; ----------
    103 (define bind-seq-exception
    104   (make-exception "sequence exception" 'sequence))
    105 
    106 ;;; helpers
    107 ;;; -------
    108 (define-inline (1+ n) (fx+ n 1))
    109 (define-inline (1- n) (fx- n 1))
    110 (define-inline (0= n) (fx= n 0))
    111 (define-inline (0<= n) (fx>= n 0))
    112 
    113 (define (bind-pseudo-list? xpr) #t)
    114 
    115 ;;; (bind-seq-ref seq k)
    116 ;;; --------------------
    117 ;;; access to a sequence item
    118 ;;; the second returned value is needed in bind-seq-null?
    119 (define (bind-seq-ref seq k)
    120   (assert (0<= k) 'bind-seq-ref)
    121   (values
    122     (let loop ((db (bind-seq-db)))
    123       ;; Since everything is a bind-pseudo-list, which is checked last
    124       ;; db is never empty
    125       (if ((caar db) seq)
    126         ((vector-ref (cdar db) 0) seq k)
    127         (loop (cdr db))))
    128     #f))
    129 
    130 ;;; (bind-seq-tail seq k)
     234bind-define is simply an alias to bind-set!
     235]|#
     236
     237;;; (bind-define pat seq)
    131238;;; ---------------------
    132 ;;; access to the tail of a sequence
    133 (define (bind-seq-tail seq k)
    134   (assert (0<= k) 'bind-seq-tail)
    135   (let loop ((db (bind-seq-db)))
    136     ;; Since everything is a bind-pseudo-list, which is checked last
    137     ;; db is never empty
    138     (if ((caar db) seq)
    139       ((vector-ref (cdar db) 1) seq k)
    140       (loop (cdr db)))))
    141 
    142 ;;; (bind-seq-null? seq)
    143 ;;; --------------------
    144 ;;; tests for emptiness of a sequence
    145 (define (bind-seq-null? seq)
    146   (receive (result out-of-bounds?)
    147     (condition-case (bind-seq-ref seq 0)
    148       ((exn) (values #t #t)))
    149     ;(if out-of-bounds? #t #f)))
    150     (cond
    151       ((eq? #t result) ; exn
    152        (if out-of-bounds? #t #f))
    153       ((and (symbol? result) (eq? result eos)) ; gensym, lazy-list
    154        #t)
    155       (else #f)
    156        )))
    157 
    158 
    159 ;;; (bind-seq-db type? ref: ref tail: tail)
    160 ;;; ---------------------------------------
    161 ;;; adds a new sequence type to the front of the database
    162 ;;; (bind-seq-db)
    163 ;;; -------------
    164 ;;; shows the sequence database
    165 (define bind-seq-db
    166   (let ((db (list (cons list? (vector list-ref list-tail))
    167                   (cons vector? (vector vector-ref subvector))
    168                   (cons string? (vector string-ref substring))
    169                   (cons bind-pseudo-list?
    170                         (vector (lambda (pl k) ; ref
    171                                   (let loop ((pl pl) (n 0))
    172                                     (cond
    173                                       ((and (pair? pl) (fx= n k))
    174                                        (car pl))
    175                                       ((pair? pl)
    176                                        (loop (cdr pl) (1+ n)))
    177                                       (else
    178                                         (raise (bind-seq-exception 'bind-seq-ref
    179                                                               "out of range"
    180                                                               pl k))))))
    181                                 (lambda (pl k) ; tail  ;;; wrong at end
    182                                   (let loop ((pl pl) (n 0))
    183                                     (cond
    184                                       ((fx= n k)
    185                                        pl)
    186                                       ((pair? pl)
    187                                        (loop (cdr pl) (1+ n)))
    188                                       (else
    189                                         (raise (bind-seq-exception 'bind-seq-tail
    190                                                               "out of range"
    191                                                               pl k))))))
    192                                 ))
    193                   )))
    194     (case-lambda
    195       (() db)
    196       ((type? . keyword-args)
    197        (let* ((args (chop keyword-args 2))
    198               (vec (make-vector (length args))))
    199          ;; populate vec and add to db
    200          (do ((args args (cdr args)))
    201            ((null? args)
    202             (set! db
    203                   (cons (cons type? vec) db)))
    204            (case (caar args)
    205              ((#:ref)
    206               (vector-set! vec
    207                            0
    208                            (lambda (seq k)
    209                              (condition-case
    210                                ((cadar args) seq k)
    211                                ((exn)
    212                                 (raise (bind-seq-exception 'bind-seq-ref
    213                                                       "out of range"
    214                                                       seq k)))))))
    215              ((#:tail)
    216               (vector-set! vec
    217                            1
    218                            (lambda (seq k)
    219                              (condition-case
    220                                ((cadar args) seq k)
    221                                ((exn)
    222                                 (raise (bind-seq-exception 'bind-seq-tail
    223                                                       "out of range"
    224                                                       seq k)))))))
    225              (else
    226                (raise (bind-seq-exception 'bind-seq-db
    227                                      "not a keyword"
    228                                      (caar args))))
    229              )))))))
    230 
    231 ;;; simple explicit-renaming  macros
    232 ;;; ---------------------------------
    233 (define-syntax define-er-macro-transformer
    234   (syntax-rules ()
    235     ((_ (name form rename compare?) xpr . xprs)
    236      (define-syntax name
    237        (er-macro-transformer
    238          (lambda (form rename compare?) xpr . xprs))))))
     239;;; destructures the sequence seq according to the pattern
     240;;; pat and sets pattern variables with values
     241;;; to corresponding subexpressions of seq
     242(define-syntax bind-define
     243  (syntax-rules ()
     244    ((_ pat seq)
     245     (bind-set! pat seq))))
    239246
    240247#|[
    241 First, a helper macro, which allows to implement bind as well
    242 as a recursive version of it, bindrec, in one go.
    243 It does all of the dirty work,
    244 ]|#
    245 
    246 ;;; (bind-with binder pat seq xpr . xprs)
    247 ;;; -------------------------------------
    248 ;;; where binder is let or letrec
    249 (define-er-macro-transformer (bind-with form rename compare?)
    250   (let ((binder (cadr form))
    251         (pat (caddr form))
    252         (seq (cadddr form))
    253         (xpr (car (cddddr form)))
    254         (xprs (cdr (cddddr form)))
    255         (%and (rename 'and))
    256         (%where (rename 'where))
    257         (%_ (rename '_))
    258         (%if (rename 'if))
    259         (%raise (rename 'raise))
    260         (%begin (rename 'begin))
    261         (%error (rename 'error))
    262         (%equal? (rename 'equal?))
    263         (%bind-seq-ref (rename 'bind-seq-ref))
    264         (%bind-seq-tail (rename 'bind-seq-tail))
    265         (%bind-seq-null? (rename 'bind-seq-null?))
    266         (%bind-seq-exception (rename 'bind-seq-exception)))
    267     (let* ((fenders? (and (pair? xpr)
    268                         (compare? (car xpr) %where)))
    269            (where-clause (if fenders?
    270                              xpr                 
    271                              '(where)))
    272            (fenders
    273              (apply append
    274                     (map (lambda (pair)
    275                            (map (lambda (p?)
    276                                   `(,p?  ,(car pair)))
    277                                 (cdr pair)))
    278                          (cdr where-clause))))
    279            (body (if fenders?
    280                    `(,%if (,%and ,@fenders)
    281                       (,%begin ,@xprs)
    282                       (,%raise (,%bind-seq-exception
    283                                  'bind
    284                                  "fenders not passed"
    285                                  ',fenders)))
    286                    `(,%begin ,xpr ,@xprs))))
    287       (letrec (
    288         (no-dups?
    289           (lambda (lst)
    290             (call-with-current-continuation
    291               (lambda (cc)
    292                 (let loop ((lst lst) (result '()))
    293                   (if (null? lst)
    294                     #t
    295                     (loop (cdr lst)
    296                           ;(if (memq (car lst) result)
    297                           ;; keywords can be used as literals
    298                           (if (and (not (keyword? (car lst)))
    299                                    (memq (car lst) result))
    300                             (cc #f)
    301                             (cons (car lst) result)))))))))
    302         (destructure
    303            (lambda (pat seq)
    304              (let ((len (let loop ((pat pat) (result 0))
    305                           (cond
    306                             ((null? pat) result)
    307                             ((pair? pat)
    308                              (loop (cdr pat) (+ 1 result)))
    309                             (else result)))))
    310                (let loop ((k 0) (pairs '()) (literals '()) (tails '()))
    311                  (if (= k len)
    312                    (let ((sentinel
    313                            ;last dotted item or '()
    314                            (let loop ((result pat) (k len))
    315                              (if (zero? k)
    316                                result
    317                                (loop (cdr result) (- k 1))))))
    318                      (cond
    319                        ((null? sentinel)
    320                         (values pairs literals
    321                                 (cons `(,%bind-seq-null?
    322                                          (,%bind-seq-tail ,seq ,k))
    323                                       tails)))
    324                        ((symbol? sentinel)
    325                         (if (compare? sentinel %_)
    326                           (values pairs literals tails)
    327                           (values (cons (list sentinel
    328                                               `(,%bind-seq-tail ,seq ,k))
    329                                         pairs)
    330                                   literals tails)))
    331                        (else
    332                          (values pairs
    333                                  (cons `(,%equal? ',sentinel
    334                                                   (,%bind-seq-tail ,seq ,k))
    335                                        literals)
    336                                  tails))))
    337                    (let ((item (list-ref pat k)))
    338                      (cond
    339                        ;((symbol? item)
    340                        ((and (symbol? item) (not (keyword? item)))
    341                         (if (compare? item %_)
    342                           (loop (+ k 1) pairs literals tails)
    343                           (loop (+ k 1)
    344                                 (cons (list item `(,%bind-seq-ref ,seq ,k)) pairs)
    345                                 literals
    346                                 tails)))
    347                        ;((atom? item) ; literal
    348                        ((and (not (pair? item)) (not (null? item)))
    349                         (loop (+ k 1)
    350                               pairs
    351                               (cons `(,%equal? ',item
    352                                                (,%bind-seq-ref ,seq ,k))
    353                                     literals)
    354                               tails))
    355                        ;((pair? item)
    356                        ((or (null? item) (pair? item))
    357                         (receive (ps ls ts)
    358                           (destructure item `(,%bind-seq-ref ,seq ,k))
    359                           (loop (+ k 1)
    360                                 (append ps pairs)
    361                                 (append ls literals)
    362                                 (append ts tails))))
    363                        )))))))
    364         )
    365         (receive (pairs literals tails)
    366           (destructure pat seq)
    367           (if (no-dups? (map car pairs))
    368             `(,%if (,%and ,@tails)
    369                (,%if (,%and ,@literals)
    370                  (,(rename binder) ,pairs ,body)
    371                  (,%raise (,%bind-seq-exception
    372                             'bind
    373                             "literals don't match"
    374                             ',literals)))
    375                (,%raise (,%bind-seq-exception
    376                           'bind
    377                           "length mismatch"
    378                           ',tails)))
    379             `(,%error 'bind-with
    380                       "duplicate pattern variables"
    381                       ',(map car pairs))
    382           ))))))
    383 
    384 #|[
    385 The following is Graham's dbind extended with fenders, wildcards,
    386 non-symbol literals and length-checks. For example
    387 
    388   (bind (x (y z)) '(1 #(2 3)) (where (x integer?)) (list x y z))
     248The following is Graham's dbind extended with wildcards,
     249non-symbol literals and length as well as duplicate checks.
     250
     251For example
     252
     253  (bind (x (y z)) '(1 (2 3)) (>> x integer?) (list x y z))
    389254
    390255will result in '(1 2 3) while
    391256
    392   (bind (_ ("y" z)) '(1 #("y" z)) z)
     257  (bind (_ ("y" z)) '(1 ("y" 3)) z)
    393258
    394259will produce 3.
    395 ]|#
    396 
    397 ;;; (bind pat seq (where . fenders) .. xpr ....)
    398 ;;; ---------------------------------------------
     260
     261After adding vector and string support
     262
     263  (bind-seq->list string? string->list list->string)
     264  (bind-seq->list vector? vector->list list->vector)
     265
     266it will destructure vectors and strings as well:
     267
     268  (bind (x (y z)) '(1 #(2 3)) (list x y z))
     269  (bind (x (y z)) '(1 "12") (list x y z))
     270
     271]|#
     272
     273;;; (bind pat seq xpr ....)
     274;;; -----------------------
    399275;;; binds pattern variables of pat to corresponding subexpressions of
    400 ;;; seq and executes body xpr .... in this context, provided all
    401 ;;; fenders pass
    402 (define-er-macro-transformer (bind form rename compare?)
    403   (let ((pat (cadr form))
    404         (seq (caddr form))
    405         (xpr (cadddr form))
    406         (xprs (cddddr form))
    407         (%let (rename 'let))
    408         (%where (rename 'where))
    409         (%bind-with (rename 'bind-with))
    410         (%seq (rename 'seq)))
    411     (let ((fenders? (and (pair? xpr) (compare? (car xpr) %where))))
    412       (let ((body (if fenders?
    413                      `(,xpr ,@xprs)
    414                      `((,%where) ,xpr ,@xprs))))
    415         `(,%let ((,%seq ,seq))
    416            ;,(cons %bind-with
    417            ;       (cons %let
    418            ;             (cons pat
    419            ;                   (cons %seq body)))))))))
    420            ,(apply list %bind-with %let pat %seq body))))))
    421 
    422 #|[
    423 And here is the recursive version of bind, which is used in bind-letrec.
    424 
    425   (bindrec ((o?) e?)
    426     (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    427           (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    428     (list (o? 95) (e? 95)))
    429   -> '(#t #f)
    430 ]|#
    431 
    432 ;;; (bindrec pat seq (where fender ...) .. xpr ....)
    433 ;;; ------------------------------------------------
    434 ;;; recursive version of bind
    435 (define-syntax bindrec
     276;;; lst and executes body xpr .... in this context.
     277;;; Fenders are implemented in client code by the >> macro of the
     278;;; checks egg.
     279(define-syntax bind
    436280  (syntax-rules ()
    437281    ((_ pat seq xpr . xprs)
    438      (bind-with letrec pat seq xpr . xprs))))
     282     (begin
     283       (bind-set! pat seq) xpr . xprs))))
    439284
    440285#|[
     
    443288
    444289  (bind-case '(1 (2 3))
    445     ((x y) (where (y list?)) (list x y))
     290    ((x y) (>> y list?) (list x y))
    446291    ((x (y . z)) (list x y z))
    447292    ((x (y z)) (list x y z))) ;-> '(1 2 (3))
     
    455300]|#
    456301
    457 ;;; (bind-case seq (pat (where fender ...) .. xpr ....) ....)
    458 ;;; ---------------------------------------------------------
    459 ;;; Checks if seq matches pattern pat [satisfying fender ...] ....
     302;;; (bind-case seq (pat xpr ....) ....)
     303;;; -----------------------------------
     304;;; Checks if seq matches patterns pat ....
    460305;;; in sequence, binds the pattern variables of the first matching
    461306;;; pattern to corresponding subexpressions of seq and executes
    462 ;;; corresponding body xpr ....
     307;;; body expressions xpr .... in this context
    463308(define-syntax bind-case
    464   (ir-macro-transformer
    465     (lambda (form inject compare?)
    466   (let ((seq (cadr form))
    467         (rules (cddr form))
    468         (insert-where-clause
    469           (lambda (rule)
    470             (if (and (pair? (cadr rule))
    471                      (compare? (caadr rule) 'where))
    472               rule
    473               `(,(car rule) (,(inject 'where)) ,@(cdr rule))))))
    474     (let ((rules (map insert-where-clause rules))
    475           (rule->bind
    476             (lambda (rule)
    477               `(bind ,(car rule) ,seq ,(cadr rule) ,@(cddr rule)))))
    478       (let loop ((binds (map rule->bind rules)) (pats '()))
    479         (if (null? binds)
    480            `(raise (bind-seq-exception 'bind-case "no match"
    481                                   ,seq
    482                                   ',(reverse pats)))
    483            `(condition-case ,(car binds)
    484               ((exn)
    485                ,(loop (cdr binds)
    486                       (cons (list (cadar binds) (car (cdddar binds)))
    487                             pats)))))))))))
    488 ; the procedural version above improves the error message
    489 ;(define-syntax bind-case
    490 ;  (syntax-rules ()
    491 ;    ((_ seq)
    492 ;     (raise (bind-seq-exception 'bind-case "no match for" seq)))
    493 ;    ((_ seq (pat (where . fenders) xpr . xprs))
    494 ;     (condition-case (bind pat seq (where . fenders) xpr . xprs)
    495 ;       ((exn sequence) (bind-case seq))))
    496 ;    ((_ seq (pat xpr . xprs))
    497 ;     (bind-case seq (pat (where) xpr . xprs)))
    498 ;    ((_ seq clause . clauses)
    499 ;     (condition-case (bind-case seq clause)
    500 ;       ((exn sequence) (bind-case seq . clauses))))
    501 ;    ))
    502 
    503 #|[
    504 The next macro, bindable?, can be used to check, if a
    505 sequence-expression matches a pattern and passes all fenders.
    506 ]|#
    507 
    508 ;;; (bindable? pat (where fender ...) ..)
    509 ;;; -------------------------------------
    510 ;;; returns a unary predicate which checks, if its argument matches pat
    511 ;;; and fulfills the predicates in the list fender ...
    512 ;;; Mostly used in fenders of macro-rules and define-macro-transformer, but must
    513 ;;; then be imported for-syntax.
     309  (syntax-rules ()
     310    ((_ seq)
     311     (error 'bind-case "no match for" seq))
     312    ((_ seq (pat xpr . xprs))
     313     (condition-case (bind pat seq xpr . xprs)
     314       ((exn) (bind-case seq))))
     315    ((_ seq clause . clauses)
     316     (condition-case (bind-case seq clause)
     317       ((exn) (bind-case seq . clauses))))
     318    ))
     319
     320;;; (bindable? pat)
     321;;; ---------------
     322;;; returns a unary predicate which checks, if its arguments match pat
    514323(define-syntax bindable?
    515   (syntax-rules (where)
    516     ((_ pat (where . fenders))
     324  (syntax-rules ()
     325    ((_ pat)
    517326     (lambda (seq)
    518         (condition-case (bind pat seq (where . fenders) #t)
    519           ((exn sequence) #f))))
    520     ((_ pat)
    521      (bindable? pat (where)))))
    522 
    523 #|[
    524 The following two macros, bind-define and bind-set!, destructure their
    525 sequence arguments with respect to their pattern argument and define or
    526 set! the pattern variables correspondingly.  For example, one can define
    527 multiple procedures operating on a common state
    528 
    529   (bind-define (push top pop)
    530     (let ((state '()))
    531       (list
    532         (lambda (arg) (set! state (cons arg state)))
    533         (lambda () (car state))
    534         (lambda () (set! state (cdr state))))))
    535 
    536 ]|#
    537 
    538 ;;; (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
    539 ;;; -------------------------------------------------------
    540 ;;; sets pattern variables of pat pat1 ... to corresponding sub-expressins of
    541 ;;; seq seq1 ..., provided the fenders are satisfied
    542 (define-er-macro-transformer (bind-set! form rename compare?)
    543   (let ((pairs (reverse (chop (cdr form) 2)))
    544         (%_ (rename '_))
    545         (%let (rename 'let))
    546         (%list (rename 'list))
    547         (%where (rename 'where))
    548         (%bind (rename 'bind))
    549         (%set! (rename 'set!))
    550         (%seq (rename 'seq)))
    551     (let ((where-clause?
    552             (and (null? (cdar pairs))
    553                  (pair? (caar pairs))
    554                  (compare? (caaar pairs) %where))))
    555       (let ((where-clause (if where-clause?
    556                             (caar pairs)
    557                             `(,%where)))
    558             (pairs (if where-clause?
    559                      ;(reverse (cdr pairs))
    560                      (cdr pairs)
    561                      ;(reverse pairs))))
    562                      pairs)))
    563         (let ((pat (map car pairs))
    564               (seq `(,%list ,@(map cadr pairs)))
    565               (sym? (lambda (x)
    566                       (and (symbol? x)
    567                            (not (compare? x %_))))))
    568     (letrec (
    569       (pflatten (lambda (pls)
    570                   (cond
    571                     ((null? pls) pls)
    572                     ((pair? pls)
    573                      (append (pflatten (car pls))
    574                              (pflatten (cdr pls))))
    575                     (else (list pls)))))
    576       (filter (lambda (ok? lst)
    577                  (compress (map ok? lst) lst)))
    578       (reduce (lambda (pat)
    579                  (filter sym? (pflatten pat))))
    580       )
    581       (let ((aux (let copy ((pat pat))
    582                     (cond
    583                       ((sym? pat) (rename pat))
    584                       ((pair? pat)
    585                        (cons (copy (car pat)) (copy (cdr pat))))
    586                       (else pat))))
    587             (%where-clause
    588               (cons %where
    589                     (map (lambda (c)
    590                            (cons (rename (car c))
    591                                  (cdr c)))
    592                          (cdr where-clause)))))
    593         `(,%let ((,%seq ,seq))
    594            (,%bind ,aux ,%seq ,%where-clause
    595                    ,@(map (lambda (p a) `(,%set! ,p ,a))
    596                           (reduce pat)
    597                           (reduce aux))))
    598         )))))))
    599 
    600 ;;; (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
    601 ;;; ---------------------------------------------------------
    602 ;;; destructures the sequences seq seq1 ... according to the patterns
    603 ;;; pat pat1 ...  and sets pattern variables with values corresponding
    604 ;;; to subexpressions of seq seq1 ..., provided the fenders are
    605 ;;; satisfied
    606 (define-er-macro-transformer (bind-define form rename compare?)
    607   (let ((pairs (reverse (chop (cdr form) 2)))
    608         (%_ (rename '_))
    609         (%list (rename 'list))
    610         (%where (rename 'where))
    611         (%bind-set! (rename 'bind-set!))
    612         (%define (rename 'define))
    613         (%begin (rename 'begin)))
    614     (let ((where-clause?
    615             (and (null? (cdar pairs))
    616                  (pair? (caar pairs))
    617                  (compare? (caaar pairs) %where))))
    618       (let ((where-clause (if where-clause?
    619                             (caar pairs)
    620                             `(,%where)))
    621             (pairs (if where-clause?
    622                      ;(reverse (cdr pairs))
    623                      (cdr pairs)
    624                      ;(reverse pairs))))
    625                      pairs)))
    626         (let ((pat (map car pairs))
    627               (seq `(,%list ,@(map cadr pairs)))
    628               (sym? (lambda (x)
    629                       (and (symbol? x)
    630                            (not (compare? x %_))))))
    631     (letrec (
    632       (map-flatten (lambda (pls)
    633                      (cond
    634                        ((null? pls) pls)
    635                        ((pair? pls)
    636                         (append (map-flatten (car pls))
    637                                 (map-flatten (cdr pls))))
    638                        (else (list `(,%define ,pls #f))))))
    639       (filter (lambda (ok? lst)
    640                 (compress (map ok? lst) lst)))
    641       )
    642       `(,%begin
    643          ,@(filter sym?
    644                    (map-flatten pat))
    645          (,%bind-set! ,pat ,seq ,where-clause))))))))
     327        (condition-case (bind pat seq #t)
     328          ((exn) #f))))
     329    ))
    646330
    647331#|[
     
    660344]|#
    661345
    662 ;;; (bind-lambda pat (where fender ...) .. xpr ....)
    663 ;;; ------------------------------------------------
     346;;; (bind-lambda pat xpr ....)
     347;;; --------------------------
    664348;;; combination of lambda and bind, one pattern argument
    665349(define-syntax bind-lambda
    666   (syntax-rules (where)
    667     ((_ pat (where . fenders) xpr . xprs)
    668      (lambda (x) (bind pat x (where . fenders) xpr . xprs)))
     350  (syntax-rules ()
    669351    ((_ pat xpr . xprs)
    670      (bind-lambda pat (where) xpr . xprs))))
    671 
    672 ;;; (bind-lambda* pat (where fender ...) .. xpr ....)
    673 ;;; -------------------------------------------------
     352     (lambda (x) (bind pat x xpr . xprs)))
     353    ))
     354
     355;;; (bind-lambda* pat xpr ....)
     356;;; ---------------------------
    674357;;; combination of lambda and bind, multiple pattern arguments
    675358(define-syntax bind-lambda*
    676   (syntax-rules (where)
    677     ((_ pat (where . fenders) xpr . xprs)
    678      (lambda x (bind pat x (where . fenders) xpr . xprs)))
     359  (syntax-rules ()
    679360    ((_ pat xpr . xprs)
    680      (bind-lambda* pat (where) xpr . xprs))))
     361     (lambda x (bind pat x xpr . xprs)))
     362     ))
    681363
    682364#|[
     
    684366same as match-lambda and match-lambda* in the matchable package. The
    685367first destructures one argument, the second a list of arguments.
    686 Here is an example together with its result:
     368Here is an example together with its result (note the >> fender):
    687369
    688370  ((bind-case-lambda
    689371     ((a (b . c) . d) (list a b c d))
    690      ((e . f) (where (e zero?)) e)
     372     ((e . f) (>> e zero?) e)
    691373     ((e . f) (list e f)))
    692374   '(1 2 3 4 5))
     
    697379      (list a b c d e f)))
    698380   '(1 #(20 30 40) 2 3) '(4 5 6))
    699   -> '(1 20 #(30 40) (2 3) 4 (5 6))
    700 ]|#
    701 
    702 ;;; (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
    703 ;;; ------------------------------------------------------------
     381  -> '(1 20 (30 40) (2 3) 4 (5 6))
     382]|#
     383
     384;;; (bind-case-lambda (pat xpr ....) ....)
     385;;; --------------------------------------
    704386;;; combination of lambda and bind-case, one pattern argument
    705387(define-syntax bind-case-lambda
    706   (syntax-rules (where)
    707     ((_ (pat (where . fenders) xpr . xprs))
    708      (lambda (x)
    709        (bind-case x (pat (where . fenders) xpr . xprs))))
     388  (syntax-rules ()
    710389    ((_ (pat xpr . xprs))
    711390     (lambda (x)
     
    713392    ((_ clause . clauses)
    714393     (lambda (x)
    715        (bind-case x clause . clauses)))))
    716 
    717 ;;; (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
    718 ;;; -------------------------------------------------------------
     394       (bind-case x clause . clauses)))
     395    ))
     396
     397;;; (bind-case-lambda* (pat xpr ....) ....)
     398;;; ---------------------------------------
    719399;;; combination of lambda and bind-case, multiple pattern arguments
    720400(define-syntax bind-case-lambda*
    721   (syntax-rules (where)
    722     ((_ (pat (where . fenders) xpr . xprs))
    723      (lambda x
    724        (bind-case x (pat (where . fenders) xpr . xprs))))
     401  (syntax-rules ()
    725402    ((_ (pat xpr . xprs))
    726403     (lambda x
     
    728405    ((_ clause . clauses)
    729406     (lambda x
    730        (bind-case x clause . clauses)))))
     407       (bind-case x clause . clauses)))
     408    ))
    731409
    732410#|[
    733 The following macro, bind-named, is a named version of bind. It takes an
     411The following macro, bind*, is a named version of bind. It takes an
    734412additional argument besides those of bind, which is bound to a
    735413recursive procedure, which can be called in bind's body. The pattern
     
    737415For example
    738416
    739   (bind-named loop (x y) '(5 0)
     417  (bind* loop (x y) '(5 0)
    740418    (if (zero? x)
    741419      (list x y)
     
    744422]|#
    745423
    746 ;;; (bind-named name pat seq (where fender ...) .. xpr ....)
    747 ;;; ---- ---------------------------------------------------
     424;;; (bind* name pat seq xpr ....)
     425;;; ---- -----------------------------
    748426;;; named version of bind
    749 (define-syntax bind-named
    750   (syntax-rules (where)
    751     ((_ name pat seq (where . fenders) xpr . xprs)
    752      ((letrec ((name
    753                   (bind-lambda pat (where . fenders) xpr . xprs)))
    754          name)
    755        seq))
     427(define-syntax bind*
     428  (syntax-rules ()
    756429    ((_ name pat seq xpr . xprs)
    757      (bind-named name pat seq (where) xpr . xprs))))
     430     ((letrec ((name (bind-lambda pat xpr . xprs)))
     431        name)
     432      seq))))
    758433
    759434#|[
    760 Now the implementation of a nested version of let, named and unnamed,
    761 is easy: Simply combine bind and bind-named. For example
    762 
    763   (bind-let (
    764      (((x y) z) '((1 2) 3))
    765      (u (+ 2 2))
    766      ((v w) '(5 6))
    767      )
    768      (list x y z u v w))
    769   -> '(1 2 3 4 5 6)
    770 
    771   (bind-let loop (((a b) '(5 0)))
    772     (if (zero? a)
    773       (list a b)
    774       (loop (list (sub1 a) (add1 b)))))
    775       ;(loop (list (list (sub1 a) (add1 b))))))
    776       ;version with bind-named
    777   -> '(0 5)
    778 ]|#
    779 
    780 ;;; (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
    781 ;;; -----------------------------------------------------------------
    782 ;;; nested version of let, named and unnamed
    783 (define-er-macro-transformer (bind-let form rename compare?)
    784   (let ((named? (symbol? (cadr form))))
    785     (let ((name (if named? (cadr form) (gensym)))
    786           (binds (if named? (caddr form) (cadr form)))
    787           (xpr (if named? (cadddr form) (caddr form)))
    788           (xprs (if named? (cddddr form) (cdddr form))))
    789       (let ((pats (map car binds))
    790             (seqs (map cadr binds))
    791             (%list (rename 'list))
    792             (%bind (rename 'bind))
    793             ;(%bind-named (rename 'bind-named)))
    794             (%letrec (rename 'letrec))
    795             (%bind-lambda* (rename 'bind-lambda*)))
    796         (if named?
    797           `(,%letrec ((,name (,%bind-lambda* ,pats ,xpr ,@xprs)))
    798              (,name ,@seqs))
    799           ;`(,%bind-named ,name ,pats (,%list ,@seqs) ,xpr ,@xprs)
    800           `(,%bind ,pats (,%list ,@seqs) ,xpr ,@xprs))))))
    801 
    802 #|[
    803 The sequential version of bind-let should work as follows
    804 
    805   (bind-let* (
    806      (((x y) z) '((1 2) 3))
    807      (u (+ 1 2 x))
    808      ((v w) (list (+ z 2) 6))
    809      )
    810      (list x y z u v w))
    811   -> '(1 2 3 4 5 6)
    812 ]|#
    813 
    814 ;;; (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
    815 ;;; ----------------------------------------------------------
    816 ;;; sequential version of bind-let
     435The following three macros are analoga of the standard base macros let,
     436let* and letrec, the first named or unnamed. For example
     437
     438(bind-let loop (((a b) '(5 0)))
     439  (if (zero? a)
     440    (list a b)
     441    (loop (list (sub1 a) (add1 b)))))
     442-> '(0 5)
     443
     444A recursive version of bind follows
     445]|#
     446
     447;;; (bind-let* ((pat seq) ...) xpr . xprs)
     448;;; --------------------------------------
     449;;; sequentually binding patterns to sequences
    817450(define-syntax bind-let*
    818   (syntax-rules (where)
     451  (syntax-rules ()
    819452    ((_ () xpr . xprs)
    820      (begin xpr . xprs))
    821     ((_ ((pat seq)) (where . fenders) xpr . xprs)
    822      (bind pat seq (where . fenders) xpr . xprs))
     453     (let () xpr . xprs))
    823454    ((_ ((pat seq)) xpr . xprs)
    824455     (bind pat seq xpr . xprs))
    825     ((_ ((pat seq) binds ...) (where . fenders) xpr . xprs)
    826      (bind pat seq (bind-let* (binds ...)
    827                      (where . fenders) xpr . xprs)))
    828     ((_ ((pat seq) binds ...) xpr . xprs)
    829      (bind pat seq
    830        (bind-let* (binds ...) xpr . xprs)))))
     456    ((_ ((pat seq) (pat1 seq1) ...) xpr . xprs)
     457     (bind pat seq (bind-let* ((pat1 seq1) ...) xpr . xprs)))
     458     ))
     459
     460;;; (bind-let name .. ((pat seq) ...) xpr . xprs)
     461;;; ---------------------------------------------
     462;;; binding patterns to sequences in parallel, whith or without a
     463;;; recursive name procedure
     464(define-syntax bind-let
     465  (syntax-rules ()
     466    ((_ ((pat seq) ...) xpr . xprs)
     467     (bind (pat ...) (list seq ...) xpr . xprs))
     468    ((_ name ((pat seq) ...) xpr . xprs)
     469     ((letrec ((name (bind-lambda* (pat ...) xpr . xprs)))
     470        name)
     471      seq ...))
     472    ))
     473
     474;;; (bind-letrec ((pat seq) ...) xpr . xprs)
     475;;; ----------------------------------------
     476;;; binding patterns to sequences recursively
     477(define-syntax bind-letrec
     478  (syntax-rules ()
     479    ((_ ((pat seq) ...) xpr . xprs)
     480     (bind-let ((pat 'pat) ...)
     481       (bind-set! (pat ...) (list seq ...))
     482       xpr . xprs))))
     483   
     484;;; (bindrec pat seq xpr . xprs)
     485;;; ----------------------------
     486;;; recursive version of bind
     487(define-syntax bindrec
     488  (syntax-rules ()
     489    ((_ pat seq xpr . xprs)
     490     (bind pat 'pat
     491       (bind-set! pat seq)
     492       xpr . xprs))))
    831493
    832494#|[
    833 The recursive version of bind-let works as follows
    834  
    835   (bind-letrec (
    836     ((o? (e?))
    837      (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
    838            (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    839     )
    840     (list (o? 95) (e? 95)))
    841   -> '(#t #f)
    842 ]|#
    843 
    844 ;;; (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
    845 ;;; ------------------------------------------------------------
    846 ;;; recursive version of bind-let
    847 (define-er-macro-transformer (bind-letrec form rename compare?)
    848   (let ((binds (cadr form)) (xpr (caddr form)) (xprs (cdddr form)))
    849     (let ((pats (map car binds))
    850           (seqs (map cadr binds))
    851           (%list (rename 'list))
    852           (%bindrec (rename 'bindrec)))
    853       `(,%bindrec ,pats (,%list ,@seqs) ,xpr ,@xprs))))
    854 
    855 #|[
    856 The following macro is sometimes named let/cc or let-cc
     495I don't like the let/cc syntax, because it differs from let syntax,
     496here is bind/cc, which does the same.
    857497]|#
    858498
     
    867507       (lambda (cc) xpr . xprs)))))
    868508
    869 
    870 ;;; (symbol-dispatcher alist)
    871 ;;; -------------------------
    872 ;;; returns a procedure of zero or one argument, which shows all cars
    873 ;;; or the cdr of the alist item with car symbol
    874 (define (symbol-dispatcher alist)
     509(define (symbol-dispatcher alist) ; internal
    875510  (case-lambda
    876511    (()
     
    885520
    886521;;; (bindings sym ..)
    887 ;;; ----------------------
     522;;; -----------------
    888523;;; documentation procedure
    889524(define bindings
     
    893528      (bindings sym ..)
    894529      "documentation procedure")
    895     (bind-seq-exception
     530    (bind-seq->list
     531      generic procedure:
     532      (bind-seq->list)
     533      "resets the internal database for lists only"
     534      (bind-seq->list seq)
     535      "returns the pair of transformers corresponding to seq"
     536      (bind-seq->list pat seq)
     537      "returns a list where the value of the possible dotted"
     538      "argument is retransformed to the type of seq"
     539      (bind-seq->list seq? seq->list list->seq)
     540      "adds support for a new sequence type to the"
     541      "internal database")
     542    (bind-pvars
    896543      procedure:
    897       (bind-seq-exception loc . args)
    898       "generates an exception to be raised")
    899     (bind-seq-db
    900       procedure:
    901       (bind-seq-db)
    902       "shows the sequence database"
    903       (bind-seq-db type ref: ref tail: tail)
    904       "adds a new sequence type to the database where the keywords"
    905       "name arguments being accessed as bind-seq-ref and bind-seq-tail"
    906       "respectively")
    907     (bind-seq-ref
    908       procedure:
    909       (bind-seq-ref seq k)
    910       "sequence analog of list-ref")
    911     (bind-seq-tail
    912       procedure:
    913       (bind-seq-tail seq k)
    914       "sequence analog of list-tail")
    915     (bind-seq-null?
    916       procedure:
    917       (bind-seq-null? xpr)
    918       "sequence analog of null?")
    919     (bind-pseudo-list
    920       procedure:
    921       (bind-pseudo-list? xpr)
    922       "always #t")
     544      (bind-pvars pat)
     545      "checks if a pattern contains duplicate pattern variables,"
     546      "if so calls error, otherwise returns the list of pvars.")
    923547    (bind
    924548      macro:
    925       (bind pat seq (where fender ...) .. xpr ....)
     549      (bind pat seq xpr ....)
    926550      "a variant of Common Lisp's destructuring-bind")
    927551    (bind-case
    928552      macro:
    929       (bind-case seq (pat (where fender ...) .. xpr ....) ....)
     553      (bind-case seq (pat xpr ....) ....)
    930554      "matches seq against pat with optional fenders in a case regime")
    931555    (bindable?
    932556      macro:
    933       (bindable? pat (where fender ...) ..)
     557      (bindable? pat)
    934558      "returns a unary predicate, which checks"
    935559      "if its argument matches pat and passes all fenders")
    936560    (bind-set!
    937561      macro:
    938       (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
     562      (bind-set! pat seq)
    939563      "sets multiple variables by destructuring its sequence arguments")
    940564    (bind-define
    941565      macro:
    942       (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
     566      (bind-define pat seq)
    943567      "defines multiple variables by destructuring its sequence arguments")
    944568    (bind-lambda
    945569      macro:
    946       (bind-lambda pat (where fender ...) .. xpr ....)
     570      (bind-lambda pat xpr ....)
    947571      "combination of lambda and bind, one pattern argument")
    948572    (bind-lambda*
    949573      macro:
    950       (bind-lambda* pat (where fender ...) .. xpr ....)
     574      (bind-lambda* pat xpr ....)
    951575      "combination of lambda and bind, multiple pattern arguments")
    952     (bind-named
    953       macro:
    954       (bind-named loop pat (where fender ...) .. seq xpr ....)
     576    (bind*
     577      macro:
     578      (bind* loop pat seq xpr ....)
    955579      "named version of bind")
    956580    (bind-let
    957581      macro:
    958       (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
     582      (bind-let loop .. ((pat seq) ...) xpr ....)
    959583      "nested version of let, named and unnamed")
    960584    (bind-let*
    961585      macro:
    962       (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
     586      (bind-let* ((pat seq) ...) xpr ....)
    963587      "nested version of let*")
    964588    (bindrec
    965589      macro:
    966       (bindrec pat seq (where fender ...) .. xpr ....)
     590      (bindrec pat seq xpr ....)
    967591      "recursive version of bind")
    968592    (bind-letrec
    969593      macro:
    970       (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
     594      (bind-letrec ((pat seq) ...) xpr ....)
    971595      "recursive version of bind-let")
    972596    (bind-case-lambda
    973597      macro:
    974       (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
     598      (bind-case-lambda (pat xpr ....) ....)
    975599      "combination of lambda and bind-case with one pattern argument")
    976600    (bind-case-lambda*
    977601      macro:
    978       (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
     602      (bind-case-lambda* (pat xpr ....) ....)
    979603      "combination of lambda and bind-case with multiple pattern arguments")
    980604    (bind/cc
     
    984608      "and execute xpr ... in this context")
    985609    )))
    986   ) ; bindings
    987 
    988 ;(import bindings)
     610
     611) ; module
     612
  • release/5/bindings/tags/2.0/tests/run.scm

    r36467 r38015  
    1 ;;;; File: tests/run.scm
    2 ;;;; Author: Juergen Lorenz
    3 ;;;; ju (at) jugilo (dot) de
     1;;; File: tests/run.scm
     2;;; Author: Juergen Lorenz
     3;;; ju (at) jugilo (dot) de
    44
    55(import simple-tests
    66        bindings
    7         simple-exceptions
     7        checks
    88        (chicken base)
    9         ;(only arrays array array? array-ref array-tail array->list)
     9        (chicken condition)
    1010        )
    1111
    12   (define (my-map fn lst)
    13     (let loop ((lst lst) (result '()))
    14       (bind-case lst
    15         (() (reverse result))
    16         ((x . xs)
    17          (loop xs (cons (fn x) result))))))
    18 
    19   (define (vector-map fn vec)
    20     (let* ((len (vector-length vec))
    21            (result (make-vector len #f)))
    22       (let loop ((vec vec))
    23         (bind-case vec
    24           (() result)
    25           ((x . xs)
    26            (vector-set! result
    27                         (- len (vector-length xs) 1)
    28                         (fn x))
    29            (loop (subvector vec 1)))))))
    30 
    31   (define (vector-reverse vec)
    32     (let ((result (make-vector (vector-length vec) #f)))
    33       (let loop ((vec vec))
    34         (bind-case vec
    35           (() result)
    36           ((x . xs)
    37            (vector-set! result
    38                         (vector-length xs)
    39                         x)
    40            (loop (subvector vec 1)))))))
    41 
    42   (define stack #f) (define push! #f) (define pop! #f)
     12(define-test (helpers?)
     13  ;; reset internal database
     14  (bind-seq->list)
     15
     16  (equal? (bind-pvars '(a (b c)))
     17          '(a b c))
     18  (equal? (bind-pvars '(a _ (b _ c)))
     19          '(a b c))
     20  (equal? (bind-pvars '(#f a (b 3 c)))
     21          '(a b c))
     22  (not (condition-case (bind-pvars '(a (b b)))
     23         ((exn) #f)))
     24  (equal? (bind-seq->list "x") (cons identity identity))
     25  (bind-seq->list string? string->list list->string)
     26  (bind-seq->list vector? vector->list list->vector)
     27  (equal? (bind-seq->list "x") (cons string->list list->string))
     28  (equal? (bind-seq->list '(x) "x") '(#\x . ""))
     29  (equal? (bind-seq->list '(x . y) "xyz") '(#\x . "yz"))
     30  (equal? (bind-seq->list '(x) #(1)) '(1 . #()))
     31  (equal? (bind-seq->list '(x . y) #(1 2 3)) '(1 . #(2 3)))
     32  )
     33;(helpers?)
     34
     35(define-test (lists-only?)
     36  ;; reset internal database
     37  (bind-seq->list)
     38
     39  "this would work with string support:"
     40  (not (condition-case (bind (x) "x" x)
     41         ((exn) #f)))
     42  (string=? (bind x "x" x) "x")
     43  (equal? (bind (x (y (z))) '(1 (2 (3))) (list x y z))
     44          '(1 2 3))
     45  (equal? (bind (x (y . z)) '(1 (2 . 3)) (list x y z))
     46          '(1 2 3))
     47  (let ((x #f) (y #f))
     48    (bind-set! (x (y)) '(1 (2)))
     49    (and (= x 1) (= y 2)))
     50  )
     51;(lists-only?)
     52
     53(define stack #f) (define push! #f) (define pop! #f)
     54
     55(define-test (defines?)
     56  ;; reset internal database
     57  (bind-seq->list)
     58  ;; add vector and string support
     59  (bind-seq->list string? string->list list->string)
     60  (bind-seq->list vector? vector->list list->vector)
     61
     62  (equal?
     63    (let ((x #f) (y #f) (z #f))
     64      (bind-set! (x (y . z))
     65        '(1 #(2 3 3)))
     66      (list x y z))
     67    '(1 2 #(3 3)))
     68  (equal?
     69    (let ((x #f) (y #f) (z #f))
     70      (bind-set! (x #f _ (y _ . z))
     71        '(1 #f 10 #(2 30 3 3)))
     72      (list x y z))
     73    '(1 2 #(3 3)))
     74  (equal?
     75    (let ((x #f) (y #f) (z #f))
     76      (bind-set! x 1)
     77      (bind-set! y 2)
     78      (bind-set! z 3)
     79      (list x y z))
     80    '(1 2 3))
     81  (equal?
     82    (let ((x #f) (y #f) (z #f) (u #f) (v #f))
     83      (bind-set! (x (y . z)) '(1 #(2 3 3)))
     84      (bind-set! (u (v)) '(10 (20)))
     85      (>> x integer?) (>> u number?)
     86      (list x y z u v))
     87    '(1 2 #(3 3) 10 20))
     88  (equal?
     89    (let ((x #f) (y #f) (z #f))
     90      (bind-set! (x (y . z))
     91        '(1 #(2 3 3)))
     92      (>> x integer?)
     93      (list x y z))
     94    '(1 2 #(3 3)))
     95  (equal?
     96    (let ((state #f) (push! #f) (pop! #f))
     97      (bind-set! (state (push! pop!))
     98        (list '()
     99              (vector
     100                (lambda (xpr) (set! state (cons xpr state)))
     101                (lambda () (set! state (cdr state))))))
     102      (>> push! procedure?) (>> pop! procedure?)
     103      (push! 1)
     104      (push! 0)
     105      state)
     106    '(0 1))
     107  (equal?
     108    (begin
     109      (bind-define (plus5 times5)
     110        (let ((a 5))
     111          (list
     112            (lambda (x) (+ x a))
     113            (lambda (x) (* x a)))))
     114      (list (plus5 6) (times5 6)))
     115    '(11 30))
     116  (equal?
     117    (begin
     118      (bind-define (x . y) '(1 . 2))
     119      (>> x integer?)
     120      (list x y))
     121    '(1 2))
     122  (equal?
     123    (begin
     124      (bind-define (x _ . y) '(1 10 . 2))
     125      (>> x integer?)
     126      (list x y))
     127    '(1 2))
     128  (equal?
     129    (begin
     130      (bind-define (x #f . y) '(1 #f . 2))
     131      (list x y))
     132    '(1 2))
     133  (=
     134    (begin
     135      (bind-define (push top pop)
     136        (let ((lst '()))
     137          (vector
     138            (lambda (xpr) (set! lst (cons xpr lst)))
     139            (lambda () (car lst))
     140            (lambda () (set! lst (cdr lst))))))
     141      (>> push procedure?)
     142      (>> top procedure?)
     143      (>> pop procedure?)
     144      (push 0)
     145      (push 1)
     146      (pop)
     147      (top))
     148    0)
     149  (equal?
     150    (begin
     151      (bind-define (x (_ y (z _))) '(1 #(2 3 (4 5))))
     152      (list x y z))
     153    '(1 3 4))
     154  (equal?
     155    (begin
     156      (bind-define (x (#f y (z #t)))
     157        (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
     158      (>> x integer?)
     159      (list x y z))
     160    '(1 3 4))
     161  )
     162;(defines?)
    43163
    44164(define-test (binds?)
     165  ;; reset internal database
     166  (bind-seq->list)
     167  ;; add string and vector support
     168  (bind-seq->list string? string->list list->string)
     169  (bind-seq->list vector? vector->list list->vector)
     170
    45171  (= (bind a 1 a) 1)
    46         (= (bind (a ()) (list 1 "") a) 1)
    47   (equal? (bind (a b) '(1 2) (where (a odd?)) (list a b)) '(1 2))
    48   (equal?
    49     (bind (x . y) '#(1 2 3 4) (list x y))
     172  ;(= (bind (a ()) (list 1 "") a) 1)
     173  (equal? (bind (a b) '(1 2) (>> a odd?) (list a b)) '(1 2))
     174  (equal?
     175    (bind (x . y) #(1 2 3 4) (list x y))
    50176    '(1 #(2 3 4)))
    51177  (equal?
    52     (bind (_ . y) '#(1 2 3 4) y)
     178    (bind (_ . y) #(1 2 3 4) y)
    53179    '#(2 3 4))
    54180  (equal?
     
    80206    '(1 2 3 4 5 #(6)))
    81207  (equal?
    82     (bind-named loop (x (a . b) y) '(5 #(1) 0) (where (x integer?))
     208    (bind* loop (x (a . b) y) '(5 #(1) 0)
     209      (>> x integer?)
    83210      (if (zero? x)
    84211        (list x a b y)
     
    86213    '(0 1 (1 1 1 1 1 . #()) 5))
    87214  (equal?
    88     (bind-named loop (x y) #(5 0) (where (x integer?))
     215    (bind* loop (x y) #(5 0)
     216      (>> x integer?)
    89217      (if (zero? x)
    90218        (vector x y)
     
    98226    (condition-case
    99227      (bind (#f . ys) '(#t 2 3) ys)
    100       ((exn sequence) #f)))
     228      ((exn) #f)))
    101229  (bind #f #f #t)
    102230  (not
    103231    (condition-case
    104232      (bind #f #t #t)
    105       ((exn sequence) #f)))
     233      ((exn) #f)))
    106234  (not
    107235    (condition-case
    108236      (bind (x . #f) '(1 . #t) x)
    109       ((exn sequence) #f)))
     237      ((exn) #f)))
    110238  (equal?
    111239    (bind (x (y . #f)) '(1 (2 . #f)) (list x y))
     
    114242    (condition-case
    115243      (bind (x (y . #f)) '(1 (2 . #t)) (list x y))
    116       ((exn sequence) #f)))
     244      ((exn) #f)))
    117245  (equal?
    118246    (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y))
     
    121249    (condition-case
    122250      (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y))
    123       ((exn sequence) #f)))
     251      ((exn) #f)))
    124252  (not
    125253    (condition-case
    126254      (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y))
    127       ((exn sequence) #f)))
    128   (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))
    129 
    130 ;  "ADD ARRAYS TO GENERIC SEQUENCES"
    131 ;  (bind-seq-db array? ref: array-ref tail: array-tail)
    132 ;  (equal?
    133 ;    (bind (x y z) (array 1 2 3) (list x y z))
    134 ;    '(1 2 3))
    135 ;  (equal?
    136 ;    (bind (x (y z)) (vector 0 (array 1 2)) (list x y z))
    137 ;    '(0 1 2))
    138 ;  (equal?
    139 ;    (bind (x (y . z)) (vector 0 (array 1 2 3 4))
    140 ;      (list x y (array->list z)))
    141 ;    '(0 1 (2 3 4)))
    142 
    143   )
     255      ((exn) #f)))
     256  (equal?
     257    (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))
     258    '(1 2 3))
     259  )
     260;(binds?)
    144261
    145262(define-test (predicates?)
     263  ; reset internal database
     264  (bind-seq->list)
     265  ; add vector and string support
     266  (bind-seq->list string? string->list list->string)
     267  (bind-seq->list vector? vector->list list->vector)
    146268  (not ((bindable? (x)) '(name 1)))
    147   (not ((bindable? (x y) (where (x number?))) '(name 1)))
    148   ((bindable? (_ x)) '(name 1))
    149269  (not ((bindable? (_ x)) '(name 1 2)))
    150   ((bindable? (a b) (where (a odd?))) '#(1 2))
    151   (not ((bindable? (x (y z)) (where (y char-alphabetic?))) '(1 "23")))
     270  ((bindable? (a b)) '#(1 2))
     271  ((bindable? (x (y z))) '(1 "23"))
    152272  ((bindable? (x (y . z))) '(1 "23"))
    153273  ((bindable? (x y)) '(1 "23"))
    154   (not ((bindable? (a (b . C) . d)) '(1 2 3 4 5)))
     274  (not ((bindable? (a (b . c) . d)) '(1 2 3 4 5)))
    155275  (not ((bindable? (a)) 1))
    156276  )
     277;(predicates?)
     278
     279(define (my-map fn lst)
     280  (let loop ((lst lst) (result '()))
     281    (bind-case lst
     282      (() (reverse result))
     283      ((x . xs)
     284       (loop xs (cons (fn x) result))))))
     285
     286(define (vector-map fn vec)
     287  (let* ((len (vector-length vec))
     288         (result (make-vector len #f)))
     289    (let loop ((vec vec))
     290      (bind-case vec
     291        (() result)
     292        ((x . xs)
     293         (vector-set! result
     294                      (- len (vector-length xs) 1)
     295                      (fn x))
     296         (loop (subvector vec 1)))))))
     297
     298(define (vector-reverse vec)
     299  (let ((result (make-vector (vector-length vec) #f)))
     300    (let loop ((vec vec))
     301      (bind-case vec
     302        (() result)
     303        ((x . xs)
     304         (vector-set! result
     305                      (vector-length xs)
     306                      x)
     307         (loop (subvector vec 1)))))))
    157308
    158309(define-test (cases?)
     310  ;; reset internal database
     311  (bind-seq->list)
     312  ;; add vector and string support
     313  (bind-seq->list string? string->list list->string)
     314  (bind-seq->list vector? vector->list list->vector)
    159315  (not (bind-case #() (() #f)))
    160316  (equal? (bind-case #(2 2)
    161             ((a b) (where (a even?) (b odd?)) (print 'even-odd a b))
    162             ((a b) (where (a odd?) (b even?)) (print 'odd-even a b))
     317            ((a b) (>> a even?) (>> b odd?) (print 'even-odd a b))
     318            ((a b) (>> a odd?) (>> b even?) (print 'odd-even a b))
    163319            ((a b) (list a b))) '(2 2))
    164320  (equal? (bind-case '(1 "2 3")
     
    168324          '(1 #\2 " 3"))
    169325  (equal? (bind-case '(1 "23")
    170             ((x (y z)) (where (y char-alphabetic?)) (list x y z))
     326            ((x (y z)) (>> y char-alphabetic?) (list x y z))
    171327            ((x (y . z)) (list x y z))
    172328            ((x y) (list x y)))
    173329          '(1 #\2 "3"))
    174330  (equal? (bind-case '(1 "23")
    175             ((x (y z)) (where (y char-alphabetic?)) (list x y z))
     331            ((x (y z)) (>> y char-alphabetic?) (list x y z))
    176332            ((x (y . _)) (list x y))
    177333            ((x y) (list x y)))
    178334          '(1 #\2))
    179335  (equal? (bind-case '(1 "23")
    180             ((x (y z)) (where (y char-numeric?)) (list x y z))
     336            ((x (y z)) (>> y char-numeric?) (list x y z))
    181337            ((x (y . z)) (list x y z))
    182338            ((x y) (list x y)))
     
    193349          '(1 #\2 " 3"))
    194350  (equal? (bind-case '(1 #(2 3))
    195             ((x y) (where (y list?)) (list x y))
     351            ((x y) (>> y list?) (list x y))
    196352            ((x (y . z)) (list x y z))
    197353            ((x (y z)) (list x y z)))
     
    250406  (bind-case #("a") ((#f) #f) (("a") #t))
    251407  (equal? (bind-case (vector 1 (list (odd? 2) 3))
    252             ((x y) (where (y number?)) (list x y))
     408            ((x y) (>> y number?) (list x y))
    253409            ((x ("y" . z)) (list x z))
    254410            ((x (#f z)) (list x z)))
     
    264420          '(1 (3)))
    265421  )
     422;(cases?)
    266423
    267424(define-test (lambdas?)
     425  ;; reset internal database
     426  (bind-seq->list)
     427  ;; add vector and string support
     428  (bind-seq->list string? string->list list->string)
     429  (bind-seq->list vector? vector->list list->vector)
    268430  (equal?
    269431    ((bind-lambda (a (b . C) . d)
     
    278440  (equal?
    279441    ((bind-case-lambda
    280        ((e . f) (where (e zero?)) f)
     442       ((e . f) (>> e zero?) f)
    281443       ((e . f) (list e f)))
    282444     '#(0 2 3 4 5))
     
    284446  (equal?
    285447    ((bind-case-lambda
    286        ((e . f) (where (e zero?)) e)
     448       ((e . f) (>> e zero?) e)
    287449       ((a (b . #f) . d) (list a b d))
    288450       ((e . f) (list e f)))
     
    291453  (equal?
    292454    ((bind-case-lambda
    293        ((e . f) (where (e zero?)) e)
     455       ((e . f) (>> e zero?) e)
    294456       ((a (b . #f) . d) (list a b d))
    295457       ((e . f) (list e f))) ; match
     
    298460  (not (condition-case
    299461         ((bind-case-lambda
    300             ((e . f) (where (e zero?)) e)
     462            ((e . f) (>> e zero?) e)
    301463            ((a (b . #f) . d) (list a b d)))
    302464          '(1 (2 . #t) 4 5))
    303          ((exn sequence) #f)))
     465         ((exn) #f)))
    304466  (equal?
    305467    ((bind-case-lambda
    306        ((e . f) (where (e zero?)) e)
     468       ((e . f) (>> e zero?) e)
    307469       ((a (b "c") . d) (list a b d))
    308470       ((e . f) (list e f)))
     
    311473  (equal?
    312474    ((bind-case-lambda
    313        ((a (b . C) . d) (where (a integer?)) (list a b C d))
     475       ((a (b . C) . d) (>> a integer?) (list a b C d))
    314476       ((e . f) (list e f)))
    315477     '(1 #(2 3 4) 5 6))
     
    317479  (equal?
    318480    ((bind-case-lambda
    319        ((a (b . C) . d) (where (a string?)) (list a b C d))
     481       ((a (b . C) . d) (>> a string?) (list a b C d))
    320482       ((e . f) (list e f)))
    321483     '(1 #(2 3 4) 5 6))
     
    334496    '(1 20 #(30 40) (2 3) 4 (5 6)))
    335497  )
     498;(lambdas?)
    336499
    337500(define-test (lets?)
    338501  (equal?
    339     (bind-let (
    340                (((x y) z) '(#(1 2) 3))
     502    (bind-let ((((x y) z) '(#(1 2) 3))
    341503               (u (+ 2 2))
    342                ((v w) #(5 6))
    343                )
    344       (where (u integer?))
     504               ((v w) #(5 6)))
     505      (>> u integer?)
    345506      (list x y z u v w))
    346507    '(1 2 3 4 5 6))
    347508  (equal?
    348     (bind-named loop (a b) '(5 0)
     509    (bind* loop (a b) '(5 0)
    349510      (if (zero? a)
    350511        (list a b)
     
    352513    '(0 5))
    353514  (equal?
    354     (bind-let loop (
    355                     ((a b) '(5 0))
    356                     )
    357       (where (a integer?))
     515    (bind-let loop (((a b) '(5 0)))
     516      (>> a integer?)
    358517      (if (zero? a)
    359518        (list a b)
     
    361520    '(0 5))
    362521  (equal?
    363     (bind-let loop (
    364                     ((x . y) '(1 2 3))
    365                     ((z) #(10))
    366                     )
    367       (where (x integer?) (y (list-of? integer?)) (z integer?))
     522    (bind-let loop (((x . y) '(1 2 3))
     523                    ((z) #(10)))
     524      (>> x integer?) (>> y (list-of? integer?)) (>> z integer?)
    368525      (if (zero? z)
    369526        (list x y z)
     
    371528    '(11 (12 13) 0))
    372529  (equal?
    373     (bind-let* (
    374                 (((x y) z) '(#(1 2) 3))
     530    (bind-let* ((((x y) z) '(#(1 2) 3))
    375531                (u (+ 1 2 x))
    376                 ((v w) (list (+ z 2) 6))
    377                 )
    378       (where (u integer?))
     532                ((v w) (list (+ z 2) 6)))
     533      (>> u integer?)
    379534      (list x y z u v w))
    380535    '(1 2 3 4 5 6))
     
    384539        (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    385540        (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    386       (where (o? procedure?) (e? procedure?))
    387541      (list (o? 95) (e? 95)))
    388542    '(#t #f))
    389543  (equal?
    390     (bind-letrec (
    391                   ((o? (e?))
    392                    (list
    393                      (lambda (m) (if (zero? m) #f (e? (- m 1))))
    394                      (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    395                   )
    396       (where (o? procedure?) (e? procedure?))
     544    (bind-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     545                  ((e?)
     546                   (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    397547      (list (o? 95) (e? 95)))
    398548    '(#t #f))
    399549  )
    400 
    401 (define-test (defines?)
    402   (equal?
    403     (let ((x #f) (y #f) (z #f))
    404       (bind-set! (x (y . z))
    405         '(1 #(2 3 3)))
    406       (list x y z))
    407     '(1 2 #(3 3)))
    408   (equal?
    409     (let ((x #f) (y #f) (z #f))
    410       (bind-set! (x #f _ (y _ . z))
    411         '(1 #f 10 #(2 30 3 3)))
    412       (list x y z))
    413     '(1 2 #(3 3)))
    414   (equal?
    415     (let ((x #f) (y #f) (z #f))
    416       (bind-set! x 1 y 2 z 3)
    417       (list x y z))
    418     '(1 2 3))
    419   (equal?
    420     (let ((x #f) (y #f) (z #f) (u #f) (v #f))
    421       (bind-set!
    422         (x (y . z))
    423         '(1 #(2 3 3))
    424         (u (v))
    425         '(10 (20))
    426         (where (x integer?) (u number?)))
    427       (list x y z u v))
    428     '(1 2 #(3 3) 10 20))
    429   (equal?
    430     (let ((x #f) (y #f) (z #f))
    431       (bind-set! (x (y . z))
    432         '(1 #(2 3 3))
    433         (where (x integer?)))
    434       (list x y z))
    435     '(1 2 #(3 3)))
    436   (equal?
    437     (begin
    438       '(define stack #f) '(define push! #f) '(define pop! #f)
    439       (bind-set! (stack (push! pop!))
    440         (list
    441           '()
    442           (vector
    443             (lambda (xpr) (set! stack (cons xpr stack)))
    444             (lambda () (set! stack (cdr stack)))))
    445         (where (push! procedure?) (pop! procedure?)))
    446       (push! 1)
    447       (push! 0)
    448       stack)
    449     '(0 1))
    450   (equal?
    451     (begin
    452       (bind-define (plus5 times5)
    453         (let ((a 5))
    454           (list
    455             (lambda (x) (+ x a))
    456             (lambda (x) (* x a)))))
    457       (list (plus5 6) (times5 6)))
    458     '(11 30))
    459   (equal?
    460     (begin
    461       (bind-define (x . y) '(1 . 2) ((z)) '((3)) (where (x integer?)))
    462       (list x y z))
    463     '(1 2 3))
    464   (equal?
    465     (begin
    466       (bind-define (x _ . y) '(1 10 . 2) ((z)) '((3)) (where (x integer?)))
    467       (list x y z))
    468     '(1 2 3))
    469   (equal?
    470     (begin
    471       (bind-define (x #f . y) '(1 #f . 2) ((z)) '((3)))
    472       (list x y z))
    473     '(1 2 3))
    474   (equal?
    475     (begin
    476       (bind-define x 1 y 2 z 3 (where (x integer?)))
    477       (list x y z))
    478     '(1 2 3))
    479   (equal?
    480     (begin
    481       (bind-define (push top pop)
    482         (let ((lst '()))
    483           (vector
    484             (lambda (xpr) (set! lst (cons xpr lst)))
    485             (lambda () (car lst))
    486             (lambda () (set! lst (cdr lst)))))
    487         (where (push procedure?)
    488                (top procedure?)
    489                (pop procedure?)))
    490       (push 0)
    491       (push 1)
    492       (pop)
    493       (top))
    494     0)
    495   (equal?
    496     (begin
    497       (bind-define (x (_ y (z _))) '(1 #(2 3 (4 5))))
    498       (list x y z))
    499     '(1 3 4))
    500   (equal?
    501     (begin
    502       (bind-define (x (#f y (z #t)))
    503         (list 1 (vector (odd? 2) 3 (list 4 (odd?  5))))
    504         (where (x integer?)))
    505       (list x y z))
    506     '(1 3 4))
    507   )
     550;(lets?)
    508551
    509552(compound-test (BINDINGS)
     553  (helpers?)
     554  (lists-only?)
     555  (defines?)
    510556  (binds?)
    511557  (predicates?)
     
    513559  (lambdas?)
    514560  (lets?)
    515   (defines?)
    516   )
    517 
     561  )
     562
     563
  • release/5/bindings/trunk/bindings.egg

    r37352 r38015  
    22 (category lang-exts)
    33 (license "BSD")
    4  (dependencies simple-exceptions)
    5  (test-dependencies simple-tests)
     4 (test-dependencies simple-tests checks)
    65 (author "Juergen Lorenz")
    7  (version "1.5")
     6 (version "2.0")
    87 (components (extension bindings)))
  • release/5/bindings/trunk/bindings.scm

    r37352 r38015  
    1 ; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
     1; Author: Juergen Lorenz, ju (at) jugilo (dot) de
    22;
    3 ; Copyright (c) 2013-2018, Juergen Lorenz
     3; Copyright (c) 2013-2019, Juergen Lorenz
    44; All rights reserved.
    55;
     
    3131; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    3232
     33(module bindings (
     34  bind
     35  bind-set!
     36  bindrec
     37  bind-case
     38  bindable?
     39  bind-lambda
     40  bind-lambda*
     41  bind-case-lambda
     42  bind-case-lambda*
     43  bind*
     44  bind-let*
     45  bind-let
     46  bind-letrec
     47  bind-define
     48  bind/cc
     49  bind-seq->list
     50  bind-pvars
     51  bindings
     52  )
     53
     54(import scheme
     55        (only (chicken condition) condition-case)
     56        (only (chicken base) void receive identity print case-lambda error)
     57        (only (chicken keyword) keyword?)
     58        (only (chicken format) format)
     59        )
     60
     61(import-for-syntax (only (chicken keyword) keyword?))
     62
     63(define (split-along pat lst) ; internal
     64  (let loop ((pat pat) (tail lst) (head '()))
     65    (if (pair? pat)
     66      (if (pair? tail)
     67        (loop (cdr pat) (cdr tail) (cons (car tail) head))
     68        (error 'bind-set!
     69               (format #f "template ~s doesn't match pattern ~s~%"
     70                       tail pat)))
     71      (values (reverse head) tail))))
     72
     73;;; (bind-seq->list)
     74;;; (bind-seq->list seq)
     75;;; (bind-seq->list pat seq)
     76;;; (bind-seq->list seq? seq->list list->seq)
     77;;; -----------------------------------------
     78;;; the first version resets the internal database,
     79;;; the second the two transformers corresponding to seq,
     80;;; the third the transformed list, where the value of the possible
     81;;; dotted pattern variable is retransformed to the type of seq,
     82;;; and the last adds support for a new sequence type.
     83(define bind-seq->list
     84  (let ((db (list (cons (lambda (x) #t)
     85                        (cons identity
     86                              identity)))))
     87    (case-lambda
     88      (() (set! db ; reset
     89            (list (cons (lambda (x) #t)
     90                        (cons identity identity)))))
     91      ((seq)
     92       (let loop ((db db))
     93         (if ((caar db) seq)
     94           (cdar db)
     95           (loop (cdr db)))))
     96      ((pat seq)
     97       (let ((transformers
     98               (bind-seq->list seq)))
     99         (receive (head tail)
     100           (split-along pat ((car transformers) seq))
     101           (append head ((cdr transformers) tail)))))
     102      ((seq? seq->list list->seq)
     103       (set! db (cons (cons seq?
     104                            (cons seq->list list->seq)) db)))
     105      )))
     106
     107;;; (bind-pvars pat)
     108;;; ----------------
     109;;; returns the list of pattern variables of the pattern
     110;;; or error in case of duplicates
     111(define (bind-pvars pat)
     112  (let ((result '()))
     113    (let loop ((pat pat))
     114      (cond
     115        ((pair? pat)
     116         (loop (car pat))
     117         (loop (cdr pat)))
     118        ((and (symbol? pat)
     119              (not (eq? pat '_)))
     120         (if (memq pat result)
     121             (error 'bind-pvars
     122                    (format #f "duplicates: ~s already in ~s~%"
     123                            pat result))
     124             (set! result (cons pat result))))
     125        (else (void))))
     126    (reverse result)))
     127
     128;#|[
     129;bind-set! is the macro, which does all the dirty work. It destructures
     130;the pattern and the template in parallel, checks if literals match and
     131;if length' are equal, checks for duplicate pattern variables, and
     132;handles the wildcard, which matches everything but binds nothing.
     133;Because of the wildcard, _, the macro will be unhygienic, hence must
     134;be implemented procedurally. This has the additional advantage, that
     135;some the branching code can be evaluated at compile time.
     136
     137;]|#
     138
     139;;; (bind-set! pat seq)
     140;;; -------------------
     141;;; sets pattern variables of pat to the corresponding subexpression of
     142;;; seq, which might be arbitrary nested sequences, if bind-seq->list is
     143;;; prepared accordingly
     144(define-syntax bind-set!
     145  (er-macro-transformer
     146    (lambda (form rename compare?)
     147      (let ((pat (cadr form))
     148            (seq (caddr form))
     149            (%_ (rename '_))
     150            (%if (rename 'if))
     151            (%pair? (rename 'pair?))
     152            (%bind-set! (rename 'bind-set!))
     153            (%error (rename 'error))
     154            (%format (rename 'format))
     155            (%null? (rename 'null?))
     156            (%let (rename 'let))
     157            (%begin (rename 'begin))
     158            (%seq (rename 'seq))
     159            (%pat (rename 'pat))
     160            (%car (rename 'car))
     161            (%cdr (rename 'cdr))
     162            (%void (rename 'void))
     163            (%set! (rename 'set!))
     164            (%char=? (rename 'char=?))
     165            (%string=? (rename 'string=?))
     166            (%= (rename '=))
     167            (%eq? (rename 'eq?))
     168            (%bind-pvars (rename 'bind-pvars))
     169            (%bind-seq->list (rename 'bind-seq->list))
     170            )
     171        `(,%let ((,%pat ',pat) (,%seq ,seq))
     172           (,%bind-pvars ,%pat) ;check for duplicates
     173           ,(cond
     174              ((pair? pat)
     175               `(,%let ((,%seq (,%bind-seq->list ,%pat ,%seq)))
     176                        ; transform seq to pseudolist
     177                  (,%if (,%pair? ,%seq)
     178                    (,%begin
     179                      (,%bind-set! ,(car pat) (,%car ,%seq))
     180                      (,%bind-set! ,(cdr pat) (,%cdr ,%seq)))
     181                    (,%error 'bind-set!
     182                             (,%format
     183                               #f
     184                               "template ~s doesn't match pattern ~s\n"
     185                               ;,seq ',pat)))))
     186                               ,seq ,%pat)))))
     187              ((null? pat)
     188               `(,%if (,%null?
     189                        ((,%car (,%bind-seq->list ,%seq)) ,%seq))
     190                 (,%void)
     191                 (,%error 'bind-set!
     192                        (,%format #f
     193                                "template ~s doesn't match pattern ~s"
     194                                ,seq '()))))
     195              ;; symbols
     196              ((symbol? pat)
     197               (if (compare? pat %_) ; wildcard
     198                 `(,%void)
     199                 `(,%set! ,pat ,%seq)))
     200              ;; literals
     201              ((char? pat)
     202               `(,%if (,%char=? ',pat ,%seq)
     203                  (,%if #f #f) ;(,%void)
     204                  (,%error 'bind-set!
     205                        (,%format #f "strings ~s and ~s not char=?~%"
     206                                ',pat ,%seq))))
     207              ((string? pat)
     208               `(,%if (,%string=? ',pat ,%seq)
     209                  (,%if #f #f) ;(,%void)
     210                  (,%error 'bind-set!
     211                        (,%format #f "strings ~s and ~s not string=?~%"
     212                                ',pat ,%seq))))
     213              ((number? pat)
     214               `(if (,%= ',pat ,%seq)
     215                  (,%if #f #f) ;(,%void)
     216                  (,%error 'bind-set!
     217                        (,%format #f "numbers ~s and ~s not =~%"
     218                                ',pat ,%seq))))
     219              ((boolean? pat)
     220               `(,%if (,%eq? ',pat ,%seq)
     221                 (,%if #f #f) ;(,%void)
     222                 (,%error 'bind-set!
     223                        (,%format #f "booleans ~s and ~s not eq?~%"
     224                                ',pat ,%seq))))
     225              ((keyword? pat)
     226               `(,%if (,%eq? ',pat ,%seq)
     227                  (,%if #f #f) ;(,%void)
     228                  (,%error 'bind-set!
     229                        (,%format #f "keywords ~s and ~s not eq?~%"
     230                                ',pat ,%seq))))
     231              ))))))
    33232
    34233#|[
    35 
    36 The fundamental macro defined in this library is bind. It's like
    37 destructuring-bind in Common Lisp and dbind in Graham's classic On Lisp,
    38 but with some extensions, in particular, wildcards, non-symbol literals
    39 and fenders.
    40 
    41 The syntax is as follows
    42 
    43   (bind pat seq [(where . fenders)] . body)
    44 
    45 It destructures the seq argument according to the pat argument, binds
    46 pattern variables to corresponding sequence items and executes body in
    47 this context. For example
    48 
    49   (bind (x (y z) . w) '(1 #(2 3) 4 5) (where (y even?)) (list x y z w))
    50 
    51 will return '(1 2 3 (4 5)).
    52 
    53 (Note that the position of the optional fenders, supplied in a where
    54 clause, has changed again in this version: It's now always on top of the body.
    55 This simplyfies implementation and usage of the library).
    56 
    57 This version of the library is a complete rewrite. The code no longer
    58 uses Graham's dbind implementation. Instead, a direct implementation of
    59 bind is given, which doesn't need gensyms. The internal destructure
    60 routine transforms the pattern and sequence arguments into three lists,
    61 pairs, literals and tails. Pairs is a list of pattern-variable and
    62 corresponding sequence-accesscode pairs to be used in a let at runtime,
    63 literals and tails check for equality of literals and their
    64 corresponding sequence values, and the emptyness of sequence tails
    65 corresponding to null patterns respectively. So, contrary to Graham's
    66 dbind, an exception is raised if the lengths of a pattern and its
    67 corresponding sequence don't match. Fenders are supplied in a where
    68 clause at the very beginning of the macro body: A list of
    69 pattern-variable predicates pairs is internally transformed into a list
    70 of predicate calls.
    71 
    72 Sequences are either lists, psuedolists, vectors or strings by default.
    73 The sequence operators needed are bind-seq-ref, bind-seq-tail and bind-seq-null? with
    74 the same syntax as the likely named list routines.  But there is a
    75 procedure, bind-seq-db, which allows to add a pair consisting of a type
    76 predicate and a vector containing the needed operators to a database.
    77 
    78 ]|#
    79 
    80 (module bindings
    81   (bind bind-case bind-lambda bind-lambda* bind-case-lambda
    82    bind-case-lambda* bind-named bind-let bind-let* bind-letrec bindrec
    83    bindable? bind-define bind-set! bind/cc bindings bind-seq-db
    84    bind-seq-ref bind-seq-tail bind-seq-null? bind-seq-exception
    85    bind-pseudo-list? eos)
    86 
    87   (import scheme
    88           (only (chicken base)
    89                 case-lambda receive error assert define-inline
    90                 subvector chop print gensym)
    91           (only (chicken condition) condition-case)
    92           (only (chicken fixnum) fx+ fx- fx= fx>=)
    93           (only simple-exceptions make-exception raise)
    94           )
    95   (import-for-syntax (only (chicken base) receive chop)
    96                      (only (chicken keyword) keyword?))
    97 
    98 ;;; needed in lazy-pairs
    99 (define eos (gensym 'eos))
    100 
    101 ;;; exceptions
    102 ;;; ----------
    103 (define bind-seq-exception
    104   (make-exception "sequence exception" 'sequence))
    105 
    106 ;;; helpers
    107 ;;; -------
    108 (define-inline (1+ n) (fx+ n 1))
    109 (define-inline (1- n) (fx- n 1))
    110 (define-inline (0= n) (fx= n 0))
    111 (define-inline (0<= n) (fx>= n 0))
    112 
    113 (define (bind-pseudo-list? xpr) #t)
    114 
    115 ;;; (bind-seq-ref seq k)
    116 ;;; --------------------
    117 ;;; access to a sequence item
    118 ;;; the second returned value is needed in bind-seq-null?
    119 (define (bind-seq-ref seq k)
    120   (assert (0<= k) 'bind-seq-ref)
    121   (values
    122     (let loop ((db (bind-seq-db)))
    123       ;; Since everything is a bind-pseudo-list, which is checked last
    124       ;; db is never empty
    125       (if ((caar db) seq)
    126         ((vector-ref (cdar db) 0) seq k)
    127         (loop (cdr db))))
    128     #f))
    129 
    130 ;;; (bind-seq-tail seq k)
     234bind-define is simply an alias to bind-set!
     235]|#
     236
     237;;; (bind-define pat seq)
    131238;;; ---------------------
    132 ;;; access to the tail of a sequence
    133 (define (bind-seq-tail seq k)
    134   (assert (0<= k) 'bind-seq-tail)
    135   (let loop ((db (bind-seq-db)))
    136     ;; Since everything is a bind-pseudo-list, which is checked last
    137     ;; db is never empty
    138     (if ((caar db) seq)
    139       ((vector-ref (cdar db) 1) seq k)
    140       (loop (cdr db)))))
    141 
    142 ;;; (bind-seq-null? seq)
    143 ;;; --------------------
    144 ;;; tests for emptiness of a sequence
    145 (define (bind-seq-null? seq)
    146   (receive (result out-of-bounds?)
    147     (condition-case (bind-seq-ref seq 0)
    148       ((exn) (values #t #t)))
    149     ;(if out-of-bounds? #t #f)))
    150     (cond
    151       ((eq? #t result) ; exn
    152        (if out-of-bounds? #t #f))
    153       ((and (symbol? result) (eq? result eos)) ; gensym, lazy-list
    154        #t)
    155       (else #f)
    156        )))
    157 
    158 
    159 ;;; (bind-seq-db type? ref: ref tail: tail)
    160 ;;; ---------------------------------------
    161 ;;; adds a new sequence type to the front of the database
    162 ;;; (bind-seq-db)
    163 ;;; -------------
    164 ;;; shows the sequence database
    165 (define bind-seq-db
    166   (let ((db (list (cons list? (vector list-ref list-tail))
    167                   (cons vector? (vector vector-ref subvector))
    168                   (cons string? (vector string-ref substring))
    169                   (cons bind-pseudo-list?
    170                         (vector (lambda (pl k) ; ref
    171                                   (let loop ((pl pl) (n 0))
    172                                     (cond
    173                                       ((and (pair? pl) (fx= n k))
    174                                        (car pl))
    175                                       ((pair? pl)
    176                                        (loop (cdr pl) (1+ n)))
    177                                       (else
    178                                         (raise (bind-seq-exception 'bind-seq-ref
    179                                                               "out of range"
    180                                                               pl k))))))
    181                                 (lambda (pl k) ; tail  ;;; wrong at end
    182                                   (let loop ((pl pl) (n 0))
    183                                     (cond
    184                                       ((fx= n k)
    185                                        pl)
    186                                       ((pair? pl)
    187                                        (loop (cdr pl) (1+ n)))
    188                                       (else
    189                                         (raise (bind-seq-exception 'bind-seq-tail
    190                                                               "out of range"
    191                                                               pl k))))))
    192                                 ))
    193                   )))
    194     (case-lambda
    195       (() db)
    196       ((type? . keyword-args)
    197        (let* ((args (chop keyword-args 2))
    198               (vec (make-vector (length args))))
    199          ;; populate vec and add to db
    200          (do ((args args (cdr args)))
    201            ((null? args)
    202             (set! db
    203                   (cons (cons type? vec) db)))
    204            (case (caar args)
    205              ((#:ref)
    206               (vector-set! vec
    207                            0
    208                            (lambda (seq k)
    209                              (condition-case
    210                                ((cadar args) seq k)
    211                                ((exn)
    212                                 (raise (bind-seq-exception 'bind-seq-ref
    213                                                       "out of range"
    214                                                       seq k)))))))
    215              ((#:tail)
    216               (vector-set! vec
    217                            1
    218                            (lambda (seq k)
    219                              (condition-case
    220                                ((cadar args) seq k)
    221                                ((exn)
    222                                 (raise (bind-seq-exception 'bind-seq-tail
    223                                                       "out of range"
    224                                                       seq k)))))))
    225              (else
    226                (raise (bind-seq-exception 'bind-seq-db
    227                                      "not a keyword"
    228                                      (caar args))))
    229              )))))))
    230 
    231 ;;; simple explicit-renaming  macros
    232 ;;; ---------------------------------
    233 (define-syntax define-er-macro-transformer
    234   (syntax-rules ()
    235     ((_ (name form rename compare?) xpr . xprs)
    236      (define-syntax name
    237        (er-macro-transformer
    238          (lambda (form rename compare?) xpr . xprs))))))
     239;;; destructures the sequence seq according to the pattern
     240;;; pat and sets pattern variables with values
     241;;; to corresponding subexpressions of seq
     242(define-syntax bind-define
     243  (syntax-rules ()
     244    ((_ pat seq)
     245     (bind-set! pat seq))))
    239246
    240247#|[
    241 First, a helper macro, which allows to implement bind as well
    242 as a recursive version of it, bindrec, in one go.
    243 It does all of the dirty work,
    244 ]|#
    245 
    246 ;;; (bind-with binder pat seq xpr . xprs)
    247 ;;; -------------------------------------
    248 ;;; where binder is let or letrec
    249 (define-er-macro-transformer (bind-with form rename compare?)
    250   (let ((binder (cadr form))
    251         (pat (caddr form))
    252         (seq (cadddr form))
    253         (xpr (car (cddddr form)))
    254         (xprs (cdr (cddddr form)))
    255         (%and (rename 'and))
    256         (%where (rename 'where))
    257         (%_ (rename '_))
    258         (%if (rename 'if))
    259         (%raise (rename 'raise))
    260         (%begin (rename 'begin))
    261         (%error (rename 'error))
    262         (%equal? (rename 'equal?))
    263         (%bind-seq-ref (rename 'bind-seq-ref))
    264         (%bind-seq-tail (rename 'bind-seq-tail))
    265         (%bind-seq-null? (rename 'bind-seq-null?))
    266         (%bind-seq-exception (rename 'bind-seq-exception)))
    267     (let* ((fenders? (and (pair? xpr)
    268                         (compare? (car xpr) %where)))
    269            (where-clause (if fenders?
    270                              xpr                 
    271                              '(where)))
    272            (fenders
    273              (apply append
    274                     (map (lambda (pair)
    275                            (map (lambda (p?)
    276                                   `(,p?  ,(car pair)))
    277                                 (cdr pair)))
    278                          (cdr where-clause))))
    279            (body (if fenders?
    280                    `(,%if (,%and ,@fenders)
    281                       (,%begin ,@xprs)
    282                       (,%raise (,%bind-seq-exception
    283                                  'bind
    284                                  "fenders not passed"
    285                                  ',fenders)))
    286                    `(,%begin ,xpr ,@xprs))))
    287       (letrec (
    288         (no-dups?
    289           (lambda (lst)
    290             (call-with-current-continuation
    291               (lambda (cc)
    292                 (let loop ((lst lst) (result '()))
    293                   (if (null? lst)
    294                     #t
    295                     (loop (cdr lst)
    296                           ;(if (memq (car lst) result)
    297                           ;; keywords can be used as literals
    298                           (if (and (not (keyword? (car lst)))
    299                                    (memq (car lst) result))
    300                             (cc #f)
    301                             (cons (car lst) result)))))))))
    302         (destructure
    303            (lambda (pat seq)
    304              (let ((len (let loop ((pat pat) (result 0))
    305                           (cond
    306                             ((null? pat) result)
    307                             ((pair? pat)
    308                              (loop (cdr pat) (+ 1 result)))
    309                             (else result)))))
    310                (let loop ((k 0) (pairs '()) (literals '()) (tails '()))
    311                  (if (= k len)
    312                    (let ((sentinel
    313                            ;last dotted item or '()
    314                            (let loop ((result pat) (k len))
    315                              (if (zero? k)
    316                                result
    317                                (loop (cdr result) (- k 1))))))
    318                      (cond
    319                        ((null? sentinel)
    320                         (values pairs literals
    321                                 (cons `(,%bind-seq-null?
    322                                          (,%bind-seq-tail ,seq ,k))
    323                                       tails)))
    324                        ((symbol? sentinel)
    325                         (if (compare? sentinel %_)
    326                           (values pairs literals tails)
    327                           (values (cons (list sentinel
    328                                               `(,%bind-seq-tail ,seq ,k))
    329                                         pairs)
    330                                   literals tails)))
    331                        (else
    332                          (values pairs
    333                                  (cons `(,%equal? ',sentinel
    334                                                   (,%bind-seq-tail ,seq ,k))
    335                                        literals)
    336                                  tails))))
    337                    (let ((item (list-ref pat k)))
    338                      (cond
    339                        ;((symbol? item)
    340                        ((and (symbol? item) (not (keyword? item)))
    341                         (if (compare? item %_)
    342                           (loop (+ k 1) pairs literals tails)
    343                           (loop (+ k 1)
    344                                 (cons (list item `(,%bind-seq-ref ,seq ,k)) pairs)
    345                                 literals
    346                                 tails)))
    347                        ;((atom? item) ; literal
    348                        ((and (not (pair? item)) (not (null? item)))
    349                         (loop (+ k 1)
    350                               pairs
    351                               (cons `(,%equal? ',item
    352                                                (,%bind-seq-ref ,seq ,k))
    353                                     literals)
    354                               tails))
    355                        ;((pair? item)
    356                        ((or (null? item) (pair? item))
    357                         (receive (ps ls ts)
    358                           (destructure item `(,%bind-seq-ref ,seq ,k))
    359                           (loop (+ k 1)
    360                                 (append ps pairs)
    361                                 (append ls literals)
    362                                 (append ts tails))))
    363                        )))))))
    364         )
    365         (receive (pairs literals tails)
    366           (destructure pat seq)
    367           (if (no-dups? (map car pairs))
    368             `(,%if (,%and ,@tails)
    369                (,%if (,%and ,@literals)
    370                  (,(rename binder) ,pairs ,body)
    371                  (,%raise (,%bind-seq-exception
    372                             'bind
    373                             "literals don't match"
    374                             ',literals)))
    375                (,%raise (,%bind-seq-exception
    376                           'bind
    377                           "length mismatch"
    378                           ',tails)))
    379             `(,%error 'bind-with
    380                       "duplicate pattern variables"
    381                       ',(map car pairs))
    382           ))))))
    383 
    384 #|[
    385 The following is Graham's dbind extended with fenders, wildcards,
    386 non-symbol literals and length-checks. For example
    387 
    388   (bind (x (y z)) '(1 #(2 3)) (where (x integer?)) (list x y z))
     248The following is Graham's dbind extended with wildcards,
     249non-symbol literals and length as well as duplicate checks.
     250
     251For example
     252
     253  (bind (x (y z)) '(1 (2 3)) (>> x integer?) (list x y z))
    389254
    390255will result in '(1 2 3) while
    391256
    392   (bind (_ ("y" z)) '(1 #("y" z)) z)
     257  (bind (_ ("y" z)) '(1 ("y" 3)) z)
    393258
    394259will produce 3.
    395 ]|#
    396 
    397 ;;; (bind pat seq (where . fenders) .. xpr ....)
    398 ;;; ---------------------------------------------
     260
     261After adding vector and string support
     262
     263  (bind-seq->list string? string->list list->string)
     264  (bind-seq->list vector? vector->list list->vector)
     265
     266it will destructure vectors and strings as well:
     267
     268  (bind (x (y z)) '(1 #(2 3)) (list x y z))
     269  (bind (x (y z)) '(1 "12") (list x y z))
     270
     271]|#
     272
     273;;; (bind pat seq xpr ....)
     274;;; -----------------------
    399275;;; binds pattern variables of pat to corresponding subexpressions of
    400 ;;; seq and executes body xpr .... in this context, provided all
    401 ;;; fenders pass
    402 (define-er-macro-transformer (bind form rename compare?)
    403   (let ((pat (cadr form))
    404         (seq (caddr form))
    405         (xpr (cadddr form))
    406         (xprs (cddddr form))
    407         (%let (rename 'let))
    408         (%where (rename 'where))
    409         (%bind-with (rename 'bind-with))
    410         (%seq (rename 'seq)))
    411     (let ((fenders? (and (pair? xpr) (compare? (car xpr) %where))))
    412       (let ((body (if fenders?
    413                      `(,xpr ,@xprs)
    414                      `((,%where) ,xpr ,@xprs))))
    415         `(,%let ((,%seq ,seq))
    416            ;,(cons %bind-with
    417            ;       (cons %let
    418            ;             (cons pat
    419            ;                   (cons %seq body)))))))))
    420            ,(apply list %bind-with %let pat %seq body))))))
    421 
    422 #|[
    423 And here is the recursive version of bind, which is used in bind-letrec.
    424 
    425   (bindrec ((o?) e?)
    426     (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    427           (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    428     (list (o? 95) (e? 95)))
    429   -> '(#t #f)
    430 ]|#
    431 
    432 ;;; (bindrec pat seq (where fender ...) .. xpr ....)
    433 ;;; ------------------------------------------------
    434 ;;; recursive version of bind
    435 (define-syntax bindrec
     276;;; lst and executes body xpr .... in this context.
     277;;; Fenders are implemented in client code by the >> macro of the
     278;;; checks egg.
     279(define-syntax bind
    436280  (syntax-rules ()
    437281    ((_ pat seq xpr . xprs)
    438      (bind-with letrec pat seq xpr . xprs))))
     282     (begin
     283       (bind-set! pat seq) xpr . xprs))))
    439284
    440285#|[
     
    443288
    444289  (bind-case '(1 (2 3))
    445     ((x y) (where (y list?)) (list x y))
     290    ((x y) (>> y list?) (list x y))
    446291    ((x (y . z)) (list x y z))
    447292    ((x (y z)) (list x y z))) ;-> '(1 2 (3))
     
    455300]|#
    456301
    457 ;;; (bind-case seq (pat (where fender ...) .. xpr ....) ....)
    458 ;;; ---------------------------------------------------------
    459 ;;; Checks if seq matches pattern pat [satisfying fender ...] ....
     302;;; (bind-case seq (pat xpr ....) ....)
     303;;; -----------------------------------
     304;;; Checks if seq matches patterns pat ....
    460305;;; in sequence, binds the pattern variables of the first matching
    461306;;; pattern to corresponding subexpressions of seq and executes
    462 ;;; corresponding body xpr ....
     307;;; body expressions xpr .... in this context
    463308(define-syntax bind-case
    464   (ir-macro-transformer
    465     (lambda (form inject compare?)
    466   (let ((seq (cadr form))
    467         (rules (cddr form))
    468         (insert-where-clause
    469           (lambda (rule)
    470             (if (and (pair? (cadr rule))
    471                      (compare? (caadr rule) 'where))
    472               rule
    473               `(,(car rule) (,(inject 'where)) ,@(cdr rule))))))
    474     (let ((rules (map insert-where-clause rules))
    475           (rule->bind
    476             (lambda (rule)
    477               `(bind ,(car rule) ,seq ,(cadr rule) ,@(cddr rule)))))
    478       (let loop ((binds (map rule->bind rules)) (pats '()))
    479         (if (null? binds)
    480            `(raise (bind-seq-exception 'bind-case "no match"
    481                                   ,seq
    482                                   ',(reverse pats)))
    483            `(condition-case ,(car binds)
    484               ((exn)
    485                ,(loop (cdr binds)
    486                       (cons (list (cadar binds) (car (cdddar binds)))
    487                             pats)))))))))))
    488 ; the procedural version above improves the error message
    489 ;(define-syntax bind-case
    490 ;  (syntax-rules ()
    491 ;    ((_ seq)
    492 ;     (raise (bind-seq-exception 'bind-case "no match for" seq)))
    493 ;    ((_ seq (pat (where . fenders) xpr . xprs))
    494 ;     (condition-case (bind pat seq (where . fenders) xpr . xprs)
    495 ;       ((exn sequence) (bind-case seq))))
    496 ;    ((_ seq (pat xpr . xprs))
    497 ;     (bind-case seq (pat (where) xpr . xprs)))
    498 ;    ((_ seq clause . clauses)
    499 ;     (condition-case (bind-case seq clause)
    500 ;       ((exn sequence) (bind-case seq . clauses))))
    501 ;    ))
    502 
    503 #|[
    504 The next macro, bindable?, can be used to check, if a
    505 sequence-expression matches a pattern and passes all fenders.
    506 ]|#
    507 
    508 ;;; (bindable? pat (where fender ...) ..)
    509 ;;; -------------------------------------
    510 ;;; returns a unary predicate which checks, if its argument matches pat
    511 ;;; and fulfills the predicates in the list fender ...
    512 ;;; Mostly used in fenders of macro-rules and define-macro-transformer, but must
    513 ;;; then be imported for-syntax.
     309  (syntax-rules ()
     310    ((_ seq)
     311     (error 'bind-case "no match for" seq))
     312    ((_ seq (pat xpr . xprs))
     313     (condition-case (bind pat seq xpr . xprs)
     314       ((exn) (bind-case seq))))
     315    ((_ seq clause . clauses)
     316     (condition-case (bind-case seq clause)
     317       ((exn) (bind-case seq . clauses))))
     318    ))
     319
     320;;; (bindable? pat)
     321;;; ---------------
     322;;; returns a unary predicate which checks, if its arguments match pat
    514323(define-syntax bindable?
    515   (syntax-rules (where)
    516     ((_ pat (where . fenders))
     324  (syntax-rules ()
     325    ((_ pat)
    517326     (lambda (seq)
    518         (condition-case (bind pat seq (where . fenders) #t)
    519           ((exn sequence) #f))))
    520     ((_ pat)
    521      (bindable? pat (where)))))
    522 
    523 #|[
    524 The following two macros, bind-define and bind-set!, destructure their
    525 sequence arguments with respect to their pattern argument and define or
    526 set! the pattern variables correspondingly.  For example, one can define
    527 multiple procedures operating on a common state
    528 
    529   (bind-define (push top pop)
    530     (let ((state '()))
    531       (list
    532         (lambda (arg) (set! state (cons arg state)))
    533         (lambda () (car state))
    534         (lambda () (set! state (cdr state))))))
    535 
    536 ]|#
    537 
    538 ;;; (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
    539 ;;; -------------------------------------------------------
    540 ;;; sets pattern variables of pat pat1 ... to corresponding sub-expressins of
    541 ;;; seq seq1 ..., provided the fenders are satisfied
    542 (define-er-macro-transformer (bind-set! form rename compare?)
    543   (let ((pairs (reverse (chop (cdr form) 2)))
    544         (%_ (rename '_))
    545         (%let (rename 'let))
    546         (%list (rename 'list))
    547         (%where (rename 'where))
    548         (%bind (rename 'bind))
    549         (%set! (rename 'set!))
    550         (%seq (rename 'seq)))
    551     (let ((where-clause?
    552             (and (null? (cdar pairs))
    553                  (pair? (caar pairs))
    554                  (compare? (caaar pairs) %where))))
    555       (let ((where-clause (if where-clause?
    556                             (caar pairs)
    557                             `(,%where)))
    558             (pairs (if where-clause?
    559                      ;(reverse (cdr pairs))
    560                      (cdr pairs)
    561                      ;(reverse pairs))))
    562                      pairs)))
    563         (let ((pat (map car pairs))
    564               (seq `(,%list ,@(map cadr pairs)))
    565               (sym? (lambda (x)
    566                       (and (symbol? x)
    567                            (not (compare? x %_))))))
    568     (letrec (
    569       (pflatten (lambda (pls)
    570                   (cond
    571                     ((null? pls) pls)
    572                     ((pair? pls)
    573                      (append (pflatten (car pls))
    574                              (pflatten (cdr pls))))
    575                     (else (list pls)))))
    576       (filter (lambda (ok? lst)
    577                  (compress (map ok? lst) lst)))
    578       (reduce (lambda (pat)
    579                  (filter sym? (pflatten pat))))
    580       )
    581       (let ((aux (let copy ((pat pat))
    582                     (cond
    583                       ((sym? pat) (rename pat))
    584                       ((pair? pat)
    585                        (cons (copy (car pat)) (copy (cdr pat))))
    586                       (else pat))))
    587             (%where-clause
    588               (cons %where
    589                     (map (lambda (c)
    590                            (cons (rename (car c))
    591                                  (cdr c)))
    592                          (cdr where-clause)))))
    593         `(,%let ((,%seq ,seq))
    594            (,%bind ,aux ,%seq ,%where-clause
    595                    ,@(map (lambda (p a) `(,%set! ,p ,a))
    596                           (reduce pat)
    597                           (reduce aux))))
    598         )))))))
    599 
    600 ;;; (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
    601 ;;; ---------------------------------------------------------
    602 ;;; destructures the sequences seq seq1 ... according to the patterns
    603 ;;; pat pat1 ...  and sets pattern variables with values corresponding
    604 ;;; to subexpressions of seq seq1 ..., provided the fenders are
    605 ;;; satisfied
    606 (define-er-macro-transformer (bind-define form rename compare?)
    607   (let ((pairs (reverse (chop (cdr form) 2)))
    608         (%_ (rename '_))
    609         (%list (rename 'list))
    610         (%where (rename 'where))
    611         (%bind-set! (rename 'bind-set!))
    612         (%define (rename 'define))
    613         (%begin (rename 'begin)))
    614     (let ((where-clause?
    615             (and (null? (cdar pairs))
    616                  (pair? (caar pairs))
    617                  (compare? (caaar pairs) %where))))
    618       (let ((where-clause (if where-clause?
    619                             (caar pairs)
    620                             `(,%where)))
    621             (pairs (if where-clause?
    622                      ;(reverse (cdr pairs))
    623                      (cdr pairs)
    624                      ;(reverse pairs))))
    625                      pairs)))
    626         (let ((pat (map car pairs))
    627               (seq `(,%list ,@(map cadr pairs)))
    628               (sym? (lambda (x)
    629                       (and (symbol? x)
    630                            (not (compare? x %_))))))
    631     (letrec (
    632       (map-flatten (lambda (pls)
    633                      (cond
    634                        ((null? pls) pls)
    635                        ((pair? pls)
    636                         (append (map-flatten (car pls))
    637                                 (map-flatten (cdr pls))))
    638                        (else (list `(,%define ,pls #f))))))
    639       (filter (lambda (ok? lst)
    640                 (compress (map ok? lst) lst)))
    641       )
    642       `(,%begin
    643          ,@(filter sym?
    644                    (map-flatten pat))
    645          (,%bind-set! ,pat ,seq ,where-clause))))))))
     327        (condition-case (bind pat seq #t)
     328          ((exn) #f))))
     329    ))
    646330
    647331#|[
     
    660344]|#
    661345
    662 ;;; (bind-lambda pat (where fender ...) .. xpr ....)
    663 ;;; ------------------------------------------------
     346;;; (bind-lambda pat xpr ....)
     347;;; --------------------------
    664348;;; combination of lambda and bind, one pattern argument
    665349(define-syntax bind-lambda
    666   (syntax-rules (where)
    667     ((_ pat (where . fenders) xpr . xprs)
    668      (lambda (x) (bind pat x (where . fenders) xpr . xprs)))
     350  (syntax-rules ()
    669351    ((_ pat xpr . xprs)
    670      (bind-lambda pat (where) xpr . xprs))))
    671 
    672 ;;; (bind-lambda* pat (where fender ...) .. xpr ....)
    673 ;;; -------------------------------------------------
     352     (lambda (x) (bind pat x xpr . xprs)))
     353    ))
     354
     355;;; (bind-lambda* pat xpr ....)
     356;;; ---------------------------
    674357;;; combination of lambda and bind, multiple pattern arguments
    675358(define-syntax bind-lambda*
    676   (syntax-rules (where)
    677     ((_ pat (where . fenders) xpr . xprs)
    678      (lambda x (bind pat x (where . fenders) xpr . xprs)))
     359  (syntax-rules ()
    679360    ((_ pat xpr . xprs)
    680      (bind-lambda* pat (where) xpr . xprs))))
     361     (lambda x (bind pat x xpr . xprs)))
     362     ))
    681363
    682364#|[
     
    684366same as match-lambda and match-lambda* in the matchable package. The
    685367first destructures one argument, the second a list of arguments.
    686 Here is an example together with its result:
     368Here is an example together with its result (note the >> fender):
    687369
    688370  ((bind-case-lambda
    689371     ((a (b . c) . d) (list a b c d))
    690      ((e . f) (where (e zero?)) e)
     372     ((e . f) (>> e zero?) e)
    691373     ((e . f) (list e f)))
    692374   '(1 2 3 4 5))
     
    697379      (list a b c d e f)))
    698380   '(1 #(20 30 40) 2 3) '(4 5 6))
    699   -> '(1 20 #(30 40) (2 3) 4 (5 6))
    700 ]|#
    701 
    702 ;;; (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
    703 ;;; ------------------------------------------------------------
     381  -> '(1 20 (30 40) (2 3) 4 (5 6))
     382]|#
     383
     384;;; (bind-case-lambda (pat xpr ....) ....)
     385;;; --------------------------------------
    704386;;; combination of lambda and bind-case, one pattern argument
    705387(define-syntax bind-case-lambda
    706   (syntax-rules (where)
    707     ((_ (pat (where . fenders) xpr . xprs))
    708      (lambda (x)
    709        (bind-case x (pat (where . fenders) xpr . xprs))))
     388  (syntax-rules ()
    710389    ((_ (pat xpr . xprs))
    711390     (lambda (x)
     
    713392    ((_ clause . clauses)
    714393     (lambda (x)
    715        (bind-case x clause . clauses)))))
    716 
    717 ;;; (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
    718 ;;; -------------------------------------------------------------
     394       (bind-case x clause . clauses)))
     395    ))
     396
     397;;; (bind-case-lambda* (pat xpr ....) ....)
     398;;; ---------------------------------------
    719399;;; combination of lambda and bind-case, multiple pattern arguments
    720400(define-syntax bind-case-lambda*
    721   (syntax-rules (where)
    722     ((_ (pat (where . fenders) xpr . xprs))
    723      (lambda x
    724        (bind-case x (pat (where . fenders) xpr . xprs))))
     401  (syntax-rules ()
    725402    ((_ (pat xpr . xprs))
    726403     (lambda x
     
    728405    ((_ clause . clauses)
    729406     (lambda x
    730        (bind-case x clause . clauses)))))
     407       (bind-case x clause . clauses)))
     408    ))
    731409
    732410#|[
    733 The following macro, bind-named, is a named version of bind. It takes an
     411The following macro, bind*, is a named version of bind. It takes an
    734412additional argument besides those of bind, which is bound to a
    735413recursive procedure, which can be called in bind's body. The pattern
     
    737415For example
    738416
    739   (bind-named loop (x y) '(5 0)
     417  (bind* loop (x y) '(5 0)
    740418    (if (zero? x)
    741419      (list x y)
     
    744422]|#
    745423
    746 ;;; (bind-named name pat seq (where fender ...) .. xpr ....)
    747 ;;; ---- ---------------------------------------------------
     424;;; (bind* name pat seq xpr ....)
     425;;; ---- -----------------------------
    748426;;; named version of bind
    749 (define-syntax bind-named
    750   (syntax-rules (where)
    751     ((_ name pat seq (where . fenders) xpr . xprs)
    752      ((letrec ((name
    753                   (bind-lambda pat (where . fenders) xpr . xprs)))
    754          name)
    755        seq))
     427(define-syntax bind*
     428  (syntax-rules ()
    756429    ((_ name pat seq xpr . xprs)
    757      (bind-named name pat seq (where) xpr . xprs))))
     430     ((letrec ((name (bind-lambda pat xpr . xprs)))
     431        name)
     432      seq))))
    758433
    759434#|[
    760 Now the implementation of a nested version of let, named and unnamed,
    761 is easy: Simply combine bind and bind-named. For example
    762 
    763   (bind-let (
    764      (((x y) z) '((1 2) 3))
    765      (u (+ 2 2))
    766      ((v w) '(5 6))
    767      )
    768      (list x y z u v w))
    769   -> '(1 2 3 4 5 6)
    770 
    771   (bind-let loop (((a b) '(5 0)))
    772     (if (zero? a)
    773       (list a b)
    774       (loop (list (sub1 a) (add1 b)))))
    775       ;(loop (list (list (sub1 a) (add1 b))))))
    776       ;version with bind-named
    777   -> '(0 5)
    778 ]|#
    779 
    780 ;;; (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
    781 ;;; -----------------------------------------------------------------
    782 ;;; nested version of let, named and unnamed
    783 (define-er-macro-transformer (bind-let form rename compare?)
    784   (let ((named? (symbol? (cadr form))))
    785     (let ((name (if named? (cadr form) (gensym)))
    786           (binds (if named? (caddr form) (cadr form)))
    787           (xpr (if named? (cadddr form) (caddr form)))
    788           (xprs (if named? (cddddr form) (cdddr form))))
    789       (let ((pats (map car binds))
    790             (seqs (map cadr binds))
    791             (%list (rename 'list))
    792             (%bind (rename 'bind))
    793             ;(%bind-named (rename 'bind-named)))
    794             (%letrec (rename 'letrec))
    795             (%bind-lambda* (rename 'bind-lambda*)))
    796         (if named?
    797           `(,%letrec ((,name (,%bind-lambda* ,pats ,xpr ,@xprs)))
    798              (,name ,@seqs))
    799           ;`(,%bind-named ,name ,pats (,%list ,@seqs) ,xpr ,@xprs)
    800           `(,%bind ,pats (,%list ,@seqs) ,xpr ,@xprs))))))
    801 
    802 #|[
    803 The sequential version of bind-let should work as follows
    804 
    805   (bind-let* (
    806      (((x y) z) '((1 2) 3))
    807      (u (+ 1 2 x))
    808      ((v w) (list (+ z 2) 6))
    809      )
    810      (list x y z u v w))
    811   -> '(1 2 3 4 5 6)
    812 ]|#
    813 
    814 ;;; (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
    815 ;;; ----------------------------------------------------------
    816 ;;; sequential version of bind-let
     435The following three macros are analoga of the standard base macros let,
     436let* and letrec, the first named or unnamed. For example
     437
     438(bind-let loop (((a b) '(5 0)))
     439  (if (zero? a)
     440    (list a b)
     441    (loop (list (sub1 a) (add1 b)))))
     442-> '(0 5)
     443
     444A recursive version of bind follows
     445]|#
     446
     447;;; (bind-let* ((pat seq) ...) xpr . xprs)
     448;;; --------------------------------------
     449;;; sequentually binding patterns to sequences
    817450(define-syntax bind-let*
    818   (syntax-rules (where)
     451  (syntax-rules ()
    819452    ((_ () xpr . xprs)
    820      (begin xpr . xprs))
    821     ((_ ((pat seq)) (where . fenders) xpr . xprs)
    822      (bind pat seq (where . fenders) xpr . xprs))
     453     (let () xpr . xprs))
    823454    ((_ ((pat seq)) xpr . xprs)
    824455     (bind pat seq xpr . xprs))
    825     ((_ ((pat seq) binds ...) (where . fenders) xpr . xprs)
    826      (bind pat seq (bind-let* (binds ...)
    827                      (where . fenders) xpr . xprs)))
    828     ((_ ((pat seq) binds ...) xpr . xprs)
    829      (bind pat seq
    830        (bind-let* (binds ...) xpr . xprs)))))
     456    ((_ ((pat seq) (pat1 seq1) ...) xpr . xprs)
     457     (bind pat seq (bind-let* ((pat1 seq1) ...) xpr . xprs)))
     458     ))
     459
     460;;; (bind-let name .. ((pat seq) ...) xpr . xprs)
     461;;; ---------------------------------------------
     462;;; binding patterns to sequences in parallel, whith or without a
     463;;; recursive name procedure
     464(define-syntax bind-let
     465  (syntax-rules ()
     466    ((_ ((pat seq) ...) xpr . xprs)
     467     (bind (pat ...) (list seq ...) xpr . xprs))
     468    ((_ name ((pat seq) ...) xpr . xprs)
     469     ((letrec ((name (bind-lambda* (pat ...) xpr . xprs)))
     470        name)
     471      seq ...))
     472    ))
     473
     474;;; (bind-letrec ((pat seq) ...) xpr . xprs)
     475;;; ----------------------------------------
     476;;; binding patterns to sequences recursively
     477(define-syntax bind-letrec
     478  (syntax-rules ()
     479    ((_ ((pat seq) ...) xpr . xprs)
     480     (bind-let ((pat 'pat) ...)
     481       (bind-set! (pat ...) (list seq ...))
     482       xpr . xprs))))
     483   
     484;;; (bindrec pat seq xpr . xprs)
     485;;; ----------------------------
     486;;; recursive version of bind
     487(define-syntax bindrec
     488  (syntax-rules ()
     489    ((_ pat seq xpr . xprs)
     490     (bind pat 'pat
     491       (bind-set! pat seq)
     492       xpr . xprs))))
    831493
    832494#|[
    833 The recursive version of bind-let works as follows
    834  
    835   (bind-letrec (
    836     ((o? (e?))
    837      (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
    838            (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    839     )
    840     (list (o? 95) (e? 95)))
    841   -> '(#t #f)
    842 ]|#
    843 
    844 ;;; (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
    845 ;;; ------------------------------------------------------------
    846 ;;; recursive version of bind-let
    847 (define-er-macro-transformer (bind-letrec form rename compare?)
    848   (let ((binds (cadr form)) (xpr (caddr form)) (xprs (cdddr form)))
    849     (let ((pats (map car binds))
    850           (seqs (map cadr binds))
    851           (%list (rename 'list))
    852           (%bindrec (rename 'bindrec)))
    853       `(,%bindrec ,pats (,%list ,@seqs) ,xpr ,@xprs))))
    854 
    855 #|[
    856 The following macro is sometimes named let/cc or let-cc
     495I don't like the let/cc syntax, because it differs from let syntax,
     496here is bind/cc, which does the same.
    857497]|#
    858498
     
    867507       (lambda (cc) xpr . xprs)))))
    868508
    869 
    870 ;;; (symbol-dispatcher alist)
    871 ;;; -------------------------
    872 ;;; returns a procedure of zero or one argument, which shows all cars
    873 ;;; or the cdr of the alist item with car symbol
    874 (define (symbol-dispatcher alist)
     509(define (symbol-dispatcher alist) ; internal
    875510  (case-lambda
    876511    (()
     
    885520
    886521;;; (bindings sym ..)
    887 ;;; ----------------------
     522;;; -----------------
    888523;;; documentation procedure
    889524(define bindings
     
    893528      (bindings sym ..)
    894529      "documentation procedure")
    895     (bind-seq-exception
     530    (bind-seq->list
     531      generic procedure:
     532      (bind-seq->list)
     533      "resets the internal database for lists only"
     534      (bind-seq->list seq)
     535      "returns the pair of transformers corresponding to seq"
     536      (bind-seq->list pat seq)
     537      "returns a list where the value of the possible dotted"
     538      "argument is retransformed to the type of seq"
     539      (bind-seq->list seq? seq->list list->seq)
     540      "adds support for a new sequence type to the"
     541      "internal database")
     542    (bind-pvars
    896543      procedure:
    897       (bind-seq-exception loc . args)
    898       "generates an exception to be raised")
    899     (bind-seq-db
    900       procedure:
    901       (bind-seq-db)
    902       "shows the sequence database"
    903       (bind-seq-db type ref: ref tail: tail)
    904       "adds a new sequence type to the database where the keywords"
    905       "name arguments being accessed as bind-seq-ref and bind-seq-tail"
    906       "respectively")
    907     (bind-seq-ref
    908       procedure:
    909       (bind-seq-ref seq k)
    910       "sequence analog of list-ref")
    911     (bind-seq-tail
    912       procedure:
    913       (bind-seq-tail seq k)
    914       "sequence analog of list-tail")
    915     (bind-seq-null?
    916       procedure:
    917       (bind-seq-null? xpr)
    918       "sequence analog of null?")
    919     (bind-pseudo-list
    920       procedure:
    921       (bind-pseudo-list? xpr)
    922       "always #t")
     544      (bind-pvars pat)
     545      "checks if a pattern contains duplicate pattern variables,"
     546      "if so calls error, otherwise returns the list of pvars.")
    923547    (bind
    924548      macro:
    925       (bind pat seq (where fender ...) .. xpr ....)
     549      (bind pat seq xpr ....)
    926550      "a variant of Common Lisp's destructuring-bind")
    927551    (bind-case
    928552      macro:
    929       (bind-case seq (pat (where fender ...) .. xpr ....) ....)
     553      (bind-case seq (pat xpr ....) ....)
    930554      "matches seq against pat with optional fenders in a case regime")
    931555    (bindable?
    932556      macro:
    933       (bindable? pat (where fender ...) ..)
     557      (bindable? pat)
    934558      "returns a unary predicate, which checks"
    935559      "if its argument matches pat and passes all fenders")
    936560    (bind-set!
    937561      macro:
    938       (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
     562      (bind-set! pat seq)
    939563      "sets multiple variables by destructuring its sequence arguments")
    940564    (bind-define
    941565      macro:
    942       (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
     566      (bind-define pat seq)
    943567      "defines multiple variables by destructuring its sequence arguments")
    944568    (bind-lambda
    945569      macro:
    946       (bind-lambda pat (where fender ...) .. xpr ....)
     570      (bind-lambda pat xpr ....)
    947571      "combination of lambda and bind, one pattern argument")
    948572    (bind-lambda*
    949573      macro:
    950       (bind-lambda* pat (where fender ...) .. xpr ....)
     574      (bind-lambda* pat xpr ....)
    951575      "combination of lambda and bind, multiple pattern arguments")
    952     (bind-named
    953       macro:
    954       (bind-named loop pat (where fender ...) .. seq xpr ....)
     576    (bind*
     577      macro:
     578      (bind* loop pat seq xpr ....)
    955579      "named version of bind")
    956580    (bind-let
    957581      macro:
    958       (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
     582      (bind-let loop .. ((pat seq) ...) xpr ....)
    959583      "nested version of let, named and unnamed")
    960584    (bind-let*
    961585      macro:
    962       (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
     586      (bind-let* ((pat seq) ...) xpr ....)
    963587      "nested version of let*")
    964588    (bindrec
    965589      macro:
    966       (bindrec pat seq (where fender ...) .. xpr ....)
     590      (bindrec pat seq xpr ....)
    967591      "recursive version of bind")
    968592    (bind-letrec
    969593      macro:
    970       (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
     594      (bind-letrec ((pat seq) ...) xpr ....)
    971595      "recursive version of bind-let")
    972596    (bind-case-lambda
    973597      macro:
    974       (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
     598      (bind-case-lambda (pat xpr ....) ....)
    975599      "combination of lambda and bind-case with one pattern argument")
    976600    (bind-case-lambda*
    977601      macro:
    978       (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
     602      (bind-case-lambda* (pat xpr ....) ....)
    979603      "combination of lambda and bind-case with multiple pattern arguments")
    980604    (bind/cc
     
    984608      "and execute xpr ... in this context")
    985609    )))
    986   ) ; bindings
    987 
    988 ;(import bindings)
     610
     611) ; module
     612
  • release/5/bindings/trunk/tests/run.scm

    r36467 r38015  
    1 ;;;; File: tests/run.scm
    2 ;;;; Author: Juergen Lorenz
    3 ;;;; ju (at) jugilo (dot) de
     1;;; File: tests/run.scm
     2;;; Author: Juergen Lorenz
     3;;; ju (at) jugilo (dot) de
    44
    55(import simple-tests
    66        bindings
    7         simple-exceptions
     7        checks
    88        (chicken base)
    9         ;(only arrays array array? array-ref array-tail array->list)
     9        (chicken condition)
    1010        )
    1111
    12   (define (my-map fn lst)
    13     (let loop ((lst lst) (result '()))
    14       (bind-case lst
    15         (() (reverse result))
    16         ((x . xs)
    17          (loop xs (cons (fn x) result))))))
    18 
    19   (define (vector-map fn vec)
    20     (let* ((len (vector-length vec))
    21            (result (make-vector len #f)))
    22       (let loop ((vec vec))
    23         (bind-case vec
    24           (() result)
    25           ((x . xs)
    26            (vector-set! result
    27                         (- len (vector-length xs) 1)
    28                         (fn x))
    29            (loop (subvector vec 1)))))))
    30 
    31   (define (vector-reverse vec)
    32     (let ((result (make-vector (vector-length vec) #f)))
    33       (let loop ((vec vec))
    34         (bind-case vec
    35           (() result)
    36           ((x . xs)
    37            (vector-set! result
    38                         (vector-length xs)
    39                         x)
    40            (loop (subvector vec 1)))))))
    41 
    42   (define stack #f) (define push! #f) (define pop! #f)
     12(define-test (helpers?)
     13  ;; reset internal database
     14  (bind-seq->list)
     15
     16  (equal? (bind-pvars '(a (b c)))
     17          '(a b c))
     18  (equal? (bind-pvars '(a _ (b _ c)))
     19          '(a b c))
     20  (equal? (bind-pvars '(#f a (b 3 c)))
     21          '(a b c))
     22  (not (condition-case (bind-pvars '(a (b b)))
     23         ((exn) #f)))
     24  (equal? (bind-seq->list "x") (cons identity identity))
     25  (bind-seq->list string? string->list list->string)
     26  (bind-seq->list vector? vector->list list->vector)
     27  (equal? (bind-seq->list "x") (cons string->list list->string))
     28  (equal? (bind-seq->list '(x) "x") '(#\x . ""))
     29  (equal? (bind-seq->list '(x . y) "xyz") '(#\x . "yz"))
     30  (equal? (bind-seq->list '(x) #(1)) '(1 . #()))
     31  (equal? (bind-seq->list '(x . y) #(1 2 3)) '(1 . #(2 3)))
     32  )
     33;(helpers?)
     34
     35(define-test (lists-only?)
     36  ;; reset internal database
     37  (bind-seq->list)
     38
     39  "this would work with string support:"
     40  (not (condition-case (bind (x) "x" x)
     41         ((exn) #f)))
     42  (string=? (bind x "x" x) "x")
     43  (equal? (bind (x (y (z))) '(1 (2 (3))) (list x y z))
     44          '(1 2 3))
     45  (equal? (bind (x (y . z)) '(1 (2 . 3)) (list x y z))
     46          '(1 2 3))
     47  (let ((x #f) (y #f))
     48    (bind-set! (x (y)) '(1 (2)))
     49    (and (= x 1) (= y 2)))
     50  )
     51;(lists-only?)
     52
     53(define stack #f) (define push! #f) (define pop! #f)
     54
     55(define-test (defines?)
     56  ;; reset internal database
     57  (bind-seq->list)
     58  ;; add vector and string support
     59  (bind-seq->list string? string->list list->string)
     60  (bind-seq->list vector? vector->list list->vector)
     61
     62  (equal?
     63    (let ((x #f) (y #f) (z #f))
     64      (bind-set! (x (y . z))
     65        '(1 #(2 3 3)))
     66      (list x y z))
     67    '(1 2 #(3 3)))
     68  (equal?
     69    (let ((x #f) (y #f) (z #f))
     70      (bind-set! (x #f _ (y _ . z))
     71        '(1 #f 10 #(2 30 3 3)))
     72      (list x y z))
     73    '(1 2 #(3 3)))
     74  (equal?
     75    (let ((x #f) (y #f) (z #f))
     76      (bind-set! x 1)
     77      (bind-set! y 2)
     78      (bind-set! z 3)
     79      (list x y z))
     80    '(1 2 3))
     81  (equal?
     82    (let ((x #f) (y #f) (z #f) (u #f) (v #f))
     83      (bind-set! (x (y . z)) '(1 #(2 3 3)))
     84      (bind-set! (u (v)) '(10 (20)))
     85      (>> x integer?) (>> u number?)
     86      (list x y z u v))
     87    '(1 2 #(3 3) 10 20))
     88  (equal?
     89    (let ((x #f) (y #f) (z #f))
     90      (bind-set! (x (y . z))
     91        '(1 #(2 3 3)))
     92      (>> x integer?)
     93      (list x y z))
     94    '(1 2 #(3 3)))
     95  (equal?
     96    (let ((state #f) (push! #f) (pop! #f))
     97      (bind-set! (state (push! pop!))
     98        (list '()
     99              (vector
     100                (lambda (xpr) (set! state (cons xpr state)))
     101                (lambda () (set! state (cdr state))))))
     102      (>> push! procedure?) (>> pop! procedure?)
     103      (push! 1)
     104      (push! 0)
     105      state)
     106    '(0 1))
     107  (equal?
     108    (begin
     109      (bind-define (plus5 times5)
     110        (let ((a 5))
     111          (list
     112            (lambda (x) (+ x a))
     113            (lambda (x) (* x a)))))
     114      (list (plus5 6) (times5 6)))
     115    '(11 30))
     116  (equal?
     117    (begin
     118      (bind-define (x . y) '(1 . 2))
     119      (>> x integer?)
     120      (list x y))
     121    '(1 2))
     122  (equal?
     123    (begin
     124      (bind-define (x _ . y) '(1 10 . 2))
     125      (>> x integer?)
     126      (list x y))
     127    '(1 2))
     128  (equal?
     129    (begin
     130      (bind-define (x #f . y) '(1 #f . 2))
     131      (list x y))
     132    '(1 2))
     133  (=
     134    (begin
     135      (bind-define (push top pop)
     136        (let ((lst '()))
     137          (vector
     138            (lambda (xpr) (set! lst (cons xpr lst)))
     139            (lambda () (car lst))
     140            (lambda () (set! lst (cdr lst))))))
     141      (>> push procedure?)
     142      (>> top procedure?)
     143      (>> pop procedure?)
     144      (push 0)
     145      (push 1)
     146      (pop)
     147      (top))
     148    0)
     149  (equal?
     150    (begin
     151      (bind-define (x (_ y (z _))) '(1 #(2 3 (4 5))))
     152      (list x y z))
     153    '(1 3 4))
     154  (equal?
     155    (begin
     156      (bind-define (x (#f y (z #t)))
     157        (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
     158      (>> x integer?)
     159      (list x y z))
     160    '(1 3 4))
     161  )
     162;(defines?)
    43163
    44164(define-test (binds?)
     165  ;; reset internal database
     166  (bind-seq->list)
     167  ;; add string and vector support
     168  (bind-seq->list string? string->list list->string)
     169  (bind-seq->list vector? vector->list list->vector)
     170
    45171  (= (bind a 1 a) 1)
    46         (= (bind (a ()) (list 1 "") a) 1)
    47   (equal? (bind (a b) '(1 2) (where (a odd?)) (list a b)) '(1 2))
    48   (equal?
    49     (bind (x . y) '#(1 2 3 4) (list x y))
     172  ;(= (bind (a ()) (list 1 "") a) 1)
     173  (equal? (bind (a b) '(1 2) (>> a odd?) (list a b)) '(1 2))
     174  (equal?
     175    (bind (x . y) #(1 2 3 4) (list x y))
    50176    '(1 #(2 3 4)))
    51177  (equal?
    52     (bind (_ . y) '#(1 2 3 4) y)
     178    (bind (_ . y) #(1 2 3 4) y)
    53179    '#(2 3 4))
    54180  (equal?
     
    80206    '(1 2 3 4 5 #(6)))
    81207  (equal?
    82     (bind-named loop (x (a . b) y) '(5 #(1) 0) (where (x integer?))
     208    (bind* loop (x (a . b) y) '(5 #(1) 0)
     209      (>> x integer?)
    83210      (if (zero? x)
    84211        (list x a b y)
     
    86213    '(0 1 (1 1 1 1 1 . #()) 5))
    87214  (equal?
    88     (bind-named loop (x y) #(5 0) (where (x integer?))
     215    (bind* loop (x y) #(5 0)
     216      (>> x integer?)
    89217      (if (zero? x)
    90218        (vector x y)
     
    98226    (condition-case
    99227      (bind (#f . ys) '(#t 2 3) ys)
    100       ((exn sequence) #f)))
     228      ((exn) #f)))
    101229  (bind #f #f #t)
    102230  (not
    103231    (condition-case
    104232      (bind #f #t #t)
    105       ((exn sequence) #f)))
     233      ((exn) #f)))
    106234  (not
    107235    (condition-case
    108236      (bind (x . #f) '(1 . #t) x)
    109       ((exn sequence) #f)))
     237      ((exn) #f)))
    110238  (equal?
    111239    (bind (x (y . #f)) '(1 (2 . #f)) (list x y))
     
    114242    (condition-case
    115243      (bind (x (y . #f)) '(1 (2 . #t)) (list x y))
    116       ((exn sequence) #f)))
     244      ((exn) #f)))
    117245  (equal?
    118246    (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y))
     
    121249    (condition-case
    122250      (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y))
    123       ((exn sequence) #f)))
     251      ((exn) #f)))
    124252  (not
    125253    (condition-case
    126254      (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y))
    127       ((exn sequence) #f)))
    128   (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))
    129 
    130 ;  "ADD ARRAYS TO GENERIC SEQUENCES"
    131 ;  (bind-seq-db array? ref: array-ref tail: array-tail)
    132 ;  (equal?
    133 ;    (bind (x y z) (array 1 2 3) (list x y z))
    134 ;    '(1 2 3))
    135 ;  (equal?
    136 ;    (bind (x (y z)) (vector 0 (array 1 2)) (list x y z))
    137 ;    '(0 1 2))
    138 ;  (equal?
    139 ;    (bind (x (y . z)) (vector 0 (array 1 2 3 4))
    140 ;      (list x y (array->list z)))
    141 ;    '(0 1 (2 3 4)))
    142 
    143   )
     255      ((exn) #f)))
     256  (equal?
     257    (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))
     258    '(1 2 3))
     259  )
     260;(binds?)
    144261
    145262(define-test (predicates?)
     263  ; reset internal database
     264  (bind-seq->list)
     265  ; add vector and string support
     266  (bind-seq->list string? string->list list->string)
     267  (bind-seq->list vector? vector->list list->vector)
    146268  (not ((bindable? (x)) '(name 1)))
    147   (not ((bindable? (x y) (where (x number?))) '(name 1)))
    148   ((bindable? (_ x)) '(name 1))
    149269  (not ((bindable? (_ x)) '(name 1 2)))
    150   ((bindable? (a b) (where (a odd?))) '#(1 2))
    151   (not ((bindable? (x (y z)) (where (y char-alphabetic?))) '(1 "23")))
     270  ((bindable? (a b)) '#(1 2))
     271  ((bindable? (x (y z))) '(1 "23"))
    152272  ((bindable? (x (y . z))) '(1 "23"))
    153273  ((bindable? (x y)) '(1 "23"))
    154   (not ((bindable? (a (b . C) . d)) '(1 2 3 4 5)))
     274  (not ((bindable? (a (b . c) . d)) '(1 2 3 4 5)))
    155275  (not ((bindable? (a)) 1))
    156276  )
     277;(predicates?)
     278
     279(define (my-map fn lst)
     280  (let loop ((lst lst) (result '()))
     281    (bind-case lst
     282      (() (reverse result))
     283      ((x . xs)
     284       (loop xs (cons (fn x) result))))))
     285
     286(define (vector-map fn vec)
     287  (let* ((len (vector-length vec))
     288         (result (make-vector len #f)))
     289    (let loop ((vec vec))
     290      (bind-case vec
     291        (() result)
     292        ((x . xs)
     293         (vector-set! result
     294                      (- len (vector-length xs) 1)
     295                      (fn x))
     296         (loop (subvector vec 1)))))))
     297
     298(define (vector-reverse vec)
     299  (let ((result (make-vector (vector-length vec) #f)))
     300    (let loop ((vec vec))
     301      (bind-case vec
     302        (() result)
     303        ((x . xs)
     304         (vector-set! result
     305                      (vector-length xs)
     306                      x)
     307         (loop (subvector vec 1)))))))
    157308
    158309(define-test (cases?)
     310  ;; reset internal database
     311  (bind-seq->list)
     312  ;; add vector and string support
     313  (bind-seq->list string? string->list list->string)
     314  (bind-seq->list vector? vector->list list->vector)
    159315  (not (bind-case #() (() #f)))
    160316  (equal? (bind-case #(2 2)
    161             ((a b) (where (a even?) (b odd?)) (print 'even-odd a b))
    162             ((a b) (where (a odd?) (b even?)) (print 'odd-even a b))
     317            ((a b) (>> a even?) (>> b odd?) (print 'even-odd a b))
     318            ((a b) (>> a odd?) (>> b even?) (print 'odd-even a b))
    163319            ((a b) (list a b))) '(2 2))
    164320  (equal? (bind-case '(1 "2 3")
     
    168324          '(1 #\2 " 3"))
    169325  (equal? (bind-case '(1 "23")
    170             ((x (y z)) (where (y char-alphabetic?)) (list x y z))
     326            ((x (y z)) (>> y char-alphabetic?) (list x y z))
    171327            ((x (y . z)) (list x y z))
    172328            ((x y) (list x y)))
    173329          '(1 #\2 "3"))
    174330  (equal? (bind-case '(1 "23")
    175             ((x (y z)) (where (y char-alphabetic?)) (list x y z))
     331            ((x (y z)) (>> y char-alphabetic?) (list x y z))
    176332            ((x (y . _)) (list x y))
    177333            ((x y) (list x y)))
    178334          '(1 #\2))
    179335  (equal? (bind-case '(1 "23")
    180             ((x (y z)) (where (y char-numeric?)) (list x y z))
     336            ((x (y z)) (>> y char-numeric?) (list x y z))
    181337            ((x (y . z)) (list x y z))
    182338            ((x y) (list x y)))
     
    193349          '(1 #\2 " 3"))
    194350  (equal? (bind-case '(1 #(2 3))
    195             ((x y) (where (y list?)) (list x y))
     351            ((x y) (>> y list?) (list x y))
    196352            ((x (y . z)) (list x y z))
    197353            ((x (y z)) (list x y z)))
     
    250406  (bind-case #("a") ((#f) #f) (("a") #t))
    251407  (equal? (bind-case (vector 1 (list (odd? 2) 3))
    252             ((x y) (where (y number?)) (list x y))
     408            ((x y) (>> y number?) (list x y))
    253409            ((x ("y" . z)) (list x z))
    254410            ((x (#f z)) (list x z)))
     
    264420          '(1 (3)))
    265421  )
     422;(cases?)
    266423
    267424(define-test (lambdas?)
     425  ;; reset internal database
     426  (bind-seq->list)
     427  ;; add vector and string support
     428  (bind-seq->list string? string->list list->string)
     429  (bind-seq->list vector? vector->list list->vector)
    268430  (equal?
    269431    ((bind-lambda (a (b . C) . d)
     
    278440  (equal?
    279441    ((bind-case-lambda
    280        ((e . f) (where (e zero?)) f)
     442       ((e . f) (>> e zero?) f)
    281443       ((e . f) (list e f)))
    282444     '#(0 2 3 4 5))
     
    284446  (equal?
    285447    ((bind-case-lambda
    286        ((e . f) (where (e zero?)) e)
     448       ((e . f) (>> e zero?) e)
    287449       ((a (b . #f) . d) (list a b d))
    288450       ((e . f) (list e f)))
     
    291453  (equal?
    292454    ((bind-case-lambda
    293        ((e . f) (where (e zero?)) e)
     455       ((e . f) (>> e zero?) e)
    294456       ((a (b . #f) . d) (list a b d))
    295457       ((e . f) (list e f))) ; match
     
    298460  (not (condition-case
    299461         ((bind-case-lambda
    300             ((e . f) (where (e zero?)) e)
     462            ((e . f) (>> e zero?) e)
    301463            ((a (b . #f) . d) (list a b d)))
    302464          '(1 (2 . #t) 4 5))
    303          ((exn sequence) #f)))
     465         ((exn) #f)))
    304466  (equal?
    305467    ((bind-case-lambda
    306        ((e . f) (where (e zero?)) e)
     468       ((e . f) (>> e zero?) e)
    307469       ((a (b "c") . d) (list a b d))
    308470       ((e . f) (list e f)))
     
    311473  (equal?
    312474    ((bind-case-lambda
    313        ((a (b . C) . d) (where (a integer?)) (list a b C d))
     475       ((a (b . C) . d) (>> a integer?) (list a b C d))
    314476       ((e . f) (list e f)))
    315477     '(1 #(2 3 4) 5 6))
     
    317479  (equal?
    318480    ((bind-case-lambda
    319        ((a (b . C) . d) (where (a string?)) (list a b C d))
     481       ((a (b . C) . d) (>> a string?) (list a b C d))
    320482       ((e . f) (list e f)))
    321483     '(1 #(2 3 4) 5 6))
     
    334496    '(1 20 #(30 40) (2 3) 4 (5 6)))
    335497  )
     498;(lambdas?)
    336499
    337500(define-test (lets?)
    338501  (equal?
    339     (bind-let (
    340                (((x y) z) '(#(1 2) 3))
     502    (bind-let ((((x y) z) '(#(1 2) 3))
    341503               (u (+ 2 2))
    342                ((v w) #(5 6))
    343                )
    344       (where (u integer?))
     504               ((v w) #(5 6)))
     505      (>> u integer?)
    345506      (list x y z u v w))
    346507    '(1 2 3 4 5 6))
    347508  (equal?
    348     (bind-named loop (a b) '(5 0)
     509    (bind* loop (a b) '(5 0)
    349510      (if (zero? a)
    350511        (list a b)
     
    352513    '(0 5))
    353514  (equal?
    354     (bind-let loop (
    355                     ((a b) '(5 0))
    356                     )
    357       (where (a integer?))
     515    (bind-let loop (((a b) '(5 0)))
     516      (>> a integer?)
    358517      (if (zero? a)
    359518        (list a b)
     
    361520    '(0 5))
    362521  (equal?
    363     (bind-let loop (
    364                     ((x . y) '(1 2 3))
    365                     ((z) #(10))
    366                     )
    367       (where (x integer?) (y (list-of? integer?)) (z integer?))
     522    (bind-let loop (((x . y) '(1 2 3))
     523                    ((z) #(10)))
     524      (>> x integer?) (>> y (list-of? integer?)) (>> z integer?)
    368525      (if (zero? z)
    369526        (list x y z)
     
    371528    '(11 (12 13) 0))
    372529  (equal?
    373     (bind-let* (
    374                 (((x y) z) '(#(1 2) 3))
     530    (bind-let* ((((x y) z) '(#(1 2) 3))
    375531                (u (+ 1 2 x))
    376                 ((v w) (list (+ z 2) 6))
    377                 )
    378       (where (u integer?))
     532                ((v w) (list (+ z 2) 6)))
     533      (>> u integer?)
    379534      (list x y z u v w))
    380535    '(1 2 3 4 5 6))
     
    384539        (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    385540        (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    386       (where (o? procedure?) (e? procedure?))
    387541      (list (o? 95) (e? 95)))
    388542    '(#t #f))
    389543  (equal?
    390     (bind-letrec (
    391                   ((o? (e?))
    392                    (list
    393                      (lambda (m) (if (zero? m) #f (e? (- m 1))))
    394                      (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    395                   )
    396       (where (o? procedure?) (e? procedure?))
     544    (bind-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     545                  ((e?)
     546                   (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    397547      (list (o? 95) (e? 95)))
    398548    '(#t #f))
    399549  )
    400 
    401 (define-test (defines?)
    402   (equal?
    403     (let ((x #f) (y #f) (z #f))
    404       (bind-set! (x (y . z))
    405         '(1 #(2 3 3)))
    406       (list x y z))
    407     '(1 2 #(3 3)))
    408   (equal?
    409     (let ((x #f) (y #f) (z #f))
    410       (bind-set! (x #f _ (y _ . z))
    411         '(1 #f 10 #(2 30 3 3)))
    412       (list x y z))
    413     '(1 2 #(3 3)))
    414   (equal?
    415     (let ((x #f) (y #f) (z #f))
    416       (bind-set! x 1 y 2 z 3)
    417       (list x y z))
    418     '(1 2 3))
    419   (equal?
    420     (let ((x #f) (y #f) (z #f) (u #f) (v #f))
    421       (bind-set!
    422         (x (y . z))
    423         '(1 #(2 3 3))
    424         (u (v))
    425         '(10 (20))
    426         (where (x integer?) (u number?)))
    427       (list x y z u v))
    428     '(1 2 #(3 3) 10 20))
    429   (equal?
    430     (let ((x #f) (y #f) (z #f))
    431       (bind-set! (x (y . z))
    432         '(1 #(2 3 3))
    433         (where (x integer?)))
    434       (list x y z))
    435     '(1 2 #(3 3)))
    436   (equal?
    437     (begin
    438       '(define stack #f) '(define push! #f) '(define pop! #f)
    439       (bind-set! (stack (push! pop!))
    440         (list
    441           '()
    442           (vector
    443             (lambda (xpr) (set! stack (cons xpr stack)))
    444             (lambda () (set! stack (cdr stack)))))
    445         (where (push! procedure?) (pop! procedure?)))
    446       (push! 1)
    447       (push! 0)
    448       stack)
    449     '(0 1))
    450   (equal?
    451     (begin
    452       (bind-define (plus5 times5)
    453         (let ((a 5))
    454           (list
    455             (lambda (x) (+ x a))
    456             (lambda (x) (* x a)))))
    457       (list (plus5 6) (times5 6)))
    458     '(11 30))
    459   (equal?
    460     (begin
    461       (bind-define (x . y) '(1 . 2) ((z)) '((3)) (where (x integer?)))
    462       (list x y z))
    463     '(1 2 3))
    464   (equal?
    465     (begin
    466       (bind-define (x _ . y) '(1 10 . 2) ((z)) '((3)) (where (x integer?)))
    467       (list x y z))
    468     '(1 2 3))
    469   (equal?
    470     (begin
    471       (bind-define (x #f . y) '(1 #f . 2) ((z)) '((3)))
    472       (list x y z))
    473     '(1 2 3))
    474   (equal?
    475     (begin
    476       (bind-define x 1 y 2 z 3 (where (x integer?)))
    477       (list x y z))
    478     '(1 2 3))
    479   (equal?
    480     (begin
    481       (bind-define (push top pop)
    482         (let ((lst '()))
    483           (vector
    484             (lambda (xpr) (set! lst (cons xpr lst)))
    485             (lambda () (car lst))
    486             (lambda () (set! lst (cdr lst)))))
    487         (where (push procedure?)
    488                (top procedure?)
    489                (pop procedure?)))
    490       (push 0)
    491       (push 1)
    492       (pop)
    493       (top))
    494     0)
    495   (equal?
    496     (begin
    497       (bind-define (x (_ y (z _))) '(1 #(2 3 (4 5))))
    498       (list x y z))
    499     '(1 3 4))
    500   (equal?
    501     (begin
    502       (bind-define (x (#f y (z #t)))
    503         (list 1 (vector (odd? 2) 3 (list 4 (odd?  5))))
    504         (where (x integer?)))
    505       (list x y z))
    506     '(1 3 4))
    507   )
     550;(lets?)
    508551
    509552(compound-test (BINDINGS)
     553  (helpers?)
     554  (lists-only?)
     555  (defines?)
    510556  (binds?)
    511557  (predicates?)
     
    513559  (lambdas?)
    514560  (lets?)
    515   (defines?)
    516   )
    517 
     561  )
     562
     563
Note: See TracChangeset for help on using the changeset viewer.