Changeset 38613 in project for release


Ignore:
Timestamp:
04/15/20 13:10:55 (4 months ago)
Author:
juergen
Message:

generics 2.0 with restructured code and enhanced helpers

Location:
release/5/generics
Files:
4 added
2 deleted
4 edited
1 copied

Legend:

Unmodified
Added
Removed

  • release/5/generics/tags/2.0/generics.egg

    r38310 r38613  
    1 ((synopsis "an implementation of generic procedures")
     1((synopsis "an implementation of generic functions and a lot of helpers")
    22 (category lang-exts)
    33 (license "BSD")
    … …  
    55 (dependencies simple-cells)
    66 (author "Juergen Lorenz")
    7  (version "1.0.1")
     7 (version "2.0")
     8 (component-options
     9   (csc-options "-d0" "-O3"))
    810 (components
    9    (extension generics
    10      ;(csc-options "-d0" "-O3") ;fails with method-tree-show
    11      (csc-options "-d1" "-O3")
    12      (modules generic-helpers generics))))
     11   (extension generic-functions)
     12   (extension generic-helpers)))
    1313

  • release/5/generics/tags/2.0/tests/run.scm

    r37460 r38613  
    11(import scheme (chicken base) (chicken fixnum)
    2         generics generic-helpers simple-tests)
    3 
    4 (define-test (Generic-helpers)
    5   (equal?
    6     (receive (rhead tail)
    7       (rsplit-with odd? '(1 3 5 2 4 6))
    8       (list rhead tail))
    9     '(() (1 3 5 2 4 6)))
    10   (equal?
    11     (receive (rhead tail)
    12       (rsplit-with even? '(1 3 5 2 4 6))
    13       (list rhead tail))
    14     '((5 3 1) (2 4 6)))
    15   (equal?
    16     (receive (rhead tail)
    17       (rsplit-at 3 '(0 1 2 3 4 5 6))
    18       (list rhead tail))
    19     '((2 1 0) (3 4 5 6)))
    20   (equal?
    21     (reverse* '(10 20 30) '(1 2 3 4 5))
    22     '(30 20 10 1 2 3 4 5))
    23   (equal?
    24     (reverse* '(10 20 30) '(1 2 3 4 5) list)
    25     '(30 (20 (10 (1 2 3 4 5)))))
    26   (equal?
    27     (reverse* '(10 20 30) '0 list)
    28     '(30 (20 (10 . 0))))
    29   (equal?
    30     (reverse* '(10 20 30) '(0 . 1) list)
    31     '(30 (20 (10 (0 . 1)))))
    32   (equal?
    33     (reverse* '(10 20 30) '((0 . 1) (0 . 2)) list)
    34     '(30 (20 (10 (0 . 1) (0 . 2)))))
    35   (equal?
    36     (map* add1 '(0 (1 (2 . 3))))
    37     '(1 (2 (3 . 4))))
    38   (equal?
    39     (map* add1 '(0 (1 (2) 3) 4))
    40     '(1 (2 (3) 4) 5))
    41   (equal? (map* add1 '(0 1 2)) '(1 2 3))
    42   (= (map* add1 0) 1)
    43   (= ((repeat 3 add1) 0) 3)
    44   (equal? ((repeat 2 cdr) '(0 1 2 3)) '(2 3))
    45   (equal? (substring
    46              (symbol->string
    47                (proc-name (named-lambda (! n)
    48                             (if (zero? n) 1 (* n (! (- n 1)))))))
    49              0 1)
    50            "!")
    51   (equal? (map (named-lambda (! n) (if (zero? n) 1 (* n (! (- n 1)))))
    52                '(1 2 3 4 5))
    53           '(1 2 6 24 120))
    54   (eq? (proc-name number?) 'scheme#number?)
    55   (eq? (proc-name +) 'C_plus)
    56 )
    57 
    58 (define-test (Selectors)
     2        generic-functions generic-helpers simple-tests)
     3
     4(define-checks (List-helpers verbose?
     5                             xs '(0 1 2 3 4)
     6                             xss '(0 1 2 (3 4)))
     7  (map* add1 '(0 (1 (2 . 3))))
     8  '(1 (2 (3 . 4)))
     9  ((map* add1) '(0 (1 (2) 3) 4))
     10  '(1 (2 (3) 4) 5)
     11  ((map* add1) '(0 1 2))
     12  '(1 2 3)
     13  (map* add1 0)
     14  1
     15  ((repeat 3 add1) 0)
     16  3
     17  xs
     18  '(0 1 2 3 4)
     19  ((repeat 2 cdr) xs)
     20  '(2 3 4)
     21  (receive (yes no)
     22    ((filter odd?) xs)
     23    (list yes no))
     24  '((1 3) (0 2 4))
     25  (adjoin = 3 xs)
     26  xs
     27  ((adjoin = 5) xs)
     28  '(0 1 2 3 4 5)
     29  (insert-before = 20 60 xs)
     30  '(0 1 2 3 4 20)
     31  ((insert-before = 20 2) xs)
     32  '(0 1 20 2 3 4)
     33  (memp odd? xs)
     34  '(1 2 3 4)
     35  ((memp odd?) '(0 2 4))
     36  #f
     37  (assp odd? '((0 0) (1 10)))
     38  '(1 10)
     39  (assp odd? '((0 0) (2 20)))
     40  #f
     41  (condition-case (assp odd? '((0 0) 2 (1 10)))
     42    ((exn) #f))
     43  #f
     44  (let ((n (random-choice 0 1 2 3)))
     45    (if (memv n '(0 1 2 3)) #t #f))
     46  #t
     47  )
     48
     49(define-checks (Splitting verbose? xs '(0 1 2 3 4))
     50  (receive (rhead tail)
     51    (rsplit-with odd? '(1 3 5 2 4 6))
     52    (list rhead tail))
     53  '(() (1 3 5 2 4 6))
     54  (receive (rhead tail)
     55    ((rsplit-with even?) '(1 3 5 2 4 6))
     56    (list rhead tail))
     57  '((5 3 1) (2 4 6))
     58  (receive (rhead tail)
     59    (rsplit-at 3 '(0 1 2 3 4 5 6))
     60    (list rhead tail))
     61  '((2 1 0) (3 4 5 6))
     62  (reverse* '(10 20 30) '(1 2 3 4 5))
     63  '(30 20 10 1 2 3 4 5)
     64  (reverse* '(10 20 30) '(1 2 3 4 5) list)
     65  '(30 (20 (10 (1 2 3 4 5))))
     66  (reverse* '(10 20 30) '0 list)
     67  '(30 (20 (10 . 0)))
     68  (reverse* '(10 20 30) '(0 . 1) list)
     69  '(30 (20 (10 (0 . 1))))
     70  (reverse* '(10 20 30) '((0 . 1) (0 . 2)) list)
     71  '(30 (20 (10 (0 . 1) (0 . 2))))
     72  xs
     73  '(0 1 2 3 4)
     74  (receive (head tail)
     75    (split-at 2 xs)
     76    (list head tail))
     77  '((0 1) (2 3 4))
     78  (receive (head tail)
     79    ((split-with odd?) xs)
     80    (list head tail))
     81  '((0) (1 2 3 4))
     82  (receive (head tail)
     83    (split-along '(a b . c) xs)
     84    (list head tail))
     85  '((0 1) (2 3 4))
     86  (receive (head tail)
     87    ((split-along '(a . b)) xs)
     88    (list head tail))
     89  '((0) (1 2 3 4))
     90  )
     91       
     92(define-checks (Predicates verbose?
     93                           xs '(0 1 2 3))
     94  (any? 5)
     95  #t
     96  (none? 5)
     97  #f
     98  ((all? number?) xs)
     99  #t
     100  ((all? odd?) xs)
     101  #f
     102  ((some? odd?) xs)
     103  #t
     104  (apply (always #t) xs)
     105  #t
     106  (for-all symbol? '(a b c))
     107  #t
     108  (for-all = '(1 2 3) '(1.0 2.0 3.0))
     109  #t
     110  (exists memq '(a b c) '((A a) (b B) (C c)))
     111  '(a)
     112  (exists memq '(a b c) '((A B) (b B) (C c)))
     113  '(b B)
     114  (exists symbol? '(#f #\a "b" 5))
     115  #f
     116  (in? = 2 0 1 2 3)
     117  #t
     118  (in? = 5 0 1 2 3)
     119  #f
     120  )
     121
     122(mdefine* ys yss)
     123
     124(define-checks (Accessors verbose?
     125                          xs '(0 1 2 3 4)
     126                          xss '(0 1 2 (3 4)))
     127  xs
     128  '(0 1 2 3 4)
     129  (cxr 'ad xs)
     130  1
     131  (cxr 'dd xs)
     132  '(2 3 4)
     133  ((cxr 'add) xs)
     134  2
     135  ((cxr 'addd) xs)
     136  3
     137  (cxr '(1 a 3 d) xs)
     138  3
     139  xss
     140  '(0 1 2 (3 4))
     141  (cxr '(1 a 3 d) xss)
     142  '(3 4)
     143  (cxr '(2 a 3 d) xss)
     144  3
     145  ((cxr '(1 a 1 a 3 d)) xss)
     146  3
     147  (cxr '(1 a 1 d 1 a 3 d) xss)
     148  4
     149  xss
     150  '(0 1 2 (3 4))
     151  (cxr 'addd xss)
     152  '(3 4)
     153  (cxr 'daddd xss)
     154  '(4)
     155
     156  ys
     157  'ys
     158  yss
     159  'yss
     160  (mset! ys 1 yss 2)
     161  (void)
     162  ys
     163  1
     164  yss
     165  2
     166  )
     167
     168(define-checks (Destructuring-lambda verbose?
     169                 count-test
     170                 (let ((count 0))
     171                   (dlambda
     172                     (reset () (set! count 0) count)
     173                     (inc   (n) (set! count (+ count n)) count)
     174                     (dec   (n) (set! count (- count n)) count)
     175                     (bound (lo hi)
     176                            (set! count
     177                              (min hi (max lo count))) count)
     178                     (else () #f)
     179                     ))
     180                 fac-test
     181                 (dlambda (fac (n) (if (zero? n)
     182                                     1
     183                                     (* n (fac (- n 1))))))
     184                 )
     185  (count-test 'reset)
     186  0
     187  (count-test 'inc 2)
     188  2
     189  (count-test 'inc 2)
     190  4
     191  (count-test 'dec 2)
     192  2
     193  (count-test 'bound 3 5)
     194  3
     195  (count-test 'inc 2)
     196  5
     197  (count-test 'bound 4 6)
     198  5
     199  (count-test 'bound 2 3)
     200  3
     201  (count-test 'reset)
     202  0
     203  (count-test)
     204  #f
     205  (fac-test 'fac 5)
     206  120
     207  )
     208
     209(define-checks (Selectors verbose?)
    59210  (selector? fixnum??)
    60   (equal? (selector-parents fixnum??)
    61           `(,integer?? ,number?? ,any??))
    62   (eq? (index??) any??)
    63   )
    64 
    65 (define item (method-tree-item + number??))
     211  #t
     212  (map selector-name (selector-parents fixnum??))
     213  '(integer? number? any?)
     214  (selector-parent index??)
     215  any??
     216  ;; not eq? since different pointers:
     217  ;(selector-predicate index??)
     218  ;index?
     219  (selector-name number??)
     220  'number?
     221  ((selector-predicate number??) 5)
     222  (number? 5)
     223  ((selector-predicate number??) 'foo)
     224  (number? 'foo)
     225  )
     226
     227(define item (method-tree-item (method +) number??))
    66228(define tree
    67         (list (method-tree-item append list?? list??)))
     229        (list (method-tree-item (method append) list?? list??)))
    68230(define (fn+ x y) (+ x y))
    69231(define (nf+ x y) (+ x y))
    … …  
    71233(define-values (fff+ ffn+ fnf+ fnn+ nff+ nfn+ nnf+ nnn+)
    72234  (values mfx+ + + + + + + +))
    73 (define otree `((,fixnum?? (,fixnum?? (,fixnum?? . ,fff+)
    74                                       (,number?? . ,ffn+))
    75                            (,number?? (,fixnum?? . ,fnf+)
    76                                       (,number?? . ,fnn+)))
    77                 (,number?? (,fixnum?? (,fixnum?? . ,nff+)
    78                                       (,number?? . ,nfn+))
    79                            (,number?? (,fixnum?? . ,nnf+)
    80                                       (,number?? . ,nnn+)))))
    81 
    82 (define-test (Trees)
     235(define otree `((,fixnum?? (,fixnum?? (,fixnum?? . ,(method fff+))
     236                                      (,number?? . ,(method ffn+)))
     237                           (,number?? (,fixnum?? . ,(method fnf+))
     238                                      (,number?? . ,(method fnn+))))
     239                (,number?? (,fixnum?? (,fixnum?? . ,(method nff+))
     240                                      (,number?? . ,(method nfn+)))
     241                           (,number?? (,fixnum?? . ,(method nnf+))
     242                                      (,number?? . ,(method nnn+))))))
     243
     244(define-checks (Trees verbose?)
    83245  (method-tree-item? item)
    84   (equal? item `(,number?? . ,+))
     246  #t
     247  item
     248  `(,number?? . ,(method +))
    85249  (method-tree? (list item))
    86   (fx= (method-tree-depth (list item)) 1)
    87 
    88   (set! item (method-tree-item string-append string?? string??))
     250  #t
     251  (method-tree-depth (list item))
     252  1
     253
     254  (set! item (method-tree-item (method string-append) string?? string??))
     255  (void)
    89256  (method-tree-item? item)
    90   (equal? item `(,string?? (,string?? . ,string-append)))
     257  #t
     258  item
     259  `(,string?? (,string?? . ,(method string-append)))
    91260  (method-tree? (list item))
    92   (fx= (method-tree-depth (list item)) 2)
    93   (equal? (cadr item) `(,string?? . ,string-append))
    94   (eq? (cdadr item) string-append)
    95 
    96   (set! tree
    97         (method-tree-insert tree
    98                             (method-tree-item string-append
     261  #t
     262  (method-tree-depth (list item))
     263  2
     264  (cadr item)
     265  `(,string?? . ,(method string-append))
     266  (method-name (cdadr item))
     267  'string-append
     268
     269  (set! tree
     270        (method-tree-insert tree
     271                            (method-tree-item (method string-append)
    99272                                              string??
    100273                                              string??)))
     274  (void)
    101275  (set! tree
    102276        (method-tree-insert tree
    103                             (method-tree-item + number??  number??)))
     277                            (method-tree-item (method +) number??  number??)))
     278  (void)
    104279  (method-tree? tree)
    105   (fx= (method-tree-depth tree) 2)
    106   (equal? (method-tree-show tree)
    107     '((generics#list?? (generics#list?? . scheme#append))
    108       (generics#string?? (generics#string?? . scheme#string-append))
    109       (generics#number?? (generics#number?? . C_plus))
    110       ))
    111   (eq? (method-tree-dispatch tree '() '()) append)
    112   (eq? (method-tree-dispatch tree #t #t) #f)
    113   (eq? (method-tree-dispatch tree 0 0) +)
    114   (eq? (method-tree-dispatch tree "" "") string-append)
    115   (eq? (method-tree-dispatch tree '() 0) #f)
    116   (eq? (method-tree-dispatch tree 0 '()) #f)
    117   (eq? (method-tree-dispatch tree 0 "") #f)
    118 
    119   (set! tree
    120         (list (method-tree-item fx+ fixnum?? fixnum??)))
    121   (set! tree
    122         (method-tree-insert tree
    123                             (method-tree-item fn+ fixnum?? number??)))
    124   (set! tree
    125         (method-tree-insert tree
    126                             (method-tree-item nf+ number?? fixnum??)))
    127   (set! tree
    128         (method-tree-insert tree
    129                             (method-tree-item nn+ number?? number??)))
     280  #t
     281  (method-tree-depth tree)
     282  2
     283  (method-tree-show tree)
     284  '((list? (list? . append))
     285    (string? (string? . string-append))
     286    (number? (number? . +)))
     287  (method-name (method-tree-dispatch tree '() '()))
     288  'append
     289  (method-tree-dispatch tree #t #t)
     290  #f
     291  (method-name (method-tree-dispatch tree 0 0))
     292  '+
     293  (method-name (method-tree-dispatch tree "" ""))
     294  'string-append
     295  (method-tree-dispatch tree '() 0)
     296  #f
     297  (method-tree-dispatch tree 0 '())
     298  #f
     299  (method-tree-dispatch tree 0 "")
     300  #f
     301
     302  (set! tree
     303        (list (method-tree-item (method fx+) fixnum?? fixnum??)))
     304  (void)
     305  (set! tree
     306        (method-tree-insert tree
     307                            (method-tree-item (method fn+) fixnum?? number??)))
     308  (void)
     309  (set! tree
     310        (method-tree-insert tree
     311                            (method-tree-item (method nf+) number?? fixnum??)))
     312  (void)
     313  (set! tree
     314        (method-tree-insert tree
     315                            (method-tree-item (method nn+) number?? number??)))
     316  (void)
    130317  (method-tree? tree)
    131   (fx= (method-tree-depth tree) 2)
    132   (equal? (method-tree-show tree)
    133     '((generics#fixnum?? (generics#fixnum?? . chicken.fixnum#fx+)
    134                          (generics#number?? . fn+))
    135       (generics#number?? (generics#fixnum?? . nf+) (generics#number?? . nn+))))
    136   (eq? (method-tree-dispatch tree 0.0 0.0) nn+)
    137   (eq? (method-tree-dispatch tree 0 0.0) fn+)
    138   (eq? (method-tree-dispatch tree 0.0 0) nf+)
    139   (eq? (method-tree-dispatch tree 0 0) fx+)
    140   (not (method-tree-dispatch tree #f 0))
    141   (not (method-tree-dispatch tree 0 #f))
    142   (not (method-tree-dispatch tree #f #f))
    143 
    144   (set! tree
    145         (list (method-tree-item nnn+ number?? number?? number??)))
    146   ;(set! tree
    147   ;      (list (method-tree-item fff+ fixnum?? fixnum??  fixnum??)))
    148   (set! tree
    149         (method-tree-insert tree
    150                             (method-tree-item fff+
     318  #t
     319  (method-tree-depth tree)
     320  2
     321  (method-tree-show tree)
     322  '((fixnum? (fixnum? . fx+)
     323              (number? . fn+))
     324    (number? (fixnum? . nf+)
     325              (number? . nn+)))
     326  (method-name (method-tree-dispatch tree 0.0 0.0))
     327  'nn+
     328  (method-name (method-tree-dispatch tree 0 0.0))
     329  'fn+
     330  (method-name (method-tree-dispatch tree 0.0 0))
     331  'nf+
     332  (method-name (method-tree-dispatch tree 0 0))
     333  'fx+
     334  (method-tree-dispatch tree #f 0)
     335  #f
     336  (method-tree-dispatch tree 0 #f)
     337  #f
     338  (method-tree-dispatch tree #f #f)
     339  #f
     340
     341  (set! tree
     342        (list (method-tree-item (method nnn+) number?? number?? number??)))
     343  (void)
     344  (set! tree
     345        (method-tree-insert tree
     346                            (method-tree-item (method fff+)
    151347                                              fixnum??
    152348                                              fixnum??
    153349                                              fixnum??)))
    154   (set! tree
    155         (method-tree-insert tree
    156                             (method-tree-item ffn+
     350  (void)
     351  (set! tree
     352        (method-tree-insert tree
     353                            (method-tree-item (method ffn+)
    157354                                              fixnum??
    158355                                              fixnum??
    159356                                              number??)))
    160   (set! tree
    161         (method-tree-insert tree
    162                             (method-tree-item fnf+
     357  (void)
     358  (set! tree
     359        (method-tree-insert tree
     360                            (method-tree-item (method fnf+)
    163361                                              fixnum??
    164362                                              number??
    165363                                              fixnum??)))
    166   (set! tree
    167         (method-tree-insert tree
    168                             (method-tree-item fnn+
     364  (void)
     365  (set! tree
     366        (method-tree-insert tree
     367                            (method-tree-item (method fnn+)
    169368                                              fixnum??
    170369                                              number??
    171370                                              number??)))
    172   (set! tree
    173         (method-tree-insert tree
    174                             (method-tree-item nff+
     371  (void)
     372  (set! tree
     373        (method-tree-insert tree
     374                            (method-tree-item (method nff+)
    175375                                              number??
    176376                                              fixnum??
    177377                                              fixnum??)))
    178   (set! tree
    179         (method-tree-insert tree
    180                             (method-tree-item nfn+
     378  (void)
     379  (set! tree
     380        (method-tree-insert tree
     381                            (method-tree-item (method nfn+)
    181382                                              number??
    182383                                              fixnum??
    183384                                              number??)))
    184   (set! tree
    185         (method-tree-insert tree
    186                             (method-tree-item nnf+
     385  (void)
     386  (set! tree
     387        (method-tree-insert tree
     388                            (method-tree-item (method nnf+)
    187389                                              number??
    188390                                              number??
    189391                                              fixnum??)))
     392  (void)
    190393  (method-tree? tree)
    191   (fx= (method-tree-depth tree) 3)
    192   (equal? tree otree)
    193   (eq? (method-tree-dispatch tree 0 0 0) fff+)
    194   (eq? (method-tree-dispatch tree 0.0 0 0) nff+)
    195   (eq? (method-tree-dispatch tree 0 0 0.0) ffn+)
    196   (eq? (method-tree-dispatch tree 0 0.0 0.0) fnn+)
    197   (eq? (method-tree-dispatch tree 0 0.0 0) fnf+)
    198   (eq? (method-tree-dispatch tree 0.0 0.0 0.0) nnn+)
     394  #t
     395  (method-tree-depth tree)
     396  3
     397  (method-tree? otree)
     398  #t
     399  (method-tree-show tree)
     400  (method-tree-show otree)
     401  (method-name (method-tree-dispatch tree 0 0 0))
     402  'fff+
     403  (method-name (method-tree-dispatch tree 0.0 0 0))
     404  'nff+
     405  (method-name (method-tree-dispatch tree 0 0 0.0))
     406  'ffn+
     407  (method-name (method-tree-dispatch tree 0 0.0 0.0))
     408  'fnn+
     409  (method-name (method-tree-dispatch tree 0 0.0 0))
     410  'fnf+
     411  (method-name (method-tree-dispatch tree 0.0 0.0 0.0))
     412  'nnn+
     413
    199414  ;; override nnn+ with +
    200415  (set! tree
    201416        (method-tree-insert tree
    202                             (method-tree-item + number?? number??
    203                                          number??)))
    204   (eq? (method-tree-dispatch tree 0.0 0.0 0.0) +)
    205   (not (method-tree-dispatch tree 0 0 #f))
    206   (not (method-tree-dispatch tree 0 #f #f))
    207   (not (method-tree-dispatch tree #f 0 0))
    208   (not (method-tree-dispatch tree 0.0 0.0 #f))
    209   (not (method-tree-dispatch tree 0.0 0 #f))
    210   (not (method-tree-dispatch tree 0.0 #f 0.0))
    211   )
    212 
    213 (define-generic (Add (x number??) (y number??)) (+ x y))
    214 (define-generic (At (k index??) (seq list??)) (list-ref seq k))
    215 (define-generic (Drop (k index??) (seq list??)) (list-tail seq k))
    216 (define-generic (Take (k index??) (seq list??))
     417                            (method-tree-item (method +)
     418                                              number??
     419                                              number??
     420                                              number??)))
     421  (void)
     422  (method-name (method-tree-dispatch tree 0.0 0.0 0.0))
     423  '+
     424  (method-tree-dispatch tree 0 0 #f)
     425  #f
     426  (method-tree-dispatch tree 0 #f #f)
     427  #f
     428  (method-tree-dispatch tree #f 0 0)
     429  #f
     430  (method-tree-dispatch tree 0.0 0.0 #f)
     431  #f
     432  (method-tree-dispatch tree 0.0 0 #f)
     433  #f
     434  (method-tree-dispatch tree 0.0 #f 0.0)
     435  #f
     436  )
     437
     438(define-generic (Add x y) (error 'Add "no method found"))
     439(define-method (Add (x number??) (y number??)) (+ x y))
     440(define-generic (At k seq) (error 'At "no method found"))
     441(define-method (At (k index??) (seq list??)) (list-ref seq k))
     442(define-generic (Drop k seq) (error 'Drop "no method found"))
     443(define-method (Drop (k index??) (seq list??)) (list-tail seq k))
     444(define-generic (Take k seq) (error 'Take "no method found"))
     445(define-method (Take (k index??) (seq list??))
    217446                ;(compress (make-list k #t) seq))
    218447                (let loop ((n 0) (lst seq) (result '()))
    … …  
    222451                          (cdr lst)
    223452                          (cons (car lst) result)))))
    224 (define seq '(0 1 2 3 4))
    225 (define-generic (Add* xs number??) (apply + xs))
    226 
    227 (define-test (Generics)
     453(define-generic (Add* . xs) (error 'Add* "no method found"))
     454(define-method (Add* xs number??) (apply + xs))
     455
     456(define-checks (Generic-functions verbose? seq '(0 1 2 3 4))
    228457  (define-method  (Add (x fixnum??) (y fixnum??)) (fx+ x y))
     458  (void)
    229459  (generic? Add)
    230   (not (generic-variadic? Add))
    231   (fx= (generic-arity Add) 2)
    232   (= (Add 1 2.0) 3.0)
    233   (fx= (Add 1 2) 3)
    234   (not (condition-case (Add 1) ((exn) #f)))
    235   (not (condition-case (Add 1 #f) ((exn) #f)))
    236 
    237   (= (At 2 seq) 2)
    238   (equal? (Drop 2 seq) '(2 3 4))
    239   (equal? (Take 2 seq) '(0 1))
     460  #t
     461  (generic-variadic? Add)
     462  #f
     463  (generic-arity Add)
     464  2
     465  (Add 1 2.0)
     466  3.0
     467  (Add 1 2)
     468  3
     469  (condition-case (Add 1) ((exn) #f))
     470  #f
     471  (condition-case (Add 1 #f) ((exn) #f))
     472  #f
     473
     474  (At 2 seq)
     475  2
     476  (Drop 2 seq)
     477  '(2 3 4)
     478  (Take 2 seq)
     479  '(0 1)
    240480  (generic? At)
    241   (not (generic-variadic? At))
    242   (= (generic-arity At) 2)
     481  #t
     482  (generic-variadic? At)
     483  #f
     484  (generic-arity At)
     485  2
    243486  (define-method (At (k index??) (seq vector??)) (vector-ref seq k))
     487  (void)
    244488  (define-method (Drop (k index??) (seq vector??)) (subvector seq k))
     489  (void)
    245490  (define-method (Take (k index??) (seq vector??)) (subvector seq 0 k))
     491  (void)
    246492  (define-method (At (k index??) (seq string??)) (string-ref seq k))
     493  (void)
    247494  (define-method (Drop (k index??) (seq string??)) (substring seq k))
     495  (void)
    248496  (define-method (Take (k index??) (seq string??)) (substring seq 0 k))
    249   (not (generic-variadic? At))
    250   (fx= (generic-arity Take) 2)
    251   (string=? (Drop 2 "abcde") "cde")
    252   (fx= (At 2 seq) 2)
    253   (equal? (Take 2 #(0 1 2 3 4)) #(0 1))
     497  (void)
     498  (generic-variadic? At)
     499  #f
     500  (generic-arity Take)
     501  2
     502  (Drop 2 "abcde")
     503  "cde"
     504  (At 2 seq)
     505  2
     506  (Take 2 #(0 1 2 3 4))
     507  #(0 1)
    254508
    255509  (define-method (Add* xs list??) (apply append xs))
    256   (fx= (Add* 1 2 3) 6)
    257   (equal? (Add* '(1) '(2) '(3)) '(1 2 3))
     510  (void)
     511  (Add* 1 2 3)
     512  6
     513  (Add* '(1) '(2) '(3))
     514  '(1 2 3)
    258515  (define-method (Add* xs string??) (apply string-append xs))
    259   (string=? (Add* "1" "2" "3") "123")
    260   (not (condition-case (Add* 1 #f 3) ((exn) #f)))
     516  (void)
     517  (Add* "1" "2" "3")
     518  "123"
     519  (condition-case (Add* 1 #f 3) ((exn) #f))
     520  #f
    261521  (generic? Add*)
     522  #t
    262523  (generic-variadic? Add*)
    263   (fx= (generic-arity Add*) 1)
    264   )
    265 
    266 (compound-test (GENERICS)
    267   (Generic-helpers)
     524  #t
     525  (generic-arity Add*)
     526  1
     527  )
     528
     529(check-all GENERICS
     530  (List-helpers)
     531  (Splitting)
     532  (Predicates)
     533  (Accessors)
     534  (Destructuring-lambda)
    268535  (Selectors)
    269536  (Trees)
    270   (Generics)
    271   )
    272 
     537  (Generic-functions)
     538  )
     539

  • release/5/generics/trunk/generics.egg

    r38310 r38613  
    1 ((synopsis "an implementation of generic procedures")
     1((synopsis "an implementation of generic functions and a lot of helpers")
    22 (category lang-exts)
    33 (license "BSD")
    … …  
    55 (dependencies simple-cells)
    66 (author "Juergen Lorenz")
    7  (version "1.0.1")
     7 (version "2.0")
     8 (component-options
     9   (csc-options "-d0" "-O3"))
    810 (components
    9    (extension generics
    10      ;(csc-options "-d0" "-O3") ;fails with method-tree-show
    11      (csc-options "-d1" "-O3")
    12      (modules generic-helpers generics))))
     11   (extension generic-functions)
     12   (extension generic-helpers)))
    1313

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

    r37460 r38613  
    11(import scheme (chicken base) (chicken fixnum)
    2         generics generic-helpers simple-tests)
    3 
    4 (define-test (Generic-helpers)
    5   (equal?
    6     (receive (rhead tail)
    7       (rsplit-with odd? '(1 3 5 2 4 6))
    8       (list rhead tail))
    9     '(() (1 3 5 2 4 6)))
    10   (equal?
    11     (receive (rhead tail)
    12       (rsplit-with even? '(1 3 5 2 4 6))
    13       (list rhead tail))
    14     '((5 3 1) (2 4 6)))
    15   (equal?
    16     (receive (rhead tail)
    17       (rsplit-at 3 '(0 1 2 3 4 5 6))
    18       (list rhead tail))
    19     '((2 1 0) (3 4 5 6)))
    20   (equal?
    21     (reverse* '(10 20 30) '(1 2 3 4 5))
    22     '(30 20 10 1 2 3 4 5))
    23   (equal?
    24     (reverse* '(10 20 30) '(1 2 3 4 5) list)
    25     '(30 (20 (10 (1 2 3 4 5)))))
    26   (equal?
    27     (reverse* '(10 20 30) '0 list)
    28     '(30 (20 (10 . 0))))
    29   (equal?
    30     (reverse* '(10 20 30) '(0 . 1) list)
    31     '(30 (20 (10 (0 . 1)))))
    32   (equal?
    33     (reverse* '(10 20 30) '((0 . 1) (0 . 2)) list)
    34     '(30 (20 (10 (0 . 1) (0 . 2)))))
    35   (equal?
    36     (map* add1 '(0 (1 (2 . 3))))
    37     '(1 (2 (3 . 4))))
    38   (equal?
    39     (map* add1 '(0 (1 (2) 3) 4))
    40     '(1 (2 (3) 4) 5))
    41   (equal? (map* add1 '(0 1 2)) '(1 2 3))
    42   (= (map* add1 0) 1)
    43   (= ((repeat 3 add1) 0) 3)
    44   (equal? ((repeat 2 cdr) '(0 1 2 3)) '(2 3))
    45   (equal? (substring
    46              (symbol->string
    47                (proc-name (named-lambda (! n)
    48                             (if (zero? n) 1 (* n (! (- n 1)))))))
    49              0 1)
    50            "!")
    51   (equal? (map (named-lambda (! n) (if (zero? n) 1 (* n (! (- n 1)))))
    52                '(1 2 3 4 5))
    53           '(1 2 6 24 120))
    54   (eq? (proc-name number?) 'scheme#number?)
    55   (eq? (proc-name +) 'C_plus)
    56 )
    57 
    58 (define-test (Selectors)
     2        generic-functions generic-helpers simple-tests)
     3
     4(define-checks (List-helpers verbose?
     5                             xs '(0 1 2 3 4)
     6                             xss '(0 1 2 (3 4)))
     7  (map* add1 '(0 (1 (2 . 3))))
     8  '(1 (2 (3 . 4)))
     9  ((map* add1) '(0 (1 (2) 3) 4))
     10  '(1 (2 (3) 4) 5)
     11  ((map* add1) '(0 1 2))
     12  '(1 2 3)
     13  (map* add1 0)
     14  1
     15  ((repeat 3 add1) 0)
     16  3
     17  xs
     18  '(0 1 2 3 4)
     19  ((repeat 2 cdr) xs)
     20  '(2 3 4)
     21  (receive (yes no)
     22    ((filter odd?) xs)
     23    (list yes no))
     24  '((1 3) (0 2 4))
     25  (adjoin = 3 xs)
     26  xs
     27  ((adjoin = 5) xs)
     28  '(0 1 2 3 4 5)
     29  (insert-before = 20 60 xs)
     30  '(0 1 2 3 4 20)
     31  ((insert-before = 20 2) xs)
     32  '(0 1 20 2 3 4)
     33  (memp odd? xs)
     34  '(1 2 3 4)
     35  ((memp odd?) '(0 2 4))
     36  #f
     37  (assp odd? '((0 0) (1 10)))
     38  '(1 10)
     39  (assp odd? '((0 0) (2 20)))
     40  #f
     41  (condition-case (assp odd? '((0 0) 2 (1 10)))
     42    ((exn) #f))
     43  #f
     44  (let ((n (random-choice 0 1 2 3)))
     45    (if (memv n '(0 1 2 3)) #t #f))
     46  #t
     47  )
     48
     49(define-checks (Splitting verbose? xs '(0 1 2 3 4))
     50  (receive (rhead tail)
     51    (rsplit-with odd? '(1 3 5 2 4 6))
     52    (list rhead tail))
     53  '(() (1 3 5 2 4 6))
     54  (receive (rhead tail)
     55    ((rsplit-with even?) '(1 3 5 2 4 6))
     56    (list rhead tail))
     57  '((5 3 1) (2 4 6))
     58  (receive (rhead tail)
     59    (rsplit-at 3 '(0 1 2 3 4 5 6))
     60    (list rhead tail))
     61  '((2 1 0) (3 4 5 6))
     62  (reverse* '(10 20 30) '(1 2 3 4 5))
     63  '(30 20 10 1 2 3 4 5)
     64  (reverse* '(10 20 30) '(1 2 3 4 5) list)
     65  '(30 (20 (10 (1 2 3 4 5))))
     66  (reverse* '(10 20 30) '0 list)
     67  '(30 (20 (10 . 0)))
     68  (reverse* '(10 20 30) '(0 . 1) list)
     69  '(30 (20 (10 (0 . 1))))
     70  (reverse* '(10 20 30) '((0 . 1) (0 . 2)) list)
     71  '(30 (20 (10 (0 . 1) (0 . 2))))
     72  xs
     73  '(0 1 2 3 4)
     74  (receive (head tail)
     75    (split-at 2 xs)
     76    (list head tail))
     77  '((0 1) (2 3 4))
     78  (receive (head tail)
     79    ((split-with odd?) xs)
     80    (list head tail))
     81  '((0) (1 2 3 4))
     82  (receive (head tail)
     83    (split-along '(a b . c) xs)
     84    (list head tail))
     85  '((0 1) (2 3 4))
     86  (receive (head tail)
     87    ((split-along '(a . b)) xs)
     88    (list head tail))
     89  '((0) (1 2 3 4))
     90  )
     91       
     92(define-checks (Predicates verbose?
     93                           xs '(0 1 2 3))
     94  (any? 5)
     95  #t
     96  (none? 5)
     97  #f
     98  ((all? number?) xs)
     99  #t
     100  ((all? odd?) xs)
     101  #f
     102  ((some? odd?) xs)
     103  #t
     104  (apply (always #t) xs)
     105  #t
     106  (for-all symbol? '(a b c))
     107  #t
     108  (for-all = '(1 2 3) '(1.0 2.0 3.0))
     109  #t
     110  (exists memq '(a b c) '((A a) (b B) (C c)))
     111  '(a)
     112  (exists memq '(a b c) '((A B) (b B) (C c)))
     113  '(b B)
     114  (exists symbol? '(#f #\a "b" 5))
     115  #f
     116  (in? = 2 0 1 2 3)
     117  #t
     118  (in? = 5 0 1 2 3)
     119  #f
     120  )
     121
     122(mdefine* ys yss)
     123
     124(define-checks (Accessors verbose?
     125                          xs '(0 1 2 3 4)
     126                          xss '(0 1 2 (3 4)))
     127  xs
     128  '(0 1 2 3 4)
     129  (cxr 'ad xs)
     130  1
     131  (cxr 'dd xs)
     132  '(2 3 4)
     133  ((cxr 'add) xs)
     134  2
     135  ((cxr 'addd) xs)
     136  3
     137  (cxr '(1 a 3 d) xs)
     138  3
     139  xss
     140  '(0 1 2 (3 4))
     141  (cxr '(1 a 3 d) xss)
     142  '(3 4)
     143  (cxr '(2 a 3 d) xss)
     144  3
     145  ((cxr '(1 a 1 a 3 d)) xss)
     146  3
     147  (cxr '(1 a 1 d 1 a 3 d) xss)
     148  4
     149  xss
     150  '(0 1 2 (3 4))
     151  (cxr 'addd xss)
     152  '(3 4)
     153  (cxr 'daddd xss)
     154  '(4)
     155
     156  ys
     157  'ys
     158  yss
     159  'yss
     160  (mset! ys 1 yss 2)
     161  (void)
     162  ys
     163  1
     164  yss
     165  2
     166  )
     167
     168(define-checks (Destructuring-lambda verbose?
     169                 count-test
     170                 (let ((count 0))
     171                   (dlambda
     172                     (reset () (set! count 0) count)
     173                     (inc   (n) (set! count (+ count n)) count)
     174                     (dec   (n) (set! count (- count n)) count)
     175                     (bound (lo hi)
     176                            (set! count
     177                              (min hi (max lo count))) count)
     178                     (else () #f)
     179                     ))
     180                 fac-test
     181                 (dlambda (fac (n) (if (zero? n)
     182                                     1
     183                                     (* n (fac (- n 1))))))
     184                 )
     185  (count-test 'reset)
     186  0
     187  (count-test 'inc 2)
     188  2
     189  (count-test 'inc 2)
     190  4
     191  (count-test 'dec 2)
     192  2
     193  (count-test 'bound 3 5)
     194  3
     195  (count-test 'inc 2)
     196  5
     197  (count-test 'bound 4 6)
     198  5
     199  (count-test 'bound 2 3)
     200  3
     201  (count-test 'reset)
     202  0
     203  (count-test)
     204  #f
     205  (fac-test 'fac 5)
     206  120
     207  )
     208
     209(define-checks (Selectors verbose?)
    59210  (selector? fixnum??)
    60   (equal? (selector-parents fixnum??)
    61           `(,integer?? ,number?? ,any??))
    62   (eq? (index??) any??)
    63   )
    64 
    65 (define item (method-tree-item + number??))
     211  #t
     212  (map selector-name (selector-parents fixnum??))
     213  '(integer? number? any?)
     214  (selector-parent index??)
     215  any??
     216  ;; not eq? since different pointers:
     217  ;(selector-predicate index??)
     218  ;index?
     219  (selector-name number??)
     220  'number?
     221  ((selector-predicate number??) 5)
     222  (number? 5)
     223  ((selector-predicate number??) 'foo)
     224  (number? 'foo)
     225  )
     226
     227(define item (method-tree-item (method +) number??))
    66228(define tree
    67         (list (method-tree-item append list?? list??)))
     229        (list (method-tree-item (method append) list?? list??)))
    68230(define (fn+ x y) (+ x y))
    69231(define (nf+ x y) (+ x y))
    … …  
    71233(define-values (fff+ ffn+ fnf+ fnn+ nff+ nfn+ nnf+ nnn+)
    72234  (values mfx+ + + + + + + +))
    73 (define otree `((,fixnum?? (,fixnum?? (,fixnum?? . ,fff+)
    74                                       (,number?? . ,ffn+))
    75                            (,number?? (,fixnum?? . ,fnf+)
    76                                       (,number?? . ,fnn+)))
    77                 (,number?? (,fixnum?? (,fixnum?? . ,nff+)
    78                                       (,number?? . ,nfn+))
    79                            (,number?? (,fixnum?? . ,nnf+)
    80                                       (,number?? . ,nnn+)))))
    81 
    82 (define-test (Trees)
     235(define otree `((,fixnum?? (,fixnum?? (,fixnum?? . ,(method fff+))
     236                                      (,number?? . ,(method ffn+)))
     237                           (,number?? (,fixnum?? . ,(method fnf+))
     238                                      (,number?? . ,(method fnn+))))
     239                (,number?? (,fixnum?? (,fixnum?? . ,(method nff+))
     240                                      (,number?? . ,(method nfn+)))
     241                           (,number?? (,fixnum?? . ,(method nnf+))
     242                                      (,number?? . ,(method nnn+))))))
     243
     244(define-checks (Trees verbose?)
    83245  (method-tree-item? item)
    84   (equal? item `(,number?? . ,+))
     246  #t
     247  item
     248  `(,number?? . ,(method +))
    85249  (method-tree? (list item))
    86   (fx= (method-tree-depth (list item)) 1)
    87 
    88   (set! item (method-tree-item string-append string?? string??))
     250  #t
     251  (method-tree-depth (list item))
     252  1
     253
     254  (set! item (method-tree-item (method string-append) string?? string??))
     255  (void)
    89256  (method-tree-item? item)
    90   (equal? item `(,string?? (,string?? . ,string-append)))
     257  #t
     258  item
     259  `(,string?? (,string?? . ,(method string-append)))
    91260  (method-tree? (list item))
    92   (fx= (method-tree-depth (list item)) 2)
    93   (equal? (cadr item) `(,string?? . ,string-append))
    94   (eq? (cdadr item) string-append)
    95 
    96   (set! tree
    97         (method-tree-insert tree
    98                             (method-tree-item string-append
     261  #t
     262  (method-tree-depth (list item))
     263  2
     264  (cadr item)
     265  `(,string?? . ,(method string-append))
     266  (method-name (cdadr item))
     267  'string-append
     268
     269  (set! tree
     270        (method-tree-insert tree
     271                            (method-tree-item (method string-append)
    99272                                              string??
    100273                                              string??)))
     274  (void)
    101275  (set! tree
    102276        (method-tree-insert tree
    103                             (method-tree-item + number??  number??)))
     277                            (method-tree-item (method +) number??  number??)))
     278  (void)
    104279  (method-tree? tree)
    105   (fx= (method-tree-depth tree) 2)
    106   (equal? (method-tree-show tree)
    107     '((generics#list?? (generics#list?? . scheme#append))
    108       (generics#string?? (generics#string?? . scheme#string-append))
    109       (generics#number?? (generics#number?? . C_plus))
    110       ))
    111   (eq? (method-tree-dispatch tree '() '()) append)
    112   (eq? (method-tree-dispatch tree #t #t) #f)
    113   (eq? (method-tree-dispatch tree 0 0) +)
    114   (eq? (method-tree-dispatch tree "" "") string-append)
    115   (eq? (method-tree-dispatch tree '() 0) #f)
    116   (eq? (method-tree-dispatch tree 0 '()) #f)
    117   (eq? (method-tree-dispatch tree 0 "") #f)
    118 
    119   (set! tree
    120         (list (method-tree-item fx+ fixnum?? fixnum??)))
    121   (set! tree
    122         (method-tree-insert tree
    123                             (method-tree-item fn+ fixnum?? number??)))
    124   (set! tree
    125         (method-tree-insert tree
    126                             (method-tree-item nf+ number?? fixnum??)))
    127   (set! tree
    128         (method-tree-insert tree
    129                             (method-tree-item nn+ number?? number??)))
     280  #t
     281  (method-tree-depth tree)
     282  2
     283  (method-tree-show tree)
     284  '((list? (list? . append))
     285    (string? (string? . string-append))
     286    (number? (number? . +)))
     287  (method-name (method-tree-dispatch tree '() '()))
     288  'append
     289  (method-tree-dispatch tree #t #t)
     290  #f
     291  (method-name (method-tree-dispatch tree 0 0))
     292  '+
     293  (method-name (method-tree-dispatch tree "" ""))
     294  'string-append
     295  (method-tree-dispatch tree '() 0)
     296  #f
     297  (method-tree-dispatch tree 0 '())
     298  #f
     299  (method-tree-dispatch tree 0 "")
     300  #f
     301
     302  (set! tree
     303        (list (method-tree-item (method fx+) fixnum?? fixnum??)))
     304  (void)
     305  (set! tree
     306        (method-tree-insert tree
     307                            (method-tree-item (method fn+) fixnum?? number??)))
     308  (void)
     309  (set! tree
     310        (method-tree-insert tree
     311                            (method-tree-item (method nf+) number?? fixnum??)))
     312  (void)
     313  (set! tree
     314        (method-tree-insert tree
     315                            (method-tree-item (method nn+) number?? number??)))
     316  (void)
    130317  (method-tree? tree)
    131   (fx= (method-tree-depth tree) 2)
    132   (equal? (method-tree-show tree)
    133     '((generics#fixnum?? (generics#fixnum?? . chicken.fixnum#fx+)
    134                          (generics#number?? . fn+))
    135       (generics#number?? (generics#fixnum?? . nf+) (generics#number?? . nn+))))
    136   (eq? (method-tree-dispatch tree 0.0 0.0) nn+)
    137   (eq? (method-tree-dispatch tree 0 0.0) fn+)
    138   (eq? (method-tree-dispatch tree 0.0 0) nf+)
    139   (eq? (method-tree-dispatch tree 0 0) fx+)
    140   (not (method-tree-dispatch tree #f 0))
    141   (not (method-tree-dispatch tree 0 #f))
    142   (not (method-tree-dispatch tree #f #f))
    143 
    144   (set! tree
    145         (list (method-tree-item nnn+ number?? number?? number??)))
    146   ;(set! tree
    147   ;      (list (method-tree-item fff+ fixnum?? fixnum??  fixnum??)))
    148   (set! tree
    149         (method-tree-insert tree
    150                             (method-tree-item fff+
     318  #t
     319  (method-tree-depth tree)
     320  2
     321  (method-tree-show tree)
     322  '((fixnum? (fixnum? . fx+)
     323              (number? . fn+))
     324    (number? (fixnum? . nf+)
     325              (number? . nn+)))
     326  (method-name (method-tree-dispatch tree 0.0 0.0))
     327  'nn+
     328  (method-name (method-tree-dispatch tree 0 0.0))
     329  'fn+
     330  (method-name (method-tree-dispatch tree 0.0 0))
     331  'nf+
     332  (method-name (method-tree-dispatch tree 0 0))
     333  'fx+
     334  (method-tree-dispatch tree #f 0)
     335  #f
     336  (method-tree-dispatch tree 0 #f)
     337  #f
     338  (method-tree-dispatch tree #f #f)
     339  #f
     340
     341  (set! tree
     342        (list (method-tree-item (method nnn+) number?? number?? number??)))
     343  (void)
     344  (set! tree
     345        (method-tree-insert tree
     346                            (method-tree-item (method fff+)
    151347                                              fixnum??
    152348                                              fixnum??
    153349                                              fixnum??)))
    154   (set! tree
    155         (method-tree-insert tree
    156                             (method-tree-item ffn+
     350  (void)
     351  (set! tree
     352        (method-tree-insert tree
     353                            (method-tree-item (method ffn+)
    157354                                              fixnum??
    158355                                              fixnum??
    159356                                              number??)))
    160   (set! tree
    161         (method-tree-insert tree
    162                             (method-tree-item fnf+
     357  (void)
     358  (set! tree
     359        (method-tree-insert tree
     360                            (method-tree-item (method fnf+)
    163361                                              fixnum??
    164362                                              number??
    165363                                              fixnum??)))
    166   (set! tree
    167         (method-tree-insert tree
    168                             (method-tree-item fnn+
     364  (void)
     365  (set! tree
     366        (method-tree-insert tree
     367                            (method-tree-item (method fnn+)
    169368                                              fixnum??
    170369                                              number??
    171370                                              number??)))
    172   (set! tree
    173         (method-tree-insert tree
    174                             (method-tree-item nff+
     371  (void)
     372  (set! tree
     373        (method-tree-insert tree
     374                            (method-tree-item (method nff+)
    175375                                              number??
    176376                                              fixnum??
    177377                                              fixnum??)))
    178   (set! tree
    179         (method-tree-insert tree
    180                             (method-tree-item nfn+
     378  (void)
     379  (set! tree
     380        (method-tree-insert tree
     381                            (method-tree-item (method nfn+)
    181382                                              number??
    182383                                              fixnum??
    183384                                              number??)))
    184   (set! tree
    185         (method-tree-insert tree
    186                             (method-tree-item nnf+
     385  (void)
     386  (set! tree
     387        (method-tree-insert tree
     388                            (method-tree-item (method nnf+)
    187389                                              number??
    188390                                              number??
    189391                                              fixnum??)))
     392  (void)
    190393  (method-tree? tree)
    191   (fx= (method-tree-depth tree) 3)
    192   (equal? tree otree)
    193   (eq? (method-tree-dispatch tree 0 0 0) fff+)
    194   (eq? (method-tree-dispatch tree 0.0 0 0) nff+)
    195   (eq? (method-tree-dispatch tree 0 0 0.0) ffn+)
    196   (eq? (method-tree-dispatch tree 0 0.0 0.0) fnn+)
    197   (eq? (method-tree-dispatch tree 0 0.0 0) fnf+)
    198   (eq? (method-tree-dispatch tree 0.0 0.0 0.0) nnn+)
     394  #t
     395  (method-tree-depth tree)
     396  3
     397  (method-tree? otree)
     398  #t
     399  (method-tree-show tree)
     400  (method-tree-show otree)
     401  (method-name (method-tree-dispatch tree 0 0 0))
     402  'fff+
     403  (method-name (method-tree-dispatch tree 0.0 0 0))
     404  'nff+
     405  (method-name (method-tree-dispatch tree 0 0 0.0))
     406  'ffn+
     407  (method-name (method-tree-dispatch tree 0 0.0 0.0))
     408  'fnn+
     409  (method-name (method-tree-dispatch tree 0 0.0 0))
     410  'fnf+
     411  (method-name (method-tree-dispatch tree 0.0 0.0 0.0))
     412  'nnn+
     413
    199414  ;; override nnn+ with +
    200415  (set! tree
    201416        (method-tree-insert tree
    202                             (method-tree-item + number?? number??
    203                                          number??)))
    204   (eq? (method-tree-dispatch tree 0.0 0.0 0.0) +)
    205   (not (method-tree-dispatch tree 0 0 #f))
    206   (not (method-tree-dispatch tree 0 #f #f))
    207   (not (method-tree-dispatch tree #f 0 0))
    208   (not (method-tree-dispatch tree 0.0 0.0 #f))
    209   (not (method-tree-dispatch tree 0.0 0 #f))
    210   (not (method-tree-dispatch tree 0.0 #f 0.0))
    211   )
    212 
    213 (define-generic (Add (x number??) (y number??)) (+ x y))
    214 (define-generic (At (k index??) (seq list??)) (list-ref seq k))
    215 (define-generic (Drop (k index??) (seq list??)) (list-tail seq k))
    216 (define-generic (Take (k index??) (seq list??))
     417                            (method-tree-item (method +)
     418                                              number??
     419                                              number??
     420                                              number??)))
     421  (void)
     422  (method-name (method-tree-dispatch tree 0.0 0.0 0.0))
     423  '+
     424  (method-tree-dispatch tree 0 0 #f)
     425  #f
     426  (method-tree-dispatch tree 0 #f #f)
     427  #f
     428  (method-tree-dispatch tree #f 0 0)
     429  #f
     430  (method-tree-dispatch tree 0.0 0.0 #f)
     431  #f
     432  (method-tree-dispatch tree 0.0 0 #f)
     433  #f
     434  (method-tree-dispatch tree 0.0 #f 0.0)
     435  #f
     436  )
     437
     438(define-generic (Add x y) (error 'Add "no method found"))
     439(define-method (Add (x number??) (y number??)) (+ x y))
     440(define-generic (At k seq) (error 'At "no method found"))
     441(define-method (At (k index??) (seq list??)) (list-ref seq k))
     442(define-generic (Drop k seq) (error 'Drop "no method found"))
     443(define-method (Drop (k index??) (seq list??)) (list-tail seq k))
     444(define-generic (Take k seq) (error 'Take "no method found"))
     445(define-method (Take (k index??) (seq list??))
    217446                ;(compress (make-list k #t) seq))
    218447                (let loop ((n 0) (lst seq) (result '()))
    … …  
    222451                          (cdr lst)
    223452                          (cons (car lst) result)))))
    224 (define seq '(0 1 2 3 4))
    225 (define-generic (Add* xs number??) (apply + xs))
    226 
    227 (define-test (Generics)
     453(define-generic (Add* . xs) (error 'Add* "no method found"))
     454(define-method (Add* xs number??) (apply + xs))
     455
     456(define-checks (Generic-functions verbose? seq '(0 1 2 3 4))
    228457  (define-method  (Add (x fixnum??) (y fixnum??)) (fx+ x y))
     458  (void)
    229459  (generic? Add)
    230   (not (generic-variadic? Add))
    231   (fx= (generic-arity Add) 2)
    232   (= (Add 1 2.0) 3.0)
    233   (fx= (Add 1 2) 3)
    234   (not (condition-case (Add 1) ((exn) #f)))
    235   (not (condition-case (Add 1 #f) ((exn) #f)))
    236 
    237   (= (At 2 seq) 2)
    238   (equal? (Drop 2 seq) '(2 3 4))
    239   (equal? (Take 2 seq) '(0 1))
     460  #t
     461  (generic-variadic? Add)
     462  #f
     463  (generic-arity Add)
     464  2
     465  (Add 1 2.0)
     466  3.0
     467  (Add 1 2)
     468  3
     469  (condition-case (Add 1) ((exn) #f))
     470  #f
     471  (condition-case (Add 1 #f) ((exn) #f))
     472  #f
     473
     474  (At 2 seq)
     475  2
     476  (Drop 2 seq)
     477  '(2 3 4)
     478  (Take 2 seq)
     479  '(0 1)
    240480  (generic? At)
    241   (not (generic-variadic? At))
    242   (= (generic-arity At) 2)
     481  #t
     482  (generic-variadic? At)
     483  #f
     484  (generic-arity At)
     485  2
    243486  (define-method (At (k index??) (seq vector??)) (vector-ref seq k))
     487  (void)
    244488  (define-method (Drop (k index??) (seq vector??)) (subvector seq k))
     489  (void)
    245490  (define-method (Take (k index??) (seq vector??)) (subvector seq 0 k))
     491  (void)
    246492  (define-method (At (k index??) (seq string??)) (string-ref seq k))
     493  (void)
    247494  (define-method (Drop (k index??) (seq string??)) (substring seq k))
     495  (void)
    248496  (define-method (Take (k index??) (seq string??)) (substring seq 0 k))
    249   (not (generic-variadic? At))
    250   (fx= (generic-arity Take) 2)
    251   (string=? (Drop 2 "abcde") "cde")
    252   (fx= (At 2 seq) 2)
    253   (equal? (Take 2 #(0 1 2 3 4)) #(0 1))
     497  (void)
     498  (generic-variadic? At)
     499  #f
     500  (generic-arity Take)
     501  2
     502  (Drop 2 "abcde")
     503  "cde"
     504  (At 2 seq)
     505  2
     506  (Take 2 #(0 1 2 3 4))
     507  #(0 1)
    254508
    255509  (define-method (Add* xs list??) (apply append xs))
    256   (fx= (Add* 1 2 3) 6)
    257   (equal? (Add* '(1) '(2) '(3)) '(1 2 3))
     510  (void)
     511  (Add* 1 2 3)
     512  6
     513  (Add* '(1) '(2) '(3))
     514  '(1 2 3)
    258515  (define-method (Add* xs string??) (apply string-append xs))
    259   (string=? (Add* "1" "2" "3") "123")
    260   (not (condition-case (Add* 1 #f 3) ((exn) #f)))
     516  (void)
     517  (Add* "1" "2" "3")
     518  "123"
     519  (condition-case (Add* 1 #f 3) ((exn) #f))
     520  #f
    261521  (generic? Add*)
     522  #t
    262523  (generic-variadic? Add*)
    263   (fx= (generic-arity Add*) 1)
    264   )
    265 
    266 (compound-test (GENERICS)
    267   (Generic-helpers)
     524  #t
     525  (generic-arity Add*)
     526  1
     527  )
     528
     529(check-all GENERICS
     530  (List-helpers)
     531  (Splitting)
     532  (Predicates)
     533  (Accessors)
     534  (Destructuring-lambda)
    268535  (Selectors)
    269536  (Trees)
    270   (Generics)
    271   )
    272 
     537  (Generic-functions)
     538  )
     539
Note: See TracChangeset for help on using the changeset viewer.