1: ;;;
    2: ;;; primitive syntax test
    3: ;;;
    4: 
    5: (use gauche.test)
    6: 
    7: (test-start "primitive syntax")
    8: 
    9: ;; We use prim-test instead of test, for error-handler is not tested yet.
   10: 
   11: ;;----------------------------------------------------------------
   12: (test-section "conditionals")
   13: 
   14: (prim-test "if" 5 (lambda ()  (if #f 2 5)))
   15: (prim-test "if" 2 (lambda ()  (if (not #f) 2 5)))
   16: 
   17: (prim-test "and" #t (lambda ()  (and)))
   18: (prim-test "and" 5  (lambda ()  (and 5)))
   19: (prim-test "and" #f (lambda ()  (and 5 #f 2)))
   20: (prim-test "and" #f (lambda ()  (and 5 #f unbound-var)))
   21: (prim-test "and" 'a (lambda ()  (and 3 4 'a)))
   22: 
   23: (prim-test "or"  #f (lambda ()  (or)))
   24: (prim-test "or"  3  (lambda ()  (or 3 9)))
   25: (prim-test "or"  3  (lambda ()  (or #f 3 unbound-var)))
   26: 
   27: (prim-test "when" 4          (lambda ()  (when 3 5 4)))
   28: (prim-test "when" (undefined)    (lambda ()  (when #f 5 4)))
   29: (prim-test "unless" (undefined)  (lambda ()  (unless 3 5 4)))
   30: (prim-test "unless" 4        (lambda ()  (unless #f 5 4)))
   31: 
   32: (prim-test "cond" (undefined)  (lambda ()  (cond (#f 2))))
   33: (prim-test "cond" 5        (lambda ()  (cond (#f 2) (else 5))))
   34: (prim-test "cond" 2        (lambda ()  (cond (1 2) (else 5))))
   35: (prim-test "cond" 8        (lambda ()  (cond (#f 2) (1 8) (else 5))))
   36: (prim-test "cond" 3        (lambda ()  (cond (1 => (lambda (x) (+ x 2))) (else 8))))
   37: (prim-test "cond (srfi-61)" 1 (lambda () (cond (1 number? => values) (else 8))))
   38: (prim-test "cond (srfi-61)" 8 (lambda () (cond (1 string? => values) (else 8))))
   39: (prim-test "cond (srfi-61)" '(1 2)
   40:            (lambda () (cond ((values 1 2)
   41:                              (lambda (x y) (and (= x 1) (= y 2)))
   42:                              => list))))
   43: 
   44: (prim-test "case" #t (lambda ()  (case (+ 2 3) ((1 3 5 7 9) #t) ((0 2 4 6 8) #f))))
   45: (prim-test "case" #t (lambda () (undefined? (case 1 ((2 3) #t)))))
   46: (prim-test "case (srfi-87)" 0 (lambda () (case (+ 2 3) ((1 3 5) 0) (else => values))))
   47: (prim-test "case (srfi-87)" 6 (lambda () (case (+ 2 3) ((1 3 5) => (cut + 1 <>)) (else => values))))
   48: (prim-test "case (srfi-87)" 5 (lambda () (case (+ 2 3) ((2 4 6) 0) (else => values))))
   49: 
   50: ;;----------------------------------------------------------------
   51: (test-section "binding")
   52: 
   53: (prim-test "let" 35
   54:       (lambda ()
   55:         (let ((x 2) (y 3))
   56:           (let ((x 7) (z (+ x y)))
   57:             (* z x)))))
   58: (prim-test "let*" 70
   59:       (lambda ()
   60:         (let ((x 2) (y 3))
   61:           (let* ((x 7) (z (+ x y)))
   62:             (* z x)))))
   63: (prim-test "let*" 2
   64:       (lambda ()
   65:         (let* ((x 1) (x (+ x 1))) x)))
   66: 
   67: (prim-test "named let" -3
   68:       (lambda ()
   69:         (let ((f -))
   70:           (let f ((a (f 3)))
   71:             a))))
   72: 
   73: ;;----------------------------------------------------------------
   74: (test-section "closure and saved env")
   75: 
   76: (prim-test "lambda" 5  (lambda ()  ((lambda (x) (car x)) '(5 6 7))))
   77: (prim-test "lambda" 12
   78:       (lambda ()
   79:         ((lambda (x y)
   80:            ((lambda (z) (* (car z) (cdr z))) (cons x y))) 3 4)))
   81: 
   82: (define (addN n) (lambda (a) (+ a n)))
   83: (prim-test "lambda" 5 (lambda ()  ((addN 2) 3)))
   84: (define add3 (addN 3))
   85: (prim-test "lambda" 9 (lambda ()  (add3 6)))
   86: 
   87: (define count (let ((c 0)) (lambda () (set! c (+ c 1)) c)))
   88: (prim-test "lambda" 1 (lambda ()  (count)))
   89: (prim-test "lambda" 2 (lambda ()  (count)))
   90: 
   91: ;;----------------------------------------------------------------
   92: (test-section "application")
   93: 
   94: (prim-test "apply" '(1 2 3) (lambda ()  (apply list 1 '(2 3))))
   95: (prim-test "apply" '(1 2 3) (lambda ()  (apply apply (list list 1 2 '(3)))))
   96: 
   97: (prim-test "map" '()         (lambda ()  (map car '())))
   98: (prim-test "map" '(1 2 3)    (lambda ()  (map car '((1) (2) (3)))))
   99: (prim-test "map" '(() () ()) (lambda ()  (map cdr '((1) (2) (3)))))
  100: (prim-test "map" '((1 . 4) (2 . 5) (3 . 6))  (lambda ()  (map cons '(1 2 3) '(4 5 6))))
  101: 
  102: ;;----------------------------------------------------------------
  103: (test-section "loop")
  104: 
  105: (define (fact-non-tail-rec n)
  106:   (if (<= n 1) n (* n (fact-non-tail-rec (- n 1)))))
  107: (prim-test "loop non-tail-rec" 120 (lambda ()  (fact-non-tail-rec 5)))
  108: 
  109: (define (fact-tail-rec n r)
  110:   (if (<= n 1) r (fact-tail-rec (- n 1) (* n r))))
  111: (prim-test "loop tail-rec"     120 (lambda ()  (fact-tail-rec 5 1)))
  112: 
  113: (define (fact-named-let n)
  114:   (let loop ((n n) (r 1)) (if (<= n 1) r (loop (- n 1) (* n r)))))
  115: (prim-test "loop named-let"    120 (lambda ()  (fact-named-let 5)))
  116: 
  117: (define (fact-int-define n)
  118:   (define (rec n r) (if (<= n 1) r (rec (- n 1) (* n r))))
  119:   (rec n 1))
  120: (prim-test "loop int-define"   120 (lambda ()  (fact-int-define 5)))
  121: 
  122: (define (fact-do n)
  123:   (do ((n n (- n 1)) (r 1 (* n r))) ((<= n 1) r)))
  124: (prim-test "loop do"           120 (lambda ()  (fact-do 5)))
  125: 
  126: ;; tricky case
  127: (prim-test "do" #f (lambda () (do () (#t #f) #t)))
  128: 
  129: ;;----------------------------------------------------------------
  130: (test-section "quasiquote")
  131: 
  132: ;; The new compiler generates constant list for much wider
  133: ;; range of quasiquoted forms (e.g. constant numerical expressions
  134: ;; and constant variable definitions are folded at the compile time).
  135: 
  136: (define-constant quasi0 99)
  137: (define quasi1 101)
  138: (define-constant quasi2 '(a b))
  139: (define quasi3 '(c d))
  140: 
  141: (prim-test "qq" '(1 2 3)        (lambda ()  `(1 2 3)))
  142: (prim-test "qq" '()             (lambda ()  `()))
  143: (prim-test "qq"  99             (lambda ()  `,quasi0))
  144: (prim-test "qq"  101            (lambda ()  `,quasi1))
  145: (prim-test "qq," '((1 . 2))     (lambda ()  `(,(cons 1 2))))
  146: (prim-test "qq," '((1 . 2) 3)   (lambda ()  `(,(cons 1 2) 3)))
  147: (prim-test "qq," '(99 3)        (lambda ()  `(,quasi0 3)))
  148: (prim-test "qq," '(3 99)        (lambda ()  `(3 ,quasi0)))
  149: (prim-test "qq," '(100 3)       (lambda ()  `(,(+ quasi0 1) 3)))
  150: (prim-test "qq," '(3 100)       (lambda ()  `(3 ,(+ quasi0 1))))
  151: (prim-test "qq," '(101 3)       (lambda ()  `(,quasi1 3)))
  152: (prim-test "qq," '(3 101)       (lambda ()  `(3 ,quasi1)))
  153: (prim-test "qq," '(102 3)       (lambda ()  `(,(+ quasi1 1) 3)))
  154: (prim-test "qq," '(3 102)       (lambda ()  `(3 ,(+ quasi1 1))))
  155: (prim-test "qq@" '(1 2 3 4)     (lambda ()  `(1 ,@(list 2 3) 4)))
  156: (prim-test "qq@" '(1 2 3 4)     (lambda ()  `(1 2 ,@(list 3 4))))
  157: (prim-test "qq@" '(a b c d)     (lambda ()  `(,@quasi2 ,@quasi3)))
  158: (prim-test "qq." '(1 2 3 4)     (lambda ()  `(1 2 . ,(list 3 4))))
  159: (prim-test "qq." '(a b c d)     (lambda ()  `(,@quasi2 . ,quasi3)))
  160: (prim-test "qq#," '#((1 . 2) 3) (lambda ()  `#(,(cons 1 2) 3)))
  161: (prim-test "qq#," '#(99 3)      (lambda ()  `#(,quasi0 3)))
  162: (prim-test "qq#," '#(100 3)     (lambda ()  `#(,(+ quasi0 1) 3)))
  163: (prim-test "qq#," '#(3 101)     (lambda ()  `#(3 ,quasi1)))
  164: (prim-test "qq#," '#(3 102)     (lambda ()  `#(3 ,(+ quasi1 1))))
  165: (prim-test "qq#@" '#(1 2 3 4)   (lambda ()  `#(1 ,@(list 2 3) 4)))
  166: (prim-test "qq#@" '#(1 2 3 4)   (lambda ()  `#(1 2 ,@(list 3 4))))
  167: (prim-test "qq#@" '#(a b c d)   (lambda ()  `#(,@quasi2 ,@quasi3)))
  168: (prim-test "qq#@" '#(a b (c d)) (lambda ()  `#(,@quasi2 ,quasi3)))
  169: (prim-test "qq#@" '#((a b) c d) (lambda ()  `#(,quasi2  ,@quasi3)))
  170: (prim-test "qq#"  '#()          (lambda ()  `#()))
  171: (prim-test "qq#@" '#()          (lambda ()  `#(,@(list))))
  172: 
  173: (prim-test "qq@@" '(1 2 1 2)    (lambda ()  `(,@(list 1 2) ,@(list 1 2))))
  174: (prim-test "qq@@" '(1 2 a 1 2)  (lambda ()  `(,@(list 1 2) a ,@(list 1 2))))
  175: (prim-test "qq@@" '(a 1 2 1 2)  (lambda ()  `(a ,@(list 1 2) ,@(list 1 2))))
  176: (prim-test "qq@@" '(1 2 1 2 a)  (lambda ()  `(,@(list 1 2) ,@(list 1 2) a)))
  177: (prim-test "qq@@" '(1 2 1 2 a b) (lambda ()  `(,@(list 1 2) ,@(list 1 2) a b)))
  178: (prim-test "qq@." '(1 2 1 2 . a)
  179:       (lambda ()  `(,@(list 1 2) ,@(list 1 2) . a)))
  180: (prim-test "qq@." '(1 2 1 2 1 . 2)
  181:       (lambda ()  `(,@(list 1 2) ,@(list 1 2) . ,(cons 1 2))))
  182: (prim-test "qq@." '(1 2 1 2 a b)
  183:       (lambda ()  `(,@(list 1 2) ,@(list 1 2) . ,quasi2)))
  184: (prim-test "qq@." '(1 2 1 2 a 1 . 2)
  185:       (lambda ()  `(,@(list 1 2) ,@(list 1 2) a . ,(cons 1 2))))
  186: (prim-test "qq@." '(1 2 1 2 a c d)
  187:       (lambda ()  `(,@(list 1 2) ,@(list 1 2) a . ,quasi3)))
  188: 
  189: (prim-test "qq#@@" '#(1 2 1 2)    (lambda ()  `#(,@(list 1 2) ,@(list 1 2))))
  190: (prim-test "qq#@@" '#(1 2 a 1 2)  (lambda ()  `#(,@(list 1 2) a ,@(list 1 2))))
  191: (prim-test "qq#@@" '#(a 1 2 1 2)  (lambda ()  `#(a ,@(list 1 2) ,@(list 1 2))))
  192: (prim-test "qq#@@" '#(1 2 1 2 a)  (lambda ()  `#(,@(list 1 2) ,@(list 1 2) a)))
  193: (prim-test "qq#@@" '#(1 2 1 2 a b) (lambda () `#(,@(list 1 2) ,@(list 1 2) a b)))
  194: 
  195: (prim-test "qqq"   '(1 `(1 ,2 ,3) 1)
  196:            (lambda ()  `(1 `(1 ,2 ,,(+ 1 2)) 1)))
  197: (prim-test "qqq"   '(1 `(1 ,99 ,101) 1)
  198:            (lambda ()  `(1 `(1 ,,quasi0 ,,quasi1) 1)))
  199: (prim-test "qqq"   '(1 `(1 ,@2 ,@(1 2)))
  200:            (lambda () `(1 `(1 ,@2 ,@,(list 1 2)))))
  201: (prim-test "qqq"   '(1 `(1 ,@(a b) ,@(c d)))
  202:            (lambda () `(1 `(1 ,@,quasi2 ,@,quasi3))))
  203: (prim-test "qqq"   '(1 `(1 ,(a b x) ,(y c d)))
  204:            (lambda () `(1 `(1 ,(,@quasi2 x) ,(y ,@quasi3)))))
  205: (prim-test "qqq#"  '#(1 `(1 ,2 ,3) 1)
  206:            (lambda ()  `#(1 `(1 ,2 ,,(+ 1 2)) 1)))
  207: (prim-test "qqq#"  '#(1 `(1 ,99 ,101) 1)
  208:            (lambda ()  `#(1 `(1 ,,quasi0 ,,quasi1) 1)))
  209: (prim-test "qqq#"  '#(1 `(1 ,@2 ,@(1 2)))
  210:            (lambda () `#(1 `(1 ,@2 ,@,(list 1 2)))))
  211: (prim-test "qqq#"  '#(1 `(1 ,@(a b) ,@(c d)))
  212:            (lambda () `#(1 `(1 ,@,quasi2 ,@,quasi3))))
  213: (prim-test "qqq#"  '#(1 `(1 ,(a b x) ,(y c d)))
  214:            (lambda () `#(1 `(1 ,(,@quasi2 x) ,(y ,@quasi3)))))
  215: (prim-test "qqq#"  '(1 `#(1 ,(a b x) ,(y c d)))
  216:            (lambda () `(1 `#(1 ,(,@quasi2 x) ,(y ,@quasi3)))))
  217: 
  218: ;;----------------------------------------------------------------
  219: (test-section "multiple values")
  220: 
  221: (prim-test "receive" '(1 2 3)
  222:       (lambda ()  (receive (a b c) (values 1 2 3) (list a b c))))
  223: (prim-test "receive" '(1 2 3)
  224:       (lambda ()  (receive (a . r) (values 1 2 3) (cons a r))))
  225: (prim-test "receive" '(1 2 3)
  226:       (lambda ()  (receive x (values 1 2 3) x)))
  227: (prim-test "receive" 1
  228:       (lambda ()  (receive (a) 1 a)))
  229: (prim-test "call-with-values" '(1 2 3)
  230:       (lambda ()  (call-with-values (lambda () (values 1 2 3)) list)))
  231: (prim-test "call-with-values" '()
  232:       (lambda ()  (call-with-values (lambda () (values)) list)))
  233: 
  234: ;; This is not 'right' in R5RS sense---for now, I just tolerate it
  235: ;; by CommonLisp way, i.e. if more than one value is passed to an
  236: ;; implicit continuation that expects one value, the second and after
  237: ;; values are just discarded.  This behavior may be changed later,
  238: ;; so do not count on it.   The test just make sure it doesn't screw
  239: ;; up anything.
  240: (prim-test "receive" '((0 0))
  241:       (lambda ()  (receive l (list 0 (values 0 1 2)) l)))
  242: 
  243: ;;----------------------------------------------------------------
  244: (test-section "eval")
  245: 
  246: (prim-test "eval" '(1 . 2)
  247:       (lambda () (eval '(cons 1 2) (interaction-environment))))
  248: 
  249: (define (vector-ref x y) 'foo)
  250: 
  251: (prim-test "eval" '(foo foo 3)
  252:       (lambda ()
  253:         (list (vector-ref '#(3) 0)
  254:               (eval '(vector-ref '#(3) 0) (interaction-environment))
  255:               (eval '(vector-ref '#(3) 0) (scheme-report-environment 5)))))
  256: 
  257: (define vector-ref (with-module scheme vector-ref))
  258: 
  259: (prim-test "eval" #t
  260:       (lambda ()
  261:         (with-error-handler
  262:          (lambda (e) #t)
  263:          (lambda () (eval '(car '(3 2)) (null-environment 5))))))
  264: 
  265: ;; check interaction w/ modules
  266: (define-module primsyn.test (define foo 'a))
  267: (define foo '(x y))
  268: 
  269: (prim-test "eval (module)" '(a b (x y))
  270:       (lambda ()
  271:         (let* ((m (find-module 'primsyn.test))
  272:                (a (eval 'foo m))
  273:                (b (eval '(begin (set! foo 'b) foo) m)))
  274:           (list a b foo))))
  275: 
  276: (prim-test "eval (module)" '(x y)
  277:       (lambda ()
  278:         (with-error-handler
  279:             (lambda (e) foo)
  280:           (lambda ()
  281:             (eval '(apply car foo '()) (find-module 'primsyn.test))))))
  282: 
  283: ;;----------------------------------------------------------------
  284: (test-section "local procedure optimization")
  285: 
  286: ;; this caused an internal compiler error in 0.8.6.
  287: ;; (found and fixed by Jun Inoue)
  288: (prim-test "internal-define inilining" '(1)
  289:            (lambda ()
  290:              (with-error-handler
  291:                  (lambda (e) 'ouch!)
  292:                (lambda ()
  293:                  (eval '(let ()
  294:                           (define (a x) x)
  295:                           (define (b x) (a x))
  296:                           (define (c x) (b x))
  297:                           (list 1))
  298:                        (interaction-environment))))))
  299: 
  300: ;; this caused an internal compiler error in 0.8.6
  301: ;; (found and fixed by Kazuki Tsujimoto)
  302: (prim-test "multiple inlining" 0
  303:            (lambda ()
  304:              (let ((f (lambda (i) (set! i 0) i))) (f (f 1)))))
  305: 
  306: ;;----------------------------------------------------------------
  307: (test-section "lazy, delay & force")
  308: 
  309: (prim-test "simple delay" 3
  310:       (lambda () (force (delay (+ 1 2)))))
  311: 
  312: (prim-test "delay w/state" 3
  313:       (lambda ()
  314:         (let ((x 9))
  315:           (let ((d (delay (/ x 3))))
  316:             (force d)
  317:             (set! x 99)
  318:             (force d)))))
  319: 
  320: (prim-test "delay recursive" 6  ;; R5RS 6.4
  321:       (lambda ()
  322:         (letrec ((count 0)
  323:                  (x 5)
  324:                  (p (delay (begin (set! count (+ count 1))
  325:                                   (if (> count x)
  326:                                       count
  327:                                       (force p))))))
  328:           (force p)
  329:           (set! x 10)
  330:           (force p))))
  331: 
  332: ;; check to see the compiler does the right thing about expanding
  333: ;; (delay x) to (lazy (eager x)).
  334: (prim-test "delay compilation" 3
  335:            (lambda ()
  336:              (force 
  337:               (let ((lazy list)
  338:                     (eager list))
  339:                (delay (force 3))))))
  340: 
  341: ;; srfi-45 test suite
  342: (prim-test "memoize 1" 1
  343:            (lambda ()
  344:              (let ((count 0))
  345:                (define s (delay (begin (set! count (+ count 1)) 1)))
  346:                (force s)
  347:                (force s)
  348:                count)))
  349: 
  350: (prim-test "memoize 2" 1
  351:            (lambda ()
  352:              (let ((count 0))
  353:                (define s (delay (begin (set! count (+ count 1)) 1)))
  354:                (+ (force s) (force s))
  355:                count)))
  356: 
  357: (prim-test "memoize 3" 1  ;; (Alejandro Forero Cuervo)
  358:            (lambda ()
  359:              (let ((count 0))
  360:                (let* ((r (delay (begin (set! count (+ count 1)) 1)))
  361:                       (s (lazy r))
  362:                       (t (lazy s)))
  363:                  (force t)
  364:                  (force r)
  365:                  count))))
  366: 
  367: (prim-test "memoize 4" 5  ;; stream memoization
  368:            (lambda ()
  369:              (let ((count 0))
  370:                (define (stream-drop s index)
  371:                  (lazy
  372:                   (if (zero? index)
  373:                     s
  374:                     (stream-drop (cdr (force s)) (- index 1)))))
  375:                (define (ones)
  376:                  (delay (begin
  377:                           (set! count (+ count 1))
  378:                           (cons 1 (ones)))))
  379:                (let ((s (ones)))
  380:                  (car (force (stream-drop s 4)))
  381:                  (car (force (stream-drop s 4)))
  382:                  count))))
  383: 
  384: (prim-test "reentrancy 1" 'second       ;; see srfi-40 post-discussion
  385:            (lambda ()
  386:              (define f
  387:                (let ((first? #t))
  388:                  (delay
  389:                    (if first?
  390:                      (begin
  391:                        (set! first? #f)
  392:                        (force f))
  393:                      'second))))
  394:              (force f)))
  395: 
  396: (prim-test "reentrancy 2" '(5 0 10) ;; (John Shutt)
  397:            (lambda ()
  398:              (define q
  399:                (let ((count 5))
  400:                  (define (get-count) count)
  401:                  (define p (delay (if (<= count 0)
  402:                                     count
  403:                                     (begin (set! count (- count 1))
  404:                                            (force p)
  405:                                            (set! count (+ count 2))
  406:                                            count))))
  407:                  (list get-count p)))
  408:              (let* ((get-count (car q))
  409:                     (p (cadr q))
  410:                     (a (get-count))
  411:                     (b (force p))
  412:                     (c (get-count)))
  413:                (list a b c))))
  414: 
  415: ;; This leak test takes long time, so we exclude it by default.
  416: ;; If you run this on pre-0.8.6 Gauche (with replacing lazy by delay+force),
  417: ;; it'll bust the memory.
  418: ;(prim-test "leak 1" 10000000
  419: ;           (lambda ()
  420: ;             (define (stream-filter p? s)
  421: ;               (lazy
  422: ;                (let ((lis (force s)))
  423: ;                  (if (null? lis)
  424: ;                    (delay '())
  425: ;                    (let ((h (car lis))
  426: ;                          (t (cdr lis)))
  427: ;                      (if (p? h)
  428: ;                        (delay (cons h (stream-filter p? t)))
  429: ;                        (stream-filter p? t)))))))
  430: ;             (define (from n)
  431: ;               (delay (cons n (from (+ n 1)))))
  432: ;             (car (force (stream-filter (lambda (n) (= n 10000000))
  433: ;                                        (from 0))))))
  434: 
  435: