Changeset 38805 in project


Ignore:
Timestamp:
07/27/20 17:28:24 (4 months ago)
Author:
juergen
Message:

bindings 4.0 with dotted patterns

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

Legend:

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

    r38642 r38805  
    44 (test-dependencies simple-tests biglists)
    55 (author "Juergen Lorenz")
    6  (version "3.2")
     6 (version "4.0")
    77 (components (extension bindings
    88                        (csc-options "-O3" "-d0"))))
  • release/5/bindings/tags/4.0/bindings.scm

    r38642 r38805  
    4444routine handles literals and dotted ends as well.
    4545
    46 The bind macro itself uses bind-list*, a nested version of bind-list,
     46The bind macro itself uses bind-list
    4747after having processed all literals and the wildcard, an underscore. The
    4848rule is, the wildcard matches everything but doesn't bind anything,
     
    6666  bind-list
    6767  bind-list!
    68   bind-list*
    6968  bind
    7069  bind!
     
    8584  vector-car
    8685  vector-cdr
     86  vector-null?
    8787  string-car
    8888  string-cdr
     89  string-null?
    8990  )
    9091
    9192(import scheme
    9293        (only (chicken condition) condition-case)
    93         (only (chicken base) cut subvector gensym void receive identity print case-lambda error)
     94        (only (chicken base) assert cut subvector gensym void receive identity print case-lambda error)
    9495        (only (chicken keyword) keyword?)
    9596        (only (chicken format) format)
     
    101102(define vector-car (cut vector-ref <> 0))
    102103(define vector-cdr (cut subvector <> 1))
     104(define (vector-null? vec) (zero? (vector-length vec)))
    103105(define string-car (cut string-ref <> 0))
    104106(define string-cdr (cut substring <> 1))
     107(define (string-null? str) (zero? (string-length str)))
     108
     109(define (literal? x)
     110  (or (boolean? x)
     111      (string? x)
     112      (char? x)
     113      (number? x)
     114      (keyword? x)))
     115
     116(define (dots? xpr)
     117  (and (symbol? xpr)
     118       (if (memq xpr '(.. ... ....)) #t #f)))
     119
     120(define (dotted-list? xpr)
     121  (and (list? xpr)
     122       (not (null? xpr))
     123       (dots? (car xpr))))
    105124
    106125;;; (bind-listify*)
     
    108127;;; (bind-listify* pat seq)
    109128;;; (bind-listify* seq? seq-car seq-cdr)
    110 ;;; ------------------------------------
     129;;; (bind-listify* seq? seq-car seq-cdr seq-null?)
     130;;; ----------------------------------------------
    111131;;; the first version resets the internal database,
    112 ;;; the second returns the car-cdr-pair corresponding to seq,
     132;;; the second returns the car-cdr-null? list corresponding to seq,
    113133;;; the third does the actual work transforming seq to a nested list
    114 ;;; and the last adds support for a new sequence type.
     134;;; and the last two add support for a new sequence type.
    115135(define bind-listify*
    116136  (let ((db (list (cons (lambda (x) #t)
    117                         (cons car cdr)))))
     137                        (list car cdr null?)))))
    118138    (case-lambda
    119139      (() (set! db ; reset
    120140            (list (cons (lambda (x) #t)
    121                         (cons car cdr)))))
     141                        (list car cdr null?)))))
    122142      ((seq)
    123143       (let loop ((db db))
     
    128148       (let ((gstop (gensym 'stop))
    129149             (seq-car (car (bind-listify* seq)))
    130              (seq-cdr (cdr (bind-listify* seq)))
    131              (literal? (lambda (x)
    132                          (or (boolean? x)
    133                              (string? x)
    134                              (char? x)
    135                              (number? x)
    136                              (keyword? x))))
    137              )
    138          (let ((seq-null?
    139                  (lambda (seq)
    140                    (eq? (condition-case (seq-car seq)
    141                           ((exn) gstop)) gstop))))
     150             (accessors (bind-listify* seq)))
     151         (let ((seq-cdr (cadr accessors))
     152               (seq-null?
     153                 (if (null? (cddr accessors))
     154                   (lambda (seq)
     155                     (eq? (condition-case (seq-car seq)
     156                            ((exn) gstop))
     157                          gstop))
     158                   (caddr accessors))))
    142159           (let loop ((pat pat) (seq seq) (result '()))
    143160             (cond
     
    146163                  (reverse result)
    147164                  (error 'bind-listify* "length mismatch" pat seq)))
    148                ;(reverse (cons seq result))))
     165               ((and (pair? pat) (dotted-list? (cdr pat))) ; new
     166                (let ((pfirst (car pat))
     167                      (len (- (let iloop ((seq seq) (result 0))
     168                                (if (seq-null? seq)
     169                                    result
     170                                    (iloop (seq-cdr seq) (+ result 1))))
     171                              (length (cddr pat)))))
     172                  (receive (head tail)
     173                    (let iloop ((tail seq) (k 0) (head '()))
     174                      (cond
     175                        ((seq-null? tail)
     176                         (values (reverse head) tail))
     177                        ((= k len)
     178                         (values (reverse head) tail))
     179                        (else
     180                          (iloop (seq-cdr tail)
     181                                 (+ k 1)
     182                                 (cons (seq-car tail) head)))))
     183                    ;(print "HHH" head)
     184                    (case (cadr pat)
     185                      ((..)
     186                       (assert (or (null? head) (null? (cdr head)))))
     187                      ((...)
     188                       (assert #t))
     189                      ((....)
     190                       (assert (pair? head)))
     191                      (else 'bind-listify* "can't happen"))
     192                    (cond
     193                      ((symbol?  pfirst)
     194                       (if (eq? pfirst '_)
     195                         (error 'bind-listify*
     196                                "dots mustn't follow wildcard")
     197                         (append
     198                           (reverse result)
     199                           (cons head
     200                                 (bind-listify* (cddr pat) tail)))))
     201                      ((literal? pfirst)
     202                       (error 'bind-listify*
     203                              "dots mustn't follow literal"))
     204                      ((pair? pfirst)
     205                       (assert (all-bindable? pfirst head))
     206                       (letrec
     207                         ((recompose
     208                            (lambda (pat seq)
     209                              ;;; (a (b c)) ((1 (10 100)) (2 (20 200)))
     210                              ;;; ->
     211                              ;;; (a (b c)) ((1 2) ((10 20) (100 200)))
     212                              (cond
     213                                ((null? pat) '())
     214                                ((symbol? pat) seq)
     215                                (else
     216                                  (let ((pf (car pat))
     217                                        (lf (map car
     218                                                 (map (lambda (s)
     219                                                        (bind-listify*
     220                                                          pat s))
     221                                                      seq)))
     222                                        (pr (cdr pat))
     223                                        (lr (map cdr
     224                                                 (map (lambda (s)
     225                                                        (bind-listify*
     226                                                          pat s))
     227                                                      seq))))
     228                                    (if (pair? pf)
     229                                      (cons (recompose pf lf) (recompose pr lr))
     230                                      (cons lf (recompose pr lr)))))))))
     231                         (append
     232                           (reverse result)
     233                           (cons (recompose pfirst head)
     234                                 (bind-listify* (cddr pat) tail)))))
     235                           ))))
    149236               ((pair? pat)
    150237                (let ((pfirst (car pat))
     
    164251                       (error 'bind-listify* "length mismatch"
    165252                              pfirst sfirst)))
    166                     ((pair? pfirst)
    167                      (loop prest
    168                            srest
    169                            (cons (bind-listify* pfirst sfirst) result)))
    170253                    ((literal? pfirst)
    171254                     (if (equal? pfirst sfirst)
     
    174257                              (format #f "literals ~s and ~s not equal?~%"
    175258                                      pfirst sfirst))))
     259                    ((pair? pfirst)
     260                     (loop prest
     261                           srest
     262                           (cons (bind-listify* pfirst sfirst) result)))
    176263                    (else (error 'bind-listify*
    177264                                 (format #f "~s is not a valid literal~%")
     
    196283      ((seq? seq-car seq-cdr)
    197284       (set! db (cons (cons seq?
    198                             (cons seq-car seq-cdr)) db)))
     285                            (list seq-car seq-cdr)) db)))
     286      ((seq? seq-car seq-cdr seq-null?)
     287       (set! db (cons (cons seq?
     288                            (list seq-car seq-cdr seq-null?)) db)))
    199289      )))
    200290       
    201 
    202 ;;; (bind-list pat lst . body)
    203 ;;; --------------------------
    204 ;;; flat versions of bind (symbol-lists only)
     291;;; (bind-list pat lst)
     292;;; (bind-list pat lst xpr . xprs)
     293;;; ------------------------------
     294;;; nested versions of bind (symbol-lists only)
    205295(define-syntax bind-list
    206296  (ir-macro-transformer
    207297    (lambda (form inject compare?)
    208       (let ((pat (cadr form)))
    209         (if (null? (cddr form))
    210           `(begin ,@(map (lambda (var)
    211                            `(set! ,var ',var))
    212                          pat))
    213           (let ((lst (caddr form))); (seq (gensym)))
    214             (if (null? (cdddr form))
    215               ;`(begin ,@(map (lambda (var val)
    216               ;                 `(set! ,var ,val))
    217               ;               pat (eval lst)))
    218               `(if (= ,(length pat) (length ,lst))
    219                 (begin
    220                    ,@(let loop ((pat pat) (lst lst))
    221                        (if (null? pat)
    222                          '()
    223                          (cons `(set! ,(car pat) (car ,lst))
    224                                (loop (cdr pat) `(cdr ,lst))))))
    225                 (error 'bind-list "length mismatch" ',pat ,lst))
    226               `(apply (lambda ,pat ,@(cdddr form))
    227                       ,lst))))))))
    228 ;(define-syntax bind-list
    229 ;  (syntax-rules ()
    230 ;    ((_ () ls)
    231 ;     (if (null? ls)
    232 ;       (if #f #f)
    233 ;       (error 'bind-list "length mismatch" '() ls)))
    234 ;    ((_ (a . as) ls)
    235 ;     (begin (set! a (car ls)) (bind-list as (cdr ls))))
    236 ;    ((_ pat)
    237 ;     (bind-list pat 'pat))
    238 ;    ((_ xs ls . body)
    239 ;     (apply (lambda xs . body) ls))
    240 ;    ))
    241 
     298      (let ((pat (cadr form))
     299            (lst (caddr form))
     300            (body (cdddr form))
     301            )
     302        (let* (
     303           ;; (a (b c) d) -> (a (g b c) d)
     304           (pat* (map (lambda (s)
     305                        (if (symbol? s)
     306                          s
     307                          (cons (gensym) s)))
     308                      pat))
     309           ;; (a (b c) d) -> (a g d)
     310           (flat-pat* (map (lambda (s)
     311                             (if (symbol? s)
     312                               s
     313                               (car s)))
     314                           pat*))
     315           )
     316          ;(print pat " " pat* " " flat-pat*)
     317          (receive (pairs syms) ; filter
     318            ;; (a (g b c) d) -> ((g b c)) (a d)
     319            (let loop ((lst pat*) (yes '()) (no '()))
     320              (cond
     321                ((null? lst)
     322                 (values (reverse yes) (reverse no)))
     323                ((pair? (car lst))
     324                 (loop (cdr lst) (cons (car lst) yes) no))
     325                ((symbol? (car lst))
     326                 (loop (cdr lst) yes (cons (car lst) no)))
     327                (else (error 'bind-list "can't happen"))))
     328            ;(print pairs " PS " syms)
     329            (if (null? body)
     330              ;; without body, i.e. multiple set!
     331              (if (null? pairs) ; flat list
     332                `(if (= (length ',syms) (length ,lst))
     333                   ,(let loop ((pat syms) (lst lst) (result '(begin)))
     334                      (if (null? pat)
     335                        (reverse result)
     336                        (loop (cdr pat)
     337                              `(cdr ,lst)
     338                              (cons `(set! ,(car pat) (car ,lst)) result))))
     339                   (error 'bind-list "length mismatch" ',pat ,lst))
     340                ;; (bind-list (a (b c)) '(1 (2 3)))
     341                ;; ->
     342                ;; (begin (bind-list (a g) lst)
     343                ;;        (bind-list (b c) g))
     344                `(begin (bind-list ,flat-pat* ,lst)
     345                          ,@(map (lambda (pair)
     346                                   `(bind-list ,(cdr pair) ,(car pair)))
     347                                 pairs)))
     348              ;; with body
     349              (if (null? pairs) ; flat list
     350                `(apply (lambda ,syms ,@body)
     351                        ,lst)
     352                ;; (bind-list* (a (b c)) '(1 (2 3)) body)
     353                ;; ->
     354                ;; (apply (lambda (a g) (bind-list* (b c) g body))
     355                ;; lst)
     356                `(apply
     357                   (lambda ,flat-pat*
     358                             ,(let loop ((pairs pairs))
     359                                 (if (null? pairs)
     360                                   `(begin ,@body)
     361                                   `(bind-list ,(cdar pairs)
     362                                                  ,(caar pairs)
     363                                                  ,(loop (cdr pairs))))))
     364                   ,lst))
     365              )))))))
     366
     367;;; (bind-list! pat)
    242368;;; (bind-list! pat lst)
    243 ;;; (bind-list! pat)
    244369;;; --------------------
    245370;;; list version of bind!
     
    252377    ))
    253378
    254 ;;; (bind-list* pat seq . body)
    255 ;;; ---------------------------
    256 ;;; nested versions of bind (symbol-lists only)
    257 (define-syntax bind-list*
    258   (er-macro-transformer
    259     (lambda (form rename compare?)
    260       (let ((pat (cadr form))
    261             (seq (caddr form))
    262             (body (cdddr form))
    263             (%_ (rename '_))
    264             (%let (rename 'let))
    265             (%set! (rename 'set!))
    266             (%bind (rename 'bind))
    267             (%apply (rename 'apply))
    268             (%begin (rename 'begin))
    269             (%lambda (rename 'lambda))
    270             (%bind-list (rename 'bind-list))
    271             (%bind-list* (rename 'bind-list*))
    272             )
    273           (let* ((pat* (map (lambda (s)
    274                           (if (symbol? s)
    275                             s
    276                             (cons (gensym) s)))
    277                         pat))
    278                  (flat-pat* (map (lambda (s)
    279                                    (if (symbol? s)
    280                                      s
    281                                      (car s)))
    282                                  pat*)))
    283             (receive (pairs syms)
    284               (let loop ((lst pat*) (yes '()) (no '()))
    285                 (cond
    286                   ((null? lst)
    287                    (values (reverse yes) (reverse no)))
    288                   ((pair? (car lst))
    289                    (loop (cdr lst) (cons (car lst) yes) no))
    290                   ((symbol? (car lst))
    291                    (loop (cdr lst) yes (cons (car lst) no)))
    292                   (else (error 'bind "can't happen"))))
    293               (if (null? body)
    294                 ;; without body
    295                 (if (null? pairs) ; flat list
    296                   `(,%bind-list ,syms ,seq)
    297                   ;; (bind-list* (a (b c)) '(1 (2 3)))
    298                   ;; ->
    299                   ;; (begin (bind-list (a g) seq)
    300                   ;;        (bind-list* (b c) g))
    301                   `(,%begin (,%bind-list ,flat-pat* ,seq)
    302                             ,@(map (lambda (pair)
    303                                      `(,%bind ,(cdr pair) ,(car pair)))
    304                                    pairs)))
    305                 ;; with body
    306                 (let ((xpr (car body)) (xprs (cdr body)))
    307                   (if (null? pairs) ; flat list
    308                     ;`(,%apply (,%lambda ,syms ,xpr ,@xprs) ,seq)
    309                     `(,%bind-list ,syms ,seq ,xpr ,@xprs)
    310                     ;; (bind-list* (a (b c)) '(1 (2 3)) body)
    311                     ;; ->
    312                     ;; (apply (lambda (a g) (bind-list* (b c) g body))
    313                     ;; seq)
    314                     `(,%apply
    315                        (,%lambda ,flat-pat*
    316                                  ,(let loop ((pairs pairs))
    317                                      (if (null? pairs)
    318                                        `(,%begin ,xpr ,@xprs)
    319                                        `(,%bind-list* ,(cdar pairs)
    320                                                       ,(caar pairs)
    321                                                       ,(loop (cdr pairs))))))
    322                        ,seq)
    323                      )))))))))
    324 
     379;;; (bind pat seq)
    325380;;; (bind pat seq . body)
    326381;;; ---------------------
     
    332387        (seq (caddr form))
    333388        (body (cdddr form))
    334         (%_ (rename '_))
    335         (%bind-list* (rename 'bind-list*))
     389        (%bind-list (rename 'bind-list))
    336390        (%bind-listify* (rename 'bind-listify*))
    337391        (literal? (lambda (x)
     
    341395                        (number? x)
    342396                        (keyword? x))))
     397        (dotted-list? (lambda (x)
     398                        (and (list? x)
     399                             (not (null? x))
     400                             (if (memq (car x) '(.. ... ....))
     401                               #t #f))))
    343402        )
    344403        (letrec (
     
    349408                  ((null? pat)
    350409                   (reverse result))
    351                   ((and (symbol? pat) (compare? pat %_))
     410                  ((and (symbol? pat) (eq? pat '_));(compare? pat %_))
    352411                   (reverse result))
    353412                  ((symbol? pat)
     
    356415                   (reverse result))
    357416                  ((pair? pat)
    358                    (let ((first (car pat))
    359                          (rest (cdr pat)))
    360                      (cond
    361                        ((and (symbol? first)
    362                              (compare? first %_))
    363                         (loop rest result))
    364                        ((symbol? first)
    365                         (loop rest (cons first result)))
    366                        ((null? first) ;;;
    367                         (loop rest (cons first result)))
    368                        ((pair? first)
    369                         (loop rest (cons (listify* first) result)))
    370                        ((literal? first)
    371                         (loop rest result))
    372                        )))))))
     417                   (let ((first (car pat)) (rest (cdr pat)))
     418                     (if (dotted-list? (cdr pat))
     419                       (cond
     420                         ((and (symbol? first) (eq? first '_))
     421                          (error 'bind "dots mustn't follow wildcard"))
     422                         ((symbol? first)
     423                          (loop (cdr rest) (cons first result)))
     424                         ((literal? first)
     425                          (error 'bind "dots mustn't follow literal"))
     426                         ((pair? first)
     427                          (loop (cdr rest) (cons (listify* first) result)))
     428                         )
     429                       (cond
     430                         ((and (symbol? first)
     431                               (eq? first '_));(compare? first %_))
     432                          (loop rest result))
     433                         ((symbol? first)
     434                          (loop rest (cons first result)))
     435                         ((null? first) ;;;
     436                          (loop rest (cons first result)))
     437                         ((literal? first)
     438                          (loop rest result))
     439                         ((pair? first)
     440                          (loop rest (cons (listify* first) result)))
     441                         ))))))))
    373442          )
    374443          (if (null? body)
    375444            ;; without body
    376             `(,%bind-list* ,(listify* pat)
     445            `(,%bind-list ,(listify* pat)
    377446                           (,%bind-listify* ',pat ,seq))
    378447            ;; with body
    379448            (let ((xpr (car body)) (xprs (cdr body)))
    380               `(,%bind-list* ,(listify* pat)
     449              `(,%bind-list ,(listify* pat)
    381450                             (,%bind-listify* ',pat ,seq)
    382451                             ,xpr ,@xprs)))
     
    415484       (bindable? pat seq)))
    416485    ))
     486
     487(define (all-bindable? pat lst)
     488  (let loop ((lst lst))
     489    (cond
     490      ((null? lst) #t)
     491      (((bindable? (eval pat)) (car lst)) (loop (cdr lst)))
     492      (else
     493        (error 'all-bindable? "fails in bind with " pat (car lst))))))
    417494
    418495#|[
     
    702779      generic procedure:
    703780      (bind-listify*)
    704       "resets the internal database for lists only"
    705781      (bind-listify* seq)
    706       "returns the car-cdr-pair corresponding to seq"
    707782      (bind-listify* pat seq)
    708       "transforms the nested pseudolist seq to a nested list"
    709783      (bind-listify* seq? seq-car seq-cdr)
    710       "adds support for a new sequence type to the"
    711       "internal database")
     784      (bind-listify* seq? seq-car seq-cdr seq-null?)
     785      "the first resets the internal database for lists only"
     786      "the second returns the car-cdr-pair corresponding to seq"
     787      "the third transforms the nested pseudolist seq to a nested list"
     788      "and the last two add support for a new sequence type to the"
     789      "internal database, where seq-null? is needed only if"
     790      "seq-car doesn't raise an exception on an empty sequence")
    712791    (bind-list
    713792      macro:
     793      (bind-list pat lst)
    714794      (bind-list pat lst . body)
    715       "flat version of bind: destructure symbol-lists only")
     795      "list version of bind: destructure nested symbol-lists only")
    716796    (bind-list!
    717797      macro:
    718798      (bind-list! pat lst)
    719       "alias to bind-list wtihout body"
    720799      (bind-list! pat)
    721       "alias to (bind-list! pat 'pat)")
    722     (bind-list*
    723       macro:
    724       (bind-list* pat seq . body)
    725       "nested version of bind: destructure symbol-lists only"
    726       "multiple set!s without")
     800      "the former is an alias to bind-list wtihout body"
     801      "the latter alias to (bind-list! pat 'pat)")
    727802    (bind
    728803      macro:
     804      (bind pat seq)
    729805      (bind pat seq . body)
    730806      "a variant of Common Lisp's destructuring-bind with body"
     
    818894) ; module
    819895
     896;(import bindings simple-tests)
     897;( bind-listify* vector? vector-car vector-cdr)
     898;(ppp
     899;  (bind (a (b . cs) . ds)
     900;        '(1 #(20 30 40) 2 3)
     901;    (list a b cs ds))
     902;  (bind (a (b cs ...) ds ...)
     903;        '(1 #(20 30 40) 2 3)
     904;    (list a b cs ds))
     905;  ((bind-lambda (a (b cs ...) ds ...)
     906;     (list a b cs ds))
     907;   '(1 #(20 30 40) 2 3))
     908;  )
     909;;(ppp
     910;;  (bind-listify* '(as ... b c) '(1 2 3 40 50))
     911;;  (bind-listify* '(as ... b c) '(40 50))
     912;;  (bind-listify* '(x y as ... b c) '(-2 -1 1 2 3 40 50))
     913;;  (bind-listify* '(x y as ... b c) '(-2 -1 40 50)) ; as might be null
     914;;  (bind-listify* '(a b c) '(1 2 3))
     915;;  (bind-listify* '((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5))
     916;;  (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5))
     917;;  )
     918;;
     919;(newline)
     920;;(pe '(bind (as ... d e) '(1 2 3 4 5) #f))
     921;(ppp (bind (as ... d e) '(1 2 3 4 5) (list as d e)))
     922;(ppp (bind (x y as ... d e) '(-1 0 1 2 3 4 5) (list x y as d e)))
     923;(ppp (bind (x y as .. d e) '(-1 0 4 5)  (list x y as d e)))
     924;(newline)
     925;;(pe '(bind ((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5) #f))
     926;(ppp (bind ((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5)
     927;           (list as bs cs d e)))
     928;(newline)
     929;;(pe '(bind (x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5) #f))
     930;(ppp (bind (x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5)
     931;           (list x y as bs cs d e)))
     932;(newline)
     933;;(bind-listify* string? string-car string-cdr string-null?)
     934;(bind-listify* vector? vector-car vector-cdr vector-null?)
     935;(ppp (bind (u (x y (as (bs cs)) ... d e) v) ; should be wrong: ok
     936;           '(100 #(-1 0 4 5) 200)
     937;           (list u x y as bs cs d e v)))
     938;;(ppp (bind (u (x y (as (bs cs)) .... d e) v) ; should be wrong: ok
     939;;           '(100 #(-1 0 4 5) 200)
     940;;           (list u x y as bs cs d e v)))
     941;;(ppp (bind (u (x y (as (bs cs)) ... d e) v)
     942;;           '(100 (-1 0 (1 2 3) 4 5) 200) ; should be wrong: ok
     943;;           (list u x y as bs cs d e v)))
     944;(ppp (bind (u (x y (as (bs cs)) ... d e) v)
     945;           '(100 (-1 0 (1 (2 3)) (10 (20 30)) 4 5) 200)
     946;           (list u x y as bs cs d e v)))
     947;(ppp (bind (u (x y (as (bs cs)) ... d e) v)
     948;           '(100 (-1 0 (1 (2 3)) #(10 (20 30)) 4 5) 200)
     949;           (list u x y as bs cs d e v)))
     950;;
     951;;;(ppp (bind-listify* '(1 2 3))
     952;;;     (bind-listify* "x")
     953;;;     (bind-listify* '(a . b) #(1 2 3))
     954;;;     )
     955;;;(pe '(bind-list (a (b c)) '(1 (2 3))))
     956;;;(pe '(bind-list (a (b c) d) '(1 (2 3) 4)))
     957;;;(pe '(bind-list (a (b (c d))) '(1 (2 (3 4)))))
     958;;;(pe '(bind-list (a b) '(1)))
     959;;
  • release/5/bindings/tags/4.0/tests/run.scm

    r38642 r38805  
    1818  #t
    1919  (bind-listify* "x")
    20   (cons string-car string-cdr)
     20  (list string-car string-cdr)
    2121  (bind-listify* 'a 1)
    2222  '(1)
     
    4747  (bind-listify* '(#f ()) #(#f #()))
    4848  '(())
     49  (bind-listify* '(as ... b c) '(1 2 3 40 50))
     50  '((1 2 3) 40 50)
     51  (bind-listify* '(as ... b c) '(40 50))
     52  '(() 40 50)
     53  (bind-listify* '(x y as ... b c) '(-2 -1 1 2 3 40 50))
     54  '(-2 -1 (1 2 3) 40 50)
     55  (bind-listify* '(x y as ... b c) '(-2 -1 40 50))
     56  '(-2 -1 () 40 50)
     57  (bind-listify* '((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5))
     58  '(((1 10) ((2 20) (3 30))) 4 5)
     59  (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5))
     60  '(-1 0 ((1 10) ((2 20) (3 30))) 4 5)
     61  (bind-listify* '(x y (as (bs cs)) ... d e) #(-1 0 (1 (2 3)) (10 (20 30)) 4 5))
     62  '(-1 0 ((1 10) ((2 20) (3 30))) 4 5)
     63  (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) #(10 (20 30)) 4 5))
     64  '(-1 0 ((1 10) ((2 20) (3 30))) 4 5)
     65  (bind-listify* '(x y (as (bs (cs))) ... d e)
     66                 '(-1 0 (1 (2 (3))) #(10 (20 (30))) 4 5))
     67  '(-1 0 ((1 10) ((2 20) ((3 30)))) 4 5)
    4968  )
    5069;(listify?)
     
    6180  (bind-list (a b) '(1 2) (list a b))
    6281  '(1 2)
    63   (bind-list* (x (y (z))) '(1 (2 (3))) (list x y z))
     82  (bind-list (x (y (z))) '(1 (2 (3))) (list x y z))
    6483  '(1 2 3)
    6584  (let ((x #f) (y #f))
     
    6887  #t
    6988  (let ((x #f) (y #f))
    70     (bind-list* (x (y)) '(1 (2)))
     89    (bind-list (x (y)) '(1 (2)))
    7190    (and (= x 1) (= y 2)))
    7291  #t
     
    219238    (list x y z u v w))
    220239  '(1 2 3 4 5 #(6))
     240
     241  (bind (as ... d e) '(1 2 3 4 5) (list as d e))
     242  '((1 2 3) 4 5)
     243  (bind (x y as ... d e) '(-1 0 1 2 3 4 5) (list x y as d e))
     244  '(-1 0 (1 2 3) 4 5)
     245  (bind (x y as .. d e) '(-1 0 4 5)  (list x y as d e))
     246  '(-1 0 () 4 5)
     247  (bind ((as (bs cs)) ... d e)
     248        '((1 (2 3)) (10 (20 30)) 4 5)
     249        (list as bs cs d e))
     250  '((1 10) (2 20) (3 30) 4 5)
     251  (bind ((as (bs cs)) ... d e)
     252        '((1 (2 3)) #(10 (20 30)) 4 5)
     253        (list as bs cs d e))
     254  '((1 10) (2 20) (3 30) 4 5)
     255
    221256  (bind-loop (x (a . b) y) '(5 #(1) 0)
    222257    (if (zero? x)
     
    305340  (bindable? (a b) (where (even? a) (odd? b)) '(2 2))
    306341  #f
     342  (bindable? (a (b cs .. d)) '(1 (2 3)))
     343  #t
    307344  )
    308345;(predicates?)
     
    328365  '(2 2)
    329366  (bind-case '(1 "2 3")
    330     ((x (y z)) (list x y z))
     367    ((x (y z)) #f)
    331368    ((x (y . z)) (list x y z))
    332     ((x y) (list x y)))
     369    ((x y) #t))
    333370  '(1 #\2 " 3")
    334371  (bind-case '(1 "23")
    335     ((x (y z)) (where (char-alphabetic? y)) (list x y z))
     372    ((x (y z)) (where (char-alphabetic? y)) #f)
    336373    ((x (y . z)) (list x y z))
    337     ((x y) (list x y)))
     374    ((x y) #t))
    338375  '(1 #\2 "3")
    339376  (bind-case '(1 "23")
    340     ((x (y z)) (where (char-alphabetic? y)) (list x y z))
     377    ((x (y z)) (where (char-alphabetic? y)) #f)
    341378    ((x (y . _)) (list x y))
    342     ((x y) (list x y)))
     379    ((x y) #t))
    343380  '(1 #\2)
    344381  (bind-case '(1 "23")
    345382    ((x (y z)) (where (char-numeric? y)) (list x y z))
    346     ((x (y . z)) (list x y z))
    347     ((x y) (list x y)))
     383    ((x (y . z)) #t)
     384    ((x y) #t))
    348385  '(1 #\2 #\3)
    349386  (bind-case '(1 "23")
    350387    ((x (y z)) (list x y z))
    351     ((x (y . z)) (list x y z))
    352     ((x y) (list x y)))
     388    ((x (y . z)) #t)
     389    ((x y) #t))
    353390  '(1 #\2 #\3)
    354391  (bind-case '(1 "2 3") ;
    355392    ((x (y . z)) (list x y z))
    356     ((x (y z)) (list x y z))
    357     ((x y) (list x y)))
     393    ((x (y z)) #f)
     394    ((x y) #t))
    358395  '(1 #\2 " 3")
    359396  (bind-case '(1 #(2 3))
    360     ((x y) (where (list? y)) (list x y))
     397    ((x y) (where (list? y)) #f)
    361398    ((x (y . z)) (list x y z))
    362     ((x (y z)) (list x y z)))
     399    ((x (y z)) #t))
    363400  '(1 2 #(3))
    364401  (bind-case '(1 (2 3))
    365402    ((x y) (list x y))
    366     ((x (y . z)) (list x y z))
    367     ((x (y z)) (list x y z)))
     403    ((x (y . z)) #t)
     404    ((x (y z)) #t))
    368405  '(1 (2 3))
    369406  (bind-case '(1 (2 . 3))
    370407    ((x y) (list x y))
    371     ((x (y . z)) (list x y z))
    372     ((x (y z)) (list x y z)))
     408    ((x (y . z)) #t)
     409    ((x (y z)) #f))
    373410  '(1 (2 . 3))
    374411  (bind-case '#(1 2)
    375     (() '())
    376     ((a) (list a))
     412    (() #f)
     413    ((a) #f)
    377414    ((a b) (list a b))
    378     ((a b c) (list a b c)))
    379   '(1 2)
     415    ((a b c) #f))
     416  '(1 2)
     417
     418  (bind-case '(0 4)
     419    ((a bs .... c) #f)
     420    ((a bs ... c) (list a bs c)))
     421  '(0 () 4)
     422  (bind-case '(0 1 2 3 4)
     423    ((a bs .. c) #f)
     424    ((a bs ... c) (list a bs c)))
     425  '(0 (1 2 3) 4)
     426  (bind-case '(0 #(1 (2 3)) 4)
     427    ((a (bs (cs (ds))) .. e) #f)
     428    ((a (bs (cs ds)) .. e) (list a bs cs ds e)))
     429  '(0 (1) (2) (3) 4)
     430  (bind-case '(0 4)
     431    ((a (bs (cs (ds))) .. e) (list a bs cs ds e))
     432    ((a (bs (cs ds)) .. e) #t))
     433  '(0 () () () 4)
     434  (bind-case '((0 1 2 3) (10 #(20 30)))
     435    (((a bs ...) (x (ys zs) ..)) (list a bs x ys zs)))
     436  '(0 (1 2 3) 10 (20) (30))
    380437
    381438  ;LOCAL VARIABLES IN ALL RULES
     
    421478
    422479  ;NON-SYMBOL LITERALS
    423   (bind-case #("a") ((#f) #f) (("a") #t))
     480  (bind-case #("a")
     481    ((#f) #f)
     482    (("a") #t))
    424483  #t
    425484  (bind-case (vector 1 (list (odd? 2) 3))
    426     ((x y) (where (number? y)) (list x y))
    427     ((x ("y" . z)) (list x z))
     485    ((x y) (where (number? y)) #f)
     486    ((x ("y" . z)) #f)
    428487    ((x (#f z)) (list x z)))
    429488  '(1 3)
    430489  (bind-case '(1 (#f 3))
    431490    ((x y) (list x y))
    432     ((x ("y" . z)) (list x z))
     491    ((x ("y" . z)) #f)
    433492    ((x (#f z)) (list x z)))
    434493  '(1 (#f 3))
    435494  (bind-case #(1 ("y" 3))
    436495    ((x ("y" . z)) (list x z))
    437     ((x (#f z)) (list x z)))
     496    ((x (#f z)) #f))
    438497  '(1 (3))
     498  (bind-case '((0 1 2 3) ("" #(20 30)))
     499    (((a bs ...) ("x" (ys zs) ..)) #f)
     500    (((a bs ...) ("" (ys zs) ..)) (list a bs ys zs)))
     501  '(0 (1 2 3) (20) (30))
     502
     503  (bind-case '((0 1 2 3) (10 #(20 30)))
     504    (((_ bs ... c) (_ (ys zs) ..)) (list bs c ys zs)))
     505  '((1 2) 3 (20) (30))
    439506  )
    440507;(cases?)
     
    448515         #t)
    449516  #t
    450   ((bind-lambda (a (b . c) . d)
    451      (list a b c d))
     517  ((bind-lambda (a (b cs ...) ds ...)
     518     (list a b cs ds))
     519   '(1 #(20 30 40) 2 3))
     520  '(1 20 (30 40) (2 3))
     521  ((bind-lambda (a (b (cs ds) ...) . es)
     522     (list a b cs ds es))
     523   '(1 #(20 (30 40)) 2 3))
     524  '(1 20 (30) (40) (2 3))
     525  ((bind-lambda (a (b . cs) . ds)
     526     (list a b cs ds))
    452527   '(1 #(20 30 40) 2 3))
    453528  '(1 20 #(30 40) (2 3))
     
    462537  '#(2 3 4 5)
    463538  ((bind-case-lambda
    464      ((e . f) (where (zero? e)) e)
     539     ((e . f) (where (zero? e)) #f)
    465540     ((a (b . #f) . d) (list a b d))
    466      ((e . f) (list e f)))
     541     ((e . f) #f))
    467542   '(1 (2 . #f) 4 5))
    468543  '(1 2 (4 5))
    469544  ((bind-case-lambda
    470      ((e . f) (where (zero? e)) e)
    471      ((a (b . #f) . d) (list a b d))
    472      ((e . f) (list e f))) ; match
     545     ((e . f) (where (zero? e)) #f)
     546     ((a (b . #f) (ds es) ...) (list a b ds es))
     547     ((e . f) #f))
     548   '(1 (2 . #f) (4 5) (40 50)))
     549  '(1 2 (4 40) (5 50))
     550  ((bind-case-lambda
     551     ((e . f) (where (zero? e)) #f)
     552     ((a (b . #f) . d) #f)
     553     ((e . f) (list e f)))
    473554   '(1 (2 . #t) 4 5))
    474555  '(1 ((2 . #t) 4 5))
    475556  (condition-case
    476557    ((bind-case-lambda
    477        ((e . f) (where (zero? e)) e)
    478        ((a (b . #f) . d) (list a b d)))
     558       ((e . f) (where (zero? e)) #f)
     559       ((a (b . #f) . d) #f))
    479560     '(1 (2 . #t) 4 5))
    480561    ((exn) #f))
    481562    #f
    482563  ((bind-case-lambda
    483      ((e . f) (where (zero? e)) e)
     564     ((e . f) (where (zero? e)) #f)
    484565     ((a (b "c") . d) (list a b d))
    485      ((e . f) (list e f)))
     566     ((e . f) #f))
    486567   '(1 (2 "c") 4 5))
    487568  '(1 2 (4 5))
     
    492573  '(1 2 #(3 4) (5 6))
    493574  ((bind-case-lambda
    494      ((a (b . c) . d) (where (string? a)) (list a b c d))
     575     ((a (b . c) . d) (where (string? a)) #f)
    495576     ((e . f) (list e f)))
    496577   '(1 #(2 3 4) 5 6))
     
    522603    (list x y z u v w))
    523604  '(1 2 3 4 5 6)
     605  (bind-let ((((x y) (zs ..)) '(#(1 2) ()))
     606             (u (+ 2 2))
     607             ((v w) #(5 6)))
     608    (list x y zs u v w))
     609  '(1 2 () 4 5 6)
     610  (bind-let ((((x y) (zs ..)) '(#(1 2) ()))
     611             (((us vs) ...) '((3 4) (30 40) (300 400))))
     612    (list x y zs us vs))
     613  '(1 2 () (3 30 300) (4 40 400))
    524614  (bind* loop (a b) '(5 0)
    525615    (if (zero? a)
  • release/5/bindings/trunk/bindings.egg

    r38642 r38805  
    44 (test-dependencies simple-tests biglists)
    55 (author "Juergen Lorenz")
    6  (version "3.2")
     6 (version "4.0")
    77 (components (extension bindings
    88                        (csc-options "-O3" "-d0"))))
  • release/5/bindings/trunk/bindings.scm

    r38642 r38805  
    4444routine handles literals and dotted ends as well.
    4545
    46 The bind macro itself uses bind-list*, a nested version of bind-list,
     46The bind macro itself uses bind-list
    4747after having processed all literals and the wildcard, an underscore. The
    4848rule is, the wildcard matches everything but doesn't bind anything,
     
    6666  bind-list
    6767  bind-list!
    68   bind-list*
    6968  bind
    7069  bind!
     
    8584  vector-car
    8685  vector-cdr
     86  vector-null?
    8787  string-car
    8888  string-cdr
     89  string-null?
    8990  )
    9091
    9192(import scheme
    9293        (only (chicken condition) condition-case)
    93         (only (chicken base) cut subvector gensym void receive identity print case-lambda error)
     94        (only (chicken base) assert cut subvector gensym void receive identity print case-lambda error)
    9495        (only (chicken keyword) keyword?)
    9596        (only (chicken format) format)
     
    101102(define vector-car (cut vector-ref <> 0))
    102103(define vector-cdr (cut subvector <> 1))
     104(define (vector-null? vec) (zero? (vector-length vec)))
    103105(define string-car (cut string-ref <> 0))
    104106(define string-cdr (cut substring <> 1))
     107(define (string-null? str) (zero? (string-length str)))
     108
     109(define (literal? x)
     110  (or (boolean? x)
     111      (string? x)
     112      (char? x)
     113      (number? x)
     114      (keyword? x)))
     115
     116(define (dots? xpr)
     117  (and (symbol? xpr)
     118       (if (memq xpr '(.. ... ....)) #t #f)))
     119
     120(define (dotted-list? xpr)
     121  (and (list? xpr)
     122       (not (null? xpr))
     123       (dots? (car xpr))))
    105124
    106125;;; (bind-listify*)
     
    108127;;; (bind-listify* pat seq)
    109128;;; (bind-listify* seq? seq-car seq-cdr)
    110 ;;; ------------------------------------
     129;;; (bind-listify* seq? seq-car seq-cdr seq-null?)
     130;;; ----------------------------------------------
    111131;;; the first version resets the internal database,
    112 ;;; the second returns the car-cdr-pair corresponding to seq,
     132;;; the second returns the car-cdr-null? list corresponding to seq,
    113133;;; the third does the actual work transforming seq to a nested list
    114 ;;; and the last adds support for a new sequence type.
     134;;; and the last two add support for a new sequence type.
    115135(define bind-listify*
    116136  (let ((db (list (cons (lambda (x) #t)
    117                         (cons car cdr)))))
     137                        (list car cdr null?)))))
    118138    (case-lambda
    119139      (() (set! db ; reset
    120140            (list (cons (lambda (x) #t)
    121                         (cons car cdr)))))
     141                        (list car cdr null?)))))
    122142      ((seq)
    123143       (let loop ((db db))
     
    128148       (let ((gstop (gensym 'stop))
    129149             (seq-car (car (bind-listify* seq)))
    130              (seq-cdr (cdr (bind-listify* seq)))
    131              (literal? (lambda (x)
    132                          (or (boolean? x)
    133                              (string? x)
    134                              (char? x)
    135                              (number? x)
    136                              (keyword? x))))
    137              )
    138          (let ((seq-null?
    139                  (lambda (seq)
    140                    (eq? (condition-case (seq-car seq)
    141                           ((exn) gstop)) gstop))))
     150             (accessors (bind-listify* seq)))
     151         (let ((seq-cdr (cadr accessors))
     152               (seq-null?
     153                 (if (null? (cddr accessors))
     154                   (lambda (seq)
     155                     (eq? (condition-case (seq-car seq)
     156                            ((exn) gstop))
     157                          gstop))
     158                   (caddr accessors))))
    142159           (let loop ((pat pat) (seq seq) (result '()))
    143160             (cond
     
    146163                  (reverse result)
    147164                  (error 'bind-listify* "length mismatch" pat seq)))
    148                ;(reverse (cons seq result))))
     165               ((and (pair? pat) (dotted-list? (cdr pat))) ; new
     166                (let ((pfirst (car pat))
     167                      (len (- (let iloop ((seq seq) (result 0))
     168                                (if (seq-null? seq)
     169                                    result
     170                                    (iloop (seq-cdr seq) (+ result 1))))
     171                              (length (cddr pat)))))
     172                  (receive (head tail)
     173                    (let iloop ((tail seq) (k 0) (head '()))
     174                      (cond
     175                        ((seq-null? tail)
     176                         (values (reverse head) tail))
     177                        ((= k len)
     178                         (values (reverse head) tail))
     179                        (else
     180                          (iloop (seq-cdr tail)
     181                                 (+ k 1)
     182                                 (cons (seq-car tail) head)))))
     183                    ;(print "HHH" head)
     184                    (case (cadr pat)
     185                      ((..)
     186                       (assert (or (null? head) (null? (cdr head)))))
     187                      ((...)
     188                       (assert #t))
     189                      ((....)
     190                       (assert (pair? head)))
     191                      (else 'bind-listify* "can't happen"))
     192                    (cond
     193                      ((symbol?  pfirst)
     194                       (if (eq? pfirst '_)
     195                         (error 'bind-listify*
     196                                "dots mustn't follow wildcard")
     197                         (append
     198                           (reverse result)
     199                           (cons head
     200                                 (bind-listify* (cddr pat) tail)))))
     201                      ((literal? pfirst)
     202                       (error 'bind-listify*
     203                              "dots mustn't follow literal"))
     204                      ((pair? pfirst)
     205                       (assert (all-bindable? pfirst head))
     206                       (letrec
     207                         ((recompose
     208                            (lambda (pat seq)
     209                              ;;; (a (b c)) ((1 (10 100)) (2 (20 200)))
     210                              ;;; ->
     211                              ;;; (a (b c)) ((1 2) ((10 20) (100 200)))
     212                              (cond
     213                                ((null? pat) '())
     214                                ((symbol? pat) seq)
     215                                (else
     216                                  (let ((pf (car pat))
     217                                        (lf (map car
     218                                                 (map (lambda (s)
     219                                                        (bind-listify*
     220                                                          pat s))
     221                                                      seq)))
     222                                        (pr (cdr pat))
     223                                        (lr (map cdr
     224                                                 (map (lambda (s)
     225                                                        (bind-listify*
     226                                                          pat s))
     227                                                      seq))))
     228                                    (if (pair? pf)
     229                                      (cons (recompose pf lf) (recompose pr lr))
     230                                      (cons lf (recompose pr lr)))))))))
     231                         (append
     232                           (reverse result)
     233                           (cons (recompose pfirst head)
     234                                 (bind-listify* (cddr pat) tail)))))
     235                           ))))
    149236               ((pair? pat)
    150237                (let ((pfirst (car pat))
     
    164251                       (error 'bind-listify* "length mismatch"
    165252                              pfirst sfirst)))
    166                     ((pair? pfirst)
    167                      (loop prest
    168                            srest
    169                            (cons (bind-listify* pfirst sfirst) result)))
    170253                    ((literal? pfirst)
    171254                     (if (equal? pfirst sfirst)
     
    174257                              (format #f "literals ~s and ~s not equal?~%"
    175258                                      pfirst sfirst))))
     259                    ((pair? pfirst)
     260                     (loop prest
     261                           srest
     262                           (cons (bind-listify* pfirst sfirst) result)))
    176263                    (else (error 'bind-listify*
    177264                                 (format #f "~s is not a valid literal~%")
     
    196283      ((seq? seq-car seq-cdr)
    197284       (set! db (cons (cons seq?
    198                             (cons seq-car seq-cdr)) db)))
     285                            (list seq-car seq-cdr)) db)))
     286      ((seq? seq-car seq-cdr seq-null?)
     287       (set! db (cons (cons seq?
     288                            (list seq-car seq-cdr seq-null?)) db)))
    199289      )))
    200290       
    201 
    202 ;;; (bind-list pat lst . body)
    203 ;;; --------------------------
    204 ;;; flat versions of bind (symbol-lists only)
     291;;; (bind-list pat lst)
     292;;; (bind-list pat lst xpr . xprs)
     293;;; ------------------------------
     294;;; nested versions of bind (symbol-lists only)
    205295(define-syntax bind-list
    206296  (ir-macro-transformer
    207297    (lambda (form inject compare?)
    208       (let ((pat (cadr form)))
    209         (if (null? (cddr form))
    210           `(begin ,@(map (lambda (var)
    211                            `(set! ,var ',var))
    212                          pat))
    213           (let ((lst (caddr form))); (seq (gensym)))
    214             (if (null? (cdddr form))
    215               ;`(begin ,@(map (lambda (var val)
    216               ;                 `(set! ,var ,val))
    217               ;               pat (eval lst)))
    218               `(if (= ,(length pat) (length ,lst))
    219                 (begin
    220                    ,@(let loop ((pat pat) (lst lst))
    221                        (if (null? pat)
    222                          '()
    223                          (cons `(set! ,(car pat) (car ,lst))
    224                                (loop (cdr pat) `(cdr ,lst))))))
    225                 (error 'bind-list "length mismatch" ',pat ,lst))
    226               `(apply (lambda ,pat ,@(cdddr form))
    227                       ,lst))))))))
    228 ;(define-syntax bind-list
    229 ;  (syntax-rules ()
    230 ;    ((_ () ls)
    231 ;     (if (null? ls)
    232 ;       (if #f #f)
    233 ;       (error 'bind-list "length mismatch" '() ls)))
    234 ;    ((_ (a . as) ls)
    235 ;     (begin (set! a (car ls)) (bind-list as (cdr ls))))
    236 ;    ((_ pat)
    237 ;     (bind-list pat 'pat))
    238 ;    ((_ xs ls . body)
    239 ;     (apply (lambda xs . body) ls))
    240 ;    ))
    241 
     298      (let ((pat (cadr form))
     299            (lst (caddr form))
     300            (body (cdddr form))
     301            )
     302        (let* (
     303           ;; (a (b c) d) -> (a (g b c) d)
     304           (pat* (map (lambda (s)
     305                        (if (symbol? s)
     306                          s
     307                          (cons (gensym) s)))
     308                      pat))
     309           ;; (a (b c) d) -> (a g d)
     310           (flat-pat* (map (lambda (s)
     311                             (if (symbol? s)
     312                               s
     313                               (car s)))
     314                           pat*))
     315           )
     316          ;(print pat " " pat* " " flat-pat*)
     317          (receive (pairs syms) ; filter
     318            ;; (a (g b c) d) -> ((g b c)) (a d)
     319            (let loop ((lst pat*) (yes '()) (no '()))
     320              (cond
     321                ((null? lst)
     322                 (values (reverse yes) (reverse no)))
     323                ((pair? (car lst))
     324                 (loop (cdr lst) (cons (car lst) yes) no))
     325                ((symbol? (car lst))
     326                 (loop (cdr lst) yes (cons (car lst) no)))
     327                (else (error 'bind-list "can't happen"))))
     328            ;(print pairs " PS " syms)
     329            (if (null? body)
     330              ;; without body, i.e. multiple set!
     331              (if (null? pairs) ; flat list
     332                `(if (= (length ',syms) (length ,lst))
     333                   ,(let loop ((pat syms) (lst lst) (result '(begin)))
     334                      (if (null? pat)
     335                        (reverse result)
     336                        (loop (cdr pat)
     337                              `(cdr ,lst)
     338                              (cons `(set! ,(car pat) (car ,lst)) result))))
     339                   (error 'bind-list "length mismatch" ',pat ,lst))
     340                ;; (bind-list (a (b c)) '(1 (2 3)))
     341                ;; ->
     342                ;; (begin (bind-list (a g) lst)
     343                ;;        (bind-list (b c) g))
     344                `(begin (bind-list ,flat-pat* ,lst)
     345                          ,@(map (lambda (pair)
     346                                   `(bind-list ,(cdr pair) ,(car pair)))
     347                                 pairs)))
     348              ;; with body
     349              (if (null? pairs) ; flat list
     350                `(apply (lambda ,syms ,@body)
     351                        ,lst)
     352                ;; (bind-list* (a (b c)) '(1 (2 3)) body)
     353                ;; ->
     354                ;; (apply (lambda (a g) (bind-list* (b c) g body))
     355                ;; lst)
     356                `(apply
     357                   (lambda ,flat-pat*
     358                             ,(let loop ((pairs pairs))
     359                                 (if (null? pairs)
     360                                   `(begin ,@body)
     361                                   `(bind-list ,(cdar pairs)
     362                                                  ,(caar pairs)
     363                                                  ,(loop (cdr pairs))))))
     364                   ,lst))
     365              )))))))
     366
     367;;; (bind-list! pat)
    242368;;; (bind-list! pat lst)
    243 ;;; (bind-list! pat)
    244369;;; --------------------
    245370;;; list version of bind!
     
    252377    ))
    253378
    254 ;;; (bind-list* pat seq . body)
    255 ;;; ---------------------------
    256 ;;; nested versions of bind (symbol-lists only)
    257 (define-syntax bind-list*
    258   (er-macro-transformer
    259     (lambda (form rename compare?)
    260       (let ((pat (cadr form))
    261             (seq (caddr form))
    262             (body (cdddr form))
    263             (%_ (rename '_))
    264             (%let (rename 'let))
    265             (%set! (rename 'set!))
    266             (%bind (rename 'bind))
    267             (%apply (rename 'apply))
    268             (%begin (rename 'begin))
    269             (%lambda (rename 'lambda))
    270             (%bind-list (rename 'bind-list))
    271             (%bind-list* (rename 'bind-list*))
    272             )
    273           (let* ((pat* (map (lambda (s)
    274                           (if (symbol? s)
    275                             s
    276                             (cons (gensym) s)))
    277                         pat))
    278                  (flat-pat* (map (lambda (s)
    279                                    (if (symbol? s)
    280                                      s
    281                                      (car s)))
    282                                  pat*)))
    283             (receive (pairs syms)
    284               (let loop ((lst pat*) (yes '()) (no '()))
    285                 (cond
    286                   ((null? lst)
    287                    (values (reverse yes) (reverse no)))
    288                   ((pair? (car lst))
    289                    (loop (cdr lst) (cons (car lst) yes) no))
    290                   ((symbol? (car lst))
    291                    (loop (cdr lst) yes (cons (car lst) no)))
    292                   (else (error 'bind "can't happen"))))
    293               (if (null? body)
    294                 ;; without body
    295                 (if (null? pairs) ; flat list
    296                   `(,%bind-list ,syms ,seq)
    297                   ;; (bind-list* (a (b c)) '(1 (2 3)))
    298                   ;; ->
    299                   ;; (begin (bind-list (a g) seq)
    300                   ;;        (bind-list* (b c) g))
    301                   `(,%begin (,%bind-list ,flat-pat* ,seq)
    302                             ,@(map (lambda (pair)
    303                                      `(,%bind ,(cdr pair) ,(car pair)))
    304                                    pairs)))
    305                 ;; with body
    306                 (let ((xpr (car body)) (xprs (cdr body)))
    307                   (if (null? pairs) ; flat list
    308                     ;`(,%apply (,%lambda ,syms ,xpr ,@xprs) ,seq)
    309                     `(,%bind-list ,syms ,seq ,xpr ,@xprs)
    310                     ;; (bind-list* (a (b c)) '(1 (2 3)) body)
    311                     ;; ->
    312                     ;; (apply (lambda (a g) (bind-list* (b c) g body))
    313                     ;; seq)
    314                     `(,%apply
    315                        (,%lambda ,flat-pat*
    316                                  ,(let loop ((pairs pairs))
    317                                      (if (null? pairs)
    318                                        `(,%begin ,xpr ,@xprs)
    319                                        `(,%bind-list* ,(cdar pairs)
    320                                                       ,(caar pairs)
    321                                                       ,(loop (cdr pairs))))))
    322                        ,seq)
    323                      )))))))))
    324 
     379;;; (bind pat seq)
    325380;;; (bind pat seq . body)
    326381;;; ---------------------
     
    332387        (seq (caddr form))
    333388        (body (cdddr form))
    334         (%_ (rename '_))
    335         (%bind-list* (rename 'bind-list*))
     389        (%bind-list (rename 'bind-list))
    336390        (%bind-listify* (rename 'bind-listify*))
    337391        (literal? (lambda (x)
     
    341395                        (number? x)
    342396                        (keyword? x))))
     397        (dotted-list? (lambda (x)
     398                        (and (list? x)
     399                             (not (null? x))
     400                             (if (memq (car x) '(.. ... ....))
     401                               #t #f))))
    343402        )
    344403        (letrec (
     
    349408                  ((null? pat)
    350409                   (reverse result))
    351                   ((and (symbol? pat) (compare? pat %_))
     410                  ((and (symbol? pat) (eq? pat '_));(compare? pat %_))
    352411                   (reverse result))
    353412                  ((symbol? pat)
     
    356415                   (reverse result))
    357416                  ((pair? pat)
    358                    (let ((first (car pat))
    359                          (rest (cdr pat)))
    360                      (cond
    361                        ((and (symbol? first)
    362                              (compare? first %_))
    363                         (loop rest result))
    364                        ((symbol? first)
    365                         (loop rest (cons first result)))
    366                        ((null? first) ;;;
    367                         (loop rest (cons first result)))
    368                        ((pair? first)
    369                         (loop rest (cons (listify* first) result)))
    370                        ((literal? first)
    371                         (loop rest result))
    372                        )))))))
     417                   (let ((first (car pat)) (rest (cdr pat)))
     418                     (if (dotted-list? (cdr pat))
     419                       (cond
     420                         ((and (symbol? first) (eq? first '_))
     421                          (error 'bind "dots mustn't follow wildcard"))
     422                         ((symbol? first)
     423                          (loop (cdr rest) (cons first result)))
     424                         ((literal? first)
     425                          (error 'bind "dots mustn't follow literal"))
     426                         ((pair? first)
     427                          (loop (cdr rest) (cons (listify* first) result)))
     428                         )
     429                       (cond
     430                         ((and (symbol? first)
     431                               (eq? first '_));(compare? first %_))
     432                          (loop rest result))
     433                         ((symbol? first)
     434                          (loop rest (cons first result)))
     435                         ((null? first) ;;;
     436                          (loop rest (cons first result)))
     437                         ((literal? first)
     438                          (loop rest result))
     439                         ((pair? first)
     440                          (loop rest (cons (listify* first) result)))
     441                         ))))))))
    373442          )
    374443          (if (null? body)
    375444            ;; without body
    376             `(,%bind-list* ,(listify* pat)
     445            `(,%bind-list ,(listify* pat)
    377446                           (,%bind-listify* ',pat ,seq))
    378447            ;; with body
    379448            (let ((xpr (car body)) (xprs (cdr body)))
    380               `(,%bind-list* ,(listify* pat)
     449              `(,%bind-list ,(listify* pat)
    381450                             (,%bind-listify* ',pat ,seq)
    382451                             ,xpr ,@xprs)))
     
    415484       (bindable? pat seq)))
    416485    ))
     486
     487(define (all-bindable? pat lst)
     488  (let loop ((lst lst))
     489    (cond
     490      ((null? lst) #t)
     491      (((bindable? (eval pat)) (car lst)) (loop (cdr lst)))
     492      (else
     493        (error 'all-bindable? "fails in bind with " pat (car lst))))))
    417494
    418495#|[
     
    702779      generic procedure:
    703780      (bind-listify*)
    704       "resets the internal database for lists only"
    705781      (bind-listify* seq)
    706       "returns the car-cdr-pair corresponding to seq"
    707782      (bind-listify* pat seq)
    708       "transforms the nested pseudolist seq to a nested list"
    709783      (bind-listify* seq? seq-car seq-cdr)
    710       "adds support for a new sequence type to the"
    711       "internal database")
     784      (bind-listify* seq? seq-car seq-cdr seq-null?)
     785      "the first resets the internal database for lists only"
     786      "the second returns the car-cdr-pair corresponding to seq"
     787      "the third transforms the nested pseudolist seq to a nested list"
     788      "and the last two add support for a new sequence type to the"
     789      "internal database, where seq-null? is needed only if"
     790      "seq-car doesn't raise an exception on an empty sequence")
    712791    (bind-list
    713792      macro:
     793      (bind-list pat lst)
    714794      (bind-list pat lst . body)
    715       "flat version of bind: destructure symbol-lists only")
     795      "list version of bind: destructure nested symbol-lists only")
    716796    (bind-list!
    717797      macro:
    718798      (bind-list! pat lst)
    719       "alias to bind-list wtihout body"
    720799      (bind-list! pat)
    721       "alias to (bind-list! pat 'pat)")
    722     (bind-list*
    723       macro:
    724       (bind-list* pat seq . body)
    725       "nested version of bind: destructure symbol-lists only"
    726       "multiple set!s without")
     800      "the former is an alias to bind-list wtihout body"
     801      "the latter alias to (bind-list! pat 'pat)")
    727802    (bind
    728803      macro:
     804      (bind pat seq)
    729805      (bind pat seq . body)
    730806      "a variant of Common Lisp's destructuring-bind with body"
     
    818894) ; module
    819895
     896;(import bindings simple-tests)
     897;( bind-listify* vector? vector-car vector-cdr)
     898;(ppp
     899;  (bind (a (b . cs) . ds)
     900;        '(1 #(20 30 40) 2 3)
     901;    (list a b cs ds))
     902;  (bind (a (b cs ...) ds ...)
     903;        '(1 #(20 30 40) 2 3)
     904;    (list a b cs ds))
     905;  ((bind-lambda (a (b cs ...) ds ...)
     906;     (list a b cs ds))
     907;   '(1 #(20 30 40) 2 3))
     908;  )
     909;;(ppp
     910;;  (bind-listify* '(as ... b c) '(1 2 3 40 50))
     911;;  (bind-listify* '(as ... b c) '(40 50))
     912;;  (bind-listify* '(x y as ... b c) '(-2 -1 1 2 3 40 50))
     913;;  (bind-listify* '(x y as ... b c) '(-2 -1 40 50)) ; as might be null
     914;;  (bind-listify* '(a b c) '(1 2 3))
     915;;  (bind-listify* '((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5))
     916;;  (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5))
     917;;  )
     918;;
     919;(newline)
     920;;(pe '(bind (as ... d e) '(1 2 3 4 5) #f))
     921;(ppp (bind (as ... d e) '(1 2 3 4 5) (list as d e)))
     922;(ppp (bind (x y as ... d e) '(-1 0 1 2 3 4 5) (list x y as d e)))
     923;(ppp (bind (x y as .. d e) '(-1 0 4 5)  (list x y as d e)))
     924;(newline)
     925;;(pe '(bind ((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5) #f))
     926;(ppp (bind ((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5)
     927;           (list as bs cs d e)))
     928;(newline)
     929;;(pe '(bind (x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5) #f))
     930;(ppp (bind (x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5)
     931;           (list x y as bs cs d e)))
     932;(newline)
     933;;(bind-listify* string? string-car string-cdr string-null?)
     934;(bind-listify* vector? vector-car vector-cdr vector-null?)
     935;(ppp (bind (u (x y (as (bs cs)) ... d e) v) ; should be wrong: ok
     936;           '(100 #(-1 0 4 5) 200)
     937;           (list u x y as bs cs d e v)))
     938;;(ppp (bind (u (x y (as (bs cs)) .... d e) v) ; should be wrong: ok
     939;;           '(100 #(-1 0 4 5) 200)
     940;;           (list u x y as bs cs d e v)))
     941;;(ppp (bind (u (x y (as (bs cs)) ... d e) v)
     942;;           '(100 (-1 0 (1 2 3) 4 5) 200) ; should be wrong: ok
     943;;           (list u x y as bs cs d e v)))
     944;(ppp (bind (u (x y (as (bs cs)) ... d e) v)
     945;           '(100 (-1 0 (1 (2 3)) (10 (20 30)) 4 5) 200)
     946;           (list u x y as bs cs d e v)))
     947;(ppp (bind (u (x y (as (bs cs)) ... d e) v)
     948;           '(100 (-1 0 (1 (2 3)) #(10 (20 30)) 4 5) 200)
     949;           (list u x y as bs cs d e v)))
     950;;
     951;;;(ppp (bind-listify* '(1 2 3))
     952;;;     (bind-listify* "x")
     953;;;     (bind-listify* '(a . b) #(1 2 3))
     954;;;     )
     955;;;(pe '(bind-list (a (b c)) '(1 (2 3))))
     956;;;(pe '(bind-list (a (b c) d) '(1 (2 3) 4)))
     957;;;(pe '(bind-list (a (b (c d))) '(1 (2 (3 4)))))
     958;;;(pe '(bind-list (a b) '(1)))
     959;;
  • release/5/bindings/trunk/tests/run.scm

    r38642 r38805  
    1818  #t
    1919  (bind-listify* "x")
    20   (cons string-car string-cdr)
     20  (list string-car string-cdr)
    2121  (bind-listify* 'a 1)
    2222  '(1)
     
    4747  (bind-listify* '(#f ()) #(#f #()))
    4848  '(())
     49  (bind-listify* '(as ... b c) '(1 2 3 40 50))
     50  '((1 2 3) 40 50)
     51  (bind-listify* '(as ... b c) '(40 50))
     52  '(() 40 50)
     53  (bind-listify* '(x y as ... b c) '(-2 -1 1 2 3 40 50))
     54  '(-2 -1 (1 2 3) 40 50)
     55  (bind-listify* '(x y as ... b c) '(-2 -1 40 50))
     56  '(-2 -1 () 40 50)
     57  (bind-listify* '((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5))
     58  '(((1 10) ((2 20) (3 30))) 4 5)
     59  (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5))
     60  '(-1 0 ((1 10) ((2 20) (3 30))) 4 5)
     61  (bind-listify* '(x y (as (bs cs)) ... d e) #(-1 0 (1 (2 3)) (10 (20 30)) 4 5))
     62  '(-1 0 ((1 10) ((2 20) (3 30))) 4 5)
     63  (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) #(10 (20 30)) 4 5))
     64  '(-1 0 ((1 10) ((2 20) (3 30))) 4 5)
     65  (bind-listify* '(x y (as (bs (cs))) ... d e)
     66                 '(-1 0 (1 (2 (3))) #(10 (20 (30))) 4 5))
     67  '(-1 0 ((1 10) ((2 20) ((3 30)))) 4 5)
    4968  )
    5069;(listify?)
     
    6180  (bind-list (a b) '(1 2) (list a b))
    6281  '(1 2)
    63   (bind-list* (x (y (z))) '(1 (2 (3))) (list x y z))
     82  (bind-list (x (y (z))) '(1 (2 (3))) (list x y z))
    6483  '(1 2 3)
    6584  (let ((x #f) (y #f))
     
    6887  #t
    6988  (let ((x #f) (y #f))
    70     (bind-list* (x (y)) '(1 (2)))
     89    (bind-list (x (y)) '(1 (2)))
    7190    (and (= x 1) (= y 2)))
    7291  #t
     
    219238    (list x y z u v w))
    220239  '(1 2 3 4 5 #(6))
     240
     241  (bind (as ... d e) '(1 2 3 4 5) (list as d e))
     242  '((1 2 3) 4 5)
     243  (bind (x y as ... d e) '(-1 0 1 2 3 4 5) (list x y as d e))
     244  '(-1 0 (1 2 3) 4 5)
     245  (bind (x y as .. d e) '(-1 0 4 5)  (list x y as d e))
     246  '(-1 0 () 4 5)
     247  (bind ((as (bs cs)) ... d e)
     248        '((1 (2 3)) (10 (20 30)) 4 5)
     249        (list as bs cs d e))
     250  '((1 10) (2 20) (3 30) 4 5)
     251  (bind ((as (bs cs)) ... d e)
     252        '((1 (2 3)) #(10 (20 30)) 4 5)
     253        (list as bs cs d e))
     254  '((1 10) (2 20) (3 30) 4 5)
     255
    221256  (bind-loop (x (a . b) y) '(5 #(1) 0)
    222257    (if (zero? x)
     
    305340  (bindable? (a b) (where (even? a) (odd? b)) '(2 2))
    306341  #f
     342  (bindable? (a (b cs .. d)) '(1 (2 3)))
     343  #t
    307344  )
    308345;(predicates?)
     
    328365  '(2 2)
    329366  (bind-case '(1 "2 3")
    330     ((x (y z)) (list x y z))
     367    ((x (y z)) #f)
    331368    ((x (y . z)) (list x y z))
    332     ((x y) (list x y)))
     369    ((x y) #t))
    333370  '(1 #\2 " 3")
    334371  (bind-case '(1 "23")
    335     ((x (y z)) (where (char-alphabetic? y)) (list x y z))
     372    ((x (y z)) (where (char-alphabetic? y)) #f)
    336373    ((x (y . z)) (list x y z))
    337     ((x y) (list x y)))
     374    ((x y) #t))
    338375  '(1 #\2 "3")
    339376  (bind-case '(1 "23")
    340     ((x (y z)) (where (char-alphabetic? y)) (list x y z))
     377    ((x (y z)) (where (char-alphabetic? y)) #f)
    341378    ((x (y . _)) (list x y))
    342     ((x y) (list x y)))
     379    ((x y) #t))
    343380  '(1 #\2)
    344381  (bind-case '(1 "23")
    345382    ((x (y z)) (where (char-numeric? y)) (list x y z))
    346     ((x (y . z)) (list x y z))
    347     ((x y) (list x y)))
     383    ((x (y . z)) #t)
     384    ((x y) #t))
    348385  '(1 #\2 #\3)
    349386  (bind-case '(1 "23")
    350387    ((x (y z)) (list x y z))
    351     ((x (y . z)) (list x y z))
    352     ((x y) (list x y)))
     388    ((x (y . z)) #t)
     389    ((x y) #t))
    353390  '(1 #\2 #\3)
    354391  (bind-case '(1 "2 3") ;
    355392    ((x (y . z)) (list x y z))
    356     ((x (y z)) (list x y z))
    357     ((x y) (list x y)))
     393    ((x (y z)) #f)
     394    ((x y) #t))
    358395  '(1 #\2 " 3")
    359396  (bind-case '(1 #(2 3))
    360     ((x y) (where (list? y)) (list x y))
     397    ((x y) (where (list? y)) #f)
    361398    ((x (y . z)) (list x y z))
    362     ((x (y z)) (list x y z)))
     399    ((x (y z)) #t))
    363400  '(1 2 #(3))
    364401  (bind-case '(1 (2 3))
    365402    ((x y) (list x y))
    366     ((x (y . z)) (list x y z))
    367     ((x (y z)) (list x y z)))
     403    ((x (y . z)) #t)
     404    ((x (y z)) #t))
    368405  '(1 (2 3))
    369406  (bind-case '(1 (2 . 3))
    370407    ((x y) (list x y))
    371     ((x (y . z)) (list x y z))
    372     ((x (y z)) (list x y z)))
     408    ((x (y . z)) #t)
     409    ((x (y z)) #f))
    373410  '(1 (2 . 3))
    374411  (bind-case '#(1 2)
    375     (() '())
    376     ((a) (list a))
     412    (() #f)
     413    ((a) #f)
    377414    ((a b) (list a b))
    378     ((a b c) (list a b c)))
    379   '(1 2)
     415    ((a b c) #f))
     416  '(1 2)
     417
     418  (bind-case '(0 4)
     419    ((a bs .... c) #f)
     420    ((a bs ... c) (list a bs c)))
     421  '(0 () 4)
     422  (bind-case '(0 1 2 3 4)
     423    ((a bs .. c) #f)
     424    ((a bs ... c) (list a bs c)))
     425  '(0 (1 2 3) 4)
     426  (bind-case '(0 #(1 (2 3)) 4)
     427    ((a (bs (cs (ds))) .. e) #f)
     428    ((a (bs (cs ds)) .. e) (list a bs cs ds e)))
     429  '(0 (1) (2) (3) 4)
     430  (bind-case '(0 4)
     431    ((a (bs (cs (ds))) .. e) (list a bs cs ds e))
     432    ((a (bs (cs ds)) .. e) #t))
     433  '(0 () () () 4)
     434  (bind-case '((0 1 2 3) (10 #(20 30)))
     435    (((a bs ...) (x (ys zs) ..)) (list a bs x ys zs)))
     436  '(0 (1 2 3) 10 (20) (30))
    380437
    381438  ;LOCAL VARIABLES IN ALL RULES
     
    421478
    422479  ;NON-SYMBOL LITERALS
    423   (bind-case #("a") ((#f) #f) (("a") #t))
     480  (bind-case #("a")
     481    ((#f) #f)
     482    (("a") #t))
    424483  #t
    425484  (bind-case (vector 1 (list (odd? 2) 3))
    426     ((x y) (where (number? y)) (list x y))
    427     ((x ("y" . z)) (list x z))
     485    ((x y) (where (number? y)) #f)
     486    ((x ("y" . z)) #f)
    428487    ((x (#f z)) (list x z)))
    429488  '(1 3)
    430489  (bind-case '(1 (#f 3))
    431490    ((x y) (list x y))
    432     ((x ("y" . z)) (list x z))
     491    ((x ("y" . z)) #f)
    433492    ((x (#f z)) (list x z)))
    434493  '(1 (#f 3))
    435494  (bind-case #(1 ("y" 3))
    436495    ((x ("y" . z)) (list x z))
    437     ((x (#f z)) (list x z)))
     496    ((x (#f z)) #f))
    438497  '(1 (3))
     498  (bind-case '((0 1 2 3) ("" #(20 30)))
     499    (((a bs ...) ("x" (ys zs) ..)) #f)
     500    (((a bs ...) ("" (ys zs) ..)) (list a bs ys zs)))
     501  '(0 (1 2 3) (20) (30))
     502
     503  (bind-case '((0 1 2 3) (10 #(20 30)))
     504    (((_ bs ... c) (_ (ys zs) ..)) (list bs c ys zs)))
     505  '((1 2) 3 (20) (30))
    439506  )
    440507;(cases?)
     
    448515         #t)
    449516  #t
    450   ((bind-lambda (a (b . c) . d)
    451      (list a b c d))
     517  ((bind-lambda (a (b cs ...) ds ...)
     518     (list a b cs ds))
     519   '(1 #(20 30 40) 2 3))
     520  '(1 20 (30 40) (2 3))
     521  ((bind-lambda (a (b (cs ds) ...) . es)
     522     (list a b cs ds es))
     523   '(1 #(20 (30 40)) 2 3))
     524  '(1 20 (30) (40) (2 3))
     525  ((bind-lambda (a (b . cs) . ds)
     526     (list a b cs ds))
    452527   '(1 #(20 30 40) 2 3))
    453528  '(1 20 #(30 40) (2 3))
     
    462537  '#(2 3 4 5)
    463538  ((bind-case-lambda
    464      ((e . f) (where (zero? e)) e)
     539     ((e . f) (where (zero? e)) #f)
    465540     ((a (b . #f) . d) (list a b d))
    466      ((e . f) (list e f)))
     541     ((e . f) #f))
    467542   '(1 (2 . #f) 4 5))
    468543  '(1 2 (4 5))
    469544  ((bind-case-lambda
    470      ((e . f) (where (zero? e)) e)
    471      ((a (b . #f) . d) (list a b d))
    472      ((e . f) (list e f))) ; match
     545     ((e . f) (where (zero? e)) #f)
     546     ((a (b . #f) (ds es) ...) (list a b ds es))
     547     ((e . f) #f))
     548   '(1 (2 . #f) (4 5) (40 50)))
     549  '(1 2 (4 40) (5 50))
     550  ((bind-case-lambda
     551     ((e . f) (where (zero? e)) #f)
     552     ((a (b . #f) . d) #f)
     553     ((e . f) (list e f)))
    473554   '(1 (2 . #t) 4 5))
    474555  '(1 ((2 . #t) 4 5))
    475556  (condition-case
    476557    ((bind-case-lambda
    477        ((e . f) (where (zero? e)) e)
    478        ((a (b . #f) . d) (list a b d)))
     558       ((e . f) (where (zero? e)) #f)
     559       ((a (b . #f) . d) #f))
    479560     '(1 (2 . #t) 4 5))
    480561    ((exn) #f))
    481562    #f
    482563  ((bind-case-lambda
    483      ((e . f) (where (zero? e)) e)
     564     ((e . f) (where (zero? e)) #f)
    484565     ((a (b "c") . d) (list a b d))
    485      ((e . f) (list e f)))
     566     ((e . f) #f))
    486567   '(1 (2 "c") 4 5))
    487568  '(1 2 (4 5))
     
    492573  '(1 2 #(3 4) (5 6))
    493574  ((bind-case-lambda
    494      ((a (b . c) . d) (where (string? a)) (list a b c d))
     575     ((a (b . c) . d) (where (string? a)) #f)
    495576     ((e . f) (list e f)))
    496577   '(1 #(2 3 4) 5 6))
     
    522603    (list x y z u v w))
    523604  '(1 2 3 4 5 6)
     605  (bind-let ((((x y) (zs ..)) '(#(1 2) ()))
     606             (u (+ 2 2))
     607             ((v w) #(5 6)))
     608    (list x y zs u v w))
     609  '(1 2 () 4 5 6)
     610  (bind-let ((((x y) (zs ..)) '(#(1 2) ()))
     611             (((us vs) ...) '((3 4) (30 40) (300 400))))
     612    (list x y zs us vs))
     613  '(1 2 () (3 30 300) (4 40 400))
    524614  (bind* loop (a b) '(5 0)
    525615    (if (zero? a)
Note: See TracChangeset for help on using the changeset viewer.