mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
Adopted a couple of nice ideas from Greg.
This commit is contained in:
Dirk Herrmann
parent
1a45015332
commit
57e7f27001
7 changed files with 936 additions and 909 deletions
|
|
@ -1,3 +1,25 @@
|
|||
2000-05-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
|
||||
|
||||
* guile-test: Eliminate use of catch-test-errors.
|
||||
|
||||
* lib.scm: Adopted a couple of nice ideas from Greg.
|
||||
|
||||
(pass, fail, expect-failure, expect-failure-if,
|
||||
expect-failure-if*, catch-test-errors, catch-test-errors*,
|
||||
expected-failure-fluid, pessimist?): Removed.
|
||||
|
||||
(run-test, expect-fail, result-tags, important-result-tags):
|
||||
Added.
|
||||
|
||||
(report, make-count-reporter, print-counts, make-log-reporter,
|
||||
full-reporter, user-reporter): Reporters take two mandatory
|
||||
arguments and make use of the tag descriptions in result-tags and
|
||||
important-result-tags.
|
||||
|
||||
* tests/alist.test, tests/hooks.test, tests/ports.test,
|
||||
tests/weaks.test: Don't use catch-test-errors and
|
||||
expect-failure-if.
|
||||
|
||||
2000-05-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
|
||||
|
||||
* mambo.test: Removed dummy file.
|
||||
|
|
|
|||
|
|
@ -144,8 +144,7 @@
|
|||
;; Run the tests.
|
||||
(for-each (lambda (test)
|
||||
(with-test-prefix test
|
||||
(catch-test-errors
|
||||
(load (test-file-name test)))))
|
||||
(load (test-file-name test))))
|
||||
tests)
|
||||
|
||||
;; Display the final counts, both to the user and in the log
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;;; test-suite/lib.scm --- generic support for testing
|
||||
;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or modify
|
||||
;;;; it under the terms of the GNU General Public License as published by
|
||||
|
|
@ -22,13 +22,7 @@
|
|||
(export
|
||||
|
||||
;; Reporting passes and failures.
|
||||
pass fail pass-if
|
||||
|
||||
;; Indicating tests that are expected to fail.
|
||||
expect-failure expect-failure-if expect-failure-if*
|
||||
|
||||
;; Marking independent groups of tests.
|
||||
catch-test-errors catch-test-errors*
|
||||
run-test pass-if expect-fail
|
||||
|
||||
;; Naming groups of tests in a regular fashion.
|
||||
with-test-prefix with-test-prefix* current-test-prefix
|
||||
|
|
@ -49,9 +43,45 @@
|
|||
|
||||
|
||||
;;;; If you're using Emacs's Scheme mode:
|
||||
;;;; (put 'expect-failure 'scheme-indent-function 0)
|
||||
;;;; (put 'with-test-prefix 'scheme-indent-function 1)
|
||||
|
||||
|
||||
;;;; CORE FUNCTIONS
|
||||
;;;;
|
||||
;;;; The function (run-test name expected-result thunk) is the heart of the
|
||||
;;;; testing environment. The first parameter NAME is a unique name for the
|
||||
;;;; test to be executed (for an explanation of this parameter see below under
|
||||
;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value
|
||||
;;;; that indicates whether the corresponding test is expected to pass. If
|
||||
;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
|
||||
;;;; #f the test is expected to fail. Finally, THUNK is the function that
|
||||
;;;; actually performs the test. For example:
|
||||
;;;;
|
||||
;;;; (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
|
||||
;;;;
|
||||
;;;; To report success, THUNK should either return #t or throw 'pass. To
|
||||
;;;; report failure, THUNK should either return #f or throw 'fail. If THUNK
|
||||
;;;; returns a non boolean value or throws 'unresolved, this indicates that
|
||||
;;;; the test did not perform as expected. For example the property that was
|
||||
;;;; to be tested could not be tested because something else went wrong.
|
||||
;;;; THUNK may also throw 'untested to indicate that the test was deliberately
|
||||
;;;; not performed, for example because the test case is not complete yet.
|
||||
;;;; Finally, if THUNK throws 'unsupported, this indicates that this test
|
||||
;;;; requires some feature that is not available in the configured testing
|
||||
;;;; environment. All other exceptions thrown by THUNK are considered as
|
||||
;;;; errors.
|
||||
;;;;
|
||||
;;;; For convenience, the following macros are provided:
|
||||
;;;; * (pass-if name body) is a short form for
|
||||
;;;; (run-test name #t (lambda () body))
|
||||
;;;; * (expect-fail name body) is a short form for
|
||||
;;;; (run-test name #f (lambda () body))
|
||||
;;;;
|
||||
;;;; For example:
|
||||
;;;;
|
||||
;;;; (pass-if "integer addition" (= 2 (+ 1 1)))
|
||||
|
||||
|
||||
|
||||
;;;; TEST NAMES
|
||||
;;;;
|
||||
|
|
@ -69,12 +99,9 @@
|
|||
;;;; - Test names can be reliably stored and retrieved with the standard WRITE
|
||||
;;;; and READ procedures; doing so preserves their identity.
|
||||
;;;;
|
||||
;;;; The functions for reporting results (PASS, FAIL, PASS-IF, ...)
|
||||
;;;; take the name of the passing/failing test as an argument.
|
||||
;;;; For example:
|
||||
;;;;
|
||||
;;;; (if (= 4 (+ 2 2))
|
||||
;;;; (pass "simple addition"))
|
||||
;;;; (pass-if "simple addition" (= 4 (+ 2 2)))
|
||||
;;;;
|
||||
;;;; In that case, the test name is the list ("simple addition").
|
||||
;;;;
|
||||
|
|
@ -126,21 +153,37 @@
|
|||
|
||||
|
||||
;;;; REPORTERS
|
||||
|
||||
;;;;
|
||||
;;;; A reporter is a function which we apply to each test outcome.
|
||||
;;;; Reporters can log results, print interesting results to the
|
||||
;;;; standard output, collect statistics, etc.
|
||||
;;;;
|
||||
;;;; A reporter function takes one argument, RESULT; its return value
|
||||
;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
|
||||
;;;; possibly additional arguments depending on RESULT; its return value
|
||||
;;;; is ignored. RESULT has one of the following forms:
|
||||
;;;;
|
||||
;;;; (pass TEST) - The test named TEST passed.
|
||||
;;;; (fail TEST) - The test named TEST failed.
|
||||
;;;; (xpass TEST) - The test named TEST passed unexpectedly.
|
||||
;;;; (xfail TEST) - The test named TEST failed, as expected.
|
||||
;;;; (error PREFIX) - An error occurred, with TEST as the current
|
||||
;;;; test name prefix. Some tests were
|
||||
;;;; probably not executed because of this.
|
||||
;;;; pass - The test named TEST passed.
|
||||
;;;; Additional arguments are ignored.
|
||||
;;;; upass - The test named TEST passed unexpectedly.
|
||||
;;;; Additional arguments are ignored.
|
||||
;;;; fail - The test named TEST failed.
|
||||
;;;; Additional arguments are ignored.
|
||||
;;;; xfail - The test named TEST failed, as expected.
|
||||
;;;; Additional arguments are ignored.
|
||||
;;;; unresolved - The test named TEST did not perform as expected, for
|
||||
;;;; example the property that was to be tested could not be
|
||||
;;;; tested because something else went wrong.
|
||||
;;;; Additional arguments are ignored.
|
||||
;;;; untested - The test named TEST was not actually performed, for
|
||||
;;;; example because the test case is not complete yet.
|
||||
;;;; Additional arguments are ignored.
|
||||
;;;; unsupported - The test named TEST requires some feature that is not
|
||||
;;;; available in the configured testing environment.
|
||||
;;;; Additional arguments are ignored.
|
||||
;;;; error - An error occurred while the test named TEST was
|
||||
;;;; performed. Since this result means that the system caught
|
||||
;;;; an exception it could not handle, the exception arguments
|
||||
;;;; are passed as additional arguments.
|
||||
;;;;
|
||||
;;;; This library provides some standard reporters for logging results
|
||||
;;;; to a file, reporting interesting results to the user, and
|
||||
|
|
@ -152,12 +195,87 @@
|
|||
;;;; all results to the standard output.
|
||||
|
||||
|
||||
;;;; with-test-prefix: naming groups of tests
|
||||
;;;; See the discussion of TEST NAMES, above.
|
||||
;;;; MISCELLANEOUS
|
||||
;;;;
|
||||
|
||||
;;; Display all parameters to the default output port, followed by a newline.
|
||||
(define (display-line . objs)
|
||||
(for-each display objs)
|
||||
(newline))
|
||||
|
||||
;;; Display all parameters to the given output port, followed by a newline.
|
||||
(define (display-line-port port . objs)
|
||||
(for-each (lambda (obj) (display obj port)) objs)
|
||||
(newline port))
|
||||
|
||||
|
||||
;;;; CORE FUNCTIONS
|
||||
;;;;
|
||||
|
||||
;;; The central testing routine.
|
||||
;;; The idea is taken from Greg, the GNUstep regression test environment.
|
||||
(define run-test #f)
|
||||
(let ((test-running #f))
|
||||
(define (local-run-test name expect-pass thunk)
|
||||
(if test-running
|
||||
(error "Nested calls to run-test are not permitted.")
|
||||
(let ((test-name (full-name name)))
|
||||
(set! test-running #t)
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(let ((result (thunk)))
|
||||
(if (eq? result #t) (throw 'pass))
|
||||
(if (eq? result #f) (throw 'fail))
|
||||
(throw 'unresolved)))
|
||||
(lambda (key . args)
|
||||
(case key
|
||||
((pass)
|
||||
(report (if expect-pass 'pass 'upass) test-name))
|
||||
((fail)
|
||||
(report (if expect-pass 'fail 'xfail) test-name))
|
||||
((unresolved untested unsupported)
|
||||
(report key test-name))
|
||||
((quit)
|
||||
(report 'unresolved test-name)
|
||||
(quit))
|
||||
(else
|
||||
(report 'error test-name (cons key args))))))
|
||||
(set! test-running #f))))
|
||||
(set! run-test local-run-test))
|
||||
|
||||
;;; A short form for tests that are expected to pass, taken from Greg.
|
||||
(defmacro pass-if (name body)
|
||||
`(run-test ,name #t (lambda () (not (not (begin ,body))))))
|
||||
|
||||
;;; A short form for tests that are expected to fail, taken from Greg.
|
||||
(defmacro expect-fail (name body)
|
||||
`(run-test ,name #f (lambda () ,body)))
|
||||
|
||||
|
||||
;;;; TEST NAMES
|
||||
;;;;
|
||||
|
||||
;;;; Turn a test name into a nice human-readable string.
|
||||
(define (format-test-name name)
|
||||
(call-with-output-string
|
||||
(lambda (port)
|
||||
(let loop ((name name)
|
||||
(separator ""))
|
||||
(if (pair? name)
|
||||
(begin
|
||||
(display separator port)
|
||||
(display (car name) port)
|
||||
(loop (cdr name) ": ")))))))
|
||||
|
||||
;;;; For a given test-name, deliver the full name including all prefixes.
|
||||
(define (full-name name)
|
||||
(append (current-test-prefix) (list name)))
|
||||
|
||||
;;; A fluid containing the current test prefix, as a list.
|
||||
(define prefix-fluid (make-fluid))
|
||||
(fluid-set! prefix-fluid '())
|
||||
(define (current-test-prefix)
|
||||
(fluid-ref prefix-fluid))
|
||||
|
||||
;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
|
||||
;;; The name prefix is only changed within the dynamic scope of the
|
||||
|
|
@ -175,11 +293,9 @@
|
|||
(defmacro with-test-prefix (prefix . body)
|
||||
`(with-test-prefix* ,prefix (lambda () ,@body)))
|
||||
|
||||
(define (current-test-prefix)
|
||||
(fluid-ref prefix-fluid))
|
||||
|
||||
|
||||
;;;; register-reporter, etc. --- the global reporter list
|
||||
;;;; REPORTERS
|
||||
;;;;
|
||||
|
||||
;;; The global list of reporters.
|
||||
(define reporters '())
|
||||
|
|
@ -205,16 +321,51 @@
|
|||
(define (reporter-registered? reporter)
|
||||
(if (memq reporter reporters) #t #f))
|
||||
|
||||
|
||||
;;; Send RESULT to all currently registered reporter functions.
|
||||
(define (report result)
|
||||
(define (report . args)
|
||||
(if (pair? reporters)
|
||||
(for-each (lambda (reporter) (reporter result))
|
||||
(for-each (lambda (reporter) (apply reporter args))
|
||||
reporters)
|
||||
(default-reporter result)))
|
||||
(apply default-reporter args)))
|
||||
|
||||
|
||||
;;;; Some useful reporter functions.
|
||||
;;;; Some useful standard reporters:
|
||||
;;;; Count reporters count the occurrence of each test result type.
|
||||
;;;; Log reporters write all test results to a given log file.
|
||||
;;;; Full reporters write all test results to the standard output.
|
||||
;;;; User reporters write interesting test results to the standard output.
|
||||
|
||||
;;; The complete list of possible test results.
|
||||
(define result-tags
|
||||
'((pass "PASS" "passes: ")
|
||||
(fail "FAIL" "failures: ")
|
||||
(upass "UPASS" "unexpected passes: ")
|
||||
(xfail "XFAIL" "expected failures: ")
|
||||
(unresolved "UNRESOLVED" "unresolved test cases: ")
|
||||
(untested "UNTESTED" "untested test cases: ")
|
||||
(unsupported "UNSUPPORTED" "unsupported test cases: ")
|
||||
(error "ERROR" "errors: ")))
|
||||
|
||||
;;; The list of important test results.
|
||||
(define important-result-tags
|
||||
'(fail upass unresolved error))
|
||||
|
||||
;;; Display a single test result in formatted form to the given port
|
||||
(define (print-result port result name . args)
|
||||
(let* ((tag (assq result result-tags))
|
||||
(label (if tag (cadr tag) #f)))
|
||||
(if label
|
||||
(begin
|
||||
(display label port)
|
||||
(display ": " port)
|
||||
(display (format-test-name name) port)
|
||||
(if (pair? args)
|
||||
(begin
|
||||
(display " - arguments: " port)
|
||||
(write args port)))
|
||||
(newline port))
|
||||
(error "(test-suite lib) FULL-REPORTER: unrecognized result: "
|
||||
result))))
|
||||
|
||||
;;; Return a list of the form (COUNTER RESULTS), where:
|
||||
;;; - COUNTER is a reporter procedure, and
|
||||
|
|
@ -222,194 +373,57 @@
|
|||
;;; results seen so far by COUNTER. The return value is an alist
|
||||
;;; mapping outcome symbols (`pass', `fail', etc.) onto counts.
|
||||
(define (make-count-reporter)
|
||||
(let ((counts (map (lambda (outcome) (cons outcome 0))
|
||||
'(pass fail xpass xfail error))))
|
||||
(let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
|
||||
(list
|
||||
(lambda (result)
|
||||
(let ((pair (assq (car result) counts)))
|
||||
(if pair (set-cdr! pair (+ 1 (cdr pair)))
|
||||
(error "count-reporter: unexpected test result: " result))))
|
||||
(lambda (result name . args)
|
||||
(let ((pair (assq result counts)))
|
||||
(if pair
|
||||
(set-cdr! pair (+ 1 (cdr pair)))
|
||||
(error "count-reporter: unexpected test result: "
|
||||
(cons result (cons name args))))))
|
||||
(lambda ()
|
||||
(append counts '())))))
|
||||
|
||||
;;; Print a count reporter's results nicely. Pass this function the value
|
||||
;;; returned by a count reporter's RESULTS procedure.
|
||||
(define print-counts
|
||||
(let ((tags '(pass fail xpass xfail error))
|
||||
(labels
|
||||
'("passes: "
|
||||
"failures: "
|
||||
"unexpected passes: "
|
||||
"expected failures: "
|
||||
"errors: ")))
|
||||
(lambda (results . port?)
|
||||
(let ((port (if (pair? port?)
|
||||
(car port?)
|
||||
(current-output-port))))
|
||||
(newline port)
|
||||
(display-line-port port "Totals for this test run:")
|
||||
(for-each
|
||||
(lambda (tag label)
|
||||
(let ((result (assq tag results)))
|
||||
(if result
|
||||
(display-line-port port label (cdr result))
|
||||
(display-line-port port
|
||||
"Test suite bug: "
|
||||
"no total available for `" tag "'"))))
|
||||
tags labels)
|
||||
(newline port)))))
|
||||
|
||||
;;; Handy functions. Should be in a library somewhere.
|
||||
(define (display-line . objs)
|
||||
(for-each display objs)
|
||||
(newline))
|
||||
(define (display-line-port port . objs)
|
||||
(for-each (lambda (obj) (display obj port))
|
||||
objs)
|
||||
(newline port))
|
||||
|
||||
;;; Turn a test name into a nice human-readable string.
|
||||
(define (format-test-name name)
|
||||
(call-with-output-string
|
||||
(lambda (port)
|
||||
(let loop ((name name))
|
||||
(if (pair? name)
|
||||
(begin
|
||||
(display (car name) port)
|
||||
(if (pair? (cdr name))
|
||||
(display ": " port))
|
||||
(loop (cdr name))))))))
|
||||
(define (print-counts results . port?)
|
||||
(let ((port (if (pair? port?)
|
||||
(car port?)
|
||||
(current-output-port))))
|
||||
(newline port)
|
||||
(display-line-port port "Totals for this test run:")
|
||||
(for-each
|
||||
(lambda (tag)
|
||||
(let ((result (assq (car tag) results)))
|
||||
(if result
|
||||
(display-line-port port (caddr tag) (cdr result))
|
||||
(display-line-port port
|
||||
"Test suite bug: "
|
||||
"no total available for `" (car tag) "'"))))
|
||||
result-tags)
|
||||
(newline port)))
|
||||
|
||||
;;; Return a reporter procedure which prints all results to the file
|
||||
;;; FILE, in human-readable form. FILE may be a filename, or a port.
|
||||
(define (make-log-reporter file)
|
||||
(let ((port (if (output-port? file) file
|
||||
(open-output-file file))))
|
||||
(lambda (result)
|
||||
(display (car result) port)
|
||||
(display ": " port)
|
||||
(display (format-test-name (cadr result)) port)
|
||||
(newline port)
|
||||
(lambda args
|
||||
(apply print-result port args)
|
||||
(force-output port))))
|
||||
|
||||
;;; A reporter that reports all results to the user.
|
||||
(define (full-reporter result)
|
||||
(let ((label (case (car result)
|
||||
((pass) "pass")
|
||||
((fail) "FAIL")
|
||||
((xpass) "XPASS")
|
||||
((xfail) "xfail")
|
||||
((error) "ERROR")
|
||||
(else #f))))
|
||||
(if label
|
||||
(display-line label ": " (format-test-name (cadr result)))
|
||||
(error "(test-suite lib) FULL-REPORTER: unrecognized result: "
|
||||
result))))
|
||||
(define (full-reporter . args)
|
||||
(apply print-result (current-output-port) args))
|
||||
|
||||
;;; A reporter procedure which shows interesting results (failures,
|
||||
;;; unexpected passes) to the user.
|
||||
(define (user-reporter result)
|
||||
(case (car result)
|
||||
((fail xpass) (full-reporter result))))
|
||||
;;; unexpected passes etc.) to the user.
|
||||
(define (user-reporter result name . args)
|
||||
(if (memq result important-result-tags)
|
||||
(apply full-reporter result name args)))
|
||||
|
||||
(set! default-reporter full-reporter)
|
||||
|
||||
|
||||
;;;; Marking independent groups of tests.
|
||||
|
||||
;;; When test code encounters an error (like "file not found" or "()
|
||||
;;; is not a pair"), that may mean that that particular test can't
|
||||
;;; continue, or that some nearby tests shouldn't be run, but it
|
||||
;;; doesn't mean the whole test suite must be aborted.
|
||||
;;;
|
||||
;;; Wrap each group of interdependent tests in a CATCH-TEST-ERRORS
|
||||
;;; form, so that if an error occurs, that group will be aborted, but
|
||||
;;; control will continue after the catch-test-errors form.
|
||||
|
||||
;;; Evaluate thunk, catching errors. If THUNK returns without
|
||||
;;; signalling any errors, return a list containing its value.
|
||||
;;; Otherwise, return #f.
|
||||
(define (catch-test-errors* thunk)
|
||||
|
||||
(letrec ((handler
|
||||
(lambda (key . args)
|
||||
(display-line "ERROR in test "
|
||||
(format-test-name (current-test-prefix))
|
||||
":")
|
||||
(apply display-error
|
||||
(make-stack #t handler)
|
||||
(current-error-port)
|
||||
args)
|
||||
(throw 'catch-test-errors))))
|
||||
|
||||
;; I don't know if we should really catch everything here. If you
|
||||
;; find a case where an error is signalled which really should abort
|
||||
;; the whole test case, feel free to adjust this appropriately.
|
||||
(catch 'catch-test-errors
|
||||
(lambda ()
|
||||
(lazy-catch #t
|
||||
(lambda () (list (thunk)))
|
||||
handler))
|
||||
(lambda args
|
||||
(report (list 'error (current-test-prefix)))
|
||||
#f))))
|
||||
|
||||
;;; (catch-test-errors BODY ...)
|
||||
;;; Evaluate the expressions BODY ... If a BODY expression signals an
|
||||
;;; error, record that in the test results, and return #f. Otherwise,
|
||||
;;; return a list containing the value of the last BODY expression.
|
||||
(defmacro catch-test-errors body
|
||||
`(catch-test-errors* (lambda () ,@body)))
|
||||
|
||||
|
||||
;;;; Indicating tests that are expected to fail.
|
||||
|
||||
;;; Fluid indicating whether we're currently expecting tests to fail.
|
||||
(define expected-failure-fluid (make-fluid))
|
||||
|
||||
;;; Hmm. The documentation treats EXPECT-FAILURE-IF as the primitive,
|
||||
;;; but in the implementation, EXPECT-FAILURE-IF* is the primitive.
|
||||
|
||||
;;; (expect-failure-if TEST BODY ...)
|
||||
;;; Evaluate the expression TEST, then evaluate BODY ...
|
||||
;;; If TEST evaluates to a true value, expect all tests whose results
|
||||
;;; are reported by the BODY expressions to fail.
|
||||
;;; Return the value of the last BODY form.
|
||||
(defmacro expect-failure-if (test . body)
|
||||
`(expect-failure-if* ,test (lambda () ,@body)))
|
||||
|
||||
;;; Call THUNK; if SHOULD-FAIL is true, expect any tests whose results
|
||||
;;; are reported by THUNK to fail. Return the value returned by THUNK.
|
||||
(define (expect-failure-if* should-fail thunk)
|
||||
(with-fluids ((expected-failure-fluid (not (not should-fail))))
|
||||
(thunk)))
|
||||
|
||||
;;; (expect-failure BODY ...)
|
||||
;;; Evaluate the expressions BODY ..., expecting all tests whose results
|
||||
;;; they report to fail.
|
||||
(defmacro expect-failure body
|
||||
`(expect-failure-if #t ,@body))
|
||||
|
||||
(define (pessimist?)
|
||||
(fluid-ref expected-failure-fluid))
|
||||
|
||||
|
||||
;;;; Reporting passes and failures.
|
||||
|
||||
(define (full-name name)
|
||||
(append (current-test-prefix) (list name)))
|
||||
|
||||
(define (pass name)
|
||||
(report (list (if (pessimist?) 'xpass 'pass)
|
||||
(full-name name))))
|
||||
|
||||
(define (fail name)
|
||||
(report (list (if (pessimist?) 'xfail 'fail)
|
||||
(full-name name))))
|
||||
|
||||
(define (pass-if name condition)
|
||||
((if condition pass fail) name))
|
||||
|
||||
|
||||
;;;; Helping test cases find their files
|
||||
|
||||
|
|
@ -446,5 +460,3 @@
|
|||
(catch key
|
||||
(lambda () (thunk) #f)
|
||||
(lambda args #t)))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -70,232 +70,247 @@
|
|||
(if x (cdr x) x)))
|
||||
|
||||
;;; Creators, getters
|
||||
(catch-test-errors
|
||||
(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f ()))))
|
||||
(b (acons "this" "is" (acons "a" "test" ())))
|
||||
(deformed '(a b c d e f g)))
|
||||
(pass-if "alist: acons"
|
||||
(and (equal? a '((a . b) (c . d) (e . f)))
|
||||
(equal? b '(("this" . "is") ("a" . "test")))))
|
||||
(pass-if "alist: sloppy-assq"
|
||||
(let ((x (sloppy-assq 'c a)))
|
||||
(and (pair? x)
|
||||
(eq? (car x) 'c)
|
||||
(eq? (cdr x) 'd))))
|
||||
(pass-if "alist: sloppy-assq not"
|
||||
(let ((x (sloppy-assq "this" b)))
|
||||
(not x)))
|
||||
(pass-if "alist: sloppy-assv"
|
||||
(let ((x (sloppy-assv 'c a)))
|
||||
(and (pair? x)
|
||||
(eq? (car x) 'c)
|
||||
(eq? (cdr x) 'd))))
|
||||
(pass-if "alist: sloppy-assv not"
|
||||
(let ((x (sloppy-assv "this" b)))
|
||||
(not x)))
|
||||
(pass-if "alist: sloppy-assoc"
|
||||
(let ((x (sloppy-assoc "this" b)))
|
||||
(and (pair? x)
|
||||
(string=? (cdr x) "is"))))
|
||||
(pass-if "alist: sloppy-assoc not"
|
||||
(let ((x (sloppy-assoc "heehee" b)))
|
||||
(not x)))
|
||||
(pass-if "alist: assq"
|
||||
(let ((x (assq 'c a)))
|
||||
(and (pair? x)
|
||||
(eq? (car x) 'c)
|
||||
(eq? (cdr x) 'd))))
|
||||
(pass-if "alist: assq deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assq 'x deformed))
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if-not "alist: assq not" (assq 'r a))
|
||||
(pass-if "alist: assv"
|
||||
(let ((x (assv 'a a)))
|
||||
(and (pair? x)
|
||||
(eq? (car x) 'a)
|
||||
(eq? (cdr x) 'b))))
|
||||
(pass-if "alist: assv deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assv 'x deformed)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if-not "alist: assv not" (assq "this" b))
|
||||
(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f ()))))
|
||||
(b (acons "this" "is" (acons "a" "test" ())))
|
||||
(deformed '(a b c d e f g)))
|
||||
(pass-if "alist: acons"
|
||||
(and (equal? a '((a . b) (c . d) (e . f)))
|
||||
(equal? b '(("this" . "is") ("a" . "test")))))
|
||||
(pass-if "alist: sloppy-assq"
|
||||
(let ((x (sloppy-assq 'c a)))
|
||||
(and (pair? x)
|
||||
(eq? (car x) 'c)
|
||||
(eq? (cdr x) 'd))))
|
||||
(pass-if "alist: sloppy-assq not"
|
||||
(let ((x (sloppy-assq "this" b)))
|
||||
(not x)))
|
||||
(pass-if "alist: sloppy-assv"
|
||||
(let ((x (sloppy-assv 'c a)))
|
||||
(and (pair? x)
|
||||
(eq? (car x) 'c)
|
||||
(eq? (cdr x) 'd))))
|
||||
(pass-if "alist: sloppy-assv not"
|
||||
(let ((x (sloppy-assv "this" b)))
|
||||
(not x)))
|
||||
(pass-if "alist: sloppy-assoc"
|
||||
(let ((x (sloppy-assoc "this" b)))
|
||||
(and (pair? x)
|
||||
(string=? (cdr x) "is"))))
|
||||
(pass-if "alist: sloppy-assoc not"
|
||||
(let ((x (sloppy-assoc "heehee" b)))
|
||||
(not x)))
|
||||
(pass-if "alist: assq"
|
||||
(let ((x (assq 'c a)))
|
||||
(and (pair? x)
|
||||
(eq? (car x) 'c)
|
||||
(eq? (cdr x) 'd))))
|
||||
(pass-if "alist: assq deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assq 'x deformed))
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if-not "alist: assq not" (assq 'r a))
|
||||
(pass-if "alist: assv"
|
||||
(let ((x (assv 'a a)))
|
||||
(and (pair? x)
|
||||
(eq? (car x) 'a)
|
||||
(eq? (cdr x) 'b))))
|
||||
(pass-if "alist: assv deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assv 'x deformed)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if-not "alist: assv not" (assq "this" b))
|
||||
|
||||
(pass-if "alist: assoc"
|
||||
(let ((x (assoc "this" b)))
|
||||
(and (pair? x)
|
||||
(string=? (car x) "this")
|
||||
(string=? (cdr x) "is"))))
|
||||
(pass-if "alist: assoc deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assoc 'x deformed)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if-not "alist: assoc not" (assoc "this isn't" b))))
|
||||
(pass-if "alist: assoc"
|
||||
(let ((x (assoc "this" b)))
|
||||
(and (pair? x)
|
||||
(string=? (car x) "this")
|
||||
(string=? (cdr x) "is"))))
|
||||
(pass-if "alist: assoc deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assoc 'x deformed)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if-not "alist: assoc not" (assoc "this isn't" b)))
|
||||
|
||||
|
||||
;;; Refers
|
||||
(catch-test-errors
|
||||
(let ((a '((foo bar) (baz quux)))
|
||||
(b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
|
||||
(deformed '(thats a real sloppy assq you got there)))
|
||||
(pass-if "alist: assq-ref"
|
||||
(let ((x (assq-ref a 'foo)))
|
||||
(and (list? x)
|
||||
(eq? (car x) 'bar))))
|
||||
|
||||
(pass-if-not "alist: assq-ref not" (assq-ref b "one"))
|
||||
(pass-if "alist: assv-ref"
|
||||
(let ((x (assv-ref a 'baz)))
|
||||
(and (list? x)
|
||||
(eq? (car x) 'quux))))
|
||||
|
||||
(pass-if-not "alist: assv-ref not" (assv-ref b "one"))
|
||||
(let ((a '((foo bar) (baz quux)))
|
||||
(b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
|
||||
(deformed '(thats a real sloppy assq you got there)))
|
||||
(pass-if "alist: assq-ref"
|
||||
(let ((x (assq-ref a 'foo)))
|
||||
(and (list? x)
|
||||
(eq? (car x) 'bar))))
|
||||
|
||||
(pass-if "alist: assoc-ref"
|
||||
(let ((x (assoc-ref b "one")))
|
||||
(and (list? x)
|
||||
(eq? (car x) 2)
|
||||
(eq? (cadr x) 3))))
|
||||
(pass-if-not "alist: assq-ref not" (assq-ref b "one"))
|
||||
(pass-if "alist: assv-ref"
|
||||
(let ((x (assv-ref a 'baz)))
|
||||
(and (list? x)
|
||||
(eq? (car x) 'quux))))
|
||||
|
||||
(pass-if-not "alist: assv-ref not" (assv-ref b "one"))
|
||||
|
||||
(pass-if "alist: assoc-ref"
|
||||
(let ((x (assoc-ref b "one")))
|
||||
(and (list? x)
|
||||
(eq? (car x) 2)
|
||||
(eq? (cadr x) 3))))
|
||||
|
||||
|
||||
(pass-if-not "alist: assoc-ref not" (assoc-ref a 'testing))
|
||||
|
||||
(let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
|
||||
|
||||
(pass-if "alist: assv-ref deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(if (not have-sloppy-assv-ref?) (throw 'unsupported))
|
||||
(assv-ref deformed 'sloppy)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
|
||||
(pass-if "alist: assoc-ref deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(if (not have-sloppy-assv-ref?) (throw 'unsupported))
|
||||
(assoc-ref deformed 'sloppy)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
|
||||
(pass-if "alist: assq-ref deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(if (not have-sloppy-assv-ref?) (throw 'unsupported))
|
||||
(assq-ref deformed 'sloppy)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))))
|
||||
|
||||
|
||||
(pass-if-not "alist: assoc-ref not" (assoc-ref a 'testing))
|
||||
(expect-failure-if (not (defined? 'sloppy-assv-ref))
|
||||
(pass-if "alist: assv-ref deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assv-ref deformed 'sloppy)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if "alist: assoc-ref deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assoc-ref deformed 'sloppy)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
|
||||
(pass-if "alist: assq-ref deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assq-ref deformed 'sloppy)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t))))))
|
||||
|
||||
|
||||
;;; Setters
|
||||
(catch-test-errors
|
||||
(let ((a '((another . silly) (alist . test-case)))
|
||||
(b '(("this" "one" "has") ("strings" "!")))
|
||||
(deformed '(canada is a cold nation)))
|
||||
(pass-if "alist: assq-set!"
|
||||
(begin
|
||||
(set! a (assq-set! a 'another 'stupid))
|
||||
(let ((x (safe-assq-ref a 'another)))
|
||||
(and x
|
||||
(symbol? x) (eq? x 'stupid)))))
|
||||
(let ((a '((another . silly) (alist . test-case)))
|
||||
(b '(("this" "one" "has") ("strings" "!")))
|
||||
(deformed '(canada is a cold nation)))
|
||||
(pass-if "alist: assq-set!"
|
||||
(begin
|
||||
(set! a (assq-set! a 'another 'stupid))
|
||||
(let ((x (safe-assq-ref a 'another)))
|
||||
(and x
|
||||
(symbol? x) (eq? x 'stupid)))))
|
||||
|
||||
(pass-if "alist: assq-set! add"
|
||||
(begin
|
||||
(set! a (assq-set! a 'fickle 'pickle))
|
||||
(let ((x (safe-assq-ref a 'fickle)))
|
||||
(and x (symbol? x)
|
||||
(eq? x 'pickle)))))
|
||||
|
||||
(pass-if "alist: assv-set!"
|
||||
(begin
|
||||
(set! a (assv-set! a 'another 'boring))
|
||||
(let ((x (safe-assv-ref a 'another)))
|
||||
(and x
|
||||
(eq? x 'boring)))))
|
||||
(pass-if "alist: assv-set! add"
|
||||
(begin
|
||||
(set! a (assv-set! a 'whistle '(while you work)))
|
||||
(let ((x (safe-assv-ref a 'whistle)))
|
||||
(and x (equal? x '(while you work))))))
|
||||
(pass-if "alist: assq-set! add"
|
||||
(begin
|
||||
(set! a (assq-set! a 'fickle 'pickle))
|
||||
(let ((x (safe-assq-ref a 'fickle)))
|
||||
(and x (symbol? x)
|
||||
(eq? x 'pickle)))))
|
||||
|
||||
(pass-if "alist: assv-set!"
|
||||
(begin
|
||||
(set! a (assv-set! a 'another 'boring))
|
||||
(let ((x (safe-assv-ref a 'another)))
|
||||
(and x
|
||||
(eq? x 'boring)))))
|
||||
(pass-if "alist: assv-set! add"
|
||||
(begin
|
||||
(set! a (assv-set! a 'whistle '(while you work)))
|
||||
(let ((x (safe-assv-ref a 'whistle)))
|
||||
(and x (equal? x '(while you work))))))
|
||||
|
||||
(pass-if "alist: assoc-set!"
|
||||
(begin
|
||||
(set! b (assoc-set! b "this" "has"))
|
||||
(let ((x (safe-assoc-ref b "this")))
|
||||
(and x (string? x)
|
||||
(string=? x "has")))))
|
||||
(pass-if "alist: assoc-set! add"
|
||||
(begin
|
||||
(set! b (assoc-set! b "flugle" "horn"))
|
||||
(let ((x (safe-assoc-ref b "flugle")))
|
||||
(and x (string? x)
|
||||
(string=? x "horn")))))
|
||||
|
||||
(let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
|
||||
|
||||
(pass-if "alist: assq-set! deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(if (not have-sloppy-assv-ref?) (throw 'unsupported))
|
||||
(assq-set! deformed 'cold '(very cold))
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
|
||||
(pass-if "alist: assv-set! deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(if (not have-sloppy-assv-ref?) (throw 'unsupported))
|
||||
(assv-set! deformed 'canada 'Canada)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
|
||||
(pass-if "alist: assoc-set! deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(if (not have-sloppy-assv-ref?) (throw 'unsupported))
|
||||
(assoc-set! deformed 'canada '(Iceland hence the name))
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))))
|
||||
|
||||
(pass-if "alist: assoc-set!"
|
||||
(begin
|
||||
(set! b (assoc-set! b "this" "has"))
|
||||
(let ((x (safe-assoc-ref b "this")))
|
||||
(and x (string? x)
|
||||
(string=? x "has")))))
|
||||
(pass-if "alist: assoc-set! add"
|
||||
(begin
|
||||
(set! b (assoc-set! b "flugle" "horn"))
|
||||
(let ((x (safe-assoc-ref b "flugle")))
|
||||
(and x (string? x)
|
||||
(string=? x "horn")))))
|
||||
(expect-failure-if (not (defined? 'sloppy-assq-ref))
|
||||
(pass-if "alist: assq-set! deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assq-set! deformed 'cold '(very cold))
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if "alist: assv-set! deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assv-set! deformed 'canada 'Canada)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if "alist: assoc-set! deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assoc-set! deformed 'canada
|
||||
'(Iceland hence the name))
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t))))))
|
||||
|
||||
;;; Removers
|
||||
|
||||
(catch-test-errors
|
||||
(let ((a '((a b) (c d) (e boring)))
|
||||
(b '(("what" . "else") ("could" . "I") ("say" . "here")))
|
||||
(deformed 1))
|
||||
(pass-if "alist: assq-remove!"
|
||||
(begin
|
||||
(set! a (assq-remove! a 'a))
|
||||
(equal? a '((c d) (e boring)))))
|
||||
(pass-if "alist: assv-remove!"
|
||||
(begin
|
||||
(set! a (assv-remove! a 'c))
|
||||
(equal? a '((e boring)))))
|
||||
(pass-if "alist: assoc-remove!"
|
||||
(begin
|
||||
(set! b (assoc-remove! b "what"))
|
||||
(equal? b '(("could" . "I") ("say" . "here")))))
|
||||
(expect-failure-if (not (defined? 'sloppy-assq-remove!))
|
||||
(pass-if "alist: assq-remove! deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assq-remove! deformed 'puddle)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if "alist: assv-remove! deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assv-remove! deformed 'splashing)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if "alist: assoc-remove! deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(assoc-remove! deformed 'fun)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t))))))
|
||||
(let ((a '((a b) (c d) (e boring)))
|
||||
(b '(("what" . "else") ("could" . "I") ("say" . "here")))
|
||||
(deformed 1))
|
||||
(pass-if "alist: assq-remove!"
|
||||
(begin
|
||||
(set! a (assq-remove! a 'a))
|
||||
(equal? a '((c d) (e boring)))))
|
||||
(pass-if "alist: assv-remove!"
|
||||
(begin
|
||||
(set! a (assv-remove! a 'c))
|
||||
(equal? a '((e boring)))))
|
||||
(pass-if "alist: assoc-remove!"
|
||||
(begin
|
||||
(set! b (assoc-remove! b "what"))
|
||||
(equal? b '(("could" . "I") ("say" . "here")))))
|
||||
|
||||
(let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove)))
|
||||
|
||||
(pass-if "alist: assq-remove! deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(if (not have-sloppy-assq-remove?) (throw 'unsupported))
|
||||
(assq-remove! deformed 'puddle)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
|
||||
(pass-if "alist: assv-remove! deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(if (not have-sloppy-assq-remove?) (throw 'unsupported))
|
||||
(assv-remove! deformed 'splashing)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
|
||||
(pass-if "alist: assoc-remove! deformed"
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(if (not have-sloppy-assq-remove?) (throw 'unsupported))
|
||||
(assoc-remove! deformed 'fun)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))))
|
||||
|
|
|
|||
|
|
@ -70,114 +70,113 @@
|
|||
`(pass-if ,string (not ,form)))
|
||||
|
||||
;; {The tests}
|
||||
(catch-test-errors
|
||||
(let ((proc1 (lambda (x) (+ x 1)))
|
||||
(proc2 (lambda (x) (- x 1)))
|
||||
(bad-proc (lambda (x y) #t)))
|
||||
(with-test-prefix "hooks"
|
||||
(pass-if "make-hook"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(define x (make-hook 1))))
|
||||
(proc2 (lambda (x) (- x 1)))
|
||||
(bad-proc (lambda (x y) #t)))
|
||||
(with-test-prefix "hooks"
|
||||
(pass-if "make-hook"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(define x (make-hook 1))))
|
||||
|
||||
(pass-if "add-hook!"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(let ((x (make-hook 1)))
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2))))
|
||||
|
||||
(with-test-prefix "add-hook!"
|
||||
(pass-if "append"
|
||||
(let ((x (make-hook 1)))
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2 #t)
|
||||
(eq? (cadr (hook->list x))
|
||||
proc2)))
|
||||
(pass-if "illegal proc"
|
||||
(catch-error-returning-true
|
||||
#t
|
||||
(let ((x (make-hook 1)))
|
||||
(add-hook! x bad-proc))))
|
||||
(pass-if "illegal hook"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(add-hook! '(foo) proc1))))
|
||||
(pass-if "run-hook"
|
||||
(let ((x (make-hook 1)))
|
||||
(catch-error-returning-false #t
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2)
|
||||
(run-hook x 1))))
|
||||
(with-test-prefix "run-hook"
|
||||
(pass-if "bad hook"
|
||||
(catch-error-returning-true
|
||||
#t
|
||||
(let ((x (cons 'a 'b)))
|
||||
(run-hook x 1))))
|
||||
(pass-if "too many args"
|
||||
(let ((x (make-hook 1)))
|
||||
(catch-error-returning-true
|
||||
#t
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2)
|
||||
(run-hook x 1 2))))
|
||||
(pass-if "add-hook!"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(let ((x (make-hook 1)))
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2))))
|
||||
|
||||
(pass-if
|
||||
"destructive procs"
|
||||
(let ((x (make-hook 1))
|
||||
(dest-proc1 (lambda (x)
|
||||
(set-car! x
|
||||
'i-sunk-your-battleship)))
|
||||
(dest-proc2 (lambda (x) (set-cdr! x 'no-way!)))
|
||||
(val '(a-game-of battleship)))
|
||||
(add-hook! x dest-proc1)
|
||||
(add-hook! x dest-proc2 #t)
|
||||
(run-hook x val)
|
||||
(and (eq? (car val) 'i-sunk-your-battleship)
|
||||
(eq? (cdr val) 'no-way!)))))
|
||||
(with-test-prefix "add-hook!"
|
||||
(pass-if "append"
|
||||
(let ((x (make-hook 1)))
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2 #t)
|
||||
(eq? (cadr (hook->list x))
|
||||
proc2)))
|
||||
(pass-if "illegal proc"
|
||||
(catch-error-returning-true
|
||||
#t
|
||||
(let ((x (make-hook 1)))
|
||||
(add-hook! x bad-proc))))
|
||||
(pass-if "illegal hook"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(add-hook! '(foo) proc1))))
|
||||
(pass-if "run-hook"
|
||||
(let ((x (make-hook 1)))
|
||||
(catch-error-returning-false #t
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2)
|
||||
(run-hook x 1))))
|
||||
(with-test-prefix "run-hook"
|
||||
(pass-if "bad hook"
|
||||
(catch-error-returning-true
|
||||
#t
|
||||
(let ((x (cons 'a 'b)))
|
||||
(run-hook x 1))))
|
||||
(pass-if "too many args"
|
||||
(let ((x (make-hook 1)))
|
||||
(catch-error-returning-true
|
||||
#t
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2)
|
||||
(run-hook x 1 2))))
|
||||
|
||||
(pass-if "make-hook-with-name"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(let ((x (make-hook-with-name 'x 1)))
|
||||
(add-hook! x proc1))))
|
||||
(pass-if "make-hook-with-name: bad name"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(define x (make-hook-with-name '(a b) 1))))
|
||||
(pass-if
|
||||
"destructive procs"
|
||||
(let ((x (make-hook 1))
|
||||
(dest-proc1 (lambda (x)
|
||||
(set-car! x
|
||||
'i-sunk-your-battleship)))
|
||||
(dest-proc2 (lambda (x) (set-cdr! x 'no-way!)))
|
||||
(val '(a-game-of battleship)))
|
||||
(add-hook! x dest-proc1)
|
||||
(add-hook! x dest-proc2 #t)
|
||||
(run-hook x val)
|
||||
(and (eq? (car val) 'i-sunk-your-battleship)
|
||||
(eq? (cdr val) 'no-way!)))))
|
||||
|
||||
(with-test-prefix "remove-hook!"
|
||||
(pass-if ""
|
||||
(let ((x (make-hook 1)))
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2)
|
||||
(remove-hook! x proc1)
|
||||
(not (memq proc1 (hook->list x)))))
|
||||
; Maybe it should error, but this is probably
|
||||
; more convienient
|
||||
(pass-if "empty hook"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(let ((x (make-hook 1)))
|
||||
(remove-hook! x proc1)))))
|
||||
(pass-if "hook->list"
|
||||
(let ((x (make-hook 1)))
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2)
|
||||
(and (memq proc1 (hook->list x) )
|
||||
(memq proc2 (hook->list x)))))
|
||||
(pass-if "reset-hook!"
|
||||
(let ((x (make-hook 1)))
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2)
|
||||
(reset-hook! x)
|
||||
(null? (hook->list x))))
|
||||
(with-test-prefix "reset-hook!"
|
||||
(pass-if "empty hook"
|
||||
(let ((x (make-hook 1)))
|
||||
(reset-hook! x)))
|
||||
(pass-if "bad hook"
|
||||
(catch-error-returning-true
|
||||
#t
|
||||
(reset-hook! '(a b))))))))
|
||||
(pass-if "make-hook-with-name"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(let ((x (make-hook-with-name 'x 1)))
|
||||
(add-hook! x proc1))))
|
||||
(pass-if "make-hook-with-name: bad name"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(define x (make-hook-with-name '(a b) 1))))
|
||||
|
||||
(with-test-prefix "remove-hook!"
|
||||
(pass-if ""
|
||||
(let ((x (make-hook 1)))
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2)
|
||||
(remove-hook! x proc1)
|
||||
(not (memq proc1 (hook->list x)))))
|
||||
; Maybe it should error, but this is probably
|
||||
; more convienient
|
||||
(pass-if "empty hook"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(let ((x (make-hook 1)))
|
||||
(remove-hook! x proc1)))))
|
||||
(pass-if "hook->list"
|
||||
(let ((x (make-hook 1)))
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2)
|
||||
(and (memq proc1 (hook->list x) )
|
||||
(memq proc2 (hook->list x)))))
|
||||
(pass-if "reset-hook!"
|
||||
(let ((x (make-hook 1)))
|
||||
(add-hook! x proc1)
|
||||
(add-hook! x proc2)
|
||||
(reset-hook! x)
|
||||
(null? (hook->list x))))
|
||||
(with-test-prefix "reset-hook!"
|
||||
(pass-if "empty hook"
|
||||
(let ((x (make-hook 1)))
|
||||
(reset-hook! x)))
|
||||
(pass-if "bad hook"
|
||||
(catch-error-returning-true
|
||||
#t
|
||||
(reset-hook! '(a b)))))))
|
||||
|
|
|
|||
|
|
@ -49,188 +49,177 @@
|
|||
;;;; Normal file ports.
|
||||
|
||||
;;; Write out an s-expression, and read it back.
|
||||
(catch-test-errors
|
||||
(let ((string '("From fairest creatures we desire increase,"
|
||||
"That thereby beauty's rose might never die,"))
|
||||
(filename (test-file)))
|
||||
(let ((port (open-output-file filename)))
|
||||
(write string port)
|
||||
(close-port port))
|
||||
(let ((port (open-input-file filename)))
|
||||
(let ((in-string (read port)))
|
||||
(pass-if "file: write and read back list of strings"
|
||||
(equal? string in-string)))
|
||||
(close-port port))
|
||||
(delete-file filename)))
|
||||
(let ((string '("From fairest creatures we desire increase,"
|
||||
"That thereby beauty's rose might never die,"))
|
||||
(filename (test-file)))
|
||||
(let ((port (open-output-file filename)))
|
||||
(write string port)
|
||||
(close-port port))
|
||||
(let ((port (open-input-file filename)))
|
||||
(let ((in-string (read port)))
|
||||
(pass-if "file: write and read back list of strings"
|
||||
(equal? string in-string)))
|
||||
(close-port port))
|
||||
(delete-file filename))
|
||||
|
||||
;;; Write out a string, and read it back a character at a time.
|
||||
(catch-test-errors
|
||||
(let ((string "This is a test string\nwith no newline at the end")
|
||||
(filename (test-file)))
|
||||
(let ((port (open-output-file filename)))
|
||||
(display string port)
|
||||
(close-port port))
|
||||
(let ((in-string (read-file filename)))
|
||||
(pass-if "file: write and read back characters"
|
||||
(equal? string in-string)))
|
||||
(delete-file filename)))
|
||||
(let ((string "This is a test string\nwith no newline at the end")
|
||||
(filename (test-file)))
|
||||
(let ((port (open-output-file filename)))
|
||||
(display string port)
|
||||
(close-port port))
|
||||
(let ((in-string (read-file filename)))
|
||||
(pass-if "file: write and read back characters"
|
||||
(equal? string in-string)))
|
||||
(delete-file filename))
|
||||
|
||||
;;; Buffered input/output port with seeking.
|
||||
(catch-test-errors
|
||||
(let* ((filename (test-file))
|
||||
(port (open-file filename "w+")))
|
||||
(display "J'Accuse" port)
|
||||
(seek port -1 SEEK_CUR)
|
||||
(pass-if "file: r/w 1"
|
||||
(char=? (read-char port) #\e))
|
||||
(pass-if "file: r/w 2"
|
||||
(eof-object? (read-char port)))
|
||||
(seek port -1 SEEK_CUR)
|
||||
(write-char #\x port)
|
||||
(seek port 7 SEEK_SET)
|
||||
(pass-if "file: r/w 3"
|
||||
(char=? (read-char port) #\x))
|
||||
(seek port -2 SEEK_END)
|
||||
(pass-if "file: r/w 4"
|
||||
(char=? (read-char port) #\s))
|
||||
(delete-file filename)))
|
||||
(let* ((filename (test-file))
|
||||
(port (open-file filename "w+")))
|
||||
(display "J'Accuse" port)
|
||||
(seek port -1 SEEK_CUR)
|
||||
(pass-if "file: r/w 1"
|
||||
(char=? (read-char port) #\e))
|
||||
(pass-if "file: r/w 2"
|
||||
(eof-object? (read-char port)))
|
||||
(seek port -1 SEEK_CUR)
|
||||
(write-char #\x port)
|
||||
(seek port 7 SEEK_SET)
|
||||
(pass-if "file: r/w 3"
|
||||
(char=? (read-char port) #\x))
|
||||
(seek port -2 SEEK_END)
|
||||
(pass-if "file: r/w 4"
|
||||
(char=? (read-char port) #\s))
|
||||
(delete-file filename))
|
||||
|
||||
;;; Unbuffered input/output port with seeking.
|
||||
(catch-test-errors
|
||||
(let* ((filename (test-file))
|
||||
(port (open-file filename "w+0")))
|
||||
(display "J'Accuse" port)
|
||||
(seek port -1 SEEK_CUR)
|
||||
(pass-if "file: ub r/w 1"
|
||||
(char=? (read-char port) #\e))
|
||||
(pass-if "file: ub r/w 2"
|
||||
(eof-object? (read-char port)))
|
||||
(seek port -1 SEEK_CUR)
|
||||
(write-char #\x port)
|
||||
(seek port 7 SEEK_SET)
|
||||
(pass-if "file: ub r/w 3"
|
||||
(char=? (read-char port) #\x))
|
||||
(seek port -2 SEEK_END)
|
||||
(pass-if "file: ub r/w 4"
|
||||
(char=? (read-char port) #\s))
|
||||
(delete-file filename)))
|
||||
(let* ((filename (test-file))
|
||||
(port (open-file filename "w+0")))
|
||||
(display "J'Accuse" port)
|
||||
(seek port -1 SEEK_CUR)
|
||||
(pass-if "file: ub r/w 1"
|
||||
(char=? (read-char port) #\e))
|
||||
(pass-if "file: ub r/w 2"
|
||||
(eof-object? (read-char port)))
|
||||
(seek port -1 SEEK_CUR)
|
||||
(write-char #\x port)
|
||||
(seek port 7 SEEK_SET)
|
||||
(pass-if "file: ub r/w 3"
|
||||
(char=? (read-char port) #\x))
|
||||
(seek port -2 SEEK_END)
|
||||
(pass-if "file: ub r/w 4"
|
||||
(char=? (read-char port) #\s))
|
||||
(delete-file filename))
|
||||
|
||||
;;; Buffered output-only and input-only ports with seeking.
|
||||
(catch-test-errors
|
||||
(let* ((filename (test-file))
|
||||
(port (open-output-file filename)))
|
||||
(display "J'Accuse" port)
|
||||
(pass-if "file: out tell"
|
||||
(= (seek port 0 SEEK_CUR) 8))
|
||||
(seek port -1 SEEK_CUR)
|
||||
(write-char #\x port)
|
||||
(close-port port)
|
||||
(let ((iport (open-input-file filename)))
|
||||
(pass-if "file: in tell 0"
|
||||
(= (seek iport 0 SEEK_CUR) 0))
|
||||
(read-char iport)
|
||||
(pass-if "file: in tell 1"
|
||||
(= (seek iport 0 SEEK_CUR) 1))
|
||||
(unread-char #\z iport)
|
||||
(pass-if "file: in tell 0 after unread"
|
||||
(= (seek iport 0 SEEK_CUR) 0))
|
||||
(pass-if "file: unread char still there"
|
||||
(char=? (read-char iport) #\z))
|
||||
(seek iport 7 SEEK_SET)
|
||||
(pass-if "file: in last char"
|
||||
(char=? (read-char iport) #\x))
|
||||
(close-port iport))
|
||||
(delete-file filename)))
|
||||
(let* ((filename (test-file))
|
||||
(port (open-output-file filename)))
|
||||
(display "J'Accuse" port)
|
||||
(pass-if "file: out tell"
|
||||
(= (seek port 0 SEEK_CUR) 8))
|
||||
(seek port -1 SEEK_CUR)
|
||||
(write-char #\x port)
|
||||
(close-port port)
|
||||
(let ((iport (open-input-file filename)))
|
||||
(pass-if "file: in tell 0"
|
||||
(= (seek iport 0 SEEK_CUR) 0))
|
||||
(read-char iport)
|
||||
(pass-if "file: in tell 1"
|
||||
(= (seek iport 0 SEEK_CUR) 1))
|
||||
(unread-char #\z iport)
|
||||
(pass-if "file: in tell 0 after unread"
|
||||
(= (seek iport 0 SEEK_CUR) 0))
|
||||
(pass-if "file: unread char still there"
|
||||
(char=? (read-char iport) #\z))
|
||||
(seek iport 7 SEEK_SET)
|
||||
(pass-if "file: in last char"
|
||||
(char=? (read-char iport) #\x))
|
||||
(close-port iport))
|
||||
(delete-file filename))
|
||||
|
||||
;;; unusual characters.
|
||||
(catch-test-errors
|
||||
(let* ((filename (test-file))
|
||||
(port (open-output-file filename)))
|
||||
(display (string #\nul (integer->char 255) (integer->char 128)
|
||||
#\nul) port)
|
||||
(close-port port)
|
||||
(let* ((port (open-input-file filename))
|
||||
(line (read-line port)))
|
||||
(pass-if "file: read back NUL 1"
|
||||
(char=? (string-ref line 0) #\nul))
|
||||
(pass-if "file: read back 255"
|
||||
(char=? (string-ref line 1) (integer->char 255)))
|
||||
(pass-if "file: read back 128"
|
||||
(char=? (string-ref line 2) (integer->char 128)))
|
||||
(pass-if "file: read back NUL 2"
|
||||
(char=? (string-ref line 3) #\nul))
|
||||
(pass-if "file: EOF"
|
||||
(eof-object? (read-char port))))
|
||||
(delete-file filename)))
|
||||
(let* ((filename (test-file))
|
||||
(port (open-output-file filename)))
|
||||
(display (string #\nul (integer->char 255) (integer->char 128)
|
||||
#\nul) port)
|
||||
(close-port port)
|
||||
(let* ((port (open-input-file filename))
|
||||
(line (read-line port)))
|
||||
(pass-if "file: read back NUL 1"
|
||||
(char=? (string-ref line 0) #\nul))
|
||||
(pass-if "file: read back 255"
|
||||
(char=? (string-ref line 1) (integer->char 255)))
|
||||
(pass-if "file: read back 128"
|
||||
(char=? (string-ref line 2) (integer->char 128)))
|
||||
(pass-if "file: read back NUL 2"
|
||||
(char=? (string-ref line 3) #\nul))
|
||||
(pass-if "file: EOF"
|
||||
(eof-object? (read-char port))))
|
||||
(delete-file filename))
|
||||
|
||||
;;; line buffering mode.
|
||||
(catch-test-errors
|
||||
(let* ((filename (test-file))
|
||||
(port (open-file filename "wl"))
|
||||
(test-string "one line more or less"))
|
||||
(write-line test-string port)
|
||||
(let* ((in-port (open-input-file filename))
|
||||
(line (read-line in-port)))
|
||||
(close-port in-port)
|
||||
(close-port port)
|
||||
(pass-if "file: line buffering"
|
||||
(string=? line test-string)))
|
||||
(delete-file filename)))
|
||||
(let* ((filename (test-file))
|
||||
(port (open-file filename "wl"))
|
||||
(test-string "one line more or less"))
|
||||
(write-line test-string port)
|
||||
(let* ((in-port (open-input-file filename))
|
||||
(line (read-line in-port)))
|
||||
(close-port in-port)
|
||||
(close-port port)
|
||||
(pass-if "file: line buffering"
|
||||
(string=? line test-string)))
|
||||
(delete-file filename))
|
||||
|
||||
;;; ungetting characters and strings.
|
||||
(catch-test-errors
|
||||
(with-input-from-string "walk on the moon\nmoon"
|
||||
(lambda ()
|
||||
(read-char)
|
||||
(unread-char #\a (current-input-port))
|
||||
(pass-if "unread-char"
|
||||
(char=? (read-char) #\a))
|
||||
(read-line)
|
||||
(let ((replacenoid "chicken enchilada"))
|
||||
(unread-char #\newline (current-input-port))
|
||||
(unread-string replacenoid (current-input-port))
|
||||
(pass-if "unread-string"
|
||||
(string=? (read-line) replacenoid)))
|
||||
(pass-if "unread residue"
|
||||
(string=? (read-line) "moon")))))
|
||||
(with-input-from-string "walk on the moon\nmoon"
|
||||
(lambda ()
|
||||
(read-char)
|
||||
(unread-char #\a (current-input-port))
|
||||
(pass-if "unread-char"
|
||||
(char=? (read-char) #\a))
|
||||
(read-line)
|
||||
(let ((replacenoid "chicken enchilada"))
|
||||
(unread-char #\newline (current-input-port))
|
||||
(unread-string replacenoid (current-input-port))
|
||||
(pass-if "unread-string"
|
||||
(string=? (read-line) replacenoid)))
|
||||
(pass-if "unread residue"
|
||||
(string=? (read-line) "moon"))))
|
||||
|
||||
;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on
|
||||
;;; the reading end. try to read a byte: should get EAGAIN or
|
||||
;;; EWOULDBLOCK error.
|
||||
(catch-test-errors
|
||||
(let* ((p (pipe))
|
||||
(r (car p)))
|
||||
(fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
|
||||
(pass-if "non-blocking-I/O"
|
||||
(catch 'system-error
|
||||
(lambda () (read-char r) #f)
|
||||
(lambda (key . args)
|
||||
(and (eq? key 'system-error)
|
||||
(let ((errno (car (list-ref args 3))))
|
||||
(or (= errno EAGAIN)
|
||||
(= errno EWOULDBLOCK)))))))))
|
||||
(let* ((p (pipe))
|
||||
(r (car p)))
|
||||
(fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
|
||||
(pass-if "non-blocking-I/O"
|
||||
(catch 'system-error
|
||||
(lambda () (read-char r) #f)
|
||||
(lambda (key . args)
|
||||
(and (eq? key 'system-error)
|
||||
(let ((errno (car (list-ref args 3))))
|
||||
(or (= errno EAGAIN)
|
||||
(= errno EWOULDBLOCK))))))))
|
||||
|
||||
;;;; Pipe (popen) ports.
|
||||
|
||||
;;; Run a command, and read its output.
|
||||
(catch-test-errors
|
||||
(let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
|
||||
(in-string (read-all pipe)))
|
||||
(close-pipe pipe)
|
||||
(pass-if "pipe: read"
|
||||
(equal? in-string "Howdy there, partner!\n"))))
|
||||
(let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
|
||||
(in-string (read-all pipe)))
|
||||
(close-pipe pipe)
|
||||
(pass-if "pipe: read"
|
||||
(equal? in-string "Howdy there, partner!\n")))
|
||||
|
||||
;;; Run a command, send some output to it, and see if it worked.
|
||||
(catch-test-errors
|
||||
(let* ((filename (test-file))
|
||||
(pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
|
||||
(display "Now Jimmy lives on a mushroom cloud\n" pipe)
|
||||
(display "Mommy, why does everybody have a bomb?\n" pipe)
|
||||
(close-pipe pipe)
|
||||
(let ((in-string (read-file filename)))
|
||||
(pass-if "pipe: write"
|
||||
(equal? in-string "Mommy, why does everybody have a bomb?\n")))
|
||||
(delete-file filename)))
|
||||
(let* ((filename (test-file))
|
||||
(pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
|
||||
(display "Now Jimmy lives on a mushroom cloud\n" pipe)
|
||||
(display "Mommy, why does everybody have a bomb?\n" pipe)
|
||||
(close-pipe pipe)
|
||||
(let ((in-string (read-file filename)))
|
||||
(pass-if "pipe: write"
|
||||
(equal? in-string "Mommy, why does everybody have a bomb?\n")))
|
||||
(delete-file filename))
|
||||
|
||||
|
||||
;;;; Void ports. These are so trivial we don't test them.
|
||||
|
|
@ -241,75 +230,71 @@
|
|||
(with-test-prefix "string ports"
|
||||
|
||||
;; Write text to a string port.
|
||||
(catch-test-errors
|
||||
(let* ((string "Howdy there, partner!")
|
||||
(in-string (call-with-output-string
|
||||
(lambda (port)
|
||||
(display string port)
|
||||
(newline port)))))
|
||||
(pass-if "display text"
|
||||
(equal? in-string (string-append string "\n")))))
|
||||
(let* ((string "Howdy there, partner!")
|
||||
(in-string (call-with-output-string
|
||||
(lambda (port)
|
||||
(display string port)
|
||||
(newline port)))))
|
||||
(pass-if "display text"
|
||||
(equal? in-string (string-append string "\n"))))
|
||||
|
||||
;; Write an s-expression to a string port.
|
||||
(catch-test-errors
|
||||
(let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
|
||||
(in-sexpr
|
||||
(call-with-input-string (call-with-output-string
|
||||
(lambda (port)
|
||||
(write sexpr port)))
|
||||
read)))
|
||||
(pass-if "write/read sexpr"
|
||||
(equal? in-sexpr sexpr))))
|
||||
(let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
|
||||
(in-sexpr
|
||||
(call-with-input-string (call-with-output-string
|
||||
(lambda (port)
|
||||
(write sexpr port)))
|
||||
read)))
|
||||
(pass-if "write/read sexpr"
|
||||
(equal? in-sexpr sexpr)))
|
||||
|
||||
;; seeking and unreading from an input string.
|
||||
(catch-test-errors
|
||||
(let ((text "that text didn't look random to me"))
|
||||
(call-with-input-string text
|
||||
(lambda (p)
|
||||
(pass-if "input tell 0"
|
||||
(= (seek p 0 SEEK_CUR) 0))
|
||||
(read-char p)
|
||||
(pass-if "input tell 1"
|
||||
(= (seek p 0 SEEK_CUR) 1))
|
||||
(unread-char #\x p)
|
||||
(pass-if "input tell back to 0"
|
||||
(= (seek p 0 SEEK_CUR) 0))
|
||||
(pass-if "input ungetted char"
|
||||
(char=? (read-char p) #\x))
|
||||
(seek p 0 SEEK_END)
|
||||
(pass-if "input seek to end"
|
||||
(= (seek p 0 SEEK_CUR)
|
||||
(string-length text)))
|
||||
(unread-char #\x p)
|
||||
(pass-if "input seek to beginning"
|
||||
(= (seek p 0 SEEK_SET) 0))
|
||||
(pass-if "input reread first char"
|
||||
(char=? (read-char p)
|
||||
(string-ref text 0)))))))
|
||||
|
||||
(let ((text "that text didn't look random to me"))
|
||||
(call-with-input-string text
|
||||
(lambda (p)
|
||||
(pass-if "input tell 0"
|
||||
(= (seek p 0 SEEK_CUR) 0))
|
||||
(read-char p)
|
||||
(pass-if "input tell 1"
|
||||
(= (seek p 0 SEEK_CUR) 1))
|
||||
(unread-char #\x p)
|
||||
(pass-if "input tell back to 0"
|
||||
(= (seek p 0 SEEK_CUR) 0))
|
||||
(pass-if "input ungetted char"
|
||||
(char=? (read-char p) #\x))
|
||||
(seek p 0 SEEK_END)
|
||||
(pass-if "input seek to end"
|
||||
(= (seek p 0 SEEK_CUR)
|
||||
(string-length text)))
|
||||
(unread-char #\x p)
|
||||
(pass-if "input seek to beginning"
|
||||
(= (seek p 0 SEEK_SET) 0))
|
||||
(pass-if "input reread first char"
|
||||
(char=? (read-char p)
|
||||
(string-ref text 0))))))
|
||||
|
||||
;; seeking an output string.
|
||||
(catch-test-errors
|
||||
(let* ((text "123456789")
|
||||
(len (string-length text))
|
||||
(result (call-with-output-string
|
||||
(lambda (p)
|
||||
(pass-if "output tell 0"
|
||||
(= (seek p 0 SEEK_CUR) 0))
|
||||
(display text p)
|
||||
(pass-if "output tell end"
|
||||
(= (seek p 0 SEEK_CUR) len))
|
||||
(pass-if "output seek to beginning"
|
||||
(= (seek p 0 SEEK_SET) 0))
|
||||
(write-char #\a p)
|
||||
(seek p -1 SEEK_END)
|
||||
(pass-if "output seek to last char"
|
||||
(= (seek p 0 SEEK_CUR)
|
||||
(- len 1)))
|
||||
(write-char #\b p)))))
|
||||
(string-set! text 0 #\a)
|
||||
(string-set! text (- len 1) #\b)
|
||||
(pass-if "output check"
|
||||
(string=? text result)))))
|
||||
(let* ((text "123456789")
|
||||
(len (string-length text))
|
||||
(result (call-with-output-string
|
||||
(lambda (p)
|
||||
(pass-if "output tell 0"
|
||||
(= (seek p 0 SEEK_CUR) 0))
|
||||
(display text p)
|
||||
(pass-if "output tell end"
|
||||
(= (seek p 0 SEEK_CUR) len))
|
||||
(pass-if "output seek to beginning"
|
||||
(= (seek p 0 SEEK_SET) 0))
|
||||
(write-char #\a p)
|
||||
(seek p -1 SEEK_END)
|
||||
(pass-if "output seek to last char"
|
||||
(= (seek p 0 SEEK_CUR)
|
||||
(- len 1)))
|
||||
(write-char #\b p)))))
|
||||
(string-set! text 0 #\a)
|
||||
(string-set! text (- len 1) #\b)
|
||||
(pass-if "output check"
|
||||
(string=? text result))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -372,28 +357,26 @@
|
|||
(for-each close-port ports)
|
||||
(delete-file port-loop-temp))))
|
||||
|
||||
(catch-test-errors
|
||||
(with-test-prefix "newline"
|
||||
(test-line-counter
|
||||
(string-append "x\n"
|
||||
"He who receives an idea from me, receives instruction\n"
|
||||
"himself without lessening mine; as he who lights his\n"
|
||||
"taper at mine, receives light without darkening me.\n"
|
||||
" --- Thomas Jefferson\n")
|
||||
"He who receives an idea from me, receives instruction"
|
||||
0)))
|
||||
(with-test-prefix "newline"
|
||||
(test-line-counter
|
||||
(string-append "x\n"
|
||||
"He who receives an idea from me, receives instruction\n"
|
||||
"himself without lessening mine; as he who lights his\n"
|
||||
"taper at mine, receives light without darkening me.\n"
|
||||
" --- Thomas Jefferson\n")
|
||||
"He who receives an idea from me, receives instruction"
|
||||
0))
|
||||
|
||||
(catch-test-errors
|
||||
(with-test-prefix "no newline"
|
||||
(test-line-counter
|
||||
(string-append "x\n"
|
||||
"He who receives an idea from me, receives instruction\n"
|
||||
"himself without lessening mine; as he who lights his\n"
|
||||
"taper at mine, receives light without darkening me.\n"
|
||||
" --- Thomas Jefferson\n"
|
||||
"no newline here")
|
||||
"He who receives an idea from me, receives instruction"
|
||||
15))))
|
||||
(with-test-prefix "no newline"
|
||||
(test-line-counter
|
||||
(string-append "x\n"
|
||||
"He who receives an idea from me, receives instruction\n"
|
||||
"himself without lessening mine; as he who lights his\n"
|
||||
"taper at mine, receives light without darkening me.\n"
|
||||
" --- Thomas Jefferson\n"
|
||||
"no newline here")
|
||||
"He who receives an idea from me, receives instruction"
|
||||
15)))
|
||||
|
||||
|
||||
;;;; testing read-delimited and friends
|
||||
|
|
|
|||
|
|
@ -75,65 +75,64 @@
|
|||
;;; Creation functions
|
||||
|
||||
|
||||
(catch-test-errors
|
||||
(with-test-prefix
|
||||
"weak-creation"
|
||||
(with-test-prefix "make-weak-vector"
|
||||
(pass-if "normal"
|
||||
(catch-error-returning-false #t
|
||||
(define x (make-weak-vector 10 #f))))
|
||||
(pass-if "bad size"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(define x (make-weak-vector 'foo)))))
|
||||
|
||||
(with-test-prefix "list->weak-vector"
|
||||
(pass-if "create"
|
||||
(let* ((lst '(a b c d e f g))
|
||||
(wv (list->weak-vector lst)))
|
||||
(and (eq? (vector-ref wv 0) 'a)
|
||||
(eq? (vector-ref wv 1) 'b)
|
||||
(eq? (vector-ref wv 2) 'c)
|
||||
(eq? (vector-ref wv 3) 'd)
|
||||
(eq? (vector-ref wv 4) 'e)
|
||||
(eq? (vector-ref wv 5) 'f)
|
||||
(eq? (vector-ref wv 6) 'g))))
|
||||
(pass-if "bad-args"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(define x (list->weak-vector 32)))))
|
||||
(with-test-prefix
|
||||
"weak-creation"
|
||||
(with-test-prefix "make-weak-vector"
|
||||
(pass-if "normal"
|
||||
(catch-error-returning-false #t
|
||||
(define x (make-weak-vector 10 #f))))
|
||||
(pass-if "bad size"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(define x (make-weak-vector 'foo)))))
|
||||
|
||||
(with-test-prefix "make-weak-key-hash-table"
|
||||
(pass-if "create"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(define x (make-weak-key-hash-table 17))))
|
||||
(pass-if "bad-args"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(define x
|
||||
(make-weak-key-hash-table '(bad arg))))))
|
||||
(with-test-prefix "make-weak-value-hash-table"
|
||||
(pass-if "create"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(define x (make-weak-value-hash-table 17))))
|
||||
(pass-if "bad-args"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(define x
|
||||
(make-weak-value-hash-table '(bad arg))))))
|
||||
|
||||
(with-test-prefix "make-doubly-weak-hash-table"
|
||||
(pass-if "create"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(define x (make-doubly-weak-hash-table 17))))
|
||||
(pass-if "bad-args"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(define x
|
||||
(make-doubly-weak-hash-table '(bad arg))))))))
|
||||
(with-test-prefix "list->weak-vector"
|
||||
(pass-if "create"
|
||||
(let* ((lst '(a b c d e f g))
|
||||
(wv (list->weak-vector lst)))
|
||||
(and (eq? (vector-ref wv 0) 'a)
|
||||
(eq? (vector-ref wv 1) 'b)
|
||||
(eq? (vector-ref wv 2) 'c)
|
||||
(eq? (vector-ref wv 3) 'd)
|
||||
(eq? (vector-ref wv 4) 'e)
|
||||
(eq? (vector-ref wv 5) 'f)
|
||||
(eq? (vector-ref wv 6) 'g))))
|
||||
(pass-if "bad-args"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(define x (list->weak-vector 32)))))
|
||||
|
||||
(with-test-prefix "make-weak-key-hash-table"
|
||||
(pass-if "create"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(define x (make-weak-key-hash-table 17))))
|
||||
(pass-if "bad-args"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(define x
|
||||
(make-weak-key-hash-table '(bad arg))))))
|
||||
(with-test-prefix "make-weak-value-hash-table"
|
||||
(pass-if "create"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(define x (make-weak-value-hash-table 17))))
|
||||
(pass-if "bad-args"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(define x
|
||||
(make-weak-value-hash-table '(bad arg))))))
|
||||
|
||||
(with-test-prefix "make-doubly-weak-hash-table"
|
||||
(pass-if "create"
|
||||
(catch-error-returning-false
|
||||
#t
|
||||
(define x (make-doubly-weak-hash-table 17))))
|
||||
(pass-if "bad-args"
|
||||
(catch-error-returning-true
|
||||
'wrong-type-arg
|
||||
(define x
|
||||
(make-doubly-weak-hash-table '(bad arg)))))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -151,84 +150,82 @@
|
|||
(gc))
|
||||
|
||||
;;; Normal weak vectors
|
||||
(catch-test-errors
|
||||
(let ((x (make-weak-vector 10 #f))
|
||||
(bar "bar"))
|
||||
(with-test-prefix
|
||||
"weak-vector"
|
||||
(pass-if "lives"
|
||||
(begin
|
||||
(vector-set! x 0 bar)
|
||||
(gc)
|
||||
(and (vector-ref x 0) (eq? bar (vector-ref x 0)))))
|
||||
(pass-if "dies"
|
||||
(begin
|
||||
(gc)
|
||||
(or (not (vector-ref global-weak 0))
|
||||
(not (vector-ref global-weak 1))
|
||||
(not (vector-ref global-weak 2))
|
||||
(not (vector-ref global-weak 3))
|
||||
(not (vector-ref global-weak 4))))))))
|
||||
|
||||
(catch-test-errors
|
||||
(let ((x (make-weak-key-hash-table 17))
|
||||
(y (make-weak-value-hash-table 17))
|
||||
(z (make-doubly-weak-hash-table 17))
|
||||
(test-key "foo")
|
||||
(test-value "bar"))
|
||||
(with-test-prefix
|
||||
"weak-hash"
|
||||
(pass-if "lives"
|
||||
(begin
|
||||
(hashq-set! x test-key test-value)
|
||||
(hashq-set! y test-key test-value)
|
||||
(hashq-set! z test-key test-value)
|
||||
(gc)
|
||||
(gc)
|
||||
(and (hashq-ref x test-key)
|
||||
(hashq-ref y test-key)
|
||||
(hashq-ref z test-key))))
|
||||
(pass-if "weak-key dies"
|
||||
(begin
|
||||
(hashq-set! x "this" "is")
|
||||
(hashq-set! x "a" "test")
|
||||
(hashq-set! x "of" "the")
|
||||
(hashq-set! x "emergency" "weak")
|
||||
(hashq-set! x "key" "hash system")
|
||||
(gc)
|
||||
(and
|
||||
(or (not (hashq-ref x "this"))
|
||||
(not (hashq-ref x "a"))
|
||||
(not (hashq-ref x "of"))
|
||||
(not (hashq-ref x "emergency"))
|
||||
(not (hashq-ref x "key")))
|
||||
(hashq-ref x test-key))))
|
||||
(let ((x (make-weak-vector 10 #f))
|
||||
(bar "bar"))
|
||||
(with-test-prefix
|
||||
"weak-vector"
|
||||
(pass-if "lives"
|
||||
(begin
|
||||
(vector-set! x 0 bar)
|
||||
(gc)
|
||||
(and (vector-ref x 0) (eq? bar (vector-ref x 0)))))
|
||||
(pass-if "dies"
|
||||
(begin
|
||||
(gc)
|
||||
(or (not (vector-ref global-weak 0))
|
||||
(not (vector-ref global-weak 1))
|
||||
(not (vector-ref global-weak 2))
|
||||
(not (vector-ref global-weak 3))
|
||||
(not (vector-ref global-weak 4)))))))
|
||||
|
||||
(pass-if "weak-value dies"
|
||||
(begin
|
||||
(hashq-set! y "this" "is")
|
||||
(hashq-set! y "a" "test")
|
||||
(hashq-set! y "of" "the")
|
||||
(hashq-set! y "emergency" "weak")
|
||||
(hashq-set! y "value" "hash system")
|
||||
(gc)
|
||||
(and (or (not (hashq-ref y "this"))
|
||||
(not (hashq-ref y "a"))
|
||||
(not (hashq-ref y "of"))
|
||||
(not (hashq-ref y "emergency"))
|
||||
(not (hashq-ref y "value")))
|
||||
(hashq-ref y test-key))))
|
||||
(pass-if "doubly-weak dies"
|
||||
(begin
|
||||
(hashq-set! z "this" "is")
|
||||
(hashq-set! z "a" "test")
|
||||
(hashq-set! z "of" "the")
|
||||
(hashq-set! z "emergency" "weak")
|
||||
(hashq-set! z "all" "hash system")
|
||||
(gc)
|
||||
(and (or (not (hashq-ref z "this"))
|
||||
(not (hashq-ref z "a"))
|
||||
(not (hashq-ref z "of"))
|
||||
(not (hashq-ref z "emergency"))
|
||||
(not (hashq-ref z "all")))
|
||||
(hashq-ref z test-key)))))))
|
||||
(let ((x (make-weak-key-hash-table 17))
|
||||
(y (make-weak-value-hash-table 17))
|
||||
(z (make-doubly-weak-hash-table 17))
|
||||
(test-key "foo")
|
||||
(test-value "bar"))
|
||||
(with-test-prefix
|
||||
"weak-hash"
|
||||
(pass-if "lives"
|
||||
(begin
|
||||
(hashq-set! x test-key test-value)
|
||||
(hashq-set! y test-key test-value)
|
||||
(hashq-set! z test-key test-value)
|
||||
(gc)
|
||||
(gc)
|
||||
(and (hashq-ref x test-key)
|
||||
(hashq-ref y test-key)
|
||||
(hashq-ref z test-key))))
|
||||
(pass-if "weak-key dies"
|
||||
(begin
|
||||
(hashq-set! x "this" "is")
|
||||
(hashq-set! x "a" "test")
|
||||
(hashq-set! x "of" "the")
|
||||
(hashq-set! x "emergency" "weak")
|
||||
(hashq-set! x "key" "hash system")
|
||||
(gc)
|
||||
(and
|
||||
(or (not (hashq-ref x "this"))
|
||||
(not (hashq-ref x "a"))
|
||||
(not (hashq-ref x "of"))
|
||||
(not (hashq-ref x "emergency"))
|
||||
(not (hashq-ref x "key")))
|
||||
(hashq-ref x test-key))))
|
||||
|
||||
(pass-if "weak-value dies"
|
||||
(begin
|
||||
(hashq-set! y "this" "is")
|
||||
(hashq-set! y "a" "test")
|
||||
(hashq-set! y "of" "the")
|
||||
(hashq-set! y "emergency" "weak")
|
||||
(hashq-set! y "value" "hash system")
|
||||
(gc)
|
||||
(and (or (not (hashq-ref y "this"))
|
||||
(not (hashq-ref y "a"))
|
||||
(not (hashq-ref y "of"))
|
||||
(not (hashq-ref y "emergency"))
|
||||
(not (hashq-ref y "value")))
|
||||
(hashq-ref y test-key))))
|
||||
(pass-if "doubly-weak dies"
|
||||
(begin
|
||||
(hashq-set! z "this" "is")
|
||||
(hashq-set! z "a" "test")
|
||||
(hashq-set! z "of" "the")
|
||||
(hashq-set! z "emergency" "weak")
|
||||
(hashq-set! z "all" "hash system")
|
||||
(gc)
|
||||
(and (or (not (hashq-ref z "this"))
|
||||
(not (hashq-ref z "a"))
|
||||
(not (hashq-ref z "of"))
|
||||
(not (hashq-ref z "emergency"))
|
||||
(not (hashq-ref z "all")))
|
||||
(hashq-ref z test-key))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue