Changeset 12193 in project

Timestamp:

10/18/08 16:50:28 (12 years ago)

Author:

Alex Shinn

Message:

Fixing silly bug in test-error.

Location:

release/3/test

Files:

• test-support.scm (modified) (4 diffs)
• test.scm (modified) (1 diff)
• test.setup (modified) (1 diff)

release/3/test/test-support.scm

@@ -105 +105 @@
       ((and (pair? x) (eq? 'let (car x)))
        (if (and (pair? o) (car o))
-         (truncate-source (car (reverse x)) width #t)
-         (string-append "..."
-                        (truncate-source (car (reverse x)) (- width 3) #t))))
+           (truncate-source (car (reverse x)) width #t)
+           (string-append "..."
+                          (truncate-source (car (reverse x)) (- width 3) #t))))
+      ((and (pair? x) (eq? 'call-with-current-continuation (car x)))
+       (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o))))
       (else
        (string-append
@@ -129 +131 @@
             (else ""))))
      (if (pair? info)
-       (set-cdr! info (cons (cons 'gen-name name) (cdr info))))
+         (set-cdr! info (cons (cons 'gen-name name) (cdr info))))
      name)))
 
@@ -137 +139 @@
         (name (test-get-name! info)))
     (display name)
+    (display " ")
     (let ((diff (- width 9 (string-length name))))
       (cond
        ((positive? diff)
-        (display " ")
         (display (make-string diff #\.)))))
     (display " ")
@@ -197 +199 @@
           (let ((res (expr)))
             (let ((status
-                   (if (if (assq-ref info 'assertion)
-                           res
-                           ((current-test-comparator) expect-val res))
+                   (if (and (not (assq-ref info 'expect-error))
+                            (if (assq-ref info 'assertion)
+                                res
+                                ((current-test-comparator) expect-val res)))
                        'PASS
                        'FAIL))

release/3/test/test.scm

@@ -26 +26 @@
          (test name (expect ...) expr)))
        ((test name expect expr)
-        (test-info name expect expr))
+        (test-info name expect expr ()))
        ((test a ...)
         (test-syntax-error 'test "2 or 3 arguments required"

release/3/test/test.setup

@@ -6 +6 @@
  '((syntax)
   (require-at-runtime test-support)
-  (version 0.9.5)))
+  (version 0.9.6)))