- Timestamp:
- 04/15/20 13:10:55 (10 months ago)
- 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") 2 2 (category lang-exts) 3 3 (license "BSD") … … 5 5 (dependencies simple-cells) 6 6 (author "Juergen Lorenz") 7 (version "1.0.1") 7 (version "2.0") 8 (component-options 9 (csc-options "-d0" "-O3")) 8 10 (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))) 13 13 -
release/5/generics/tags/2.0/tests/run.scm
r37460 r38613 1 1 (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?) 59 210 (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??)) 66 228 (define tree 67 (list (method-tree-item appendlist?? list??)))229 (list (method-tree-item (method append) list?? list??))) 68 230 (define (fn+ x y) (+ x y)) 69 231 (define (nf+ x y) (+ x y)) … … 71 233 (define-values (fff+ ffn+ fnf+ fnn+ nff+ nfn+ nnf+ nnn+) 72 234 (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?) 83 245 (method-tree-item? item) 84 (equal? item `(,number?? . ,+)) 246 #t 247 item 248 `(,number?? . ,(method +)) 85 249 (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) 89 256 (method-tree-item? item) 90 (equal? item `(,string?? (,string?? . ,string-append))) 257 #t 258 item 259 `(,string?? (,string?? . ,(method string-append))) 91 260 (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) 99 272 string?? 100 273 string??))) 274 (void) 101 275 (set! tree 102 276 (method-tree-insert tree 103 (method-tree-item + number?? number??))) 277 (method-tree-item (method +) number?? number??))) 278 (void) 104 279 (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) 130 317 (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+) 151 347 fixnum?? 152 348 fixnum?? 153 349 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+) 157 354 fixnum?? 158 355 fixnum?? 159 356 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+) 163 361 fixnum?? 164 362 number?? 165 363 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+) 169 368 fixnum?? 170 369 number?? 171 370 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+) 175 375 number?? 176 376 fixnum?? 177 377 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+) 181 382 number?? 182 383 fixnum?? 183 384 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+) 187 389 number?? 188 390 number?? 189 391 fixnum??))) 392 (void) 190 393 (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 199 414 ;; override nnn+ with + 200 415 (set! tree 201 416 (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??)) 217 446 ;(compress (make-list k #t) seq)) 218 447 (let loop ((n 0) (lst seq) (result '())) … … 222 451 (cdr lst) 223 452 (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)) 228 457 (define-method (Add (x fixnum??) (y fixnum??)) (fx+ x y)) 458 (void) 229 459 (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) 240 480 (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 243 486 (define-method (At (k index??) (seq vector??)) (vector-ref seq k)) 487 (void) 244 488 (define-method (Drop (k index??) (seq vector??)) (subvector seq k)) 489 (void) 245 490 (define-method (Take (k index??) (seq vector??)) (subvector seq 0 k)) 491 (void) 246 492 (define-method (At (k index??) (seq string??)) (string-ref seq k)) 493 (void) 247 494 (define-method (Drop (k index??) (seq string??)) (substring seq k)) 495 (void) 248 496 (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) 254 508 255 509 (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) 258 515 (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 261 521 (generic? Add*) 522 #t 262 523 (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) 268 535 (Selectors) 269 536 (Trees) 270 (Generic s)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") 2 2 (category lang-exts) 3 3 (license "BSD") … … 5 5 (dependencies simple-cells) 6 6 (author "Juergen Lorenz") 7 (version "1.0.1") 7 (version "2.0") 8 (component-options 9 (csc-options "-d0" "-O3")) 8 10 (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))) 13 13 -
release/5/generics/trunk/tests/run.scm
r37460 r38613 1 1 (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?) 59 210 (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??)) 66 228 (define tree 67 (list (method-tree-item appendlist?? list??)))229 (list (method-tree-item (method append) list?? list??))) 68 230 (define (fn+ x y) (+ x y)) 69 231 (define (nf+ x y) (+ x y)) … … 71 233 (define-values (fff+ ffn+ fnf+ fnn+ nff+ nfn+ nnf+ nnn+) 72 234 (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?) 83 245 (method-tree-item? item) 84 (equal? item `(,number?? . ,+)) 246 #t 247 item 248 `(,number?? . ,(method +)) 85 249 (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) 89 256 (method-tree-item? item) 90 (equal? item `(,string?? (,string?? . ,string-append))) 257 #t 258 item 259 `(,string?? (,string?? . ,(method string-append))) 91 260 (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) 99 272 string?? 100 273 string??))) 274 (void) 101 275 (set! tree 102 276 (method-tree-insert tree 103 (method-tree-item + number?? number??))) 277 (method-tree-item (method +) number?? number??))) 278 (void) 104 279 (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) 130 317 (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+) 151 347 fixnum?? 152 348 fixnum?? 153 349 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+) 157 354 fixnum?? 158 355 fixnum?? 159 356 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+) 163 361 fixnum?? 164 362 number?? 165 363 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+) 169 368 fixnum?? 170 369 number?? 171 370 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+) 175 375 number?? 176 376 fixnum?? 177 377 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+) 181 382 number?? 182 383 fixnum?? 183 384 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+) 187 389 number?? 188 390 number?? 189 391 fixnum??))) 392 (void) 190 393 (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 199 414 ;; override nnn+ with + 200 415 (set! tree 201 416 (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??)) 217 446 ;(compress (make-list k #t) seq)) 218 447 (let loop ((n 0) (lst seq) (result '())) … … 222 451 (cdr lst) 223 452 (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)) 228 457 (define-method (Add (x fixnum??) (y fixnum??)) (fx+ x y)) 458 (void) 229 459 (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) 240 480 (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 243 486 (define-method (At (k index??) (seq vector??)) (vector-ref seq k)) 487 (void) 244 488 (define-method (Drop (k index??) (seq vector??)) (subvector seq k)) 489 (void) 245 490 (define-method (Take (k index??) (seq vector??)) (subvector seq 0 k)) 491 (void) 246 492 (define-method (At (k index??) (seq string??)) (string-ref seq k)) 493 (void) 247 494 (define-method (Drop (k index??) (seq string??)) (substring seq k)) 495 (void) 248 496 (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) 254 508 255 509 (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) 258 515 (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 261 521 (generic? Add*) 522 #t 262 523 (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) 268 535 (Selectors) 269 536 (Trees) 270 (Generic s)271 ) 272 537 (Generic-functions) 538 ) 539
Note: See TracChangeset
for help on using the changeset viewer.