1: ;;
    2: ;; Test for SRFIs
    3: ;;
    4: 
    5: ;; $Id: srfi.scm,v 1.45 2007/04/05 05:56:58 shirok Exp $
    6: 
    7: (use gauche.test)
    8: 
    9: (test-start "SRFIs")
   10: 
   11: ;;-----------------------------------------------------------------------
   12: (test-section "srfi-0")
   13: 
   14: (test* "cond-expand" 0
   15:        (cond-expand (srfi-0 0) (else 1)))
   16: (test* "cond-expand" 1
   17:        (cond-expand (hogehoge 0) (else 1)))
   18: (test* "cond-expand" 0
   19:        (cond-expand ((and srfi-0 srfi-1) 0) (else 1)))
   20: (test* "cond-expand" #t
   21:        (cond-expand ((and srfi-2 srfi-1) (procedure? xcons)) (else #f)))
   22: (test* "cond-expand" 0
   23:        (cond-expand ((or hogehoge srfi-1) 0) (else 1)))
   24: (test* "cond-expand" 0
   25:        (cond-expand ((or srfi-1 hogehoge) 0) (else 1)))
   26: (test* "cond-expand" 1
   27:        (cond-expand ((or (not srfi-1) hogehoge) 0) (else 1)))
   28: (test* "cond-expand" 0
   29:        (cond-expand (gauche 0) (else 1)))
   30: (test* "cond-expand" 0
   31:        (cond-expand (scm -1) (gauche 0) (else 1)))
   32: 
   33: ;;-----------------------------------------------------------------------
   34: (test-section "srfi-2")
   35: (use srfi-2)
   36: (test-module 'srfi-2)
   37: 
   38: (define (srfi-2-look-up key alist)
   39:   (and-let* ((x (assq key alist))) (cdr x)))
   40: (test* "and-let*" 3
   41:        (srfi-2-look-up 'c '((a . 1) (b . 2) (c . 3))))
   42: (test* "and-let*" #f
   43:        (srfi-2-look-up 'd '((a . 1) (b . 2) (c . 3))))
   44: (test* "and-let*" 3
   45:        (let ((x 3))
   46:          (and-let* (((positive? x))
   47:                     (y x))
   48:            y)))
   49: (test* "and-let*" #f
   50:        (let ((x -3))
   51:          (and-let* (((positive? x))
   52:                     (y x))
   53:            y)))
   54: 
   55: ;;-----------------------------------------------------------------------
   56: (test-section "srfi-5")
   57: ;; NB: srfi-5 replaces the binding of 'let'.  We don't want it to interfere
   58: ;; with the rest of file, so we segregate it within a dummy module.
   59: 
   60: (define-module srfi-5-test
   61:   (use gauche.test)
   62:   (use srfi-5)
   63:   (test-module 'srfi-5)
   64: 
   65:   (test* "let - standard" 3
   66:          (let ((x 1) (y 2))
   67:            (let ()
   68:              (+ x y))))
   69: 
   70:   (test* "let - standard" 1
   71:          (let ((x 1) (y 2))
   72:            (let ((y x) (x y))
   73:              (- x y))))
   74: 
   75:   (test* "let - standard" 1
   76:          (let ()
   77:            (define x 1)
   78:            (* x x)))
   79: 
   80:   (test* "let - standard, named" 55
   81:          (let loop ((x 1) (sum 0))
   82:            (if (> x 10) sum (loop (+ x 1) (+ sum x)))))
   83: 
   84:   (test* "let - signature style" 55
   85:          (let (loop (x 1) (sum 0))
   86:            (if (> x 10) sum (loop (+ x 1) (+ sum x)))))
   87: 
   88:   (test* "let - signature style" #t
   89:          (let (loop)
   90:            (procedure? loop)))
   91: 
   92:   (test* "let - rest binding" '(0 1 (2 3 4))
   93:          (let ((x 0) (y 1) . (z 2 3 4)) (list x y z)))
   94: 
   95:   (test* "let - rest binding, named" '((2 3 4) 0 (1))
   96:          (let loop ((x 0) (y 1) . (z 2 3 4))
   97:            (if (list? x) (list x y z) (loop z x y))))
   98:   )
   99: 
  100: ;;-----------------------------------------------------------------------
  101: (test-section "srfi-7")
  102: 
  103: ;; NB: srfi-7 is a "meta-language".   The 'program' form doesn't need
  104: ;; to be evaluated within Scheme---an implementation can use a preprocessor
  105: ;; to produce an evaluatable form from the 'program' form.
  106: ;; Gauche directly expands it within the macro processor and evaluates it.
  107: ;;
  108: ;; These tests also relies on how Gauche compiles the empty begin form.
  109: ;; See the notes in lib/srfi-7.scm for the details.
  110: 
  111: (sys-system "rm -rf test.o")
  112: (sys-system "mkdir test.o")
  113: (with-output-to-file "test.o/a.scm"
  114:   (lambda ()
  115:     (write '(define x 3))))
  116: (with-output-to-file "test.o/b.scm"
  117:   (lambda ()
  118:     (write '(define (y) (+ x x)))))
  119: 
  120: (test* "program (empty)" 'ok
  121:        (begin (eval '(program) (make-module #f))
  122:               'ok))
  123: 
  124: (test* "program (requires, code)" #t
  125:        (eval '(program
  126:                (requires srfi-1)
  127:                (code (procedure? list-tabulate)))
  128:              (make-module #f)))
  129: (test* "program (requires, multiple code)" '(1 2 1)
  130:        (eval '(program
  131:                (requires srfi-1)
  132:                (code (define foo (circular-list 1 2)))
  133:                (requires srfi-2)
  134:                (code (and-let* ((x (circular-list? foo)))
  135:                        (take foo 3))))
  136:              (make-module #f)))
  137: (test* "program (requires, no such feature)" *test-error*
  138:        (eval '(program
  139:                (requires no-such-feature))
  140:              (make-module #f)))
  141: (test* "program (files (empty))" '(1 . 2)
  142:        (eval '(program
  143:                (files)
  144:                (code (cons 1 2)))
  145:              (make-module #f)))
  146: (test* "program (files)" 6
  147:        (eval '(program
  148:                (files "./test.o/a")
  149:                (files "./test.o/b")
  150:                (code (y)))
  151:              (make-module #f)))
  152: (test* "program (files (multi))" 6
  153:        (eval '(program
  154:                (files "./test.o/a" "./test.o/b")
  155:                (code (y)))
  156:              (make-module #f)))
  157: (test* "program (feature-cond)" 2
  158:        (eval '(program
  159:                (feature-cond
  160:                 ((and srfi-1 srfi-2) (code (define x 1)))
  161:                 (else (code (define x 2))))
  162:                (code (+ x x)))
  163:              (make-module #f)))
  164: (test* "program (feature-cond)" 4
  165:        (eval '(program
  166:                (feature-cond
  167:                 ((and srfi-1 no-such-feature) (code (define x 1)))
  168:                 (else (code (define x 2))))
  169:                (code (+ x x)))
  170:              (make-module #f)))
  171: (test* "program (feature-cond)" 6
  172:        (eval '(program
  173:                (feature-cond
  174:                 ((or srfi-1 no-such-feature) (code (define x 3)))
  175:                 (else (code (define x 2))))
  176:                (code (+ x x)))
  177:              (make-module #f)))
  178: (test* "program (feature-cond w/o else)" *test-error*
  179:        (eval '(program
  180:                (feature-cond
  181:                 ((not srfi-1) (code (define x 5)))))
  182:              (make-module #f)))
  183: 
  184: (sys-system "rm -rf test.o")
  185: 
  186: ;;-----------------------------------------------------------------------
  187: (test-section "srfi-9")
  188: (use srfi-9)
  189: (test-module 'srfi-9)
  190: 
  191: (define-record-type pare
  192:   (kons x y)
  193:   pare?
  194:   (x kar set-kar!)
  195:   (y kdr))
  196: 
  197: (test* "pare kons" #t (pare? (kons 1 2)))
  198: (test* "pare kons" #f (pare? (cons 1 2)))
  199: (test* "pare kar" 1 (kar (kons 1 2)))
  200: (test* "pare kdr" 2 (kdr (kons 1 2)))
  201: (test* "pare set-kar!" 3 (let ((k (kons 1 2))) (set-kar! k 3) (kar k)))
  202: 
  203: (define-record-type xpare
  204:   (xkons y x)
  205:   xpare?
  206:   (x kar)
  207:   (y kdr))
  208: 
  209: (test* "xpare kons" '(1 . 2)
  210:        (let ((k (xkons 2 1))) (cons (kar k) (kdr k))))
  211: 
  212: ;;-----------------------------------------------------------------------
  213: (test-section "srfi-10")
  214: (use srfi-10)
  215: (test-module 'srfi-10)
  216: 
  217: (test "read ctor 1a" '(1 2 #f "4 5")
  218:       (lambda ()
  219:         (define-reader-ctor 'list list)
  220:         (with-input-from-string "#,(list 1 2 #f \"4 5\")" read)))
  221: (test "read ctor 1b" 3
  222:       (lambda ()
  223:         (define-reader-ctor '+ +)
  224:         (with-input-from-string "#,(+ 1 2)" read)))
  225: (define-reader-ctor 'my-vector
  226:   (lambda x (apply vector (cons 'my-vector x))))
  227: (test* "read ctor 2a" '#(my-vector (my-vector 1 2))
  228:        (with-input-from-string "#,(my-vector (my-vector 1 2))" read))
  229: (test* "read ctor 2b" '#(my-vector #(my-vector 1 2))
  230:        (with-input-from-string "#,(my-vector #,(my-vector 1 2))" read))
  231: 
  232: ;;-----------------------------------------------------------------------
  233: (test-section "srfi-14")
  234: (use srfi-14)
  235: (test-module 'srfi-14)
  236: 
  237: ;; Test samples taken from Olin Shivers' test suite,
  238: ;; http://srfi.schemers.org/srfi-14/srfi-14-tests.scm
  239: ;; TODO: This doesn't test characters beyond ASCII.  See char-set.euc.scm.
  240: (define (vowel? c) (member c '(#\a #\e #\i #\o #\u)))
  241: 
  242: (test* "char-set?" #f (char-set? 5))
  243: (test* "char-set?" #t (char-set? (char-set #\a #\e #\i #\o #\u)))
  244: (test* "char-set=" #t (char-set=))
  245: (test* "char-set=" #t (char-set= (char-set)))
  246: (test* "char-set=" #t (char-set= (char-set #\a #\e #\i #\o #\u)
  247:                                  (string->char-set "ioeauaiii")))
  248: (test* "char-set=" #f (char-set= (char-set #\e #\i #\o #\u)
  249:                                  (string->char-set "ioeauaiii")))
  250: (test* "char-set<=" #t (char-set<=))
  251: (test* "char-set<=" #t (char-set<= (char-set)))
  252: (test* "char-set<=" #t (char-set<= (char-set #\a #\e #\i #\o #\u)
  253:                                    (string->char-set "ioeauaiii")))
  254: (test* "char-set<=" #t (char-set<= (char-set #\e #\i #\o #\u)
  255:                                    (string->char-set "ioeauaiii")))
  256: 
  257: (test* "char-set-hash" #t
  258:        (<= 0 (char-set-hash char-set:graphic 100) 99))
  259: (test* "char-set-fold" #t
  260:        (= 4 (char-set-fold (lambda (c i) (+ i 1)) 0
  261:                            (char-set #\e #\i #\o #\u #\e #\e))))
  262: (test* "char-set-unfold" #t
  263:        (char-set= (string->char-set "eiaou2468013579999")
  264:                   (char-set-unfold null? car cdr
  265:                                    '(#\a #\e #\i #\o #\u #\u #\u)
  266:                                    char-set:digit)))
  267: (test* "char-set-unfold!" #t
  268:        
  269:        (char-set= (string->char-set "eiaou246801357999")
  270:                   (char-set-unfold! null? car cdr '(#\a #\e #\i #\o #\u)
  271:                                     (string->char-set "0123456789"))))
  272: (test* "char-set-unfold!" #f
  273:        (char-set= (string->char-set "eiaou246801357")
  274:                   (char-set-unfold! null? car cdr '(#\a #\e #\i #\o #\u)
  275:                                     (string->char-set "0123456789"))))
  276: (test* "char-set-for-each" #t
  277:        (let ((cs (string->char-set "0123456789")))
  278:          (char-set-for-each (lambda (c) (set! cs (char-set-delete cs c)))
  279:                             (string->char-set "02468000"))
  280:          (char-set= cs (string->char-set "97531"))))
  281: (test* "char-set-for-each" #t
  282:        (not (let ((cs (string->char-set "0123456789")))
  283:               (char-set-for-each (lambda (c) (set! cs (char-set-delete cs c)))
  284:                                  (string->char-set "02468"))
  285:               (char-set= cs (string->char-set "7531")))))
  286: (test* "char-set-map" #t
  287:        (char-set= (char-set-map char-upcase (string->char-set "aeiou"))
  288:                   (string->char-set "IOUAEEEE")))
  289: (test* "char-set-map" #f
  290:        (char-set= (char-set-map char-upcase (string->char-set "aeiou"))
  291:                   (string->char-set "OUAEEEE")))
  292: (test* "char-set-copy" #t
  293:        (char-set= (char-set-copy (string->char-set "aeiou"))
  294:                   (string->char-set "aeiou")))
  295: (test* "string->char-set" #t
  296:        (char-set= (char-set #\x #\y) (string->char-set "xy")))
  297: (test* "string->char-set" #t
  298:        (not (char-set= (char-set #\x #\y #\z) (string->char-set "xy"))))
  299: (test* "list->char-set" #t
  300:        (char-set= (string->char-set "xy") (list->char-set '(#\x #\y))))
  301: (test* "list->char-set" #f
  302:        
  303:        (char-set= (string->char-set "axy") (list->char-set '(#\x #\y))))
  304: (test* "list->char-set" #t
  305:        
  306:        (char-set= (string->char-set "xy12345")
  307:                   (list->char-set '(#\x #\y) (string->char-set "12345"))))
  308: (test* "list->char-set" #f
  309:        (char-set= (string->char-set "y12345")
  310:                   (list->char-set '(#\x #\y) (string->char-set "12345"))))
  311: (test* "list->char-set!" #t
  312:        (char-set= (string->char-set "xy12345")
  313:                   (list->char-set! '(#\x #\y) (string->char-set "12345"))))
  314: (test* "list->char-set!" #f
  315:        (char-set= (string->char-set "y12345")
  316:                   (list->char-set! '(#\x #\y) (string->char-set "12345"))))
  317: (test* "char-set-filter" #t
  318:        (char-set= (string->char-set "aeiou12345")
  319:                   (char-set-filter vowel? char-set:ascii
  320:                                    (string->char-set "12345"))))
  321: (test* "char-set-filter" #f
  322:        (char-set= (string->char-set "aeou12345")
  323:                   (char-set-filter vowel? char-set:ascii
  324:                                    (string->char-set "12345"))))
  325: (test* "char-set-filter!" #t
  326:        (char-set= (string->char-set "aeiou12345")
  327:                   (char-set-filter! vowel? char-set:ascii
  328:                                     (string->char-set "12345"))))
  329: (test* "char-set-filter!" #f
  330:        (char-set= (string->char-set "aeou12345")
  331:                   (char-set-filter! vowel? char-set:ascii
  332:                                     (string->char-set "12345"))))
  333: (test* "ucs-range->char-set" #t
  334:        (char-set= (string->char-set "abcdef12345")
  335:                   (ucs-range->char-set 97 103 #t
  336:                                        (string->char-set "12345"))))
  337: (test* "ucs-range->char-set" #f
  338:        (char-set= (string->char-set "abcef12345")
  339:                   (ucs-range->char-set 97 103 #t
  340:                                        (string->char-set "12345"))))
  341: (test* "ucs-range->char-set!" #t
  342:        (char-set= (string->char-set "abcdef12345")
  343:                   (ucs-range->char-set! 97 103 #t
  344:                                         (string->char-set "12345"))))
  345: (test* "ucs-range->char-set!" #f
  346:        (char-set= (string->char-set "abcef12345")
  347:                   (ucs-range->char-set! 97 103 #t
  348:                                         (string->char-set "12345"))))
  349: (test* "integer-range->char-set" #t
  350:        (char-set= (string->char-set "abcdef12345")
  351:                   (integer-range->char-set 97 103 #t
  352:                                            (string->char-set "12345"))))
  353: (test* "integer-range->char-set" #f
  354:        (char-set= (string->char-set "abcef12345")
  355:                   (integer-range->char-set 97 103 #t
  356:                                            (string->char-set "12345"))))
  357: (test* "integer-range->char-set!" #t
  358:        (char-set= (string->char-set "abcdef12345")
  359:                   (integer-range->char-set! 97 103 #t
  360:                                             (string->char-set "12345"))))
  361: (test* "integer-range->char-set!" #f
  362:        (char-set= (string->char-set "abcef12345")
  363:                   (integer-range->char-set! 97 103 #t
  364:                                             (string->char-set "12345"))))
  365: 
  366: (test* "->char-set" #t
  367:        (char-set= (->char-set #\x)
  368:                   (->char-set "x")
  369:                   (->char-set (char-set #\x))))
  370: (test* "->char-set" #f
  371:        (char-set= (->char-set #\x)
  372:                   (->char-set "y")
  373:                   (->char-set (char-set #\x))))
  374: (test* "char-set-size" 10
  375:        (char-set-size (char-set-intersection char-set:ascii char-set:digit)))
  376: (test* "char-set-count" 5
  377:        (char-set-count vowel? char-set:ascii))
  378: (test* "char-set->list" #t
  379:        (equal? '(#\x) (char-set->list (char-set #\x))))
  380: (test* "char-set->list" #f
  381:        (equal? '(#\X) (char-set->list (char-set #\x))))
  382: (test* "char-set->string" #t
  383:        (equal? "x" (char-set->string (char-set #\x))))
  384: (test* "char-set->string" #f
  385:        (equal? "X" (char-set->string (char-set #\x))))
  386: (test* "char-set-contains?" #t
  387:        (char-set-contains? (->char-set "xyz") #\x))
  388: (test* "char-set-contains?" #f
  389:        (char-set-contains? (->char-set "xyz") #\a))
  390: (test* "char-set-every" #t
  391:        (char-set-every char-lower-case? (->char-set "abcd")))
  392: (test* "char-set-every" #f
  393:        (char-set-every char-lower-case? (->char-set "abcD")))
  394: (test* "char-set-any" #t
  395:        (char-set-any char-lower-case? (->char-set "abcd")))
  396: (test* "char-set-any" #f
  397:        (char-set-any char-lower-case? (->char-set "ABCD")))
  398: (test* "char-set iterators" #t
  399:        (char-set= (->char-set "ABCD")
  400:                   (let ((cs (->char-set "abcd")))
  401:                     (let lp ((cur (char-set-cursor cs)) (ans '()))
  402:                       (if (end-of-char-set? cur) (list->char-set ans)
  403:                           (lp (char-set-cursor-next cs cur)
  404:                               (cons (char-upcase (char-set-ref cs cur)) ans)))))))
  405: (test* "char-set-adjoin" #t
  406:        (char-set= (char-set-adjoin (->char-set "123") #\x #\a)
  407:                   (->char-set "123xa")))
  408: (test* "char-set-adjoin" #f
  409:        (char-set= (char-set-adjoin (->char-set "123") #\x #\a)
  410:                   (->char-set "123x")))
  411: (test* "char-set-adjoin!" #t
  412:        (char-set= (char-set-adjoin! (->char-set "123") #\x #\a)
  413:                   (->char-set "123xa")))
  414: (test* "char-set-adjoin!" #f
  415:        (char-set= (char-set-adjoin! (->char-set "123") #\x #\a)
  416:                   (->char-set "123x")))
  417: (test* "char-set-delete" #t
  418:        (char-set= (char-set-delete (->char-set "123") #\2 #\a #\2)
  419:                   (->char-set "13")))
  420: (test* "char-set-delete" #f
  421:        (char-set= (char-set-delete (->char-set "123") #\2 #\a #\2)
  422:                   (->char-set "13a")))
  423: (test* "char-set-delete" #t
  424:        (char-set= (char-set-adjoin (char-set-delete char-set:full #\;) #\;)
  425:                   char-set:full))
  426: (test* "char-set-delete!" #t
  427:        (char-set= (char-set-delete! (->char-set "123") #\2 #\a #\2)
  428:                   (->char-set "13")))
  429: (test* "char-set-delete!" #f
  430:        (char-set= (char-set-delete! (->char-set "123") #\2 #\a #\2)
  431:                   (->char-set "13a")))
  432: (test* "char-set-delete!" #[\x81\x83\x84\x86]
  433:        (char-set-delete! (->char-set '(#\x81 #\x82 #\x83 #\x84 #\x85 #\x86 #\x87))
  434:                          #\x82 #\x87 #\x85)
  435:        char-set=)
  436: (test* "char-set-intersection" #t
  437:        (char-set= (char-set-intersection char-set:hex-digit (char-set-complement char-set:digit))
  438:                   (->char-set "abcdefABCDEF")))
  439: (test* "char-set-intersection!" #t
  440:        (char-set= (char-set-intersection! (char-set-complement! (->char-set "0123456789"))
  441:                                           char-set:hex-digit)
  442:                   (->char-set "abcdefABCDEF")))
  443: (test* "char-set-union" #t
  444:        (char-set= (char-set-union char-set:hex-digit
  445:                                   (->char-set "abcdefghijkl"))
  446:                   (->char-set "abcdefABCDEFghijkl0123456789")))
  447: (test* "char-set-union!" #t
  448:        (char-set= (char-set-union! (->char-set "abcdefghijkl")
  449:                                    char-set:hex-digit)
  450:                   (->char-set "abcdefABCDEFghijkl0123456789")))
  451: (test* "char-set-union!" #[\x81-\x89]
  452:        (char-set-union! (->char-set '(#\x81 #\x83 #\x84 #\x86 #\x87))
  453:                         (->char-set '(#\x82 #\x85 #\x86 #\x88 #\x89)))
  454:        char-set=)
  455: (test* "char-set-difference" #t
  456:        (char-set= (char-set-difference (->char-set "abcdefghijklmn")
  457:                                        char-set:hex-digit)
  458:                   (->char-set "ghijklmn")))
  459: (test* "char-set-difference!" #t
  460:        (char-set= (char-set-difference! (->char-set "abcdefghijklmn")
  461:                                         char-set:hex-digit)
  462:                   (->char-set "ghijklmn")))
  463: (test* "char-set-xor" #t
  464:        (char-set= (char-set-xor (->char-set "0123456789")
  465:                                 char-set:hex-digit)
  466:                   (->char-set "abcdefABCDEF")))
  467: (test* "char-set-xor!" #t
  468:        (char-set= (char-set-xor! (->char-set "0123456789")
  469:                                  char-set:hex-digit)
  470:                   (->char-set "abcdefABCDEF")))
  471: (test* "char-set-diff+intersection" #t
  472:        (call-with-values (lambda ()
  473:                            (char-set-diff+intersection char-set:hex-digit
  474:                                                        char-set:letter))
  475:          (lambda (d i)
  476:            (and (char-set= d (->char-set "0123456789"))
  477:                 (char-set= i (->char-set "abcdefABCDEF"))))))
  478: (test* "char-set-diff+intersection!" #t
  479:        (call-with-values (lambda ()
  480:                            (char-set-diff+intersection! (char-set-copy char-set:hex-digit)
  481:                                                         (char-set-copy char-set:letter)))
  482:          (lambda (d i)
  483:            (and (char-set= d (->char-set "0123456789"))
  484:                 (char-set= i (->char-set "abcdefABCDEF"))))))
  485: 
  486: ;;-----------------------------------------------------------------------
  487: (test-section "srfi-16")
  488: 
  489: (test* "case-lambda (plus)" '(0 1 3 6 10)
  490:        (let ()
  491:          (define plus
  492:            (case-lambda 
  493:             (() 0)
  494:             ((x) x)
  495:             ((x y) (+ x y))
  496:             ((x y z) (+ (+ x y) z))
  497:             (args (apply + args))))
  498:          (list (plus) (plus 1) (plus 1 2) (