mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

Adopted a couple of nice ideas from Greg.

Browse source
This commit is contained in:
Dirk Herrmann 2000-05-08 17:42:03 +00:00
parent 1a45015332
commit 57e7f27001
7 changed files with 936 additions and 909 deletions
Download patch file Download diff file Expand all files Collapse all files

22
test-suite/ChangeLog
View file

@ -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> 2000-05-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
* mambo.test: Removed dummy file. * mambo.test: Removed dummy file.

3
test-suite/guile-test
View file

@ -144,8 +144,7 @@
;; Run the tests. ;; Run the tests.
(for-each (lambda (test) (for-each (lambda (test)
(with-test-prefix test (with-test-prefix test
(catch-test-errors (load (test-file-name test))))
(load (test-file-name test)))))
tests) tests)
;; Display the final counts, both to the user and in the log ;; Display the final counts, both to the user and in the log

418
test-suite/lib.scm
View file

@ -1,5 +1,5 @@
;;;; test-suite/lib.scm --- generic support for testing ;;;; 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 ;;;; 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 ;;;; it under the terms of the GNU General Public License as published by
@ -22,13 +22,7 @@
(export (export
;; Reporting passes and failures. ;; Reporting passes and failures.
pass fail pass-if run-test pass-if expect-fail
;; 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*
;; Naming groups of tests in a regular fashion. ;; Naming groups of tests in a regular fashion.
with-test-prefix with-test-prefix* current-test-prefix with-test-prefix with-test-prefix* current-test-prefix
@ -49,9 +43,45 @@
;;;; If you're using Emacs's Scheme mode: ;;;; If you're using Emacs's Scheme mode:
;;;; (put 'expect-failure 'scheme-indent-function 0)
;;;; (put 'with-test-prefix 'scheme-indent-function 1) ;;;; (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 ;;;; TEST NAMES
;;;; ;;;;
@ -69,12 +99,9 @@
;;;; - Test names can be reliably stored and retrieved with the standard WRITE ;;;; - Test names can be reliably stored and retrieved with the standard WRITE
;;;; and READ procedures; doing so preserves their identity. ;;;; 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: ;;;; For example:
;;;; ;;;;
;;;; (if (= 4 (+ 2 2)) ;;;; (pass-if "simple addition" (= 4 (+ 2 2)))
;;;; (pass "simple addition"))
;;;; ;;;;
;;;; In that case, the test name is the list ("simple addition"). ;;;; In that case, the test name is the list ("simple addition").
;;;; ;;;;
@ -126,21 +153,37 @@
;;;; REPORTERS ;;;; REPORTERS
;;;;
;;;; A reporter is a function which we apply to each test outcome. ;;;; A reporter is a function which we apply to each test outcome.
;;;; Reporters can log results, print interesting results to the ;;;; Reporters can log results, print interesting results to the
;;;; standard output, collect statistics, etc. ;;;; 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: ;;;; is ignored. RESULT has one of the following forms:
;;;; ;;;;
;;;; (pass TEST) - The test named TEST passed. ;;;; pass - The test named TEST passed.
;;;; (fail TEST) - The test named TEST failed. ;;;; Additional arguments are ignored.
;;;; (xpass TEST) - The test named TEST passed unexpectedly. ;;;; upass - The test named TEST passed unexpectedly.
;;;; (xfail TEST) - The test named TEST failed, as expected. ;;;; Additional arguments are ignored.
;;;; (error PREFIX) - An error occurred, with TEST as the current ;;;; fail - The test named TEST failed.
;;;; test name prefix. Some tests were ;;;; Additional arguments are ignored.
;;;; probably not executed because of this. ;;;; 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 ;;;; This library provides some standard reporters for logging results
;;;; to a file, reporting interesting results to the user, and ;;;; to a file, reporting interesting results to the user, and
@ -152,12 +195,87 @@
;;;; all results to the standard output. ;;;; all results to the standard output.
;;;; with-test-prefix: naming groups of tests ;;;; MISCELLANEOUS
;;;; See the discussion of TEST NAMES, above. ;;;;
;;; 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. ;;; A fluid containing the current test prefix, as a list.
(define prefix-fluid (make-fluid)) (define prefix-fluid (make-fluid))
(fluid-set! prefix-fluid '()) (fluid-set! prefix-fluid '())
(define (current-test-prefix)
(fluid-ref prefix-fluid))
;;; Postpend PREFIX to the current name prefix while evaluting THUNK. ;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
;;; The name prefix is only changed within the dynamic scope of the ;;; The name prefix is only changed within the dynamic scope of the
@ -175,11 +293,9 @@
(defmacro with-test-prefix (prefix . body) (defmacro with-test-prefix (prefix . body)
`(with-test-prefix* ,prefix (lambda () ,@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. ;;; The global list of reporters.
(define reporters '()) (define reporters '())
@ -205,16 +321,51 @@
(define (reporter-registered? reporter) (define (reporter-registered? reporter)
(if (memq reporter reporters) #t #f)) (if (memq reporter reporters) #t #f))
;;; Send RESULT to all currently registered reporter functions. ;;; Send RESULT to all currently registered reporter functions.
(define (report result) (define (report . args)
(if (pair? reporters) (if (pair? reporters)
(for-each (lambda (reporter) (reporter result)) (for-each (lambda (reporter) (apply reporter args))
reporters) 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: ;;; Return a list of the form (COUNTER RESULTS), where:
;;; - COUNTER is a reporter procedure, and ;;; - COUNTER is a reporter procedure, and
@ -222,194 +373,57 @@
;;; results seen so far by COUNTER. The return value is an alist ;;; results seen so far by COUNTER. The return value is an alist
;;; mapping outcome symbols (`pass', `fail', etc.) onto counts. ;;; mapping outcome symbols (`pass', `fail', etc.) onto counts.
(define (make-count-reporter) (define (make-count-reporter)
(let ((counts (map (lambda (outcome) (cons outcome 0)) (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
'(pass fail xpass xfail error))))
(list (list
(lambda (result) (lambda (result name . args)
(let ((pair (assq (car result) counts))) (let ((pair (assq result counts)))
(if pair (set-cdr! pair (+ 1 (cdr pair))) (if pair
(error "count-reporter: unexpected test result: " result)))) (set-cdr! pair (+ 1 (cdr pair)))
(error "count-reporter: unexpected test result: "
(cons result (cons name args))))))
(lambda () (lambda ()
(append counts '()))))) (append counts '())))))
;;; Print a count reporter's results nicely. Pass this function the value ;;; Print a count reporter's results nicely. Pass this function the value
;;; returned by a count reporter's RESULTS procedure. ;;; returned by a count reporter's RESULTS procedure.
(define print-counts (define (print-counts results . port?)
(let ((tags '(pass fail xpass xfail error)) (let ((port (if (pair? port?)
(labels (car port?)
'("passes: " (current-output-port))))
"failures: " (newline port)
"unexpected passes: " (display-line-port port "Totals for this test run:")
"expected failures: " (for-each
"errors: "))) (lambda (tag)
(lambda (results . port?) (let ((result (assq (car tag) results)))
(let ((port (if (pair? port?) (if result
(car port?) (display-line-port port (caddr tag) (cdr result))
(current-output-port)))) (display-line-port port
(newline port) "Test suite bug: "
(display-line-port port "Totals for this test run:") "no total available for `" (car tag) "'"))))
(for-each result-tags)
(lambda (tag label) (newline port)))
(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))))))))
;;; Return a reporter procedure which prints all results to the file ;;; Return a reporter procedure which prints all results to the file
;;; FILE, in human-readable form. FILE may be a filename, or a port. ;;; FILE, in human-readable form. FILE may be a filename, or a port.
(define (make-log-reporter file) (define (make-log-reporter file)
(let ((port (if (output-port? file) file (let ((port (if (output-port? file) file
(open-output-file file)))) (open-output-file file))))
(lambda (result) (lambda args
(display (car result) port) (apply print-result port args)
(display ": " port)
(display (format-test-name (cadr result)) port)
(newline port)
(force-output port)))) (force-output port))))
;;; A reporter that reports all results to the user. ;;; A reporter that reports all results to the user.
(define (full-reporter result) (define (full-reporter . args)
(let ((label (case (car result) (apply print-result (current-output-port) args))
((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))))
;;; A reporter procedure which shows interesting results (failures, ;;; A reporter procedure which shows interesting results (failures,
;;; unexpected passes) to the user. ;;; unexpected passes etc.) to the user.
(define (user-reporter result) (define (user-reporter result name . args)
(case (car result) (if (memq result important-result-tags)
((fail xpass) (full-reporter result)))) (apply full-reporter result name args)))
(set! default-reporter full-reporter) (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 ;;;; Helping test cases find their files
@ -446,5 +460,3 @@
(catch key (catch key
(lambda () (thunk) #f) (lambda () (thunk) #f)
(lambda args #t))) (lambda args #t)))

449
test-suite/tests/alist.test
View file

@ -70,232 +70,247 @@
(if x (cdr x) x))) (if x (cdr x) x)))
;;; Creators, getters ;;; Creators, getters
(catch-test-errors (let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f ()))))
(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f ())))) (b (acons "this" "is" (acons "a" "test" ())))
(b (acons "this" "is" (acons "a" "test" ()))) (deformed '(a b c d e f g)))
(deformed '(a b c d e f g))) (pass-if "alist: acons"
(pass-if "alist: acons" (and (equal? a '((a . b) (c . d) (e . f)))
(and (equal? a '((a . b) (c . d) (e . f))) (equal? b '(("this" . "is") ("a" . "test")))))
(equal? b '(("this" . "is") ("a" . "test"))))) (pass-if "alist: sloppy-assq"
(pass-if "alist: sloppy-assq" (let ((x (sloppy-assq 'c a)))
(let ((x (sloppy-assq 'c a))) (and (pair? x)
(and (pair? x) (eq? (car x) 'c)
(eq? (car x) 'c) (eq? (cdr x) 'd))))
(eq? (cdr x) 'd)))) (pass-if "alist: sloppy-assq not"
(pass-if "alist: sloppy-assq not" (let ((x (sloppy-assq "this" b)))
(let ((x (sloppy-assq "this" b))) (not x)))
(not x))) (pass-if "alist: sloppy-assv"
(pass-if "alist: sloppy-assv" (let ((x (sloppy-assv 'c a)))
(let ((x (sloppy-assv 'c a))) (and (pair? x)
(and (pair? x) (eq? (car x) 'c)
(eq? (car x) 'c) (eq? (cdr x) 'd))))
(eq? (cdr x) 'd)))) (pass-if "alist: sloppy-assv not"
(pass-if "alist: sloppy-assv not" (let ((x (sloppy-assv "this" b)))
(let ((x (sloppy-assv "this" b))) (not x)))
(not x))) (pass-if "alist: sloppy-assoc"
(pass-if "alist: sloppy-assoc" (let ((x (sloppy-assoc "this" b)))
(let ((x (sloppy-assoc "this" b))) (and (pair? x)
(and (pair? x) (string=? (cdr x) "is"))))
(string=? (cdr x) "is")))) (pass-if "alist: sloppy-assoc not"
(pass-if "alist: sloppy-assoc not" (let ((x (sloppy-assoc "heehee" b)))
(let ((x (sloppy-assoc "heehee" b))) (not x)))
(not x))) (pass-if "alist: assq"
(pass-if "alist: assq" (let ((x (assq 'c a)))
(let ((x (assq 'c a))) (and (pair? x)
(and (pair? x) (eq? (car x) 'c)
(eq? (car x) 'c) (eq? (cdr x) 'd))))
(eq? (cdr x) 'd)))) (pass-if "alist: assq deformed"
(pass-if "alist: assq deformed" (catch 'wrong-type-arg
(catch 'wrong-type-arg (lambda ()
(lambda () (assq 'x deformed))
(assq 'x deformed)) (lambda (key . args)
(lambda (key . args) #t)))
#t))) (pass-if-not "alist: assq not" (assq 'r a))
(pass-if-not "alist: assq not" (assq 'r a)) (pass-if "alist: assv"
(pass-if "alist: assv" (let ((x (assv 'a a)))
(let ((x (assv 'a a))) (and (pair? x)
(and (pair? x) (eq? (car x) 'a)
(eq? (car x) 'a) (eq? (cdr x) 'b))))
(eq? (cdr x) 'b)))) (pass-if "alist: assv deformed"
(pass-if "alist: assv deformed" (catch 'wrong-type-arg
(catch 'wrong-type-arg (lambda ()
(lambda () (assv 'x deformed)
(assv 'x deformed) #f)
#f) (lambda (key . args)
(lambda (key . args) #t)))
#t))) (pass-if-not "alist: assv not" (assq "this" b))
(pass-if-not "alist: assv not" (assq "this" b))
(pass-if "alist: assoc" (pass-if "alist: assoc"
(let ((x (assoc "this" b))) (let ((x (assoc "this" b)))
(and (pair? x) (and (pair? x)
(string=? (car x) "this") (string=? (car x) "this")
(string=? (cdr x) "is")))) (string=? (cdr x) "is"))))
(pass-if "alist: assoc deformed" (pass-if "alist: assoc deformed"
(catch 'wrong-type-arg (catch 'wrong-type-arg
(lambda () (lambda ()
(assoc 'x deformed) (assoc 'x deformed)
#f) #f)
(lambda (key . args) (lambda (key . args)
#t))) #t)))
(pass-if-not "alist: assoc not" (assoc "this isn't" b)))) (pass-if-not "alist: assoc not" (assoc "this isn't" b)))
;;; Refers ;;; Refers
(catch-test-errors (let ((a '((foo bar) (baz quux)))
(let ((a '((foo bar) (baz quux))) (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
(b '(("one" 2 3) ("four" 5 6) ("seven" 8 9))) (deformed '(thats a real sloppy assq you got there)))
(deformed '(thats a real sloppy assq you got there))) (pass-if "alist: assq-ref"
(pass-if "alist: assq-ref" (let ((x (assq-ref a 'foo)))
(let ((x (assq-ref a 'foo))) (and (list? x)
(and (list? x) (eq? (car x) 'bar))))
(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"))
(pass-if "alist: assoc-ref" (pass-if-not "alist: assq-ref not" (assq-ref b "one"))
(let ((x (assoc-ref b "one"))) (pass-if "alist: assv-ref"
(and (list? x) (let ((x (assv-ref a 'baz)))
(eq? (car x) 2) (and (list? x)
(eq? (cadr x) 3)))) (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 ;;; Setters
(catch-test-errors (let ((a '((another . silly) (alist . test-case)))
(let ((a '((another . silly) (alist . test-case))) (b '(("this" "one" "has") ("strings" "!")))
(b '(("this" "one" "has") ("strings" "!"))) (deformed '(canada is a cold nation)))
(deformed '(canada is a cold nation))) (pass-if "alist: assq-set!"
(pass-if "alist: assq-set!" (begin
(begin (set! a (assq-set! a 'another 'stupid))
(set! a (assq-set! a 'another 'stupid)) (let ((x (safe-assq-ref a 'another)))
(let ((x (safe-assq-ref a 'another))) (and x
(and x (symbol? x) (eq? x 'stupid)))))
(symbol? x) (eq? x 'stupid)))))
(pass-if "alist: assq-set! add" (pass-if "alist: assq-set! add"
(begin (begin
(set! a (assq-set! a 'fickle 'pickle)) (set! a (assq-set! a 'fickle 'pickle))
(let ((x (safe-assq-ref a 'fickle))) (let ((x (safe-assq-ref a 'fickle)))
(and x (symbol? x) (and x (symbol? x)
(eq? x 'pickle))))) (eq? x 'pickle)))))
(pass-if "alist: assv-set!" (pass-if "alist: assv-set!"
(begin (begin
(set! a (assv-set! a 'another 'boring)) (set! a (assv-set! a 'another 'boring))
(let ((x (safe-assv-ref a 'another))) (let ((x (safe-assv-ref a 'another)))
(and x (and x
(eq? x 'boring))))) (eq? x 'boring)))))
(pass-if "alist: assv-set! add" (pass-if "alist: assv-set! add"
(begin (begin
(set! a (assv-set! a 'whistle '(while you work))) (set! a (assv-set! a 'whistle '(while you work)))
(let ((x (safe-assv-ref a 'whistle))) (let ((x (safe-assv-ref a 'whistle)))
(and x (equal? x '(while you work)))))) (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 ;;; Removers
(catch-test-errors (let ((a '((a b) (c d) (e boring)))
(let ((a '((a b) (c d) (e boring))) (b '(("what" . "else") ("could" . "I") ("say" . "here")))
(b '(("what" . "else") ("could" . "I") ("say" . "here"))) (deformed 1))
(deformed 1)) (pass-if "alist: assq-remove!"
(pass-if "alist: assq-remove!" (begin
(begin (set! a (assq-remove! a 'a))
(set! a (assq-remove! a 'a)) (equal? a '((c d) (e boring)))))
(equal? a '((c d) (e boring))))) (pass-if "alist: assv-remove!"
(pass-if "alist: assv-remove!" (begin
(begin (set! a (assv-remove! a 'c))
(set! a (assv-remove! a 'c)) (equal? a '((e boring)))))
(equal? a '((e boring))))) (pass-if "alist: assoc-remove!"
(pass-if "alist: assoc-remove!" (begin
(begin (set! b (assoc-remove! b "what"))
(set! b (assoc-remove! b "what")) (equal? b '(("could" . "I") ("say" . "here")))))
(equal? b '(("could" . "I") ("say" . "here")))))
(expect-failure-if (not (defined? 'sloppy-assq-remove!)) (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove)))
(pass-if "alist: assq-remove! deformed"
(catch 'wrong-type-arg (pass-if "alist: assq-remove! deformed"
(lambda () (catch 'wrong-type-arg
(assq-remove! deformed 'puddle) (lambda ()
#f) (if (not have-sloppy-assq-remove?) (throw 'unsupported))
(lambda (key . args) (assq-remove! deformed 'puddle)
#t))) #f)
(pass-if "alist: assv-remove! deformed" (lambda (key . args)
(catch 'wrong-type-arg #t)))
(lambda ()
(assv-remove! deformed 'splashing) (pass-if "alist: assv-remove! deformed"
#f) (catch 'wrong-type-arg
(lambda (key . args) (lambda ()
#t))) (if (not have-sloppy-assq-remove?) (throw 'unsupported))
(pass-if "alist: assoc-remove! deformed" (assv-remove! deformed 'splashing)
(catch 'wrong-type-arg #f)
(lambda () (lambda (key . args)
(assoc-remove! deformed 'fun) #t)))
#f)
(lambda (key . args) (pass-if "alist: assoc-remove! deformed"
#t)))))) (catch 'wrong-type-arg
(lambda ()
(if (not have-sloppy-assq-remove?) (throw 'unsupported))
(assoc-remove! deformed 'fun)
#f)
(lambda (key . args)
#t)))))

211
test-suite/tests/hooks.test
View file

@ -70,114 +70,113 @@
`(pass-if ,string (not ,form))) `(pass-if ,string (not ,form)))
;; {The tests} ;; {The tests}
(catch-test-errors
(let ((proc1 (lambda (x) (+ x 1))) (let ((proc1 (lambda (x) (+ x 1)))
(proc2 (lambda (x) (- x 1))) (proc2 (lambda (x) (- x 1)))
(bad-proc (lambda (x y) #t))) (bad-proc (lambda (x y) #t)))
(with-test-prefix "hooks" (with-test-prefix "hooks"
(pass-if "make-hook" (pass-if "make-hook"
(catch-error-returning-false (catch-error-returning-false
#t #t
(define x (make-hook 1)))) (define x (make-hook 1))))
(pass-if "add-hook!" (pass-if "add-hook!"
(catch-error-returning-false (catch-error-returning-false
#t #t
(let ((x (make-hook 1))) (let ((x (make-hook 1)))
(add-hook! x proc1) (add-hook! x proc1)
(add-hook! x proc2)))) (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 (with-test-prefix "add-hook!"
"destructive procs" (pass-if "append"
(let ((x (make-hook 1)) (let ((x (make-hook 1)))
(dest-proc1 (lambda (x) (add-hook! x proc1)
(set-car! x (add-hook! x proc2 #t)
'i-sunk-your-battleship))) (eq? (cadr (hook->list x))
(dest-proc2 (lambda (x) (set-cdr! x 'no-way!))) proc2)))
(val '(a-game-of battleship))) (pass-if "illegal proc"
(add-hook! x dest-proc1) (catch-error-returning-true
(add-hook! x dest-proc2 #t) #t
(run-hook x val) (let ((x (make-hook 1)))
(and (eq? (car val) 'i-sunk-your-battleship) (add-hook! x bad-proc))))
(eq? (cdr val) 'no-way!))))) (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" (pass-if
(catch-error-returning-false "destructive procs"
#t (let ((x (make-hook 1))
(let ((x (make-hook-with-name 'x 1))) (dest-proc1 (lambda (x)
(add-hook! x proc1)))) (set-car! x
(pass-if "make-hook-with-name: bad name" 'i-sunk-your-battleship)))
(catch-error-returning-true (dest-proc2 (lambda (x) (set-cdr! x 'no-way!)))
'wrong-type-arg (val '(a-game-of battleship)))
(define x (make-hook-with-name '(a b) 1)))) (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 "make-hook-with-name"
(pass-if "" (catch-error-returning-false
(let ((x (make-hook 1))) #t
(add-hook! x proc1) (let ((x (make-hook-with-name 'x 1)))
(add-hook! x proc2) (add-hook! x proc1))))
(remove-hook! x proc1) (pass-if "make-hook-with-name: bad name"
(not (memq proc1 (hook->list x))))) (catch-error-returning-true
; Maybe it should error, but this is probably 'wrong-type-arg
; more convienient (define x (make-hook-with-name '(a b) 1))))
(pass-if "empty hook"
(catch-error-returning-false (with-test-prefix "remove-hook!"
#t (pass-if ""
(let ((x (make-hook 1))) (let ((x (make-hook 1)))
(remove-hook! x proc1))))) (add-hook! x proc1)
(pass-if "hook->list" (add-hook! x proc2)
(let ((x (make-hook 1))) (remove-hook! x proc1)
(add-hook! x proc1) (not (memq proc1 (hook->list x)))))
(add-hook! x proc2) ; Maybe it should error, but this is probably
(and (memq proc1 (hook->list x) ) ; more convienient
(memq proc2 (hook->list x))))) (pass-if "empty hook"
(pass-if "reset-hook!" (catch-error-returning-false
(let ((x (make-hook 1))) #t
(add-hook! x proc1) (let ((x (make-hook 1)))
(add-hook! x proc2) (remove-hook! x proc1)))))
(reset-hook! x) (pass-if "hook->list"
(null? (hook->list x)))) (let ((x (make-hook 1)))
(with-test-prefix "reset-hook!" (add-hook! x proc1)
(pass-if "empty hook" (add-hook! x proc2)
(let ((x (make-hook 1))) (and (memq proc1 (hook->list x) )
(reset-hook! x))) (memq proc2 (hook->list x)))))
(pass-if "bad hook" (pass-if "reset-hook!"
(catch-error-returning-true (let ((x (make-hook 1)))
#t (add-hook! x proc1)
(reset-hook! '(a b)))))))) (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)))))))

469
test-suite/tests/ports.test
View file

@ -49,188 +49,177 @@
;;;; Normal file ports. ;;;; Normal file ports.
;;; Write out an s-expression, and read it back. ;;; Write out an s-expression, and read it back.
(catch-test-errors (let ((string '("From fairest creatures we desire increase,"
(let ((string '("From fairest creatures we desire increase," "That thereby beauty's rose might never die,"))
"That thereby beauty's rose might never die,")) (filename (test-file)))
(filename (test-file))) (let ((port (open-output-file filename)))
(let ((port (open-output-file filename))) (write string port)
(write string port) (close-port port))
(close-port port)) (let ((port (open-input-file filename)))
(let ((port (open-input-file filename))) (let ((in-string (read port)))
(let ((in-string (read port))) (pass-if "file: write and read back list of strings"
(pass-if "file: write and read back list of strings" (equal? string in-string)))
(equal? string in-string))) (close-port port))
(close-port port)) (delete-file filename))
(delete-file filename)))
;;; Write out a string, and read it back a character at a time. ;;; 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")
(let ((string "This is a test string\nwith no newline at the end") (filename (test-file)))
(filename (test-file))) (let ((port (open-output-file filename)))
(let ((port (open-output-file filename))) (display string port)
(display string port) (close-port port))
(close-port port)) (let ((in-string (read-file filename)))
(let ((in-string (read-file filename))) (pass-if "file: write and read back characters"
(pass-if "file: write and read back characters" (equal? string in-string)))
(equal? string in-string))) (delete-file filename))
(delete-file filename)))
;;; Buffered input/output port with seeking. ;;; Buffered input/output port with seeking.
(catch-test-errors (let* ((filename (test-file))
(let* ((filename (test-file)) (port (open-file filename "w+")))
(port (open-file filename "w+"))) (display "J'Accuse" port)
(display "J'Accuse" port) (seek port -1 SEEK_CUR)
(seek port -1 SEEK_CUR) (pass-if "file: r/w 1"
(pass-if "file: r/w 1" (char=? (read-char port) #\e))
(char=? (read-char port) #\e)) (pass-if "file: r/w 2"
(pass-if "file: r/w 2" (eof-object? (read-char port)))
(eof-object? (read-char port))) (seek port -1 SEEK_CUR)
(seek port -1 SEEK_CUR) (write-char #\x port)
(write-char #\x port) (seek port 7 SEEK_SET)
(seek port 7 SEEK_SET) (pass-if "file: r/w 3"
(pass-if "file: r/w 3" (char=? (read-char port) #\x))
(char=? (read-char port) #\x)) (seek port -2 SEEK_END)
(seek port -2 SEEK_END) (pass-if "file: r/w 4"
(pass-if "file: r/w 4" (char=? (read-char port) #\s))
(char=? (read-char port) #\s)) (delete-file filename))
(delete-file filename)))
;;; Unbuffered input/output port with seeking. ;;; Unbuffered input/output port with seeking.
(catch-test-errors (let* ((filename (test-file))
(let* ((filename (test-file)) (port (open-file filename "w+0")))
(port (open-file filename "w+0"))) (display "J'Accuse" port)
(display "J'Accuse" port) (seek port -1 SEEK_CUR)
(seek port -1 SEEK_CUR) (pass-if "file: ub r/w 1"
(pass-if "file: ub r/w 1" (char=? (read-char port) #\e))
(char=? (read-char port) #\e)) (pass-if "file: ub r/w 2"
(pass-if "file: ub r/w 2" (eof-object? (read-char port)))
(eof-object? (read-char port))) (seek port -1 SEEK_CUR)
(seek port -1 SEEK_CUR) (write-char #\x port)
(write-char #\x port) (seek port 7 SEEK_SET)
(seek port 7 SEEK_SET) (pass-if "file: ub r/w 3"
(pass-if "file: ub r/w 3" (char=? (read-char port) #\x))
(char=? (read-char port) #\x)) (seek port -2 SEEK_END)
(seek port -2 SEEK_END) (pass-if "file: ub r/w 4"
(pass-if "file: ub r/w 4" (char=? (read-char port) #\s))
(char=? (read-char port) #\s)) (delete-file filename))
(delete-file filename)))
;;; Buffered output-only and input-only ports with seeking. ;;; Buffered output-only and input-only ports with seeking.
(catch-test-errors (let* ((filename (test-file))
(let* ((filename (test-file)) (port (open-output-file filename)))
(port (open-output-file filename))) (display "J'Accuse" port)
(display "J'Accuse" port) (pass-if "file: out tell"
(pass-if "file: out tell" (= (seek port 0 SEEK_CUR) 8))
(= (seek port 0 SEEK_CUR) 8)) (seek port -1 SEEK_CUR)
(seek port -1 SEEK_CUR) (write-char #\x port)
(write-char #\x port) (close-port port)
(close-port port) (let ((iport (open-input-file filename)))
(let ((iport (open-input-file filename))) (pass-if "file: in tell 0"
(pass-if "file: in tell 0" (= (seek iport 0 SEEK_CUR) 0))
(= (seek iport 0 SEEK_CUR) 0)) (read-char iport)
(read-char iport) (pass-if "file: in tell 1"
(pass-if "file: in tell 1" (= (seek iport 0 SEEK_CUR) 1))
(= (seek iport 0 SEEK_CUR) 1)) (unread-char #\z iport)
(unread-char #\z iport) (pass-if "file: in tell 0 after unread"
(pass-if "file: in tell 0 after unread" (= (seek iport 0 SEEK_CUR) 0))
(= (seek iport 0 SEEK_CUR) 0)) (pass-if "file: unread char still there"
(pass-if "file: unread char still there" (char=? (read-char iport) #\z))
(char=? (read-char iport) #\z)) (seek iport 7 SEEK_SET)
(seek iport 7 SEEK_SET) (pass-if "file: in last char"
(pass-if "file: in last char" (char=? (read-char iport) #\x))
(char=? (read-char iport) #\x)) (close-port iport))
(close-port iport)) (delete-file filename))
(delete-file filename)))
;;; unusual characters. ;;; unusual characters.
(catch-test-errors (let* ((filename (test-file))
(let* ((filename (test-file)) (port (open-output-file filename)))
(port (open-output-file filename))) (display (string #\nul (integer->char 255) (integer->char 128)
(display (string #\nul (integer->char 255) (integer->char 128) #\nul) port)
#\nul) port) (close-port port)
(close-port port) (let* ((port (open-input-file filename))
(let* ((port (open-input-file filename)) (line (read-line port)))
(line (read-line port))) (pass-if "file: read back NUL 1"
(pass-if "file: read back NUL 1" (char=? (string-ref line 0) #\nul))
(char=? (string-ref line 0) #\nul)) (pass-if "file: read back 255"
(pass-if "file: read back 255" (char=? (string-ref line 1) (integer->char 255)))
(char=? (string-ref line 1) (integer->char 255))) (pass-if "file: read back 128"
(pass-if "file: read back 128" (char=? (string-ref line 2) (integer->char 128)))
(char=? (string-ref line 2) (integer->char 128))) (pass-if "file: read back NUL 2"
(pass-if "file: read back NUL 2" (char=? (string-ref line 3) #\nul))
(char=? (string-ref line 3) #\nul)) (pass-if "file: EOF"
(pass-if "file: EOF" (eof-object? (read-char port))))
(eof-object? (read-char port)))) (delete-file filename))
(delete-file filename)))
;;; line buffering mode. ;;; line buffering mode.
(catch-test-errors (let* ((filename (test-file))
(let* ((filename (test-file)) (port (open-file filename "wl"))
(port (open-file filename "wl")) (test-string "one line more or less"))
(test-string "one line more or less")) (write-line test-string port)
(write-line test-string port) (let* ((in-port (open-input-file filename))
(let* ((in-port (open-input-file filename)) (line (read-line in-port)))
(line (read-line in-port))) (close-port in-port)
(close-port in-port) (close-port port)
(close-port port) (pass-if "file: line buffering"
(pass-if "file: line buffering" (string=? line test-string)))
(string=? line test-string))) (delete-file filename))
(delete-file filename)))
;;; ungetting characters and strings. ;;; ungetting characters and strings.
(catch-test-errors (with-input-from-string "walk on the moon\nmoon"
(with-input-from-string "walk on the moon\nmoon" (lambda ()
(lambda () (read-char)
(read-char) (unread-char #\a (current-input-port))
(unread-char #\a (current-input-port)) (pass-if "unread-char"
(pass-if "unread-char" (char=? (read-char) #\a))
(char=? (read-char) #\a)) (read-line)
(read-line) (let ((replacenoid "chicken enchilada"))
(let ((replacenoid "chicken enchilada")) (unread-char #\newline (current-input-port))
(unread-char #\newline (current-input-port)) (unread-string replacenoid (current-input-port))
(unread-string replacenoid (current-input-port)) (pass-if "unread-string"
(pass-if "unread-string" (string=? (read-line) replacenoid)))
(string=? (read-line) replacenoid))) (pass-if "unread residue"
(pass-if "unread residue" (string=? (read-line) "moon"))))
(string=? (read-line) "moon")))))
;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on ;;; 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 ;;; the reading end. try to read a byte: should get EAGAIN or
;;; EWOULDBLOCK error. ;;; EWOULDBLOCK error.
(catch-test-errors (let* ((p (pipe))
(let* ((p (pipe)) (r (car p)))
(r (car p))) (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
(fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK)) (pass-if "non-blocking-I/O"
(pass-if "non-blocking-I/O" (catch 'system-error
(catch 'system-error (lambda () (read-char r) #f)
(lambda () (read-char r) #f) (lambda (key . args)
(lambda (key . args) (and (eq? key 'system-error)
(and (eq? key 'system-error) (let ((errno (car (list-ref args 3))))
(let ((errno (car (list-ref args 3)))) (or (= errno EAGAIN)
(or (= errno EAGAIN) (= errno EWOULDBLOCK))))))))
(= errno EWOULDBLOCK)))))))))
;;;; Pipe (popen) ports. ;;;; Pipe (popen) ports.
;;; Run a command, and read its output. ;;; Run a command, and read its output.
(catch-test-errors (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
(let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r")) (in-string (read-all pipe)))
(in-string (read-all pipe))) (close-pipe pipe)
(close-pipe pipe) (pass-if "pipe: read"
(pass-if "pipe: read" (equal? in-string "Howdy there, partner!\n")))
(equal? in-string "Howdy there, partner!\n"))))
;;; Run a command, send some output to it, and see if it worked. ;;; Run a command, send some output to it, and see if it worked.
(catch-test-errors (let* ((filename (test-file))
(let* ((filename (test-file)) (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
(pipe (open-pipe (string-append "grep Mommy > " filename) "w"))) (display "Now Jimmy lives on a mushroom cloud\n" pipe)
(display "Now Jimmy lives on a mushroom cloud\n" pipe) (display "Mommy, why does everybody have a bomb?\n" pipe)
(display "Mommy, why does everybody have a bomb?\n" pipe) (close-pipe pipe)
(close-pipe pipe) (let ((in-string (read-file filename)))
(let ((in-string (read-file filename))) (pass-if "pipe: write"
(pass-if "pipe: write" (equal? in-string "Mommy, why does everybody have a bomb?\n")))
(equal? in-string "Mommy, why does everybody have a bomb?\n"))) (delete-file filename))
(delete-file filename)))
;;;; Void ports. These are so trivial we don't test them. ;;;; Void ports. These are so trivial we don't test them.
@ -241,75 +230,71 @@
(with-test-prefix "string ports" (with-test-prefix "string ports"
;; Write text to a string port. ;; Write text to a string port.
(catch-test-errors (let* ((string "Howdy there, partner!")
(let* ((string "Howdy there, partner!") (in-string (call-with-output-string
(in-string (call-with-output-string (lambda (port)
(lambda (port) (display string port)
(display string port) (newline port)))))
(newline port))))) (pass-if "display text"
(pass-if "display text" (equal? in-string (string-append string "\n"))))
(equal? in-string (string-append string "\n")))))
;; Write an s-expression to a string port. ;; Write an s-expression to a string port.
(catch-test-errors (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
(let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926)) (in-sexpr
(in-sexpr (call-with-input-string (call-with-output-string
(call-with-input-string (call-with-output-string (lambda (port)
(lambda (port) (write sexpr port)))
(write sexpr port))) read)))
read))) (pass-if "write/read sexpr"
(pass-if "write/read sexpr" (equal? in-sexpr sexpr)))
(equal? in-sexpr sexpr))))
;; seeking and unreading from an input string. ;; seeking and unreading from an input string.
(catch-test-errors (let ((text "that text didn't look random to me"))
(let ((text "that text didn't look random to me")) (call-with-input-string text
(call-with-input-string text (lambda (p)
(lambda (p) (pass-if "input tell 0"
(pass-if "input tell 0" (= (seek p 0 SEEK_CUR) 0))
(= (seek p 0 SEEK_CUR) 0)) (read-char p)
(read-char p) (pass-if "input tell 1"
(pass-if "input tell 1" (= (seek p 0 SEEK_CUR) 1))
(= (seek p 0 SEEK_CUR) 1)) (unread-char #\x p)
(unread-char #\x p) (pass-if "input tell back to 0"
(pass-if "input tell back to 0" (= (seek p 0 SEEK_CUR) 0))
(= (seek p 0 SEEK_CUR) 0)) (pass-if "input ungetted char"
(pass-if "input ungetted char" (char=? (read-char p) #\x))
(char=? (read-char p) #\x)) (seek p 0 SEEK_END)
(seek p 0 SEEK_END) (pass-if "input seek to end"
(pass-if "input seek to end" (= (seek p 0 SEEK_CUR)
(= (seek p 0 SEEK_CUR) (string-length text)))
(string-length text))) (unread-char #\x p)
(unread-char #\x p) (pass-if "input seek to beginning"
(pass-if "input seek to beginning" (= (seek p 0 SEEK_SET) 0))
(= (seek p 0 SEEK_SET) 0)) (pass-if "input reread first char"
(pass-if "input reread first char" (char=? (read-char p)
(char=? (read-char p) (string-ref text 0))))))
(string-ref text 0)))))))
;; seeking an output string. ;; seeking an output string.
(catch-test-errors (let* ((text "123456789")
(let* ((text "123456789") (len (string-length text))
(len (string-length text)) (result (call-with-output-string
(result (call-with-output-string (lambda (p)
(lambda (p) (pass-if "output tell 0"
(pass-if "output tell 0" (= (seek p 0 SEEK_CUR) 0))
(= (seek p 0 SEEK_CUR) 0)) (display text p)
(display text p) (pass-if "output tell end"
(pass-if "output tell end" (= (seek p 0 SEEK_CUR) len))
(= (seek p 0 SEEK_CUR) len)) (pass-if "output seek to beginning"
(pass-if "output seek to beginning" (= (seek p 0 SEEK_SET) 0))
(= (seek p 0 SEEK_SET) 0)) (write-char #\a p)
(write-char #\a p) (seek p -1 SEEK_END)
(seek p -1 SEEK_END) (pass-if "output seek to last char"
(pass-if "output seek to last char" (= (seek p 0 SEEK_CUR)
(= (seek p 0 SEEK_CUR) (- len 1)))
(- len 1))) (write-char #\b p)))))
(write-char #\b p))))) (string-set! text 0 #\a)
(string-set! text 0 #\a) (string-set! text (- len 1) #\b)
(string-set! text (- len 1) #\b) (pass-if "output check"
(pass-if "output check" (string=? text result))))
(string=? text result)))))
@ -372,28 +357,26 @@
(for-each close-port ports) (for-each close-port ports)
(delete-file port-loop-temp)))) (delete-file port-loop-temp))))
(catch-test-errors (with-test-prefix "newline"
(with-test-prefix "newline" (test-line-counter
(test-line-counter (string-append "x\n"
(string-append "x\n" "He who receives an idea from me, receives instruction\n"
"He who receives an idea from me, receives instruction\n" "himself without lessening mine; as he who lights his\n"
"himself without lessening mine; as he who lights his\n" "taper at mine, receives light without darkening me.\n"
"taper at mine, receives light without darkening me.\n" " --- Thomas Jefferson\n")
" --- Thomas Jefferson\n") "He who receives an idea from me, receives instruction"
"He who receives an idea from me, receives instruction" 0))
0)))
(catch-test-errors (with-test-prefix "no newline"
(with-test-prefix "no newline" (test-line-counter
(test-line-counter (string-append "x\n"
(string-append "x\n" "He who receives an idea from me, receives instruction\n"
"He who receives an idea from me, receives instruction\n" "himself without lessening mine; as he who lights his\n"
"himself without lessening mine; as he who lights his\n" "taper at mine, receives light without darkening me.\n"
"taper at mine, receives light without darkening me.\n" " --- Thomas Jefferson\n"
" --- Thomas Jefferson\n" "no newline here")
"no newline here") "He who receives an idea from me, receives instruction"
"He who receives an idea from me, receives instruction" 15)))
15))))
;;;; testing read-delimited and friends ;;;; testing read-delimited and friends

273
test-suite/tests/weaks.test
View file

@ -75,65 +75,64 @@
;;; Creation functions ;;; Creation functions
(catch-test-errors (with-test-prefix
(with-test-prefix "weak-creation"
"weak-creation" (with-test-prefix "make-weak-vector"
(with-test-prefix "make-weak-vector" (pass-if "normal"
(pass-if "normal" (catch-error-returning-false #t
(catch-error-returning-false #t (define x (make-weak-vector 10 #f))))
(define x (make-weak-vector 10 #f)))) (pass-if "bad size"
(pass-if "bad size" (catch-error-returning-true
(catch-error-returning-true 'wrong-type-arg
'wrong-type-arg (define x (make-weak-vector 'foo)))))
(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 "make-weak-key-hash-table" (with-test-prefix "list->weak-vector"
(pass-if "create" (pass-if "create"
(catch-error-returning-false (let* ((lst '(a b c d e f g))
#t (wv (list->weak-vector lst)))
(define x (make-weak-key-hash-table 17)))) (and (eq? (vector-ref wv 0) 'a)
(pass-if "bad-args" (eq? (vector-ref wv 1) 'b)
(catch-error-returning-true (eq? (vector-ref wv 2) 'c)
'wrong-type-arg (eq? (vector-ref wv 3) 'd)
(define x (eq? (vector-ref wv 4) 'e)
(make-weak-key-hash-table '(bad arg)))))) (eq? (vector-ref wv 5) 'f)
(with-test-prefix "make-weak-value-hash-table" (eq? (vector-ref wv 6) 'g))))
(pass-if "create" (pass-if "bad-args"
(catch-error-returning-false (catch-error-returning-true
#t 'wrong-type-arg
(define x (make-weak-value-hash-table 17)))) (define x (list->weak-vector 32)))))
(pass-if "bad-args"
(catch-error-returning-true (with-test-prefix "make-weak-key-hash-table"
'wrong-type-arg (pass-if "create"
(define x (catch-error-returning-false
(make-weak-value-hash-table '(bad arg)))))) #t
(define x (make-weak-key-hash-table 17))))
(with-test-prefix "make-doubly-weak-hash-table" (pass-if "bad-args"
(pass-if "create" (catch-error-returning-true
(catch-error-returning-false 'wrong-type-arg
#t (define x
(define x (make-doubly-weak-hash-table 17)))) (make-weak-key-hash-table '(bad arg))))))
(pass-if "bad-args" (with-test-prefix "make-weak-value-hash-table"
(catch-error-returning-true (pass-if "create"
'wrong-type-arg (catch-error-returning-false
(define x #t
(make-doubly-weak-hash-table '(bad arg)))))))) (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)) (gc))
;;; Normal weak vectors ;;; Normal weak vectors
(catch-test-errors (let ((x (make-weak-vector 10 #f))
(let ((x (make-weak-vector 10 #f)) (bar "bar"))
(bar "bar")) (with-test-prefix
(with-test-prefix "weak-vector"
"weak-vector" (pass-if "lives"
(pass-if "lives" (begin
(begin (vector-set! x 0 bar)
(vector-set! x 0 bar) (gc)
(gc) (and (vector-ref x 0) (eq? bar (vector-ref x 0)))))
(and (vector-ref x 0) (eq? bar (vector-ref x 0))))) (pass-if "dies"
(pass-if "dies" (begin
(begin (gc)
(gc) (or (not (vector-ref global-weak 0))
(or (not (vector-ref global-weak 0)) (not (vector-ref global-weak 1))
(not (vector-ref global-weak 1)) (not (vector-ref global-weak 2))
(not (vector-ref global-weak 2)) (not (vector-ref global-weak 3))
(not (vector-ref global-weak 3)) (not (vector-ref global-weak 4)))))))
(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))))
(pass-if "weak-value dies" (let ((x (make-weak-key-hash-table 17))
(begin (y (make-weak-value-hash-table 17))
(hashq-set! y "this" "is") (z (make-doubly-weak-hash-table 17))
(hashq-set! y "a" "test") (test-key "foo")
(hashq-set! y "of" "the") (test-value "bar"))
(hashq-set! y "emergency" "weak") (with-test-prefix
(hashq-set! y "value" "hash system") "weak-hash"
(gc) (pass-if "lives"
(and (or (not (hashq-ref y "this")) (begin
(not (hashq-ref y "a")) (hashq-set! x test-key test-value)
(not (hashq-ref y "of")) (hashq-set! y test-key test-value)
(not (hashq-ref y "emergency")) (hashq-set! z test-key test-value)
(not (hashq-ref y "value"))) (gc)
(hashq-ref y test-key)))) (gc)
(pass-if "doubly-weak dies" (and (hashq-ref x test-key)
(begin (hashq-ref y test-key)
(hashq-set! z "this" "is") (hashq-ref z test-key))))
(hashq-set! z "a" "test") (pass-if "weak-key dies"
(hashq-set! z "of" "the") (begin
(hashq-set! z "emergency" "weak") (hashq-set! x "this" "is")
(hashq-set! z "all" "hash system") (hashq-set! x "a" "test")
(gc) (hashq-set! x "of" "the")
(and (or (not (hashq-ref z "this")) (hashq-set! x "emergency" "weak")
(not (hashq-ref z "a")) (hashq-set! x "key" "hash system")
(not (hashq-ref z "of")) (gc)
(not (hashq-ref z "emergency")) (and
(not (hashq-ref z "all"))) (or (not (hashq-ref x "this"))
(hashq-ref z test-key))))))) (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))))))