Changeset 39398 in project


Ignore:
Timestamp:
11/27/20 17:52:54 (5 months ago)
Author:
juergen
Message:

bindings 5.0 with new implementation

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

Legend:

Unmodified
Added
Removed

  • release/5/bindings/tags/5.0/bindings.egg

    r38814 r39398  
    1 ((synopsis "Pattern matching with destructuring bindings")
     1((synopsis "Pattern matching with destructuring bindings and setters")
    22 (category lang-exts)
    33 (license "BSD")
    44 (test-dependencies simple-tests biglists)
     5 (dependencies simple-sequences)
    56 (author "Juergen Lorenz")
    6  (version "4.1")
     7 (version "5.0")
    78 (components (extension bindings
    89                        (csc-options "-O3" "-d0"))))

  • release/5/bindings/tags/5.0/bindings.scm

    r38814 r39398  
    3333#|[
    3434Yet another implementation of the bindings egg.
    35 It's based on the bind macro, which is a variant of Common Lisp's
    36 destructuring bind.
    37 
    38 It not only destructures nested pseudolists but nested sequences as
    39 well, which can be vectors, strings, biglists or what have you, provided
    40 you have added support for those datatypes. But that's as simple as
    41 adding a triple seq? seq-car and seq-cdr to the generic transformer
    42 procedure bind-listify*. As this name suggests, every sequence is
    43 transformed to an ordinary list at each nesting level. Moreover, this
    44 routine handles literals and dotted ends as well.
    45 
    46 The bind macro itself uses bind-list
    47 after having processed all literals and the wildcard, an underscore. The
    48 rule is, the wildcard matches everything but doesn't bind anything,
    49 whereas the literals match only itself, and, of course, don't bind
    50 anything.
    51 
    52 All other macros, in particular bind-case, a variant of match in the
    53 matchable egg, are based on bind and are implemented as declarative
    54 macros.
    55 
    56 One difference to former versions of bind is, that it can be called
    57 without a body which results in setting the pattern variables to
    58 correspondig values in the nested sequence argument. In other words,
    59 this is what was called bind! before. Hence bind! and
    60 bind-define are expendable and code duplication is avoided. But for
    61 convenience of use, this version is aliased bind!
     35Sequence routines are outsourced to simple-sequences, so that an
     36enhanced version of Paul Graham's dbind (On Lisp, p. 232) can be used, a
     37variant of Common Lisp's destructuring bind.
     38
     39But this version of dbind supports setters as well, using dbind without
     40body. The reason to put it all in one huge macro is, that both variants
     41use a common set of subroutines, which are implemented within the macro
     42body. I could have put it into a helper module to be imported by syntax,
     43but this subroutines are without interest outside of dbind.
     44
     45Other enhancements include length checks of sequences, a wildcard, _,
     46which matches everything and binds nothing, literals, which match only
     47themselfs but can't of course be bound, and dots, which are extensions of
     48ellipses: two dots accept zero or one items of the same shape as the
     49nested list to its left, and four dots accept only non-empty nested
     50lists.
     51
     52Note, that dbind is not exported, but bind and bind! are exported
     53instead.
    6254]|#
    6355
    6456(module bindings (
    65   bind-listify*
    66   bind-list
    67   bind-list!
    6857  bind
    6958  bind!
    … …  
    8271  bind/cc
    8372  bindings
    84   vector-car
    85   vector-cdr
    86   vector-null?
    87   string-car
    88   string-cdr
    89   string-null?
    90   resolve-dots
    9173  )
    9274
    9375(import scheme
     76        (only simple-sequences sequence-db seq-ref seq-ref* seq-tail seq-length)
    9477        (only (chicken condition) condition-case)
    95         (only (chicken base) assert cut subvector gensym void receive identity print case-lambda error)
     78        (only (chicken base) gensym receive print case-lambda error)
    9679        (only (chicken keyword) keyword?)
    97         (only (chicken format) format)
     80        (only (chicken module) reexport)
    9881        )
    9982
    100 (import-for-syntax (only (chicken keyword) keyword?)
    101                    (only (chicken format) format))
    102 
    103 (define vector-car (cut vector-ref <> 0))
    104 (define vector-cdr (cut subvector <> 1))
    105 (define (vector-null? vec) (zero? (vector-length vec)))
    106 (define string-car (cut string-ref <> 0))
    107 (define string-cdr (cut substring <> 1))
    108 (define (string-null? str) (zero? (string-length str)))
    109 
    110 (define (literal? x)
    111   (or (boolean? x)
    112       (string? x)
    113       (char? x)
    114       (number? x)
    115       (keyword? x)))
    116 
    117 (define (dots? xpr)
    118   (and (symbol? xpr)
    119        (if (memq xpr '(.. ... ....)) #t #f)))
    120 
    121 (define (dotted-list? xpr)
    122   (and (list? xpr)
    123        (not (null? xpr))
    124        (dots? (car xpr))))
    125 
    126 ;;; (a b cs ... d e)
    127 ;;; ->
    128 ;;; (append (a) (b) cs (d) (e))
    129 ;;; to be used in body
    130 (define-syntax resolve-dots
    131   (ir-macro-transformer
    132     (lambda (form inject compare?)
    133       (let ((args (cdr form))
    134             (dots? (lambda (sym)
    135                      (or (compare? sym '..)
    136                          (compare? sym '...)
    137                          (compare? sym '....)))))
    138         (let ((lists (let loop ((args args) (result '()))
    139                        (let loop ((args args) (result '()))
    140                          (cond
    141                            ((null? args)
    142                             (reverse result))
    143                            ((null? (cdr args))
    144                             (if (dots? (car args))
    145                               (reverse result)
    146                               (reverse (cons `(list ,(car args)) result))))
    147                            (else
    148                              (cond
    149                                ((dots? (cadr args))
    150                                 (loop (cdr args)
    151                                       (cons (car args) result)))
    152                                ((dots? (car args))
    153                                 (loop (cdr args) result))
    154                                (else
    155                                 (loop (cdr args)
    156                                       (cons `(list ,(car args))
    157                                             result)))))
    158                            )))))
    159           `(append ,@lists))))))
    160 
    161 ;;; (bind-listify*)
    162 ;;; (bind-listify* seq)
    163 ;;; (bind-listify* pat seq)
    164 ;;; (bind-listify* seq? seq-car seq-cdr)
    165 ;;; (bind-listify* seq? seq-car seq-cdr seq-null?)
    166 ;;; ----------------------------------------------
    167 ;;; the first version resets the internal database,
    168 ;;; the second returns the car-cdr-null? list corresponding to seq,
    169 ;;; the third does the actual work transforming seq to a nested list
    170 ;;; and the last two add support for a new sequence type.
    171 (define bind-listify*
    172   (let ((db (list (cons (lambda (x) #t)
    173                         (list car cdr null?)))))
    174     (case-lambda
    175       (() (set! db ; reset
    176             (list (cons (lambda (x) #t)
    177                         (list car cdr null?)))))
    178       ((seq)
    179        (let loop ((db db))
    180          (if ((caar db) seq)
    181            (cdar db)
    182            (loop (cdr db)))))
    183       ((pat seq)
    184        (let ((gstop (gensym 'stop))
    185              (seq-car (car (bind-listify* seq)))
    186              (accessors (bind-listify* seq)))
    187          (let ((seq-cdr (cadr accessors))
    188                (seq-null?
    189                  (if (null? (cddr accessors))
    190                    (lambda (seq)
    191                      (eq? (condition-case (seq-car seq)
    192                             ((exn) gstop))
    193                           gstop))
    194                    (caddr accessors))))
    195            (let loop ((pat pat) (seq seq) (result '()))
    196              (cond
    197                ((null? pat)
    198                 (if (seq-null? seq)
    199                   (reverse result)
    200                   (error 'bind-listify* "length mismatch" pat seq)))
    201                ((and (pair? pat) (dotted-list? (cdr pat))) ; new
    202                 (let ((pfirst (car pat))
    203                       (len (- (let iloop ((seq seq) (result 0))
    204                                 (if (seq-null? seq)
    205                                     result
    206                                     (iloop (seq-cdr seq) (+ result 1))))
    207                               (length (cddr pat)))))
    208                   (receive (head tail)
    209                     (let iloop ((tail seq) (k 0) (head '()))
    210                       (cond
    211                         ((seq-null? tail)
    212                          (values (reverse head) tail))
    213                         ((= k len)
    214                          (values (reverse head) tail))
    215                         (else
    216                           (iloop (seq-cdr tail)
    217                                  (+ k 1)
    218                                  (cons (seq-car tail) head)))))
    219                     ;(print "HHH" head)
    220                     (case (cadr pat)
    221                       ((..)
    222                        (assert (or (null? head) (null? (cdr head)))))
    223                       ((...)
    224                        (assert #t))
    225                       ((....)
    226                        (assert (pair? head)))
    227                       (else 'bind-listify* "can't happen"))
    228                     (cond
    229                       ((symbol?  pfirst)
    230                        (if (eq? pfirst '_)
    231                          (error 'bind-listify*
    232                                 "dots mustn't follow wildcard")
    233                          (append
    234                            (reverse result)
    235                            (cons head
    236                                  (bind-listify* (cddr pat) tail)))))
    237                       ((literal? pfirst)
    238                        (error 'bind-listify*
    239                               "dots mustn't follow literal"))
    240                       ((pair? pfirst)
    241                        (assert (all-bindable? pfirst head))
    242                        (letrec
    243                          ((recompose
    244                             (lambda (pat seq)
    245                               ;;; (a (b c)) ((1 (10 100)) (2 (20 200)))
    246                               ;;; ->
    247                               ;;; (a (b c)) ((1 2) ((10 20) (100 200)))
    248                               (cond
    249                                 ((null? pat) '())
    250                                 ((symbol? pat) seq)
    251                                 (else
    252                                   (let ((pf (car pat))
    253                                         (lf (map car
    254                                                  (map (lambda (s)
    255                                                         (bind-listify*
    256                                                           pat s))
    257                                                       seq)))
    258                                         (pr (cdr pat))
    259                                         (lr (map cdr
    260                                                  (map (lambda (s)
    261                                                         (bind-listify*
    262                                                           pat s))
    263                                                       seq))))
    264                                     (if (pair? pf)
    265                                       (cons (recompose pf lf) (recompose pr lr))
    266                                       (cons lf (recompose pr lr)))))))))
    267                          (append
    268                            (reverse result)
    269                            (cons (recompose pfirst head)
    270                                  (bind-listify* (cddr pat) tail)))))
    271                            ))))
    272                ((pair? pat)
    273                 (let ((pfirst (car pat))
    274                       (prest (cdr pat))
    275                       (sfirst (seq-car seq))
    276                       (srest (seq-cdr seq)))
    277                   (cond
    278                     ((and (symbol? pfirst) (eq? pfirst '_))
    279                      (loop prest srest result))
    280                     ((symbol? pfirst)
    281                      (loop prest srest (cons sfirst result)))
    282                     ((null? pfirst) ;;;
    283                      (if (seq-null? sfirst)
    284                        (loop prest
    285                              srest
    286                              (cons (bind-listify* pfirst sfirst) result))
    287                        (error 'bind-listify* "length mismatch"
    288                               pfirst sfirst)))
    289                     ((literal? pfirst)
    290                      (if (equal? pfirst sfirst)
    291                        (loop prest srest result)
    292                        (error 'bind-listify*
    293                               (format #f "literals ~s and ~s not equal?~%"
    294                                       pfirst sfirst))))
    295                     ((pair? pfirst)
    296                      (loop prest
    297                            srest
    298                            (cons (bind-listify* pfirst sfirst) result)))
    299                     (else (error 'bind-listify*
    300                                  (format #f "~s is not a valid literal~%")
    301                                  pfirst))
    302                     )))
    303                (else
    304                  (cond
    305                    ((and (symbol? pat) (eq? pat '_))
    306                     (reverse result))
    307                    ((symbol? pat)
    308                     (reverse (cons seq result)))
    309                    ((literal? pat)
    310                     (if (equal? pat seq)
    311                       (reverse result)
    312                       (error 'bind-listify*
    313                               (format #f "literals ~s and ~s not equal?~%"
    314                                       pat seq))))
    315                    (else (error 'bind-listify*
    316                                 (format #f "~s is not a valid literal~%")
    317                                 pat))
    318                    )))))))
    319       ((seq? seq-car seq-cdr)
    320        (set! db (cons (cons seq?
    321                             (list seq-car seq-cdr)) db)))
    322       ((seq? seq-car seq-cdr seq-null?)
    323        (set! db (cons (cons seq?
    324                             (list seq-car seq-cdr seq-null?)) db)))
    325       )))
    326        
    327 ;;; (bind-list pat lst)
    328 ;;; (bind-list pat lst xpr . xprs)
    329 ;;; ------------------------------
    330 ;;; nested versions of bind (symbol-lists only)
    331 (define-syntax bind-list
    332   (ir-macro-transformer
    333     (lambda (form inject compare?)
    334       (let ((pat (cadr form))
    335             (lst (caddr form))
    336             (body (cdddr form))
    337             )
    338         (let* (
    339            ;; (a (b c) d) -> (a (g b c) d)
    340            (pat* (map (lambda (s)
    341                         (if (symbol? s)
    342                           s
    343                           (cons (gensym) s)))
    344                       pat))
    345            ;; (a (b c) d) -> (a g d)
    346            (flat-pat* (map (lambda (s)
    347                              (if (symbol? s)
    348                                s
    349                                (car s)))
    350                            pat*))
    351            )
    352           ;(print pat " " pat* " " flat-pat*)
    353           (receive (pairs syms) ; filter
    354             ;; (a (g b c) d) -> ((g b c)) (a d)
    355             (let loop ((lst pat*) (yes '()) (no '()))
    356               (cond
    357                 ((null? lst)
    358                  (values (reverse yes) (reverse no)))
    359                 ((pair? (car lst))
    360                  (loop (cdr lst) (cons (car lst) yes) no))
    361                 ((symbol? (car lst))
    362                  (loop (cdr lst) yes (cons (car lst) no)))
    363                 (else (error 'bind-list "can't happen"))))
    364             ;(print pairs " PS " syms)
    365             (if (null? body)
    366               ;; without body, i.e. multiple set!
    367               (if (null? pairs) ; flat list
    368                 `(if (= (length ',syms) (length ,lst))
    369                    ,(let loop ((pat syms) (lst lst) (result '(begin)))
    370                       (if (null? pat)
    371                         (reverse result)
    372                         (loop (cdr pat)
    373                               `(cdr ,lst)
    374                               (cons `(set! ,(car pat) (car ,lst)) result))))
    375                    (error 'bind-list "length mismatch" ',pat ,lst))
    376                 ;; (bind-list (a (b c)) '(1 (2 3)))
    377                 ;; ->
    378                 ;; (begin (bind-list (a g) lst)
    379                 ;;        (bind-list (b c) g))
    380                 `(begin (bind-list ,flat-pat* ,lst)
    381                           ,@(map (lambda (pair)
    382                                    `(bind-list ,(cdr pair) ,(car pair)))
    383                                  pairs)))
    384               ;; with body
    385               (if (null? pairs) ; flat list
    386                 `(apply (lambda ,syms ,@body)
    387                         ,lst)
    388                 ;; (bind-list* (a (b c)) '(1 (2 3)) body)
    389                 ;; ->
    390                 ;; (apply (lambda (a g) (bind-list* (b c) g body))
    391                 ;; lst)
    392                 `(apply
    393                    (lambda ,flat-pat*
    394                              ,(let loop ((pairs pairs))
    395                                  (if (null? pairs)
    396                                    `(begin ,@body)
    397                                    `(bind-list ,(cdar pairs)
    398                                                   ,(caar pairs)
    399                                                   ,(loop (cdr pairs))))))
    400                    ,lst))
    401               )))))))
    402 
    403 ;;; (bind-list! pat)
    404 ;;; (bind-list! pat lst)
    405 ;;; --------------------
    406 ;;; list version of bind!
    407 (define-syntax bind-list!
    408   (syntax-rules ()
    409     ((_ pat lst)
    410      (bind-list pat lst))
    411     ((_ pat)
    412      (bind-list pat 'pat))
    413     ))
    414 
    415 ;;; (bind pat seq)
    416 ;;; (bind pat seq . body)
    417 ;;; ---------------------
    418 ;;; Note, that the destructuring of pat and seq happen at different
    419 ;;; times: The former at compile-time, the latter at run-time.
    420 ;;; Consequently, some code in bind almost duplicates some code in
    421 ;;; bind-listify*.
    422 (define-syntax bind
     83(reexport (only simple-sequences sequence-db))
     84
     85(import-for-syntax (only (chicken keyword) keyword?))
     86
     87;;; Graham's dbind for sequences with length checks, literals,
     88;;; wildcard and dots, as well as setters.
     89(define-syntax dbind
    42390  (er-macro-transformer
    42491    (lambda (form rename compare?)
    42592      (let (
    426         (pat (cadr form))
    427         (seq (caddr form))
    428         (body (cdddr form))
     93        (%x (rename 'x))
    42994        (%_ (rename '_))
    430         (%bind-list (rename 'bind-list))
    431         (%bind-listify* (rename 'bind-listify*))
    432         (literal? (lambda (x)
    433                     (or (boolean? x)
    434                         (string? x)
    435                         (char? x)
    436                         (number? x)
    437                         (keyword? x))))
    438         (dotted-list? (lambda (x)
    439                         (and (list? x)
    440                              (not (null? x))
    441                              (if (memq (car x) '(.. ... ....))
    442                                #t #f))))
     95        (%.. (rename '..))
     96        (%... (rename '...))
     97        (%.... (rename '....))
     98        (%if (rename 'if))
     99        (%or (rename 'or))
     100        (%map (rename 'map))
     101        (%let (rename 'let))
     102        (%set! (rename 'set!))
     103        (%begin (rename 'begin))
     104        (%error (rename 'error))
     105        (%zero? (rename 'zero?))
     106        (%equal? (rename 'equal?))
     107        (%lambda (rename 'lambda))
     108        (%seq-ref (rename 'seq-ref))
     109        (%seq-ref* (rename 'seq-ref*))
     110        (%seq-tail (rename 'seq-tail))
     111        (%seq-length (rename 'seq-length))
     112        (%positive? (rename 'positive?))
    443113        )
    444114        (letrec (
    445           (listify*
     115          (literal?
     116            (lambda (p)
     117              (or (boolean? p)
     118                  (char? p)
     119                  (number? p)
     120                  (string?  p)
     121                  (keyword?  p))))
     122          (mappend
     123            (lambda (fn lists)
     124              (apply append (map fn lists))))
     125          (dots?
     126            (lambda (sym)
     127              (or (compare? sym %..)
     128                  (compare? sym %...)
     129                  (compare? sym %....))))
     130          (check-dots
     131            (lambda (sym seq)
     132              `(,(gensym)
     133                (,%if
     134                  ,(cond
     135                    ((compare? sym %..)
     136                     `(,%or (,%zero? (,%seq-length ,seq))
     137                            (,%zero? (,%seq-length (,%seq-tail ,seq 1)))))
     138                    ((compare? sym %...) #t)
     139                    ((compare? sym %....)
     140                     `(,%positive? (,%seq-length ,seq))))
     141                  (,%seq-length ,seq)
     142                  (,%error 'check-dots "wrong size for this dots" ,seq ',sym)))))
     143          (indices
     144            ;;; (a b) -> ((a . 0) (b . 1))
     145            ;;; (a (b (c))) -> ((a . 0) (b 1 . 0) (c 1 1 . 0))
    446146            (lambda (pat)
    447               (let loop ((pat pat) (result '()))
    448                 (cond
    449                   ((null? pat)
    450                    (reverse result))
    451                   ((and (symbol? pat) ;(eq? pat '_))
    452                         (compare? pat %_))
    453                    (reverse result))
    454                   ((symbol? pat)
    455                    (reverse (cons pat result)))
    456                   ((literal? pat)
    457                    (reverse result))
    458                   ((and (pair? pat) (dotted-list? (cdr pat)))
    459                    (let ((first (car pat)) (rest (cdr pat)))
    460                      (cond
    461                        ((and (symbol? first) (eq? first '_))
    462                         (error 'bind "dots mustn't follow wildcard"))
    463                        ((symbol? first)
    464                         (loop (cdr rest) (cons first result)))
    465                        ((literal? first)
    466                         (error 'bind "dots mustn't follow literal"))
    467                        ((pair? first)
    468                         (loop (cdr rest) (cons (listify* first) result)))
    469                        )))
    470                   ((pair? pat)
    471                    (let ((first (car pat)) (rest (cdr pat)))
    472                      (cond
    473                        ((and (symbol? first) ;(eq? first '_))
    474                              (compare? first %_))
    475                         (loop rest result))
    476                        ((symbol? first)
    477                         (loop rest (cons first result)))
    478                        ((null? first) ;;;
    479                         (loop rest (cons first result)))
    480                        ((literal? first)
    481                         (loop rest result))
    482                        ((pair? first)
    483                         (loop rest (cons (listify* first) result)))
    484                        )))
    485                   ))))
     147              (receive (flat ind)
     148                (let recur ((pat pat) (k 0))
     149                  (cond
     150                    ((null? pat)
     151                     (values '() '()))
     152                    ((pair? pat)
     153                     (let ((p (car pat)) (ps (cdr pat)))
     154                       (receive (p* i*) (recur p 0)
     155                         (receive (ps* is*) (recur ps (+ k 1))
     156                           (if (pair? p)
     157                             (values (append p* ps*)
     158                                     (append (map (lambda (x) (cons k x)) i*)
     159                                             is*))
     160                             (values (cons p ps*)
     161                                     (cons k is*)))))))
     162                    (else ;symbol
     163                     (values '() '()))))
     164                  (map cons flat ind))))
     165          (map-seq-ref*
     166            ;;; '(a (b c)) '((1 (2 3)) (10 (20 30)))
     167            ;;; ->
     168            ;;; '((a (1 10))) (b (2 30)) (c (3 30)))
     169            (lambda (pat seqs)
     170              (let recur ((pi (indices pat)))
     171                (if (null? pi)
     172                  '()
     173                  (let ((api (car pi)) (dpi (cdr pi)))
     174                    (cons (list (car api)
     175                                `(,%map (,%lambda (,%x)
     176                                          (,%seq-ref* ,%x ',(cdr api)))
     177                                        ,seqs))
     178                          (recur dpi)))))))
     179          (destruc
     180            ;; (destruc '(a (b . c) . d) 'seq)
     181            ;; ->
     182            ;; ((a (seq 0))
     183            ;;  ((#!g (seq 1)) (b (#!g 0)) (c (#!g 1 #f)))
     184            ;;  (d (seq 2 #f)))
     185            (lambda (pat seq)
     186              (let loop ((pat pat) (seq seq) (n 0))
     187                (if (pair? pat)
     188                  (let ((p (car pat))
     189                        (q (cdr pat))
     190                        (recu (loop (cdr pat) seq (+ n 1))))
     191                    (cond
     192                      ((symbol? p)
     193                       (cond
     194                         ((compare? p %_) ; wildcard
     195                          recu)
     196                         ((and (pair? q) (dots? (car q))) ;;;;
     197                          ;(print p " PQ " q)
     198                          (let ((seqs `(,%seq-tail ,seq ,n)))
     199                            ;(cons (list p seqs) '()))) ;ok, ohne checks
     200                            (cons (list (check-dots (car q) seqs)
     201                                        (list p seqs))
     202                                  '())))
     203                         (else
     204                           (cons `(,p (,%seq-ref ,seq ,n)) recu))))
     205                      ;; literals
     206                      ((literal? p)
     207                       (cons `(,(gensym)
     208                                (,%if (,%equal? (,%seq-ref ,seq ,n) ,p)
     209                                  #t
     210                                  (,%error 'dbind
     211                                           "literals don't match"
     212                                           (,%seq-ref ,seq ,n) ,p)))
     213                             recu))
     214                      ;; pair
     215                      (else
     216                        (cond
     217                          ((and (pair? q) (dots? (car q))) ;;;;;
     218                           (let ((seqs `(,%seq-tail ,seq ,n)))
     219                             (cons (cons (check-dots (car q) seqs)
     220                                         (map-seq-ref* p seqs))
     221                                   '())))
     222                          (else
     223                            (let ((g (gensym)))
     224                              (cons (cons `(,g (,%seq-ref ,seq ,n))
     225                                          (loop p g 0))
     226                                    recu)))))) )
     227                  (let ((tail `(,%seq-tail ,seq ,n)))
     228                    (cond
     229                      ((null? pat)
     230                        `((,(gensym)
     231                            (,%if (,%zero? (,%seq-length ,tail))
     232                              #t
     233                              (,%error 'dbind
     234                                     "tail not empty?"
     235                                     ,tail)))))
     236                      ((literal? pat)  ;;;;;;
     237                       `((,(gensym)
     238                          (,%if (,%equal? (,%seq-tail ,seq ,n) ,pat)
     239                            #t
     240                            (,%error 'dbind
     241                                     "literals don't match"
     242                                     (,%seq-tail ,seq ,n) ,pat)))))
     243                      (else `((,pat ,tail)))))))))
     244          (dbind-ex
     245            ;; ->
     246            ;; (let ((a (seq 0)) (#!g (seq 1)) (d (seq 2 #f)))
     247            ;;   (let ((b (#!g 0)) (c (#!g 1 #f)))
     248            ;;     (begin body)))
     249            (lambda (binds body)
     250              (if (null? binds)
     251                `(,%begin ,@body)
     252                `(,%let ,(map (lambda (b)
     253                                (if (pair? (car b)) (car b) b))
     254                              binds)
     255                   ,(dbind-ex (mappend (lambda (b)
     256                                         (if (pair? (car b))
     257                                             (cdr b)
     258                                             '()))
     259                                       binds)
     260                              body)))))
     261          (dbind-set
     262            ;; ->
     263            ;; (begin
     264            ;;   (set! a (seq 0)) (set! #!g (seq 1)) (set! d (seq 2 #f))
     265            ;;   (set! b (#!g 0)) (set! c (#!g 1 #f)))
     266            (lambda (binds)
     267              (mappend (lambda (b)
     268                         (if (pair? (car b))
     269                             (cons `(,%set! ,(caar b) ,(cadar b))
     270                                   (dbind-set (cdr b)))
     271                             (list `(,%set! ,(car b) ,(cadr b)))))
     272                       binds)))
    486273          )
    487           (if (null? body)
    488             ;; without body
    489             `(,%bind-list ,(listify* pat)
    490                            (,%bind-listify* ',pat ,seq))
    491             ;; with body
    492             (let ((xpr (car body)) (xprs (cdr body)))
    493               `(,%bind-list ,(listify* pat)
    494                              (,%bind-listify* ',pat ,seq)
    495                              ,xpr ,@xprs)))
    496           )))))
     274          (let ((pat (cadr form))
     275                (seq (caddr form))
     276                (body (cdddr form))
     277                (gseq (gensym 'seq)))
     278            `(,%let ((,gseq ,seq))
     279               ,(if (null? body)
     280                  ;; setters
     281                  (cond
     282                    ((null? pat)
     283                     `(,%if (,%zero? (,%seq-length ,gseq))
     284                        (,%if #f #f)
     285                        (,%error 'dbind "seq too long" ,gseq ',pat)))
     286                    ((compare? pat %_)
     287                     `(,%if #f #f))
     288                    ((literal? pat)
     289                     `(,%if (,%equal? ,pat ,gseq)
     290                        (,%if #f #f)
     291                        (,%error 'dbind "literals don't match"
     292                                 ,pat ,gseq)))
     293                    ((symbol? pat)
     294                     `(,%set! ,pat ,gseq))
     295                    ((pair? pat)
     296                     `(,%begin ,@(dbind-set (destruc pat gseq)))))
     297                  ;; binders
     298                  (cond
     299                    ((null? pat)
     300                     `(,%if (,%zero? (,%seq-length ,gseq))
     301                        (,%begin ,@body)
     302                        (,%error 'dbind "seq too long" ,gseq ',pat)))
     303                    ((compare? pat %_)
     304                     `(,%begin ,@body))
     305                    ((literal? pat)
     306                     `(,%if (,%equal? ,pat ,gseq)
     307                        (,%begin ,@body)
     308                        (,%error 'dbind "literals don't match"
     309                                 ,pat ,gseq)))
     310                    ((symbol? pat)
     311                     `(,%let ((,pat ,gseq)) ,@body))
     312                    ((pair? pat)
     313                     (dbind-ex (destruc pat gseq) body)))
     314                  ))))))))
     315
     316;;; (bind pat seq xpr . xprs)
     317;;; -------------------------
     318;;; binds pattern variables of pat to corresponding places in seq
     319;;; and executes body xpr . xprs in this context.
     320;;; Literals, wildcard, length checks and dots are supported.
     321(define-syntax bind
     322  (syntax-rules ()
     323    ((_ pat seq xpr . xprs)
     324     (dbind pat seq xpr . xprs))))
    497325
    498326;;; (bind! pat seq)
    499327;;; (bind! pat)
    500328;;; ---------------
    501 ;;; alias to bind without body
     329;;; setters corresponding to bind
    502330(define-syntax bind!
    503331  (syntax-rules ()
    504332    ((_ pat seq)
    505      (bind pat seq))
     333     (dbind pat seq))
    506334    ((_ pat)
    507      (bind pat 'pat))))
     335     (dbind pat 'pat))))
    508336
    509337;;; (bindable? pat (where . fenders) seq)
    … …  
    515343  (syntax-rules (where)
    516344    ((_ pat (where fender ...) seq)
    517      (condition-case (bind pat seq (and fender ...))
     345     (condition-case (dbind pat seq (and fender ...))
    518346       ((exn) #f)))
    519347    ((_ pat seq)
    520      (condition-case (bind pat seq #t)
     348     (condition-case (dbind pat seq #t)
    521349       ((exn) #f)))
    522350    ;; curried versions
    … …  
    567395    ((_ seq (pat (where fender ...) xpr . xprs))
    568396     (if (bindable? pat (where fender ...) seq)
    569        (bind pat seq xpr . xprs)
     397       (dbind pat seq xpr . xprs)
    570398       (error 'bind-seq "sequence doesn't match pattern with fenders"
    571399              seq 'pat 'fender ...)))
    572400    ((_ seq (pat xpr . xprs))
    573401     (if (bindable? pat seq)
    574        (bind pat seq xpr . xprs)
     402       (dbind pat seq xpr . xprs)
    575403       (error 'bind-seq "sequence doesn't match pattern" seq 'pat)))
    576404    ((_ seq (pat (where fender ...) xpr . xprs) . clauses)
    577405     (if (bindable? pat (where fender ...) seq)
    578        (bind pat seq xpr . xprs)
     406       (dbind pat seq xpr . xprs)
    579407       (bind-case seq . clauses)))
    580408    ((_ seq (pat xpr . xprs) . clauses)
    581409     (if (bindable? pat seq)
    582        (bind pat seq xpr . xprs)
     410       (dbind pat seq xpr . xprs)
    583411       (bind-case seq . clauses)))
    584412    ))
    … …  
    605433  (syntax-rules ()
    606434    ((_ pat xpr . xprs)
    607      (lambda (x) (bind pat x xpr . xprs)))
     435     (lambda (x) (dbind pat x xpr . xprs)))
    608436    ))
    609437
    … …  
    614442  (syntax-rules ()
    615443    ((_ pat xpr . xprs)
    616      (lambda x (bind pat x xpr . xprs)))
     444     (lambda x (dbind pat x xpr . xprs)))
    617445     ))
    618446
    … …  
    685513
    686514;;; (bind-loop pat seq xpr ....)
    687 ;;; ---- ------------------------
     515;;; ----------------------------
    688516;;; anaphoric version of bind, introducing loop routine behind the scene
    689517(define-syntax bind-loop
    … …  
    745573     (let () xpr . xprs))
    746574    ((_ ((pat seq)) xpr . xprs)
    747      (bind pat seq xpr . xprs))
     575     (dbind pat seq xpr . xprs))
    748576    ((_ ((pat seq) (pat1 seq1) ...) xpr . xprs)
    749      (bind pat seq (bind-let* ((pat1 seq1) ...) xpr . xprs)))
     577     (dbind pat seq (bind-let* ((pat1 seq1) ...) xpr . xprs)))
    750578     ))
    751579
    … …  
    757585  (syntax-rules ()
    758586    ((_ ((pat seq) ...) xpr . xprs)
    759      (bind (pat ...) (list seq ...) xpr . xprs))
     587     (dbind (pat ...) (list seq ...) xpr . xprs))
    760588    ((_ name ((pat seq) ...) xpr . xprs)
    761589     ((letrec ((name (bind-lambda* (pat ...) xpr . xprs)))
    … …  
    780608  (syntax-rules ()
    781609    ((_ pat seq xpr . xprs)
    782      (bind pat 'pat
     610     (dbind pat 'pat
    783611       (bind! pat seq)
    784612       xpr . xprs))))
    … …  
    816644(define bindings
    817645  (symbol-dispatcher '(
     646    (sequence-db
     647      procedure:
     648      (sequence-db)
     649      (sequence-db seq)
     650      (sequence-db seq? seq-length seq-ref seq-tail seq-maker . pos?)
     651      "sequence database processing, reexported from simple-sequences:"
     652      "the first resets the database to the standard with"
     653      "lists, pairs, vectors and strings,"
     654      "the second returns the vector of handlers as well as the discriminator,"
     655      "the third adds a new database record either at the end or before the"
     656      "pos? discriminator."
     657      "A record cosists of a discriminator, seq?, and a vector with items"
     658      "seq-lenth, seq-ref, seq-tail and seq-maker patterned after vectors."
     659      "Note, that the last record can handle atoms, albeit it is not a"
     660      "sequence."
     661      )
    818662    (bindings
    819663      procedure:
    820664      (bindings sym ..)
    821665      "documentation procedure")
    822     (bind-listify*
    823       generic procedure:
    824       (bind-listify*)
    825       (bind-listify* seq)
    826       (bind-listify* pat seq)
    827       (bind-listify* seq? seq-car seq-cdr)
    828       (bind-listify* seq? seq-car seq-cdr seq-null?)
    829       "the first resets the internal database for lists only"
    830       "the second returns the car-cdr-pair corresponding to seq"
    831       "the third transforms the nested pseudolist seq to a nested list"
    832       "and the last two add support for a new sequence type to the"
    833       "internal database, where seq-null? is needed only if"
    834       "seq-car doesn't raise an exception on an empty sequence")
    835     (bind-list
    836       macro:
    837       (bind-list pat lst)
    838       (bind-list pat lst . body)
    839       "list version of bind: destructure nested symbol-lists only")
    840     (bind-list!
    841       macro:
    842       (bind-list! pat lst)
    843       (bind-list! pat)
    844       "the former is an alias to bind-list wtihout body"
    845       "the latter alias to (bind-list! pat 'pat)")
    846666    (bind
    847667      macro:
    … …  
    918738      "binds cc to the current contiunation"
    919739      "and execute xpr ... in this context")
    920     (resolve-dots
    921       macro:
    922       (resolve-dots . args)
    923       "where args is a list of items which might be followed by dots."
    924       "The item before dots must be a list, which is spliced into"
    925       "the resulting list removing the dots")
    926     (vector-car
    927       procedure:
    928       (vector-car vec)
    929       "vector-analog of car")
    930     (vector-cdr
    931       procedure:
    932       (vector-cdr vec)
    933       "vector-analog of cdr")
    934     (vector-null?
    935       procedure:
    936       (vector-null? vec)
    937       "vector-analog of null?")
    938     (string-car
    939       procedure:
    940       (string-car str)
    941       "string-analog of car")
    942     (string-cdr
    943       procedure:
    944       (string-cdr str)
    945       "string-analog of cdr")
    946     (string-null?
    947       procedure:
    948       (string-null? str)
    949       "string-analog of null?")
    950740    )))
    951741
    952742) ; module
    953743
    954 ;(import bindings simple-tests)
    955 

  • release/5/bindings/tags/5.0/tests/run.scm

    r38814 r39398  
    77        (chicken base)
    88        (chicken condition)
     9        biglists
    910        )
    1011
    11 (define-checks (listify? verbose?)
    12   (begin ;; reset internal database
    13          (bind-listify*)
    14          ;; add support for vectors and strings
    15          (bind-listify* vector? vector-car vector-cdr)
    16          (bind-listify* string? string-car string-cdr)
    17          #t)
    18   #t
    19   (bind-listify* "x")
    20   (list string-car string-cdr)
    21   (bind-listify* 'a 1)
    22   '(1)
    23   (bind-listify* '(a . as) #(1 2 3))
    24   '(1 #(2 3))
    25   (bind-listify* '(a (b #f) c) '(1 #(2 #f) 3))
    26   '(1 (2) 3)
    27   (bind-listify* '(a (b (c _ . cs) d) . es) #(1 (2 (3 30 300) 4) 50))
    28   '(1 (2 (3 (300)) 4) #(50))
    29   (bind-listify* '(a (_ b _) c) '(1 (20 30 40) 5))
    30   '(1 (30) 5)
    31   (bind-listify* '(a (_ b _) . c) '(1 (20 30 40) 5))
    32   '(1 (30) (5))
    33   (bind-listify* '(a (_ b _) . c) '(1 #(20 30 40) 5))
    34   '(1 (30) (5))
    35   (bind-listify* '(a (_ b _) . c) '(1 "xyz" 5))
    36   '(1 (#\y) (5))
    37   (bind-listify* '(x) "x")
    38   '(#\x)
    39   (bind-listify* '(x . y) "xyz")
    40   '(#\x "yz")
    41   (bind-listify* 'x 1)
    42   '(1)
    43   (bind-listify* '(x) #(1))
    44   '(1)
    45   (bind-listify* '(x . y) #(1 2 3))
    46   '(1 #(2 3))
    47   (bind-listify* '(#f ()) #(#f #()))
    48   '(())
    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)
    68   )
    69 ;(listify?)
    70 
    71 (define-checks (lists-only? verbose?)
    72   (begin ;; reset internal database
    73          (bind-listify*)
    74          #t)
    75   #t
    76   ;; this would work with string support:
    77   (condition-case (bind (x) "x" x)
    78     ((exn) #f))
    79   #f
    80   (bind-list (a b) '(1 2) (list a b))
    81   '(1 2)
    82   (bind-list (x (y (z))) '(1 (2 (3))) (list x y z))
    83   '(1 2 3)
    84   (let ((x #f) (y #f))
    85     (bind-list (x y) '(1 2))
    86     (and (= x 1) (= y 2)))
    87   #t
    88   (let ((x #f) (y #f))
    89     (bind-list (x (y)) '(1 (2)))
    90     (and (= x 1) (= y 2)))
    91   #t
    92   (let ((lst '()))
    93     (bind-list (push top pop)
    94       (list
    95         (lambda (xpr) (set! lst (cons xpr lst)))
    96         (lambda () (car lst))
    97         (lambda () (set! lst (cdr lst))))
    98       (push 0)
    99       (push 1)
    100       (pop)
    101       (top)))
    102   0
    103   (let ()
    104     (bind-list! (u v w))
    105     (and (eq? u 'u) (eq? v 'v) (eq? w 'w)))
    106   #t
    107   )
    108 ;(lists-only?)
    109 
    11012(define stack #f) (define push! #f) (define pop! #f)
    11113
    11214(define-checks (defines? verbose?)
    113   (begin ;; reset internal database
    114          (bind-listify*)
    115          ;; add support for vectors and strings
    116          (bind-listify* vector? vector-car vector-cdr)
    117          (bind-listify* string? string-car string-cdr)
    118          #t)
    119   #t
    12015  (let ((x #f) (y #f) (z #f))
    12116    (bind! (x (y . z))
    … …  
    20095  #t
    20196  )
    202 ;(defines?)
     97;(defines?) ; ok
    20398
    20499(define-checks (binds? verbose?)
    205   (begin ;; reset internal database
    206          (bind-listify*)
    207          ;; add support for vectors and strings
    208          (bind-listify* vector? vector-car vector-cdr)
    209          (bind-listify* string? string-car string-cdr)
    210          #t)
    211   #t
    212100  (bind a 1 a)
     101  1
     102  (bind (a #f) '(1 #f) a)
    213103  1
    214104  (bind (a b) '(1 2) (list a b))
    … …  
    239129  '(1 2 3 4 5 #(6))
    240130
    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)
     131  (bind (as ...) '(1 2 3) (list as))
     132  '((1 2 3))
     133  (bind (x y as ...) '(-1 0 1 2 3) (list x y as))
     134  '(-1 0 (1 2 3))
     135  (bind (x y as ..) '(-1 0)  (list x y as))
     136  '(-1 0 ())
     137  (bind ((as (bs cs)) ...)
     138        '((1 (2 3)) (10 (20 30)))
     139        (list as bs cs))
     140  '((1 10) (2 20) (3 30))
     141  (bind ((as (bs cs)) ...)
     142        '((1 (2 3)) #(10 (20 30)))
     143        (list as bs cs))
     144  '((1 10) (2 20) (3 30))
    255145
    256146  (bind-loop (x (a . b) y) '(5 #(1) 0)
    … …  
    312202  #f
    313203  )
    314 ;(binds?)
    315 ;
     204;(binds?) ; ok
     205
    316206(define-checks (predicates? verbose?)
    317   (begin ;; reset internal database
    318          (bind-listify*)
    319          ;; add support for vectors and strings
    320          (bind-listify* vector? vector-car vector-cdr)
    321          (bind-listify* string? string-car string-cdr)
    322          #t)
    323   #t
    324207  ((bindable? (x)) '(name 1))
    325208  #f
    … …  
    343226  #t
    344227  )
    345 ;(predicates?)
     228;(predicates?) ; ok
    346229
    347230(define my-map #f)
    … …  
    350233
    351234(define-checks (cases? verbose?)
    352   (begin ;; reset internal database
    353          (bind-listify*)
    354          ;; add support for vectors and strings
    355          (bind-listify* vector? vector-car vector-cdr)
    356          (bind-listify* string? string-car string-cdr)
    357          #t)
    358   #t
    359235  (bind-case #() (() #f))
    360236  #f
    … …  
    410286  '(1 (2 . 3))
    411287  (bind-case '#(1 2)
    412     (() #f)
     288    ;(() #f)  ;;;;;;;
    413289    ((a) #f)
    414290    ((a b) (list a b))
    … …  
    417293
    418294  (bind-case '(0 4)
    419     ((a bs .... c) #f)
    420     ((a bs ... c) (list a bs c)))
    421   '(0 () 4)
     295    ((a bs ....) #f)
     296    ((a bs ...) (list a bs)))
     297  #f
    422298  (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)
     299    ((a bs ..) #f)
     300    ((a bs ...) (list a bs)))
     301  '(0 (1 2 3 4))
     302  (bind-case '(0 #(1 (2 3)))
     303    ((a (bs (cs (ds))) ..) #f)
     304    ((a (bs (cs ds)) ..) (list a bs cs ds)))
     305  '(0 (1) (2) (3))
     306  (bind-case '(0)
     307    ((a (bs (cs (ds))) ..) (list a bs cs ds))
     308    ((a (bs (cs ds)) ..) #t))
     309  '(0 () () ())
    434310  (bind-case '((0 1 2 3) (10 #(20 30)))
    435311    (((a bs ...) (x (ys zs) ..)) (list a bs x ys zs)))
    … …  
    441317      (let loop ((lst lst) (result '()))
    442318        (bind-case lst
    443           (() (reverse result))
     319          (() (reverse result))  ;;;;;
    444320          ((x . xs)
    445321           (loop xs (cons (fn x) result)))))))
    … …  
    453329        (let loop ((vec vec))
    454330          (bind-case vec
    455             (() result)
     331            (() result)  ;;;;;;;
    456332            ((x . xs)
    457333             (vector-set! result
    … …  
    502378
    503379  (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))
     380    (((_ bs ...) (_ (ys zs) ..)) (list bs ys zs)))
     381  '((1 2 3) (20) (30))
    506382  )
    507383;(cases?)
    508384
    509385(define-checks (lambdas? verbose?)
    510   (begin ;; reset internal database
    511          (bind-listify*)
    512          ;; add support for vectors and strings
    513          (bind-listify* vector? vector-car vector-cdr)
    514          (bind-listify* string? string-car string-cdr)
    515          #t)
    516   #t
    517386  ((bind-lambda (a (b cs ...) ds ...)
    518387     (list a b cs ds))
    519388   '(1 #(20 30 40) 2 3))
    520   '(1 20 (30 40) (2 3))
     389  '(1 20 #(30 40) (2 3))
    521390  ((bind-lambda (a (b (cs ds) ...) . es)
    522391     (list a b cs ds es))
    523    '(1 #(20 (30 40)) 2 3))
     392   '(1 (20 (30 40)) 2 3))
     393   ;'(1 #(20 (30 40)) 2 3))
    524394  '(1 20 (30) (40) (2 3))
    525395  ((bind-lambda (a (b . cs) . ds)
    … …  
    591461
    592462(define-checks (lets? verbose?)
    593   (begin ;; reset internal database
    594          (bind-listify*)
    595          ;; add support for vectors and strings
    596          (bind-listify* vector? vector-car vector-cdr)
    597          (bind-listify* string? string-car string-cdr)
    598          #t)
    599   #t
    600463  (bind-let ((((x y) z) '(#(1 2) 3))
    601464             (u (+ 2 2))
    … …  
    647510;(lets?)
    648511
    649 (import biglists)
    650 ;
    651512(define (integers-from n)
    652513  (Cons n (integers-from (+ n 1)) #f))
    653514(define integers (integers-from 0))
    654 (define (Car xs) (At 0 xs))
    655 (define (Cdr xs) (Drop 1 xs))
     515(define 5integers (Take 5 integers))
     516(define standard-checkers (sequence-db))
     517(define checkers
     518  ;; add finite lazy list handlers at the front
     519  (sequence-db List?
     520               Length
     521               (lambda (xs k) (At k xs))
     522               (lambda (xs k) (Drop k xs))
     523               List
     524               list?))
    656525
    657526(define-checks (biglists? verbose?)
    658   (begin ;; reset internal database
    659          (bind-listify*)
    660          ;; add vector and biglist support
    661          (bind-listify* vector? vector-car vector-cdr)
    662          (bind-listify* BigList? Car Cdr)
    663          #t)
    664   #t
    665   (bind (x y . zs) integers (Car zs))
     527  (if (memq List? standard-checkers) #t #f)
     528  #f
     529  (if (memq List? checkers) #t #f)
     530  #t
     531  (car checkers)
     532  List?
     533  (List? 5integers)
     534  #t
     535  (bind (x y . zs) 5integers (At 0 zs))
    666536  2
    667   (bind (_ _ . zs) integers (Car zs))
     537  (bind (_ _ . zs) 5integers (At 0 zs))
    668538  2
    669539  (bind (x #f (_ (b . cs) . zs))
    670         (vector 1 #f (List 10 integers 2 3))
    671         (list x b (Car cs) (Car zs) (At 1 zs)))
     540        (vector 1 #f (List 10 5integers 2 3))
     541        (list x b (At 0 cs) (At 0 zs) (At 1 zs)))
    672542  '(1 0 1 2 3)
    673543  )
    674544;(biglists?)
    675545
    676 (define-checks (dots? verbose?)
    677   (resolve-dots '(1 2 3) ...)
    678   '(1 2 3)
    679   (resolve-dots 1 2 '(30 40) .. 5)
    680   '(1 2 30 40 5)
    681   (resolve-dots 1 2 '() .. 5)
    682   '(1 2 5)
    683   (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7)
    684   '(1 20 30 4 40 50 60 7)
    685 )
    686 ;(dots?)
     546;(define-checks (dots? verbose?)
     547;  (resolve-dots '(1 2 3) ...)
     548;  '(1 2 3)
     549;  (resolve-dots 1 2 '(30 40) .. 5)
     550;  '(1 2 30 40 5)
     551;  (resolve-dots 1 2 '() .. 5)
     552;  '(1 2 5)
     553;  (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7)
     554;  '(1 20 30 4 40 50 60 7)
     555;)
     556;;(dots?)
    687557
    688558(check-all BINDINGS
    689   (listify?)
    690   (lists-only?)
    691559  (defines?)
    692560  (binds?)
    … …  
    696564  (lets?)
    697565  (biglists?)
    698   (dots?)
    699   )
    700 
     566  )
     567

  • release/5/bindings/trunk/bindings.egg

    r38814 r39398  
    1 ((synopsis "Pattern matching with destructuring bindings")
     1((synopsis "Pattern matching with destructuring bindings and setters")
    22 (category lang-exts)
    33 (license "BSD")
    44 (test-dependencies simple-tests biglists)
     5 (dependencies simple-sequences)
    56 (author "Juergen Lorenz")
    6  (version "4.1")
     7 (version "5.0")
    78 (components (extension bindings
    89                        (csc-options "-O3" "-d0"))))

  • release/5/bindings/trunk/bindings.scm

    r38814 r39398  
    3333#|[
    3434Yet another implementation of the bindings egg.
    35 It's based on the bind macro, which is a variant of Common Lisp's
    36 destructuring bind.
    37 
    38 It not only destructures nested pseudolists but nested sequences as
    39 well, which can be vectors, strings, biglists or what have you, provided
    40 you have added support for those datatypes. But that's as simple as
    41 adding a triple seq? seq-car and seq-cdr to the generic transformer
    42 procedure bind-listify*. As this name suggests, every sequence is
    43 transformed to an ordinary list at each nesting level. Moreover, this
    44 routine handles literals and dotted ends as well.
    45 
    46 The bind macro itself uses bind-list
    47 after having processed all literals and the wildcard, an underscore. The
    48 rule is, the wildcard matches everything but doesn't bind anything,
    49 whereas the literals match only itself, and, of course, don't bind
    50 anything.
    51 
    52 All other macros, in particular bind-case, a variant of match in the
    53 matchable egg, are based on bind and are implemented as declarative
    54 macros.
    55 
    56 One difference to former versions of bind is, that it can be called
    57 without a body which results in setting the pattern variables to
    58 correspondig values in the nested sequence argument. In other words,
    59 this is what was called bind! before. Hence bind! and
    60 bind-define are expendable and code duplication is avoided. But for
    61 convenience of use, this version is aliased bind!
     35Sequence routines are outsourced to simple-sequences, so that an
     36enhanced version of Paul Graham's dbind (On Lisp, p. 232) can be used, a
     37variant of Common Lisp's destructuring bind.
     38
     39But this version of dbind supports setters as well, using dbind without
     40body. The reason to put it all in one huge macro is, that both variants
     41use a common set of subroutines, which are implemented within the macro
     42body. I could have put it into a helper module to be imported by syntax,
     43but this subroutines are without interest outside of dbind.
     44
     45Other enhancements include length checks of sequences, a wildcard, _,
     46which matches everything and binds nothing, literals, which match only
     47themselfs but can't of course be bound, and dots, which are extensions of
     48ellipses: two dots accept zero or one items of the same shape as the
     49nested list to its left, and four dots accept only non-empty nested
     50lists.
     51
     52Note, that dbind is not exported, but bind and bind! are exported
     53instead.
    6254]|#
    6355
    6456(module bindings (
    65   bind-listify*
    66   bind-list
    67   bind-list!
    6857  bind
    6958  bind!
    … …  
    8271  bind/cc
    8372  bindings
    84   vector-car
    85   vector-cdr
    86   vector-null?
    87   string-car
    88   string-cdr
    89   string-null?
    90   resolve-dots
    9173  )
    9274
    9375(import scheme
     76        (only simple-sequences sequence-db seq-ref seq-ref* seq-tail seq-length)
    9477        (only (chicken condition) condition-case)
    95         (only (chicken base) assert cut subvector gensym void receive identity print case-lambda error)
     78        (only (chicken base) gensym receive print case-lambda error)
    9679        (only (chicken keyword) keyword?)
    97         (only (chicken format) format)
     80        (only (chicken module) reexport)
    9881        )
    9982
    100 (import-for-syntax (only (chicken keyword) keyword?)
    101                    (only (chicken format) format))
    102 
    103 (define vector-car (cut vector-ref <> 0))
    104 (define vector-cdr (cut subvector <> 1))
    105 (define (vector-null? vec) (zero? (vector-length vec)))
    106 (define string-car (cut string-ref <> 0))
    107 (define string-cdr (cut substring <> 1))
    108 (define (string-null? str) (zero? (string-length str)))
    109 
    110 (define (literal? x)
    111   (or (boolean? x)
    112       (string? x)
    113       (char? x)
    114       (number? x)
    115       (keyword? x)))
    116 
    117 (define (dots? xpr)
    118   (and (symbol? xpr)
    119        (if (memq xpr '(.. ... ....)) #t #f)))
    120 
    121 (define (dotted-list? xpr)
    122   (and (list? xpr)
    123        (not (null? xpr))
    124        (dots? (car xpr))))
    125 
    126 ;;; (a b cs ... d e)
    127 ;;; ->
    128 ;;; (append (a) (b) cs (d) (e))
    129 ;;; to be used in body
    130 (define-syntax resolve-dots
    131   (ir-macro-transformer
    132     (lambda (form inject compare?)
    133       (let ((args (cdr form))
    134             (dots? (lambda (sym)
    135                      (or (compare? sym '..)
    136                          (compare? sym '...)
    137                          (compare? sym '....)))))
    138         (let ((lists (let loop ((args args) (result '()))
    139                        (let loop ((args args) (result '()))
    140                          (cond
    141                            ((null? args)
    142                             (reverse result))
    143                            ((null? (cdr args))
    144                             (if (dots? (car args))
    145                               (reverse result)
    146                               (reverse (cons `(list ,(car args)) result))))
    147                            (else
    148                              (cond
    149                                ((dots? (cadr args))
    150                                 (loop (cdr args)
    151                                       (cons (car args) result)))
    152                                ((dots? (car args))
    153                                 (loop (cdr args) result))
    154                                (else
    155                                 (loop (cdr args)
    156                                       (cons `(list ,(car args))
    157                                             result)))))
    158                            )))))
    159           `(append ,@lists))))))
    160 
    161 ;;; (bind-listify*)
    162 ;;; (bind-listify* seq)
    163 ;;; (bind-listify* pat seq)
    164 ;;; (bind-listify* seq? seq-car seq-cdr)
    165 ;;; (bind-listify* seq? seq-car seq-cdr seq-null?)
    166 ;;; ----------------------------------------------
    167 ;;; the first version resets the internal database,
    168 ;;; the second returns the car-cdr-null? list corresponding to seq,
    169 ;;; the third does the actual work transforming seq to a nested list
    170 ;;; and the last two add support for a new sequence type.
    171 (define bind-listify*
    172   (let ((db (list (cons (lambda (x) #t)
    173                         (list car cdr null?)))))
    174     (case-lambda
    175       (() (set! db ; reset
    176             (list (cons (lambda (x) #t)
    177                         (list car cdr null?)))))
    178       ((seq)
    179        (let loop ((db db))
    180          (if ((caar db) seq)
    181            (cdar db)
    182            (loop (cdr db)))))
    183       ((pat seq)
    184        (let ((gstop (gensym 'stop))
    185              (seq-car (car (bind-listify* seq)))
    186              (accessors (bind-listify* seq)))
    187          (let ((seq-cdr (cadr accessors))
    188                (seq-null?
    189                  (if (null? (cddr accessors))
    190                    (lambda (seq)
    191                      (eq? (condition-case (seq-car seq)
    192                             ((exn) gstop))
    193                           gstop))
    194                    (caddr accessors))))
    195            (let loop ((pat pat) (seq seq) (result '()))
    196              (cond
    197                ((null? pat)
    198                 (if (seq-null? seq)
    199                   (reverse result)
    200                   (error 'bind-listify* "length mismatch" pat seq)))
    201                ((and (pair? pat) (dotted-list? (cdr pat))) ; new
    202                 (let ((pfirst (car pat))
    203                       (len (- (let iloop ((seq seq) (result 0))
    204                                 (if (seq-null? seq)
    205                                     result
    206                                     (iloop (seq-cdr seq) (+ result 1))))
    207                               (length (cddr pat)))))
    208                   (receive (head tail)
    209                     (let iloop ((tail seq) (k 0) (head '()))
    210                       (cond
    211                         ((seq-null? tail)
    212                          (values (reverse head) tail))
    213                         ((= k len)
    214                          (values (reverse head) tail))
    215                         (else
    216                           (iloop (seq-cdr tail)
    217                                  (+ k 1)
    218                                  (cons (seq-car tail) head)))))
    219                     ;(print "HHH" head)
    220                     (case (cadr pat)
    221                       ((..)
    222                        (assert (or (null? head) (null? (cdr head)))))
    223                       ((...)
    224                        (assert #t))
    225                       ((....)
    226                        (assert (pair? head)))
    227                       (else 'bind-listify* "can't happen"))
    228                     (cond
    229                       ((symbol?  pfirst)
    230                        (if (eq? pfirst '_)
    231                          (error 'bind-listify*
    232                                 "dots mustn't follow wildcard")
    233                          (append
    234                            (reverse result)
    235                            (cons head
    236                                  (bind-listify* (cddr pat) tail)))))
    237                       ((literal? pfirst)
    238                        (error 'bind-listify*
    239                               "dots mustn't follow literal"))
    240                       ((pair? pfirst)
    241                        (assert (all-bindable? pfirst head))
    242                        (letrec
    243                          ((recompose
    244                             (lambda (pat seq)
    245                               ;;; (a (b c)) ((1 (10 100)) (2 (20 200)))
    246                               ;;; ->
    247                               ;;; (a (b c)) ((1 2) ((10 20) (100 200)))
    248                               (cond
    249                                 ((null? pat) '())
    250                                 ((symbol? pat) seq)
    251                                 (else
    252                                   (let ((pf (car pat))
    253                                         (lf (map car
    254                                                  (map (lambda (s)
    255                                                         (bind-listify*
    256                                                           pat s))
    257                                                       seq)))
    258                                         (pr (cdr pat))
    259                                         (lr (map cdr
    260                                                  (map (lambda (s)
    261                                                         (bind-listify*
    262                                                           pat s))
    263                                                       seq))))
    264                                     (if (pair? pf)
    265                                       (cons (recompose pf lf) (recompose pr lr))
    266                                       (cons lf (recompose pr lr)))))))))
    267                          (append
    268                            (reverse result)
    269                            (cons (recompose pfirst head)
    270                                  (bind-listify* (cddr pat) tail)))))
    271                            ))))
    272                ((pair? pat)
    273                 (let ((pfirst (car pat))
    274                       (prest (cdr pat))
    275                       (sfirst (seq-car seq))
    276                       (srest (seq-cdr seq)))
    277                   (cond
    278                     ((and (symbol? pfirst) (eq? pfirst '_))
    279                      (loop prest srest result))
    280                     ((symbol? pfirst)
    281                      (loop prest srest (cons sfirst result)))
    282                     ((null? pfirst) ;;;
    283                      (if (seq-null? sfirst)
    284                        (loop prest
    285                              srest
    286                              (cons (bind-listify* pfirst sfirst) result))
    287                        (error 'bind-listify* "length mismatch"
    288                               pfirst sfirst)))
    289                     ((literal? pfirst)
    290                      (if (equal? pfirst sfirst)
    291                        (loop prest srest result)
    292                        (error 'bind-listify*
    293                               (format #f "literals ~s and ~s not equal?~%"
    294                                       pfirst sfirst))))
    295                     ((pair? pfirst)
    296                      (loop prest
    297                            srest
    298                            (cons (bind-listify* pfirst sfirst) result)))
    299                     (else (error 'bind-listify*
    300                                  (format #f "~s is not a valid literal~%")
    301                                  pfirst))
    302                     )))
    303                (else
    304                  (cond
    305                    ((and (symbol? pat) (eq? pat '_))
    306                     (reverse result))
    307                    ((symbol? pat)
    308                     (reverse (cons seq result)))
    309                    ((literal? pat)
    310                     (if (equal? pat seq)
    311                       (reverse result)
    312                       (error 'bind-listify*
    313                               (format #f "literals ~s and ~s not equal?~%"
    314                                       pat seq))))
    315                    (else (error 'bind-listify*
    316                                 (format #f "~s is not a valid literal~%")
    317                                 pat))
    318                    )))))))
    319       ((seq? seq-car seq-cdr)
    320        (set! db (cons (cons seq?
    321                             (list seq-car seq-cdr)) db)))
    322       ((seq? seq-car seq-cdr seq-null?)
    323        (set! db (cons (cons seq?
    324                             (list seq-car seq-cdr seq-null?)) db)))
    325       )))
    326        
    327 ;;; (bind-list pat lst)
    328 ;;; (bind-list pat lst xpr . xprs)
    329 ;;; ------------------------------
    330 ;;; nested versions of bind (symbol-lists only)
    331 (define-syntax bind-list
    332   (ir-macro-transformer
    333     (lambda (form inject compare?)
    334       (let ((pat (cadr form))
    335             (lst (caddr form))
    336             (body (cdddr form))
    337             )
    338         (let* (
    339            ;; (a (b c) d) -> (a (g b c) d)
    340            (pat* (map (lambda (s)
    341                         (if (symbol? s)
    342                           s
    343                           (cons (gensym) s)))
    344                       pat))
    345            ;; (a (b c) d) -> (a g d)
    346            (flat-pat* (map (lambda (s)
    347                              (if (symbol? s)
    348                                s
    349                                (car s)))
    350                            pat*))
    351            )
    352           ;(print pat " " pat* " " flat-pat*)
    353           (receive (pairs syms) ; filter
    354             ;; (a (g b c) d) -> ((g b c)) (a d)
    355             (let loop ((lst pat*) (yes '()) (no '()))
    356               (cond
    357                 ((null? lst)
    358                  (values (reverse yes) (reverse no)))
    359                 ((pair? (car lst))
    360                  (loop (cdr lst) (cons (car lst) yes) no))
    361                 ((symbol? (car lst))
    362                  (loop (cdr lst) yes (cons (car lst) no)))
    363                 (else (error 'bind-list "can't happen"))))
    364             ;(print pairs " PS " syms)
    365             (if (null? body)
    366               ;; without body, i.e. multiple set!
    367               (if (null? pairs) ; flat list
    368                 `(if (= (length ',syms) (length ,lst))
    369                    ,(let loop ((pat syms) (lst lst) (result '(begin)))
    370                       (if (null? pat)
    371                         (reverse result)
    372                         (loop (cdr pat)
    373                               `(cdr ,lst)
    374                               (cons `(set! ,(car pat) (car ,lst)) result))))
    375                    (error 'bind-list "length mismatch" ',pat ,lst))
    376                 ;; (bind-list (a (b c)) '(1 (2 3)))
    377                 ;; ->
    378                 ;; (begin (bind-list (a g) lst)
    379                 ;;        (bind-list (b c) g))
    380                 `(begin (bind-list ,flat-pat* ,lst)
    381                           ,@(map (lambda (pair)
    382                                    `(bind-list ,(cdr pair) ,(car pair)))
    383                                  pairs)))
    384               ;; with body
    385               (if (null? pairs) ; flat list
    386                 `(apply (lambda ,syms ,@body)
    387                         ,lst)
    388                 ;; (bind-list* (a (b c)) '(1 (2 3)) body)
    389                 ;; ->
    390                 ;; (apply (lambda (a g) (bind-list* (b c) g body))
    391                 ;; lst)
    392                 `(apply
    393                    (lambda ,flat-pat*
    394                              ,(let loop ((pairs pairs))
    395                                  (if (null? pairs)
    396                                    `(begin ,@body)
    397                                    `(bind-list ,(cdar pairs)
    398                                                   ,(caar pairs)
    399                                                   ,(loop (cdr pairs))))))
    400                    ,lst))
    401               )))))))
    402 
    403 ;;; (bind-list! pat)
    404 ;;; (bind-list! pat lst)
    405 ;;; --------------------
    406 ;;; list version of bind!
    407 (define-syntax bind-list!
    408   (syntax-rules ()
    409     ((_ pat lst)
    410      (bind-list pat lst))
    411     ((_ pat)
    412      (bind-list pat 'pat))
    413     ))
    414 
    415 ;;; (bind pat seq)
    416 ;;; (bind pat seq . body)
    417 ;;; ---------------------
    418 ;;; Note, that the destructuring of pat and seq happen at different
    419 ;;; times: The former at compile-time, the latter at run-time.
    420 ;;; Consequently, some code in bind almost duplicates some code in
    421 ;;; bind-listify*.
    422 (define-syntax bind
     83(reexport (only simple-sequences sequence-db))
     84
     85(import-for-syntax (only (chicken keyword) keyword?))
     86
     87;;; Graham's dbind for sequences with length checks, literals,
     88;;; wildcard and dots, as well as setters.
     89(define-syntax dbind
    42390  (er-macro-transformer
    42491    (lambda (form rename compare?)
    42592      (let (
    426         (pat (cadr form))
    427         (seq (caddr form))
    428         (body (cdddr form))
     93        (%x (rename 'x))
    42994        (%_ (rename '_))
    430         (%bind-list (rename 'bind-list))
    431         (%bind-listify* (rename 'bind-listify*))
    432         (literal? (lambda (x)
    433                     (or (boolean? x)
    434                         (string? x)
    435                         (char? x)
    436                         (number? x)
    437                         (keyword? x))))
    438         (dotted-list? (lambda (x)
    439                         (and (list? x)
    440                              (not (null? x))
    441                              (if (memq (car x) '(.. ... ....))
    442                                #t #f))))
     95        (%.. (rename '..))
     96        (%... (rename '...))
     97        (%.... (rename '....))
     98        (%if (rename 'if))
     99        (%or (rename 'or))
     100        (%map (rename 'map))
     101        (%let (rename 'let))
     102        (%set! (rename 'set!))
     103        (%begin (rename 'begin))
     104        (%error (rename 'error))
     105        (%zero? (rename 'zero?))
     106        (%equal? (rename 'equal?))
     107        (%lambda (rename 'lambda))
     108        (%seq-ref (rename 'seq-ref))
     109        (%seq-ref* (rename 'seq-ref*))
     110        (%seq-tail (rename 'seq-tail))
     111        (%seq-length (rename 'seq-length))
     112        (%positive? (rename 'positive?))
    443113        )
    444114        (letrec (
    445           (listify*
     115          (literal?
     116            (lambda (p)
     117              (or (boolean? p)
     118                  (char? p)
     119                  (number? p)
     120                  (string?  p)
     121                  (keyword?  p))))
     122          (mappend
     123            (lambda (fn lists)
     124              (apply append (map fn lists))))
     125          (dots?
     126            (lambda (sym)
     127              (or (compare? sym %..)
     128                  (compare? sym %...)
     129                  (compare? sym %....))))
     130          (check-dots
     131            (lambda (sym seq)
     132              `(,(gensym)
     133                (,%if
     134                  ,(cond
     135                    ((compare? sym %..)
     136                     `(,%or (,%zero? (,%seq-length ,seq))
     137                            (,%zero? (,%seq-length (,%seq-tail ,seq 1)))))
     138                    ((compare? sym %...) #t)
     139                    ((compare? sym %....)
     140                     `(,%positive? (,%seq-length ,seq))))
     141                  (,%seq-length ,seq)
     142                  (,%error 'check-dots "wrong size for this dots" ,seq ',sym)))))
     143          (indices
     144            ;;; (a b) -> ((a . 0) (b . 1))
     145            ;;; (a (b (c))) -> ((a . 0) (b 1 . 0) (c 1 1 . 0))
    446146            (lambda (pat)
    447               (let loop ((pat pat) (result '()))
    448                 (cond
    449                   ((null? pat)
    450                    (reverse result))
    451                   ((and (symbol? pat) ;(eq? pat '_))
    452                         (compare? pat %_))
    453                    (reverse result))
    454                   ((symbol? pat)
    455                    (reverse (cons pat result)))
    456                   ((literal? pat)
    457                    (reverse result))
    458                   ((and (pair? pat) (dotted-list? (cdr pat)))
    459                    (let ((first (car pat)) (rest (cdr pat)))
    460                      (cond
    461                        ((and (symbol? first) (eq? first '_))
    462                         (error 'bind "dots mustn't follow wildcard"))
    463                        ((symbol? first)
    464                         (loop (cdr rest) (cons first result)))
    465                        ((literal? first)
    466                         (error 'bind "dots mustn't follow literal"))
    467                        ((pair? first)
    468                         (loop (cdr rest) (cons (listify* first) result)))
    469                        )))
    470                   ((pair? pat)
    471                    (let ((first (car pat)) (rest (cdr pat)))
    472                      (cond
    473                        ((and (symbol? first) ;(eq? first '_))
    474                              (compare? first %_))
    475                         (loop rest result))
    476                        ((symbol? first)
    477                         (loop rest (cons first result)))
    478                        ((null? first) ;;;
    479                         (loop rest (cons first result)))
    480                        ((literal? first)
    481                         (loop rest result))
    482                        ((pair? first)
    483                         (loop rest (cons (listify* first) result)))
    484                        )))
    485                   ))))
     147              (receive (flat ind)
     148                (let recur ((pat pat) (k 0))
     149                  (cond
     150                    ((null? pat)
     151                     (values '() '()))
     152                    ((pair? pat)
     153                     (let ((p (car pat)) (ps (cdr pat)))
     154                       (receive (p* i*) (recur p 0)
     155                         (receive (ps* is*) (recur ps (+ k 1))
     156                           (if (pair? p)
     157                             (values (append p* ps*)
     158                                     (append (map (lambda (x) (cons k x)) i*)
     159                                             is*))
     160                             (values (cons p ps*)
     161                                     (cons k is*)))))))
     162                    (else ;symbol
     163                     (values '() '()))))
     164                  (map cons flat ind))))
     165          (map-seq-ref*
     166            ;;; '(a (b c)) '((1 (2 3)) (10 (20 30)))
     167            ;;; ->
     168            ;;; '((a (1 10))) (b (2 30)) (c (3 30)))
     169            (lambda (pat seqs)
     170              (let recur ((pi (indices pat)))
     171                (if (null? pi)
     172                  '()
     173                  (let ((api (car pi)) (dpi (cdr pi)))
     174                    (cons (list (car api)
     175                                `(,%map (,%lambda (,%x)
     176                                          (,%seq-ref* ,%x ',(cdr api)))
     177                                        ,seqs))
     178                          (recur dpi)))))))
     179          (destruc
     180            ;; (destruc '(a (b . c) . d) 'seq)
     181            ;; ->
     182            ;; ((a (seq 0))
     183            ;;  ((#!g (seq 1)) (b (#!g 0)) (c (#!g 1 #f)))
     184            ;;  (d (seq 2 #f)))
     185            (lambda (pat seq)
     186              (let loop ((pat pat) (seq seq) (n 0))
     187                (if (pair? pat)
     188                  (let ((p (car pat))
     189                        (q (cdr pat))
     190                        (recu (loop (cdr pat) seq (+ n 1))))
     191                    (cond
     192                      ((symbol? p)
     193                       (cond
     194                         ((compare? p %_) ; wildcard
     195                          recu)
     196                         ((and (pair? q) (dots? (car q))) ;;;;
     197                          ;(print p " PQ " q)
     198                          (let ((seqs `(,%seq-tail ,seq ,n)))
     199                            ;(cons (list p seqs) '()))) ;ok, ohne checks
     200                            (cons (list (check-dots (car q) seqs)
     201                                        (list p seqs))
     202                                  '())))
     203                         (else
     204                           (cons `(,p (,%seq-ref ,seq ,n)) recu))))
     205                      ;; literals
     206                      ((literal? p)
     207                       (cons `(,(gensym)
     208                                (,%if (,%equal? (,%seq-ref ,seq ,n) ,p)
     209                                  #t
     210                                  (,%error 'dbind
     211                                           "literals don't match"
     212                                           (,%seq-ref ,seq ,n) ,p)))
     213                             recu))
     214                      ;; pair
     215                      (else
     216                        (cond
     217                          ((and (pair? q) (dots? (car q))) ;;;;;
     218                           (let ((seqs `(,%seq-tail ,seq ,n)))
     219                             (cons (cons (check-dots (car q) seqs)
     220                                         (map-seq-ref* p seqs))
     221                                   '())))
     222                          (else
     223                            (let ((g (gensym)))
     224                              (cons (cons `(,g (,%seq-ref ,seq ,n))
     225                                          (loop p g 0))
     226                                    recu)))))) )
     227                  (let ((tail `(,%seq-tail ,seq ,n)))
     228                    (cond
     229                      ((null? pat)
     230                        `((,(gensym)
     231                            (,%if (,%zero? (,%seq-length ,tail))
     232                              #t
     233                              (,%error 'dbind
     234                                     "tail not empty?"
     235                                     ,tail)))))
     236                      ((literal? pat)  ;;;;;;
     237                       `((,(gensym)
     238                          (,%if (,%equal? (,%seq-tail ,seq ,n) ,pat)
     239                            #t
     240                            (,%error 'dbind
     241                                     "literals don't match"
     242                                     (,%seq-tail ,seq ,n) ,pat)))))
     243                      (else `((,pat ,tail)))))))))
     244          (dbind-ex
     245            ;; ->
     246            ;; (let ((a (seq 0)) (#!g (seq 1)) (d (seq 2 #f)))
     247            ;;   (let ((b (#!g 0)) (c (#!g 1 #f)))
     248            ;;     (begin body)))
     249            (lambda (binds body)
     250              (if (null? binds)
     251                `(,%begin ,@body)
     252                `(,%let ,(map (lambda (b)
     253                                (if (pair? (car b)) (car b) b))
     254                              binds)
     255                   ,(dbind-ex (mappend (lambda (b)
     256                                         (if (pair? (car b))
     257                                             (cdr b)
     258                                             '()))
     259                                       binds)
     260                              body)))))
     261          (dbind-set
     262            ;; ->
     263            ;; (begin
     264            ;;   (set! a (seq 0)) (set! #!g (seq 1)) (set! d (seq 2 #f))
     265            ;;   (set! b (#!g 0)) (set! c (#!g 1 #f)))
     266            (lambda (binds)
     267              (mappend (lambda (b)
     268                         (if (pair? (car b))
     269                             (cons `(,%set! ,(caar b) ,(cadar b))
     270                                   (dbind-set (cdr b)))
     271                             (list `(,%set! ,(car b) ,(cadr b)))))
     272                       binds)))
    486273          )
    487           (if (null? body)
    488             ;; without body
    489             `(,%bind-list ,(listify* pat)
    490                            (,%bind-listify* ',pat ,seq))
    491             ;; with body
    492             (let ((xpr (car body)) (xprs (cdr body)))
    493               `(,%bind-list ,(listify* pat)
    494                              (,%bind-listify* ',pat ,seq)
    495                              ,xpr ,@xprs)))
    496           )))))
     274          (let ((pat (cadr form))
     275                (seq (caddr form))
     276                (body (cdddr form))
     277                (gseq (gensym 'seq)))
     278            `(,%let ((,gseq ,seq))
     279               ,(if (null? body)
     280                  ;; setters
     281                  (cond
     282                    ((null? pat)
     283                     `(,%if (,%zero? (,%seq-length ,gseq))
     284                        (,%if #f #f)
     285                        (,%error 'dbind "seq too long" ,gseq ',pat)))
     286                    ((compare? pat %_)
     287                     `(,%if #f #f))
     288                    ((literal? pat)
     289                     `(,%if (,%equal? ,pat ,gseq)
     290                        (,%if #f #f)
     291                        (,%error 'dbind "literals don't match"
     292                                 ,pat ,gseq)))
     293                    ((symbol? pat)
     294                     `(,%set! ,pat ,gseq))
     295                    ((pair? pat)
     296                     `(,%begin ,@(dbind-set (destruc pat gseq)))))
     297                  ;; binders
     298                  (cond
     299                    ((null? pat)
     300                     `(,%if (,%zero? (,%seq-length ,gseq))
     301                        (,%begin ,@body)
     302                        (,%error 'dbind "seq too long" ,gseq ',pat)))
     303                    ((compare? pat %_)
     304                     `(,%begin ,@body))
     305                    ((literal? pat)
     306                     `(,%if (,%equal? ,pat ,gseq)
     307                        (,%begin ,@body)
     308                        (,%error 'dbind "literals don't match"
     309                                 ,pat ,gseq)))
     310                    ((symbol? pat)
     311                     `(,%let ((,pat ,gseq)) ,@body))
     312                    ((pair? pat)
     313                     (dbind-ex (destruc pat gseq) body)))
     314                  ))))))))
     315
     316;;; (bind pat seq xpr . xprs)
     317;;; -------------------------
     318;;; binds pattern variables of pat to corresponding places in seq
     319;;; and executes body xpr . xprs in this context.
     320;;; Literals, wildcard, length checks and dots are supported.
     321(define-syntax bind
     322  (syntax-rules ()
     323    ((_ pat seq xpr . xprs)
     324     (dbind pat seq xpr . xprs))))
    497325
    498326;;; (bind! pat seq)
    499327;;; (bind! pat)
    500328;;; ---------------
    501 ;;; alias to bind without body
     329;;; setters corresponding to bind
    502330(define-syntax bind!
    503331  (syntax-rules ()
    504332    ((_ pat seq)
    505      (bind pat seq))
     333     (dbind pat seq))
    506334    ((_ pat)
    507      (bind pat 'pat))))
     335     (dbind pat 'pat))))
    508336
    509337;;; (bindable? pat (where . fenders) seq)
    … …  
    515343  (syntax-rules (where)
    516344    ((_ pat (where fender ...) seq)
    517      (condition-case (bind pat seq (and fender ...))
     345     (condition-case (dbind pat seq (and fender ...))
    518346       ((exn) #f)))
    519347    ((_ pat seq)
    520      (condition-case (bind pat seq #t)
     348     (condition-case (dbind pat seq #t)
    521349       ((exn) #f)))
    522350    ;; curried versions
    … …  
    567395    ((_ seq (pat (where fender ...) xpr . xprs))
    568396     (if (bindable? pat (where fender ...) seq)
    569        (bind pat seq xpr . xprs)
     397       (dbind pat seq xpr . xprs)
    570398       (error 'bind-seq "sequence doesn't match pattern with fenders"
    571399              seq 'pat 'fender ...)))
    572400    ((_ seq (pat xpr . xprs))
    573401     (if (bindable? pat seq)
    574        (bind pat seq xpr . xprs)
     402       (dbind pat seq xpr . xprs)
    575403       (error 'bind-seq "sequence doesn't match pattern" seq 'pat)))
    576404    ((_ seq (pat (where fender ...) xpr . xprs) . clauses)
    577405     (if (bindable? pat (where fender ...) seq)
    578        (bind pat seq xpr . xprs)
     406       (dbind pat seq xpr . xprs)
    579407       (bind-case seq . clauses)))
    580408    ((_ seq (pat xpr . xprs) . clauses)
    581409     (if (bindable? pat seq)
    582        (bind pat seq xpr . xprs)
     410       (dbind pat seq xpr . xprs)
    583411       (bind-case seq . clauses)))
    584412    ))
    … …  
    605433  (syntax-rules ()
    606434    ((_ pat xpr . xprs)
    607      (lambda (x) (bind pat x xpr . xprs)))
     435     (lambda (x) (dbind pat x xpr . xprs)))
    608436    ))
    609437
    … …  
    614442  (syntax-rules ()
    615443    ((_ pat xpr . xprs)
    616      (lambda x (bind pat x xpr . xprs)))
     444     (lambda x (dbind pat x xpr . xprs)))
    617445     ))
    618446
    … …  
    685513
    686514;;; (bind-loop pat seq xpr ....)
    687 ;;; ---- ------------------------
     515;;; ----------------------------
    688516;;; anaphoric version of bind, introducing loop routine behind the scene
    689517(define-syntax bind-loop
    … …  
    745573     (let () xpr . xprs))
    746574    ((_ ((pat seq)) xpr . xprs)
    747      (bind pat seq xpr . xprs))
     575     (dbind pat seq xpr . xprs))
    748576    ((_ ((pat seq) (pat1 seq1) ...) xpr . xprs)
    749      (bind pat seq (bind-let* ((pat1 seq1) ...) xpr . xprs)))
     577     (dbind pat seq (bind-let* ((pat1 seq1) ...) xpr . xprs)))
    750578     ))
    751579
    … …  
    757585  (syntax-rules ()
    758586    ((_ ((pat seq) ...) xpr . xprs)
    759      (bind (pat ...) (list seq ...) xpr . xprs))
     587     (dbind (pat ...) (list seq ...) xpr . xprs))
    760588    ((_ name ((pat seq) ...) xpr . xprs)
    761589     ((letrec ((name (bind-lambda* (pat ...) xpr . xprs)))
    … …  
    780608  (syntax-rules ()
    781609    ((_ pat seq xpr . xprs)
    782      (bind pat 'pat
     610     (dbind pat 'pat
    783611       (bind! pat seq)
    784612       xpr . xprs))))
    … …  
    816644(define bindings
    817645  (symbol-dispatcher '(
     646    (sequence-db
     647      procedure:
     648      (sequence-db)
     649      (sequence-db seq)
     650      (sequence-db seq? seq-length seq-ref seq-tail seq-maker . pos?)
     651      "sequence database processing, reexported from simple-sequences:"
     652      "the first resets the database to the standard with"
     653      "lists, pairs, vectors and strings,"
     654      "the second returns the vector of handlers as well as the discriminator,"
     655      "the third adds a new database record either at the end or before the"
     656      "pos? discriminator."
     657      "A record cosists of a discriminator, seq?, and a vector with items"
     658      "seq-lenth, seq-ref, seq-tail and seq-maker patterned after vectors."
     659      "Note, that the last record can handle atoms, albeit it is not a"
     660      "sequence."
     661      )
    818662    (bindings
    819663      procedure:
    820664      (bindings sym ..)
    821665      "documentation procedure")
    822     (bind-listify*
    823       generic procedure:
    824       (bind-listify*)
    825       (bind-listify* seq)
    826       (bind-listify* pat seq)
    827       (bind-listify* seq? seq-car seq-cdr)
    828       (bind-listify* seq? seq-car seq-cdr seq-null?)
    829       "the first resets the internal database for lists only"
    830       "the second returns the car-cdr-pair corresponding to seq"
    831       "the third transforms the nested pseudolist seq to a nested list"
    832       "and the last two add support for a new sequence type to the"
    833       "internal database, where seq-null? is needed only if"
    834       "seq-car doesn't raise an exception on an empty sequence")
    835     (bind-list
    836       macro:
    837       (bind-list pat lst)
    838       (bind-list pat lst . body)
    839       "list version of bind: destructure nested symbol-lists only")
    840     (bind-list!
    841       macro:
    842       (bind-list! pat lst)
    843       (bind-list! pat)
    844       "the former is an alias to bind-list wtihout body"
    845       "the latter alias to (bind-list! pat 'pat)")
    846666    (bind
    847667      macro:
    … …  
    918738      "binds cc to the current contiunation"
    919739      "and execute xpr ... in this context")
    920     (resolve-dots
    921       macro:
    922       (resolve-dots . args)
    923       "where args is a list of items which might be followed by dots."
    924       "The item before dots must be a list, which is spliced into"
    925       "the resulting list removing the dots")
    926     (vector-car
    927       procedure:
    928       (vector-car vec)
    929       "vector-analog of car")
    930     (vector-cdr
    931       procedure:
    932       (vector-cdr vec)
    933       "vector-analog of cdr")
    934     (vector-null?
    935       procedure:
    936       (vector-null? vec)
    937       "vector-analog of null?")
    938     (string-car
    939       procedure:
    940       (string-car str)
    941       "string-analog of car")
    942     (string-cdr
    943       procedure:
    944       (string-cdr str)
    945       "string-analog of cdr")
    946     (string-null?
    947       procedure:
    948       (string-null? str)
    949       "string-analog of null?")
    950740    )))
    951741
    952742) ; module
    953743
    954 ;(import bindings simple-tests)
    955 

  • release/5/bindings/trunk/tests/run.scm

    r38814 r39398  
    77        (chicken base)
    88        (chicken condition)
     9        biglists
    910        )
    1011
    11 (define-checks (listify? verbose?)
    12   (begin ;; reset internal database
    13          (bind-listify*)
    14          ;; add support for vectors and strings
    15          (bind-listify* vector? vector-car vector-cdr)
    16          (bind-listify* string? string-car string-cdr)
    17          #t)
    18   #t
    19   (bind-listify* "x")
    20   (list string-car string-cdr)
    21   (bind-listify* 'a 1)
    22   '(1)
    23   (bind-listify* '(a . as) #(1 2 3))
    24   '(1 #(2 3))
    25   (bind-listify* '(a (b #f) c) '(1 #(2 #f) 3))
    26   '(1 (2) 3)
    27   (bind-listify* '(a (b (c _ . cs) d) . es) #(1 (2 (3 30 300) 4) 50))
    28   '(1 (2 (3 (300)) 4) #(50))
    29   (bind-listify* '(a (_ b _) c) '(1 (20 30 40) 5))
    30   '(1 (30) 5)
    31   (bind-listify* '(a (_ b _) . c) '(1 (20 30 40) 5))
    32   '(1 (30) (5))
    33   (bind-listify* '(a (_ b _) . c) '(1 #(20 30 40) 5))
    34   '(1 (30) (5))
    35   (bind-listify* '(a (_ b _) . c) '(1 "xyz" 5))
    36   '(1 (#\y) (5))
    37   (bind-listify* '(x) "x")
    38   '(#\x)
    39   (bind-listify* '(x . y) "xyz")
    40   '(#\x "yz")
    41   (bind-listify* 'x 1)
    42   '(1)
    43   (bind-listify* '(x) #(1))
    44   '(1)
    45   (bind-listify* '(x . y) #(1 2 3))
    46   '(1 #(2 3))
    47   (bind-listify* '(#f ()) #(#f #()))
    48   '(())
    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)
    68   )
    69 ;(listify?)
    70 
    71 (define-checks (lists-only? verbose?)
    72   (begin ;; reset internal database
    73          (bind-listify*)
    74          #t)
    75   #t
    76   ;; this would work with string support:
    77   (condition-case (bind (x) "x" x)
    78     ((exn) #f))
    79   #f
    80   (bind-list (a b) '(1 2) (list a b))
    81   '(1 2)
    82   (bind-list (x (y (z))) '(1 (2 (3))) (list x y z))
    83   '(1 2 3)
    84   (let ((x #f) (y #f))
    85     (bind-list (x y) '(1 2))
    86     (and (= x 1) (= y 2)))
    87   #t
    88   (let ((x #f) (y #f))
    89     (bind-list (x (y)) '(1 (2)))
    90     (and (= x 1) (= y 2)))
    91   #t
    92   (let ((lst '()))
    93     (bind-list (push top pop)
    94       (list
    95         (lambda (xpr) (set! lst (cons xpr lst)))
    96         (lambda () (car lst))
    97         (lambda () (set! lst (cdr lst))))
    98       (push 0)
    99       (push 1)
    100       (pop)
    101       (top)))
    102   0
    103   (let ()
    104     (bind-list! (u v w))
    105     (and (eq? u 'u) (eq? v 'v) (eq? w 'w)))
    106   #t
    107   )
    108 ;(lists-only?)
    109 
    11012(define stack #f) (define push! #f) (define pop! #f)
    11113
    11214(define-checks (defines? verbose?)
    113   (begin ;; reset internal database
    114          (bind-listify*)
    115          ;; add support for vectors and strings
    116          (bind-listify* vector? vector-car vector-cdr)
    117          (bind-listify* string? string-car string-cdr)
    118          #t)
    119   #t
    12015  (let ((x #f) (y #f) (z #f))
    12116    (bind! (x (y . z))
    … …  
    20095  #t
    20196  )
    202 ;(defines?)
     97;(defines?) ; ok
    20398
    20499(define-checks (binds? verbose?)
    205   (begin ;; reset internal database
    206          (bind-listify*)
    207          ;; add support for vectors and strings
    208          (bind-listify* vector? vector-car vector-cdr)
    209          (bind-listify* string? string-car string-cdr)
    210          #t)
    211   #t
    212100  (bind a 1 a)
     101  1
     102  (bind (a #f) '(1 #f) a)
    213103  1
    214104  (bind (a b) '(1 2) (list a b))
    … …  
    239129  '(1 2 3 4 5 #(6))
    240130
    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)
     131  (bind (as ...) '(1 2 3) (list as))
     132  '((1 2 3))
     133  (bind (x y as ...) '(-1 0 1 2 3) (list x y as))
     134  '(-1 0 (1 2 3))
     135  (bind (x y as ..) '(-1 0)  (list x y as))
     136  '(-1 0 ())
     137  (bind ((as (bs cs)) ...)
     138        '((1 (2 3)) (10 (20 30)))
     139        (list as bs cs))
     140  '((1 10) (2 20) (3 30))
     141  (bind ((as (bs cs)) ...)
     142        '((1 (2 3)) #(10 (20 30)))
     143        (list as bs cs))
     144  '((1 10) (2 20) (3 30))
    255145
    256146  (bind-loop (x (a . b) y) '(5 #(1) 0)
    … …  
    312202  #f
    313203  )
    314 ;(binds?)
    315 ;
     204;(binds?) ; ok
     205
    316206(define-checks (predicates? verbose?)
    317   (begin ;; reset internal database
    318          (bind-listify*)
    319          ;; add support for vectors and strings
    320          (bind-listify* vector? vector-car vector-cdr)
    321          (bind-listify* string? string-car string-cdr)
    322          #t)
    323   #t
    324207  ((bindable? (x)) '(name 1))
    325208  #f
    … …  
    343226  #t
    344227  )
    345 ;(predicates?)
     228;(predicates?) ; ok
    346229
    347230(define my-map #f)
    … …  
    350233
    351234(define-checks (cases? verbose?)
    352   (begin ;; reset internal database
    353          (bind-listify*)
    354          ;; add support for vectors and strings
    355          (bind-listify* vector? vector-car vector-cdr)
    356          (bind-listify* string? string-car string-cdr)
    357          #t)
    358   #t
    359235  (bind-case #() (() #f))
    360236  #f
    … …  
    410286  '(1 (2 . 3))
    411287  (bind-case '#(1 2)
    412     (() #f)
     288    ;(() #f)  ;;;;;;;
    413289    ((a) #f)
    414290    ((a b) (list a b))
    … …  
    417293
    418294  (bind-case '(0 4)
    419     ((a bs .... c) #f)
    420     ((a bs ... c) (list a bs c)))
    421   '(0 () 4)
     295    ((a bs ....) #f)
     296    ((a bs ...) (list a bs)))
     297  #f
    422298  (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)
     299    ((a bs ..) #f)
     300    ((a bs ...) (list a bs)))
     301  '(0 (1 2 3 4))
     302  (bind-case '(0 #(1 (2 3)))
     303    ((a (bs (cs (ds))) ..) #f)
     304    ((a (bs (cs ds)) ..) (list a bs cs ds)))
     305  '(0 (1) (2) (3))
     306  (bind-case '(0)
     307    ((a (bs (cs (ds))) ..) (list a bs cs ds))
     308    ((a (bs (cs ds)) ..) #t))
     309  '(0 () () ())
    434310  (bind-case '((0 1 2 3) (10 #(20 30)))
    435311    (((a bs ...) (x (ys zs) ..)) (list a bs x ys zs)))
    … …  
    441317      (let loop ((lst lst) (result '()))
    442318        (bind-case lst
    443           (() (reverse result))
     319          (() (reverse result))  ;;;;;
    444320          ((x . xs)
    445321           (loop xs (cons (fn x) result)))))))
    … …  
    453329        (let loop ((vec vec))
    454330          (bind-case vec
    455             (() result)
     331            (() result)  ;;;;;;;
    456332            ((x . xs)
    457333             (vector-set! result
    … …  
    502378
    503379  (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))
     380    (((_ bs ...) (_ (ys zs) ..)) (list bs ys zs)))
     381  '((1 2 3) (20) (30))
    506382  )
    507383;(cases?)
    508384
    509385(define-checks (lambdas? verbose?)
    510   (begin ;; reset internal database
    511          (bind-listify*)
    512          ;; add support for vectors and strings
    513          (bind-listify* vector? vector-car vector-cdr)
    514          (bind-listify* string? string-car string-cdr)
    515          #t)
    516   #t
    517386  ((bind-lambda (a (b cs ...) ds ...)
    518387     (list a b cs ds))
    519388   '(1 #(20 30 40) 2 3))
    520   '(1 20 (30 40) (2 3))
     389  '(1 20 #(30 40) (2 3))
    521390  ((bind-lambda (a (b (cs ds) ...) . es)
    522391     (list a b cs ds es))
    523    '(1 #(20 (30 40)) 2 3))
     392   '(1 (20 (30 40)) 2 3))
     393   ;'(1 #(20 (30 40)) 2 3))
    524394  '(1 20 (30) (40) (2 3))
    525395  ((bind-lambda (a (b . cs) . ds)
    … …  
    591461
    592462(define-checks (lets? verbose?)
    593   (begin ;; reset internal database
    594          (bind-listify*)
    595          ;; add support for vectors and strings
    596          (bind-listify* vector? vector-car vector-cdr)
    597          (bind-listify* string? string-car string-cdr)
    598          #t)
    599   #t
    600463  (bind-let ((((x y) z) '(#(1 2) 3))
    601464             (u (+ 2 2))
    … …  
    647510;(lets?)
    648511
    649 (import biglists)
    650 ;
    651512(define (integers-from n)
    652513  (Cons n (integers-from (+ n 1)) #f))
    653514(define integers (integers-from 0))
    654 (define (Car xs) (At 0 xs))
    655 (define (Cdr xs) (Drop 1 xs))
     515(define 5integers (Take 5 integers))
     516(define standard-checkers (sequence-db))
     517(define checkers
     518  ;; add finite lazy list handlers at the front
     519  (sequence-db List?
     520               Length
     521               (lambda (xs k) (At k xs))
     522               (lambda (xs k) (Drop k xs))
     523               List
     524               list?))
    656525
    657526(define-checks (biglists? verbose?)
    658   (begin ;; reset internal database
    659          (bind-listify*)
    660          ;; add vector and biglist support
    661          (bind-listify* vector? vector-car vector-cdr)
    662          (bind-listify* BigList? Car Cdr)
    663          #t)
    664   #t
    665   (bind (x y . zs) integers (Car zs))
     527  (if (memq List? standard-checkers) #t #f)
     528  #f
     529  (if (memq List? checkers) #t #f)
     530  #t
     531  (car checkers)
     532  List?
     533  (List? 5integers)
     534  #t
     535  (bind (x y . zs) 5integers (At 0 zs))
    666536  2
    667   (bind (_ _ . zs) integers (Car zs))
     537  (bind (_ _ . zs) 5integers (At 0 zs))
    668538  2
    669539  (bind (x #f (_ (b . cs) . zs))
    670         (vector 1 #f (List 10 integers 2 3))
    671         (list x b (Car cs) (Car zs) (At 1 zs)))
     540        (vector 1 #f (List 10 5integers 2 3))
     541        (list x b (At 0 cs) (At 0 zs) (At 1 zs)))
    672542  '(1 0 1 2 3)
    673543  )
    674544;(biglists?)
    675545
    676 (define-checks (dots? verbose?)
    677   (resolve-dots '(1 2 3) ...)
    678   '(1 2 3)
    679   (resolve-dots 1 2 '(30 40) .. 5)
    680   '(1 2 30 40 5)
    681   (resolve-dots 1 2 '() .. 5)
    682   '(1 2 5)
    683   (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7)
    684   '(1 20 30 4 40 50 60 7)
    685 )
    686 ;(dots?)
     546;(define-checks (dots? verbose?)
     547;  (resolve-dots '(1 2 3) ...)
     548;  '(1 2 3)
     549;  (resolve-dots 1 2 '(30 40) .. 5)
     550;  '(1 2 30 40 5)
     551;  (resolve-dots 1 2 '() .. 5)
     552;  '(1 2 5)
     553;  (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7)
     554;  '(1 20 30 4 40 50 60 7)
     555;)
     556;;(dots?)
    687557
    688558(check-all BINDINGS
    689   (listify?)
    690   (lists-only?)
    691559  (defines?)
    692560  (binds?)
    … …  
    696564  (lets?)
    697565  (biglists?)
    698   (dots?)
    699   )
    700 
     566  )
     567
Note: See TracChangeset for help on using the changeset viewer.