1: ;;
    2: ;; test for procedures
    3: ;;
    4: 
    5: (use gauche.test)
    6: (test-start "procedures")
    7: 
    8: ;;-------------------------------------------------------------------
    9: (test-section "combinatorial programming utilities")
   10: 
   11: (test* "pa$" 10 ((pa$ + 3) 7))
   12: (test* "pa$" '(a b c)
   13:        ((pa$ list 'a) 'b 'c))
   14: (test* "pa$" '(a b c)
   15:        ((pa$ list 'a 'b) 'c))
   16: (test* "pa$" '(a b c)
   17:        ((pa$ (pa$ list 'a) 'b) 'c))
   18: 
   19: (test "map$" '(2 4 6)
   20:       (lambda ()
   21:         (define map2* (map$ (pa$ * 2)))
   22:         (map2* '(1 2 3))))
   23: 
   24: (test "compose" '(#t #f #t)
   25:       (lambda ()
   26:         (define not-zero? (compose not zero?))
   27:         (list (not-zero? 3)
   28:               (not-zero? 0)
   29:               (not-zero? -100))))
   30: 
   31: (test "compose" 'a (lambda () ((compose car) '(a b c))))
   32: (test "compose" '(a b c) (lambda () ((compose) '(a b c))))
   33: 
   34: (test "complement" '(#t #f #t)
   35:       (lambda () (map (complement even?) '(1 2 3))))
   36: (test "complement" '(#t #f #t)
   37:       (lambda () (map (complement zero?) '(-1 0 1))))
   38: (test "complement" '(#f #t #f)
   39:       (lambda () (map (complement =) '(1 2 3) '(1 1 3))))
   40: (test "complement" '(#f #t #f)
   41:       (lambda () (map (complement (lambda (x y) (= x y))) '(1 2 3) '(1 1 3))))
   42: (test "complement" #t
   43:       (lambda () ((complement (lambda () #f)))))
   44: 
   45: (test "compose, apply$, map$" 32
   46:       (lambda ()
   47:         (define dot-product (compose (apply$ +) (map$ *)))
   48:         (dot-product '(1 2 3) '(4 5 6))))
   49: 
   50: (test "any-pred" '(#t #t #f)
   51:       (lambda ()
   52:         (define string-or-symbol? (any-pred string? symbol?))
   53:         (list (string-or-symbol? "abc")
   54:               (string-or-symbol? 'abc)
   55:               (string-or-symbol? 3))))
   56: 
   57: (test "any-pred" '(b c)
   58:       (lambda ()
   59:         ((any-pred (cut memq <> '(a b c))
   60:                    (cut memq <> '(1 2 3)))
   61:          'b)))
   62: 
   63: (test "any-pred" '(#t #f)
   64:       (lambda ()
   65:         (define <> (any-pred < >))
   66:         (list (<> 3 4)
   67:               (<> 3 3))))
   68: 
   69: (test "every-pred" '(#t #f #f)
   70:       (lambda ()
   71:         (list ((every-pred odd? positive?) 3)
   72:               ((every-pred odd? positive?) 4)
   73:               ((every-pred odd? positive?) -3))))
   74: 
   75: (test "every-pred" '(3 #f)
   76:       (lambda ()
   77:         (define safe-length (every-pred list? length))
   78:         (list (safe-length '(a b c))
   79:               (safe-length "aaa"))))
   80: 
   81: ;;-------------------------------------------------------------------
   82: (test-section "optional arguments")
   83: 
   84: (define (oof x . args)
   85:   (let-optionals* args ((a 'a)
   86:                         (b 'b)
   87:                         (c 'c))
   88:     (list x a b c)))
   89: 
   90: (test* "let-optionals*" '(0 a b c) (oof 0))
   91: (test* "let-optionals*" '(0 1 b c) (oof 0 1))
   92: (test* "let-optionals*" '(0 1 2 c) (oof 0 1 2))
   93: (test* "let-optionals*" '(0 1 2 3) (oof 0 1 2 3))
   94: 
   95: (define (oof* x . args)
   96:   (let-optionals* args ((a 'a)
   97:                         (b 'b)
   98:                         . c)
   99:     (list x a b c)))
  100: 
  101: (test* "let-optionals*" '(0 a b ()) (oof* 0))
  102: (test* "let-optionals*" '(0 1 b ()) (oof* 0 1))
  103: (test* "let-optionals*" '(0 1 2 ()) (oof* 0 1 2))
  104: (test* "let-optionals*" '(0 1 2 (3)) (oof* 0 1 2 3))
  105: 
  106: (define (oof+ x . args)
  107:   (let ((i 0))
  108:     (let-optionals* (begin (inc! i) args)
  109:         ((a 'a)
  110:          (b 'b)
  111:          (c 'c))
  112:       i)))
  113: 
  114: (test* "let-optionals*" 1 (oof+ 0))
  115: (test* "let-optionals*" 1 (oof+ 0 1))
  116: (test* "let-optionals*" 1 (oof+ 0 1 2))
  117: (test* "let-optionals*" 1 (oof+ 0 1 2 3))
  118: 
  119: (define (oaf x . args)
  120:   (let ((y (get-optional args 'foof)))
  121:     (list x y)))
  122: 
  123: (test* "get-optional" '(0 foof) (oaf 0))
  124: (test* "get-optional" '(0 1)    (oaf 0 1))
  125: 
  126: (define (oaf+ x . args)
  127:   (let ((i 0))
  128:     (let ((y (get-optional (begin (inc! i) args) 'foof)))
  129:       i)))
  130: 
  131: (test* "get-optional" 1 (oaf+ 0))
  132: (test* "get-optional" 1 (oaf+ 0 1))
  133: 
  134: (define (oef x . args)
  135:   (let-keywords* args ((a 'a)
  136:                        (b :bb 'b)
  137:                        (c 'c))
  138:     (list x a b c)))
  139: 
  140: (test* "let-keywords*" '(0 a b c) (oef 0))
  141: (test* "let-keywords*" '(0 1 b c) (oef 0 :a 1))
  142: (test* "let-keywords*" '(0 a 1 c) (oef 0 :bb 1))
  143: (test* "let-keywords*" '(0 a b 1) (oef 0 :c 1))
  144: (test* "let-keywords*" '(0 1 2 3) (oef 0 :c 3 :bb 2 :a 1))
  145: ;;(test* "let-keywords*" *test-error* (oef 0 :c 3 :bb 2 :a 1 :unknown 1))
  146: 
  147: (define (oef+ x . args)
  148:   (let ((i 0))
  149:     (let-keywords* (begin (inc! i) args)
  150:         ((a 'a)
  151:          (b :bb 'b)
  152:          (c 'c))
  153:       i)))
  154: 
  155: (test* "let-keywords*" 1 (oef+ 0))
  156: (test* "let-keywords*" 1 (oef+ 0 :a 1))
  157: (test* "let-keywords*" 1 (oef+ 0 :bb 1))
  158: (test* "let-keywords*" 1 (oef+ 0 :c 1))
  159: (test* "let-keywords*" 1 (oef+ 0 :c 3 :bb 2 :a 1))
  160: ;;(test* "let-keywords*" *test-error* (oef+ 0 :c 3 :bb 2 :a 1 :unknown 1))
  161: 
  162: (define (orf x . args)
  163:   (let-keywords args ((a 'a)
  164:                       (b :bb 'b)
  165:                       (c 'c))
  166:     (list x a b c)))
  167: 
  168: (test* "let-keywords" '(0 a b c)   (orf 0))
  169: (test* "let-keywords" '(0 1 b c)   (orf 0 :a 1))
  170: (test* "let-keywords" '(0 a 1 c)   (orf 0 :bb 1))
  171: (test* "let-keywords" '(0 a b 1)   (orf 0 :c 1))
  172: (test* "let-keywords" '(0 1 2 3)   (orf 0 :c 3 :bb 2 :a 1))
  173: (test* "let-keywords" *test-error* (orf 0 :c 3 :bb 2 :a 1 :unknown 1))
  174: 
  175: (define (orf+ x . args)
  176:   (let ((i 0))
  177:     (let-keywords (begin (inc! i) args)
  178:         ((a 'a)
  179:          (b :bb 'b)
  180:          (c 'c))
  181:       i)))
  182: 
  183: (test* "let-keywords" 1 (orf+ 0))
  184: (test* "let-keywords" 1 (orf+ 0 :a 1))
  185: (test* "let-keywords" 1 (orf+ 0 :bb 1))
  186: (test* "let-keywords" 1 (orf+ 0 :c 1))
  187: (test* "let-keywords" 1 (orf+ 0 :c 3 :bb 2 :a 1))
  188: (test* "let-keywords" *test-error* (orf 0 :c 3 :bb 2 :a 1 :unknown 1))
  189: 
  190: ;; let-keywords* combined with syntax rules
  191: (define-syntax lambda++
  192:   (syntax-rules ()
  193:     ((lambda++ "sub" () (margs ...) kargs . body)
  194:      (lambda (margs ... . rest)
  195:        (let-keywords* rest kargs
  196:          . body)))
  197:     ((lambda++ "sub" (:key) margs kargs . body)
  198:      (lambda++ "sub" () margs kargs . body))
  199:     ((lambda++ "sub" (:key (arg1 def1) args ...) margs (kargs ...) . body)
  200:      (lambda++ "sub" (:key args ...) margs (kargs ... (arg1 def1)) . body))
  201:     ((lambda++ "sub" (:key arg1 args ...) margs (kargs ...) . body)
  202:      (lambda++ "sub" (:key args ...) margs (kargs ... (arg1 #f)) . body))
  203:     ((lambda++ "sub" (arg1 args ...) (margs ...) kargs . body)
  204:      (lambda++ "sub" (args ...) (margs ... arg1) kargs . body))
  205:     ((lambda++ args . body)
  206:      (lambda++ "sub" args () () . body))
  207:     ))
  208: 
  209: (test* "macro + let-keywords*" '(1 2 3 #f 5)
  210:        ((lambda++ (a b c :key d e) (list a b c d e))
  211:         1 2 3 :e 5))
  212: 
  213: (test* "macro + let-keywords*" *test-error*
  214:        ((lambda++ (a b c :key d e) (list a b c d e))
  215:         1 2 :d 3))
  216: 
  217: (test* "macro + let-keywords*" '(1 2 3 4 #f)
  218:        ((lambda++ (a b c :key d e) (list a b c d e))
  219:         1 2 3 :d 4))
  220: 
  221: (test* "macro + let-keywords*" '(1 2 3 0 1)
  222:        ((lambda++ (a b c :key (d 0) (e 1)) (list a b c d e))
  223:         1 2 3))
  224:                   
  225: 
  226: (test-end)