Changeset 33533 in project


Ignore:
Timestamp:
07/26/16 15:06:32 (4 years ago)
Author:
juergen
Message:

bindings 6.0 complete rewrite

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

Legend:

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

    r32974 r33533  
    44 (category lang-exts)
    55 (license "BSD")
    6  (depends procedural-macros)
     6 (depends simple-exceptions basic-sequences)
    77 (test-depends simple-tests arrays)
    88 (author "Juergen Lorenz")
  • release/4/bindings/tags/6.0/bindings.scm

    r33088 r33533  
    11; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
    22;
    3 ; Copyright (c) 2013-2015, Juergen Lorenz
     3; Copyright (c) 2013-2016, Juergen Lorenz
    44; All rights reserved.
    55;
     
    3131; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    3232
    33 #|[
    34 The fundamental binding-construct, bind, is patterned after Paul Graham's
    35 dbind, cf. "On Lisp", p. 232.
    36 In Chicken, dbind for lists could look as follows
    37 
    38   (define-syntax dbind
    39     (ir-macro-transformer
    40       (lambda (form inject compare?)
    41         (letrec (
    42           (mappend
    43             (lambda (fn lists)
    44               (apply append (map fn lists))))
    45           (destruc
    46             (lambda (pat seq)
    47               (let loop ((pat pat) (seq seq) (n 0))
    48                 (if (pair? pat)
    49                   (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
    50                     (if (symbol? p)
    51                       (cons `(,p (list-ref ,seq ,n)) recu)
    52                       (let ((g (gensym)))
    53                         (cons (cons `(,g (list-ref ,seq ,n))
    54                                     (loop p g 0))
    55                               recu))))
    56                   (if (null? pat)
    57                     '()
    58                     `((,pat (list-tail ,seq ,n))))))))
    59           (dbind-ex
    60             (lambda (binds body)
    61               (if (null? binds)
    62                 `(begin ,@body)
    63                 `(let ,(map (lambda (b) (if (pair? (car b)) (car b) b))
    64                             binds)
    65                    ,(dbind-ex
    66                       (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
    67                                binds)
    68                       body)))))
    69           )         
    70           (let ((pat (cadr form))
    71                 (seq (caddr form))
    72                 (body (cdddr form))
    73                 (gseq 'seq))
    74             `(let ((,gseq ,seq))
    75                ,(dbind-ex (destruc pat gseq) body)))))))
    76 
    77 This code works as follows: First, destruc traverses the pattern and
    78 groups each symbol with some list accessing code, using gensyms to step
    79 down the pattern while grouping the gensym bound object with all pairs
    80 depending on this gensym. So, for example,
    81 
    82   (destruc '(a (b . c) . d) 'seq)
    83 
    84 will result in
    85 
    86   ((a (list-ref seq 0))
    87    ((#:g (list-ref seq 1)) (b (list-ref #:g 0)) (c (list-tail #:g 1)))
    88    (d (list-tail seq 2)))
    89 
    90 This tree is then transformed via dbind-ex into a nested let
    91 
    92   (let ((a (list-ref seq 0))
    93         (#:g (list-ref seq 1))
    94         (d (list-tail seq 2)))
    95     (let ((b (list-ref #:g 0))
    96           (c (list-tail #:g 1)))
    97       body))
    98  
    99 Note, that the destructuring procedures are local to this macro. This is
    100 necessary in Chicken for the macro to work, in particular in compiled
    101 code, unless you import them for-syntax. But since they are of no
    102 interest outside of the macro, local procedrues are preferable.
    103 
    104 Note further, that ir-macro-transformer does all the necessary renaming
    105 transparently behind the scene, even if the helpers where defined in
    106 another module. In particular, gseq needn't be a gensym.
    107 
    108 And note, that Graham's code didn't check for seq's length, i.e.
    109 (dbind (a b) '(1 2 3) (list a b) would happily return '(1 2).
    110 
    111 Graham's original code works on the sequence datatype, so vectors and
    112 strings are destructured as well. Sequences don't exist in Scheme,
    113 unless you import-for-syntax Felix' sequences egg. To make this module
    114 self-contained, I prefer to supply access-routines closed over a table,
    115 which provides sequence versions of list-ref and list-tail, the only
    116 sequence routines used by destruc above, as well as a sequence version
    117 of length, which is needed to do the length checks.
    118 
    119 There are some features, which I would like to have and which are
    120 implemented as well. First wildcards, represented by the underscore
    121 symbol. It matches everything, but binds nothing. So it can appear
    122 multiple times in the same macro. Wildcard symbols are simply not
    123 collected in the destruc routine.
    124 
    125 Second, non-symbol literals, which don't bind anything, of course, but
    126 match only themselves. This and the length checks are treated simply by
    127 pairing them as well with check-routines in destruc but separating the
    128 pairs with leading symbol from those with leading nil or literal in
    129 dbind-ex. The former are bound with lets as in Graham's code, the
    130 latter's cadrs being evaluated before the recursive call to dbind-ex.
    131 
    132 The last feature missing is fenders, which is important in particular
    133 for bind-case and can easily be implemented with a where clause: A
    134 pattern matches successfully if only each pattern variable can be bound
    135 and the where clause is satisfied. If the where clause doesn't pass, the
    136 next pattern is tried in bind-case or a bind-exception is signalled in
    137 bind.
    138 
    139 ]|#
    140 
    141 (require-library procedural-macros)
    142 
    143 (module bind-sequences
    144   (bind-table-show bind-table-add! range-exception
    145    bind-seq-length bind-seq-ref bind-seq-tail
    146    symbol-dispatcher list-of pseudo-list-of vector-of bind-sequences)
     33
     34#|[
     35
     36The fundamental macro defined in this library is bind. It's like
     37destructuring-bind in Common Lisp and dbind in Graham's classic On Lisp,
     38but with some extensions, in particular, wildcards, non-symbol literals
     39and fenders.
     40
     41The syntax is as follows
     42
     43  (bind pat seq [(where . fenders)] . body)
     44
     45It destructures the seq argument according to the pat argument, binds
     46pattern variables to corresponding sequence items and executes body in
     47this context. For example
     48
     49  (bind (x (y z) . w) '(1 #(2 3) 4 5) (where (y even?)) (list x y z w))
     50
     51will return '(1 2 3 (4 5)).
     52
     53(Note that the position of the optional fenders, supplied in a where
     54clause, has changed again in this version: It's now always on top of the body.
     55This simplyfies implementation and usage of the library).
     56
     57This version of the library is a complete rewrite. The code no longer
     58uses Graham's dbind implementation. Instead, a direct implementation of
     59bind is given, which doesn't need gensyms. The internal destructure
     60routine transforms the pattern and sequence arguments into three lists,
     61pairs, literals and tails. Pairs is a list of pattern-variable and
     62corresponding sequence-accesscode pairs to be used in a let at runtime,
     63literals and tails check for equality of literals and their
     64corresponding sequence values, and the emptyness of sequence tails
     65corresponding to null patterns respectively. So, contrary to Graham's
     66dbind, an exception is raised if the lengths of a pattern and its
     67corresponding sequence don't match. Fenders are supplied in a where
     68clause at the very beginning of the macro body: A list of
     69pattern-variable predicates pairs is internally transformed into a list
     70of predicate calls.
     71
     72Sequences are either lists, psuedolists, vectors or strings by default.
     73The sequence operators needed are seq-ref, seq-tail and seq-null? with the same
     74syntax as the likely named list routines.  But there is a procedure, seq-db,
     75which allows to add a pair consisting of a type predicate and a vector
     76containing the needed operators to a database. All these are implemented
     77in the basic-sequences egg, on which this version of the library
     78depends.  The database routine, seq-db, is reexported from there.
     79
     80]|#
     81
     82(require-library basic-sequences simple-exceptions)
     83
     84(module bindings
     85  (bind bind-case bind-lambda bind-lambda* bind-case-lambda
     86   bind-case-lambda* bind-named bind-let bind-let* bind-letrec bindrec
     87   bindable? bind-define bind-set! bind/cc bindings)
    14788
    14889  (import scheme
    149           (only data-structures conjoin list-of?)
    150           (only chicken
    151                 case-lambda define-values
    152                 signal make-property-condition make-composite-condition
    153                 error print subvector))
    154 
    155 #|[
    156 The following three routines maintain the lookup table for the needed
    157 sequence primitives. Instead of bind-table-lookup the three sequence
    158 primitives below are exported.
    159 If you prefer, you can use the sequence primitives size, elt and sub of
    160 the sequences egg, provided you rename them bind-seq-length,
    161 bind-seq-ref and bind-seq-tail respectively.
    162 ]|#
    163 
    164 (define (range-exception loc msg . args)
    165   (make-composite-condition
    166     (make-property-condition 'exn
    167       'location loc
    168       'message msg
    169       'arguments (apply list args))
    170     (make-property-condition 'range)))
    171 
    172 ;;; (bind-table-lookup obj)
    173 ;;; -----------------------
    174 ;;; returns an association list of predicates and associated vectors
    175 ;;; with length, ref and tail primitives
    176 ;;;
    177 ;;; (bind-table-show)
    178 ;;; -----------------
    179 ;;; prints the contents of the table
    180 ;;;
    181 ;;; (bind-table-add! type? len ref tail)
    182 ;;; ------------------------------------
    183 ;;; adds a new list to the top of the table
    184 (define-values (bind-table-lookup bind-table-show bind-table-add!)
    185   (let (
    186     (tbl
    187       (list (cons pair?
    188                   (vector
    189                     (lambda (obj)
    190                       (let loop ((obj obj) (len 0))
    191                         (if (pair? obj)
    192                           (loop (cdr obj) (+ len 1))
    193                           len)))
    194                     list-ref
    195                     list-tail))
    196             (cons vector?
    197                   (vector vector-length vector-ref subvector))
    198             (cons string?
    199                   (vector string-length string-ref substring))
    200             ;; atoms catch all
    201             (cons (lambda (obj) (not (pair? obj)))
    202                   (vector
    203                     (lambda (obj) 0) ; len
    204                     (lambda (obj pos) ; ref
    205                       (signal
    206                         (range-exception
    207                           'bind-table-lookup
    208                              "out of range"
    209                              obj
    210                              pos)))
    211                     (lambda (obj pos) ; tail
    212                       (if (zero? pos)
    213                         obj
    214                         (signal
    215                           (range-exception
    216                             'bind-table-lookup
    217                                "out of range"
    218                                obj))))))
    219             ))
    220     )
    221     (values
    222       (lambda (obj)
    223         (let loop ((tbl tbl))
    224           ;; note, that we have a catch-all predicate in the table
    225           (if ((caar tbl) obj)
    226             (cdar tbl)
    227             (loop (cdr tbl)))))
    228       (lambda () (print tbl))
    229       (lambda (type? len ref tail)
    230         (set! tbl (cons (cons type?
    231                               (vector len ref tail))
    232                         tbl))))
    233       ))
    234 
    235 ;;; (bind-seq-length seq)
    236 ;;; ---------------------
    237 ;;; returns the length of the sequence argument
    238 (define (bind-seq-length obj)
    239   ((vector-ref (bind-table-lookup obj) 0) obj))
    240 
    241 ;;; (bind-seq-ref seq pos)
    242 ;;; ----------------------
    243 ;;; returns the item of the sequence argument at index pos
    244 (define (bind-seq-ref obj pos)
    245   ((vector-ref (bind-table-lookup obj) 1) obj pos))
    246 
    247 ;;; (bind-seq-tail seq pos)
    248 ;;; -----------------------
    249 ;;; returns the tail of the sequence argument starting at index pos
    250 (define (bind-seq-tail obj pos)
    251   ((vector-ref (bind-table-lookup obj) 2) obj pos))
    252 
    253 #|[
    254 At last some helper functions, which sometimes make life easier
    255 ]|#
    256 
    257 ;;; (list-of ok? ....)
    258 ;;; ------------------
    259 ;;; returns a list predicate which checks all ok? arguments
    260 (define (list-of . oks?) (list-of? (apply conjoin oks?)))
    261 
    262 ;;; (pseudo-list-of ok? ....)
    263 ;;; ------------------
    264 ;;; returns a pseudo-list predicate which checks all ok? arguments
    265 (define (pseudo-list-of . oks?)
    266   (letrec
    267     ((pseudo-list-of?
    268        (lambda (ok?)
    269          (lambda (xpr)
    270            (or (ok? xpr)
    271                (and (pair? xpr)
    272                     (ok? (car xpr))
    273                     ((pseudo-list-of? ok?) (cdr xpr))))))))
    274     (pseudo-list-of? (apply conjoin oks?))))
    275 
    276 ;;; (vector-of ok? ....)
    277 ;;; --------------------
    278 ;;; returns a list predicate which checks all ok? arguments
    279 (define (vector-of . oks?)
    280   (let (
    281     (vector-of?
    282       (lambda (ok?)
    283         (lambda (vec)
    284           (and (vector? vec)
    285                (let loop ((n 0))
    286                  (cond
    287                    ((= n (vector-length vec))
    288                     #t)
    289                    ((ok? (vector-ref vec n))
    290                     (loop (+ n 1)))
    291                    (else #f)))))))
    292     )
    293     (vector-of? (apply conjoin oks?))))
    294 
    295 ;;; (symbol-dispatcher alist)
    296 ;;; -------------------------
    297 ;;; returns a procedure of zero or one argument, which shows all cars
    298 ;;; or the cdr of the alist item with car symbol
    299 (define (symbol-dispatcher alist)
    300   (case-lambda
    301     (()
    302      (map car alist))
    303     ((sym)
    304      (let ((pair (assq sym alist)))
    305        (if pair
    306          (for-each print (cdr pair))
    307          (error "Not in list"
    308                 sym
    309                 (map car alist)))))))
    310 
    311 (define bind-sequences
    312   (symbol-dispatcher '(
    313     (bind-seq-length
    314       procedure:
    315       (bind-seq-length seq)
    316       "redurns the length of a sequence")
    317     (bind-seq-ref
    318       procedure:
    319       (bind-seq-ref seq pos)
    320       "returns the item at position pos of a sequence")
    321     (bind-seq-tail
    322       procedure:
    323       (bind-seq-ref seq pos)
    324       "returns the tail starting at position pos of a sequence")
    325     (bind-table-show
    326       procedure:
    327       (bind-table-show)
    328       "pretty prints the sequence table")
    329     (bind-table-add!
    330       procedure:
    331       (bind-table-add! type? len ref tail)
    332       "adds a new table item to the front of the sequence table")
    333     (list-of
    334       procedure:
    335       (list-of ok? ...)
    336       "generates a list predicate which checks all of its arguments")
    337     (pseudo-list-of
    338       procedure:
    339       (pseudo-list-of ok? ...)
    340       "generates a pseudo-list predicate which checks all of its arguments")
    341     (vector-of
    342       procedure:
    343       (vector-of ok? ...)
    344       "generates a vector predicate which checks all of its arguments")
    345     (symbol-dispatcher
    346       procedure:
    347       (symbol-dispatcher alist)
    348       "generates a procedure of zero or one argument showing all"
    349       "cars or the cdr or the alist item with symbol as car")
    350     )))
    351 
    352 ) ; module bind-sequences
    353 
    354 ;(module bindings
    355 (functor (bind-functor (M (len ref tail)))
    356   (bind bind-case bind-lambda bind-lambda* bind-case-lambda
    357    bind-case-lambda* bind* bind-let bind-let* bind-letrec bindrec
    358    bindable? bind-define bind-set! bind/cc
    359    ;bind-exception-handler
    360    signal-bind-exception bind-exception
    361    bindings)
    362   (import scheme
    363           bind-sequences
    364           (only chicken case-lambda condition-case define-values
    365                 error subvector define-for-syntax
    366                 current-exception-handler condition-predicate
    367                 get-condition-property make-property-condition
    368                 make-composite-condition signal abort print)
    369           (only procedural-macros define-macro)
    370           M
     90          (only basic-sequences seq-ref seq-tail seq-null?
     91                seq-db seq-exception symbol-dispatcher)
     92          (only chicken condition-case receive error)
     93          (only simple-exceptions raise)
    37194          )
    372   (reexport (only bind-sequences
    373                   bind-table-add! bind-table-show
    374                   symbol-dispatcher list-of pseudo-list-of vector-of))
    375 
    376   (import-for-syntax
    377     (only procedural-macros macro-rules)
    378     (only data-structures compress))
    379 
    380 #|[
    381 Let's start with defining bind-exceptions, a corresponding exception-handler,
    382 and registering this handler
    383 ]|#
    384 
    385 ;;; (bind-exception loc msg arg ...)
    386 ;;; --------------------------------
    387 ;;; composite condition, to allow for (exn bind) in condition-case
    388 (define (bind-exception loc msg . args)
    389   (make-composite-condition
    390     (make-property-condition 'exn
    391       'location loc
    392       'message msg
    393       'arguments (apply list args))
    394     (make-property-condition 'bind)))
    395 
    396 ;;; (signal-bind-exception loc msg arg ...)
    397 ;;; ---------------------------------------
    398 ;;; signals a bind-exception, can be used instead of error
    399 (define (signal-bind-exception loc msg . args)
    400   (signal
    401     (apply bind-exception loc msg args)))
    402 
    403 ;;;; (bind-exception-handler var)
    404 ;;;; ----------------------------
    405 ;;;; exception-handler to be passed to the parameter
    406 ;;;; current-exception-handler
    407 ;(define bind-exception-handler
    408 ;  (let ((old-handler (current-exception-handler)))
    409 ;    (lambda (var)
    410 ;      (if ((condition-predicate 'bind) var)
    411 ;        (begin
    412 ;          (display "Bind error: ")
    413 ;          (print (get-condition-property var 'bind 'location))
    414 ;          (print (get-condition-property var 'bind 'message))
    415 ;          (for-each print (get-condition-property var 'bind 'arguments))
    416 ;          (abort (make-property-condition 'exn
    417 ;                   'message "exception-handler returned")))
    418 ;        (old-handler var)))))
    419 ;
    420 ;;;; set current-exception-handler
    421 ;(current-exception-handler bind-exception-handler)
     95  (import-for-syntax (only chicken receive)
     96                     (only data-structures chop))
     97
     98  (reexport (only basic-sequences seq-db))
     99 
     100;;; simple explicit-renaming  macros
     101;;; ---------------------------------
     102(define-syntax define-er-macro-transformer
     103  (syntax-rules ()
     104    ((_ (name form rename compare?) xpr . xprs)
     105     (define-syntax name
     106       (er-macro-transformer
     107         (lambda (form rename compare?) xpr . xprs))))))
     108
     109#|[
     110First, a helper macro, which allows to implement bind as well
     111as a recursive version of it, bindrec, in one go.
     112It does all of the dirty work,
     113]|#
     114
     115;;; (bind-with binder pat seq xpr . xprs)
     116;;; -------------------------------------
     117;;; where binder is let or letrec
     118(define-er-macro-transformer (bind-with form rename compare?)
     119  (let ((binder (cadr form))
     120        (pat (caddr form))
     121        (seq (cadddr form))
     122        (xpr (car (cddddr form)))
     123        (xprs (cdr (cddddr form)))
     124        (%and (rename 'and))
     125        (%where (rename 'where))
     126        (%_ (rename '_))
     127        (%if (rename 'if))
     128        (%raise (rename 'raise))
     129        (%begin (rename 'begin))
     130        (%error (rename 'error))
     131        (%equal? (rename 'equal?))
     132        (%seq-ref (rename 'seq-ref))
     133        (%seq-tail (rename 'seq-tail))
     134        (%seq-null? (rename 'seq-null?))
     135        (%seq-exception (rename 'seq-exception)))
     136    (let* ((fenders? (and (pair? xpr)
     137                        (compare? (car xpr) %where)))
     138           (where-clause (if fenders?
     139                             xpr                 
     140                             '(where)))
     141           (fenders
     142             (apply append
     143                    (map (lambda (pair)
     144                           (map (lambda (p?)
     145                                  `(,p?  ,(car pair)))
     146                                (cdr pair)))
     147                         (cdr where-clause))))
     148           (body (if fenders?
     149                   `(,%if (,%and ,@fenders)
     150                      (,%begin ,@xprs)
     151                      (,%raise (,%seq-exception
     152                                 'bind
     153                                 "fenders not passed"
     154                                 ',fenders)))
     155                   `(,%begin ,xpr ,@xprs))))
     156      (letrec (
     157        (no-dups?
     158          (lambda (lst)
     159            (call-with-current-continuation
     160              (lambda (cc)
     161                (let loop ((lst lst) (result '()))
     162                  (if (null? lst)
     163                    #t
     164                    (loop (cdr lst)
     165                          (if (memq (car lst) result)
     166                            (cc #f)
     167                            (cons (car lst) result)))))))))
     168        (destructure
     169           (lambda (pat seq)
     170             (let ((len (let loop ((pat pat) (result 0))
     171                          (cond
     172                            ((null? pat) result)
     173                            ((pair? pat)
     174                             (loop (cdr pat) (+ 1 result)))
     175                            (else result)))))
     176               (let loop ((k 0) (pairs '()) (literals '()) (tails '()))
     177                 (if (= k len)
     178                   (let ((sentinel
     179                           ;last dotted item or '()
     180                           (let loop ((result pat) (k len))
     181                             (if (zero? k)
     182                               result
     183                               (loop (cdr result) (- k 1))))))
     184                     (cond
     185                       ((null? sentinel)
     186                        (values pairs literals
     187                                (cons `(,%seq-null?
     188                                         (,%seq-tail ,seq ,k))
     189                                      tails)))
     190                       ((symbol? sentinel)
     191                        (if (compare? sentinel %_)
     192                          (values pairs literals tails)
     193                          (values (cons (list sentinel
     194                                              `(,%seq-tail ,seq ,k))
     195                                        pairs)
     196                                  literals tails)))
     197                       (else
     198                         (values pairs
     199                                 (cons `(,%equal? ,sentinel
     200                                                  (,%seq-tail ,seq ,k))
     201                                       literals)
     202                                 tails))))
     203                   (let ((item (list-ref pat k)))
     204                     (cond
     205                       ((symbol? item)
     206                        (if (compare? item %_)
     207                          (loop (+ k 1) pairs literals tails)
     208                          (loop (+ k 1)
     209                                (cons (list item `(,%seq-ref ,seq ,k)) pairs)
     210                                literals
     211                                tails)))
     212                       ((atom? item) ; literal
     213                        (loop (+ k 1)
     214                              pairs
     215                              (cons `(,%equal? ,item
     216                                               (,%seq-ref ,seq ,k))
     217                                    literals)
     218                              tails))
     219                       ((pair? item)
     220                        (receive (ps ls ts)
     221                          (destructure item `(,%seq-ref ,seq ,k))
     222                          (loop (+ k 1)
     223                                (append ps pairs)
     224                                (append ls literals)
     225                                (append ts tails))))
     226                       )))))))
     227        )
     228        (receive (pairs literals tails)
     229          (destructure pat seq)
     230          (if (no-dups? (map car pairs))
     231            `(,%if (,%and ,@tails)
     232               (,%if (,%and ,@literals)
     233                 (,(rename binder) ,pairs ,body)
     234                 (,%raise (,%seq-exception
     235                            'bind
     236                            "literals don't match"
     237                            ',literals)))
     238               (,%raise (,%seq-exception
     239                          'bind
     240                          "length mismatch"
     241                          ',tails)))
     242            `(,%error 'bind-with
     243                      "duplicate pattern variables"
     244                      ',(map car pairs))
     245          ))))))
    422246
    423247#|[
     
    431255  (bind (_ ("y" z)) '(1 #("y" z)) z)
    432256
    433 will produce 3
    434 
    435 ]|#
    436 
    437 ;;; (bind pat (where . fenders) .. seq xpr ....)
     257will produce 3.
     258]|#
     259
     260;;; (bind pat seq (where . fenders) .. xpr ....)
    438261;;; ---------------------------------------------
    439262;;; binds pattern variables of pat to corresponding subexpressions of
    440263;;; seq and executes body xpr .... in this context, provided all
    441264;;; fenders pass
    442 (define-syntax bind
    443   (macro-rules _ (where)
    444     ((bind pat (where . fenders) seq xpr . xprs)
    445      (letrec (
    446        (filter
    447          (lambda (ok? lst)
    448            (let loop ((lst lst) (yes '()) (no '()))
    449              (if (null? lst)
    450                (values (reverse yes) (reverse no))
    451                (let ((first (car lst)) (rest (cdr lst)))
    452                  (if (ok? first)
    453                    (loop rest (cons first yes) no)
    454                    (loop rest yes (cons first no))))))))
    455        (mappend
    456          (lambda (fn lists)
    457            (apply append (map fn lists))))
    458        (fenders->tests
    459          (lambda (fenders)
    460            (apply append
    461                   (map (lambda (pair)
    462                          (map (lambda (p?)
    463                                 `(,p?  ,(car pair)))
    464                               (cdr pair)))
    465                        fenders))))
    466        (destruc
    467          (lambda (pat seq)
    468            (let loop ((pat pat) (seq seq) (n 0))
    469              (if (pair? pat)
    470                (let ((p (car pat))
    471                      (recu (loop (cdr pat) seq (+ n 1))))
    472                  (cond
    473                    ((pair? p)
    474                     (let ((g (gensym)))
    475                       `(((,g (ref ,seq ,n)) ,@(loop p g 0))
    476                         ,@recu)))
    477                    ((symbol? p)
    478                     (if (eq? p _)
    479                       ;; skip
    480                       recu
    481                       `((,p (ref ,seq ,n)) ,@recu)))
    482                    (else ; other atom
    483                      `((,p (equal? ',p (ref ,seq ,n)))
    484                        ,@recu))
    485                    ))
    486                ;; atom
    487                (cond
    488                  ((symbol? pat)
    489                   (if (eq? pat _) ; skip
    490                     (loop '() seq `(len ,seq))
    491                     `((,pat (tail ,seq ,n))))
    492                   )
    493                  ((null? pat)
    494                   `((,pat (zero? (len (tail ,seq ,n))))))
    495                  (else ; other atom
    496                    `((,pat (equal? ,pat (tail ,seq ,n)))))))
    497                )))
    498        (dbind-ex
    499          (lambda (binds body)
    500            (if (null? binds)
    501              `(begin ,@body)
    502              (call-with-values
    503                (lambda ()
    504                  (filter (lambda (pair) (symbol? (car pair)))
    505                          (map (lambda (b) (if (pair? (car b)) (car b) b))
    506                               binds)))
    507                (lambda (defs checks)
    508                     ;(print "YYYYY " `(and ,@(map cadr checks)))
    509                  `(let ,defs
    510                     (if (and ,@(map cadr checks))
    511                       ,(dbind-ex
    512                          (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
    513                                   binds)
    514                          `((if (or ,(null? fenders)
    515                                    ,(cons 'and (fenders->tests
    516                                                  fenders)))
    517                              (begin ,@body)
    518                              (signal-bind-exception
    519                                'bind
    520                                "fenders not passed"
    521                                ,seq
    522                                ',pat
    523                                ',(cons 'where fenders)))))
    524                       (signal-bind-exception
    525                         'bind
    526                         "match error"
    527                         ,seq
    528                         ',pat
    529                         ',(cons 'and (map cadr checks))))))
    530              ))))
    531        )         
    532        (let ((gseq 'seq))
    533          `(let ((,gseq ,seq))
    534             ,(dbind-ex ;(condition-case
    535                        ;  (destruc pat gseq)
    536                        ;  ((exn) (signal-bind-exception
    537                        ;           'bind
    538                        ;           "match error"
    539                        ;           gseq
    540                        ;           ',pat)))
    541                        (destruc pat gseq)
    542                        (cons xpr xprs)))
    543            )))
    544     ((bind pat seq xpr . xprs)
    545      `(bind ,pat (where) ,seq ,xpr ,@xprs))))
     265(define-er-macro-transformer (bind form rename compare?)
     266  (let ((pat (cadr form))
     267        (seq (caddr form))
     268        (xpr (cadddr form))
     269        (xprs (cddddr form))
     270        (%let (rename 'let))
     271        (%where (rename 'where))
     272        (%bind-with (rename 'bind-with))
     273        (%seq (rename 'seq)))
     274    (let ((fenders? (and (pair? xpr) (compare? (car xpr) %where))))
     275      (let ((body (if fenders?
     276                     `(,xpr ,@xprs)
     277                     `((,%where) ,xpr ,@xprs))))
     278        `(,%let ((,%seq ,seq))
     279           ,(cons %bind-with
     280                  (cons %let
     281                        (cons pat
     282                              (cons %seq body)))))))))
     283
     284#|[
     285And here is the recursive version of bind, which is used in bind-letrec.
     286
     287  (bindrec ((o?) e?)
     288    (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     289          (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     290    (list (o? 95) (e? 95)))
     291  -> '(#t #f)
     292]|#
     293
     294;;; (bindrec pat seq (where fender ...) .. xpr ....)
     295;;; ------------------------------------------------
     296;;; recursive version of bind
     297(define-syntax bindrec
     298  (syntax-rules ()
     299    ((_ pat seq xpr . xprs)
     300     (bind-with letrec pat seq xpr . xprs))))
    546301
    547302#|[
     
    560315      (() '())
    561316      ((x . xs) (cons (fn x) (my-map fn xs)))))
    562 
    563 To improve error messages, we wrap it around an inner version,
    564 bind-case-inner, which does all of the work.
    565 ]|#
    566 
    567 ;;; inner version, not exported
    568 (define-syntax bind-case-inner
    569   (macro-rules (where)
    570     ((_ seq (pat (where . fenders) xpr . xprs))
    571      `(bind ,pat (where ,@fenders) ,seq ,xpr ,@xprs))
    572     ((_ seq (pat xpr . xprs))
    573      `(bind ,pat (where) ,seq ,xpr ,@xprs))
    574     ((_ seq clause . clauses)
    575      `(condition-case (bind-case-inner ,seq ,clause)
    576         ((exn type)
    577          (bind-case-inner ,seq ,@clauses))
    578         ((exn bind)
    579          (bind-case-inner ,seq ,@clauses))))))
     317]|#
    580318
    581319;;; (bind-case seq (pat (where fender ...) .. xpr ....) ....)
     
    585323;;; pattern to corresponding subexpressions of seq and executes
    586324;;; corresponding body xpr ....
    587 (define-macro (bind-case seq clause . clauses)
    588   `(condition-case
    589      (bind-case-inner ,seq ,clause ,@clauses)
    590      ((exn bind)
    591       (signal-bind-exception
    592         'bind-case
    593         "no match for"
    594         ,seq
    595         'in
    596         ',(map (lambda (cl)
    597                  (list (car cl) (cadr cl)))
    598                (cons clause clauses))))))
     325(define-syntax bind-case
     326  (syntax-rules ()
     327    ((_ seq)
     328     (raise (seq-exception 'bind-case "no match for" seq)))
     329    ((_ seq (pat (where . fenders) xpr . xprs))
     330     (condition-case (bind pat seq (where . fenders) xpr . xprs)
     331       ((exn sequence) (bind-case seq))))
     332    ((_ seq (pat xpr . xprs))
     333     (bind-case seq (pat (where) xpr . xprs)))
     334    ((_ seq clause . clauses)
     335     (condition-case (bind-case seq clause)
     336       ((exn sequence) (bind-case seq . clauses))))
     337    ))
    599338
    600339#|[
     
    607346;;; returns a unary predicate which checks, if its argument matches pat
    608347;;; and fulfills the predicates in the list fender ...
    609 ;;; Mostly used in fenders of macro-rules and define-macro, but must
     348;;; Mostly used in fenders of macro-rules and define-macro-transformer, but must
    610349;;; then be imported for-syntax.
    611350(define-syntax bindable?
    612   (macro-rules (where)
     351  (syntax-rules (where)
    613352    ((_ pat (where . fenders))
    614      `(lambda (seq)
    615         (condition-case (bind ,pat (where ,@fenders) seq #t)
    616           ((exn bind) #f)
    617           ((exn range) #f))))
     353     (lambda (seq)
     354        (condition-case (bind pat seq (where . fenders) #t)
     355          ((exn sequence) #f))))
    618356    ((_ pat)
    619      `(bindable? ,pat (where)))))
     357     (bindable? pat (where)))))
    620358
    621359#|[
     
    634372]|#
    635373
    636 ;; helper macro for bind-define and bind-set!
    637 (define-syntax bind-def-set!
    638   (macro-rules _ (where)
    639     ((bind-def-set! pat (where . fenders) seq def?)
    640      (let ((sym? (lambda (p)
    641                    (and (symbol? p)
    642                         (not (eq? p _))))))
    643         (let ((aux (let copy ((pat pat))
     374;;; (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
     375;;; -------------------------------------------------------
     376;;; sets pattern variables of pat pat1 ... to corresponding sub-expressins of
     377;;; seq seq1 ..., provided the fenders are satisfied
     378(define-er-macro-transformer (bind-set! form rename compare?)
     379  (let ((pairs (reverse (chop (cdr form) 2)))
     380        (%_ (rename '_))
     381        (%let (rename 'let))
     382        (%list (rename 'list))
     383        (%where (rename 'where))
     384        (%bind (rename 'bind))
     385        (%set! (rename 'set!))
     386        (%seq (rename 'seq)))
     387    (let ((where-clause?
     388            (and (null? (cdar pairs))
     389                 (pair? (caar pairs))
     390                 (compare? (caaar pairs) %where))))
     391      (let ((where-clause (if where-clause?
     392                            (caar pairs)
     393                            `(,%where)))
     394            (pairs (if where-clause?
     395                     ;(reverse (cdr pairs))
     396                     (cdr pairs)
     397                     ;(reverse pairs))))
     398                     pairs)))
     399        (let ((pat (map car pairs))
     400              (seq `(,%list ,@(map cadr pairs)))
     401              (sym? (lambda (x)
     402                      (and (symbol? x)
     403                           (not (compare? x %_))))))
     404    (letrec (
     405      (pflatten (lambda (pls)
     406                  (cond
     407                    ((null? pls) pls)
     408                    ((pair? pls)
     409                     (append (pflatten (car pls))
     410                             (pflatten (cdr pls))))
     411                    (else (list pls)))))
     412      (filter (lambda (ok? lst)
     413                 (compress (map ok? lst) lst)))
     414      (reduce (lambda (pat)
     415                 (filter sym? (pflatten pat))))
     416      )
     417      (let ((aux (let copy ((pat pat))
     418                    (cond
     419                      ((sym? pat) (rename pat))
     420                      ((pair? pat)
     421                       (cons (copy (car pat)) (copy (cdr pat))))
     422                      (else pat))))
     423            (%where-clause
     424              (cons %where
     425                    (map (lambda (c)
     426                           (cons (rename (car c))
     427                                 (cdr c)))
     428                         (cdr where-clause)))))
     429        `(,%let ((,%seq ,seq))
     430           (,%bind ,aux ,%seq ,%where-clause
     431                   ,@(map (lambda (p a) `(,%set! ,p ,a))
     432                          (reduce pat)
     433                          (reduce aux))))
     434        )))))))
     435
     436;;; (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
     437;;; ---------------------------------------------------------
     438;;; destructures the sequences seq seq1 ... according to the patterns
     439;;; pat pat1 ...  and sets pattern variables with values corresponding
     440;;; to subexpressions of seq seq1 ..., provided the fenders are
     441;;; satisfied
     442(define-er-macro-transformer (bind-define form rename compare?)
     443  (let ((pairs (reverse (chop (cdr form) 2)))
     444        (%_ (rename '_))
     445        (%list (rename 'list))
     446        (%where (rename 'where))
     447        (%bind-set! (rename 'bind-set!))
     448        (%define (rename 'define))
     449        (%begin (rename 'begin)))
     450    (let ((where-clause?
     451            (and (null? (cdar pairs))
     452                 (pair? (caar pairs))
     453                 (compare? (caaar pairs) %where))))
     454      (let ((where-clause (if where-clause?
     455                            (caar pairs)
     456                            `(,%where)))
     457            (pairs (if where-clause?
     458                     ;(reverse (cdr pairs))
     459                     (cdr pairs)
     460                     ;(reverse pairs))))
     461                     pairs)))
     462        (let ((pat (map car pairs))
     463              (seq `(,%list ,@(map cadr pairs)))
     464              (sym? (lambda (x)
     465                      (and (symbol? x)
     466                           (not (compare? x %_))))))
     467    (letrec (
     468      (map-flatten (lambda (pls)
    644469                     (cond
    645                        ((sym? pat) (gensym))
    646                        ((pair? pat)
    647                         (cons (copy (car pat)) (copy (cdr pat))))
    648                        (else pat))))
    649               (flatten*
    650                 ; imported flatten doesn't work with pseudo-lists
    651                 (lambda (tree)
    652                   (let loop ((tree tree) (result '()))
    653                     (cond
    654                       ((pair? tree)
    655                        (loop (car tree) (loop (cdr tree) result)))
    656                       ((null? tree) result)
    657                       (else
    658                         (cons tree result))))))
    659               (filter
    660                 (lambda (ok? lst)
    661                   (compress (map ok? lst) lst))))
    662           (if def?
    663             `(if ((bindable? ,pat (where ,@fenders)) ,seq)
    664                (begin
    665                  ,@(map (lambda (p) `(define ,p ',p))
    666                         (filter sym? (flatten* pat)))
    667                  (bind ,aux ,seq
    668                    ,@(map (lambda (p a) `(set! ,p ,a))
    669                           (filter sym? (flatten* pat))
    670                           (filter sym? (flatten* aux)))))
    671                (signal-bind-exception 'bind-define
    672                                       "fenders not passed"
    673                                       ',seq
    674                                       ',pat
    675                                       '(where ,@fenders)))
    676             `(if ((bindable? ,pat (where ,@fenders)) ,seq)
    677                (bind ,aux ,seq
    678                  ,@(map (lambda (p a) `(set! ,p ,a))
    679                         (filter sym? (flatten* pat))
    680                         (filter sym? (flatten* aux))))
    681                (signal-bind-exception 'bind-set!
    682                                       "fenders not passed"
    683                                       ',seq
    684                                       ',pat
    685                                       '(where ,@fenders)))))))
    686     ))
    687 
    688 
    689 ;;; (bind-define pat (where fender ...) .. seq)
    690 ;;; -------------------------------------------
    691 ;;; destructures the sequence seq according to the pattern pat and sets
    692 ;;; pattern variables with values corresponding to subexpressions of
    693 ;;; seq, provided the fenders are satisfied
    694 (define-syntax bind-define
    695   (macro-rules (where)
    696     ((_ pat (where . fenders) seq)
    697      `(bind-def-set! ,pat (where ,@fenders) ,seq #t))
    698     ((_ pat seq)
    699      `(bind-def-set! ,pat (where) ,seq #t))))
    700 
    701 ;;; (bind-set! pat (where fender ...) .. seq)
    702 ;;; -----------------------------------------
    703 ;;; sets pattern variables of pat to corresponding sub-expressins of
    704 ;;; seq, provided the fenders are satisfied
    705 (define-syntax bind-set!
    706   (macro-rules (where)
    707     ((_ pat (where . fenders) seq)
    708      `(bind-def-set! ,pat (where ,@fenders) ,seq #f))
    709     ((_ pat seq)
    710      `(bind-def-set! ,pat (where) ,seq #f))))
     470                       ((null? pls) pls)
     471                       ((pair? pls)
     472                        (append (map-flatten (car pls))
     473                                (map-flatten (cdr pls))))
     474                       (else (list `(,%define ,pls #f))))))
     475      (filter (lambda (ok? lst)
     476                (compress (map ok? lst) lst)))
     477      )
     478      `(,%begin
     479         ,@(filter sym?
     480                   (map-flatten pat))
     481         (,%bind-set! ,pat ,seq ,where-clause))))))))
    711482
    712483#|[
     
    729500;;; combination of lambda and bind, one pattern argument
    730501(define-syntax bind-lambda
    731   (macro-rules (where)
     502  (syntax-rules (where)
    732503    ((_ pat (where . fenders) xpr . xprs)
    733      `(lambda (x) (bind ,pat (where ,@fenders) x ,xpr ,@xprs)))
     504     (lambda (x) (bind pat x (where . fenders) xpr . xprs)))
    734505    ((_ pat xpr . xprs)
    735      `(bind-lambda ,pat (where) ,xpr ,@xprs))))
     506     (bind-lambda pat (where) xpr . xprs))))
    736507
    737508;;; (bind-lambda* pat (where fender ...) .. xpr ....)
     
    739510;;; combination of lambda and bind, multiple pattern arguments
    740511(define-syntax bind-lambda*
    741   (macro-rules (where)
     512  (syntax-rules (where)
    742513    ((_ pat (where . fenders) xpr . xprs)
    743      `(lambda x (bind ,pat (where ,@fenders) x ,xpr ,@xprs)))
     514     (lambda x (bind pat x (where . fenders) xpr . xprs)))
    744515    ((_ pat xpr . xprs)
    745      `(bind-lambda* ,pat (where) ,xpr ,@xprs))))
     516     (bind-lambda* pat (where) xpr . xprs))))
    746517
    747518#|[
     
    769540;;; combination of lambda and bind-case, one pattern argument
    770541(define-syntax bind-case-lambda
    771   (macro-rules (where)
     542  (syntax-rules (where)
    772543    ((_ (pat (where . fenders) xpr . xprs))
    773      `(lambda (x)
    774         (bind-case x (,pat (where ,@fenders) ,xpr ,@xprs))))
     544     (lambda (x)
     545       (bind-case x (pat (where . fenders) xpr . xprs))))
    775546    ((_ (pat xpr . xprs))
    776      `(lambda (x)
    777         (bind-case x (,pat ,xpr ,@xprs))))
     547     (lambda (x)
     548       (bind-case x (pat xpr . xprs))))
    778549    ((_ clause . clauses)
    779      `(lambda (x)
    780         (bind-case x ,clause ,@clauses)))))
     550     (lambda (x)
     551       (bind-case x clause . clauses)))))
    781552
    782553;;; (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
     
    784555;;; combination of lambda and bind-case, multiple pattern arguments
    785556(define-syntax bind-case-lambda*
    786   (macro-rules (where)
     557  (syntax-rules (where)
    787558    ((_ (pat (where . fenders) xpr . xprs))
    788      `(lambda x
    789         (bind-case x (,pat (where ,@fenders) ,xpr ,@xprs))))
     559     (lambda x
     560       (bind-case x (pat (where . fenders) xpr . xprs))))
    790561    ((_ (pat xpr . xprs))
    791      `(lambda x
    792         (bind-case x (,pat ,xpr ,@xprs))))
     562     (lambda x
     563       (bind-case x (pat xpr . xprs))))
    793564    ((_ clause . clauses)
    794      `(lambda x
    795         (bind-case x ,clause ,@clauses)))))
    796 
    797 #|[
    798 The following macro, bind*, is a named version of bind. It takes an
     565     (lambda x
     566       (bind-case x clause . clauses)))))
     567
     568#|[
     569The following macro, bind-named, is a named version of bind. It takes an
    799570additional argument besides those of bind, which is bound to a
    800571recursive procedure, which can be called in bind's body. The pattern
     
    802573For example
    803574
    804   (bind* loop (x y) '(5 0)
     575  (bind-named loop (x y) '(5 0)
    805576    (if (zero? x)
    806577      (list x y)
     
    809580]|#
    810581
    811 ;;; (bind* name pat seq (where fender ...) .. xpr ....)
    812 ;;; ---------------------------------------------------
     582;;; (bind-named name pat seq (where fender ...) .. xpr ....)
     583;;; ---- ---------------------------------------------------
    813584;;; named version of bind
    814 (define-syntax bind*
    815   (macro-rules (where)
    816     ((_ name pat (where . fenders) seq xpr . xprs)
    817      `((letrec ((,name
    818                   (bind-lambda ,pat (where ,@fenders) ,xpr ,@xprs)))
    819          ,name)
    820        ,seq))
     585(define-syntax bind-named
     586  (syntax-rules (where)
     587    ((_ name pat seq (where . fenders) xpr . xprs)
     588     ((letrec ((name
     589                  (bind-lambda pat (where . fenders) xpr . xprs)))
     590         name)
     591       seq))
    821592    ((_ name pat seq xpr . xprs)
    822      `(bind* ,name ,pat (where) ,seq ,xpr ,@xprs))))
     593     (bind-named name pat seq (where) xpr . xprs))))
    823594
    824595#|[
    825596Now the implementation of a nested version of let, named and unnamed,
    826 is easy: Simply combine bind and bind*. For example
     597is easy: Simply combine bind and bind-named. For example
    827598
    828599  (bind-let (
     
    838609      (list a b)
    839610      (loop (list (sub1 a) (add1 b)))))
     611      ;(loop (list (list (sub1 a) (add1 b))))))
     612      ;version with bind-named
    840613  -> '(0 5)
    841614]|#
    842615
    843 ;;; (bind-let loop .. ((pat (where fender ...) .. seq) ...) xpr ....)
     616;;; (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
    844617;;; -----------------------------------------------------------------
    845618;;; nested version of let, named and unnamed
    846 (define-syntax bind-let
    847   (let ((last (lambda (lst)
    848                 (let loop ((lst lst))
    849                   (if (null? (cdr lst))
    850                     (car lst)
    851                     (loop (cdr lst))))))
    852         (extract-fenders
    853           (lambda (pairs)
    854             (apply append
    855                    (map cdadr
    856                         (compress
    857                           (map (lambda (pair)
    858                                  (= (length pair) 3))
    859                                pairs)
    860                           pairs))))))
    861     (macro-rules (where)
    862       ((_ loop () xpr . xprs)
    863        `(let ,loop () ,xpr ,@xprs))
    864       ((_ loop ((pat0 (where . fenders) seq0) . pat-seq-pairs) xpr . xprs)
    865        `(bind* ,loop
    866           ,(cons pat0 (map car pat-seq-pairs))
    867           (where ,@(append fenders
    868                            (extract-fenders pat-seq-pairs)))
    869           (list ,seq0 ,@(map last pat-seq-pairs))
    870           ,xpr ,@xprs))
    871       ((_ loop ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
    872        `(bind* ,loop
    873           ,(cons pat0 (map car pat-seq-pairs))
    874           (where ,@(extract-fenders pat-seq-pairs))
    875           (list ,seq0 ,@(map last pat-seq-pairs))
    876           ,xpr ,@xprs))
    877       ((_ () xpr . xprs)
    878        `(let () ,xpr ,@xprs))
    879       ((_ ((pat0 (where . fenders) seq0) . pat-seq-pairs) xpr . xprs)
    880        `(bind
    881           ,(cons pat0 (map car pat-seq-pairs))
    882           (where ,@(append fenders
    883                            (extract-fenders pat-seq-pairs)))
    884           (list ,seq0 ,@(map last pat-seq-pairs))
    885           ,xpr ,@xprs))
    886       ((_ ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
    887        `(bind
    888           ,(cons pat0 (map car pat-seq-pairs))
    889           (where ,@(extract-fenders pat-seq-pairs))
    890           (list ,seq0 ,@(map last pat-seq-pairs))
    891           ,xpr ,@xprs))
    892     )))
     619(define-er-macro-transformer (bind-let form rename compare?)
     620  (let ((named? (symbol? (cadr form))))
     621    (let ((name (if named? (cadr form) (gensym)))
     622          (binds (if named? (caddr form) (cadr form)))
     623          (xpr (if named? (cadddr form) (caddr form)))
     624          (xprs (if named? (cddddr form) (cdddr form))))
     625      (let ((pats (map car binds))
     626            (seqs (map cadr binds))
     627            (%list (rename 'list))
     628            (%bind (rename 'bind))
     629            ;(%bind-named (rename 'bind-named)))
     630            (%letrec (rename 'letrec))
     631            (%bind-lambda* (rename 'bind-lambda*)))
     632        (if named?
     633          `(,%letrec ((,name (,%bind-lambda* ,pats ,xpr ,@xprs)))
     634             (,name ,@seqs))
     635          ;`(,%bind-named ,name ,pats (,%list ,@seqs) ,xpr ,@xprs)
     636          `(,%bind ,pats (,%list ,@seqs) ,xpr ,@xprs))))))
    893637
    894638#|[
     
    904648]|#
    905649
    906 ;;; (bind-let* ((pat (where fender ...) .. seq) ...) xpr ....)
     650;;; (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
    907651;;; ----------------------------------------------------------
    908652;;; sequential version of bind-let
    909653(define-syntax bind-let*
    910   (macro-rules (where)
     654  (syntax-rules (where)
    911655    ((_ () xpr . xprs)
    912      `(let () ,xpr ,@xprs))
    913     ((_ ((pat (where . fenders) seq) . pat-seq-pairs) xpr . xprs)
    914      `(bind ,pat (where ,@fenders) ,seq
    915         (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))
    916     ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
    917      `(bind ,pat ,seq
    918         (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))))
    919 
    920 #|[
    921 And here is the recursive version of bind, which is used in bind-letrec.
    922 
    923   (bindrec ((o?) e?)
    924     (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    925           (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    926     (list (o? 95) (e? 95)))
    927   -> '(#t #f)
    928 ]|#
    929 
    930 ;;; (bindrec pat (where fender ...) .. seq xpr ....)
    931 ;;; ------------------------------------------------
    932 ;;; recursive version of bind
    933 (define-syntax bindrec
    934   (macro-rules (where)
    935     ((_ pat (where . fenders) seq xpr . xprs)
    936      `(if ((bindable? ,pat) ,seq)
    937         (bind ,pat ',pat
    938           ; bind pattern variables to auxiliary values
    939           ; so that they are in scope
    940           (bind-set! ,pat (where ,@fenders) ,seq)
    941           ; set! the real values
    942           ,xpr ,@xprs)
    943         (signal-bind-exception 'bindrec
    944                                "fenders not passed"
    945                                ',seq
    946                                ',pat
    947                                '(where ,@fenders))))
    948     ((_ pat seq xpr . xprs)
    949      `(bindrec ,pat (where) ,seq ,xpr ,@xprs))))
     656     (begin xpr . xprs))
     657    ((_ ((pat seq)) (where . fenders) xpr . xprs)
     658     (bind pat seq (where . fenders) xpr . xprs))
     659    ((_ ((pat seq)) xpr . xprs)
     660     (bind pat seq xpr . xprs))
     661    ((_ ((pat seq) binds ...) (where . fenders) xpr . xprs)
     662     (bind pat seq (bind-let* (binds ...)
     663                     (where . fenders) xpr . xprs)))
     664    ((_ ((pat seq) binds ...) xpr . xprs)
     665     (bind pat seq
     666       (bind-let* (binds ...) xpr . xprs)))))
    950667
    951668#|[
     
    961678]|#
    962679
    963 ;;; (bind-letrec ((pat (where fender ...) .. seq) ...) xpr ....)
     680;;; (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
    964681;;; ------------------------------------------------------------
    965682;;; recursive version of bind-let
    966 (define-syntax bind-letrec
    967   (let ((last (lambda (lst)
    968                 (let loop ((lst lst))
    969                   (if (null? (cdr lst))
    970                     (car lst)
    971                     (loop (cdr lst))))))
    972         (extract-fenders
    973           (lambda (pairs)
    974             (apply append
    975                    (map cdadr
    976                         (compress
    977                           (map (lambda (pair)
    978                                  (= (length pair) 3))
    979                                pairs)
    980                           pairs))))))
    981     (macro-rules (where)
    982       ((_ ((pat (where . fenders) seq) . pat-seq-pairs) xpr . xprs)
    983        `(bindrec ,(cons pat (map car pat-seq-pairs))
    984           (where ,@(append fenders
    985                            (extract-fenders pat-seq-pairs)))
    986           (list ,seq ,@(map last pat-seq-pairs))
    987           ,xpr ,@xprs))
    988       ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
    989        `(bindrec ,(cons pat (map car pat-seq-pairs))
    990           (where ,@(extract-fenders pat-seq-pairs))
    991           (list ,seq ,@(map last pat-seq-pairs))
    992           ,xpr ,@xprs))
    993       ((_ () xpr . xprs)
    994        `(let () ,xpr ,@xprs))
    995     )))
     683(define-er-macro-transformer (bind-letrec form rename compare?)
     684  (let ((binds (cadr form)) (xpr (caddr form)) (xprs (cdddr form)))
     685    (let ((pats (map car binds))
     686          (seqs (map cadr binds))
     687          (%list (rename 'list))
     688          (%bindrec (rename 'bindrec)))
     689      `(,%bindrec ,pats (,%list ,@seqs) ,xpr ,@xprs))))
    996690
    997691#|[
     
    1003697;;; captures the current continuation, binds it to cc and executes
    1004698;;; xpr .... in this context
    1005 (define-macro (bind/cc cc xpr . xprs)
    1006   `(call-with-current-continuation
    1007      (lambda (,cc) ,xpr ,@xprs)))
     699(define-syntax bind/cc
     700  (syntax-rules ()
     701    ((_ cc xpr . xprs)
     702     (call-with-current-continuation
     703       (lambda (cc) xpr . xprs)))))
    1008704
    1009705;;; (bindings sym ..)
     
    1012708(define bindings
    1013709  (symbol-dispatcher '(
     710    (bindings
     711      procedure:
     712      (bindings sym ..)
     713      "documentation procedure")
     714    (seq-db
     715      procedure:
     716      (seq-db)
     717      "shows the sequence database"
     718      (seq-db type ref: ref tail: tail maker: maker ra?: random-access?)
     719      "adds a new sequence type to the database where the keywords"
     720      "name arguments being accessed as seq-ref and seq-tail seq-maker"
     721      "and seq-random-access? respectively")
    1014722    (bind
    1015723      macro:
    1016       (bind pat (where fender ...) .. seq xpr ....)
     724      (bind pat seq (where fender ...) .. xpr ....)
    1017725      "a variant of Common Lisp's destructuring-bind")
    1018726    (bind-case
     
    1027735    (bind-set!
    1028736      macro:
    1029       (bind-set! pat (where fender ...) .. seq)
    1030       "sets multiple variables by destructuring its sequence argument")
     737      (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
     738      "sets multiple variables by destructuring its sequence arguments")
    1031739    (bind-define
    1032740      macro:
    1033       (bind-define pat (where fender ...) .. seq)
    1034       "defines multiple variables by destructuring its sequence argument")
     741      (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
     742      "defines multiple variables by destructuring its sequence arguments")
    1035743    (bind-lambda
    1036744      macro:
     
    1041749      (bind-lambda* pat (where fender ...) .. xpr ....)
    1042750      "combination of lambda and bind, multiple pattern arguments")
    1043     (bind*
    1044       macro:
    1045       (bind* loop pat (where fender ...) .. seq xpr ....)
     751    (bind-named
     752      macro:
     753      (bind-named loop pat (where fender ...) .. seq xpr ....)
    1046754      "named version of bind")
    1047755    (bind-let
    1048756      macro:
    1049       (bind-let loop .. ((pat (where fender ...) .. seq) ...) xpr ....)
     757      (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
    1050758      "nested version of let, named and unnamed")
    1051759    (bind-let*
    1052760      macro:
    1053       (bind-let* ((pat (where fender ...) .. seq) ...) xpr ....)
     761      (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
    1054762      "nested version of let*")
    1055763    (bindrec
    1056764      macro:
    1057       (bindrec pat (where fender ...) .. seq xpr ....)
     765      (bindrec pat seq (where fender ...) .. xpr ....)
    1058766      "recursive version of bind")
    1059767    (bind-letrec
    1060768      macro:
    1061       (bind-letrec ((pat (where fender ...) .. seq) ...) xpr ....)
     769      (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
    1062770      "recursive version of bind-let")
    1063771    (bind-case-lambda
     
    1074782      "binds cc to the current contiunation"
    1075783      "and execute xpr ... in this context")
    1076     (bind-exception
    1077       procedure:
    1078       (bind-exception loc msg arg ...)
    1079       "generates a composite condition with location symbol, string message"
    1080       "and passible additional arguments arg ...")
    1081     (signal-bind-exception
    1082       procedure:
    1083       (bind-exception loc msg arg ...)
    1084       "signals a composite condition with location symbol, string message"
    1085       "and passible additional arguments arg ...")
    1086     (bind-exception-handler
    1087       procedure:
    1088       (bind-exception-handler var)
    1089       "to be passed to the parameter current-exception-handler")
    1090     (bind-table-show
    1091       procedure:
    1092       (bind-table-show)
    1093       "pretty prints the sequence table")
    1094     (bind-table-add!
    1095       procedure:
    1096       (bind-table-add! type? len ref tail)
    1097       "adds a new table item to the front of the sequence table")
    1098     (list-of
    1099       procedure:
    1100       (list-of ok? ...)
    1101       "generates a list predicate which checks all of its arguments")
    1102     (pseudo-list-of
    1103       procedure:
    1104       (pseudo-list-of ok? ...)
    1105       "generates a pseudo-list predicate which checks all of its arguments")
    1106     (vector-of
    1107       procedure:
    1108       (vector-of ok? ...)
    1109       "generates a vector predicate which checks all of its arguments")
    1110     (symbol-dispatcher
    1111       procedure:
    1112       (symbol-dispatcher alist)
    1113       "generates a procedure of zero or one argument showing all"
    1114       "cars or the cdr or the alist item with symbol as car")
    1115784    )))
    1116   ) ; bind-functor
    1117 
    1118 (module bindings = bind-functor
    1119   (import scheme
    1120           (only bind-sequences
    1121                 bind-seq-length bind-seq-ref bind-seq-tail))
    1122   (define len bind-seq-length)
    1123   (define ref bind-seq-ref)
    1124   (define tail bind-seq-tail))
    1125 
    1126 (module list-bindings = bind-functor
    1127   (import scheme)
    1128   (define len length)
    1129   (define ref list-ref)
    1130   (define tail list-tail))
    1131 
    1132 ;(use sequences)
    1133 ;;; uses matchable, which bindings can replace
    1134 ;(module sequence-bindings = bind-functor
    1135 ;  (import scheme sequences)
    1136 ;  (define len size)
    1137 ;  (define ref elt)
    1138 ;  (define tail sub))
     785  ) ; bindings
     786
     787;(import bindings)
  • release/4/bindings/tags/6.0/bindings.setup

    r33088 r33533  
    22
    33(compile -O3 -d1 -s bindings.scm -J)
    4 (compile -O3 -d0 -s bind-sequences.import.scm)
    5 (compile -O3 -d0 -s bind-functor.import.scm)
    6 (compile -O3 -d0 -s _bindings.import.scm)
    74(compile -O3 -d0 -s bindings.import.scm)
    8 (compile -O3 -d0 -s _list-bindings.import.scm)
    9 (compile -O3 -d0 -s list-bindings.import.scm)
    105
    116(install-extension
    127 'bindings
    13  '("bindings.so" "bind-sequences.import.so"
    14    "bind-functor.import.so" "_bindings.import.so" "bindings.import.so"
    15    "_list-bindings.import.so" "list-bindings.import.so")
    16  '((version "5.0")))
     8 '("bindings.so" "bindings.import.so")
     9 '((version "6.0")))
  • release/4/bindings/tags/6.0/tests/run.scm

    r33088 r33533  
    33;;;; ju (at) jugilo (dot) de
    44
    5 (require-library bindings arrays simple-tests)
     5(require-library bindings arrays basic-sequences simple-tests)
    66
    77(import simple-tests
    88        bindings
    9         (prefix list-bindings list-)
    10         (only arrays array array? array-length array-item array-drop
    11               array->list)
    12         )
    13 
    14 (define-test (bind?)
     9        (only basic-sequences seq-db)
     10        (only arrays array array? array-ref array-tail array->list)
     11        )
     12
     13(define-test (binds?)
    1514  (check
    1615    (= (bind a 1 a) 1)
    17     (equal? (bind (a b) (where (a odd?)) '(1 2) (list a b)) '(1 2))
    18     (equal?
    19       (list-bind (x y z w) '(1 2 3 4) (list x y z w))
    20       '(1 2 3 4))
    21     (equal?
    22       (list-bind (_ y z _) '(1 2 3 4) (list y z))
    23       '(2 3))
     16    (equal? (bind (a b) '(1 2) (where (a odd?)) (list a b)) '(1 2))
    2417    (equal?
    2518      (bind (x . y) '#(1 2 3 4) (list x y))
     
    4235      (bind (x (y _ . _) . _) '(1 #(2 3 4) 5 6) (list x y))
    4336      '(1 2))
    44     (equal? (list-bind (x (y (z . u) . v) . w)
    45               (where (z odd?))
    46               '(1 (2 (3 4) 5) 6)
    47               (list x y z u v w))
    48             '(1 2 3 (4) (5) (6)))
    49     (condition-case
    50       (list-bind (x (y (z . u) . v) . w)
    51         (where (z even?))
    52         '(1 (2 (3 4) 5) 6)
    53         (list x y z u v w))
    54       ((exn bind) #t))
    5537    (equal?
    5638      (bind (x (y (z . u)) v . w) (vector 1 (list 2 (cons #f #f)) 5 6)
     
    6749      '(1 2 3 4 5 #(6)))
    6850    (equal?
    69       (bind* loop (x (a . b) y) (where (x integer?)) '(5 #(1) 0)
     51      (bind-named loop (x (a . b) y) '(5 #(1) 0) (where (x integer?))
    7052        (if (zero? x)
    7153          (list x a b y)
     
    7355      '(0 1 (1 1 1 1 1 . #()) 5))
    7456    (equal?
    75       (bind* loop (x y) (where (x integer?)) #(5 0)
     57      (bind-named loop (x y) #(5 0) (where (x integer?))
    7658        (if (zero? x)
    7759          (vector x y)
     
    8567      (condition-case
    8668        (bind (#f . ys) '(#t 2 3) ys)
    87         ((exn bind) #f)))
     69        ((exn sequence) #f)))
    8870    (bind #f #f #t)
    8971    (not
    9072      (condition-case
    9173        (bind #f #t #t)
    92         ((exn bind) #f)))
    93     (= (list-bind (x . #f) '(1 . #f) x) 1)
     74        ((exn sequence) #f)))
    9475    (not
    9576      (condition-case
    9677        (bind (x . #f) '(1 . #t) x)
    97         ((exn bind) #f)))
     78        ((exn sequence) #f)))
    9879    (equal?
    9980      (bind (x (y . #f)) '(1 (2 . #f)) (list x y))
     
    10283      (condition-case
    10384        (bind (x (y . #f)) '(1 (2 . #t)) (list x y))
    104         ((exn bind) #f)))
     85        ((exn sequence) #f)))
    10586    (equal?
    10687      (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y))
     
    10990      (condition-case
    11091        (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y))
    111         ((exn bind) #f)))
     92        ((exn sequence) #f)))
    11293    (not
    11394      (condition-case
    11495        (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y))
    115         ((exn bind) #f)))
     96        ((exn sequence) #f)))
    11697    (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))
    11798
    11899    "ADD ARRAYS TO GENERIC SEQUENCES"
    119     (bind-table-add!  array?
    120                       array-length
    121                       (lambda (seq k)
    122                         (array-item k seq))
    123                       (lambda (seq k)
    124                         (array-drop k seq)))
     100    (seq-db array? ref: array-ref tail: array-tail maker: array ra?: #t)
    125101    (equal?
    126102      (bind (x y z) (array 1 2 3) (list x y z))
     
    136112    ))
    137113
    138 (define-test (predicate?)
     114(define-test (predicates?)
    139115  (check
    140116    (not ((bindable? (x)) '(name 1)))
     
    142118    ((bindable? (_ x)) '(name 1))
    143119    (not ((bindable? (_ x)) '(name 1 2)))
    144     (not ((list-bindable? (_ x y) (where (x symbol?))) '(name 1 2)))
    145120    ((bindable? (a b) (where (a odd?))) '#(1 2))
    146121    (not ((bindable? (x (y z)) (where (y char-alphabetic?))) '(1 "23")))
     
    151126    ))
    152127
    153 (define-test (case?)
    154   (check
    155     (not (bind-case '#() (() #f)))
    156     (equal? (bind-case '#(2 2)
     128(define-test (cases?)
     129  (check
     130    (not (bind-case #() (() #f)))
     131    (equal? (bind-case #(2 2)
    157132              ((a b) (where (a even?) (b odd?)) (print 'even-odd a b))
    158133              ((a b) (where (a odd?) (b even?)) (print 'odd-even a b))
     
    183158              ((x y) (list x y)))
    184159            '(1 #\2 #\3))
    185     (equal? (list-bind-case '(1 (2 3))
    186               ((x (y z)) (list x y z))
    187               ((x (y . z)) (list x y z))
    188               ((x y) (list x y)))
    189             '(1 2 3))
    190160    (equal? (bind-case '(1 "2 3") ;
    191161              ((x (y . z)) (list x y z))
     
    198168              ((x (y z)) (list x y z)))
    199169            '(1 2 #(3)))
    200     (equal? (list-bind-case '(1 (2 3))
    201               ((x (y . z)) (list x y z))
    202               ((x y) (list x y))
    203               ((x (y z)) (list x y z)))
    204             '(1 2 (3)))
    205170    (equal? (bind-case '(1 (2 3))
    206171              ((x y) (list x y))
     
    208173              ((x (y z)) (list x y z)))
    209174            '(1 (2 3)))
    210     (equal? (list-bind-case '(1 (2 . 3))
    211               ((x (y . z)) (list x y z))
    212               ((x (y z)) (list x y z)))
    213             '(1 2 3))
    214175    (equal? (bind-case '(1 (2 . 3))
    215176              ((x y) (list x y))
     
    228189    (define (my-map fn lst)
    229190      (let loop ((lst lst) (result '()))
    230         (list-bind-case lst
     191        (bind-case lst
    231192          (() (reverse result))
    232193          ((x . xs)
     
    294255      '#(2 3 4 5))
    295256    (equal?
    296       ((list-bind-case-lambda
     257      ((bind-case-lambda
    297258         ((e . f) (where (e zero?)) e)
    298259         ((a (b . #f) . d) (list a b d))
     
    301262      '(1 2 (4 5)))
    302263    (equal?
    303       ((list-bind-case-lambda
     264      ((bind-case-lambda
    304265         ((e . f) (where (e zero?)) e)
    305266         ((a (b . #f) . d) (list a b d))
     
    312273              ((a (b . #f) . d) (list a b d)))
    313274            '(1 (2 . #t) 4 5))
    314            ((exn bind) #f)))
     275           ((exn sequence) #f)))
    315276    (equal?
    316277      ((bind-case-lambda
     
    350311    (equal?
    351312      (bind-let (
    352         ((x y (z . w)) (where (x number?)) '(1 2 #(3 4 5)))
    353         )
    354         (list x y z w))
    355       '(1 2 3 #(4 5)))
    356     (equal?
    357       (bind-let (
    358313        (((x y) z) '(#(1 2) 3))
    359         (u (where (u integer?)) (+ 2 2))
    360         ((v w) '#(5 6))
    361         )
     314        (u (+ 2 2))
     315        ((v w) #(5 6))
     316        )
     317        (where (u integer?))
    362318        (list x y z u v w))
    363319      '(1 2 3 4 5 6))
    364320    (equal?
    365       (bind* loop (a b) '(5 0)
     321      (bind-named loop (a b) '(5 0)
    366322        (if (zero? a)
    367323          (list a b)
     
    369325      '(0 5))
    370326    (equal?
    371       (list-bind-let loop (
    372         ((a b) (where (a integer?))'(5 0))
    373         )
     327      (bind-let loop (
     328        ((a b) '(5 0))
     329        )
     330        (where (a integer?))
    374331        (if (zero? a)
    375332          (list a b)
    376           (loop (list (list (- a 1) (+ b 1))))))
     333          (loop (list (- a 1) (+ b 1)))))
    377334      '(0 5))
    378335    (equal?
    379336      (bind-let loop (
    380         ((x . y) (where (x integer?) (y (list-of integer?))) '(1 2 3))
    381         ((z) (where (z integer?)) #(10))
    382         )
     337        ((x . y) '(1 2 3))
     338        ((z) #(10))
     339        )
     340        (where (x integer?) (y (list-of? integer?)) (z integer?))
    383341        (if (zero? z)
    384342          (list x y z)
    385           (loop (list (cons (+ x 1) (map add1 y)) (list (- z 1))))))
     343          (loop (cons (+ x 1) (map add1 y)) (list (- z 1)))))
    386344      '(11 (12 13) 0))
    387345    (equal?
    388346      (bind-let* (
    389347        (((x y) z) '(#(1 2) 3))
    390         (u (where (u integer?)) (+ 1 2 x))
     348        (u (+ 1 2 x))
    391349        ((v w) (list (+ z 2) 6))
    392350        )
     351        (where (u integer?))
    393352        (list x y z u v w))
    394353      '(1 2 3 4 5 6))
    395354    (equal?
    396       (bindrec ((o?) e?) (where (o? procedure?) (e? procedure?))
    397         (vector (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    398                 (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     355      (bindrec ((o?) e?)
     356               (vector
     357                 (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     358                 (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     359        (where (o? procedure?) (e? procedure?))
    399360        (list (o? 95) (e? 95)))
    400361      '(#t #f))
     
    402363      (bind-letrec (
    403364        ((o? (e?))
    404          (where (o? procedure?) (e? procedure?))
    405          (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
    406                (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    407         )
     365         (list
     366           (lambda (m) (if (zero? m) #f (e? (- m 1))))
     367           (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
     368        )
     369        (where (o? procedure?) (e? procedure?))
    408370        (list (o? 95) (e? 95)))
    409371      '(#t #f))
     
    413375  (check
    414376    (equal?
    415       (let ((stack #f) (push! #f) (pop! #f))
     377      (let ((x #f) (y #f) (z #f))
     378        (bind-set! (x (y . z))
     379          '(1 #(2 3 3)))
     380        (list x y z))
     381      '(1 2 #(3 3)))
     382    (equal?
     383      (let ((x #f) (y #f) (z #f))
     384        (bind-set! (x #f _ (y _ . z))
     385          '(1 #f 10 #(2 30 3 3)))
     386        (list x y z))
     387      '(1 2 #(3 3)))
     388    (equal?
     389      (let ((x #f) (y #f) (z #f))
     390        (bind-set! x 1 y 2 z 3)
     391        (list x y z))
     392      '(1 2 3))
     393    (equal?
     394      (let ((x #f) (y #f) (z #f) (u #f) (v #f))
     395        (bind-set!
     396          (x (y . z))
     397          '(1 #(2 3 3))
     398          (u (v))
     399          '(10 (20))
     400          (where (x integer?) (u number?)))
     401        (list x y z u v))
     402      '(1 2 #(3 3) 10 20))
     403    (equal?
     404      (let ((x #f) (y #f) (z #f))
     405        (bind-set! (x (y . z))
     406          '(1 #(2 3 3))
     407          (where (x integer?)))
     408        (list x y z))
     409      '(1 2 #(3 3)))
     410    (equal?
     411      (begin
     412        (define stack #f) (define push! #f) (define pop! #f)
    416413        (bind-set! (stack (push! pop!))
    417414          (list
     
    419416            (vector
    420417              (lambda (xpr) (set! stack (cons xpr stack)))
    421               (lambda () (set! stack (cdr stack))))))
     418              (lambda () (set! stack (cdr stack)))))
     419          (where (push! procedure?) (pop! procedure?)))
    422420        (push! 1)
    423421        (push! 0)
     
    425423      '(0 1))
    426424    (equal?
    427       (let ((x #f) (y #f) (z #f))
    428         (bind-set! (x (y . z))
    429           (where (x integer?))
    430           '(1 #(2 3 3)))
    431         (list x y z))
    432       '(1 2 #(3 3)))
    433     (equal?
    434       (begin
    435         (list-bind-define (plus5 times5)
     425      (begin
     426        (bind-define (plus5 times5)
    436427          (let ((a 5))
    437428            (list
     
    442433    (equal?
    443434      (begin
     435        (bind-define (x . y) '(1 . 2) ((z)) '((3)) (where (x integer?)))
     436        (list x y z))
     437      '(1 2 3))
     438    (equal?
     439      (begin
     440        (bind-define (x _ . y) '(1 10 . 2) ((z)) '((3)) (where (x integer?)))
     441        (list x y z))
     442      '(1 2 3))
     443    (equal?
     444      (begin
     445        (bind-define (x #f . y) '(1 #f . 2) ((z)) '((3)))
     446        (list x y z))
     447      '(1 2 3))
     448    (equal?
     449      (begin
     450        (bind-define x 1 y 2 z 3 (where (x integer?)))
     451        (list x y z))
     452      '(1 2 3))
     453    (equal?
     454      (begin
    444455        (bind-define (push top pop)
    445           (where (push procedure?)
    446                  (top procedure?)
    447                  (pop procedure?))
    448456          (let ((lst '()))
    449457            (vector
    450458              (lambda (xpr) (set! lst (cons xpr lst)))
    451459              (lambda () (car lst))
    452               (lambda () (set! lst (cdr lst))))))
     460              (lambda () (set! lst (cdr lst)))))
     461          (where (push procedure?)
     462                 (top procedure?)
     463                 (pop procedure?)))
    453464        (push 0)
    454465        (push 1)
     
    464475      (begin
    465476        (bind-define (x (#f y (z #t)))
    466           (where (x integer?))
    467           (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
     477          (list 1 (vector (odd? 2) 3 (list 4 (odd?  5))))
     478          (where (x integer?)))
    468479        (list x y z))
    469480      '(1 3 4))
     
    471482
    472483(compound-test (BINDINGS)
    473   (bind?)
    474   (predicate?)
    475   (case?)
     484  (binds?)
     485  (predicates?)
     486  (cases?)
    476487  (lambdas?)
    477488  (lets?)
  • release/4/bindings/trunk/bindings.meta

    r32974 r33533  
    44 (category lang-exts)
    55 (license "BSD")
    6  (depends procedural-macros)
     6 (depends simple-exceptions basic-sequences)
    77 (test-depends simple-tests arrays)
    88 (author "Juergen Lorenz")
  • release/4/bindings/trunk/bindings.scm

    r33088 r33533  
    11; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
    22;
    3 ; Copyright (c) 2013-2015, Juergen Lorenz
     3; Copyright (c) 2013-2016, Juergen Lorenz
    44; All rights reserved.
    55;
     
    3131; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    3232
    33 #|[
    34 The fundamental binding-construct, bind, is patterned after Paul Graham's
    35 dbind, cf. "On Lisp", p. 232.
    36 In Chicken, dbind for lists could look as follows
    37 
    38   (define-syntax dbind
    39     (ir-macro-transformer
    40       (lambda (form inject compare?)
    41         (letrec (
    42           (mappend
    43             (lambda (fn lists)
    44               (apply append (map fn lists))))
    45           (destruc
    46             (lambda (pat seq)
    47               (let loop ((pat pat) (seq seq) (n 0))
    48                 (if (pair? pat)
    49                   (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
    50                     (if (symbol? p)
    51                       (cons `(,p (list-ref ,seq ,n)) recu)
    52                       (let ((g (gensym)))
    53                         (cons (cons `(,g (list-ref ,seq ,n))
    54                                     (loop p g 0))
    55                               recu))))
    56                   (if (null? pat)
    57                     '()
    58                     `((,pat (list-tail ,seq ,n))))))))
    59           (dbind-ex
    60             (lambda (binds body)
    61               (if (null? binds)
    62                 `(begin ,@body)
    63                 `(let ,(map (lambda (b) (if (pair? (car b)) (car b) b))
    64                             binds)
    65                    ,(dbind-ex
    66                       (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
    67                                binds)
    68                       body)))))
    69           )         
    70           (let ((pat (cadr form))
    71                 (seq (caddr form))
    72                 (body (cdddr form))
    73                 (gseq 'seq))
    74             `(let ((,gseq ,seq))
    75                ,(dbind-ex (destruc pat gseq) body)))))))
    76 
    77 This code works as follows: First, destruc traverses the pattern and
    78 groups each symbol with some list accessing code, using gensyms to step
    79 down the pattern while grouping the gensym bound object with all pairs
    80 depending on this gensym. So, for example,
    81 
    82   (destruc '(a (b . c) . d) 'seq)
    83 
    84 will result in
    85 
    86   ((a (list-ref seq 0))
    87    ((#:g (list-ref seq 1)) (b (list-ref #:g 0)) (c (list-tail #:g 1)))
    88    (d (list-tail seq 2)))
    89 
    90 This tree is then transformed via dbind-ex into a nested let
    91 
    92   (let ((a (list-ref seq 0))
    93         (#:g (list-ref seq 1))
    94         (d (list-tail seq 2)))
    95     (let ((b (list-ref #:g 0))
    96           (c (list-tail #:g 1)))
    97       body))
    98  
    99 Note, that the destructuring procedures are local to this macro. This is
    100 necessary in Chicken for the macro to work, in particular in compiled
    101 code, unless you import them for-syntax. But since they are of no
    102 interest outside of the macro, local procedrues are preferable.
    103 
    104 Note further, that ir-macro-transformer does all the necessary renaming
    105 transparently behind the scene, even if the helpers where defined in
    106 another module. In particular, gseq needn't be a gensym.
    107 
    108 And note, that Graham's code didn't check for seq's length, i.e.
    109 (dbind (a b) '(1 2 3) (list a b) would happily return '(1 2).
    110 
    111 Graham's original code works on the sequence datatype, so vectors and
    112 strings are destructured as well. Sequences don't exist in Scheme,
    113 unless you import-for-syntax Felix' sequences egg. To make this module
    114 self-contained, I prefer to supply access-routines closed over a table,
    115 which provides sequence versions of list-ref and list-tail, the only
    116 sequence routines used by destruc above, as well as a sequence version
    117 of length, which is needed to do the length checks.
    118 
    119 There are some features, which I would like to have and which are
    120 implemented as well. First wildcards, represented by the underscore
    121 symbol. It matches everything, but binds nothing. So it can appear
    122 multiple times in the same macro. Wildcard symbols are simply not
    123 collected in the destruc routine.
    124 
    125 Second, non-symbol literals, which don't bind anything, of course, but
    126 match only themselves. This and the length checks are treated simply by
    127 pairing them as well with check-routines in destruc but separating the
    128 pairs with leading symbol from those with leading nil or literal in
    129 dbind-ex. The former are bound with lets as in Graham's code, the
    130 latter's cadrs being evaluated before the recursive call to dbind-ex.
    131 
    132 The last feature missing is fenders, which is important in particular
    133 for bind-case and can easily be implemented with a where clause: A
    134 pattern matches successfully if only each pattern variable can be bound
    135 and the where clause is satisfied. If the where clause doesn't pass, the
    136 next pattern is tried in bind-case or a bind-exception is signalled in
    137 bind.
    138 
    139 ]|#
    140 
    141 (require-library procedural-macros)
    142 
    143 (module bind-sequences
    144   (bind-table-show bind-table-add! range-exception
    145    bind-seq-length bind-seq-ref bind-seq-tail
    146    symbol-dispatcher list-of pseudo-list-of vector-of bind-sequences)
     33
     34#|[
     35
     36The fundamental macro defined in this library is bind. It's like
     37destructuring-bind in Common Lisp and dbind in Graham's classic On Lisp,
     38but with some extensions, in particular, wildcards, non-symbol literals
     39and fenders.
     40
     41The syntax is as follows
     42
     43  (bind pat seq [(where . fenders)] . body)
     44
     45It destructures the seq argument according to the pat argument, binds
     46pattern variables to corresponding sequence items and executes body in
     47this context. For example
     48
     49  (bind (x (y z) . w) '(1 #(2 3) 4 5) (where (y even?)) (list x y z w))
     50
     51will return '(1 2 3 (4 5)).
     52
     53(Note that the position of the optional fenders, supplied in a where
     54clause, has changed again in this version: It's now always on top of the body.
     55This simplyfies implementation and usage of the library).
     56
     57This version of the library is a complete rewrite. The code no longer
     58uses Graham's dbind implementation. Instead, a direct implementation of
     59bind is given, which doesn't need gensyms. The internal destructure
     60routine transforms the pattern and sequence arguments into three lists,
     61pairs, literals and tails. Pairs is a list of pattern-variable and
     62corresponding sequence-accesscode pairs to be used in a let at runtime,
     63literals and tails check for equality of literals and their
     64corresponding sequence values, and the emptyness of sequence tails
     65corresponding to null patterns respectively. So, contrary to Graham's
     66dbind, an exception is raised if the lengths of a pattern and its
     67corresponding sequence don't match. Fenders are supplied in a where
     68clause at the very beginning of the macro body: A list of
     69pattern-variable predicates pairs is internally transformed into a list
     70of predicate calls.
     71
     72Sequences are either lists, psuedolists, vectors or strings by default.
     73The sequence operators needed are seq-ref, seq-tail and seq-null? with the same
     74syntax as the likely named list routines.  But there is a procedure, seq-db,
     75which allows to add a pair consisting of a type predicate and a vector
     76containing the needed operators to a database. All these are implemented
     77in the basic-sequences egg, on which this version of the library
     78depends.  The database routine, seq-db, is reexported from there.
     79
     80]|#
     81
     82(require-library basic-sequences simple-exceptions)
     83
     84(module bindings
     85  (bind bind-case bind-lambda bind-lambda* bind-case-lambda
     86   bind-case-lambda* bind-named bind-let bind-let* bind-letrec bindrec
     87   bindable? bind-define bind-set! bind/cc bindings)
    14788
    14889  (import scheme
    149           (only data-structures conjoin list-of?)
    150           (only chicken
    151                 case-lambda define-values
    152                 signal make-property-condition make-composite-condition
    153                 error print subvector))
    154 
    155 #|[
    156 The following three routines maintain the lookup table for the needed
    157 sequence primitives. Instead of bind-table-lookup the three sequence
    158 primitives below are exported.
    159 If you prefer, you can use the sequence primitives size, elt and sub of
    160 the sequences egg, provided you rename them bind-seq-length,
    161 bind-seq-ref and bind-seq-tail respectively.
    162 ]|#
    163 
    164 (define (range-exception loc msg . args)
    165   (make-composite-condition
    166     (make-property-condition 'exn
    167       'location loc
    168       'message msg
    169       'arguments (apply list args))
    170     (make-property-condition 'range)))
    171 
    172 ;;; (bind-table-lookup obj)
    173 ;;; -----------------------
    174 ;;; returns an association list of predicates and associated vectors
    175 ;;; with length, ref and tail primitives
    176 ;;;
    177 ;;; (bind-table-show)
    178 ;;; -----------------
    179 ;;; prints the contents of the table
    180 ;;;
    181 ;;; (bind-table-add! type? len ref tail)
    182 ;;; ------------------------------------
    183 ;;; adds a new list to the top of the table
    184 (define-values (bind-table-lookup bind-table-show bind-table-add!)
    185   (let (
    186     (tbl
    187       (list (cons pair?
    188                   (vector
    189                     (lambda (obj)
    190                       (let loop ((obj obj) (len 0))
    191                         (if (pair? obj)
    192                           (loop (cdr obj) (+ len 1))
    193                           len)))
    194                     list-ref
    195                     list-tail))
    196             (cons vector?
    197                   (vector vector-length vector-ref subvector))
    198             (cons string?
    199                   (vector string-length string-ref substring))
    200             ;; atoms catch all
    201             (cons (lambda (obj) (not (pair? obj)))
    202                   (vector
    203                     (lambda (obj) 0) ; len
    204                     (lambda (obj pos) ; ref
    205                       (signal
    206                         (range-exception
    207                           'bind-table-lookup
    208                              "out of range"
    209                              obj
    210                              pos)))
    211                     (lambda (obj pos) ; tail
    212                       (if (zero? pos)
    213                         obj
    214                         (signal
    215                           (range-exception
    216                             'bind-table-lookup
    217                                "out of range"
    218                                obj))))))
    219             ))
    220     )
    221     (values
    222       (lambda (obj)
    223         (let loop ((tbl tbl))
    224           ;; note, that we have a catch-all predicate in the table
    225           (if ((caar tbl) obj)
    226             (cdar tbl)
    227             (loop (cdr tbl)))))
    228       (lambda () (print tbl))
    229       (lambda (type? len ref tail)
    230         (set! tbl (cons (cons type?
    231                               (vector len ref tail))
    232                         tbl))))
    233       ))
    234 
    235 ;;; (bind-seq-length seq)
    236 ;;; ---------------------
    237 ;;; returns the length of the sequence argument
    238 (define (bind-seq-length obj)
    239   ((vector-ref (bind-table-lookup obj) 0) obj))
    240 
    241 ;;; (bind-seq-ref seq pos)
    242 ;;; ----------------------
    243 ;;; returns the item of the sequence argument at index pos
    244 (define (bind-seq-ref obj pos)
    245   ((vector-ref (bind-table-lookup obj) 1) obj pos))
    246 
    247 ;;; (bind-seq-tail seq pos)
    248 ;;; -----------------------
    249 ;;; returns the tail of the sequence argument starting at index pos
    250 (define (bind-seq-tail obj pos)
    251   ((vector-ref (bind-table-lookup obj) 2) obj pos))
    252 
    253 #|[
    254 At last some helper functions, which sometimes make life easier
    255 ]|#
    256 
    257 ;;; (list-of ok? ....)
    258 ;;; ------------------
    259 ;;; returns a list predicate which checks all ok? arguments
    260 (define (list-of . oks?) (list-of? (apply conjoin oks?)))
    261 
    262 ;;; (pseudo-list-of ok? ....)
    263 ;;; ------------------
    264 ;;; returns a pseudo-list predicate which checks all ok? arguments
    265 (define (pseudo-list-of . oks?)
    266   (letrec
    267     ((pseudo-list-of?
    268        (lambda (ok?)
    269          (lambda (xpr)
    270            (or (ok? xpr)
    271                (and (pair? xpr)
    272                     (ok? (car xpr))
    273                     ((pseudo-list-of? ok?) (cdr xpr))))))))
    274     (pseudo-list-of? (apply conjoin oks?))))
    275 
    276 ;;; (vector-of ok? ....)
    277 ;;; --------------------
    278 ;;; returns a list predicate which checks all ok? arguments
    279 (define (vector-of . oks?)
    280   (let (
    281     (vector-of?
    282       (lambda (ok?)
    283         (lambda (vec)
    284           (and (vector? vec)
    285                (let loop ((n 0))
    286                  (cond
    287                    ((= n (vector-length vec))
    288                     #t)
    289                    ((ok? (vector-ref vec n))
    290                     (loop (+ n 1)))
    291                    (else #f)))))))
    292     )
    293     (vector-of? (apply conjoin oks?))))
    294 
    295 ;;; (symbol-dispatcher alist)
    296 ;;; -------------------------
    297 ;;; returns a procedure of zero or one argument, which shows all cars
    298 ;;; or the cdr of the alist item with car symbol
    299 (define (symbol-dispatcher alist)
    300   (case-lambda
    301     (()
    302      (map car alist))
    303     ((sym)
    304      (let ((pair (assq sym alist)))
    305        (if pair
    306          (for-each print (cdr pair))
    307          (error "Not in list"
    308                 sym
    309                 (map car alist)))))))
    310 
    311 (define bind-sequences
    312   (symbol-dispatcher '(
    313     (bind-seq-length
    314       procedure:
    315       (bind-seq-length seq)
    316       "redurns the length of a sequence")
    317     (bind-seq-ref
    318       procedure:
    319       (bind-seq-ref seq pos)
    320       "returns the item at position pos of a sequence")
    321     (bind-seq-tail
    322       procedure:
    323       (bind-seq-ref seq pos)
    324       "returns the tail starting at position pos of a sequence")
    325     (bind-table-show
    326       procedure:
    327       (bind-table-show)
    328       "pretty prints the sequence table")
    329     (bind-table-add!
    330       procedure:
    331       (bind-table-add! type? len ref tail)
    332       "adds a new table item to the front of the sequence table")
    333     (list-of
    334       procedure:
    335       (list-of ok? ...)
    336       "generates a list predicate which checks all of its arguments")
    337     (pseudo-list-of
    338       procedure:
    339       (pseudo-list-of ok? ...)
    340       "generates a pseudo-list predicate which checks all of its arguments")
    341     (vector-of
    342       procedure:
    343       (vector-of ok? ...)
    344       "generates a vector predicate which checks all of its arguments")
    345     (symbol-dispatcher
    346       procedure:
    347       (symbol-dispatcher alist)
    348       "generates a procedure of zero or one argument showing all"
    349       "cars or the cdr or the alist item with symbol as car")
    350     )))
    351 
    352 ) ; module bind-sequences
    353 
    354 ;(module bindings
    355 (functor (bind-functor (M (len ref tail)))
    356   (bind bind-case bind-lambda bind-lambda* bind-case-lambda
    357    bind-case-lambda* bind* bind-let bind-let* bind-letrec bindrec
    358    bindable? bind-define bind-set! bind/cc
    359    ;bind-exception-handler
    360    signal-bind-exception bind-exception
    361    bindings)
    362   (import scheme
    363           bind-sequences
    364           (only chicken case-lambda condition-case define-values
    365                 error subvector define-for-syntax
    366                 current-exception-handler condition-predicate
    367                 get-condition-property make-property-condition
    368                 make-composite-condition signal abort print)
    369           (only procedural-macros define-macro)
    370           M
     90          (only basic-sequences seq-ref seq-tail seq-null?
     91                seq-db seq-exception symbol-dispatcher)
     92          (only chicken condition-case receive error)
     93          (only simple-exceptions raise)
    37194          )
    372   (reexport (only bind-sequences
    373                   bind-table-add! bind-table-show
    374                   symbol-dispatcher list-of pseudo-list-of vector-of))
    375 
    376   (import-for-syntax
    377     (only procedural-macros macro-rules)
    378     (only data-structures compress))
    379 
    380 #|[
    381 Let's start with defining bind-exceptions, a corresponding exception-handler,
    382 and registering this handler
    383 ]|#
    384 
    385 ;;; (bind-exception loc msg arg ...)
    386 ;;; --------------------------------
    387 ;;; composite condition, to allow for (exn bind) in condition-case
    388 (define (bind-exception loc msg . args)
    389   (make-composite-condition
    390     (make-property-condition 'exn
    391       'location loc
    392       'message msg
    393       'arguments (apply list args))
    394     (make-property-condition 'bind)))
    395 
    396 ;;; (signal-bind-exception loc msg arg ...)
    397 ;;; ---------------------------------------
    398 ;;; signals a bind-exception, can be used instead of error
    399 (define (signal-bind-exception loc msg . args)
    400   (signal
    401     (apply bind-exception loc msg args)))
    402 
    403 ;;;; (bind-exception-handler var)
    404 ;;;; ----------------------------
    405 ;;;; exception-handler to be passed to the parameter
    406 ;;;; current-exception-handler
    407 ;(define bind-exception-handler
    408 ;  (let ((old-handler (current-exception-handler)))
    409 ;    (lambda (var)
    410 ;      (if ((condition-predicate 'bind) var)
    411 ;        (begin
    412 ;          (display "Bind error: ")
    413 ;          (print (get-condition-property var 'bind 'location))
    414 ;          (print (get-condition-property var 'bind 'message))
    415 ;          (for-each print (get-condition-property var 'bind 'arguments))
    416 ;          (abort (make-property-condition 'exn
    417 ;                   'message "exception-handler returned")))
    418 ;        (old-handler var)))))
    419 ;
    420 ;;;; set current-exception-handler
    421 ;(current-exception-handler bind-exception-handler)
     95  (import-for-syntax (only chicken receive)
     96                     (only data-structures chop))
     97
     98  (reexport (only basic-sequences seq-db))
     99 
     100;;; simple explicit-renaming  macros
     101;;; ---------------------------------
     102(define-syntax define-er-macro-transformer
     103  (syntax-rules ()
     104    ((_ (name form rename compare?) xpr . xprs)
     105     (define-syntax name
     106       (er-macro-transformer
     107         (lambda (form rename compare?) xpr . xprs))))))
     108
     109#|[
     110First, a helper macro, which allows to implement bind as well
     111as a recursive version of it, bindrec, in one go.
     112It does all of the dirty work,
     113]|#
     114
     115;;; (bind-with binder pat seq xpr . xprs)
     116;;; -------------------------------------
     117;;; where binder is let or letrec
     118(define-er-macro-transformer (bind-with form rename compare?)
     119  (let ((binder (cadr form))
     120        (pat (caddr form))
     121        (seq (cadddr form))
     122        (xpr (car (cddddr form)))
     123        (xprs (cdr (cddddr form)))
     124        (%and (rename 'and))
     125        (%where (rename 'where))
     126        (%_ (rename '_))
     127        (%if (rename 'if))
     128        (%raise (rename 'raise))
     129        (%begin (rename 'begin))
     130        (%error (rename 'error))
     131        (%equal? (rename 'equal?))
     132        (%seq-ref (rename 'seq-ref))
     133        (%seq-tail (rename 'seq-tail))
     134        (%seq-null? (rename 'seq-null?))
     135        (%seq-exception (rename 'seq-exception)))
     136    (let* ((fenders? (and (pair? xpr)
     137                        (compare? (car xpr) %where)))
     138           (where-clause (if fenders?
     139                             xpr                 
     140                             '(where)))
     141           (fenders
     142             (apply append
     143                    (map (lambda (pair)
     144                           (map (lambda (p?)
     145                                  `(,p?  ,(car pair)))
     146                                (cdr pair)))
     147                         (cdr where-clause))))
     148           (body (if fenders?
     149                   `(,%if (,%and ,@fenders)
     150                      (,%begin ,@xprs)
     151                      (,%raise (,%seq-exception
     152                                 'bind
     153                                 "fenders not passed"
     154                                 ',fenders)))
     155                   `(,%begin ,xpr ,@xprs))))
     156      (letrec (
     157        (no-dups?
     158          (lambda (lst)
     159            (call-with-current-continuation
     160              (lambda (cc)
     161                (let loop ((lst lst) (result '()))
     162                  (if (null? lst)
     163                    #t
     164                    (loop (cdr lst)
     165                          (if (memq (car lst) result)
     166                            (cc #f)
     167                            (cons (car lst) result)))))))))
     168        (destructure
     169           (lambda (pat seq)
     170             (let ((len (let loop ((pat pat) (result 0))
     171                          (cond
     172                            ((null? pat) result)
     173                            ((pair? pat)
     174                             (loop (cdr pat) (+ 1 result)))
     175                            (else result)))))
     176               (let loop ((k 0) (pairs '()) (literals '()) (tails '()))
     177                 (if (= k len)
     178                   (let ((sentinel
     179                           ;last dotted item or '()
     180                           (let loop ((result pat) (k len))
     181                             (if (zero? k)
     182                               result
     183                               (loop (cdr result) (- k 1))))))
     184                     (cond
     185                       ((null? sentinel)
     186                        (values pairs literals
     187                                (cons `(,%seq-null?
     188                                         (,%seq-tail ,seq ,k))
     189                                      tails)))
     190                       ((symbol? sentinel)
     191                        (if (compare? sentinel %_)
     192                          (values pairs literals tails)
     193                          (values (cons (list sentinel
     194                                              `(,%seq-tail ,seq ,k))
     195                                        pairs)
     196                                  literals tails)))
     197                       (else
     198                         (values pairs
     199                                 (cons `(,%equal? ,sentinel
     200                                                  (,%seq-tail ,seq ,k))
     201                                       literals)
     202                                 tails))))
     203                   (let ((item (list-ref pat k)))
     204                     (cond
     205                       ((symbol? item)
     206                        (if (compare? item %_)
     207                          (loop (+ k 1) pairs literals tails)
     208                          (loop (+ k 1)
     209                                (cons (list item `(,%seq-ref ,seq ,k)) pairs)
     210                                literals
     211                                tails)))
     212                       ((atom? item) ; literal
     213                        (loop (+ k 1)
     214                              pairs
     215                              (cons `(,%equal? ,item
     216                                               (,%seq-ref ,seq ,k))
     217                                    literals)
     218                              tails))
     219                       ((pair? item)
     220                        (receive (ps ls ts)
     221                          (destructure item `(,%seq-ref ,seq ,k))
     222                          (loop (+ k 1)
     223                                (append ps pairs)
     224                                (append ls literals)
     225                                (append ts tails))))
     226                       )))))))
     227        )
     228        (receive (pairs literals tails)
     229          (destructure pat seq)
     230          (if (no-dups? (map car pairs))
     231            `(,%if (,%and ,@tails)
     232               (,%if (,%and ,@literals)
     233                 (,(rename binder) ,pairs ,body)
     234                 (,%raise (,%seq-exception
     235                            'bind
     236                            "literals don't match"
     237                            ',literals)))
     238               (,%raise (,%seq-exception
     239                          'bind
     240                          "length mismatch"
     241                          ',tails)))
     242            `(,%error 'bind-with
     243                      "duplicate pattern variables"
     244                      ',(map car pairs))
     245          ))))))
    422246
    423247#|[
     
    431255  (bind (_ ("y" z)) '(1 #("y" z)) z)
    432256
    433 will produce 3
    434 
    435 ]|#
    436 
    437 ;;; (bind pat (where . fenders) .. seq xpr ....)
     257will produce 3.
     258]|#
     259
     260;;; (bind pat seq (where . fenders) .. xpr ....)
    438261;;; ---------------------------------------------
    439262;;; binds pattern variables of pat to corresponding subexpressions of
    440263;;; seq and executes body xpr .... in this context, provided all
    441264;;; fenders pass
    442 (define-syntax bind
    443   (macro-rules _ (where)
    444     ((bind pat (where . fenders) seq xpr . xprs)
    445      (letrec (
    446        (filter
    447          (lambda (ok? lst)
    448            (let loop ((lst lst) (yes '()) (no '()))
    449              (if (null? lst)
    450                (values (reverse yes) (reverse no))
    451                (let ((first (car lst)) (rest (cdr lst)))
    452                  (if (ok? first)
    453                    (loop rest (cons first yes) no)
    454                    (loop rest yes (cons first no))))))))
    455        (mappend
    456          (lambda (fn lists)
    457            (apply append (map fn lists))))
    458        (fenders->tests
    459          (lambda (fenders)
    460            (apply append
    461                   (map (lambda (pair)
    462                          (map (lambda (p?)
    463                                 `(,p?  ,(car pair)))
    464                               (cdr pair)))
    465                        fenders))))
    466        (destruc
    467          (lambda (pat seq)
    468            (let loop ((pat pat) (seq seq) (n 0))
    469              (if (pair? pat)
    470                (let ((p (car pat))
    471                      (recu (loop (cdr pat) seq (+ n 1))))
    472                  (cond
    473                    ((pair? p)
    474                     (let ((g (gensym)))
    475                       `(((,g (ref ,seq ,n)) ,@(loop p g 0))
    476                         ,@recu)))
    477                    ((symbol? p)
    478                     (if (eq? p _)
    479                       ;; skip
    480                       recu
    481                       `((,p (ref ,seq ,n)) ,@recu)))
    482                    (else ; other atom
    483                      `((,p (equal? ',p (ref ,seq ,n)))
    484                        ,@recu))
    485                    ))
    486                ;; atom
    487                (cond
    488                  ((symbol? pat)
    489                   (if (eq? pat _) ; skip
    490                     (loop '() seq `(len ,seq))
    491                     `((,pat (tail ,seq ,n))))
    492                   )
    493                  ((null? pat)
    494                   `((,pat (zero? (len (tail ,seq ,n))))))
    495                  (else ; other atom
    496                    `((,pat (equal? ,pat (tail ,seq ,n)))))))
    497                )))
    498        (dbind-ex
    499          (lambda (binds body)
    500            (if (null? binds)
    501              `(begin ,@body)
    502              (call-with-values
    503                (lambda ()
    504                  (filter (lambda (pair) (symbol? (car pair)))
    505                          (map (lambda (b) (if (pair? (car b)) (car b) b))
    506                               binds)))
    507                (lambda (defs checks)
    508                     ;(print "YYYYY " `(and ,@(map cadr checks)))
    509                  `(let ,defs
    510                     (if (and ,@(map cadr checks))
    511                       ,(dbind-ex
    512                          (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
    513                                   binds)
    514                          `((if (or ,(null? fenders)
    515                                    ,(cons 'and (fenders->tests
    516                                                  fenders)))
    517                              (begin ,@body)
    518                              (signal-bind-exception
    519                                'bind
    520                                "fenders not passed"
    521                                ,seq
    522                                ',pat
    523                                ',(cons 'where fenders)))))
    524                       (signal-bind-exception
    525                         'bind
    526                         "match error"
    527                         ,seq
    528                         ',pat
    529                         ',(cons 'and (map cadr checks))))))
    530              ))))
    531        )         
    532        (let ((gseq 'seq))
    533          `(let ((,gseq ,seq))
    534             ,(dbind-ex ;(condition-case
    535                        ;  (destruc pat gseq)
    536                        ;  ((exn) (signal-bind-exception
    537                        ;           'bind
    538                        ;           "match error"
    539                        ;           gseq
    540                        ;           ',pat)))
    541                        (destruc pat gseq)
    542                        (cons xpr xprs)))
    543            )))
    544     ((bind pat seq xpr . xprs)
    545      `(bind ,pat (where) ,seq ,xpr ,@xprs))))
     265(define-er-macro-transformer (bind form rename compare?)
     266  (let ((pat (cadr form))
     267        (seq (caddr form))
     268        (xpr (cadddr form))
     269        (xprs (cddddr form))
     270        (%let (rename 'let))
     271        (%where (rename 'where))
     272        (%bind-with (rename 'bind-with))
     273        (%seq (rename 'seq)))
     274    (let ((fenders? (and (pair? xpr) (compare? (car xpr) %where))))
     275      (let ((body (if fenders?
     276                     `(,xpr ,@xprs)
     277                     `((,%where) ,xpr ,@xprs))))
     278        `(,%let ((,%seq ,seq))
     279           ,(cons %bind-with
     280                  (cons %let
     281                        (cons pat
     282                              (cons %seq body)))))))))
     283
     284#|[
     285And here is the recursive version of bind, which is used in bind-letrec.
     286
     287  (bindrec ((o?) e?)
     288    (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     289          (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     290    (list (o? 95) (e? 95)))
     291  -> '(#t #f)
     292]|#
     293
     294;;; (bindrec pat seq (where fender ...) .. xpr ....)
     295;;; ------------------------------------------------
     296;;; recursive version of bind
     297(define-syntax bindrec
     298  (syntax-rules ()
     299    ((_ pat seq xpr . xprs)
     300     (bind-with letrec pat seq xpr . xprs))))
    546301
    547302#|[
     
    560315      (() '())
    561316      ((x . xs) (cons (fn x) (my-map fn xs)))))
    562 
    563 To improve error messages, we wrap it around an inner version,
    564 bind-case-inner, which does all of the work.
    565 ]|#
    566 
    567 ;;; inner version, not exported
    568 (define-syntax bind-case-inner
    569   (macro-rules (where)
    570     ((_ seq (pat (where . fenders) xpr . xprs))
    571      `(bind ,pat (where ,@fenders) ,seq ,xpr ,@xprs))
    572     ((_ seq (pat xpr . xprs))
    573      `(bind ,pat (where) ,seq ,xpr ,@xprs))
    574     ((_ seq clause . clauses)
    575      `(condition-case (bind-case-inner ,seq ,clause)
    576         ((exn type)
    577          (bind-case-inner ,seq ,@clauses))
    578         ((exn bind)
    579          (bind-case-inner ,seq ,@clauses))))))
     317]|#
    580318
    581319;;; (bind-case seq (pat (where fender ...) .. xpr ....) ....)
     
    585323;;; pattern to corresponding subexpressions of seq and executes
    586324;;; corresponding body xpr ....
    587 (define-macro (bind-case seq clause . clauses)
    588   `(condition-case
    589      (bind-case-inner ,seq ,clause ,@clauses)
    590      ((exn bind)
    591       (signal-bind-exception
    592         'bind-case
    593         "no match for"
    594         ,seq
    595         'in
    596         ',(map (lambda (cl)
    597                  (list (car cl) (cadr cl)))
    598                (cons clause clauses))))))
     325(define-syntax bind-case
     326  (syntax-rules ()
     327    ((_ seq)
     328     (raise (seq-exception 'bind-case "no match for" seq)))
     329    ((_ seq (pat (where . fenders) xpr . xprs))
     330     (condition-case (bind pat seq (where . fenders) xpr . xprs)
     331       ((exn sequence) (bind-case seq))))
     332    ((_ seq (pat xpr . xprs))
     333     (bind-case seq (pat (where) xpr . xprs)))
     334    ((_ seq clause . clauses)
     335     (condition-case (bind-case seq clause)
     336       ((exn sequence) (bind-case seq . clauses))))
     337    ))
    599338
    600339#|[
     
    607346;;; returns a unary predicate which checks, if its argument matches pat
    608347;;; and fulfills the predicates in the list fender ...
    609 ;;; Mostly used in fenders of macro-rules and define-macro, but must
     348;;; Mostly used in fenders of macro-rules and define-macro-transformer, but must
    610349;;; then be imported for-syntax.
    611350(define-syntax bindable?
    612   (macro-rules (where)
     351  (syntax-rules (where)
    613352    ((_ pat (where . fenders))
    614      `(lambda (seq)
    615         (condition-case (bind ,pat (where ,@fenders) seq #t)
    616           ((exn bind) #f)
    617           ((exn range) #f))))
     353     (lambda (seq)
     354        (condition-case (bind pat seq (where . fenders) #t)
     355          ((exn sequence) #f))))
    618356    ((_ pat)
    619      `(bindable? ,pat (where)))))
     357     (bindable? pat (where)))))
    620358
    621359#|[
     
    634372]|#
    635373
    636 ;; helper macro for bind-define and bind-set!
    637 (define-syntax bind-def-set!
    638   (macro-rules _ (where)
    639     ((bind-def-set! pat (where . fenders) seq def?)
    640      (let ((sym? (lambda (p)
    641                    (and (symbol? p)
    642                         (not (eq? p _))))))
    643         (let ((aux (let copy ((pat pat))
     374;;; (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
     375;;; -------------------------------------------------------
     376;;; sets pattern variables of pat pat1 ... to corresponding sub-expressins of
     377;;; seq seq1 ..., provided the fenders are satisfied
     378(define-er-macro-transformer (bind-set! form rename compare?)
     379  (let ((pairs (reverse (chop (cdr form) 2)))
     380        (%_ (rename '_))
     381        (%let (rename 'let))
     382        (%list (rename 'list))
     383        (%where (rename 'where))
     384        (%bind (rename 'bind))
     385        (%set! (rename 'set!))
     386        (%seq (rename 'seq)))
     387    (let ((where-clause?
     388            (and (null? (cdar pairs))
     389                 (pair? (caar pairs))
     390                 (compare? (caaar pairs) %where))))
     391      (let ((where-clause (if where-clause?
     392                            (caar pairs)
     393                            `(,%where)))
     394            (pairs (if where-clause?
     395                     ;(reverse (cdr pairs))
     396                     (cdr pairs)
     397                     ;(reverse pairs))))
     398                     pairs)))
     399        (let ((pat (map car pairs))
     400              (seq `(,%list ,@(map cadr pairs)))
     401              (sym? (lambda (x)
     402                      (and (symbol? x)
     403                           (not (compare? x %_))))))
     404    (letrec (
     405      (pflatten (lambda (pls)
     406                  (cond
     407                    ((null? pls) pls)
     408                    ((pair? pls)
     409                     (append (pflatten (car pls))
     410                             (pflatten (cdr pls))))
     411                    (else (list pls)))))
     412      (filter (lambda (ok? lst)
     413                 (compress (map ok? lst) lst)))
     414      (reduce (lambda (pat)
     415                 (filter sym? (pflatten pat))))
     416      )
     417      (let ((aux (let copy ((pat pat))
     418                    (cond
     419                      ((sym? pat) (rename pat))
     420                      ((pair? pat)
     421                       (cons (copy (car pat)) (copy (cdr pat))))
     422                      (else pat))))
     423            (%where-clause
     424              (cons %where
     425                    (map (lambda (c)
     426                           (cons (rename (car c))
     427                                 (cdr c)))
     428                         (cdr where-clause)))))
     429        `(,%let ((,%seq ,seq))
     430           (,%bind ,aux ,%seq ,%where-clause
     431                   ,@(map (lambda (p a) `(,%set! ,p ,a))
     432                          (reduce pat)
     433                          (reduce aux))))
     434        )))))))
     435
     436;;; (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
     437;;; ---------------------------------------------------------
     438;;; destructures the sequences seq seq1 ... according to the patterns
     439;;; pat pat1 ...  and sets pattern variables with values corresponding
     440;;; to subexpressions of seq seq1 ..., provided the fenders are
     441;;; satisfied
     442(define-er-macro-transformer (bind-define form rename compare?)
     443  (let ((pairs (reverse (chop (cdr form) 2)))
     444        (%_ (rename '_))
     445        (%list (rename 'list))
     446        (%where (rename 'where))
     447        (%bind-set! (rename 'bind-set!))
     448        (%define (rename 'define))
     449        (%begin (rename 'begin)))
     450    (let ((where-clause?
     451            (and (null? (cdar pairs))
     452                 (pair? (caar pairs))
     453                 (compare? (caaar pairs) %where))))
     454      (let ((where-clause (if where-clause?
     455                            (caar pairs)
     456                            `(,%where)))
     457            (pairs (if where-clause?
     458                     ;(reverse (cdr pairs))
     459                     (cdr pairs)
     460                     ;(reverse pairs))))
     461                     pairs)))
     462        (let ((pat (map car pairs))
     463              (seq `(,%list ,@(map cadr pairs)))
     464              (sym? (lambda (x)
     465                      (and (symbol? x)
     466                           (not (compare? x %_))))))
     467    (letrec (
     468      (map-flatten (lambda (pls)
    644469                     (cond
    645                        ((sym? pat) (gensym))
    646                        ((pair? pat)
    647                         (cons (copy (car pat)) (copy (cdr pat))))
    648                        (else pat))))
    649               (flatten*
    650                 ; imported flatten doesn't work with pseudo-lists
    651                 (lambda (tree)
    652                   (let loop ((tree tree) (result '()))
    653                     (cond
    654                       ((pair? tree)
    655                        (loop (car tree) (loop (cdr tree) result)))
    656                       ((null? tree) result)
    657                       (else
    658                         (cons tree result))))))
    659               (filter
    660                 (lambda (ok? lst)
    661                   (compress (map ok? lst) lst))))
    662           (if def?
    663             `(if ((bindable? ,pat (where ,@fenders)) ,seq)
    664                (begin
    665                  ,@(map (lambda (p) `(define ,p ',p))
    666                         (filter sym? (flatten* pat)))
    667                  (bind ,aux ,seq
    668                    ,@(map (lambda (p a) `(set! ,p ,a))
    669                           (filter sym? (flatten* pat))
    670                           (filter sym? (flatten* aux)))))
    671                (signal-bind-exception 'bind-define
    672                                       "fenders not passed"
    673                                       ',seq
    674                                       ',pat
    675                                       '(where ,@fenders)))
    676             `(if ((bindable? ,pat (where ,@fenders)) ,seq)
    677                (bind ,aux ,seq
    678                  ,@(map (lambda (p a) `(set! ,p ,a))
    679                         (filter sym? (flatten* pat))
    680                         (filter sym? (flatten* aux))))
    681                (signal-bind-exception 'bind-set!
    682                                       "fenders not passed"
    683                                       ',seq
    684                                       ',pat
    685                                       '(where ,@fenders)))))))
    686     ))
    687 
    688 
    689 ;;; (bind-define pat (where fender ...) .. seq)
    690 ;;; -------------------------------------------
    691 ;;; destructures the sequence seq according to the pattern pat and sets
    692 ;;; pattern variables with values corresponding to subexpressions of
    693 ;;; seq, provided the fenders are satisfied
    694 (define-syntax bind-define
    695   (macro-rules (where)
    696     ((_ pat (where . fenders) seq)
    697      `(bind-def-set! ,pat (where ,@fenders) ,seq #t))
    698     ((_ pat seq)
    699      `(bind-def-set! ,pat (where) ,seq #t))))
    700 
    701 ;;; (bind-set! pat (where fender ...) .. seq)
    702 ;;; -----------------------------------------
    703 ;;; sets pattern variables of pat to corresponding sub-expressins of
    704 ;;; seq, provided the fenders are satisfied
    705 (define-syntax bind-set!
    706   (macro-rules (where)
    707     ((_ pat (where . fenders) seq)
    708      `(bind-def-set! ,pat (where ,@fenders) ,seq #f))
    709     ((_ pat seq)
    710      `(bind-def-set! ,pat (where) ,seq #f))))
     470                       ((null? pls) pls)
     471                       ((pair? pls)
     472                        (append (map-flatten (car pls))
     473                                (map-flatten (cdr pls))))
     474                       (else (list `(,%define ,pls #f))))))
     475      (filter (lambda (ok? lst)
     476                (compress (map ok? lst) lst)))
     477      )
     478      `(,%begin
     479         ,@(filter sym?
     480                   (map-flatten pat))
     481         (,%bind-set! ,pat ,seq ,where-clause))))))))
    711482
    712483#|[
     
    729500;;; combination of lambda and bind, one pattern argument
    730501(define-syntax bind-lambda
    731   (macro-rules (where)
     502  (syntax-rules (where)
    732503    ((_ pat (where . fenders) xpr . xprs)
    733      `(lambda (x) (bind ,pat (where ,@fenders) x ,xpr ,@xprs)))
     504     (lambda (x) (bind pat x (where . fenders) xpr . xprs)))
    734505    ((_ pat xpr . xprs)
    735      `(bind-lambda ,pat (where) ,xpr ,@xprs))))
     506     (bind-lambda pat (where) xpr . xprs))))
    736507
    737508;;; (bind-lambda* pat (where fender ...) .. xpr ....)
     
    739510;;; combination of lambda and bind, multiple pattern arguments
    740511(define-syntax bind-lambda*
    741   (macro-rules (where)
     512  (syntax-rules (where)
    742513    ((_ pat (where . fenders) xpr . xprs)
    743      `(lambda x (bind ,pat (where ,@fenders) x ,xpr ,@xprs)))
     514     (lambda x (bind pat x (where . fenders) xpr . xprs)))
    744515    ((_ pat xpr . xprs)
    745      `(bind-lambda* ,pat (where) ,xpr ,@xprs))))
     516     (bind-lambda* pat (where) xpr . xprs))))
    746517
    747518#|[
     
    769540;;; combination of lambda and bind-case, one pattern argument
    770541(define-syntax bind-case-lambda
    771   (macro-rules (where)
     542  (syntax-rules (where)
    772543    ((_ (pat (where . fenders) xpr . xprs))
    773      `(lambda (x)
    774         (bind-case x (,pat (where ,@fenders) ,xpr ,@xprs))))
     544     (lambda (x)
     545       (bind-case x (pat (where . fenders) xpr . xprs))))
    775546    ((_ (pat xpr . xprs))
    776      `(lambda (x)
    777         (bind-case x (,pat ,xpr ,@xprs))))
     547     (lambda (x)
     548       (bind-case x (pat xpr . xprs))))
    778549    ((_ clause . clauses)
    779      `(lambda (x)
    780         (bind-case x ,clause ,@clauses)))))
     550     (lambda (x)
     551       (bind-case x clause . clauses)))))
    781552
    782553;;; (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
     
    784555;;; combination of lambda and bind-case, multiple pattern arguments
    785556(define-syntax bind-case-lambda*
    786   (macro-rules (where)
     557  (syntax-rules (where)
    787558    ((_ (pat (where . fenders) xpr . xprs))
    788      `(lambda x
    789         (bind-case x (,pat (where ,@fenders) ,xpr ,@xprs))))
     559     (lambda x
     560       (bind-case x (pat (where . fenders) xpr . xprs))))
    790561    ((_ (pat xpr . xprs))
    791      `(lambda x
    792         (bind-case x (,pat ,xpr ,@xprs))))
     562     (lambda x
     563       (bind-case x (pat xpr . xprs))))
    793564    ((_ clause . clauses)
    794      `(lambda x
    795         (bind-case x ,clause ,@clauses)))))
    796 
    797 #|[
    798 The following macro, bind*, is a named version of bind. It takes an
     565     (lambda x
     566       (bind-case x clause . clauses)))))
     567
     568#|[
     569The following macro, bind-named, is a named version of bind. It takes an
    799570additional argument besides those of bind, which is bound to a
    800571recursive procedure, which can be called in bind's body. The pattern
     
    802573For example
    803574
    804   (bind* loop (x y) '(5 0)
     575  (bind-named loop (x y) '(5 0)
    805576    (if (zero? x)
    806577      (list x y)
     
    809580]|#
    810581
    811 ;;; (bind* name pat seq (where fender ...) .. xpr ....)
    812 ;;; ---------------------------------------------------
     582;;; (bind-named name pat seq (where fender ...) .. xpr ....)
     583;;; ---- ---------------------------------------------------
    813584;;; named version of bind
    814 (define-syntax bind*
    815   (macro-rules (where)
    816     ((_ name pat (where . fenders) seq xpr . xprs)
    817      `((letrec ((,name
    818                   (bind-lambda ,pat (where ,@fenders) ,xpr ,@xprs)))
    819          ,name)
    820        ,seq))
     585(define-syntax bind-named
     586  (syntax-rules (where)
     587    ((_ name pat seq (where . fenders) xpr . xprs)
     588     ((letrec ((name
     589                  (bind-lambda pat (where . fenders) xpr . xprs)))
     590         name)
     591       seq))
    821592    ((_ name pat seq xpr . xprs)
    822      `(bind* ,name ,pat (where) ,seq ,xpr ,@xprs))))
     593     (bind-named name pat seq (where) xpr . xprs))))
    823594
    824595#|[
    825596Now the implementation of a nested version of let, named and unnamed,
    826 is easy: Simply combine bind and bind*. For example
     597is easy: Simply combine bind and bind-named. For example
    827598
    828599  (bind-let (
     
    838609      (list a b)
    839610      (loop (list (sub1 a) (add1 b)))))
     611      ;(loop (list (list (sub1 a) (add1 b))))))
     612      ;version with bind-named
    840613  -> '(0 5)
    841614]|#
    842615
    843 ;;; (bind-let loop .. ((pat (where fender ...) .. seq) ...) xpr ....)
     616;;; (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
    844617;;; -----------------------------------------------------------------
    845618;;; nested version of let, named and unnamed
    846 (define-syntax bind-let
    847   (let ((last (lambda (lst)
    848                 (let loop ((lst lst))
    849                   (if (null? (cdr lst))
    850                     (car lst)
    851                     (loop (cdr lst))))))
    852         (extract-fenders
    853           (lambda (pairs)
    854             (apply append
    855                    (map cdadr
    856                         (compress
    857                           (map (lambda (pair)
    858                                  (= (length pair) 3))
    859                                pairs)
    860                           pairs))))))
    861     (macro-rules (where)
    862       ((_ loop () xpr . xprs)
    863        `(let ,loop () ,xpr ,@xprs))
    864       ((_ loop ((pat0 (where . fenders) seq0) . pat-seq-pairs) xpr . xprs)
    865        `(bind* ,loop
    866           ,(cons pat0 (map car pat-seq-pairs))
    867           (where ,@(append fenders
    868                            (extract-fenders pat-seq-pairs)))
    869           (list ,seq0 ,@(map last pat-seq-pairs))
    870           ,xpr ,@xprs))
    871       ((_ loop ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
    872        `(bind* ,loop
    873           ,(cons pat0 (map car pat-seq-pairs))
    874           (where ,@(extract-fenders pat-seq-pairs))
    875           (list ,seq0 ,@(map last pat-seq-pairs))
    876           ,xpr ,@xprs))
    877       ((_ () xpr . xprs)
    878        `(let () ,xpr ,@xprs))
    879       ((_ ((pat0 (where . fenders) seq0) . pat-seq-pairs) xpr . xprs)
    880        `(bind
    881           ,(cons pat0 (map car pat-seq-pairs))
    882           (where ,@(append fenders
    883                            (extract-fenders pat-seq-pairs)))
    884           (list ,seq0 ,@(map last pat-seq-pairs))
    885           ,xpr ,@xprs))
    886       ((_ ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
    887        `(bind
    888           ,(cons pat0 (map car pat-seq-pairs))
    889           (where ,@(extract-fenders pat-seq-pairs))
    890           (list ,seq0 ,@(map last pat-seq-pairs))
    891           ,xpr ,@xprs))
    892     )))
     619(define-er-macro-transformer (bind-let form rename compare?)
     620  (let ((named? (symbol? (cadr form))))
     621    (let ((name (if named? (cadr form) (gensym)))
     622          (binds (if named? (caddr form) (cadr form)))
     623          (xpr (if named? (cadddr form) (caddr form)))
     624          (xprs (if named? (cddddr form) (cdddr form))))
     625      (let ((pats (map car binds))
     626            (seqs (map cadr binds))
     627            (%list (rename 'list))
     628            (%bind (rename 'bind))
     629            ;(%bind-named (rename 'bind-named)))
     630            (%letrec (rename 'letrec))
     631            (%bind-lambda* (rename 'bind-lambda*)))
     632        (if named?
     633          `(,%letrec ((,name (,%bind-lambda* ,pats ,xpr ,@xprs)))
     634             (,name ,@seqs))
     635          ;`(,%bind-named ,name ,pats (,%list ,@seqs) ,xpr ,@xprs)
     636          `(,%bind ,pats (,%list ,@seqs) ,xpr ,@xprs))))))
    893637
    894638#|[
     
    904648]|#
    905649
    906 ;;; (bind-let* ((pat (where fender ...) .. seq) ...) xpr ....)
     650;;; (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
    907651;;; ----------------------------------------------------------
    908652;;; sequential version of bind-let
    909653(define-syntax bind-let*
    910   (macro-rules (where)
     654  (syntax-rules (where)
    911655    ((_ () xpr . xprs)
    912      `(let () ,xpr ,@xprs))
    913     ((_ ((pat (where . fenders) seq) . pat-seq-pairs) xpr . xprs)
    914      `(bind ,pat (where ,@fenders) ,seq
    915         (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))
    916     ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
    917      `(bind ,pat ,seq
    918         (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))))
    919 
    920 #|[
    921 And here is the recursive version of bind, which is used in bind-letrec.
    922 
    923   (bindrec ((o?) e?)
    924     (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    925           (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    926     (list (o? 95) (e? 95)))
    927   -> '(#t #f)
    928 ]|#
    929 
    930 ;;; (bindrec pat (where fender ...) .. seq xpr ....)
    931 ;;; ------------------------------------------------
    932 ;;; recursive version of bind
    933 (define-syntax bindrec
    934   (macro-rules (where)
    935     ((_ pat (where . fenders) seq xpr . xprs)
    936      `(if ((bindable? ,pat) ,seq)
    937         (bind ,pat ',pat
    938           ; bind pattern variables to auxiliary values
    939           ; so that they are in scope
    940           (bind-set! ,pat (where ,@fenders) ,seq)
    941           ; set! the real values
    942           ,xpr ,@xprs)
    943         (signal-bind-exception 'bindrec
    944                                "fenders not passed"
    945                                ',seq
    946                                ',pat
    947                                '(where ,@fenders))))
    948     ((_ pat seq xpr . xprs)
    949      `(bindrec ,pat (where) ,seq ,xpr ,@xprs))))
     656     (begin xpr . xprs))
     657    ((_ ((pat seq)) (where . fenders) xpr . xprs)
     658     (bind pat seq (where . fenders) xpr . xprs))
     659    ((_ ((pat seq)) xpr . xprs)
     660     (bind pat seq xpr . xprs))
     661    ((_ ((pat seq) binds ...) (where . fenders) xpr . xprs)
     662     (bind pat seq (bind-let* (binds ...)
     663                     (where . fenders) xpr . xprs)))
     664    ((_ ((pat seq) binds ...) xpr . xprs)
     665     (bind pat seq
     666       (bind-let* (binds ...) xpr . xprs)))))
    950667
    951668#|[
     
    961678]|#
    962679
    963 ;;; (bind-letrec ((pat (where fender ...) .. seq) ...) xpr ....)
     680;;; (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
    964681;;; ------------------------------------------------------------
    965682;;; recursive version of bind-let
    966 (define-syntax bind-letrec
    967   (let ((last (lambda (lst)
    968                 (let loop ((lst lst))
    969                   (if (null? (cdr lst))
    970                     (car lst)
    971                     (loop (cdr lst))))))
    972         (extract-fenders
    973           (lambda (pairs)
    974             (apply append
    975                    (map cdadr
    976                         (compress
    977                           (map (lambda (pair)
    978                                  (= (length pair) 3))
    979                                pairs)
    980                           pairs))))))
    981     (macro-rules (where)
    982       ((_ ((pat (where . fenders) seq) . pat-seq-pairs) xpr . xprs)
    983        `(bindrec ,(cons pat (map car pat-seq-pairs))
    984           (where ,@(append fenders
    985                            (extract-fenders pat-seq-pairs)))
    986           (list ,seq ,@(map last pat-seq-pairs))
    987           ,xpr ,@xprs))
    988       ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
    989        `(bindrec ,(cons pat (map car pat-seq-pairs))
    990           (where ,@(extract-fenders pat-seq-pairs))
    991           (list ,seq ,@(map last pat-seq-pairs))
    992           ,xpr ,@xprs))
    993       ((_ () xpr . xprs)
    994        `(let () ,xpr ,@xprs))
    995     )))
     683(define-er-macro-transformer (bind-letrec form rename compare?)
     684  (let ((binds (cadr form)) (xpr (caddr form)) (xprs (cdddr form)))
     685    (let ((pats (map car binds))
     686          (seqs (map cadr binds))
     687          (%list (rename 'list))
     688          (%bindrec (rename 'bindrec)))
     689      `(,%bindrec ,pats (,%list ,@seqs) ,xpr ,@xprs))))
    996690
    997691#|[
     
    1003697;;; captures the current continuation, binds it to cc and executes
    1004698;;; xpr .... in this context
    1005 (define-macro (bind/cc cc xpr . xprs)
    1006   `(call-with-current-continuation
    1007      (lambda (,cc) ,xpr ,@xprs)))
     699(define-syntax bind/cc
     700  (syntax-rules ()
     701    ((_ cc xpr . xprs)
     702     (call-with-current-continuation
     703       (lambda (cc) xpr . xprs)))))
    1008704
    1009705;;; (bindings sym ..)
     
    1012708(define bindings
    1013709  (symbol-dispatcher '(
     710    (bindings
     711      procedure:
     712      (bindings sym ..)
     713      "documentation procedure")
     714    (seq-db
     715      procedure:
     716      (seq-db)
     717      "shows the sequence database"
     718      (seq-db type ref: ref tail: tail maker: maker ra?: random-access?)
     719      "adds a new sequence type to the database where the keywords"
     720      "name arguments being accessed as seq-ref and seq-tail seq-maker"
     721      "and seq-random-access? respectively")
    1014722    (bind
    1015723      macro:
    1016       (bind pat (where fender ...) .. seq xpr ....)
     724      (bind pat seq (where fender ...) .. xpr ....)
    1017725      "a variant of Common Lisp's destructuring-bind")
    1018726    (bind-case
     
    1027735    (bind-set!
    1028736      macro:
    1029       (bind-set! pat (where fender ...) .. seq)
    1030       "sets multiple variables by destructuring its sequence argument")
     737      (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)
     738      "sets multiple variables by destructuring its sequence arguments")
    1031739    (bind-define
    1032740      macro:
    1033       (bind-define pat (where fender ...) .. seq)
    1034       "defines multiple variables by destructuring its sequence argument")
     741      (bind-define pat seq pat1 seq1 ... (where fender ...) ..)
     742      "defines multiple variables by destructuring its sequence arguments")
    1035743    (bind-lambda
    1036744      macro:
     
    1041749      (bind-lambda* pat (where fender ...) .. xpr ....)
    1042750      "combination of lambda and bind, multiple pattern arguments")
    1043     (bind*
    1044       macro:
    1045       (bind* loop pat (where fender ...) .. seq xpr ....)
     751    (bind-named
     752      macro:
     753      (bind-named loop pat (where fender ...) .. seq xpr ....)
    1046754      "named version of bind")
    1047755    (bind-let
    1048756      macro:
    1049       (bind-let loop .. ((pat (where fender ...) .. seq) ...) xpr ....)
     757      (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)
    1050758      "nested version of let, named and unnamed")
    1051759    (bind-let*
    1052760      macro:
    1053       (bind-let* ((pat (where fender ...) .. seq) ...) xpr ....)
     761      (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)
    1054762      "nested version of let*")
    1055763    (bindrec
    1056764      macro:
    1057       (bindrec pat (where fender ...) .. seq xpr ....)
     765      (bindrec pat seq (where fender ...) .. xpr ....)
    1058766      "recursive version of bind")
    1059767    (bind-letrec
    1060768      macro:
    1061       (bind-letrec ((pat (where fender ...) .. seq) ...) xpr ....)
     769      (bind-letrec ((pat seq) ...) (where fender ...) .. xpr ....)
    1062770      "recursive version of bind-let")
    1063771    (bind-case-lambda
     
    1074782      "binds cc to the current contiunation"
    1075783      "and execute xpr ... in this context")
    1076     (bind-exception
    1077       procedure:
    1078       (bind-exception loc msg arg ...)
    1079       "generates a composite condition with location symbol, string message"
    1080       "and passible additional arguments arg ...")
    1081     (signal-bind-exception
    1082       procedure:
    1083       (bind-exception loc msg arg ...)
    1084       "signals a composite condition with location symbol, string message"
    1085       "and passible additional arguments arg ...")
    1086     (bind-exception-handler
    1087       procedure:
    1088       (bind-exception-handler var)
    1089       "to be passed to the parameter current-exception-handler")
    1090     (bind-table-show
    1091       procedure:
    1092       (bind-table-show)
    1093       "pretty prints the sequence table")
    1094     (bind-table-add!
    1095       procedure:
    1096       (bind-table-add! type? len ref tail)
    1097       "adds a new table item to the front of the sequence table")
    1098     (list-of
    1099       procedure:
    1100       (list-of ok? ...)
    1101       "generates a list predicate which checks all of its arguments")
    1102     (pseudo-list-of
    1103       procedure:
    1104       (pseudo-list-of ok? ...)
    1105       "generates a pseudo-list predicate which checks all of its arguments")
    1106     (vector-of
    1107       procedure:
    1108       (vector-of ok? ...)
    1109       "generates a vector predicate which checks all of its arguments")
    1110     (symbol-dispatcher
    1111       procedure:
    1112       (symbol-dispatcher alist)
    1113       "generates a procedure of zero or one argument showing all"
    1114       "cars or the cdr or the alist item with symbol as car")
    1115784    )))
    1116   ) ; bind-functor
    1117 
    1118 (module bindings = bind-functor
    1119   (import scheme
    1120           (only bind-sequences
    1121                 bind-seq-length bind-seq-ref bind-seq-tail))
    1122   (define len bind-seq-length)
    1123   (define ref bind-seq-ref)
    1124   (define tail bind-seq-tail))
    1125 
    1126 (module list-bindings = bind-functor
    1127   (import scheme)
    1128   (define len length)
    1129   (define ref list-ref)
    1130   (define tail list-tail))
    1131 
    1132 ;(use sequences)
    1133 ;;; uses matchable, which bindings can replace
    1134 ;(module sequence-bindings = bind-functor
    1135 ;  (import scheme sequences)
    1136 ;  (define len size)
    1137 ;  (define ref elt)
    1138 ;  (define tail sub))
     785  ) ; bindings
     786
     787;(import bindings)
  • release/4/bindings/trunk/bindings.setup

    r33088 r33533  
    22
    33(compile -O3 -d1 -s bindings.scm -J)
    4 (compile -O3 -d0 -s bind-sequences.import.scm)
    5 (compile -O3 -d0 -s bind-functor.import.scm)
    6 (compile -O3 -d0 -s _bindings.import.scm)
    74(compile -O3 -d0 -s bindings.import.scm)
    8 (compile -O3 -d0 -s _list-bindings.import.scm)
    9 (compile -O3 -d0 -s list-bindings.import.scm)
    105
    116(install-extension
    127 'bindings
    13  '("bindings.so" "bind-sequences.import.so"
    14    "bind-functor.import.so" "_bindings.import.so" "bindings.import.so"
    15    "_list-bindings.import.so" "list-bindings.import.so")
    16  '((version "5.0")))
     8 '("bindings.so" "bindings.import.so")
     9 '((version "6.0")))
  • release/4/bindings/trunk/tests/run.scm

    r33088 r33533  
    33;;;; ju (at) jugilo (dot) de
    44
    5 (require-library bindings arrays simple-tests)
     5(require-library bindings arrays basic-sequences simple-tests)
    66
    77(import simple-tests
    88        bindings
    9         (prefix list-bindings list-)
    10         (only arrays array array? array-length array-item array-drop
    11               array->list)
    12         )
    13 
    14 (define-test (bind?)
     9        (only basic-sequences seq-db)
     10        (only arrays array array? array-ref array-tail array->list)
     11        )
     12
     13(define-test (binds?)
    1514  (check
    1615    (= (bind a 1 a) 1)
    17     (equal? (bind (a b) (where (a odd?)) '(1 2) (list a b)) '(1 2))
    18     (equal?
    19       (list-bind (x y z w) '(1 2 3 4) (list x y z w))
    20       '(1 2 3 4))
    21     (equal?
    22       (list-bind (_ y z _) '(1 2 3 4) (list y z))
    23       '(2 3))
     16    (equal? (bind (a b) '(1 2) (where (a odd?)) (list a b)) '(1 2))
    2417    (equal?
    2518      (bind (x . y) '#(1 2 3 4) (list x y))
     
    4235      (bind (x (y _ . _) . _) '(1 #(2 3 4) 5 6) (list x y))
    4336      '(1 2))
    44     (equal? (list-bind (x (y (z . u) . v) . w)
    45               (where (z odd?))
    46               '(1 (2 (3 4) 5) 6)
    47               (list x y z u v w))
    48             '(1 2 3 (4) (5) (6)))
    49     (condition-case
    50       (list-bind (x (y (z . u) . v) . w)
    51         (where (z even?))
    52         '(1 (2 (3 4) 5) 6)
    53         (list x y z u v w))
    54       ((exn bind) #t))
    5537    (equal?
    5638      (bind (x (y (z . u)) v . w) (vector 1 (list 2 (cons #f #f)) 5 6)
     
    6749      '(1 2 3 4 5 #(6)))
    6850    (equal?
    69       (bind* loop (x (a . b) y) (where (x integer?)) '(5 #(1) 0)
     51      (bind-named loop (x (a . b) y) '(5 #(1) 0) (where (x integer?))
    7052        (if (zero? x)
    7153          (list x a b y)
     
    7355      '(0 1 (1 1 1 1 1 . #()) 5))
    7456    (equal?
    75       (bind* loop (x y) (where (x integer?)) #(5 0)
     57      (bind-named loop (x y) #(5 0) (where (x integer?))
    7658        (if (zero? x)
    7759          (vector x y)
     
    8567      (condition-case
    8668        (bind (#f . ys) '(#t 2 3) ys)
    87         ((exn bind) #f)))
     69        ((exn sequence) #f)))
    8870    (bind #f #f #t)
    8971    (not
    9072      (condition-case
    9173        (bind #f #t #t)
    92         ((exn bind) #f)))
    93     (= (list-bind (x . #f) '(1 . #f) x) 1)
     74        ((exn sequence) #f)))
    9475    (not
    9576      (condition-case
    9677        (bind (x . #f) '(1 . #t) x)
    97         ((exn bind) #f)))
     78        ((exn sequence) #f)))
    9879    (equal?
    9980      (bind (x (y . #f)) '(1 (2 . #f)) (list x y))
     
    10283      (condition-case
    10384        (bind (x (y . #f)) '(1 (2 . #t)) (list x y))
    104         ((exn bind) #f)))
     85        ((exn sequence) #f)))
    10586    (equal?
    10687      (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y))
     
    10990      (condition-case
    11091        (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y))
    111         ((exn bind) #f)))
     92        ((exn sequence) #f)))
    11293    (not
    11394      (condition-case
    11495        (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y))
    115         ((exn bind) #f)))
     96        ((exn sequence) #f)))
    11697    (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))
    11798
    11899    "ADD ARRAYS TO GENERIC SEQUENCES"
    119     (bind-table-add!  array?
    120                       array-length
    121                       (lambda (seq k)
    122                         (array-item k seq))
    123                       (lambda (seq k)
    124                         (array-drop k seq)))
     100    (seq-db array? ref: array-ref tail: array-tail maker: array ra?: #t)
    125101    (equal?
    126102      (bind (x y z) (array 1 2 3) (list x y z))
     
    136112    ))
    137113
    138 (define-test (predicate?)
     114(define-test (predicates?)
    139115  (check
    140116    (not ((bindable? (x)) '(name 1)))
     
    142118    ((bindable? (_ x)) '(name 1))
    143119    (not ((bindable? (_ x)) '(name 1 2)))
    144     (not ((list-bindable? (_ x y) (where (x symbol?))) '(name 1 2)))
    145120    ((bindable? (a b) (where (a odd?))) '#(1 2))
    146121    (not ((bindable? (x (y z)) (where (y char-alphabetic?))) '(1 "23")))
     
    151126    ))
    152127
    153 (define-test (case?)
    154   (check
    155     (not (bind-case '#() (() #f)))
    156     (equal? (bind-case '#(2 2)
     128(define-test (cases?)
     129  (check
     130    (not (bind-case #() (() #f)))
     131    (equal? (bind-case #(2 2)
    157132              ((a b) (where (a even?) (b odd?)) (print 'even-odd a b))
    158133              ((a b) (where (a odd?) (b even?)) (print 'odd-even a b))
     
    183158              ((x y) (list x y)))
    184159            '(1 #\2 #\3))
    185     (equal? (list-bind-case '(1 (2 3))
    186               ((x (y z)) (list x y z))
    187               ((x (y . z)) (list x y z))
    188               ((x y) (list x y)))
    189             '(1 2 3))
    190160    (equal? (bind-case '(1 "2 3") ;
    191161              ((x (y . z)) (list x y z))
     
    198168              ((x (y z)) (list x y z)))
    199169            '(1 2 #(3)))
    200     (equal? (list-bind-case '(1 (2 3))
    201               ((x (y . z)) (list x y z))
    202               ((x y) (list x y))
    203               ((x (y z)) (list x y z)))
    204             '(1 2 (3)))
    205170    (equal? (bind-case '(1 (2 3))
    206171              ((x y) (list x y))
     
    208173              ((x (y z)) (list x y z)))
    209174            '(1 (2 3)))
    210     (equal? (list-bind-case '(1 (2 . 3))
    211               ((x (y . z)) (list x y z))
    212               ((x (y z)) (list x y z)))
    213             '(1 2 3))
    214175    (equal? (bind-case '(1 (2 . 3))
    215176              ((x y) (list x y))
     
    228189    (define (my-map fn lst)
    229190      (let loop ((lst lst) (result '()))
    230         (list-bind-case lst
     191        (bind-case lst
    231192          (() (reverse result))
    232193          ((x . xs)
     
    294255      '#(2 3 4 5))
    295256    (equal?
    296       ((list-bind-case-lambda
     257      ((bind-case-lambda
    297258         ((e . f) (where (e zero?)) e)
    298259         ((a (b . #f) . d) (list a b d))
     
    301262      '(1 2 (4 5)))
    302263    (equal?
    303       ((list-bind-case-lambda
     264      ((bind-case-lambda
    304265         ((e . f) (where (e zero?)) e)
    305266         ((a (b . #f) . d) (list a b d))
     
    312273              ((a (b . #f) . d) (list a b d)))
    313274            '(1 (2 . #t) 4 5))
    314            ((exn bind) #f)))
     275           ((exn sequence) #f)))
    315276    (equal?
    316277      ((bind-case-lambda
     
    350311    (equal?
    351312      (bind-let (
    352         ((x y (z . w)) (where (x number?)) '(1 2 #(3 4 5)))
    353         )
    354         (list x y z w))
    355       '(1 2 3 #(4 5)))
    356     (equal?
    357       (bind-let (
    358313        (((x y) z) '(#(1 2) 3))
    359         (u (where (u integer?)) (+ 2 2))
    360         ((v w) '#(5 6))
    361         )
     314        (u (+ 2 2))
     315        ((v w) #(5 6))
     316        )
     317        (where (u integer?))
    362318        (list x y z u v w))
    363319      '(1 2 3 4 5 6))
    364320    (equal?
    365       (bind* loop (a b) '(5 0)
     321      (bind-named loop (a b) '(5 0)
    366322        (if (zero? a)
    367323          (list a b)
     
    369325      '(0 5))
    370326    (equal?
    371       (list-bind-let loop (
    372         ((a b) (where (a integer?))'(5 0))
    373         )
     327      (bind-let loop (
     328        ((a b) '(5 0))
     329        )
     330        (where (a integer?))
    374331        (if (zero? a)
    375332          (list a b)
    376           (loop (list (list (- a 1) (+ b 1))))))
     333          (loop (list (- a 1) (+ b 1)))))
    377334      '(0 5))
    378335    (equal?
    379336      (bind-let loop (
    380         ((x . y) (where (x integer?) (y (list-of integer?))) '(1 2 3))
    381         ((z) (where (z integer?)) #(10))
    382         )
     337        ((x . y) '(1 2 3))
     338        ((z) #(10))
     339        )
     340        (where (x integer?) (y (list-of? integer?)) (z integer?))
    383341        (if (zero? z)
    384342          (list x y z)
    385           (loop (list (cons (+ x 1) (map add1 y)) (list (- z 1))))))
     343          (loop (cons (+ x 1) (map add1 y)) (list (- z 1)))))
    386344      '(11 (12 13) 0))
    387345    (equal?
    388346      (bind-let* (
    389347        (((x y) z) '(#(1 2) 3))
    390         (u (where (u integer?)) (+ 1 2 x))
     348        (u (+ 1 2 x))
    391349        ((v w) (list (+ z 2) 6))
    392350        )
     351        (where (u integer?))
    393352        (list x y z u v w))
    394353      '(1 2 3 4 5 6))
    395354    (equal?
    396       (bindrec ((o?) e?) (where (o? procedure?) (e? procedure?))
    397         (vector (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    398                 (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     355      (bindrec ((o?) e?)
     356               (vector
     357                 (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     358                 (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     359        (where (o? procedure?) (e? procedure?))
    399360        (list (o? 95) (e? 95)))
    400361      '(#t #f))
     
    402363      (bind-letrec (
    403364        ((o? (e?))
    404          (where (o? procedure?) (e? procedure?))
    405          (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
    406                (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    407         )
     365         (list
     366           (lambda (m) (if (zero? m) #f (e? (- m 1))))
     367           (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
     368        )
     369        (where (o? procedure?) (e? procedure?))
    408370        (list (o? 95) (e? 95)))
    409371      '(#t #f))
     
    413375  (check
    414376    (equal?
    415       (let ((stack #f) (push! #f) (pop! #f))
     377      (let ((x #f) (y #f) (z #f))
     378        (bind-set! (x (y . z))
     379          '(1 #(2 3 3)))
     380        (list x y z))
     381      '(1 2 #(3 3)))
     382    (equal?
     383      (let ((x #f) (y #f) (z #f))
     384        (bind-set! (x #f _ (y _ . z))
     385          '(1 #f 10 #(2 30 3 3)))
     386        (list x y z))
     387      '(1 2 #(3 3)))
     388    (equal?
     389      (let ((x #f) (y #f) (z #f))
     390        (bind-set! x 1 y 2 z 3)
     391        (list x y z))
     392      '(1 2 3))
     393    (equal?
     394      (let ((x #f) (y #f) (z #f) (u #f) (v #f))
     395        (bind-set!
     396          (x (y . z))
     397          '(1 #(2 3 3))
     398          (u (v))
     399          '(10 (20))
     400          (where (x integer?) (u number?)))
     401        (list x y z u v))
     402      '(1 2 #(3 3) 10 20))
     403    (equal?
     404      (let ((x #f) (y #f) (z #f))
     405        (bind-set! (x (y . z))
     406          '(1 #(2 3 3))
     407          (where (x integer?)))
     408        (list x y z))
     409      '(1 2 #(3 3)))
     410    (equal?
     411      (begin
     412        (define stack #f) (define push! #f) (define pop! #f)
    416413        (bind-set! (stack (push! pop!))
    417414          (list
     
    419416            (vector
    420417              (lambda (xpr) (set! stack (cons xpr stack)))
    421               (lambda () (set! stack (cdr stack))))))
     418              (lambda () (set! stack (cdr stack)))))
     419          (where (push! procedure?) (pop! procedure?)))
    422420        (push! 1)
    423421        (push! 0)
     
    425423      '(0 1))
    426424    (equal?
    427       (let ((x #f) (y #f) (z #f))
    428         (bind-set! (x (y . z))
    429           (where (x integer?))
    430           '(1 #(2 3 3)))
    431         (list x y z))
    432       '(1 2 #(3 3)))
    433     (equal?
    434       (begin
    435         (list-bind-define (plus5 times5)
     425      (begin
     426        (bind-define (plus5 times5)
    436427          (let ((a 5))
    437428            (list
     
    442433    (equal?
    443434      (begin
     435        (bind-define (x . y) '(1 . 2) ((z)) '((3)) (where (x integer?)))
     436        (list x y z))
     437      '(1 2 3))
     438    (equal?
     439      (begin
     440        (bind-define (x _ . y) '(1 10 . 2) ((z)) '((3)) (where (x integer?)))
     441        (list x y z))
     442      '(1 2 3))
     443    (equal?
     444      (begin
     445        (bind-define (x #f . y) '(1 #f . 2) ((z)) '((3)))
     446        (list x y z))
     447      '(1 2 3))
     448    (equal?
     449      (begin
     450        (bind-define x 1 y 2 z 3 (where (x integer?)))
     451        (list x y z))
     452      '(1 2 3))
     453    (equal?
     454      (begin
    444455        (bind-define (push top pop)
    445           (where (push procedure?)
    446                  (top procedure?)
    447                  (pop procedure?))
    448456          (let ((lst '()))
    449457            (vector
    450458              (lambda (xpr) (set! lst (cons xpr lst)))
    451459              (lambda () (car lst))
    452               (lambda () (set! lst (cdr lst))))))
     460              (lambda () (set! lst (cdr lst)))))
     461          (where (push procedure?)
     462                 (top procedure?)
     463                 (pop procedure?)))
    453464        (push 0)
    454465        (push 1)
     
    464475      (begin
    465476        (bind-define (x (#f y (z #t)))
    466           (where (x integer?))
    467           (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
     477          (list 1 (vector (odd? 2) 3 (list 4 (odd?  5))))
     478          (where (x integer?)))
    468479        (list x y z))
    469480      '(1 3 4))
     
    471482
    472483(compound-test (BINDINGS)
    473   (bind?)
    474   (predicate?)
    475   (case?)
     484  (binds?)
     485  (predicates?)
     486  (cases?)
    476487  (lambdas?)
    477488  (lets?)
Note: See TracChangeset for help on using the changeset viewer.