Changeset 3242 in project


Ignore:
Timestamp:
03/03/07 16:16:39 (13 years ago)
Author:
Kon Lovett
Message:

Chgd imd out form.

Location:
testbase
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • testbase/testbase-proc.scm

    r2791 r3242  
    2727      tb$capture-test-structure
    2828      tb$report-mode?
    29       tb$result->tagged-alist
     29      tb$result->alist
    3030      tb$run-mode-driven?
    3131      tb$run-name
     
    7272      tb$report-mode?
    7373      tb$take-all-tests
    74       tb$result->tagged-alist
     74      tb$result->alist
    7575      tb$run-mode-driven?
    7676      tb$skip-test
     
    493493        [filtproc
    494494          (lambda (result)
    495             (let ([form (tb$result->tagged-alist result)])
     495            (let ([form (tb$result->alist result)])
    496496              (unless (eq? (void) form) ;ignore-result -> (void)
    497497                (write form port) (newline port)
  • testbase/testbase-support.scm

    r3236 r3242  
    203203      tb$take-test tb$take-all-tests
    204204      tb$capture-test-structure
    205       tb$result->tagged-alist
     205      tb$result->alist
    206206      tb$rnmdbtch?
    207207      tb$run-mode-driven? tb$run-mode-batch? tb$run-mode-interactive?
     
    663663;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    664664
    665 (define (tb$result->tagged-alist result)
     665(define (tb$result->alist result)
    666666  (letrec (
    667667      [badreserr
    668668        (lambda ()
    669           (error 'tb$result->tagged-alist "internal; invalid test-result" result))]
    670       [make-list-result
     669          (error 'tb$result->alist "internal; invalid test-result" result))]
     670      [make-item
     671        (lambda (key val)
     672          `(,key . ,val))]
     673      [make-alist-result
    671674        (lambda (result tag msgtag . rest)
    672           `(,tag
    673             (id ,(*-result-id-ref result))
    674             (,msgtag ,(*-result-message-ref result))
    675             (result ,(*-result-result-ref result))
    676             (kind ,(*-result-specific-ref result))
     675          `(,(make-item 'type tag)
     676            ,(make-item 'id (*-result-id-ref result))
     677            ,(make-item msgtag (*-result-message-ref result))
     678            ,(make-item 'result (*-result-result-ref result))
     679            ,(make-item 'kind (*-result-specific-ref result))
    677680            ,@(if (*-result-warning? result)
    678               `((warning ,(*-result-warning-ref result)))
     681              `(,(make-item 'warning (*-result-warning-ref result)))
    679682              '())
    680683            ,@(if (*-result-timing? result)
    681               `((timing ,(*-result-timing-ref result)))
     684              `(,(make-item 'timing (*-result-timing-ref result)))
    682685              '())
    683686            ,@rest))]
     
    689692              (if (test-suite-result-expectations-ref result)
    690693                  ;then evaluated
    691                 (make-list-result result 'end 'name)
     694                (make-alist-result result 'end 'name)
    692695                  ;else unevaluated
    693                 (make-list-result result 'begin 'name))]
     696                (make-alist-result result 'begin 'name))]
    694697            ;
    695698            [(test-case-result? result)
    696699              (if (test-case-result-expectations-ref result)
    697700                  ;then evaluated
    698                 (make-list-result result 'end 'name)
     701                (make-alist-result result 'end 'name)
    699702                  ;else unevaluated
    700                 (make-list-result result 'begin 'name))]
     703                (make-alist-result result 'begin 'name))]
    701704            ;
    702705            [(expect-result? result)
    703               (make-list-result result 'expectation 'name
    704                 `(unevaluated ,(expect-result-unevaled-ref result))
    705                 `(actual ,(expect-result-evaled-ref result)))]
     706              (make-alist-result result 'expectation 'name
     707                (make-item 'unevaluated (expect-result-unevaled-ref result))
     708                (make-item 'actual (expect-result-evaled-ref result)))]
    706709            ;
    707710            [(expect-tolerance-result? result)
    708               (make-list-result result 'expectation 'name
    709                 `(tolerance ,(expect-tolerance-result-lhs-tol-evaled-ref result))
    710                 `(unevaluated ,(expect-tolerance-result-rhs-unevaled-ref result))
    711                 `(expected ,(expect-tolerance-result-lhs-evaled-ref result))
    712                 `(actual ,(expect-tolerance-result-rhs-evaled-ref result)))]
     711              (make-alist-result result 'expectation 'name
     712                (make-item 'tolerance (expect-tolerance-result-lhs-tol-evaled-ref result))
     713                (make-item 'unevaluated (expect-tolerance-result-rhs-unevaled-ref result))
     714                (make-item 'expected (expect-tolerance-result-lhs-evaled-ref result))
     715                (make-item 'actual (expect-tolerance-result-rhs-evaled-ref result)))]
    713716            ;
    714717            [(expect-equivalence-result? result)
    715               (make-list-result result 'expectation 'name
    716                 `(unevaluated ,(expect-equivalence-result-rhs-unevaled-ref result))
    717                 `(expected ,(expect-equivalence-result-lhs-evaled-ref result))
    718                 `(actual ,(expect-equivalence-result-rhs-evaled-ref result)))]
     718              (make-alist-result result 'expectation 'name
     719                (make-item 'unevaluated (expect-equivalence-result-rhs-unevaled-ref result))
     720                (make-item 'expected (expect-equivalence-result-lhs-evaled-ref result))
     721                (make-item 'actual (expect-equivalence-result-rhs-evaled-ref result)))]
    719722            ;
    720723            [(terminate-result? result)
    721               (make-list-result result 'error 'message
    722                 `(container ,(terminate-result-container-ref result))
    723                 `(location ,(terminate-result-scope-ref result)))]
     724              (make-alist-result result 'error 'message
     725                (make-item 'container (terminate-result-container-ref result))
     726                (make-item 'location (terminate-result-scope-ref result)))]
    724727            ;
    725728            [(gloss-result? result)
    726               (make-list-result result 'annotation 'message)]
     729              (make-alist-result result 'annotation 'message)]
    727730            ;
    728731            [(todo-result? result)
    729               (make-list-result result 'annotation 'message)]
     732              (make-alist-result result 'annotation 'message)]
    730733            ;
    731734            [(skip-result? result)
    732               (make-list-result result 'annotation 'message)]
     735              (make-alist-result result 'annotation 'message)]
    733736            ;
    734737            [else (badreserr)]))])
Note: See TracChangeset for help on using the changeset viewer.