Module: common-dylan-test-suite Synopsis: Common Dylan library test suite Author: Andy Armstrong, et al... Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc. All rights reserved. License: Functional Objects Library Public License Version 1.0 Dual-license: GNU Lesser General Public License Warranty: Distributed WITHOUT WARRANTY OF ANY KIND /// Stream testing define sideways method class-test-function (class :: subclass()) => (function :: ) test-stream-class end method class-test-function; /// Stream information define class () constant slot info-class-name :: , required-init-keyword: name:; constant slot info-class :: subclass(), required-init-keyword: class:; constant slot info-input-stream? :: , required-init-keyword: input-stream?:; constant slot info-output-stream? :: , required-init-keyword: output-stream?:; constant slot info-element-type :: , required-init-keyword: element-type:; end class ; define constant $stream-classes :: = make(); define function register-stream-class-info (name :: , class :: subclass(), #key input-stream? :: = #f, output-stream? :: = #f, element-type :: = ) => () let info = make(, name: name, class: class, input-stream?: input-stream?, output-stream?: output-stream?, element-type: element-type); $stream-classes[class] := info end function register-stream-class-info; define function registered-stream-classes () => (classes :: ) key-sequence($stream-classes) end function registered-stream-classes; define function stream-class-info (class :: subclass()) => (info :: ) element($stream-classes, class, default: #f) | error("Stream class %= not registered for testing", class) end function stream-class-info; define class () constant slot info-test-name :: , required-init-keyword: test-name:; constant slot info-class-info :: , required-init-keyword: class-info:; constant slot info-contents :: , required-init-keyword: contents:; constant slot info-direction :: , required-init-keyword: direction:; constant slot info-make-function :: , required-init-keyword: make-function:; constant slot info-destroy-function :: = maybe-close-test-stream, init-keyword: destroy-function:; end class ; define function maybe-close-test-stream (stream :: ) => () if (stream-open?(stream)) close(stream) end end function maybe-close-test-stream; define open generic test-stream-class (class :: subclass(), #key, #all-keys) => (); define method test-stream-class (class :: subclass(), #key name, instantiable?, #all-keys) => () if (instantiable?) test-stream-of-size(format-to-string("Empty %s", name), class, 0); test-stream-of-size(format-to-string("One item %s", name), class, 1); test-stream-of-size(format-to-string("Multiple item %s", name), class, 5); end end method test-stream-class; define method test-stream-of-size (name :: , class :: , stream-size :: ) => () let info = stream-class-info(class); let tests = make-stream-tests-of-size(class, stream-size); do(test-stream, tests) end method test-stream-of-size; define open generic make-stream-tests-of-size (class :: subclass(), stream-size :: ) => (streams :: ); define method make-stream-tests-of-size (class :: subclass(), stream-size :: ) => (streams :: ) #[] end method make-stream-tests-of-size; define method find-stream-test-info (class :: subclass()) => (info :: false-or()) let tests = make-stream-tests-of-size(class, 2); if (~tests.empty?) tests[0] end end method find-stream-test-info; define sideways method make-test-instance (class :: subclass()) => (stream :: ) let info = find-stream-test-info(class); assert(info, "Making test instance of unregistered stream class %=", class); let make-function :: = info.info-make-function; make-function() end method make-test-instance; define sideways method destroy-test-instance (class :: subclass(), stream :: ) => () let info = find-stream-test-info(class); assert(info, "Destroying test instance of unregistered stream class %=", class); let destroy-function :: = info.info-destroy-function; destroy-function(stream) end method destroy-test-instance; define constant $stream-tests :: = make(); define class () constant slot info-class :: subclass(), required-init-keyword: class:; constant slot info-test-function :: , required-init-keyword: test-function:; constant slot info-direction :: false-or() = #f, init-keyword: direction:; end class ; define function register-stream-test (class :: subclass(), test-function :: , #key direction :: false-or() = #f) => () let tests :: = element($stream-tests, class, default: make()); add!(tests, make(, class: class, test-function: test-function, direction: direction)); $stream-tests[class] := tests end function register-stream-test; define method test-stream (test-info :: ) => () let class-info = test-info.info-class-info; for (class :: subclass() in key-sequence($stream-tests)) if (subtype?(class-info.info-class, class)) let tests = $stream-tests[class]; for (test-function-info :: in tests) let test-function = test-function-info.info-test-function; let test-function-direction = test-function-info.info-direction; if (select (test-info.info-direction) #"input" => class-info.info-input-stream? & (~test-function-direction | test-function-direction == #"input"); #"output" => class-info.info-output-stream? & (~test-function-direction | test-function-direction == #"output"); end) let stream = #f; block () stream := test-info.info-make-function(); unless (instance?(stream, class)) error("Make function for stream class %s returns wrong class of object: %=", class-info.info-class-name, stream) end; if (~test-function-direction | test-function-direction == test-info.info-direction) test-function(test-info, stream); end cleanup if (stream) test-info.info-destroy-function(stream) end end end end end end end method test-stream; /// Test stream classes define abstract class () slot stream-closed? :: = #f; slot stream-test-position :: = 0; end class ; define method close (stream :: , #key) => () stream.stream-closed? := #t end method close; define method stream-element-type (stream :: ) => (type :: ) end method stream-element-type; define method stream-position (stream :: ) => (position :: ) stream.stream-test-position end method stream-position; define method stream-position-setter (position :: , stream :: ) => (position :: ) stream.stream-test-position := position end method stream-position-setter; define method stream-position-setter (position == #"start", stream :: ) => (position :: ) stream.stream-test-position := 0 end method stream-position-setter; define method stream-position-setter (position == #"end", stream :: ) => (position :: ) stream.stream-test-position := stream.stream-size end method stream-position-setter; define method adjust-stream-position (stream :: , delta :: , #key from = #"current") => (position :: ) stream-position(stream) := select (from) #"current" => stream-position(stream) + delta; #"start" => delta; #"end" => stream-size(stream) + delta; end end method adjust-stream-position; // Test input stream define class () slot stream-test-sequence :: , required-init-keyword: test-sequence:; end class ; register-stream-class-info("", , input-stream?: #t, output-stream?: #f, element-type: ); define method make-test-instance (class == ) => (stream :: ) make(, test-sequence: "Test") end method make-test-instance; define method stream-direction (stream :: ) => (direction :: ) if (stream.stream-closed?) #"closed" else #"input" end end method stream-direction; define method stream-contents (stream :: , #key clear-contents? :: = #t) => (contents :: ) let sequence = stream.stream-test-sequence; if (clear-contents?) // clear-contents(stream) end; sequence end method stream-contents; define method stream-contents-as (type :: subclass(), stream :: , #key clear-contents? :: = #t) => (contents :: ) as(type, stream-contents(stream, clear-contents?: clear-contents?)) end method stream-contents-as; define method stream-size (stream :: ) => (size :: ) stream.stream-test-sequence.size end method stream-size; define method stream-at-end? (stream :: ) => (at-end? :: ) stream.stream-test-position = stream.stream-size end method stream-at-end?; define method stream-input-available? (stream :: ) => (input? :: ) ~stream.stream-at-end? & ~stream.stream-closed? end method stream-input-available?; define method peek (stream :: , #key on-end-of-stream = unsupplied()) => (element) let sequence = stream.stream-test-sequence; if (stream.stream-test-position < stream.stream-size) sequence[stream.stream-test-position] else let error = make(, stream: stream); signal(error) end end method peek; define method read-element (stream :: , #key on-end-of-stream = unsupplied()) => (element :: ) let value = peek(stream, on-end-of-stream: on-end-of-stream); stream.stream-test-position := stream.stream-test-position + 1; value end method read-element; define method unread-element (stream :: , object :: ) => (element :: ) if (stream.stream-test-position > 0) stream.stream-test-position := stream.stream-test-position - 1 else // Should we signal an error here? #f end; object end method unread-element; define method read-into! (stream :: , count :: , result :: , #key on-end-of-stream = unsupplied(), start :: = 0) => (n-read) for (i from 0 below count) result[i + start] := read-element(stream, on-end-of-stream: on-end-of-stream) end; count end method read-into!; define method read (stream :: , count :: , #key on-end-of-stream = unsupplied()) => (elements) let result :: = make(, size: count); read-into!(stream, count, result, on-end-of-stream: on-end-of-stream); result end method read; define method discard-input (stream :: ) => () stream.stream-test-sequence := "" end method discard-input; // Test output stream define class () constant slot stream-test-result :: = make(); end class ; register-stream-class-info("", , input-stream?: #f, output-stream?: #t, element-type: ); define method stream-direction (stream :: ) => (direction :: ) if (stream.stream-closed?) #"closed" else #"output" end end method stream-direction; define method write-element (stream :: , char :: ) => () stream.stream-test-result[stream.stream-test-position] := char; stream.stream-test-position := stream.stream-test-position + 1 end method write-element; define method write (stream :: , sequence :: , #key start :: = 0, end: _end :: = sequence.size) => () for (i :: from start below _end) write(stream, sequence[i]) end end method write; // Make test streams define constant $default-string = "abcdefghijklmnopqrstuvwxyz"; define method make-stream-tests-of-size (class == , stream-size :: ) => (streams :: ) let class-info = stream-class-info(class); let tests :: = make(); let character-sequence = copy-sequence($default-string, end: stream-size); add!(tests, make(, test-name: format-to-string(" size %d", stream-size), class-info: class-info, contents: character-sequence, direction: #"input", make-function: method () => (stream :: ) make(, test-sequence: character-sequence) end)); tests end method make-stream-tests-of-size; define method make-stream-tests-of-size (class == , stream-size :: ) => (streams :: ) let class-info = stream-class-info(class); let tests :: = make(); let character-sequence = copy-sequence($default-string, end: stream-size); add!(tests, make(, test-name: format-to-string(" size %d", stream-size), class-info: class-info, contents: character-sequence, direction: #"output", make-function: method () => (stream :: ) make() end)); tests end method make-stream-tests-of-size; define test test-stream-test () test-stream-class(, name: "", instantiable?: #t); test-stream-class(, name: "", instantiable?: #t) end test test-stream-test; define suite test-stream-suite () test test-stream-test; end suite test-stream-suite; /// Core stream tests register-stream-test(, test-close); register-stream-test(, test-stream-open?); register-stream-test(, test-stream-element-type); // Don't test the functions we're already testing... there must be a better way! define streams-protocol function-test close () end; define streams-protocol function-test stream-open? () end; define streams-protocol function-test stream-element-type () end; define method test-close (info :: , stream :: ) => () // Can't think of anything interesting to test for this #f end method test-close; define method test-stream-open? (info :: , stream :: ) => () let name = info.info-test-name; check-true(format-to-string("%s: stream-open? initially", name), stream-open?(stream)) end method test-stream-open?; define method test-stream-element-type (info :: , stream :: ) => () let name = info.info-test-name; check-true(format-to-string("%s: stream-element-type", name), subtype?(stream-element-type(stream), info.info-class-info.info-element-type)) end method test-stream-element-type; /// Stream reading tests register-stream-test(, test-stream-size, direction: #"input"); register-stream-test(, test-stream-at-end?, direction: #"input"); register-stream-test(, test-read-element, direction: #"input"); register-stream-test(, test-unread-element, direction: #"input"); register-stream-test(, test-peek, direction: #"input"); register-stream-test(, test-read, direction: #"input"); register-stream-test(, test-read-into!, direction: #"input"); register-stream-test(, test-discard-input, direction: #"input"); register-stream-test(, test-stream-input-available?, direction: #"input"); register-stream-test(, test-stream-contents, direction: #"input"); register-stream-test(, test-stream-contents-as, direction: #"input"); // Don't test the functions we're already testing... there must be a better way! define streams-protocol function-test stream-size () end; define streams-protocol function-test stream-at-end? () end; define streams-protocol function-test read-element () end; define streams-protocol function-test unread-element () end; define streams-protocol function-test peek () end; define streams-protocol function-test read () end; define streams-protocol function-test read-into! () end; define streams-protocol function-test discard-input () end; define streams-protocol function-test stream-input-available? () end; define streams-protocol function-test stream-contents () end; define streams-protocol function-test stream-contents-as () end; define method test-stream-size (info :: , stream :: ) => () let name = info.info-test-name; check-equal(format-to-string("%s: stream-size", name), info.info-contents.size, stream-size(stream)) end method test-stream-size; define method test-stream-at-end? (info :: , stream :: ) => () let name = info.info-test-name; if (~empty?(info.info-contents)) check-false(format-to-string("%s: stream-at-end? not true initially", name), stream-at-end?(stream)) else check-true(format-to-string("%s: stream-at-end? true initially", name), stream-at-end?(stream)) end end method test-stream-at-end?; define method test-read-element (info :: , stream :: ) => () let name = info.info-test-name; for (expected-element in info.info-contents, i from 0) check-equal(format-to-string("%s: read element %d", name, i), expected-element, read-element(stream)) end; check-condition(format-to-string("%s: read-element off end signals ", name), , read-element(stream)); check-at-end-of-stream(name, "read-element", stream) end method test-read-element; define method test-unread-element (info :: , stream :: ) => () let name = info.info-test-name; for (expected-element in info.info-contents, i from 0) check-true(format-to-string("%s: read element %d and then unread it", name, i), begin let element = read-element(stream); unread-element(stream, element); read-element(stream) end) end; check-at-end-of-stream(name, "unread-element", stream) end method test-unread-element; define method test-peek (info :: , stream :: ) => () let name = info.info-test-name; for (expected-element in info.info-contents, i from 0) check-true(format-to-string("%s: peek element %d", name, i), begin let element = peek(stream); read-element(stream) end) end; check-condition(format-to-string("%s: peek off end signals ", name), , peek(stream)); check-at-end-of-stream(name, "peek", stream) end method test-peek; define method test-read (info :: , stream :: ) => () let name = info.info-test-name; check-equal(format-to-string("%s: read whole stream", name), info.info-contents, read(stream, info.info-contents.size)); check-condition(format-to-string("%s: read off end signals ", name), , read(stream, 1)); check-at-end-of-stream(name, "read", stream) end method test-read; define method test-read-into! (info :: , stream :: ) => () //---*** Fill this in... end method test-read-into!; define method test-discard-input (info :: , stream :: ) => () //---*** Fill this in... end method test-discard-input; define method test-stream-input-available? (info :: , stream :: ) => () let name = info.info-test-name; if (~info.info-contents.empty?) check-true(format-to-string("%s: stream-input-available? is true", name), stream-input-available?(stream)); check-no-errors(format-to-string("%s: read to the end", name), while (~stream-at-end?(stream)) read-element(stream) end) end; check-false(format-to-string("%s: stream-input-available? at end is false", name), stream-input-available?(stream)); check-at-end-of-stream(name, "stream-contents", stream) end method test-stream-input-available?; define method test-stream-contents (info :: , stream :: ) => () let name = info.info-test-name; check-equal(format-to-string("%s: stream-contents correct", name), info.info-contents, stream-contents(stream)); check-at-end-of-stream(name, "stream-contents", stream) end method test-stream-contents; define method test-stream-contents-as (info :: , stream :: ) => () let name = info.info-test-name; let contents = #f; check-equal(format-to-string("%s: stream-contents-as correct", name), info.info-contents, contents := stream-contents-as(, stream)); check-instance?(format-to-string("%s: stream-contents-as returns sequence of specified type", name), , contents); check-at-end-of-stream(name, "stream-contents-as", stream) end method test-stream-contents-as; define function check-at-end-of-stream (name :: , function-name :: , stream :: ) => () check-true(format-to-string("%s: %s: reached end of stream", name, function-name), stream-at-end?(stream)); check-condition(format-to-string("%s: %s: signalled reading off end", name, function-name), , read-element(stream)) end function check-at-end-of-stream; /// Stream writing tests register-stream-test(, test-write-element, direction: #"output"); register-stream-test(, test-write, direction: #"output"); register-stream-test(, test-force-output, direction: #"output"); register-stream-test(, test-wait-for-io-completion, direction: #"output"); register-stream-test(, test-synchronize-output, direction: #"output"); register-stream-test(, test-discard-output, direction: #"output"); // Don't test the functions we're already testing... there must be a better way! define streams-protocol function-test write-element () end; define streams-protocol function-test write () end; define streams-protocol function-test force-output () end; define streams-protocol function-test wait-for-io-completion () end; define streams-protocol function-test synchronize-output () end; define streams-protocol function-test discard-output () end; define method test-write-element (info :: , stream :: ) => () //---*** Fill this in... end method test-write-element; define method test-write (info :: , stream :: ) => () //---*** Fill this in... end method test-write; define method test-force-output (info :: , stream :: ) => () //---*** Fill this in... end method test-force-output; define method test-wait-for-io-completion (info :: , stream :: ) => () //---*** Fill this in... end method test-wait-for-io-completion; define method test-synchronize-output (info :: , stream :: ) => () //---*** Fill this in... end method test-synchronize-output; define method test-discard-output (info :: , stream :: ) => () //---*** Fill this in... end method test-discard-output; /// Positionable stream tests register-stream-test(, test-stream-position); register-stream-test(, test-stream-position-setter); register-stream-test(, test-adjust-stream-position); // Don't test the functions we're already testing... there must be a better way! define streams-protocol function-test stream-position () end; define streams-protocol function-test stream-position-setter () end; define streams-protocol function-test adjust-stream-position () end; define method test-stream-position (info :: , stream :: ) => () //---*** Fill this in... end method test-stream-position; define method test-stream-position-setter (info :: , stream :: ) => () //---*** Fill this in... end method test-stream-position-setter; define method test-adjust-stream-position (info :: , stream :: ) => () //---*** Fill this in... end method test-adjust-stream-position; /// Stream conditions define sideways method test-condition-class (class :: subclass(), #key name, abstract?, #all-keys) => () unless (abstract?) test-stream-condition(name, make-test-instance(class)) end end method test-condition-class; define sideways method make-test-instance (class :: subclass()) => (error :: ) make(class, stream: make()) end method make-test-instance; define sideways method make-test-instance (class :: subclass()) => (error :: ) make(class, stream: make(), count: 1, sequence: #[1, 2, 3]); end method make-test-instance; define sideways method make-test-instance (class :: subclass()) => (error :: ) make(class, stream: make(), count: 1); end method make-test-instance; define method test-stream-condition (name :: , error :: ) => () //---*** Fill this in... end method test-stream-condition; define streams-protocol function-test stream-error-stream () //---*** Fill this in... end function-test stream-error-stream; define streams-protocol function-test stream-error-sequence () //---*** Fill this in... end function-test stream-error-sequence; define streams-protocol function-test stream-error-count () //---*** Fill this in... end function-test stream-error-count;