Changeset 38642 in project


Ignore:
Timestamp:
04/25/20 12:40:45 (6 weeks ago)
Author:
juergen
Message:

bindings-3.2 improved

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

Legend:

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

    r38321 r38642  
    22 (category lang-exts)
    33 (license "BSD")
    4  (test-dependencies simple-tests checks biglists)
     4 (test-dependencies simple-tests biglists)
    55 (author "Juergen Lorenz")
    6  (version "3.1.2")
     6 (version "3.2")
    77 (components (extension bindings
    88                        (csc-options "-O3" "-d0"))))
  • release/5/bindings/tags/3.2/bindings.scm

    r38205 r38642  
    394394     (bind pat 'pat))))
    395395
     396;;; (bindable? pat (where . fenders) seq)
     397;;; (bindable? pat (where . fenders))
     398;;; (bindable? pat seq)
     399;;; (bindable? pat)
     400;;; -------------------------------------
     401(define-syntax bindable?
     402  (syntax-rules (where)
     403    ((_ pat (where fender ...) seq)
     404     (condition-case (bind pat seq (and fender ...))
     405       ((exn) #f)))
     406    ((_ pat seq)
     407     (condition-case (bind pat seq #t)
     408       ((exn) #f)))
     409    ;; curried versions
     410    ((_ pat (where fender ...))
     411     (lambda (seq)
     412       (bindable? pat (where fender ...) seq)))
     413    ((_ pat)
     414     (lambda (seq)
     415       (bindable? pat seq)))
     416    ))
     417
    396418#|[
    397419The following macro does more or less the same what the match macro from
     
    411433]|#
    412434
     435;;; (bind-case seq (pat (where fender ...) xpr ....) ....)
    413436;;; (bind-case seq (pat xpr ....) ....)
    414 ;;; -----------------------------------
     437;;; ------------------------------------------------------
    415438;;; Checks if seq matches patterns pat  ....
    416439;;; in sequence, binds the pattern variables of the first matching
     
    418441;;; body expressions xpr .... in this context
    419442(define-syntax bind-case
    420   (syntax-rules ()
     443  (syntax-rules (where)
    421444    ((_ seq)
    422      (error 'bind-case "no match for" seq))
     445     (error 'bind-case "no pattern to match" seq))
     446    ((_ seq (pat (where fender ...) xpr . xprs))
     447     (if (bindable? pat (where fender ...) seq)
     448       (bind pat seq xpr . xprs)
     449       (error 'bind-seq "sequence doesn't match pattern with fenders"
     450              seq 'pat 'fender ...)))
    423451    ((_ seq (pat xpr . xprs))
    424      (condition-case (bind pat seq xpr . xprs)
    425        ((exn) (bind-case seq))))
    426     ((_ seq clause . clauses)
    427      (condition-case (bind-case seq clause)
    428        ((exn) (bind-case seq . clauses))))
    429     ))
    430 
    431 ;;; (bindable? pat)
    432 ;;; ---------------
    433 ;;; returns a unary predicate which checks, if its arguments match pat
    434 (define-syntax bindable?
    435   (syntax-rules ()
    436     ((_ pat)
    437      (lambda (seq)
    438         (condition-case (bind pat seq #t)
    439           ((exn) #f))))
     452     (if (bindable? pat seq)
     453       (bind pat seq xpr . xprs)
     454       (error 'bind-seq "sequence doesn't match pattern" seq 'pat)))
     455    ((_ seq (pat (where fender ...) xpr . xprs) . clauses)
     456     (if (bindable? pat (where fender ...) seq)
     457       (bind pat seq xpr . xprs)
     458       (bind-case seq . clauses)))
     459    ((_ seq (pat xpr . xprs) . clauses)
     460     (if (bindable? pat seq)
     461       (bind pat seq xpr . xprs)
     462       (bind-case seq . clauses)))
    440463    ))
    441464
     
    493516]|#
    494517
     518;;; (bind-case-lambda (pat (where fender ...) xpr ....) ....)
    495519;;; (bind-case-lambda (pat xpr ....) ....)
    496 ;;; --------------------------------------
     520;;; ---------------------------------------------------------
    497521;;; combination of lambda and bind-case, one pattern argument
    498522(define-syntax bind-case-lambda
    499   (syntax-rules ()
     523  (syntax-rules (where)
     524    ((_ (pat (where fender ...) xpr . xprs))
     525     (lambda (x)
     526       (bind-case x (pat (where fender ...) xpr . xprs))))
    500527    ((_ (pat xpr . xprs))
    501528     (lambda (x)
     
    506533    ))
    507534
     535;;; (bind-case-lambda* (pat (where fender ...) xpr ....) ....)
    508536;;; (bind-case-lambda* (pat xpr ....) ....)
    509 ;;; ---------------------------------------
     537;;; ----------------------------------------------------------
    510538;;; combination of lambda and bind-case, multiple pattern arguments
    511539(define-syntax bind-case-lambda*
    512   (syntax-rules ()
     540  (syntax-rules (where)
     541    ((_ (pat (where fender ...) xpr . xprs))
     542     (lambda x
     543       (bind-case x (pat (where fender ...) xpr . xprs))))
    513544    ((_ (pat xpr . xprs))
    514545     (lambda x
     
    701732    (bind-case
    702733      macro:
     734      (bind-case seq (pat (where fender ...) xpr ....) ....)
    703735      (bind-case seq (pat xpr ....) ....)
    704736      "matches seq against pat with optional fenders in a case regime")
    705737    (bindable?
    706738      macro:
     739      (bindable? pat (where fender ...) seq)
     740      (bindable? pat seq)
     741      (bindable? pat (where fender ...))
    707742      (bindable? pat)
    708       "returns a unary predicate, which checks"
    709       "if its argument matches pat and passes all fenders")
     743      "The first two check if sequence seq matches pattern pat"
     744      "with optional fenders."
     745      "The second two are curried versions of the first two")
    710746    (bind!
    711747      macro:
     
    749785    (bind-case-lambda
    750786      macro:
     787      (bind-case-lambda (pat (where fender ...) xpr ....) ....)
    751788      (bind-case-lambda (pat xpr ....) ....)
    752789      "combination of lambda and bind-case with one pattern argument")
    753790    (bind-case-lambda*
    754791      macro:
     792      (bind-case-lambda* (pat (where fender ...) xpr ....) ....)
    755793      (bind-case-lambda* (pat xpr ....) ....)
    756794      "combination of lambda and bind-case with multiple pattern arguments")
  • release/5/bindings/tags/3.2/tests/run.scm

    r38205 r38642  
    55(import simple-tests
    66        bindings
    7         checks
    87        (chicken base)
    98        (chicken condition)
    109        )
    1110
    12 (define-test (listify?)
    13   ;; reset internal database
    14   (bind-listify*)
    15   (equal? (bind-listify* "x") (cons car cdr))
    16 
    17   ;; add support for vectors and strings
    18   (bind-listify* vector? vector-car vector-cdr)
    19   (bind-listify* string? string-car string-cdr)
    20 
    21   (equal? (bind-listify* "x") (cons string-car string-cdr))
    22   (equal? (bind-listify* 'a 1) '(1))
    23   (equal? (bind-listify* '(a . as) #(1 2 3))
    24           '(1 #(2 3)))
    25   (equal? (bind-listify* '(a (b #f) c) '(1 #(2 #f) 3))
    26           '(1 (2) 3))
    27   (equal? (bind-listify* '(a (b (c _ . cs) d) . es) #(1 (2 (3 30 300) 4) 50))
    28           '(1 (2 (3 (300)) 4) #(50)))
    29   (equal? (bind-listify* '(a (_ b _) c) '(1 (20 30 40) 5))
    30           '(1 (30) 5))
    31   (equal? (bind-listify* '(a (_ b _) . c) '(1 (20 30 40) 5))
    32           '(1 (30) (5)))
    33   (equal? (bind-listify* '(a (_ b _) . c) '(1 #(20 30 40) 5))
    34           '(1 (30) (5)))
    35   (equal? (bind-listify* '(a (_ b _) . c) '(1 "xyz" 5))
    36           '(1 (#\y) (5)))
    37   (equal? (bind-listify* '(x) "x") '(#\x))
    38   (equal? (bind-listify* '(x . y) "xyz") '(#\x "yz"))
    39   (equal? (bind-listify* 'x 1) '(1))
    40   (equal? (bind-listify* '(x) #(1)) '(1))
    41   (equal? (bind-listify* '(x . y) #(1 2 3)) '(1 #(2 3)))
    42   (equal? (bind-listify* '(#f ()) #(#f #())) '(()))
     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  (cons 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  '(())
    4349  )
    4450;(listify?)
    4551
    46 (define-test (lists-only?)
    47   ;; reset internal database
    48   (bind-listify*)
    49 
    50   "this would work with string support:"
    51   (not (condition-case (bind (x) "x" x)
    52          ((exn) #f)))
    53   (equal? (bind-list (a b) '(1 2) (list a b))
    54           '(1 2))
    55   (equal? (bind-list* (x (y (z))) '(1 (2 (3))) (list x y z))
    56           '(1 2 3))
     52(define-checks (lists-only? verbose?)
     53  (begin ;; reset internal database
     54         (bind-listify*)
     55         #t)
     56  #t
     57  ;; this would work with string support:
     58  (condition-case (bind (x) "x" x)
     59    ((exn) #f))
     60  #f
     61  (bind-list (a b) '(1 2) (list a b))
     62  '(1 2)
     63  (bind-list* (x (y (z))) '(1 (2 (3))) (list x y z))
     64  '(1 2 3)
    5765  (let ((x #f) (y #f))
    5866    (bind-list (x y) '(1 2))
    5967    (and (= x 1) (= y 2)))
     68  #t
    6069  (let ((x #f) (y #f))
    6170    (bind-list* (x (y)) '(1 (2)))
    6271    (and (= x 1) (= y 2)))
    63   (= (let ((lst '()))
    64        (bind-list (push top pop)
    65          (list
    66            (lambda (xpr) (set! lst (cons xpr lst)))
    67            (lambda () (car lst))
    68            (lambda () (set! lst (cdr lst))))
    69          (>> push procedure?)
    70          (>> top procedure?)
    71          (>> pop procedure?)
    72          (push 0)
    73          (push 1)
    74          (pop)
    75          (top)))
    76     0)
     72  #t
     73  (let ((lst '()))
     74    (bind-list (push top pop)
     75      (list
     76        (lambda (xpr) (set! lst (cons xpr lst)))
     77        (lambda () (car lst))
     78        (lambda () (set! lst (cdr lst))))
     79      (push 0)
     80      (push 1)
     81      (pop)
     82      (top)))
     83  0
    7784  (let ()
    7885    (bind-list! (u v w))
    7986    (and (eq? u 'u) (eq? v 'v) (eq? w 'w)))
     87  #t
    8088  )
    8189;(lists-only?)
     
    8391(define stack #f) (define push! #f) (define pop! #f)
    8492
    85 (define-test (defines?)
    86   ;; reset internal database
    87   (bind-listify*)
    88   ;; add vector and string support
    89   (bind-listify* string? string-car string-cdr)
    90   (bind-listify* vector? vector-car vector-cdr)
    91  
    92   (equal?
    93     (let ((x #f) (y #f) (z #f))
    94       (bind! (x (y . z))
    95         '(1 #(2 3 3)))
    96       (list x y z))
    97     '(1 2 #(3 3)))
    98   (equal?
    99     (let ((x #f) (y #f) (z #f))
    100       (bind! (x #f _ (y _ . z))
    101         '(1 #f 10 #(2 30 3 3)))
    102       (list x y z))
    103     '(1 2 #(3 3)))
    104   (equal?
    105     (let ((x #f) (y #f) (z #f))
    106       (bind! x 1)
    107       (bind! y 2)
    108       (bind! z 3)
    109       (list x y z))
    110     '(1 2 3))
    111   (equal?
    112     (let ((x #f) (y #f) (z #f) (u #f) (v #f))
    113       (bind! (x (y . z)) '(1 #(2 3 3)))
    114       (bind! (u (v)) '(10 (20)))
    115       (>> x integer?) (>> u number?)
    116       (list x y z u v))
    117     '(1 2 #(3 3) 10 20))
    118   (equal?
    119     (let ((x #f) (y #f) (z #f))
    120       (bind! (x (y . z))
    121         '(1 #(2 3 3)))
    122       (>> x integer?)
    123       (list x y z))
    124     '(1 2 #(3 3)))
    125   (equal?
    126     (let ((state #f) (push! #f) (pop! #f))
    127       (bind! (state (push! pop!))
    128         (list '()
    129               (vector
    130                 (lambda (xpr) (set! state (cons xpr state)))
    131                 (lambda () (set! state (cdr state))))))
    132       (>> push! procedure?) (>> pop! procedure?)
    133       (push! 1)
    134       (push! 0)
    135       state)
    136     '(0 1))
    137   (equal?
    138     (begin
    139       (bind! (plus5 times5)
    140         (let ((a 5))
    141           (list
    142             (lambda (x) (+ x a))
    143             (lambda (x) (* x a)))))
    144       (list (plus5 6) (times5 6)))
    145     '(11 30))
    146   (equal?
    147     (begin
    148       (bind! (x . y) '(1 . 2))
    149       (>> x integer?)
    150       (list x y))
    151     '(1 2))
    152   (equal?
    153     (begin
    154       (bind! (x _ . y) '(1 10 . 2))
    155       (>> x integer?)
    156       (list x y))
    157     '(1 2))
    158   (equal?
    159     (begin
    160       (bind! (x #f . y) '(1 #f . 2))
    161       (list x y))
    162     '(1 2))
    163   (= (begin
    164        (let ((lst '()))
    165          (bind! (push top pop)
    166            (vector
    167              (lambda (xpr) (set! lst (cons xpr lst)))
    168              (lambda () (car lst))
    169              (lambda () (set! lst (cdr lst))))))
    170        (>> push procedure?)
    171        (>> top procedure?)
    172        (>> pop procedure?)
    173        (push 0)
    174        (push 1)
    175        (pop)
    176        (top))
    177     0)
    178   (equal?
    179     (begin
    180       (bind! (x (_ y (z _))) '(1 #(2 3 (4 5))))
    181       (list x y z))
    182     '(1 3 4))
    183   (equal?
    184     (begin
    185       (bind! (x (#f y (z #t)))
    186         (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
    187       (>> x integer?)
    188       (list x y z))
    189     '(1 3 4))
     93(define-checks (defines? verbose?)
     94  (begin ;; reset internal database
     95         (bind-listify*)
     96         ;; add support for vectors and strings
     97         (bind-listify* vector? vector-car vector-cdr)
     98         (bind-listify* string? string-car string-cdr)
     99         #t)
     100  #t
     101  (let ((x #f) (y #f) (z #f))
     102    (bind! (x (y . z))
     103      '(1 #(2 3 3)))
     104    (list x y z))
     105  '(1 2 #(3 3))
     106  (let ((x #f) (y #f) (z #f))
     107    (bind! (x #f _ (y _ . z))
     108      '(1 #f 10 #(2 30 3 3)))
     109    (list x y z))
     110  '(1 2 #(3 3))
     111  (let ((x #f) (y #f) (z #f))
     112    (bind! x 1)
     113    (bind! y 2)
     114    (bind! z 3)
     115    (list x y z))
     116  '(1 2 3)
     117  (let ((x #f) (y #f) (z #f) (u #f) (v #f))
     118    (bind! (x (y . z)) '(1 #(2 3 3)))
     119    (bind! (u (v)) '(10 (20)))
     120    (list x y z u v))
     121  '(1 2 #(3 3) 10 20)
     122  (let ((x #f) (y #f) (z #f))
     123    (bind! (x (y . z))
     124      '(1 #(2 3 3)))
     125    (list x y z))
     126  '(1 2 #(3 3))
     127  (let ((state #f) (push! #f) (pop! #f))
     128    (bind! (state (push! pop!))
     129      (list '()
     130            (vector
     131              (lambda (xpr) (set! state (cons xpr state)))
     132              (lambda () (set! state (cdr state))))))
     133    (push! 1)
     134    (push! 0)
     135    state)
     136  '(0 1)
     137  (begin
     138    (bind! (plus5 times5)
     139      (let ((a 5))
     140        (list
     141          (lambda (x) (+ x a))
     142          (lambda (x) (* x a)))))
     143    (list (plus5 6) (times5 6)))
     144  '(11 30)
     145  (begin
     146    (bind! (x . y) '(1 . 2))
     147    (list x y))
     148  '(1 2)
     149  (begin
     150    (bind! (x _ . y) '(1 10 . 2))
     151    (list x y))
     152  '(1 2)
     153  (begin
     154    (bind! (x #f . y) '(1 #f . 2))
     155    (list x y))
     156  '(1 2)
     157  (begin
     158    (let ((lst '()))
     159      (bind! (push top pop)
     160        (vector
     161          (lambda (xpr) (set! lst (cons xpr lst)))
     162          (lambda () (car lst))
     163          (lambda () (set! lst (cdr lst))))))
     164    (push 0)
     165    (push 1)
     166    (pop)
     167    (top))
     168  0
     169  (begin
     170    (bind! (x (_ y (z _))) '(1 #(2 3 (4 5))))
     171    (list x y z))
     172  '(1 3 4)
     173  (begin
     174    (bind! (x (#f y (z #t)))
     175      (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
     176    (list x y z))
     177  '(1 3 4)
    190178  (let ()
    191179    (bind! (a _ (b #f . bs) c))
    192180    (and (eq? a 'a) (eq? b 'b) (eq? bs 'bs) (eq? c 'c)))
     181  #t
    193182  )
    194183;(defines?)
    195184
    196 (define-test (binds?)
    197   ;; reset internal database
    198   (bind-listify*)
    199   ;; add vector and string support
    200   (bind-listify* string? string-car string-cdr)
    201   (bind-listify* vector? vector-car vector-cdr)
    202  
    203   (= (bind a 1 a) 1)
    204   ;(= (bind (a ()) (list 1 "") a) 1)
    205   (equal? (bind (a b) '(1 2) (>> a odd?) (list a b)) '(1 2))
    206   (equal?
    207     (bind (x . y) #(1 2 3 4) (list x y))
    208     '(1 #(2 3 4)))
    209   (equal?
    210     (bind (_ . y) #(1 2 3 4) y)
    211     '#(2 3 4))
    212   (equal?
    213     (bind (x (y (z u . v)) w) '(1 #(2 "foo") 4)
    214       (list x y z u v w))
    215     '(1 2 #\f #\o "o" 4))
    216   (equal?
    217     (bind (x (y (z u . _)) w) '(1 #(2 "foo") 4)
    218       (list x y z u w))
    219     '(1 2 #\f #\o 4))
    220   (equal?
    221     (bind (x (y . _) . _) '(1 #(2 3 4) 5 6) (list x y))
    222     '(1 2))
    223   (equal?
    224     (bind (x (y _ . _) . _) '(1 #(2 3 4) 5 6) (list x y))
    225     '(1 2))
    226   (equal?
    227     (bind (x (y (z . u)) v . w) (vector 1 (list 2 (cons #f #f)) 5 6)
    228       (list x y z u v w))
    229     '(1 2 #f #f 5 #(6)))
    230   (equal?
    231     (bind (x (y (#f . u)) v . w)
    232       (vector 1 (list 2 (cons (odd? 4) #f)) 5 6)
    233       (list x y u v w))
    234     '(1 2 #f 5 #(6)))
    235   (equal?
    236     (bind (x (y (z . u)) v . w) '#(1 (2 (3 . 4)) 5 6)
    237       (list x y z u v w))
    238     '(1 2 3 4 5 #(6)))
    239   (equal?
    240     (bind-loop (x (a . b) y) '(5 #(1) 0)
    241       (>> x integer?)
    242       (if (zero? x)
    243         (list x a b y)
    244         (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
    245     '(0 1 (1 1 1 1 1 . #()) 5))
    246   (equal?
    247     (bind* loop (x (a . b) y) '(5 #(1) 0)
    248       (>> x integer?)
    249       (if (zero? x)
    250         (list x a b y)
    251         (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
    252     '(0 1 (1 1 1 1 1 . #()) 5))
    253   (equal?
    254     (bind-loop (x y) #(5 0)
    255       (>> x integer?)
    256       (if (zero? x)
    257         (vector x y)
    258         (loop (vector (- x 1) (+ y 1)))))
    259     '#(0 5))
    260   (equal?
    261     (bind* loop (x y) #(5 0)
    262       (>> x integer?)
    263       (if (zero? x)
    264         (vector x y)
    265         (loop (vector (- x 1) (+ y 1)))))
    266     '#(0 5))
    267   "LITERALS"
    268   (equal?
    269     (bind (#f . ys) '(#f 2 3) ys)
    270     '(2 3))
    271   (not
    272     (condition-case
    273       (bind (#f . ys) '(#t 2 3) ys)
    274       ((exn) #f)))
     185(define-checks (binds? verbose?)
     186  (begin ;; reset internal database
     187         (bind-listify*)
     188         ;; add support for vectors and strings
     189         (bind-listify* vector? vector-car vector-cdr)
     190         (bind-listify* string? string-car string-cdr)
     191         #t)
     192  #t
     193  (bind a 1 a)
     194  1
     195  (bind (a b) '(1 2) (list a b))
     196  '(1 2)
     197  (bind (x . y) #(1 2 3 4) (list x y))
     198  '(1 #(2 3 4))
     199  (bind (_ . y) #(1 2 3 4) y)
     200  '#(2 3 4)
     201  (bind (x (y (z u . v)) w) '(1 #(2 "foo") 4)
     202    (list x y z u v w))
     203  '(1 2 #\f #\o "o" 4)
     204  (bind (x (y (z u . _)) w) '(1 #(2 "foo") 4)
     205    (list x y z u w))
     206  '(1 2 #\f #\o 4)
     207  (bind (x (y . _) . _) '(1 #(2 3 4) 5 6) (list x y))
     208  '(1 2)
     209  (bind (x (y _ . _) . _) '(1 #(2 3 4) 5 6) (list x y))
     210  '(1 2)
     211  (bind (x (y (z . u)) v . w) (vector 1 (list 2 (cons #f #f)) 5 6)
     212    (list x y z u v w))
     213  '(1 2 #f #f 5 #(6))
     214  (bind (x (y (#f . u)) v . w)
     215    (vector 1 (list 2 (cons (odd? 4) #f)) 5 6)
     216    (list x y u v w))
     217  '(1 2 #f 5 #(6))
     218  (bind (x (y (z . u)) v . w) '#(1 (2 (3 . 4)) 5 6)
     219    (list x y z u v w))
     220  '(1 2 3 4 5 #(6))
     221  (bind-loop (x (a . b) y) '(5 #(1) 0)
     222    (if (zero? x)
     223      (list x a b y)
     224      (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
     225  '(0 1 (1 1 1 1 1 . #()) 5)
     226  (bind* loop (x (a . b) y) '(5 #(1) 0)
     227    (if (zero? x)
     228      (list x a b y)
     229      (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
     230  '(0 1 (1 1 1 1 1 . #()) 5)
     231  (bind-loop (x y) #(5 0)
     232    (if (zero? x)
     233      (vector x y)
     234      (loop (vector (- x 1) (+ y 1)))))
     235  '#(0 5)
     236  (bind* loop (x y) #(5 0)
     237    (if (zero? x)
     238      (vector x y)
     239      (loop (vector (- x 1) (+ y 1)))))
     240  '#(0 5)
     241  ;LITERALS
     242  (bind (#f . ys) '(#f 2 3) ys)
     243  '(2 3)
     244  (condition-case
     245    (bind (#f . ys) '(#t 2 3) ys)
     246    ((exn) #f))
     247  #f
    275248  (bind #f #f #t)
    276   (not
    277     (condition-case
    278       (bind #f #t #t)
    279       ((exn) #f)))
    280   (not
    281     (condition-case
    282       (bind (x . #f) '(1 . #t) x)
    283       ((exn) #f)))
    284   (equal?
    285     (bind (x (y . #f)) '(1 (2 . #f)) (list x y))
    286     '(1 2))
    287   (not
    288     (condition-case
    289       (bind (x (y . #f)) '(1 (2 . #t)) (list x y))
    290       ((exn) #f)))
    291   (equal?
    292     (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y))
    293     '(1 2))
    294   (not
    295     (condition-case
    296       (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y))
    297       ((exn) #f)))
    298   (not
    299     (condition-case
    300       (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y))
    301       ((exn) #f)))
    302   (equal?
    303     (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))
    304     '(1 2 3))
    305   (not (bind (a: ()) #(a: #()) #f))
     249  #t
     250  (condition-case
     251    (bind #f #t #t)
     252    ((exn) #f))
     253  #f
     254  (condition-case
     255    (bind (x . #f) '(1 . #t) x)
     256    ((exn) #f))
     257  #f
     258  (bind (x (y . #f)) '(1 (2 . #f)) (list x y))
     259  '(1 2)
     260  (condition-case
     261    (bind (x (y . #f)) '(1 (2 . #t)) (list x y))
     262    ((exn) #f))
     263  #f
     264  (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y))
     265  '(1 2)
     266  (condition-case
     267    (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y))
     268    ((exn) #f))
     269  #f
     270  (condition-case
     271    (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y))
     272    ((exn) #f))
     273  #f
     274  (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))
     275  '(1 2 3)
     276  (bind (a: ()) #(a: #()) #f)
     277  #f
    306278  )
    307279;(binds?)
    308 
    309 (define-test (predicates?)
    310   ;; reset internal database
    311   (bind-listify*)
    312   ;; add vector and string support
    313   (bind-listify* string? string-car string-cdr)
    314   (bind-listify* vector? vector-car vector-cdr)
    315  
    316   (not ((bindable? (x)) '(name 1)))
    317   (not ((bindable? (_ x)) '(name 1 2)))
     280;
     281(define-checks (predicates? verbose?)
     282  (begin ;; reset internal database
     283         (bind-listify*)
     284         ;; add support for vectors and strings
     285         (bind-listify* vector? vector-car vector-cdr)
     286         (bind-listify* string? string-car string-cdr)
     287         #t)
     288  #t
     289  ((bindable? (x)) '(name 1))
     290  #f
     291  ((bindable? (_ x)) '(name 1 2))
     292  #f
    318293  ((bindable? (a b)) '#(1 2))
     294  #t
    319295  ((bindable? (x (y z))) '(1 "23"))
     296  #t
    320297  ((bindable? (x (y . z))) '(1 "23"))
     298  #t
    321299  ((bindable? (x y)) '(1 "23"))
    322   (not ((bindable? (a (b . c) . d)) '(1 2 3 4 5)))
    323   (not ((bindable? (a)) 1))
     300  #t
     301  ((bindable? (a (b . c) . d)) '(1 2 3 4 5))
     302  #f
     303  ((bindable? (a)) 1)
     304  #f
     305  (bindable? (a b) (where (even? a) (odd? b)) '(2 2))
     306  #f
    324307  )
    325308;(predicates?)
    326309
    327 (define (my-map fn lst)
    328   (let loop ((lst lst) (result '()))
    329     (bind-case lst
    330       (() (reverse result))
    331       ((x . xs)
    332        (loop xs (cons (fn x) result))))))
    333 
    334 (define (vector-map fn vec)
    335   (let* ((len (vector-length vec))
    336          (result (make-vector len #f)))
    337     (let loop ((vec vec))
    338       (bind-case vec
    339         (() result)
    340         ((x . xs)
    341          (vector-set! result
    342                       (- len (vector-length xs) 1)
    343                       (fn x))
    344          (loop (subvector vec 1)))))))
    345 
    346 (define (vector-reverse vec)
    347   (let ((result (make-vector (vector-length vec) #f)))
    348     (let loop ((vec vec))
    349       (bind-case vec
    350         (() result)
    351         ((x . xs)
    352          (vector-set! result
    353                       (vector-length xs)
    354                       x)
    355          (loop (subvector vec 1)))))))
    356 
    357 (define-test (cases?)
    358   ;; reset internal database
    359   (bind-listify*)
    360   ;; add vector and string support
    361   (bind-listify* string? string-car string-cdr)
    362   (bind-listify* vector? vector-car vector-cdr)
    363  
    364   (not (bind-case #() (() #f)))
    365   (equal? (bind-case #(2 2)
    366             ((a b) (>> a even?) (>> b odd?) (print 'even-odd a b))
    367             ((a b) (>> a odd?) (>> b even?) (print 'odd-even a b))
    368             ((a b) (list a b))) '(2 2))
    369   (equal? (bind-case '(1 "2 3")
    370             ((x (y z)) (list x y z))
    371             ((x (y . z)) (list x y z))
    372             ((x y) (list x y)))
    373           '(1 #\2 " 3"))
    374   (equal? (bind-case '(1 "23")
    375             ((x (y z)) (>> y char-alphabetic?) (list x y z))
    376             ((x (y . z)) (list x y z))
    377             ((x y) (list x y)))
    378           '(1 #\2 "3"))
    379   (equal? (bind-case '(1 "23")
    380             ((x (y z)) (>> y char-alphabetic?) (list x y z))
    381             ((x (y . _)) (list x y))
    382             ((x y) (list x y)))
    383           '(1 #\2))
    384   (equal? (bind-case '(1 "23")
    385             ((x (y z)) (>> y char-numeric?) (list x y z))
    386             ((x (y . z)) (list x y z))
    387             ((x y) (list x y)))
    388           '(1 #\2 #\3))
    389   (equal? (bind-case '(1 "23")
    390             ((x (y z)) (list x y z))
    391             ((x (y . z)) (list x y z))
    392             ((x y) (list x y)))
    393           '(1 #\2 #\3))
    394   (equal? (bind-case '(1 "2 3") ;
    395             ((x (y . z)) (list x y z))
    396             ((x (y z)) (list x y z))
    397             ((x y) (list x y)))
    398           '(1 #\2 " 3"))
    399   (equal? (bind-case '(1 #(2 3))
    400             ((x y) (>> y list?) (list x y))
    401             ((x (y . z)) (list x y z))
    402             ((x (y z)) (list x y z)))
    403           '(1 2 #(3)))
    404   (equal? (bind-case '(1 (2 3))
    405             ((x y) (list x y))
    406             ((x (y . z)) (list x y z))
    407             ((x (y z)) (list x y z)))
    408           '(1 (2 3)))
    409   (equal? (bind-case '(1 (2 . 3))
    410             ((x y) (list x y))
    411             ((x (y . z)) (list x y z))
    412             ((x (y z)) (list x y z)))
    413           '(1 (2 . 3)))
    414   (equal?
    415     (bind-case '#(1 2)
    416       (() '())
    417       ((a) (list a))
    418       ((a b) (list a b))
    419       ((a b c) (list a b c)))
    420     '(1 2))
    421 
    422   "LOCAL VARIABLES IN ALL RULES"
    423   '(define (my-map fn lst)
    424     (let loop ((lst lst) (result '()))
    425       (bind-case lst
    426         (() (reverse result))
    427         ((x . xs)
    428          (loop xs (cons (fn x) result))))))
    429   (equal? (my-map add1 '(0 1 2 3)) '(1 2 3 4))
    430   '(define (vector-map fn vec)
    431     (let* ((len (vector-length vec))
    432            (result (make-vector len #f)))
    433       (let loop ((vec vec))
    434         (bind-case vec
    435           (() result)
     310(define my-map #f)
     311(define vector-map #f)
     312(define vector-revrerse #f)
     313
     314(define-checks (cases? verbose?)
     315  (begin ;; reset internal database
     316         (bind-listify*)
     317         ;; add support for vectors and strings
     318         (bind-listify* vector? vector-car vector-cdr)
     319         (bind-listify* string? string-car string-cdr)
     320         #t)
     321  #t
     322  (bind-case #() (() #f))
     323  #f
     324  (bind-case #(2 2)
     325    ((a b) (where (even? a) (odd? b)) (print 'even-odd a b))
     326    ((a b) (where (odd? a) (even? b)) (print 'odd-even a b))
     327    ((a b) (list a b)))
     328  '(2 2)
     329  (bind-case '(1 "2 3")
     330    ((x (y z)) (list x y z))
     331    ((x (y . z)) (list x y z))
     332    ((x y) (list x y)))
     333  '(1 #\2 " 3")
     334  (bind-case '(1 "23")
     335    ((x (y z)) (where (char-alphabetic? y)) (list x y z))
     336    ((x (y . z)) (list x y z))
     337    ((x y) (list x y)))
     338  '(1 #\2 "3")
     339  (bind-case '(1 "23")
     340    ((x (y z)) (where (char-alphabetic? y)) (list x y z))
     341    ((x (y . _)) (list x y))
     342    ((x y) (list x y)))
     343  '(1 #\2)
     344  (bind-case '(1 "23")
     345    ((x (y z)) (where (char-numeric? y)) (list x y z))
     346    ((x (y . z)) (list x y z))
     347    ((x y) (list x y)))
     348  '(1 #\2 #\3)
     349  (bind-case '(1 "23")
     350    ((x (y z)) (list x y z))
     351    ((x (y . z)) (list x y z))
     352    ((x y) (list x y)))
     353  '(1 #\2 #\3)
     354  (bind-case '(1 "2 3") ;
     355    ((x (y . z)) (list x y z))
     356    ((x (y z)) (list x y z))
     357    ((x y) (list x y)))
     358  '(1 #\2 " 3")
     359  (bind-case '(1 #(2 3))
     360    ((x y) (where (list? y)) (list x y))
     361    ((x (y . z)) (list x y z))
     362    ((x (y z)) (list x y z)))
     363  '(1 2 #(3))
     364  (bind-case '(1 (2 3))
     365    ((x y) (list x y))
     366    ((x (y . z)) (list x y z))
     367    ((x (y z)) (list x y z)))
     368  '(1 (2 3))
     369  (bind-case '(1 (2 . 3))
     370    ((x y) (list x y))
     371    ((x (y . z)) (list x y z))
     372    ((x (y z)) (list x y z)))
     373  '(1 (2 . 3))
     374  (bind-case '#(1 2)
     375    (() '())
     376    ((a) (list a))
     377    ((a b) (list a b))
     378    ((a b c) (list a b c)))
     379  '(1 2)
     380
     381  ;LOCAL VARIABLES IN ALL RULES
     382  (set! my-map
     383    (lambda (fn lst)
     384      (let loop ((lst lst) (result '()))
     385        (bind-case lst
     386          (() (reverse result))
    436387          ((x . xs)
    437            (vector-set! result
    438                         (- len (vector-length xs) 1)
    439                         (fn x))
    440            (loop (subvector vec 1)))))))
    441   (equal? (vector-map add1 #(0 1 2 3)) #(1 2 3 4))
    442   '(define (vector-reverse vec)
     388           (loop xs (cons (fn x) result)))))))
     389  (void)
     390  (my-map add1 '(0 1 2 3))
     391  '(1 2 3 4)
     392  (set! vector-map
     393    (lambda (fn vec)
     394      (let* ((len (vector-length vec))
     395             (result (make-vector len #f)))
     396        (let loop ((vec vec))
     397          (bind-case vec
     398            (() result)
     399            ((x . xs)
     400             (vector-set! result
     401                          (- len (vector-length xs) 1)
     402                          (fn x))
     403             (loop (subvector vec 1))))))))
     404  (void)
     405  (vector-map add1 #(0 1 2 3))
     406  #(1 2 3 4)
     407  (set! vector-reverse
     408    (lambda (vec)
    443409    (let ((result (make-vector (vector-length vec) #f)))
    444410      (let loop ((vec vec))
     
    449415                        (vector-length xs)
    450416                        x)
    451            (loop (subvector vec 1)))))))
    452   (equal? (vector-reverse #(0 1 2 3)) #(3 2 1 0))
    453 
    454   "NON-SYMBOL LITERALS"
     417           (loop (subvector vec 1))))))))
     418  (void)
     419  (vector-reverse #(0 1 2 3))
     420  #(3 2 1 0)
     421
     422  ;NON-SYMBOL LITERALS
    455423  (bind-case #("a") ((#f) #f) (("a") #t))
    456   (equal? (bind-case (vector 1 (list (odd? 2) 3))
    457             ((x y) (>> y number?) (list x y))
    458             ((x ("y" . z)) (list x z))
    459             ((x (#f z)) (list x z)))
    460           '(1 3))
    461   (equal? (bind-case '(1 (#f 3))
    462             ((x y) (list x y))
    463             ((x ("y" . z)) (list x z))
    464             ((x (#f z)) (list x z)))
    465           '(1 (#f 3)))
    466   (equal? (bind-case #(1 ("y" 3))
    467             ((x ("y" . z)) (list x z))
    468             ((x (#f z)) (list x z)))
    469           '(1 (3)))
     424  #t
     425  (bind-case (vector 1 (list (odd? 2) 3))
     426    ((x y) (where (number? y)) (list x y))
     427    ((x ("y" . z)) (list x z))
     428    ((x (#f z)) (list x z)))
     429  '(1 3)
     430  (bind-case '(1 (#f 3))
     431    ((x y) (list x y))
     432    ((x ("y" . z)) (list x z))
     433    ((x (#f z)) (list x z)))
     434  '(1 (#f 3))
     435  (bind-case #(1 ("y" 3))
     436    ((x ("y" . z)) (list x z))
     437    ((x (#f z)) (list x z)))
     438  '(1 (3))
    470439  )
    471440;(cases?)
    472441
    473 (define-test (lambdas?)
    474   ;; reset internal database
    475   (bind-listify*)
    476   ;; add vector and string support
    477   (bind-listify* string? string-car string-cdr)
    478   (bind-listify* vector? vector-car vector-cdr)
    479  
    480   (equal?
    481     ((bind-lambda (a (b . c) . d)
    482        (list a b c d))
    483      '(1 #(20 30 40) 2 3))
    484     '(1 20 #(30 40) (2 3)))
    485   (equal?
    486     ((bind-lambda* ((a (b . c) . d) (e . f))
    487        (list a b c d e f))
    488      '(1 #(20 30 40) 2 3) '#(4 5 6))
    489     '(1 20 #(30 40) (2 3) 4 #(5 6)))
    490   (equal?
     442(define-checks (lambdas? verbose?)
     443  (begin ;; reset internal database
     444         (bind-listify*)
     445         ;; add support for vectors and strings
     446         (bind-listify* vector? vector-car vector-cdr)
     447         (bind-listify* string? string-car string-cdr)
     448         #t)
     449  #t
     450  ((bind-lambda (a (b . c) . d)
     451     (list a b c d))
     452   '(1 #(20 30 40) 2 3))
     453  '(1 20 #(30 40) (2 3))
     454  ((bind-lambda* ((a (b . c) . d) (e . f))
     455     (list a b c d e f))
     456   '(1 #(20 30 40) 2 3) '#(4 5 6))
     457  '(1 20 #(30 40) (2 3) 4 #(5 6))
     458  ((bind-case-lambda
     459     ((e . f) (where (zero? e)) f)
     460     ((e . f) (list e f)))
     461   '#(0 2 3 4 5))
     462  '#(2 3 4 5)
     463  ((bind-case-lambda
     464     ((e . f) (where (zero? e)) e)
     465     ((a (b . #f) . d) (list a b d))
     466     ((e . f) (list e f)))
     467   '(1 (2 . #f) 4 5))
     468  '(1 2 (4 5))
     469  ((bind-case-lambda
     470     ((e . f) (where (zero? e)) e)
     471     ((a (b . #f) . d) (list a b d))
     472     ((e . f) (list e f))) ; match
     473   '(1 (2 . #t) 4 5))
     474  '(1 ((2 . #t) 4 5))
     475  (condition-case
    491476    ((bind-case-lambda
    492        ((e . f) (>> e zero?) f)
    493        ((e . f) (list e f)))
    494      '#(0 2 3 4 5))
    495     '#(2 3 4 5))
    496   (equal?
    497     ((bind-case-lambda
    498        ((e . f) (>> e zero?) e)
    499        ((a (b . #f) . d) (list a b d))
    500        ((e . f) (list e f)))
    501      '(1 (2 . #f) 4 5))
    502     '(1 2 (4 5)))
    503   (equal?
    504     ((bind-case-lambda
    505        ((e . f) (>> e zero?) e)
    506        ((a (b . #f) . d) (list a b d))
    507        ((e . f) (list e f))) ; match
     477       ((e . f) (where (zero? e)) e)
     478       ((a (b . #f) . d) (list a b d)))
    508479     '(1 (2 . #t) 4 5))
    509     '(1 ((2 . #t) 4 5)))
    510   (not (condition-case
    511          ((bind-case-lambda
    512             ((e . f) (>> e zero?) e)
    513             ((a (b . #f) . d) (list a b d)))
    514           '(1 (2 . #t) 4 5))
    515          ((exn) #f)))
    516   (equal?
    517     ((bind-case-lambda
    518        ((e . f) (>> e zero?) e)
    519        ((a (b "c") . d) (list a b d))
    520        ((e . f) (list e f)))
    521      '(1 (2 "c") 4 5))
    522     '(1 2 (4 5)))
    523   (equal?
    524     ((bind-case-lambda
    525        ((a (b . c) . d) (>> a integer?) (list a b c d))
    526        ((e . f) (list e f)))
    527      '(1 #(2 3 4) 5 6))
    528     '(1 2 #(3 4) (5 6)))
    529   (equal?
    530     ((bind-case-lambda
    531        ((a (b . c) . d) (>> a string?) (list a b c d))
    532        ((e . f) (list e f)))
    533      '(1 #(2 3 4) 5 6))
    534     '(1 (#(2 3 4) 5 6)))
    535   (equal?
    536     ((bind-case-lambda*
    537        (((a b c . d) (e . f))
    538         (list a b c d e f)))
    539      '(1 2 3) #(4 5 6))
    540     '(1 2 3 () 4 #(5 6)))
    541   (equal?
    542     ((bind-case-lambda*
    543        (((a (b . c) . d) (e . f))
    544         (list a b c d e f)))
    545      '(1 #(20 30 40) 2 3) '(4 5 6))
    546     '(1 20 #(30 40) (2 3) 4 (5 6)))
     480    ((exn) #f))
     481    #f
     482  ((bind-case-lambda
     483     ((e . f) (where (zero? e)) e)
     484     ((a (b "c") . d) (list a b d))
     485     ((e . f) (list e f)))
     486   '(1 (2 "c") 4 5))
     487  '(1 2 (4 5))
     488  ((bind-case-lambda
     489     ((a (b . c) . d) (where (integer? a)) (list a b c d))
     490     ((e . f) (list e f)))
     491   '(1 #(2 3 4) 5 6))
     492  '(1 2 #(3 4) (5 6))
     493  ((bind-case-lambda
     494     ((a (b . c) . d) (where (string? a)) (list a b c d))
     495     ((e . f) (list e f)))
     496   '(1 #(2 3 4) 5 6))
     497  '(1 (#(2 3 4) 5 6))
     498  ((bind-case-lambda*
     499     (((a b c . d) (e . f))
     500      (list a b c d e f)))
     501   '(1 2 3) #(4 5 6))
     502  '(1 2 3 () 4 #(5 6))
     503  ((bind-case-lambda*
     504     (((a (b . c) . d) (e . f))
     505      (list a b c d e f)))
     506   '(1 #(20 30 40) 2 3) '(4 5 6))
     507  '(1 20 #(30 40) (2 3) 4 (5 6))
    547508  )
    548509;(lambdas?)
    549510
    550 (define-test (lets?)
    551   ;; reset internal database
    552   (bind-listify*)
    553   ;; add vector and string support
    554   (bind-listify* string? string-car string-cdr)
    555   (bind-listify* vector? vector-car vector-cdr)
    556  
    557   (equal?
    558     (bind-let ((((x y) z) '(#(1 2) 3))
    559                (u (+ 2 2))
    560                ((v w) #(5 6)))
    561       (>> u integer?)
    562       (list x y z u v w))
    563     '(1 2 3 4 5 6))
    564   (equal?
    565     (bind* loop (a b) '(5 0)
    566       (if (zero? a)
    567         (list a b)
    568         (loop (list (- a 1) (+ b 1)))))
    569     '(0 5))
    570   (equal?
    571     (bind-let loop (((a b) '(5 0)))
    572       (>> a integer?)
    573       (if (zero? a)
    574         (list a b)
    575         (loop (list (- a 1) (+ b 1)))))
    576     '(0 5))
    577   (equal?
    578     (bind-let loop (((x . y) '(1 2 3))
    579                     ((z) #(10)))
    580       (>> x integer?) (>> y (list-of? integer?)) (>> z integer?)
    581       (if (zero? z)
    582         (list x y z)
    583         (loop (cons (+ x 1) (map add1 y)) (list (- z 1)))))
    584     '(11 (12 13) 0))
    585   (equal?
    586     (bind-let* ((((x y) z) '(#(1 2) 3))
    587                 (u (+ 1 2 x))
    588                 ((v w) (list (+ z 2) 6)))
    589       (>> u integer?)
    590       (list x y z u v w))
    591     '(1 2 3 4 5 6))
    592   (equal?
    593     (bindrec ((o?) e?)
    594       (vector
    595         (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    596         (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    597       (list (o? 95) (e? 95)))
    598     '(#t #f))
    599   (equal?
    600     (bind-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    601                   ((e?)
    602                    (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    603       (list (o? 95) (e? 95)))
    604     '(#t #f))
     511(define-checks (lets? verbose?)
     512  (begin ;; reset internal database
     513         (bind-listify*)
     514         ;; add support for vectors and strings
     515         (bind-listify* vector? vector-car vector-cdr)
     516         (bind-listify* string? string-car string-cdr)
     517         #t)
     518  #t
     519  (bind-let ((((x y) z) '(#(1 2) 3))
     520             (u (+ 2 2))
     521             ((v w) #(5 6)))
     522    (list x y z u v w))
     523  '(1 2 3 4 5 6)
     524  (bind* loop (a b) '(5 0)
     525    (if (zero? a)
     526      (list a b)
     527      (loop (list (- a 1) (+ b 1)))))
     528  '(0 5)
     529  (bind-let loop (((a b) '(5 0)))
     530    (if (zero? a)
     531      (list a b)
     532      (loop (list (- a 1) (+ b 1)))))
     533  '(0 5)
     534  (bind-let loop (((x . y) '(1 2 3))
     535                  ((z) #(10)))
     536    (if (zero? z)
     537      (list x y z)
     538      (loop (cons (+ x 1) (map add1 y)) (list (- z 1)))))
     539  '(11 (12 13) 0)
     540  (bind-let* ((((x y) z) '(#(1 2) 3))
     541              (u (+ 1 2 x))
     542              ((v w) (list (+ z 2) 6)))
     543    (list x y z u v w))
     544  '(1 2 3 4 5 6)
     545  (bindrec ((o?) e?)
     546    (vector
     547      (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     548      (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     549    (list (o? 95) (e? 95)))
     550  '(#t #f)
     551  (bind-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     552                ((e?)
     553                 (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
     554    (list (o? 95) (e? 95)))
     555  '(#t #f)
    605556  )
    606557;(lets?)
    607558
    608559(import biglists)
    609 
     560;
    610561(define (integers-from n)
    611562  (Cons n (integers-from (+ n 1)) #f))
     
    614565(define (Cdr xs) (Drop 1 xs))
    615566
    616 (define-test (biglists?)
    617   ;; reset internal database
    618   (bind-listify*)
    619   ;; add vector and biglist support
    620   (bind-listify* vector? vector-car vector-cdr)
    621   (bind-listify* BigList? Car Cdr)
    622  
    623   (= (bind (x y . zs) integers (Car zs)) 2)
    624   (= (bind (_ _ . zs) integers (Car zs)) 2)
    625   (equal?
    626     (bind (x #f (_ (b . cs) . zs))
    627           (vector 1 #f (List 10 integers 2 3))
    628           (list x b (Car cs) (Car zs) (At 1 zs)))
    629     '(1 0 1 2 3))
     567(define-checks (biglists? verbose?)
     568  (begin ;; reset internal database
     569         (bind-listify*)
     570         ;; add vector and biglist support
     571         (bind-listify* vector? vector-car vector-cdr)
     572         (bind-listify* BigList? Car Cdr)
     573         #t)
     574  #t
     575  (bind (x y . zs) integers (Car zs))
     576  2
     577  (bind (_ _ . zs) integers (Car zs))
     578  2
     579  (bind (x #f (_ (b . cs) . zs))
     580        (vector 1 #f (List 10 integers 2 3))
     581        (list x b (Car cs) (Car zs) (At 1 zs)))
     582  '(1 0 1 2 3)
    630583  )
    631584;(biglists?)
    632585
    633 (compound-test (BINDINGS)
     586(check-all BINDINGS
    634587  (listify?)
    635588  (lists-only?)
  • release/5/bindings/trunk/bindings.egg

    r38321 r38642  
    22 (category lang-exts)
    33 (license "BSD")
    4  (test-dependencies simple-tests checks biglists)
     4 (test-dependencies simple-tests biglists)
    55 (author "Juergen Lorenz")
    6  (version "3.1.2")
     6 (version "3.2")
    77 (components (extension bindings
    88                        (csc-options "-O3" "-d0"))))
  • release/5/bindings/trunk/bindings.scm

    r38205 r38642  
    394394     (bind pat 'pat))))
    395395
     396;;; (bindable? pat (where . fenders) seq)
     397;;; (bindable? pat (where . fenders))
     398;;; (bindable? pat seq)
     399;;; (bindable? pat)
     400;;; -------------------------------------
     401(define-syntax bindable?
     402  (syntax-rules (where)
     403    ((_ pat (where fender ...) seq)
     404     (condition-case (bind pat seq (and fender ...))
     405       ((exn) #f)))
     406    ((_ pat seq)
     407     (condition-case (bind pat seq #t)
     408       ((exn) #f)))
     409    ;; curried versions
     410    ((_ pat (where fender ...))
     411     (lambda (seq)
     412       (bindable? pat (where fender ...) seq)))
     413    ((_ pat)
     414     (lambda (seq)
     415       (bindable? pat seq)))
     416    ))
     417
    396418#|[
    397419The following macro does more or less the same what the match macro from
     
    411433]|#
    412434
     435;;; (bind-case seq (pat (where fender ...) xpr ....) ....)
    413436;;; (bind-case seq (pat xpr ....) ....)
    414 ;;; -----------------------------------
     437;;; ------------------------------------------------------
    415438;;; Checks if seq matches patterns pat  ....
    416439;;; in sequence, binds the pattern variables of the first matching
     
    418441;;; body expressions xpr .... in this context
    419442(define-syntax bind-case
    420   (syntax-rules ()
     443  (syntax-rules (where)
    421444    ((_ seq)
    422      (error 'bind-case "no match for" seq))
     445     (error 'bind-case "no pattern to match" seq))
     446    ((_ seq (pat (where fender ...) xpr . xprs))
     447     (if (bindable? pat (where fender ...) seq)
     448       (bind pat seq xpr . xprs)
     449       (error 'bind-seq "sequence doesn't match pattern with fenders"
     450              seq 'pat 'fender ...)))
    423451    ((_ seq (pat xpr . xprs))
    424      (condition-case (bind pat seq xpr . xprs)
    425        ((exn) (bind-case seq))))
    426     ((_ seq clause . clauses)
    427      (condition-case (bind-case seq clause)
    428        ((exn) (bind-case seq . clauses))))
    429     ))
    430 
    431 ;;; (bindable? pat)
    432 ;;; ---------------
    433 ;;; returns a unary predicate which checks, if its arguments match pat
    434 (define-syntax bindable?
    435   (syntax-rules ()
    436     ((_ pat)
    437      (lambda (seq)
    438         (condition-case (bind pat seq #t)
    439           ((exn) #f))))
     452     (if (bindable? pat seq)
     453       (bind pat seq xpr . xprs)
     454       (error 'bind-seq "sequence doesn't match pattern" seq 'pat)))
     455    ((_ seq (pat (where fender ...) xpr . xprs) . clauses)
     456     (if (bindable? pat (where fender ...) seq)
     457       (bind pat seq xpr . xprs)
     458       (bind-case seq . clauses)))
     459    ((_ seq (pat xpr . xprs) . clauses)
     460     (if (bindable? pat seq)
     461       (bind pat seq xpr . xprs)
     462       (bind-case seq . clauses)))
    440463    ))
    441464
     
    493516]|#
    494517
     518;;; (bind-case-lambda (pat (where fender ...) xpr ....) ....)
    495519;;; (bind-case-lambda (pat xpr ....) ....)
    496 ;;; --------------------------------------
     520;;; ---------------------------------------------------------
    497521;;; combination of lambda and bind-case, one pattern argument
    498522(define-syntax bind-case-lambda
    499   (syntax-rules ()
     523  (syntax-rules (where)
     524    ((_ (pat (where fender ...) xpr . xprs))
     525     (lambda (x)
     526       (bind-case x (pat (where fender ...) xpr . xprs))))
    500527    ((_ (pat xpr . xprs))
    501528     (lambda (x)
     
    506533    ))
    507534
     535;;; (bind-case-lambda* (pat (where fender ...) xpr ....) ....)
    508536;;; (bind-case-lambda* (pat xpr ....) ....)
    509 ;;; ---------------------------------------
     537;;; ----------------------------------------------------------
    510538;;; combination of lambda and bind-case, multiple pattern arguments
    511539(define-syntax bind-case-lambda*
    512   (syntax-rules ()
     540  (syntax-rules (where)
     541    ((_ (pat (where fender ...) xpr . xprs))
     542     (lambda x
     543       (bind-case x (pat (where fender ...) xpr . xprs))))
    513544    ((_ (pat xpr . xprs))
    514545     (lambda x
     
    701732    (bind-case
    702733      macro:
     734      (bind-case seq (pat (where fender ...) xpr ....) ....)
    703735      (bind-case seq (pat xpr ....) ....)
    704736      "matches seq against pat with optional fenders in a case regime")
    705737    (bindable?
    706738      macro:
     739      (bindable? pat (where fender ...) seq)
     740      (bindable? pat seq)
     741      (bindable? pat (where fender ...))
    707742      (bindable? pat)
    708       "returns a unary predicate, which checks"
    709       "if its argument matches pat and passes all fenders")
     743      "The first two check if sequence seq matches pattern pat"
     744      "with optional fenders."
     745      "The second two are curried versions of the first two")
    710746    (bind!
    711747      macro:
     
    749785    (bind-case-lambda
    750786      macro:
     787      (bind-case-lambda (pat (where fender ...) xpr ....) ....)
    751788      (bind-case-lambda (pat xpr ....) ....)
    752789      "combination of lambda and bind-case with one pattern argument")
    753790    (bind-case-lambda*
    754791      macro:
     792      (bind-case-lambda* (pat (where fender ...) xpr ....) ....)
    755793      (bind-case-lambda* (pat xpr ....) ....)
    756794      "combination of lambda and bind-case with multiple pattern arguments")
  • release/5/bindings/trunk/tests/run.scm

    r38205 r38642  
    55(import simple-tests
    66        bindings
    7         checks
    87        (chicken base)
    98        (chicken condition)
    109        )
    1110
    12 (define-test (listify?)
    13   ;; reset internal database
    14   (bind-listify*)
    15   (equal? (bind-listify* "x") (cons car cdr))
    16 
    17   ;; add support for vectors and strings
    18   (bind-listify* vector? vector-car vector-cdr)
    19   (bind-listify* string? string-car string-cdr)
    20 
    21   (equal? (bind-listify* "x") (cons string-car string-cdr))
    22   (equal? (bind-listify* 'a 1) '(1))
    23   (equal? (bind-listify* '(a . as) #(1 2 3))
    24           '(1 #(2 3)))
    25   (equal? (bind-listify* '(a (b #f) c) '(1 #(2 #f) 3))
    26           '(1 (2) 3))
    27   (equal? (bind-listify* '(a (b (c _ . cs) d) . es) #(1 (2 (3 30 300) 4) 50))
    28           '(1 (2 (3 (300)) 4) #(50)))
    29   (equal? (bind-listify* '(a (_ b _) c) '(1 (20 30 40) 5))
    30           '(1 (30) 5))
    31   (equal? (bind-listify* '(a (_ b _) . c) '(1 (20 30 40) 5))
    32           '(1 (30) (5)))
    33   (equal? (bind-listify* '(a (_ b _) . c) '(1 #(20 30 40) 5))
    34           '(1 (30) (5)))
    35   (equal? (bind-listify* '(a (_ b _) . c) '(1 "xyz" 5))
    36           '(1 (#\y) (5)))
    37   (equal? (bind-listify* '(x) "x") '(#\x))
    38   (equal? (bind-listify* '(x . y) "xyz") '(#\x "yz"))
    39   (equal? (bind-listify* 'x 1) '(1))
    40   (equal? (bind-listify* '(x) #(1)) '(1))
    41   (equal? (bind-listify* '(x . y) #(1 2 3)) '(1 #(2 3)))
    42   (equal? (bind-listify* '(#f ()) #(#f #())) '(()))
     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  (cons 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  '(())
    4349  )
    4450;(listify?)
    4551
    46 (define-test (lists-only?)
    47   ;; reset internal database
    48   (bind-listify*)
    49 
    50   "this would work with string support:"
    51   (not (condition-case (bind (x) "x" x)
    52          ((exn) #f)))
    53   (equal? (bind-list (a b) '(1 2) (list a b))
    54           '(1 2))
    55   (equal? (bind-list* (x (y (z))) '(1 (2 (3))) (list x y z))
    56           '(1 2 3))
     52(define-checks (lists-only? verbose?)
     53  (begin ;; reset internal database
     54         (bind-listify*)
     55         #t)
     56  #t
     57  ;; this would work with string support:
     58  (condition-case (bind (x) "x" x)
     59    ((exn) #f))
     60  #f
     61  (bind-list (a b) '(1 2) (list a b))
     62  '(1 2)
     63  (bind-list* (x (y (z))) '(1 (2 (3))) (list x y z))
     64  '(1 2 3)
    5765  (let ((x #f) (y #f))
    5866    (bind-list (x y) '(1 2))
    5967    (and (= x 1) (= y 2)))
     68  #t
    6069  (let ((x #f) (y #f))
    6170    (bind-list* (x (y)) '(1 (2)))
    6271    (and (= x 1) (= y 2)))
    63   (= (let ((lst '()))
    64        (bind-list (push top pop)
    65          (list
    66            (lambda (xpr) (set! lst (cons xpr lst)))
    67            (lambda () (car lst))
    68            (lambda () (set! lst (cdr lst))))
    69          (>> push procedure?)
    70          (>> top procedure?)
    71          (>> pop procedure?)
    72          (push 0)
    73          (push 1)
    74          (pop)
    75          (top)))
    76     0)
     72  #t
     73  (let ((lst '()))
     74    (bind-list (push top pop)
     75      (list
     76        (lambda (xpr) (set! lst (cons xpr lst)))
     77        (lambda () (car lst))
     78        (lambda () (set! lst (cdr lst))))
     79      (push 0)
     80      (push 1)
     81      (pop)
     82      (top)))
     83  0
    7784  (let ()
    7885    (bind-list! (u v w))
    7986    (and (eq? u 'u) (eq? v 'v) (eq? w 'w)))
     87  #t
    8088  )
    8189;(lists-only?)
     
    8391(define stack #f) (define push! #f) (define pop! #f)
    8492
    85 (define-test (defines?)
    86   ;; reset internal database
    87   (bind-listify*)
    88   ;; add vector and string support
    89   (bind-listify* string? string-car string-cdr)
    90   (bind-listify* vector? vector-car vector-cdr)
    91  
    92   (equal?
    93     (let ((x #f) (y #f) (z #f))
    94       (bind! (x (y . z))
    95         '(1 #(2 3 3)))
    96       (list x y z))
    97     '(1 2 #(3 3)))
    98   (equal?
    99     (let ((x #f) (y #f) (z #f))
    100       (bind! (x #f _ (y _ . z))
    101         '(1 #f 10 #(2 30 3 3)))
    102       (list x y z))
    103     '(1 2 #(3 3)))
    104   (equal?
    105     (let ((x #f) (y #f) (z #f))
    106       (bind! x 1)
    107       (bind! y 2)
    108       (bind! z 3)
    109       (list x y z))
    110     '(1 2 3))
    111   (equal?
    112     (let ((x #f) (y #f) (z #f) (u #f) (v #f))
    113       (bind! (x (y . z)) '(1 #(2 3 3)))
    114       (bind! (u (v)) '(10 (20)))
    115       (>> x integer?) (>> u number?)
    116       (list x y z u v))
    117     '(1 2 #(3 3) 10 20))
    118   (equal?
    119     (let ((x #f) (y #f) (z #f))
    120       (bind! (x (y . z))
    121         '(1 #(2 3 3)))
    122       (>> x integer?)
    123       (list x y z))
    124     '(1 2 #(3 3)))
    125   (equal?
    126     (let ((state #f) (push! #f) (pop! #f))
    127       (bind! (state (push! pop!))
    128         (list '()
    129               (vector
    130                 (lambda (xpr) (set! state (cons xpr state)))
    131                 (lambda () (set! state (cdr state))))))
    132       (>> push! procedure?) (>> pop! procedure?)
    133       (push! 1)
    134       (push! 0)
    135       state)
    136     '(0 1))
    137   (equal?
    138     (begin
    139       (bind! (plus5 times5)
    140         (let ((a 5))
    141           (list
    142             (lambda (x) (+ x a))
    143             (lambda (x) (* x a)))))
    144       (list (plus5 6) (times5 6)))
    145     '(11 30))
    146   (equal?
    147     (begin
    148       (bind! (x . y) '(1 . 2))
    149       (>> x integer?)
    150       (list x y))
    151     '(1 2))
    152   (equal?
    153     (begin
    154       (bind! (x _ . y) '(1 10 . 2))
    155       (>> x integer?)
    156       (list x y))
    157     '(1 2))
    158   (equal?
    159     (begin
    160       (bind! (x #f . y) '(1 #f . 2))
    161       (list x y))
    162     '(1 2))
    163   (= (begin
    164        (let ((lst '()))
    165          (bind! (push top pop)
    166            (vector
    167              (lambda (xpr) (set! lst (cons xpr lst)))
    168              (lambda () (car lst))
    169              (lambda () (set! lst (cdr lst))))))
    170        (>> push procedure?)
    171        (>> top procedure?)
    172        (>> pop procedure?)
    173        (push 0)
    174        (push 1)
    175        (pop)
    176        (top))
    177     0)
    178   (equal?
    179     (begin
    180       (bind! (x (_ y (z _))) '(1 #(2 3 (4 5))))
    181       (list x y z))
    182     '(1 3 4))
    183   (equal?
    184     (begin
    185       (bind! (x (#f y (z #t)))
    186         (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
    187       (>> x integer?)
    188       (list x y z))
    189     '(1 3 4))
     93(define-checks (defines? verbose?)
     94  (begin ;; reset internal database
     95         (bind-listify*)
     96         ;; add support for vectors and strings
     97         (bind-listify* vector? vector-car vector-cdr)
     98         (bind-listify* string? string-car string-cdr)
     99         #t)
     100  #t
     101  (let ((x #f) (y #f) (z #f))
     102    (bind! (x (y . z))
     103      '(1 #(2 3 3)))
     104    (list x y z))
     105  '(1 2 #(3 3))
     106  (let ((x #f) (y #f) (z #f))
     107    (bind! (x #f _ (y _ . z))
     108      '(1 #f 10 #(2 30 3 3)))
     109    (list x y z))
     110  '(1 2 #(3 3))
     111  (let ((x #f) (y #f) (z #f))
     112    (bind! x 1)
     113    (bind! y 2)
     114    (bind! z 3)
     115    (list x y z))
     116  '(1 2 3)
     117  (let ((x #f) (y #f) (z #f) (u #f) (v #f))
     118    (bind! (x (y . z)) '(1 #(2 3 3)))
     119    (bind! (u (v)) '(10 (20)))
     120    (list x y z u v))
     121  '(1 2 #(3 3) 10 20)
     122  (let ((x #f) (y #f) (z #f))
     123    (bind! (x (y . z))
     124      '(1 #(2 3 3)))
     125    (list x y z))
     126  '(1 2 #(3 3))
     127  (let ((state #f) (push! #f) (pop! #f))
     128    (bind! (state (push! pop!))
     129      (list '()
     130            (vector
     131              (lambda (xpr) (set! state (cons xpr state)))
     132              (lambda () (set! state (cdr state))))))
     133    (push! 1)
     134    (push! 0)
     135    state)
     136  '(0 1)
     137  (begin
     138    (bind! (plus5 times5)
     139      (let ((a 5))
     140        (list
     141          (lambda (x) (+ x a))
     142          (lambda (x) (* x a)))))
     143    (list (plus5 6) (times5 6)))
     144  '(11 30)
     145  (begin
     146    (bind! (x . y) '(1 . 2))
     147    (list x y))
     148  '(1 2)
     149  (begin
     150    (bind! (x _ . y) '(1 10 . 2))
     151    (list x y))
     152  '(1 2)
     153  (begin
     154    (bind! (x #f . y) '(1 #f . 2))
     155    (list x y))
     156  '(1 2)
     157  (begin
     158    (let ((lst '()))
     159      (bind! (push top pop)
     160        (vector
     161          (lambda (xpr) (set! lst (cons xpr lst)))
     162          (lambda () (car lst))
     163          (lambda () (set! lst (cdr lst))))))
     164    (push 0)
     165    (push 1)
     166    (pop)
     167    (top))
     168  0
     169  (begin
     170    (bind! (x (_ y (z _))) '(1 #(2 3 (4 5))))
     171    (list x y z))
     172  '(1 3 4)
     173  (begin
     174    (bind! (x (#f y (z #t)))
     175      (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
     176    (list x y z))
     177  '(1 3 4)
    190178  (let ()
    191179    (bind! (a _ (b #f . bs) c))
    192180    (and (eq? a 'a) (eq? b 'b) (eq? bs 'bs) (eq? c 'c)))
     181  #t
    193182  )
    194183;(defines?)
    195184
    196 (define-test (binds?)
    197   ;; reset internal database
    198   (bind-listify*)
    199   ;; add vector and string support
    200   (bind-listify* string? string-car string-cdr)
    201   (bind-listify* vector? vector-car vector-cdr)
    202  
    203   (= (bind a 1 a) 1)
    204   ;(= (bind (a ()) (list 1 "") a) 1)
    205   (equal? (bind (a b) '(1 2) (>> a odd?) (list a b)) '(1 2))
    206   (equal?
    207     (bind (x . y) #(1 2 3 4) (list x y))
    208     '(1 #(2 3 4)))
    209   (equal?
    210     (bind (_ . y) #(1 2 3 4) y)
    211     '#(2 3 4))
    212   (equal?
    213     (bind (x (y (z u . v)) w) '(1 #(2 "foo") 4)
    214       (list x y z u v w))
    215     '(1 2 #\f #\o "o" 4))
    216   (equal?
    217     (bind (x (y (z u . _)) w) '(1 #(2 "foo") 4)
    218       (list x y z u w))
    219     '(1 2 #\f #\o 4))
    220   (equal?
    221     (bind (x (y . _) . _) '(1 #(2 3 4) 5 6) (list x y))
    222     '(1 2))
    223   (equal?
    224     (bind (x (y _ . _) . _) '(1 #(2 3 4) 5 6) (list x y))
    225     '(1 2))
    226   (equal?
    227     (bind (x (y (z . u)) v . w) (vector 1 (list 2 (cons #f #f)) 5 6)
    228       (list x y z u v w))
    229     '(1 2 #f #f 5 #(6)))
    230   (equal?
    231     (bind (x (y (#f . u)) v . w)
    232       (vector 1 (list 2 (cons (odd? 4) #f)) 5 6)
    233       (list x y u v w))
    234     '(1 2 #f 5 #(6)))
    235   (equal?
    236     (bind (x (y (z . u)) v . w) '#(1 (2 (3 . 4)) 5 6)
    237       (list x y z u v w))
    238     '(1 2 3 4 5 #(6)))
    239   (equal?
    240     (bind-loop (x (a . b) y) '(5 #(1) 0)
    241       (>> x integer?)
    242       (if (zero? x)
    243         (list x a b y)
    244         (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
    245     '(0 1 (1 1 1 1 1 . #()) 5))
    246   (equal?
    247     (bind* loop (x (a . b) y) '(5 #(1) 0)
    248       (>> x integer?)
    249       (if (zero? x)
    250         (list x a b y)
    251         (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
    252     '(0 1 (1 1 1 1 1 . #()) 5))
    253   (equal?
    254     (bind-loop (x y) #(5 0)
    255       (>> x integer?)
    256       (if (zero? x)
    257         (vector x y)
    258         (loop (vector (- x 1) (+ y 1)))))
    259     '#(0 5))
    260   (equal?
    261     (bind* loop (x y) #(5 0)
    262       (>> x integer?)
    263       (if (zero? x)
    264         (vector x y)
    265         (loop (vector (- x 1) (+ y 1)))))
    266     '#(0 5))
    267   "LITERALS"
    268   (equal?
    269     (bind (#f . ys) '(#f 2 3) ys)
    270     '(2 3))
    271   (not
    272     (condition-case
    273       (bind (#f . ys) '(#t 2 3) ys)
    274       ((exn) #f)))
     185(define-checks (binds? verbose?)
     186  (begin ;; reset internal database
     187         (bind-listify*)
     188         ;; add support for vectors and strings
     189         (bind-listify* vector? vector-car vector-cdr)
     190         (bind-listify* string? string-car string-cdr)
     191         #t)
     192  #t
     193  (bind a 1 a)
     194  1
     195  (bind (a b) '(1 2) (list a b))
     196  '(1 2)
     197  (bind (x . y) #(1 2 3 4) (list x y))
     198  '(1 #(2 3 4))
     199  (bind (_ . y) #(1 2 3 4) y)
     200  '#(2 3 4)
     201  (bind (x (y (z u . v)) w) '(1 #(2 "foo") 4)
     202    (list x y z u v w))
     203  '(1 2 #\f #\o "o" 4)
     204  (bind (x (y (z u . _)) w) '(1 #(2 "foo") 4)
     205    (list x y z u w))
     206  '(1 2 #\f #\o 4)
     207  (bind (x (y . _) . _) '(1 #(2 3 4) 5 6) (list x y))
     208  '(1 2)
     209  (bind (x (y _ . _) . _) '(1 #(2 3 4) 5 6) (list x y))
     210  '(1 2)
     211  (bind (x (y (z . u)) v . w) (vector 1 (list 2 (cons #f #f)) 5 6)
     212    (list x y z u v w))
     213  '(1 2 #f #f 5 #(6))
     214  (bind (x (y (#f . u)) v . w)
     215    (vector 1 (list 2 (cons (odd? 4) #f)) 5 6)
     216    (list x y u v w))
     217  '(1 2 #f 5 #(6))
     218  (bind (x (y (z . u)) v . w) '#(1 (2 (3 . 4)) 5 6)
     219    (list x y z u v w))
     220  '(1 2 3 4 5 #(6))
     221  (bind-loop (x (a . b) y) '(5 #(1) 0)
     222    (if (zero? x)
     223      (list x a b y)
     224      (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
     225  '(0 1 (1 1 1 1 1 . #()) 5)
     226  (bind* loop (x (a . b) y) '(5 #(1) 0)
     227    (if (zero? x)
     228      (list x a b y)
     229      (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
     230  '(0 1 (1 1 1 1 1 . #()) 5)
     231  (bind-loop (x y) #(5 0)
     232    (if (zero? x)
     233      (vector x y)
     234      (loop (vector (- x 1) (+ y 1)))))
     235  '#(0 5)
     236  (bind* loop (x y) #(5 0)
     237    (if (zero? x)
     238      (vector x y)
     239      (loop (vector (- x 1) (+ y 1)))))
     240  '#(0 5)
     241  ;LITERALS
     242  (bind (#f . ys) '(#f 2 3) ys)
     243  '(2 3)
     244  (condition-case
     245    (bind (#f . ys) '(#t 2 3) ys)
     246    ((exn) #f))
     247  #f
    275248  (bind #f #f #t)
    276   (not
    277     (condition-case
    278       (bind #f #t #t)
    279       ((exn) #f)))
    280   (not
    281     (condition-case
    282       (bind (x . #f) '(1 . #t) x)
    283       ((exn) #f)))
    284   (equal?
    285     (bind (x (y . #f)) '(1 (2 . #f)) (list x y))
    286     '(1 2))
    287   (not
    288     (condition-case
    289       (bind (x (y . #f)) '(1 (2 . #t)) (list x y))
    290       ((exn) #f)))
    291   (equal?
    292     (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y))
    293     '(1 2))
    294   (not
    295     (condition-case
    296       (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y))
    297       ((exn) #f)))
    298   (not
    299     (condition-case
    300       (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y))
    301       ((exn) #f)))
    302   (equal?
    303     (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))
    304     '(1 2 3))
    305   (not (bind (a: ()) #(a: #()) #f))
     249  #t
     250  (condition-case
     251    (bind #f #t #t)
     252    ((exn) #f))
     253  #f
     254  (condition-case
     255    (bind (x . #f) '(1 . #t) x)
     256    ((exn) #f))
     257  #f
     258  (bind (x (y . #f)) '(1 (2 . #f)) (list x y))
     259  '(1 2)
     260  (condition-case
     261    (bind (x (y . #f)) '(1 (2 . #t)) (list x y))
     262    ((exn) #f))
     263  #f
     264  (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y))
     265  '(1 2)
     266  (condition-case
     267    (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y))
     268    ((exn) #f))
     269  #f
     270  (condition-case
     271    (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y))
     272    ((exn) #f))
     273  #f
     274  (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))
     275  '(1 2 3)
     276  (bind (a: ()) #(a: #()) #f)
     277  #f
    306278  )
    307279;(binds?)
    308 
    309 (define-test (predicates?)
    310   ;; reset internal database
    311   (bind-listify*)
    312   ;; add vector and string support
    313   (bind-listify* string? string-car string-cdr)
    314   (bind-listify* vector? vector-car vector-cdr)
    315  
    316   (not ((bindable? (x)) '(name 1)))
    317   (not ((bindable? (_ x)) '(name 1 2)))
     280;
     281(define-checks (predicates? verbose?)
     282  (begin ;; reset internal database
     283         (bind-listify*)
     284         ;; add support for vectors and strings
     285         (bind-listify* vector? vector-car vector-cdr)
     286         (bind-listify* string? string-car string-cdr)
     287         #t)
     288  #t
     289  ((bindable? (x)) '(name 1))
     290  #f
     291  ((bindable? (_ x)) '(name 1 2))
     292  #f
    318293  ((bindable? (a b)) '#(1 2))
     294  #t
    319295  ((bindable? (x (y z))) '(1 "23"))
     296  #t
    320297  ((bindable? (x (y . z))) '(1 "23"))
     298  #t
    321299  ((bindable? (x y)) '(1 "23"))
    322   (not ((bindable? (a (b . c) . d)) '(1 2 3 4 5)))
    323   (not ((bindable? (a)) 1))
     300  #t
     301  ((bindable? (a (b . c) . d)) '(1 2 3 4 5))
     302  #f
     303  ((bindable? (a)) 1)
     304  #f
     305  (bindable? (a b) (where (even? a) (odd? b)) '(2 2))
     306  #f
    324307  )
    325308;(predicates?)
    326309
    327 (define (my-map fn lst)
    328   (let loop ((lst lst) (result '()))
    329     (bind-case lst
    330       (() (reverse result))
    331       ((x . xs)
    332        (loop xs (cons (fn x) result))))))
    333 
    334 (define (vector-map fn vec)
    335   (let* ((len (vector-length vec))
    336          (result (make-vector len #f)))
    337     (let loop ((vec vec))
    338       (bind-case vec
    339         (() result)
    340         ((x . xs)
    341          (vector-set! result
    342                       (- len (vector-length xs) 1)
    343                       (fn x))
    344          (loop (subvector vec 1)))))))
    345 
    346 (define (vector-reverse vec)
    347   (let ((result (make-vector (vector-length vec) #f)))
    348     (let loop ((vec vec))
    349       (bind-case vec
    350         (() result)
    351         ((x . xs)
    352          (vector-set! result
    353                       (vector-length xs)
    354                       x)
    355          (loop (subvector vec 1)))))))
    356 
    357 (define-test (cases?)
    358   ;; reset internal database
    359   (bind-listify*)
    360   ;; add vector and string support
    361   (bind-listify* string? string-car string-cdr)
    362   (bind-listify* vector? vector-car vector-cdr)
    363  
    364   (not (bind-case #() (() #f)))
    365   (equal? (bind-case #(2 2)
    366             ((a b) (>> a even?) (>> b odd?) (print 'even-odd a b))
    367             ((a b) (>> a odd?) (>> b even?) (print 'odd-even a b))
    368             ((a b) (list a b))) '(2 2))
    369   (equal? (bind-case '(1 "2 3")
    370             ((x (y z)) (list x y z))
    371             ((x (y . z)) (list x y z))
    372             ((x y) (list x y)))
    373           '(1 #\2 " 3"))
    374   (equal? (bind-case '(1 "23")
    375             ((x (y z)) (>> y char-alphabetic?) (list x y z))
    376             ((x (y . z)) (list x y z))
    377             ((x y) (list x y)))
    378           '(1 #\2 "3"))
    379   (equal? (bind-case '(1 "23")
    380             ((x (y z)) (>> y char-alphabetic?) (list x y z))
    381             ((x (y . _)) (list x y))
    382             ((x y) (list x y)))
    383           '(1 #\2))
    384   (equal? (bind-case '(1 "23")
    385             ((x (y z)) (>> y char-numeric?) (list x y z))
    386             ((x (y . z)) (list x y z))
    387             ((x y) (list x y)))
    388           '(1 #\2 #\3))
    389   (equal? (bind-case '(1 "23")
    390             ((x (y z)) (list x y z))
    391             ((x (y . z)) (list x y z))
    392             ((x y) (list x y)))
    393           '(1 #\2 #\3))
    394   (equal? (bind-case '(1 "2 3") ;
    395             ((x (y . z)) (list x y z))
    396             ((x (y z)) (list x y z))
    397             ((x y) (list x y)))
    398           '(1 #\2 " 3"))
    399   (equal? (bind-case '(1 #(2 3))
    400             ((x y) (>> y list?) (list x y))
    401             ((x (y . z)) (list x y z))
    402             ((x (y z)) (list x y z)))
    403           '(1 2 #(3)))
    404   (equal? (bind-case '(1 (2 3))
    405             ((x y) (list x y))
    406             ((x (y . z)) (list x y z))
    407             ((x (y z)) (list x y z)))
    408           '(1 (2 3)))
    409   (equal? (bind-case '(1 (2 . 3))
    410             ((x y) (list x y))
    411             ((x (y . z)) (list x y z))
    412             ((x (y z)) (list x y z)))
    413           '(1 (2 . 3)))
    414   (equal?
    415     (bind-case '#(1 2)
    416       (() '())
    417       ((a) (list a))
    418       ((a b) (list a b))
    419       ((a b c) (list a b c)))
    420     '(1 2))
    421 
    422   "LOCAL VARIABLES IN ALL RULES"
    423   '(define (my-map fn lst)
    424     (let loop ((lst lst) (result '()))
    425       (bind-case lst
    426         (() (reverse result))
    427         ((x . xs)
    428          (loop xs (cons (fn x) result))))))
    429   (equal? (my-map add1 '(0 1 2 3)) '(1 2 3 4))
    430   '(define (vector-map fn vec)
    431     (let* ((len (vector-length vec))
    432            (result (make-vector len #f)))
    433       (let loop ((vec vec))
    434         (bind-case vec
    435           (() result)
     310(define my-map #f)
     311(define vector-map #f)
     312(define vector-revrerse #f)
     313
     314(define-checks (cases? verbose?)
     315  (begin ;; reset internal database
     316         (bind-listify*)
     317         ;; add support for vectors and strings
     318         (bind-listify* vector? vector-car vector-cdr)
     319         (bind-listify* string? string-car string-cdr)
     320         #t)
     321  #t
     322  (bind-case #() (() #f))
     323  #f
     324  (bind-case #(2 2)
     325    ((a b) (where (even? a) (odd? b)) (print 'even-odd a b))
     326    ((a b) (where (odd? a) (even? b)) (print 'odd-even a b))
     327    ((a b) (list a b)))
     328  '(2 2)
     329  (bind-case '(1 "2 3")
     330    ((x (y z)) (list x y z))
     331    ((x (y . z)) (list x y z))
     332    ((x y) (list x y)))
     333  '(1 #\2 " 3")
     334  (bind-case '(1 "23")
     335    ((x (y z)) (where (char-alphabetic? y)) (list x y z))
     336    ((x (y . z)) (list x y z))
     337    ((x y) (list x y)))
     338  '(1 #\2 "3")
     339  (bind-case '(1 "23")
     340    ((x (y z)) (where (char-alphabetic? y)) (list x y z))
     341    ((x (y . _)) (list x y))
     342    ((x y) (list x y)))
     343  '(1 #\2)
     344  (bind-case '(1 "23")
     345    ((x (y z)) (where (char-numeric? y)) (list x y z))
     346    ((x (y . z)) (list x y z))
     347    ((x y) (list x y)))
     348  '(1 #\2 #\3)
     349  (bind-case '(1 "23")
     350    ((x (y z)) (list x y z))
     351    ((x (y . z)) (list x y z))
     352    ((x y) (list x y)))
     353  '(1 #\2 #\3)
     354  (bind-case '(1 "2 3") ;
     355    ((x (y . z)) (list x y z))
     356    ((x (y z)) (list x y z))
     357    ((x y) (list x y)))
     358  '(1 #\2 " 3")
     359  (bind-case '(1 #(2 3))
     360    ((x y) (where (list? y)) (list x y))
     361    ((x (y . z)) (list x y z))
     362    ((x (y z)) (list x y z)))
     363  '(1 2 #(3))
     364  (bind-case '(1 (2 3))
     365    ((x y) (list x y))
     366    ((x (y . z)) (list x y z))
     367    ((x (y z)) (list x y z)))
     368  '(1 (2 3))
     369  (bind-case '(1 (2 . 3))
     370    ((x y) (list x y))
     371    ((x (y . z)) (list x y z))
     372    ((x (y z)) (list x y z)))
     373  '(1 (2 . 3))
     374  (bind-case '#(1 2)
     375    (() '())
     376    ((a) (list a))
     377    ((a b) (list a b))
     378    ((a b c) (list a b c)))
     379  '(1 2)
     380
     381  ;LOCAL VARIABLES IN ALL RULES
     382  (set! my-map
     383    (lambda (fn lst)
     384      (let loop ((lst lst) (result '()))
     385        (bind-case lst
     386          (() (reverse result))
    436387          ((x . xs)
    437            (vector-set! result
    438                         (- len (vector-length xs) 1)
    439                         (fn x))
    440            (loop (subvector vec 1)))))))
    441   (equal? (vector-map add1 #(0 1 2 3)) #(1 2 3 4))
    442   '(define (vector-reverse vec)
     388           (loop xs (cons (fn x) result)))))))
     389  (void)
     390  (my-map add1 '(0 1 2 3))
     391  '(1 2 3 4)
     392  (set! vector-map
     393    (lambda (fn vec)
     394      (let* ((len (vector-length vec))
     395             (result (make-vector len #f)))
     396        (let loop ((vec vec))
     397          (bind-case vec
     398            (() result)
     399            ((x . xs)
     400             (vector-set! result
     401                          (- len (vector-length xs) 1)
     402                          (fn x))
     403             (loop (subvector vec 1))))))))
     404  (void)
     405  (vector-map add1 #(0 1 2 3))
     406  #(1 2 3 4)
     407  (set! vector-reverse
     408    (lambda (vec)
    443409    (let ((result (make-vector (vector-length vec) #f)))
    444410      (let loop ((vec vec))
     
    449415                        (vector-length xs)
    450416                        x)
    451            (loop (subvector vec 1)))))))
    452   (equal? (vector-reverse #(0 1 2 3)) #(3 2 1 0))
    453 
    454   "NON-SYMBOL LITERALS"
     417           (loop (subvector vec 1))))))))
     418  (void)
     419  (vector-reverse #(0 1 2 3))
     420  #(3 2 1 0)
     421
     422  ;NON-SYMBOL LITERALS
    455423  (bind-case #("a") ((#f) #f) (("a") #t))
    456   (equal? (bind-case (vector 1 (list (odd? 2) 3))
    457             ((x y) (>> y number?) (list x y))
    458             ((x ("y" . z)) (list x z))
    459             ((x (#f z)) (list x z)))
    460           '(1 3))
    461   (equal? (bind-case '(1 (#f 3))
    462             ((x y) (list x y))
    463             ((x ("y" . z)) (list x z))
    464             ((x (#f z)) (list x z)))
    465           '(1 (#f 3)))
    466   (equal? (bind-case #(1 ("y" 3))
    467             ((x ("y" . z)) (list x z))
    468             ((x (#f z)) (list x z)))
    469           '(1 (3)))
     424  #t
     425  (bind-case (vector 1 (list (odd? 2) 3))
     426    ((x y) (where (number? y)) (list x y))
     427    ((x ("y" . z)) (list x z))
     428    ((x (#f z)) (list x z)))
     429  '(1 3)
     430  (bind-case '(1 (#f 3))
     431    ((x y) (list x y))
     432    ((x ("y" . z)) (list x z))
     433    ((x (#f z)) (list x z)))
     434  '(1 (#f 3))
     435  (bind-case #(1 ("y" 3))
     436    ((x ("y" . z)) (list x z))
     437    ((x (#f z)) (list x z)))
     438  '(1 (3))
    470439  )
    471440;(cases?)
    472441
    473 (define-test (lambdas?)
    474   ;; reset internal database
    475   (bind-listify*)
    476   ;; add vector and string support
    477   (bind-listify* string? string-car string-cdr)
    478   (bind-listify* vector? vector-car vector-cdr)
    479  
    480   (equal?
    481     ((bind-lambda (a (b . c) . d)
    482        (list a b c d))
    483      '(1 #(20 30 40) 2 3))
    484     '(1 20 #(30 40) (2 3)))
    485   (equal?
    486     ((bind-lambda* ((a (b . c) . d) (e . f))
    487        (list a b c d e f))
    488      '(1 #(20 30 40) 2 3) '#(4 5 6))
    489     '(1 20 #(30 40) (2 3) 4 #(5 6)))
    490   (equal?
     442(define-checks (lambdas? verbose?)
     443  (begin ;; reset internal database
     444         (bind-listify*)
     445         ;; add support for vectors and strings
     446         (bind-listify* vector? vector-car vector-cdr)
     447         (bind-listify* string? string-car string-cdr)
     448         #t)
     449  #t
     450  ((bind-lambda (a (b . c) . d)
     451     (list a b c d))
     452   '(1 #(20 30 40) 2 3))
     453  '(1 20 #(30 40) (2 3))
     454  ((bind-lambda* ((a (b . c) . d) (e . f))
     455     (list a b c d e f))
     456   '(1 #(20 30 40) 2 3) '#(4 5 6))
     457  '(1 20 #(30 40) (2 3) 4 #(5 6))
     458  ((bind-case-lambda
     459     ((e . f) (where (zero? e)) f)
     460     ((e . f) (list e f)))
     461   '#(0 2 3 4 5))
     462  '#(2 3 4 5)
     463  ((bind-case-lambda
     464     ((e . f) (where (zero? e)) e)
     465     ((a (b . #f) . d) (list a b d))
     466     ((e . f) (list e f)))
     467   '(1 (2 . #f) 4 5))
     468  '(1 2 (4 5))
     469  ((bind-case-lambda
     470     ((e . f) (where (zero? e)) e)
     471     ((a (b . #f) . d) (list a b d))
     472     ((e . f) (list e f))) ; match
     473   '(1 (2 . #t) 4 5))
     474  '(1 ((2 . #t) 4 5))
     475  (condition-case
    491476    ((bind-case-lambda
    492        ((e . f) (>> e zero?) f)
    493        ((e . f) (list e f)))
    494      '#(0 2 3 4 5))
    495     '#(2 3 4 5))
    496   (equal?
    497     ((bind-case-lambda
    498        ((e . f) (>> e zero?) e)
    499        ((a (b . #f) . d) (list a b d))
    500        ((e . f) (list e f)))
    501      '(1 (2 . #f) 4 5))
    502     '(1 2 (4 5)))
    503   (equal?
    504     ((bind-case-lambda
    505        ((e . f) (>> e zero?) e)
    506        ((a (b . #f) . d) (list a b d))
    507        ((e . f) (list e f))) ; match
     477       ((e . f) (where (zero? e)) e)
     478       ((a (b . #f) . d) (list a b d)))
    508479     '(1 (2 . #t) 4 5))
    509     '(1 ((2 . #t) 4 5)))
    510   (not (condition-case
    511          ((bind-case-lambda
    512             ((e . f) (>> e zero?) e)
    513             ((a (b . #f) . d) (list a b d)))
    514           '(1 (2 . #t) 4 5))
    515          ((exn) #f)))
    516   (equal?
    517     ((bind-case-lambda
    518        ((e . f) (>> e zero?) e)
    519        ((a (b "c") . d) (list a b d))
    520        ((e . f) (list e f)))
    521      '(1 (2 "c") 4 5))
    522     '(1 2 (4 5)))
    523   (equal?
    524     ((bind-case-lambda
    525        ((a (b . c) . d) (>> a integer?) (list a b c d))
    526        ((e . f) (list e f)))
    527      '(1 #(2 3 4) 5 6))
    528     '(1 2 #(3 4) (5 6)))
    529   (equal?
    530     ((bind-case-lambda
    531        ((a (b . c) . d) (>> a string?) (list a b c d))
    532        ((e . f) (list e f)))
    533      '(1 #(2 3 4) 5 6))
    534     '(1 (#(2 3 4) 5 6)))
    535   (equal?
    536     ((bind-case-lambda*
    537        (((a b c . d) (e . f))
    538         (list a b c d e f)))
    539      '(1 2 3) #(4 5 6))
    540     '(1 2 3 () 4 #(5 6)))
    541   (equal?
    542     ((bind-case-lambda*
    543        (((a (b . c) . d) (e . f))
    544         (list a b c d e f)))
    545      '(1 #(20 30 40) 2 3) '(4 5 6))
    546     '(1 20 #(30 40) (2 3) 4 (5 6)))
     480    ((exn) #f))
     481    #f
     482  ((bind-case-lambda
     483     ((e . f) (where (zero? e)) e)
     484     ((a (b "c") . d) (list a b d))
     485     ((e . f) (list e f)))
     486   '(1 (2 "c") 4 5))
     487  '(1 2 (4 5))
     488  ((bind-case-lambda
     489     ((a (b . c) . d) (where (integer? a)) (list a b c d))
     490     ((e . f) (list e f)))
     491   '(1 #(2 3 4) 5 6))
     492  '(1 2 #(3 4) (5 6))
     493  ((bind-case-lambda
     494     ((a (b . c) . d) (where (string? a)) (list a b c d))
     495     ((e . f) (list e f)))
     496   '(1 #(2 3 4) 5 6))
     497  '(1 (#(2 3 4) 5 6))
     498  ((bind-case-lambda*
     499     (((a b c . d) (e . f))
     500      (list a b c d e f)))
     501   '(1 2 3) #(4 5 6))
     502  '(1 2 3 () 4 #(5 6))
     503  ((bind-case-lambda*
     504     (((a (b . c) . d) (e . f))
     505      (list a b c d e f)))
     506   '(1 #(20 30 40) 2 3) '(4 5 6))
     507  '(1 20 #(30 40) (2 3) 4 (5 6))
    547508  )
    548509;(lambdas?)
    549510
    550 (define-test (lets?)
    551   ;; reset internal database
    552   (bind-listify*)
    553   ;; add vector and string support
    554   (bind-listify* string? string-car string-cdr)
    555   (bind-listify* vector? vector-car vector-cdr)
    556  
    557   (equal?
    558     (bind-let ((((x y) z) '(#(1 2) 3))
    559                (u (+ 2 2))
    560                ((v w) #(5 6)))
    561       (>> u integer?)
    562       (list x y z u v w))
    563     '(1 2 3 4 5 6))
    564   (equal?
    565     (bind* loop (a b) '(5 0)
    566       (if (zero? a)
    567         (list a b)
    568         (loop (list (- a 1) (+ b 1)))))
    569     '(0 5))
    570   (equal?
    571     (bind-let loop (((a b) '(5 0)))
    572       (>> a integer?)
    573       (if (zero? a)
    574         (list a b)
    575         (loop (list (- a 1) (+ b 1)))))
    576     '(0 5))
    577   (equal?
    578     (bind-let loop (((x . y) '(1 2 3))
    579                     ((z) #(10)))
    580       (>> x integer?) (>> y (list-of? integer?)) (>> z integer?)
    581       (if (zero? z)
    582         (list x y z)
    583         (loop (cons (+ x 1) (map add1 y)) (list (- z 1)))))
    584     '(11 (12 13) 0))
    585   (equal?
    586     (bind-let* ((((x y) z) '(#(1 2) 3))
    587                 (u (+ 1 2 x))
    588                 ((v w) (list (+ z 2) 6)))
    589       (>> u integer?)
    590       (list x y z u v w))
    591     '(1 2 3 4 5 6))
    592   (equal?
    593     (bindrec ((o?) e?)
    594       (vector
    595         (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    596         (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    597       (list (o? 95) (e? 95)))
    598     '(#t #f))
    599   (equal?
    600     (bind-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    601                   ((e?)
    602                    (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    603       (list (o? 95) (e? 95)))
    604     '(#t #f))
     511(define-checks (lets? verbose?)
     512  (begin ;; reset internal database
     513         (bind-listify*)
     514         ;; add support for vectors and strings
     515         (bind-listify* vector? vector-car vector-cdr)
     516         (bind-listify* string? string-car string-cdr)
     517         #t)
     518  #t
     519  (bind-let ((((x y) z) '(#(1 2) 3))
     520             (u (+ 2 2))
     521             ((v w) #(5 6)))
     522    (list x y z u v w))
     523  '(1 2 3 4 5 6)
     524  (bind* loop (a b) '(5 0)
     525    (if (zero? a)
     526      (list a b)
     527      (loop (list (- a 1) (+ b 1)))))
     528  '(0 5)
     529  (bind-let loop (((a b) '(5 0)))
     530    (if (zero? a)
     531      (list a b)
     532      (loop (list (- a 1) (+ b 1)))))
     533  '(0 5)
     534  (bind-let loop (((x . y) '(1 2 3))
     535                  ((z) #(10)))
     536    (if (zero? z)
     537      (list x y z)
     538      (loop (cons (+ x 1) (map add1 y)) (list (- z 1)))))
     539  '(11 (12 13) 0)
     540  (bind-let* ((((x y) z) '(#(1 2) 3))
     541              (u (+ 1 2 x))
     542              ((v w) (list (+ z 2) 6)))
     543    (list x y z u v w))
     544  '(1 2 3 4 5 6)
     545  (bindrec ((o?) e?)
     546    (vector
     547      (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     548      (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     549    (list (o? 95) (e? 95)))
     550  '(#t #f)
     551  (bind-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     552                ((e?)
     553                 (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
     554    (list (o? 95) (e? 95)))
     555  '(#t #f)
    605556  )
    606557;(lets?)
    607558
    608559(import biglists)
    609 
     560;
    610561(define (integers-from n)
    611562  (Cons n (integers-from (+ n 1)) #f))
     
    614565(define (Cdr xs) (Drop 1 xs))
    615566
    616 (define-test (biglists?)
    617   ;; reset internal database
    618   (bind-listify*)
    619   ;; add vector and biglist support
    620   (bind-listify* vector? vector-car vector-cdr)
    621   (bind-listify* BigList? Car Cdr)
    622  
    623   (= (bind (x y . zs) integers (Car zs)) 2)
    624   (= (bind (_ _ . zs) integers (Car zs)) 2)
    625   (equal?
    626     (bind (x #f (_ (b . cs) . zs))
    627           (vector 1 #f (List 10 integers 2 3))
    628           (list x b (Car cs) (Car zs) (At 1 zs)))
    629     '(1 0 1 2 3))
     567(define-checks (biglists? verbose?)
     568  (begin ;; reset internal database
     569         (bind-listify*)
     570         ;; add vector and biglist support
     571         (bind-listify* vector? vector-car vector-cdr)
     572         (bind-listify* BigList? Car Cdr)
     573         #t)
     574  #t
     575  (bind (x y . zs) integers (Car zs))
     576  2
     577  (bind (_ _ . zs) integers (Car zs))
     578  2
     579  (bind (x #f (_ (b . cs) . zs))
     580        (vector 1 #f (List 10 integers 2 3))
     581        (list x b (Car cs) (Car zs) (At 1 zs)))
     582  '(1 0 1 2 3)
    630583  )
    631584;(biglists?)
    632585
    633 (compound-test (BINDINGS)
     586(check-all BINDINGS
    634587  (listify?)
    635588  (lists-only?)
Note: See TracChangeset for help on using the changeset viewer.