[Gd-chatter] r10988 - in trunk: fundev/sources/lib/collection-extensions/test fundev/sources/ole/ole-automation/tests/custom-interface-test fundev/sources/ole/ole-automation/tests/parameter-type-tests fundev/sources/qa/gui-testworks fundev/sources/qa/test-report fundev/sources/qa/testworks fundev/sources/qa/testworks-plus fundev/sources/qa/testworks-specs fundev/sources/registry/generic libraries/programming-tools libraries/programming-tools/gui-testworks libraries/programming-tools/testworks libraries/programming-tools/testworks-report libraries/programming-tools/testworks-specs libraries/programming-tools/testworks/tests libraries/registry/generic src/qa src/qa/testworks src/qa/testworks-specs
cgay at gwydiondylan.org
cgay at gwydiondylan.org
Fri Nov 24 06:49:58 CET 2006
Author: cgay
Date: Fri Nov 24 06:49:51 2006
New Revision: 10988
Added:
trunk/libraries/programming-tools/
trunk/libraries/programming-tools/gui-testworks/
trunk/libraries/programming-tools/gui-testworks/Open-Source-License.txt (contents, props changed)
trunk/libraries/programming-tools/gui-testworks/gui-testworks-lib.dylan (contents, props changed)
trunk/libraries/programming-tools/gui-testworks/gui-testworks.lid (contents, props changed)
trunk/libraries/programming-tools/gui-testworks/progress-window.dylan (contents, props changed)
trunk/libraries/programming-tools/gui-testworks/win32-gui-testworks.lid (contents, props changed)
trunk/libraries/programming-tools/testworks/
trunk/libraries/programming-tools/testworks-report/
trunk/libraries/programming-tools/testworks-report/Open-Source-License.txt (contents, props changed)
trunk/libraries/programming-tools/testworks-report/initialize.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-report/library.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-report/log-reader.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-report/reports.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-report/start.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-report/test-diff.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-report/testworks-report.lid (contents, props changed)
trunk/libraries/programming-tools/testworks-specs/
trunk/libraries/programming-tools/testworks-specs/Open-Source-License.txt (contents, props changed)
trunk/libraries/programming-tools/testworks-specs/class-specs.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-specs/function-specs.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-specs/library.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-specs/macro-specs.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-specs/module-specs.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-specs/protocol-specs.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-specs/specs.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-specs/testworks-specs.lid (contents, props changed)
trunk/libraries/programming-tools/testworks-specs/variable-specs.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks-specs/win32-testworks-specs.lid (contents, props changed)
trunk/libraries/programming-tools/testworks/Open-Source-License.txt (contents, props changed)
trunk/libraries/programming-tools/testworks/benchmarks.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks/checks.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks/command-line.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks/components.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks/reports.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks/suites.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks/tests/
trunk/libraries/programming-tools/testworks/tests.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks/tests/Open-Source-License.txt (contents, props changed)
trunk/libraries/programming-tools/testworks/tests/testworks-test-suite-lib.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks/tests/testworks-test-suite.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks/tests/testworks-test-suite.lid (contents, props changed)
trunk/libraries/programming-tools/testworks/testworks-lib.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks/testworks.dylan (contents, props changed)
trunk/libraries/programming-tools/testworks/testworks.lid (contents, props changed)
trunk/libraries/programming-tools/testworks/win32-testworks.lid (contents, props changed)
trunk/libraries/registry/generic/testworks (contents, props changed)
trunk/libraries/registry/generic/testworks-report (contents, props changed)
trunk/libraries/registry/generic/testworks-specs (contents, props changed)
trunk/libraries/registry/generic/testworks-test-suite (contents, props changed)
Removed:
trunk/fundev/sources/qa/gui-testworks/
trunk/fundev/sources/qa/test-report/
trunk/fundev/sources/qa/testworks/
trunk/fundev/sources/qa/testworks-plus/
trunk/fundev/sources/qa/testworks-specs/
trunk/fundev/sources/registry/generic/test-report
trunk/fundev/sources/registry/generic/testworks
trunk/fundev/sources/registry/generic/testworks-plus
trunk/fundev/sources/registry/generic/testworks-specs
trunk/fundev/sources/registry/generic/testworks-test-suite
trunk/src/qa/testworks/
trunk/src/qa/testworks-specs/
Modified:
trunk/fundev/sources/lib/collection-extensions/test/collection-extensions-test.dylan
trunk/fundev/sources/ole/ole-automation/tests/custom-interface-test/run.dylan
trunk/fundev/sources/ole/ole-automation/tests/parameter-type-tests/library.dylan
trunk/src/qa/README
Log:
job: 7335
Unified the GD and OD testworks libraries:
* Removed testworks-plus altogether as it is now part of testworks.
* Moved testworks, testworks-specs, gui-testworks and test-report to
new libraries/programming-tools directory.
* Renamed test-report to testworks-report.
* Fixed ole-automation test suite to not use testworks-plus.
Modified: trunk/fundev/sources/lib/collection-extensions/test/collection-extensions-test.dylan
==============================================================================
--- trunk/fundev/sources/lib/collection-extensions/test/collection-extensions-test.dylan (original)
+++ trunk/fundev/sources/lib/collection-extensions/test/collection-extensions-test.dylan Fri Nov 24 06:49:51 2006
@@ -40,7 +40,11 @@
end suite collection-extensions-suite;
define method main () => ()
- perform-suite(collection-extensions-suite);
+ block ()
+ perform-suite(collection-extensions-suite);
+ exception (e :: <error>)
+ format-out("collection-extensions-suite error: %=", e);
+ end;
end method main;
begin
Modified: trunk/fundev/sources/ole/ole-automation/tests/custom-interface-test/run.dylan
==============================================================================
--- trunk/fundev/sources/ole/ole-automation/tests/custom-interface-test/run.dylan (original)
+++ trunk/fundev/sources/ole/ole-automation/tests/custom-interface-test/run.dylan Fri Nov 24 06:49:51 2006
@@ -39,7 +39,7 @@
end block;
elseif ( OLE-util-automation?() ) // "/Automation"
run-as-server();
- else // normal testworks-plus run
+ else // normal testworks run
run-test-application(custom-interface-suite);
end if;
end method run-suite;
Modified: trunk/fundev/sources/ole/ole-automation/tests/parameter-type-tests/library.dylan
==============================================================================
--- trunk/fundev/sources/ole/ole-automation/tests/parameter-type-tests/library.dylan (original)
+++ trunk/fundev/sources/ole/ole-automation/tests/parameter-type-tests/library.dylan Fri Nov 24 06:49:51 2006
@@ -17,7 +17,6 @@
use win32-common;
use system;
use testworks;
- use testworks-plus;
end library parameter-type-tests;
@@ -35,5 +34,4 @@
use file-system;
use operating-system;
use testworks;
- use testworks-plus;
end module parameter-type-tests;
Added: trunk/libraries/programming-tools/gui-testworks/Open-Source-License.txt
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/gui-testworks/Open-Source-License.txt Fri Nov 24 06:49:51 2006
@@ -0,0 +1,21 @@
+The contents of this library are subject to the Functional Objects Library
+Public License Version 1.0 (the "License"); you may not use this library
+except in compliance with the License. You may obtain a copy of the License
+at http://www.functionalobjects.com/licenses/library-public-license-1.0.txt
+
+Software distributed under the License is distributed on an "AS IS" basis,
+WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+for the specific language governing rights and limitations under the License.
+
+Original Code is Copyright (c) 1996-2004 Functional Objects, Inc.
+All rights reserved.
+
+Alternatively, the contents of this library may be used under the
+terms of the GNU Lesser General Public License (the "GLGPL"), in which
+case the provisions of the GLGPL are applicable instead of those above. If
+you wish to allow use of your version of this library only under the
+terms of the GLGPL and not to allow others to use your version of this
+library under the License, indicate your decision by deleting the provisions
+above and replace them with the notice and other provisions required
+by the GLGPL. If you do not delete the provisions above, a recipient
+may use your version of this library under either the License or the GLGPL.
Added: trunk/libraries/programming-tools/gui-testworks/gui-testworks-lib.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/gui-testworks/gui-testworks-lib.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,35 @@
+Module: dylan-user
+Synopsis: GUI-TestWorks - a simple GUI wrapper for TestWorks
+Author: Hugh Greene
+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
+
+define library gui-testworks
+ use functional-dylan;
+ use testworks, export: all;
+ use duim;
+
+ export gui-testworks;
+end library gui-testworks;
+
+define module gui-testworks
+ use functional-dylan;
+ use testworks, export: all;
+ use threads;
+ use duim;
+
+ export <progress-window>,
+ *progress-window*,
+ gui-progress-display-message,
+ gui-progress-clear-all-messages,
+ gui-progress-pause,
+ gui-progress-pause-with-check-name,
+ gui-announce-function,
+ start-progress-window,
+ exit-progress-window,
+ gui-perform-suite,
+ gui-perform-test;
+end module gui-testworks;
Added: trunk/libraries/programming-tools/gui-testworks/gui-testworks.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/gui-testworks/gui-testworks.lid Fri Nov 24 06:49:51 2006
@@ -0,0 +1,15 @@
+Library: gui-testworks
+Synopsis: GUI-TestWorks - a simple GUI wrapper for TestWorks
+Author: Hugh Greene
+Target-Type: dll
+Files: gui-testworks-lib
+ progress-window
+Other-files: Open-Source-License.txt
+Major-Version: 2
+Minor-Version: 1
+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
+
Added: trunk/libraries/programming-tools/gui-testworks/progress-window.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/gui-testworks/progress-window.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,255 @@
+Module: gui-testworks
+Summary: GUI progress window for Tesworks
+Author: Hugh Greene
+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
+
+// ---*** ISSUES:
+//
+// Provide a way to skip over checks/tests and to step out of suites/tests.
+// - The commented-out code is a failed attempt to do that. I think I
+// need more/other hooks in TestWorks.
+
+
+/// Progress window frame class
+
+define function make-text-editor
+ (#rest args, #key lines = 4, #all-keys)
+ => (text-editor :: <text-editor>)
+ apply(make, <text-editor>,
+ columns: 80, editable?: #f, scroll-bars: #"vertical",
+ lines: lines,
+ args)
+end function make-text-editor;
+
+define constant $progress-window-name :: <string>
+ = "GUI-TestWorks Progress Window";
+
+define frame <progress-window> (<simple-frame>)
+ pane main-layout (frame)
+ vertically (spacing: 2)
+ // Vertically-scrollable text field for check descriptions.
+ make(<table-layout>,
+ columns: 2, spacing: 2,
+ x-alignment: #[#"left", #"left"], y-alignment: #"top",
+ contents:
+ vector(
+ vector(make(<label>, label: "Suite:"), frame.progress-suite-name),
+ vector(make(<label>, label: "Test:"), frame.progress-test-name),
+ vector(make(<label>, label: "Check:"), frame.progress-check-name)
+ ));
+ labelling ("Information:") frame.progress-information end;
+ horizontally (spacing: 2)
+ // Buttons controlling progress.
+ frame.progress-continue-button;
+// frame.progress-step-out-button;
+ frame.progress-close-button;
+ end;
+ end;
+ layout (frame) frame.main-layout;
+ status-bar (frame)
+ with-frame-manager (frame-manager(frame))
+ make(<status-bar>)
+ end;
+ constant slot progress-suite-name :: <text-editor> = make-text-editor();
+ constant slot progress-test-name :: <text-editor> = make-text-editor();
+ constant slot progress-check-name :: <text-editor> = make-text-editor();
+ constant slot progress-information :: <text-editor> = make-text-editor();
+ constant slot progress-continue-button :: <push-button>
+ = make(<push-button>, label: "&Continue", enabled?: #f, default?: #t,
+ documentation: "Continue with test run after a pause",
+ activate-callback: gui-progress-continue-callback);
+/*
+ constant slot progress-step-out-button :: <push-button>
+ = make(<push-button>, label: "&Step Out", enabled?: #f,
+ documentation:
+ "Step out of the current test or suite by signalling an error",
+ activate-callback: gui-progress-step-out-callback);
+*/
+ constant slot progress-close-button :: <push-button>
+ = make(<push-button>, label: "C&lose",
+ documentation: "Close progress window (test run will continue)",
+ activate-callback: gui-progress-close-callback);
+ constant slot progress-paused-lock :: <semaphore> = make(<semaphore>);
+// slot progress-exit-component? :: <boolean> = #f;
+ keyword title: = $progress-window-name;
+end frame <progress-window>;
+
+define function gui-progress-continue-callback (sheet :: <sheet>)
+ let frame = sheet-frame(sheet);
+ gadget-label(frame.frame-status-bar) := "Test run in progress";
+ gadget-enabled?(frame.progress-continue-button) := #f;
+/*
+ gadget-enabled?(frame.progress-step-out-button) := #f;
+ frame.progress-exit-component? := #f;
+*/
+ release(frame.progress-paused-lock);
+end function gui-progress-continue-callback;
+
+/*---*** Not used
+define function gui-progress-step-out-callback (sheet :: <sheet>)
+ let frame = sheet-frame(sheet);
+ gadget-label(frame.frame-status-bar) := "Stepping out of test component...";
+ gadget-enabled?(frame.progress-continue-button) := #f;
+/*
+ gadget-enabled?(frame.progress-step-out-button) := #f;
+ frame.progress-exit-component? := #t;
+*/
+ release(frame.progress-paused-lock);
+end function gui-progress-step-out-callback;
+*/
+
+define function gui-progress-close-callback (sheet :: <sheet>)
+ exit-frame(sheet-frame(sheet));
+end function gui-progress-close-callback;
+
+
+
+/// Access to message areas (useful as hooks from TestWorks)
+
+define function gui-progress-display-message (kind, message :: <string>)
+ let frame = *progress-window*;
+ let name-gadget
+ = select (kind)
+ <suite> => progress-suite-name;
+ <test> => progress-test-name;
+ #"check" => progress-check-name;
+ #"information" => progress-information;
+ otherwise => #f;
+ end;
+ when (frame & name-gadget)
+ gadget-text(frame.name-gadget) := message;
+ end;
+end function gui-progress-display-message;
+
+define function gui-progress-clear-all-messages () => ()
+ let frame = *progress-window*;
+ when (frame)
+ gadget-text(frame.progress-suite-name) := "";
+ gadget-text(frame.progress-test-name) := "";
+ gadget-text(frame.progress-check-name) := "";
+ gadget-text(frame.progress-information) := "";
+ end;
+end function gui-progress-clear-all-messages;
+
+
+define function gui-progress-pause ()
+ let frame = *progress-window*;
+ when (frame)
+ gadget-label(frame.frame-status-bar) := "Test run paused...";
+ gadget-enabled?(frame.progress-continue-button) := #t;
+// gadget-enabled?(frame.progress-step-out-button) := #t;
+ wait-for(frame.progress-paused-lock);
+/*
+ when (frame.progress-exit-component?)
+ // Normally, TestWorks will catch this and report it later.
+ error("Tester forcibly exited test component");
+ end;
+*/
+ end;
+end function gui-progress-pause;
+
+define function gui-progress-pause-with-check-name (message :: <string>)
+ gui-progress-display-message(#"check", message);
+ gui-progress-pause();
+end function gui-progress-pause-with-check-name;
+
+define function gui-announce-function (component :: <component>)
+ gui-progress-display-message
+ (component.object-class,
+ concatenate
+ (component.component-name, "\n",
+ component.component-description));
+end function gui-announce-function;
+
+
+
+/// Startup/shutdown functions
+
+// Note: There can currently be only one instance of a GUI-TestWorks
+// progress window open at a time, because the variable is the same
+// in all threads, for synchronisation purposes. (The progress window
+// itself always runs in a separate thread.)
+
+define atomic variable *progress-window* :: false-or(<progress-window>) = #f;
+
+define function do-start-progress-window ()
+ make(<thread>,
+ function: method () start-frame(*progress-window*); end,
+ name: $progress-window-name);
+end function do-start-progress-window;
+
+define function start-progress-window (#key force?)
+ unless (*progress-window* | force?)
+ *progress-window* := make(<progress-window>);
+ do-start-progress-window();
+ end;
+end function start-progress-window;
+
+
+define function exit-progress-window ()
+ when (*progress-window*)
+ exit-frame(*progress-window*);
+ end;
+end function exit-progress-window;
+
+define sideways method handle-event
+ (frame :: <progress-window>, event :: <frame-exit-event>) => ()
+ *progress-window* := #f;
+ next-method();
+end method handle-event;
+
+
+
+/// Simple wrapper function
+
+// Note: These should be functions, but the emu messes up #all-keys then.
+
+define method gui-perform-suite
+ (suite :: <suite>,
+ #rest args,
+ #key announce-function = gui-announce-function,
+ announce-checks? = #t,
+ #all-keys)
+ => (result :: <component-result>)
+ block ()
+ start-progress-window();
+ dynamic-bind
+ (*announce-check-function* = gui-progress-pause-with-check-name)
+ apply
+ (perform-suite,
+ suite,
+ announce-function: announce-function,
+ announce-checks?: announce-checks?,
+ args)
+ end
+ cleanup
+ exit-progress-window();
+ end;
+end method gui-perform-suite;
+
+define method gui-perform-test
+ (test :: <test>,
+ #rest args,
+ #key announce-function = gui-announce-function,
+ announce-checks? = #t,
+ #all-keys)
+ => (result :: <component-result>)
+ block ()
+ start-progress-window();
+ dynamic-bind
+ (*announce-check-function* = gui-progress-pause-with-check-name)
+ apply
+ (perform-test,
+ test,
+ announce-function: announce-function,
+ announce-checks?: announce-checks?,
+ args)
+ end
+ cleanup
+ exit-progress-window();
+ end;
+end method gui-perform-test;
Added: trunk/libraries/programming-tools/gui-testworks/win32-gui-testworks.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/gui-testworks/win32-gui-testworks.lid Fri Nov 24 06:49:51 2006
@@ -0,0 +1,13 @@
+Library: gui-testworks
+Author: Andy Armstrong
+Synopsis: Win32 specific options for GUI TestWorks
+Executable: Dxguitst
+Base-Address: 0x64AC0000
+LID: gui-testworks.lid
+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
+Other-files: Open-Source-License.txt
+
Added: trunk/libraries/programming-tools/testworks-report/Open-Source-License.txt
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-report/Open-Source-License.txt Fri Nov 24 06:49:51 2006
@@ -0,0 +1,21 @@
+The contents of this library are subject to the Functional Objects Library
+Public License Version 1.0 (the "License"); you may not use this library
+except in compliance with the License. You may obtain a copy of the License
+at http://www.functionalobjects.com/licenses/library-public-license-1.0.txt
+
+Software distributed under the License is distributed on an "AS IS" basis,
+WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+for the specific language governing rights and limitations under the License.
+
+Original Code is Copyright (c) 1996-2004 Functional Objects, Inc.
+All rights reserved.
+
+Alternatively, the contents of this library may be used under the
+terms of the GNU Lesser General Public License (the "GLGPL"), in which
+case the provisions of the GLGPL are applicable instead of those above. If
+you wish to allow use of your version of this library only under the
+terms of the GLGPL and not to allow others to use your version of this
+library under the License, indicate your decision by deleting the provisions
+above and replace them with the notice and other provisions required
+by the GLGPL. If you do not delete the provisions above, a recipient
+may use your version of this library under either the License or the GLGPL.
Added: trunk/libraries/programming-tools/testworks-report/initialize.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-report/initialize.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,415 @@
+Module: testworks-report
+Synopsis: A tool to generate reports from test run logs
+Author: Shri Amit, Andy Armstrong
+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
+
+// Some application exit constants
+
+define table $error-codes
+ = { #"help" => 1,
+ #"bad-argument-value" => 2,
+ #"start-token-not-found" => 3,
+ #"end-token-not-found" => 4,
+ #"token-not-found" => 5,
+ #"invalid-report-function" => 6,
+ #"invalid-command-line-argument" => 7,
+ #"missing-log-file" => 8,
+ #"no-matching-results" => 9,
+ #"file-not-found" => 10,
+ #"end-of-file" => 11
+ };
+
+
+/// Application options
+
+define class <application-options> (<object>)
+ constant slot application-quiet? :: <boolean> = #f,
+ init-keyword: quiet?:;
+ constant slot application-log1 :: <string>,
+ required-init-keyword: log1:;
+ constant slot application-log2 :: false-or(<string>) = #f,
+ init-keyword: log2:;
+ constant slot application-report-function :: <function>,
+ required-init-keyword: report-function:;
+ constant slot application-tests :: <sequence> = #[],
+ init-keyword: tests:;
+ constant slot application-suites :: <sequence> = #[],
+ init-keyword: suites:;
+ constant slot application-ignored-tests :: <sequence> = #[],
+ init-keyword: ignored-tests:;
+ constant slot application-ignored-suites :: <sequence> = #[],
+ init-keyword: ignored-suites:;
+ constant slot application-tolerance :: <integer> = $default-benchmark-tolerance,
+ init-keyword: tolerance:;
+end class <application-options>;
+
+define function print-elements
+ (sequence :: <sequence>, #key prefix = "", postfix = "\n") => ()
+ let separator = ", ";
+ let current-separator = "";
+ let sequence-size = size(sequence);
+ format-out(prefix);
+ for (element in sequence)
+ format-out("%s%s", current-separator, element);
+ current-separator := separator
+ end;
+ format-out(postfix);
+end function print-elements;
+
+define method display-run-options
+ (options :: <application-options>) => ()
+ unless (application-quiet?(options))
+ let log1 = application-log1(options);
+ let log2 = application-log2(options);
+ let report-function = application-report-function(options);
+ let tests = application-tests(options);
+ let suites = application-suites(options);
+ let ignored-tests = application-ignored-tests(options);
+ let ignored-suites = application-ignored-suites(options);
+ format-out("\n");
+ if (log2)
+ format-out("Comparing log files:\n %s\n %s\n\n", log1, log2)
+ else
+ format-out("Generating report for:\n %s\n", log1)
+ end;
+ format-out("\n Report function: %s\n",
+ select (report-function by \=)
+ diff-full-report-function => "full-diff";
+ diff-report-function => "diff";
+ diff-summary-report-function => "diff-summary";
+ benchmark-diff-report-function => "benchmark-diff";
+ summary-report-function => "summary";
+ failures-report-function => "failures";
+ full-report-function => "full";
+ otherwise => "*** unrecognised ***";
+ end);
+ print-elements(tests, prefix: " Tests: ");
+ print-elements(suites, prefix: " Suites: ");
+ print-elements(ignored-tests, prefix: " Ignored Tests: ");
+ print-elements(ignored-suites, prefix: " Ignored Suites: ");
+ format-out("Benchmark tolerance: %d%%\n", application-tolerance(options));
+ format-out("\n")
+ end
+end method display-run-options;
+
+/// application-error
+
+define method application-exit-code
+ (error-name :: <symbol>) => (code :: <integer>)
+ let error-code = element($error-codes, error-name, default: #f);
+ error-code | error("Unknown error value '%='", error-name)
+end method application-exit-code;
+
+
+/// Command line arguments
+
+// Removed '/' from this list because it is patently broken for Linux.
+// --cgay 2006.11.23
+define constant $keyword-prefixes = #['-'];
+
+define method process-argument
+ (argument :: <string>)
+ => (text :: <string>, keyword? :: <boolean>)
+ if (keyword-argument?(argument))
+ values(copy-sequence(argument, start: 1), #t)
+ else
+ values(argument, #f)
+ end
+end method process-argument;
+
+define method keyword-argument?
+ (argument :: <string>) => (keyword? :: <boolean>)
+ member?(argument[0], $keyword-prefixes)
+ & block () // don't treat a negative integer as a keyword arg.
+ let (int, index) = string-to-integer(argument);
+ ignore(int);
+ size(argument) ~= index
+ exception (e :: <error>)
+ #t
+ end
+end method keyword-argument?;
+
+define method invalid-argument
+ (error-name :: <symbol>, format-string :: <string>, #rest args) => ()
+ display-help(application-name());
+ format-out("\n");
+ apply(format-out, format-string, args);
+ exit-application(application-exit-code(error-name))
+end method invalid-argument;
+
+define method argument-value
+ (keyword :: <string>, arguments :: <deque>,
+ #key allow-zero-arguments?)
+ => (value :: <stretchy-vector>)
+ if (~allow-zero-arguments?
+ & (empty?(arguments) | keyword-argument?(arguments[0])))
+ invalid-argument(#"bad-argument-value",
+ "No argument specified for keyword '%s'.\n", keyword)
+ end;
+ let value = make(<stretchy-vector>);
+ while (~empty?(arguments) & ~keyword-argument?(arguments[0]))
+ add!(value, pop(arguments))
+ end;
+ value
+end method argument-value;
+
+// ---*** carlg 99-02-12 I think it would be a good idea to change the arguments
+// as follows:
+// -report [all | failures | summary]
+// and the rest can be figured out based on whether one or two log files
+// were specified. No time now though...
+define constant $help-format-string =
+ "Application: %s\n"
+ "\n"
+ " Arguments: log1\n"
+ " [log2]\n"
+ " [-quiet]\n"
+ " [-report [full failures summary diff full-diff diff-summary benchmark-diff]]\n"
+ " [-suite <name1> <name2> ... ...]\n"
+ " [-test <name1> <name2> ... ...]\n"
+ " [-ignore-suite <name1> <name2> ... ...]\n"
+ " [-ignore-test <name1> <name2> ... ...]\n"
+ " [-tolerance <percentage>]\n";
+
+define method display-help (command-name :: <string>) => ()
+ format-out($help-format-string, command-name);
+end method display-help;
+
+define method parse-arguments
+ (command-name :: <sequence>, arguments :: <sequence>)
+ => (options :: <application-options>)
+ let arguments = as(<deque>, arguments);
+ let log1 = #f;
+ let log2 = #f;
+ let suites = #[];
+ let tests = #[];
+ let ignored-suites = #[];
+ let ignored-tests = #[];
+ let report-function = #f;
+ let quiet? = #f;
+ let tolerance = $default-benchmark-tolerance;
+ // Parse through the arguments
+ while (~empty?(arguments))
+ let argument = pop(arguments);
+ let (option, keyword?) = process-argument(argument);
+ select (option by \=)
+ "report" =>
+ report-function
+ := begin
+ let function-name = pop(arguments);
+ select (function-name by \=)
+ "full" => full-report-function;
+ "summary" => summary-report-function;
+ "failures" => failures-report-function;
+ "diff" => diff-report-function;
+ "full-diff" => diff-full-report-function;
+ "diff-summary" => diff-summary-report-function;
+ "benchmark-diff" => benchmark-diff-report-function;
+ otherwise =>
+ invalid-argument(#"invalid-report-function",
+ "Report function '%s' not supported.\n",
+ function-name);
+ end
+ end;
+ "suite" =>
+ suites := concatenate(suites, argument-value(option, arguments));
+ "test" =>
+ tests := concatenate(tests, argument-value(option, arguments));
+ "ignore-suite" =>
+ ignored-suites
+ := concatenate(ignored-suites, argument-value(option, arguments));
+ "ignore-test" =>
+ ignored-tests
+ := concatenate(ignored-tests, argument-value(option, arguments));
+ "quiet" =>
+ quiet? := #t;
+ "verbose" =>
+ quiet? := #f;
+ "tolerance" =>
+ let vals = argument-value(option, arguments);
+ block ()
+ tolerance := string-to-integer(vals[0]);
+ exception (e :: <error>)
+ invalid-argument(#"bad-argument-value",
+ "Invalid argument specified for the %s keyword: '%s'.\n",
+ option, vals[0]);
+ end;
+ otherwise =>
+ case
+ log1 & log2 =>
+ invalid-argument(#"invalid-command-line-argument",
+ "Invalid command line keyword '%s'.\n", option);
+ log1 => log2 := option;
+ otherwise => log1 := option;
+ end;
+ end
+ end;
+ unless (log1)
+ invalid-argument(#"missing-log-file",
+ "Log file missing - one or two log files must be supplied\n")
+ end;
+ unless (report-function)
+ report-function := if (log2)
+ diff-report-function
+ else
+ failures-report-function
+ end;
+ end;
+ if (log2 & member?(report-function, vector(full-report-function,
+ failures-report-function,
+ summary-report-function)))
+ invalid-argument(#"bad-argument-value",
+ "The report function specified is not meaningful "
+ "when two log files are specified.\n");
+ end if;
+ if (~log2 & member?(report-function, vector(diff-report-function,
+ diff-full-report-function,
+ diff-summary-report-function,
+ benchmark-diff-report-function)))
+ invalid-argument(#"bad-argument-value",
+ "The report function specified is only meaningful "
+ "when two log files are specified.\n");
+ end if;
+ make(<application-options>,
+ log1: log1, log2: log2,
+ quiet?: quiet?, report-function: report-function,
+ tolerance: tolerance,
+ tests: tests, suites: suites,
+ ignored-tests: map(as-lowercase, ignored-tests),
+ ignored-suites: map(as-lowercase, ignored-suites))
+end method parse-arguments;
+
+define method case-insensitive-equal?
+ (name1 :: <string>, name2 :: <string>)
+ => (equal? :: <boolean>)
+ as-lowercase(name1) = as-lowercase(name2)
+end method case-insensitive-equal?;
+
+define method find-named-results
+ (result :: <check-result>, #key tests = #[], suites = #[])
+ => (named-results :: <sequence>)
+ #[]
+end method find-named-results;
+
+define method find-named-results
+ (results :: <sequence>, #key tests = #[], suites = #[])
+ => (named-results :: <sequence>)
+ let named-results = make(<stretchy-vector>);
+ for (subresult in results)
+ let subresults
+ = find-named-results(subresult, tests: tests, suites: suites);
+ for (result in subresults)
+ add!(named-results, result)
+ end
+ end;
+ named-results
+end method find-named-results;
+
+define method find-named-results
+ (result :: <test-result>, #key tests = #[], suites = #[])
+ => (named-results :: <sequence>)
+ let match?
+ = member?(result.result-name, tests, test: case-insensitive-equal?);
+ if (match?)
+ vector(result)
+ else
+ find-named-results
+ (result.result-subresults, tests: tests, suites: suites)
+ end
+end method find-named-results;
+
+define method find-named-results
+ (result :: <suite-result>, #key tests = #[], suites = #[])
+ => (named-results :: <sequence>)
+ let match?
+ = member?(result.result-name, suites, test: case-insensitive-equal?);
+ if (match?)
+ vector(result)
+ else
+ find-named-results
+ (result.result-subresults, tests: tests, suites: suites)
+ end
+end method find-named-results;
+
+define method find-named-result
+ (result :: <result>, #key tests = #[], suites = #[])
+ => (named-result :: <result>)
+ let results = find-named-results(result, tests: tests, suites: suites);
+ select (size(results))
+ 0 =>
+ application-error(#"no-matching-results",
+ "No matches for tests %= or suites %=",
+ tests, suites);
+ 1 =>
+ results[0];
+ otherwise =>
+ let passed?
+ = every?(method (subresult)
+ let status = subresult.result-status;
+ status = #"passed" | status = #"not-executed"
+ end,
+ results);
+ make(<suite-result>,
+ name: "[Specified tests/suites]",
+ status: if (passed?) #"passed" else #"failed" end,
+ subresults: results);
+ end
+end method find-named-result;
+
+define method main
+ (command-name :: <string>, arguments :: <sequence>) => ()
+ // Process the command line arguments
+ if (arguments & ~empty?(arguments))
+ let (first-argument, keyword?) = process-argument(arguments[0]);
+ if (keyword?
+ & member?(first-argument, #["help", "?"], test: \=))
+ display-help(command-name);
+ exit-application(application-exit-code(#"help"));
+ end if;
+ end if;
+ let options = parse-arguments(command-name, arguments);
+ display-run-options(options);
+ let log1 = application-log1(options);
+ let log2 = application-log2(options);
+ let tests = application-tests(options);
+ let suites = application-suites(options);
+ let report-function = application-report-function(options);
+ let ignored-tests = application-ignored-tests(options);
+ let ignored-suites = application-ignored-suites(options);
+ let tolerance = application-tolerance(options);
+ local method read-log-file-with-options
+ (log :: <string>) => (result :: <result>)
+ block ()
+ let result
+ = read-log-file(log,
+ ignored-tests: ignored-tests,
+ ignored-suites: ignored-suites);
+ if (~empty?(tests) | ~empty?(suites))
+ find-named-result(result,
+ tests: tests,
+ suites: suites)
+ else
+ result
+ end
+ exception (e :: <file-does-not-exist-error>)
+ application-error(#"file-not-found", "Error: %s", e);
+ end block
+ end method read-log-file-with-options;
+ if (log2)
+ let result1 = read-log-file-with-options(log1);
+ let result2 = read-log-file-with-options(log2);
+ perform-test-diff
+ (log1: log1, log2: log2,
+ result1: result1, result2: result2,
+ report-function: report-function,
+ tolerance: tolerance)
+ else
+ let results = read-log-file-with-options(log1);
+ report-function(results)
+ end
+end method main;
+
Added: trunk/libraries/programming-tools/testworks-report/library.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-report/library.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,31 @@
+Module: dylan-user
+Synopsis: A tool to generate reports from test run logs
+Author: Shri Amit, Andy Armstrong
+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
+
+define library testworks-report
+ use common-dylan;
+ use io;
+ use system;
+ use testworks;
+
+ export testworks-report;
+end library testworks-report;
+
+define module testworks-report
+ use common-dylan;
+ use simple-io;
+ use streams;
+ use file-system;
+ use operating-system;
+ use threads,
+ import: { dynamic-bind };
+ use testworks;
+
+ export read-log-file,
+ perform-test-diff;
+end module testworks-report;
Added: trunk/libraries/programming-tools/testworks-report/log-reader.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-report/log-reader.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,195 @@
+Module: testworks-report
+Synopsis: A tool to generate reports from test run logs
+Author: Shri Amit, Andy Armstrong
+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
+
+/// read-log-file
+
+define constant $testworks-plus-message
+ = "Make sure the test report was generated using the \"-report log\"\n"
+ "option to testworks-plus.";
+
+define method read-log-file
+ (test-stream :: <file-stream>, #key ignored-tests = #[], ignored-suites = #[])
+ => (result :: false-or(<result>))
+ block (return)
+ let last-line = #f;
+ // Read next non-blank line. Error if EOF reached, since that means
+ // the log file wasn't written correctly anyway.
+ local method read-next-line (#key error?) => (line :: <string>)
+ let next-line = last-line;
+ if (next-line)
+ last-line := #f;
+ next-line
+ else
+ let line = read-line(test-stream);
+ while (line = "")
+ line := read-line(test-stream);
+ end while;
+ line
+ end if
+ end method read-next-line;
+ local method unread-line (line :: <string>) => ()
+ last-line := line
+ end method unread-line;
+ local method line-starts-with (line :: <string>, s :: <string>) => (b :: <boolean>)
+ block (return)
+ let len = size(line);
+ for (i from 0 below size(s))
+ if (i >= len | line[i] ~= s[i])
+ return(#f);
+ end if;
+ end for;
+ #t
+ end block
+ end method line-starts-with;
+ local method maybe-read-keyword-line
+ (keyword :: <string>) => (value :: false-or(<string>))
+ let line = read-next-line();
+ if (line-starts-with(line, keyword))
+ as(<string>, copy-sequence(line, start: keyword.size))
+ else
+ unread-line(line);
+ #f
+ end
+ end method maybe-read-keyword-line;
+ local method read-keyword-line (keyword :: <string>) => (value :: <string>)
+ maybe-read-keyword-line(keyword)
+ | application-error(#"token-not-found",
+ "Error parsing report: The keyword \"%s\" was not found.\n%s\n",
+ $testworks-plus-message, keyword)
+ end method read-keyword-line;
+ local method read-end-token () => ()
+ unless (line-starts-with(read-next-line(), "end"))
+ application-error(#"end-token-not-found",
+ "Error parsing report: 'end' token not found.\n%s\n",
+ $testworks-plus-message);
+ end;
+ end method read-end-token;
+ local method read-log-file-section () => (result :: false-or(<result>))
+ let type = read-keyword-line("Object: ");
+ let name = read-keyword-line("Name: ");
+ when (type = "Suite")
+ debug-message("Reading %s...", name)
+ end;
+ let status-string = read-keyword-line("Status: ");
+ let reason = maybe-read-keyword-line("Reason: ");
+ let seconds = #f;
+ let microseconds = #f;
+ let allocation = #f;
+ let subresults
+ = if (type = "Check")
+ read-end-token();
+ elseif (type = "Benchmark")
+ // If there is no "Reason:" line for a benchmark then there
+ // are "Seconds:" and "Allocation:".
+ if (~reason)
+ let time = read-keyword-line("Seconds: ");
+ let alloc = read-keyword-line("Allocation: ");
+ let (secs, index) = string-to-integer(time);
+ seconds := secs;
+ microseconds := string-to-integer(time, start: index + 1);
+ allocation := string-to-integer(alloc);
+ end if;
+ read-end-token();
+ else // type is "Test" or "Suite"
+ let subresults = make(<stretchy-vector>);
+ let line = read-next-line();
+ until (line-starts-with(line, "end"))
+ unread-line(line);
+ let subresult = read-log-file-section();
+ subresult & add!(subresults, subresult);
+ line := read-next-line();
+ end;
+ subresults
+ end;
+ let status
+ = select (status-string by \=)
+ "passed" => #"passed";
+ "failed" => #"failed";
+ "not executed" => #"not-executed";
+ "crashed" => recreate-error(reason);
+ otherwise =>
+ error("Unexpected status '%s' in report", status-string);
+ end;
+ select (type by \=)
+ "Check" =>
+ make(<check-result>,
+ name: name, status: status,
+ operation: reason, value: #f);
+ "Benchmark" =>
+ make(<benchmark-result>,
+ name: name, status: status, operation: reason, value: #f,
+ seconds: seconds, microseconds: microseconds,
+ bytes: allocation);
+ "Test" =>
+ unless (member?(as-lowercase(name), ignored-tests, test: \=))
+ make(<test-result>,
+ name: name, status: status, subresults: subresults)
+ end;
+ "Suite" =>
+ if (~member?(as-lowercase(name), ignored-suites, test: \=))
+ debug-message("Read %s", name);
+ make(<suite-result>,
+ name: name, status: status, subresults: subresults)
+ else
+ debug-message("Ignored %s", name)
+ end;
+ otherwise =>
+ error("Unexpected component type '%s'", type);
+ end
+ end;
+ block ()
+ read-log-file-section();
+ exception (e :: <end-of-stream-error>)
+ application-error(#"end-of-file",
+ "Error parsing report: End of file reached.\n%s\n",
+ $testworks-plus-message);
+ end block
+ end block
+end method read-log-file;
+
+define method read-log-file
+ (path :: <string>, #key ignored-tests = #[], ignored-suites = #[])
+ => (result :: <result>)
+ let start-token = $test-log-header;
+ let stream
+ = make(<file-stream>,
+ direction: #"input",
+ locator: path,
+ if-does-not-exist: #"signal");
+ block (return)
+ while (#t)
+ let line = read-line(stream, on-end-of-stream: #f);
+ select (line by \=)
+ #f =>
+ application-error(#"start-token-not-found",
+ "The log file '%s' doesn't contain any log information.\n%s\n",
+ path, $testworks-plus-message);
+ start-token =>
+ return();
+ otherwise =>
+ #f;
+ end
+ end
+ end;
+ read-log-file(stream, ignored-tests: ignored-tests, ignored-suites: ignored-suites)
+ | application-error(#"no-matching-results",
+ "There are no matching results in log file %s\n%s\n",
+ path, $testworks-plus-message)
+end method read-log-file;
+
+
+define class <recreated-error> (<error>)
+end class <recreated-error>;
+
+define method recreate-error
+ (string :: <string>) => (error :: <recreated-error>)
+ make(<recreated-error>,
+ format-string: "%s",
+ format-arguments: vector(string))
+end method recreate-error;
Added: trunk/libraries/programming-tools/testworks-report/reports.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-report/reports.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,286 @@
+Module: testworks-report
+Synopsis: A tool to generate reports from test run logs
+Author: Shri Amit, Andy Armstrong
+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
+
+// Report functions:
+// full - report identical as well as different result objects
+// diff - reports only different result objects
+// summary - reports only a summary of passes, failures, etc.
+// benchmark - reports benchmarks that differed by more than a certain amount.
+
+define method print-status-line
+ (result :: <comparison-result>, #key indent = "", test)
+ => ()
+ let show-result? = if (test) test(result) else #t end;
+ if (show-result?)
+ let result1 = result.comparison-result1;
+ let result2 = result.comparison-result2;
+ format-out("%s%s %s -- %s\n",
+ indent,
+ result-type-name(result1 | result2),
+ result-name(result1 | result2),
+ if (result.comparison-identical?)
+ "identical"
+ else
+ "differed"
+ end)
+ end if;
+end method print-status-line;
+
+define method result-failure-reason
+ (result :: <check-result>) => (reason :: false-or(<string>))
+ failure-reason
+ (result-status(result), result-operation(result), result-value(result))
+end method result-failure-reason;
+
+define method result-failure-reason
+ (result :: <test-result>) => (reason :: false-or(<string>))
+ let status = result-status(result);
+ instance?(status, <error>) & safe-error-to-string(status)
+end method result-failure-reason;
+
+define method print-result-reason
+ (name :: <string>, result :: <result>, #key indent = "") => ()
+ let reason = result-failure-reason(result);
+ format-out("%s %s %s%s\n",
+ indent, name, status-name(result.result-status),
+ if (reason) format-to-string(" [%s]", reason) else "" end);
+end method print-result-reason;
+
+define method print-result-reason
+ (name :: <string>, result :: <benchmark-result>, #key indent = "") => ()
+ if (result.result-status ~== #"passed")
+ next-method();
+ else
+ format-out("%s %s %s in %s seconds, %d bytes allocated\n",
+ indent, name, status-name(result-status(result)),
+ result-time(result), result-bytes(result))
+ end if
+end method print-result-reason;
+
+define method print-result-reason
+ (name :: <string>, result == #f, #key indent = "") => ()
+ format-out("%s %s has no such match\n", indent, name);
+end method print-result-reason;
+
+define method print-reason
+ (result :: <comparison-result>, #key indent = "", test)
+ => ()
+ let show-result? = if (test) test(result) else #t end;
+ if (show-result?)
+ print-comparison-result(result.comparison-result1, result.comparison-result2,
+ indent: indent);
+ end;
+end method print-reason;
+
+define method print-comparison-result
+ (result1, result2, #key indent = "") => ()
+ print-result-reason("Log1", result1, indent: indent);
+ print-result-reason("Log2", result2, indent: indent);
+end method print-comparison-result;
+
+define method float->percentage
+ (f :: <float>) => (s :: <string>)
+ let sign = if (f < 0) "-" else "+" end;
+ let (int1, ff) = floor(abs(f));
+ let int2 = abs(round(ff * 100));
+ if (int1 == 0 & int2 == 0)
+ sign := "";
+ end if;
+ format-to-string("%s%d.%s%%", sign, int1, integer-to-string(int2, size: 2))
+end method float->percentage;
+
+// This method is provided only for the case where checks and benchmarks are
+// mixed together in the same test or suite. A much better way to display
+// benchmark results is to use the benchmark-diff-report-function.
+//
+define method print-comparison-result
+ (result1 :: <benchmark-result>, result2 :: <benchmark-result>,
+ #key indent = "")
+ => ()
+ next-method();
+ let (time-diff, space-diff, valid?) = diff-benchmark-results(result1, result2);
+ if (valid?)
+ format-out("%s ==> time: %s%%, allocation: %s%%\n",
+ indent,
+ float->percentage(time-diff),
+ float->percentage(space-diff));
+ else
+ format-out("%s ==> *** benchmark results invalid ***\n", indent);
+ end if;
+end method print-comparison-result;
+
+define method print-comparison-info
+ (result :: <comparison-result>, #key indent = "", test)
+ => ()
+ print-status-line(result, indent: indent, test: test);
+ let result1 = result.comparison-result1;
+ let result2 = result.comparison-result2;
+ if (instance?(result1 | result2, <unit-result>))
+ print-reason(result, indent: indent, test: test);
+ end;
+ let subindent = concatenate-as(<byte-string>, indent, " ");
+ for (subresult in comparison-subresults(result))
+ print-comparison-info(subresult, indent: subindent, test: test)
+ end
+end method print-comparison-info;
+
+define method print-percentage
+ (count :: <integer>, size :: <integer>, #key decimal-places = 1)
+ => ()
+ case
+ size > 0 =>
+ let shift = 10; // 10 ^ decimal-places;
+ let percentage = ceiling/(count * 100 * shift, size);
+ let (integer, remainder) = floor/(percentage, shift);
+ format-out("%d.%d%%", integer, floor(remainder));
+ otherwise =>
+ format-out("100%%");
+ end
+end method print-percentage;
+
+define method count-results
+ (result :: <comparison-result>, type :: <string>)
+ => (differed :: <integer>, identical :: <integer>, unique :: <integer>)
+ let differed = 0;
+ let identical = 0;
+ let unique = 0;
+
+ let result1 = result.comparison-result1;
+ let result2 = result.comparison-result2;
+ let comparison-type = result-type-name(result1 | result2);
+ if (comparison-type = type)
+ if (result.comparison-identical?)
+ identical := identical + 1;
+ else
+ differed := differed + 1;
+ end;
+ unless (result1 & result2)
+ unique := unique + 1;
+ end;
+ end;
+ for (subresult in result.comparison-subresults)
+ let (sub-differed, sub-identical, sub-unique)
+ = count-results(subresult, type);
+ differed := differed + sub-differed;
+ identical := identical + sub-identical;
+ unique := unique + sub-unique;
+ end;
+ values(differed, identical, unique)
+end method count-results;
+
+define method summarize
+ (result :: <comparison-result>, type :: <string>)
+ => ()
+ let (differed, identical, unique)
+ = count-results(result, type);
+ let total = differed + identical + unique;
+ format-out(" Compared %d %ss: %d differed(",
+ total, type, differed);
+ print-percentage(differed, total);
+ format-out("), %d identical and %d unique\n",
+ identical, unique);
+end method summarize;
+
+
+/// Report functions
+
+define method diff-full-report-function
+ (result :: <comparison-result>) => ()
+ print-comparison-info(result, test: always(#t));
+ format-out("\n");
+ diff-summary-report-function(result)
+end method diff-full-report-function;
+
+define method contains-check-results?
+ (result :: <comparison-result>) => (b :: <boolean>)
+ instance?(comparison-result1(result), <check-result>)
+ | instance?(comparison-result2(result), <check-result>)
+ | any?(contains-check-results?, comparison-subresults(result))
+end method contains-check-results?;
+
+define method diff-report-function
+ (result :: <comparison-result>) => ()
+ // To maintain backward compatibility with pre-benchmarking code, if the
+ // comparison contains any checks then use the non-benchmark display
+ // format.
+ if (contains-check-results?(result))
+ print-comparison-info(result,
+ test: method (result)
+ ~result.comparison-identical?
+ end);
+ else
+ benchmark-diff-report-function(result, show-all?: #f);
+ end if;
+ format-out("\n");
+ diff-summary-report-function(result)
+end method diff-report-function;
+
+define method diff-summary-report-function
+ (result :: <comparison-result>) => ()
+ format-out("Comparison Summary:\n");
+ summarize(result, "Suite");
+ summarize(result, "Test");
+ summarize(result, "Check");
+ summarize(result, "Benchmark");
+end method diff-summary-report-function;
+
+define method benchmark-diff-report-function
+ (top-result :: <comparison-result>, #key show-all? :: <boolean>)
+ => ()
+ let any-displayed? = #f;
+ let crashes = 0;
+ let best-time-diff = 0;
+ let worst-time-diff = 0;
+ let best-alloc-diff = 0;
+ let worst-alloc-diff = 0;
+ local method print-one (result :: <comparison-result>) => ()
+ let result1 = comparison-result1(result);
+ let result2 = comparison-result2(result);
+ if (instance?(result1, <benchmark-result>)
+ & instance?(result2, <benchmark-result>)
+ & (~comparison-identical?(result) | show-all?))
+ let (time-diff, space-diff, valid?)
+ = diff-benchmark-results(result1, result2);
+ if (~any-displayed?)
+ any-displayed? := #t;
+ print-benchmark-result-header();
+ end if;
+ print-one-benchmark-result
+ (result-name(result1),
+ if (valid?) float->percentage(time-diff) else "N/A" end,
+ if (valid?) float->percentage(space-diff) else "N/A" end);
+ if (valid?)
+ best-time-diff := min(best-time-diff, time-diff);
+ worst-time-diff := max(worst-time-diff, time-diff);
+ best-alloc-diff := min(best-alloc-diff, space-diff);
+ worst-alloc-diff := max(worst-alloc-diff, space-diff);
+ else
+ crashes := crashes + 1;
+ end if;
+ end;
+ for (subresult in comparison-subresults(result))
+ print-one(subresult)
+ end;
+ end method;
+ print-one(top-result);
+ if (any-displayed?)
+ print-benchmark-result-footer("Worst regression:",
+ float->percentage(best-time-diff),
+ float->percentage(best-alloc-diff),
+ 0);
+ print-benchmark-result-footer("Best improvement:",
+ float->percentage(worst-time-diff),
+ float->percentage(worst-alloc-diff),
+ crashes, divider?: #f);
+ else
+ format-out("*** No benchmark results differed by more than %d%%.\n",
+ *benchmark-tolerance*);
+ end if;
+end method benchmark-diff-report-function;
+
Added: trunk/libraries/programming-tools/testworks-report/start.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-report/start.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,23 @@
+Module: testworks-report
+Synopsis: A tool to generate reports from test run logs
+Author: Shri Amit, Andy Armstrong
+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
+
+define method application-error
+ (error-name :: <symbol>, format-string :: <string>, #rest args)
+ format-out("\n");
+ apply(format-out, format-string, args);
+ format-out("\nUse %s -help for help on arguments.\n", application-name());
+ exit-application(application-exit-code(error-name))
+end method application-error;
+
+// Just start it up
+
+begin
+ main(application-name(), application-arguments());
+end;
+
Added: trunk/libraries/programming-tools/testworks-report/test-diff.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-report/test-diff.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,193 @@
+Module: testworks-report
+Synopsis: A tool to generate reports from test run logs
+Author: Shri Amit, Andy Armstrong
+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
+
+define constant $default-benchmark-tolerance :: <integer>
+ = 2; // i.e., 2% change from comparison benchmark
+
+define thread variable *benchmark-tolerance* :: <integer>
+ = $default-benchmark-tolerance;
+
+/// Comparison result class
+
+define class <comparison-result> (<object>)
+ constant slot comparison-identical? :: <boolean>,
+ required-init-keyword: identical?:;
+ constant slot comparison-result1 :: false-or(<result>),
+ required-init-keyword: result1:;
+ constant slot comparison-result2 :: false-or(<result>),
+ required-init-keyword: result2:;
+ constant slot comparison-subresults :: <sequence> = make(<stretchy-vector>),
+ init-keyword: subresults:;
+end class <comparison-result>;
+
+
+/// Comparison of two test run logs
+
+define method equivalent
+ (result1 :: false-or(<result>), result2 :: false-or(<result>))
+ => (boolean :: <boolean>)
+ result1
+ & result2
+ & object-class(result1) = object-class(result2)
+ & result1 = result2
+end method equivalent;
+
+define sideways method \=
+ (result1 :: <benchmark-result>, result2 :: <benchmark-result>)
+ => (equal? :: <boolean>)
+ next-method()
+ & begin
+ let (time-diff, space-diff, valid?)
+ = diff-benchmark-results(result1, result2);
+ // Note that the use of < here rather than <= is mostly so that a tolerance
+ // of 0 will show all benchmark results, even those that haven't changed at all.
+ abs(time-diff) < *benchmark-tolerance*
+ & abs(space-diff) < *benchmark-tolerance*
+ end
+end method \=;
+
+define method diff-benchmark-results
+ (result1 :: <benchmark-result>, result2 :: <benchmark-result>)
+ => (time-diff :: <float>, space-diff :: <float>, valid? :: <boolean>)
+ let sec1 = result1.result-seconds;
+ let sec2 = result2.result-seconds;
+ let usec1 = result1.result-microseconds;
+ let usec2 = result2.result-microseconds;
+ let bytes1 = result1.result-bytes;
+ let bytes2 = result2.result-bytes;
+ if (sec1 & sec2 & usec1 & usec2 & bytes1 & bytes2)
+ values(percent-change(1e6 * sec1 + usec1, 1e6 * sec2 + usec2),
+ percent-change(as(<float>, bytes1), as(<float>, bytes2)),
+ #t)
+ else
+ // +++ Note that if all slot values were #f we get here. Technically I
+ // suppose the benchmarks are the same if that's the case...
+ values(0.0, 0.0, #f)
+ end if
+end method diff-benchmark-results;
+
+// Returns b as a relative percentage of a. For example, if a = 9 and b = 10,
+// then it returns 10 because b is 10% more than a. If a = 10 and b = 9 then
+// it returns -11 because b is 11% less than a.
+define function percent-change
+ (a :: <float>, b :: <float>) => (percent-change :: <float>)
+ 100 * (1 - a / b)
+end;
+
+define method result<
+ (result1 :: <result>, result2 :: <result>) => (less-than? :: <boolean>)
+ result1.result-name < result2.result-name
+end method result<;
+
+define method compare-subresults
+ (subresults1 :: <sequence>, subresults2 :: <sequence>)
+ => (comp-results :: <sequence>)
+ let subresults1 = sort(subresults1, test: result<);
+ let subresults2 = sort(subresults2, test: result<);
+ let comp-results = make(<stretchy-vector>);
+ let size1 = subresults1.size;
+ let size2 = subresults2.size;
+ let index1 :: <integer> = 0;
+ let index2 :: <integer> = 0;
+
+ while (index1 < size1 & index2 < size2)
+ let subresult1 :: <result> = subresults1[index1];
+ let subresult2 :: <result> = subresults2[index2];
+ let name1 = subresult1.result-name;
+ let name2 = subresult2.result-name;
+ case
+ name1 = name2 =>
+ add!(comp-results, create-comparison-result(subresult1, subresult2));
+ index1 := index1 + 1;
+ index2 := index2 + 1;
+ name1 < name2 =>
+ add!(comp-results, create-comparison-result(subresult1, #f));
+ index1 := index1 + 1;
+ otherwise =>
+ add!(comp-results, create-comparison-result(#f, subresult2));
+ index2 := index2 + 1;
+ end;
+ end;
+
+ for (index from index1 below size1)
+ add!(comp-results, create-comparison-result(subresults1[index], #f))
+ end;
+ for (index from index2 below size2)
+ add!(comp-results, create-comparison-result(#f, subresults2[index]))
+ end;
+
+ comp-results
+end method compare-subresults;
+
+
+define method compare-results
+ (result1 :: false-or(<result>), result2 :: false-or(<result>))
+ => (identical? :: <boolean>, subresults :: <sequence>)
+ let result1-component? = instance?(result1, <component-result>);
+ let result2-component? = instance?(result2, <component-result>);
+ let subresults
+ = case
+ result1-component? & result2-component? =>
+ compare-subresults(result1.result-subresults, result2.result-subresults);
+ result1-component? =>
+ compare-subresults(result1.result-subresults, #[]);
+ result2-component? =>
+ compare-subresults(#[], result2.result-subresults);
+ otherwise =>
+ #[]
+ end;
+ let identical?
+ = every?(method (subresult)
+ subresult.comparison-identical?
+ end,
+ subresults)
+ & equivalent(result1, result2);
+ values(identical?, subresults)
+end method compare-results;
+
+define method create-comparison-result
+ (result1 :: false-or(<result>), result2 :: false-or(<result>))
+ => (comp-result :: <comparison-result>)
+ let (identical?, subresults) = compare-results(result1, result2);
+ make(<comparison-result>,
+ result1: result1, result2: result2,
+ identical?: identical?, subresults: subresults)
+end method create-comparison-result;
+
+define method create-comparison-result
+ (path1 :: <string>, path2 :: <string>)
+ => (comp-result :: <comparison-result>)
+ let result1 = read-log-file(path1);
+ let result2 = read-log-file(path2);
+ create-comparison-result(result1, result2)
+end method create-comparison-result;
+
+
+/// Test diff
+
+define class <log-comparison-result> (<comparison-result>)
+end class <log-comparison-result>;
+
+define method perform-test-diff
+ (#key log1, log2, result1, result2, report-function = diff-report-function,
+ tolerance :: <integer> = $default-benchmark-tolerance)
+ => ()
+ let result1 = result1 | read-log-file(log1);
+ let result2 = result2 | read-log-file(log2);
+ dynamic-bind(*benchmark-tolerance* = tolerance)
+ let (identical?, subresults) = compare-results(result1, result2);
+ let result = make(<log-comparison-result>,
+ result1: result1,
+ result2: result2,
+ identical?: identical?,
+ subresults: subresults);
+ report-function & report-function(result);
+ end;
+end method perform-test-diff;
+
Added: trunk/libraries/programming-tools/testworks-report/testworks-report.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-report/testworks-report.lid Fri Nov 24 06:49:51 2006
@@ -0,0 +1,19 @@
+Library: testworks-report
+Synopsis: A tool to generate reports from test run logs
+Author: Shri Amit, Andy Armstrong
+Target-Type: executable
+Files: library
+ initialize
+ log-reader
+ test-diff
+ reports
+ start
+Other-files: Open-Source-License.txt
+Major-Version: 2
+Minor-Version: 1
+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
+
Added: trunk/libraries/programming-tools/testworks-specs/Open-Source-License.txt
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-specs/Open-Source-License.txt Fri Nov 24 06:49:51 2006
@@ -0,0 +1,21 @@
+The contents of this library are subject to the Functional Objects Library
+Public License Version 1.0 (the "License"); you may not use this library
+except in compliance with the License. You may obtain a copy of the License
+at http://www.functionalobjects.com/licenses/library-public-license-1.0.txt
+
+Software distributed under the License is distributed on an "AS IS" basis,
+WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+for the specific language governing rights and limitations under the License.
+
+Original Code is Copyright (c) 1996-2004 Functional Objects, Inc.
+All rights reserved.
+
+Alternatively, the contents of this library may be used under the
+terms of the GNU Lesser General Public License (the "GLGPL"), in which
+case the provisions of the GLGPL are applicable instead of those above. If
+you wish to allow use of your version of this library only under the
+terms of the GLGPL and not to allow others to use your version of this
+library under the License, indicate your decision by deleting the provisions
+above and replace them with the notice and other provisions required
+by the GLGPL. If you do not delete the provisions above, a recipient
+may use your version of this library under either the License or the GLGPL.
Added: trunk/libraries/programming-tools/testworks-specs/class-specs.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-specs/class-specs.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,200 @@
+Module: testworks-specs
+Synopsis: A library for building specification test suites
+Author: Andy Armstrong
+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
+
+/// Class specs
+
+define class <class-spec> (<definition-spec>)
+ constant slot class-spec-class :: <class>,
+ required-init-keyword: class:;
+ constant slot class-spec-superclasses :: <sequence>,
+ required-init-keyword: superclasses:;
+ slot class-spec-modifiers :: <sequence> = #[],
+ init-keyword: modifiers:;
+end class <class-spec>;
+
+define method initialize (this :: <class-spec>, #key)
+ next-method();
+ let modifiers = this.class-spec-modifiers;
+ // Ensure no conflicting modifiers were specified.
+ if ((member?(#"sealed", modifiers) & member?(#"open", modifiers))
+ | (member?(#"primary", modifiers) & member?(#"free", modifiers))
+ | (member?(#"abstract", modifiers) & member?(#"concrete", modifiers)))
+ error("Conflicting modifiers specified for class %s",
+ this.class-spec-class);
+ end if;
+ // Classes are concrete by default.
+ if (~member?(#"abstract", modifiers) & ~member?("concrete", modifiers))
+ modifiers := add!(modifiers, #"concrete");
+ end if;
+ // Classes are free by default.
+ if (~member?(#"free", modifiers) & ~member?("primary", modifiers))
+ modifiers := add!(modifiers, #"free");
+ end if;
+ // Classes are sealed by default.
+ if (~member?(#"sealed", modifiers) & ~member?("open", modifiers))
+ modifiers := add!(modifiers, #"sealed");
+ end if;
+ this.class-spec-modifiers := modifiers;
+end method initialize;
+
+
+
+/// A useful macro to define the class specs
+
+define macro class-test-definer
+ { define ?protocol-name:name class-test ?class-name:name ()
+ ?body:body
+ end }
+ => { define ?protocol-name definition-test ?class-name () ?body end }
+end macro class-test-definer;
+
+
+/// Class spec modeling
+
+define method register-class
+ (spec :: <protocol-spec>, name :: <symbol>, binding-function :: <function>)
+ => ()
+ register-binding(protocol-class-bindings(spec), name, binding-function)
+end method register-class;
+
+define method protocol-classes
+ (spec :: <protocol-spec>) => (classes :: <table>)
+ protocol-bindings(protocol-class-bindings(spec))
+end method protocol-classes;
+
+define method protocol-unbound-classes
+ (spec :: <protocol-spec>) => (classes :: <sequence>)
+ protocol-unbound-bindings(protocol-class-bindings(spec))
+end method protocol-unbound-classes;
+
+define method protocol-definition-spec
+ (protocol-spec :: <protocol-spec>, class :: <class>)
+ => (class-spec :: false-or(<class-spec>))
+ element(protocol-classes(protocol-spec), class, default: #f)
+end method protocol-definition-spec;
+
+define method protocol-class-superclasses
+ (spec :: <protocol-spec>, class :: <class>) => (superclasses :: <sequence>)
+ let class-spec = protocol-definition-spec(spec, class);
+ class-spec-superclasses(class-spec)
+end method protocol-class-superclasses;
+
+define method protocol-class-modifiers
+ (spec :: <protocol-spec>, class :: <class>) => (modifiers :: <sequence>)
+ let class-spec = protocol-definition-spec(spec, class);
+ class-spec-modifiers(class-spec)
+end method protocol-class-modifiers;
+
+define method protocol-class-instantiable?
+ (spec :: <protocol-spec>, class :: <class>) => (instantiable? :: <boolean>)
+ member?(#"instantiable", protocol-class-modifiers(spec, class))
+// I deleted the following because it causes tests that initially fail
+// because the programmer failed to provide a make-test-instance method
+// to pass on subsequent test runs. -- carlg
+// & begin
+// let info = protocol-class-bindings(spec);
+// ~member?(class, protocol-uninstantiable-classes(info))
+// end
+end method protocol-class-instantiable?;
+
+define method protocol-class-abstract?
+ (spec :: <protocol-spec>, class :: <class>)
+ => (abstract? :: <boolean>)
+ member?(#"abstract", protocol-class-modifiers(spec, class))
+end method protocol-class-abstract?;
+
+define method do-protocol-classes
+ (function :: <function>, spec :: <protocol-spec>,
+ #key superclass :: <class> = <object>)
+ => ()
+ do-protocol-definitions
+ (method (class-spec :: <class-spec>) => ()
+ let class = class-spec-class(class-spec);
+ if (subtype?(class, superclass))
+ function(class)
+ end
+ end,
+ spec, <class-spec>)
+end method do-protocol-classes;
+
+
+/// Class checking
+
+define method check-protocol-class
+ (protocol-spec :: <protocol-spec>, class-spec :: <class-spec>) => ()
+ let title = spec-title(class-spec);
+ let class = class-spec-class(class-spec);
+ with-test-unit (format-to-string("%s tests", title))
+ check-instance?(format-to-string("Variable %s is a class", title),
+ <class>, class);
+ check-true(format-to-string("Variable %s has the correct superclasses", title),
+ protocol-class-has-correct-superclasses?(protocol-spec, class));
+ check-protocol-class-instantiation(protocol-spec, class-spec);
+ test-protocol-definition
+ (protocol-spec, spec-name(protocol-spec), spec-name(class-spec))
+ end
+end method check-protocol-class;
+
+define function check-protocol-classes
+ (protocol-spec :: <protocol-spec>) => ()
+ do-protocol-definitions
+ (curry(check-protocol-class, protocol-spec),
+ protocol-spec, <class-spec>);
+ do(method (class-name :: <string>) => ()
+ check-true(format-to-string("The variable %s is a class", class-name), #f)
+ end,
+ protocol-unbound-classes(protocol-spec));
+end function check-protocol-classes;
+
+define method protocol-class-has-correct-superclasses?
+ (spec :: <protocol-spec>, class :: <class>) => (correct? :: <boolean>)
+ every?(method (superclass :: <class>) => (subtype? :: <boolean>)
+ subtype?(class, superclass)
+ end,
+ protocol-class-superclasses(spec, class))
+end method protocol-class-has-correct-superclasses?;
+
+
+/// Class instantiation checks
+
+define method make-test-instance
+ (class :: <class>) => (object)
+ make(class)
+end method make-test-instance;
+
+define method destroy-test-instance
+ (class :: <class>, object :: <object>) => ()
+ #f
+end method destroy-test-instance;
+
+define method check-protocol-class-instantiation
+ (spec :: <protocol-spec>, class-spec :: <class-spec>) => ()
+ let class = class-spec-class(class-spec);
+ let title = spec-title(class-spec);
+ if (protocol-class-instantiable?(spec, class))
+ let instance = #f;
+ check-instance?(format-to-string("make %s with required arguments", title),
+ class,
+ instance := make-test-instance(class));
+ if (instance)
+ destroy-test-instance(class, instance)
+ else
+ let info = protocol-class-bindings(spec);
+ add!(protocol-uninstantiable-classes(info), class)
+ end
+ else
+ check-condition
+ (format-to-string("make(%s) errors because not instantiable", title),
+ <error>,
+ begin
+ let instance = make-test-instance(class);
+ destroy-test-instance(class, instance)
+ end)
+ end
+end method check-protocol-class-instantiation;
Added: trunk/libraries/programming-tools/testworks-specs/function-specs.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-specs/function-specs.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,132 @@
+Module: testworks-specs
+Synopsis: A library for building specification test suites
+Author: Andy Armstrong
+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
+
+/// Function specs
+
+define class <function-spec> (<definition-spec>)
+ constant slot function-spec-function :: <function>,
+ required-init-keyword: function:;
+ constant slot function-spec-modifiers :: <sequence> = #[],
+ init-keyword: modifiers:;
+ //---*** Not used yet...
+ // constant slot function-spec-parameters :: <sequence> = #[],
+ // init-keyword: parameters:;
+ // constant slot function-spec-results :: <sequence> = #[],
+ // init-keyword: results:;
+end class <function-spec>;
+
+
+/// A useful macro to define the function specs
+
+define macro function-test-definer
+ { define ?protocol-name:name function-test ?function-name:name ()
+ ?body:body
+ end }
+ => { define ?protocol-name definition-test ?function-name () ?body end }
+end macro function-test-definer;
+
+
+/// Function spec modeling
+
+define method register-function
+ (spec :: <protocol-spec>, name :: <symbol>, binding-function :: <function>)
+ => ()
+ register-binding(protocol-function-bindings(spec), name, binding-function)
+end method register-function;
+
+define method protocol-functions
+ (spec :: <protocol-spec>) => (classes :: <table>)
+ protocol-bindings(protocol-function-bindings(spec))
+end method protocol-functions;
+
+define method protocol-unbound-functions
+ (spec :: <protocol-spec>) => (functions :: <sequence>)
+ protocol-unbound-bindings(protocol-function-bindings(spec))
+end method protocol-unbound-functions;
+
+define method protocol-definition-spec
+ (protocol-spec :: <protocol-spec>, function :: <function>)
+ => (function-spec :: false-or(<function-spec>))
+ element(protocol-functions(protocol-spec), function, default: #f)
+end method protocol-definition-spec;
+
+define method protocol-function-modifiers
+ (spec :: <protocol-spec>, function :: <function>)
+ => (modifiers :: <sequence>)
+ let function-spec = protocol-definition-spec(spec, function);
+ function-spec-modifiers(function-spec)
+end method protocol-function-modifiers;
+
+/*--- Not used yet
+define method protocol-function-parameters
+ (spec :: <protocol-spec>, function :: <function>)
+ => (parameters :: <sequence>)
+ let function-spec = protocol-definition-spec(spec, function);
+ function-spec-parameters(function-spec)
+end method protocol-function-parameters;
+
+define method protocol-function-results
+ (spec :: <protocol-spec>, function :: <function>)
+ => (results :: <sequence>)
+ let function-spec = protocol-definition-spec(spec, function);
+ function-spec-results(function-spec)
+end method protocol-function-results;
+*/
+
+define method protocol-function-generic?
+ (spec :: <protocol-spec>, function :: <function>)
+ => (generic? :: <boolean>)
+ member?(#"generic", protocol-function-modifiers(spec, function))
+end method protocol-function-generic?;
+
+define function protocol-function-type
+ (protocol-spec :: <protocol-spec>, function :: <function>)
+ => (type :: <type>, type-name :: <string>)
+ if (protocol-function-generic?(protocol-spec, function))
+ values(<generic-function>, "generic-function")
+ else
+ values(<function>, "function")
+ end
+end function protocol-function-type;
+
+// Yes this check name is verbose, but it aids in debugging testworks-specs tests.
+define function protocol-function-check-name
+ (function-name :: <string>, type-name :: <string>)
+ => (check-name :: <string>)
+ format-to-string("Variable %s is a %s and all of its specializer types are bound",
+ function-name, type-name)
+end function protocol-function-check-name;
+
+define function check-protocol-function
+ (protocol-spec :: <protocol-spec>, function-spec :: <function-spec>)
+ => ()
+ let title = spec-title(function-spec);
+ let function = function-spec-function(function-spec);
+ with-test-unit (format-to-string("%s tests", title))
+ let (type, type-name) = protocol-function-type(protocol-spec, function);
+ check-instance?(protocol-function-check-name(title, type-name),
+ type, function);
+ test-protocol-definition
+ (protocol-spec, spec-name(protocol-spec), spec-name(function-spec))
+ end
+end function check-protocol-function;
+
+define function check-protocol-functions
+ (protocol-spec :: <protocol-spec>) => ()
+ do-protocol-definitions
+ (curry(check-protocol-function, protocol-spec),
+ protocol-spec, <function-spec>);
+ do(method (function-name)
+ // This function is unbound; its type can't be determined so
+ // just say it's a "function".
+ let name = protocol-function-check-name(function-name, "function");
+ check-true(name, #f)
+ end,
+ protocol-unbound-functions(protocol-spec))
+end function check-protocol-functions;
Added: trunk/libraries/programming-tools/testworks-specs/library.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-specs/library.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,75 @@
+Module: dylan-user
+Synopsis: A library for building specification test suites
+Author: Andy Armstrong
+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
+
+define library testworks-specs
+ use common-dylan;
+ use testworks;
+
+ export testworks-specs;
+end library testworks-specs;
+
+define module testworks-specs
+ use common-dylan;
+ use testworks;
+
+ // The macros
+ export \library-spec-definer,
+ \module-spec-definer,
+ \protocol-spec-definer,
+ \definition-test-definer,
+ \constant-test-definer,
+ \variable-test-definer,
+ \class-test-definer,
+ \function-test-definer,
+ \macro-test-definer;
+
+ // The classes
+ export <spec>,
+ <protocol-spec>,
+ <definition-spec>,
+ <constant-spec>,
+ <variable-spec>,
+ <class-spec>,
+ <function-spec>,
+ <macro-spec>;
+
+ // Useful accessors
+ export spec-name,
+ spec-title,
+ protocol-definition-spec;
+
+ // The test functions
+ export make-test-instance,
+ destroy-test-instance,
+ test-protocol-definition,
+ class-test-function,
+ do-protocol-classes,
+ check-protocol-constants,
+ check-protocol-variables,
+ check-protocol-classes,
+ check-protocol-functions,
+ check-protocol-macros;
+
+ // Class handling functions
+ export do-protocol-classes,
+ protocol-class-abstract?,
+ protocol-class-instantiable?;
+
+ //---*** Hygiene glitches
+ export \protocol-spec-constant-definer,
+ \protocol-spec-bindings-definer,
+ \protocol-spec-suite-definer,
+ \module-spec-protocol-definer,
+ \module-spec-suite-definer,
+ register-constant,
+ register-variable,
+ register-class,
+ register-function,
+ register-macro;
+end module testworks-specs;
Added: trunk/libraries/programming-tools/testworks-specs/macro-specs.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-specs/macro-specs.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,51 @@
+Module: testworks-specs
+Synopsis: A library for building specification test suites
+Author: Andy Armstrong
+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
+
+/// Macro specs
+
+define class <macro-spec> (<definition-spec>)
+end class <macro-spec>;
+
+
+/// A useful macro to define a macro test
+
+define macro macro-test-definer
+ { define ?protocol-name:name macro-test ?macro-name:name ()
+ ?body:body
+ end }
+ => { define ?protocol-name definition-test ?macro-name () ?body end }
+end macro macro-test-definer;
+
+
+/// Macro spec modeling
+
+define method register-macro
+ (spec :: <protocol-spec>, name :: <symbol>)
+ => ()
+ register-definition(spec, name, make(<macro-spec>, name: name))
+end method register-macro;
+
+
+/// Macro testing
+
+define method check-protocol-macro
+ (protocol-spec :: <protocol-spec>, macro-spec :: <macro-spec>) => ()
+ let title = spec-title(macro-spec);
+ with-test-unit (format-to-string("%s tests", title))
+ test-protocol-definition
+ (protocol-spec, spec-name(protocol-spec), spec-name(macro-spec))
+ end
+end method check-protocol-macro;
+
+define method check-protocol-macros
+ (protocol-spec :: <protocol-spec>) => ()
+ do-protocol-definitions
+ (curry(check-protocol-macro, protocol-spec),
+ protocol-spec, <macro-spec>)
+end method check-protocol-macros;
Added: trunk/libraries/programming-tools/testworks-specs/module-specs.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-specs/module-specs.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,81 @@
+Module: testworks-specs
+Synopsis: A library for building specification test suites
+Author: Andy Armstrong
+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
+
+/// A useful macro to define module specs
+
+define macro module-spec-definer
+ { define module-spec ?module-name:name (?options:*)
+ ?specs:*
+ end}
+ => { define module-spec-protocol ?module-name ()
+ ?specs
+ end;
+ define module-spec-suite ?module-name ()
+ ?specs
+ end;
+ }
+end macro module-spec-definer;
+
+define macro module-spec-protocol-definer
+ { define module-spec-protocol ?module-name:name (?options:*)
+ ?specs:*
+ end }
+ => { define protocol-spec ?module-name (?options)
+ ?specs
+ end }
+ specs:
+ { } => { }
+ { ?spec:*; ... } => { ?spec ... }
+ spec:
+ { protocol ?protocol-name:name }
+ => { }
+ { ?definition:* }
+ => { ?definition; }
+end macro module-spec-protocol-definer;
+
+define macro module-spec-suite-definer
+ { define module-spec-suite ?module-name:name (?options:*)
+ ?specs:*
+ end }
+ => { define suite ?module-name ## "-module-test-suite" (?options)
+ suite ?module-name ## "-protocol-test-suite";
+ ?specs
+ end }
+ specs:
+ { } => { }
+ { ?spec:*; ... } => { ?spec ... }
+ spec:
+ { protocol ?protocol-name:name }
+ => { suite ?protocol-name ## "-protocol-test-suite"; }
+ { ?definition:* }
+ => { }
+end macro module-spec-suite-definer;
+
+
+/// Library specs
+
+// Like the "define suite" macro, but allows clauses like "module foo;"
+// in its body which expand to "suite foo-module-test-suite".
+define macro library-spec-definer
+ { define library-spec ?library-name:name (?options:*)
+ ?subsuites:*
+ end}
+ => { define suite ?library-name ## "-test-suite" (?options)
+ ?subsuites
+ end
+ }
+ subsuites:
+ { } => { }
+ { ?thing; ... } => { ?thing; ... }
+ thing:
+ { module ?module-name:name }
+ => { suite ?module-name ## "-module-test-suite" }
+ { ?x:* } => { ?x }
+end macro library-spec-definer;
+
Added: trunk/libraries/programming-tools/testworks-specs/protocol-specs.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-specs/protocol-specs.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,338 @@
+Module: testworks-specs
+Synopsis: A library for building specification test suites
+Author: Andy Armstrong
+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
+
+/// Protocol bindings modeling
+
+define class <protocol-bindings-info> (<object>)
+ constant slot names = make(<stretchy-vector>);
+ constant slot protocol-binding-functions = make(<stretchy-vector>);
+ slot %unbound-bindings :: false-or(<sequence>) = #f;
+ slot %definitions :: false-or(<table>) = #f;
+end class <protocol-bindings-info>;
+
+define class <protocol-class-bindings-info> (<protocol-bindings-info>)
+ constant slot protocol-uninstantiable-classes = make(<stretchy-vector>);
+end class <protocol-class-bindings-info>;
+
+define method evaluate-bindings
+ (info :: <protocol-bindings-info>)
+ => (bindings :: <table>, unbound-bindings :: <sequence>)
+ let table = make(<table>);
+ let unbound-bindings = make(<stretchy-vector>);
+ for (name in info.names, function in info.protocol-binding-functions)
+ let (value, spec)
+ = block ()
+ function();
+ exception (<error>)
+ add!(unbound-bindings, as-lowercase(as(<byte-string>, name)));
+ #f
+ end;
+ if (value)
+ table[value] := spec;
+ end
+ end;
+ values(table, unbound-bindings)
+end method evaluate-bindings;
+
+define method update-bindings
+ (info :: <protocol-bindings-info>) => ()
+ let (bindings, unbound-bindings) = evaluate-bindings(info);
+ info.%unbound-bindings := unbound-bindings;
+ info.%definitions := bindings
+end method update-bindings;
+
+define method protocol-bindings
+ (info :: <protocol-bindings-info>) => (bindings :: <table>)
+ info.%definitions
+ | begin
+ update-bindings(info);
+ info.%definitions
+ end
+end method protocol-bindings;
+
+define method protocol-unbound-bindings
+ (info :: <protocol-bindings-info>) => (bindings :: <sequence>)
+ info.%unbound-bindings
+ | begin
+ update-bindings(info);
+ info.%unbound-bindings
+ end
+end method protocol-unbound-bindings;
+
+define method register-binding
+ (info :: <protocol-bindings-info>, name :: <symbol>,
+ binding-function :: <function>)
+ => ()
+ add!(info.names, name);
+ add!(info.protocol-binding-functions, binding-function);
+ // Clear the caches so that they get recomputed
+ info.%unbound-bindings := #f;
+ info.%definitions := #f;
+end method register-binding;
+
+
+/// Protocol specs modeling
+
+define class <protocol-spec> (<spec>)
+ constant slot protocol-class-bindings = make(<protocol-class-bindings-info>);
+ constant slot protocol-function-bindings = make(<protocol-bindings-info>);
+ constant slot %definitions :: <table> = make(<table>);
+end class <protocol-spec>;
+
+define function protocol-definitions
+ (spec :: <protocol-spec>) => (definitions :: <table>)
+ let definitions = spec.%definitions;
+ let class-bindings = protocol-class-bindings(spec);
+ unless (class-bindings.%definitions)
+ let class-definitions = protocol-bindings(class-bindings);
+ do(method (definition-spec)
+ definitions[spec-name(definition-spec)] := definition-spec
+ end,
+ class-definitions)
+ end;
+ let function-bindings = protocol-function-bindings(spec);
+ unless (function-bindings.%definitions)
+ let function-definitions = protocol-bindings(function-bindings);
+ do(method (definition-spec)
+ definitions[spec-name(definition-spec)] := definition-spec
+ end,
+ function-definitions)
+ end;
+ definitions
+end function protocol-definitions;
+
+define method protocol-definition-spec
+ (protocol-spec :: <protocol-spec>, name :: <symbol>)
+ => (definition :: false-or(<definition-spec>))
+ let definitions = protocol-definitions(protocol-spec);
+ element(definitions, name, default: #f)
+end method protocol-definition-spec;
+
+define function do-protocol-definitions
+ (function :: <function>, spec :: <protocol-spec>, type :: <type>) => ()
+ do(method (binding)
+ when (instance?(binding, type))
+ function(binding)
+ end
+ end,
+ protocol-definitions(spec))
+end function do-protocol-definitions;
+
+define method register-definition
+ (spec :: <protocol-spec>, name :: <symbol>,
+ definition :: <definition-spec>)
+ => ()
+ let table = spec.%definitions;
+ table[name] := definition
+end method register-definition;
+
+
+/// A useful macro to define protocol specs
+
+define macro protocol-spec-definer
+ { define protocol-spec ?protocol-name:name (?options:*)
+ ?specs:*
+ end}
+ => { define protocol-spec-constant ?protocol-name (?options)
+ end;
+ define protocol-spec-bindings "$" ## ?protocol-name ## "-protocol-spec" (?options)
+ ?specs
+ end;
+ define protocol-spec-suite ?protocol-name => "$" ## ?protocol-name ## "-protocol-spec" end;
+ }
+end macro protocol-spec-definer;
+
+define macro protocol-spec-constant-definer
+ { define protocol-spec-constant ?protocol-name:name (?options:*) end}
+ => { define constant "$" ## ?protocol-name ## "-protocol-spec"
+ = make(<protocol-spec>,
+ name: ?#"protocol-name",
+ ?options) }
+end macro protocol-spec-constant-definer;
+
+define macro protocol-spec-bindings-definer
+ { define protocol-spec-bindings ?protocol-constant:name (?options:*)
+ end }
+ => { }
+ { define protocol-spec-bindings ?protocol-constant:name (?options:*)
+ ?modifiers:* class ?class-name:name (?superclasses:*);
+ ?more-specs:*
+ end }
+ => { register-class
+ (?protocol-constant,
+ ?#"class-name",
+ method ()
+ values(?class-name,
+ make(<class-spec>,
+ name: ?#"class-name",
+ class: ?class-name,
+ superclasses: vector(?superclasses),
+ modifiers: vector(?modifiers)))
+ end);
+ define protocol-spec-bindings ?protocol-constant (?options)
+ ?more-specs
+ end; }
+ { define protocol-spec-bindings ?protocol-constant:name (?options:*)
+ ?modifiers:* function ?function-name:name (?parameters:*) => (?results:*);
+ ?more-specs:*
+ end }
+ => { register-function
+ (?protocol-constant,
+ ?#"function-name",
+ method ()
+ values(?function-name,
+ make(<function-spec>,
+ name: ?#"function-name",
+ function: ?function-name,
+ parameters: vector(?parameters),
+ results: vector(?results),
+ modifiers: vector(?modifiers)))
+ end);
+ define protocol-spec-bindings ?protocol-constant (?options)
+ ?more-specs
+ end; }
+ { define protocol-spec-bindings ?protocol-constant:name (?options:*)
+ ?modifiers:* generic-function ?function-name:name (?parameters:*) => (?results:*);
+ ?more-specs:*
+ end }
+ => { register-function
+ (?protocol-constant,
+ ?#"function-name",
+ method ()
+ values(?function-name,
+ make(<function-spec>,
+ name: ?#"function-name",
+ function: ?function-name,
+ parameters: vector(?parameters),
+ results: vector(?results),
+ modifiers: vector(#"generic", ?modifiers)))
+ end);
+ define protocol-spec-bindings ?protocol-constant (?options)
+ ?more-specs
+ end; }
+ { define protocol-spec-bindings ?protocol-constant:name (?options:*)
+ ?modifiers:* variable ?variable-name:name :: ?type:expression;
+ ?more-specs:*
+ end }
+ => { register-variable
+ (?protocol-constant,
+ ?#"variable-name",
+ ?type,
+ method () => (value :: ?type)
+ ?variable-name
+ end,
+ method (value :: ?type) => (value :: ?type)
+ ?variable-name := value
+ end);
+ define protocol-spec-bindings ?protocol-constant (?options)
+ ?more-specs
+ end; }
+ { define protocol-spec-bindings ?protocol-constant:name (?options:*)
+ ?modifiers:* constant ?constant-name:name :: ?type:expression;
+ ?more-specs:*
+ end }
+ => { register-constant
+ (?protocol-constant,
+ ?#"constant-name",
+ ?type,
+ method () ?constant-name end);
+ define protocol-spec-bindings ?protocol-constant (?options)
+ ?more-specs
+ end; }
+ { define protocol-spec-bindings ?protocol-constant:name (?options:*)
+ ?modifiers:* macro-test ?macro-name:name;
+ ?more-specs:*
+ end }
+ => { register-macro(?protocol-constant, ?#"macro-name");
+ define protocol-spec-bindings ?protocol-constant (?options)
+ ?more-specs
+ end; }
+ modifiers:
+ { }
+ => { }
+ { ?modifier:name ... }
+ => { ?#"modifier", ... }
+end macro protocol-spec-bindings-definer;
+
+define macro protocol-spec-suite-definer
+ { define protocol-spec-suite ?protocol-name:name => ?spec:name end }
+ => { define test ?protocol-name ## "-protocol-classes-test" ()
+ check-protocol-classes(?spec)
+ end;
+ define test ?protocol-name ## "-protocol-functions-test" ()
+ check-protocol-functions(?spec)
+ end;
+ define test ?protocol-name ## "-protocol-variables-test" ()
+ check-protocol-variables(?spec)
+ end;
+ define test ?protocol-name ## "-protocol-constants-test" ()
+ check-protocol-constants(?spec)
+ end;
+ define test ?protocol-name ## "-protocol-macros-test" ()
+ check-protocol-macros(?spec)
+ end;
+ define suite ?protocol-name ## "-protocol-test-suite" ()
+ test ?protocol-name ## "-protocol-constants-test";
+ test ?protocol-name ## "-protocol-variables-test";
+ test ?protocol-name ## "-protocol-classes-test";
+ test ?protocol-name ## "-protocol-functions-test";
+ test ?protocol-name ## "-protocol-macros-test";
+ end }
+end macro protocol-spec-suite-definer;
+
+
+/// A useful macro to define a definition's test function
+
+define open generic test-protocol-definition
+ (protocol :: <protocol-spec>, protocol-name :: <symbol>,
+ definition-name :: <symbol>)
+ => ();
+
+define method test-protocol-definition
+ (spec :: <protocol-spec>, protocol-name :: <symbol>,
+ definition-name :: <symbol>)
+ => ()
+ ignore(protocol-name);
+ let definition-spec = protocol-definition-spec(spec, definition-name);
+ assert(definition-spec,
+ "Attempting to test definition %s which is not part of protocol %s",
+ definition-name, protocol-name);
+ let tested?
+ = if (instance?(definition-spec, <class-spec>))
+ let class = class-spec-class(definition-spec);
+ let test-function = class-test-function(class);
+ if (test-function)
+ let instantiable? = protocol-class-instantiable?(spec, class);
+ let abstract? = protocol-class-abstract?(spec, class);
+ test-function(class,
+ name: spec-title(definition-spec),
+ abstract?: abstract?,
+ instantiable?: instantiable?);
+ #t
+ end
+ end;
+ unless (tested?)
+ cerror("Continue past this testing unit",
+ "No test function provided for definition %s",
+ spec-title(definition-spec))
+ end
+end method test-protocol-definition;
+
+define macro definition-test-definer
+ { define ?protocol-name:name definition-test ?definition-name:name ()
+ ?body:body
+ end }
+ => { define sideways method test-protocol-definition
+ (protocol :: <protocol-spec>,
+ protocol-name == ?#"protocol-name",
+ definition == ?#"definition-name")
+ => ()
+ ?body
+ end method test-protocol-definition }
+end macro definition-test-definer;
Added: trunk/libraries/programming-tools/testworks-specs/specs.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-specs/specs.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,40 @@
+Module: testworks-specs
+Synopsis: A library for building specification test suites
+Author: Andy Armstrong
+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
+
+/// Specification modeling
+
+define abstract class <spec> (<object>)
+ constant slot spec-name :: <symbol>,
+ required-init-keyword: name:;
+end class <spec>;
+
+define abstract class <definition-spec> (<spec>)
+end class <definition-spec>;
+
+define method spec-title
+ (spec :: <spec>) => (title :: <byte-string>)
+ as-lowercase(as(<byte-string>, spec-name(spec)))
+end method spec-title;
+
+
+/// Protocols
+
+define open generic make-test-instance
+ (class :: <class>) => (object);
+
+define open generic destroy-test-instance
+ (class :: <class>, object :: <object>) => ();
+
+define open generic class-test-function
+ (class :: <class>) => (test-function :: false-or(<function>));
+
+define method class-test-function
+ (class :: <class>) => (test-function :: false-or(<function>))
+ #f
+end method class-test-function;
Added: trunk/libraries/programming-tools/testworks-specs/testworks-specs.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-specs/testworks-specs.lid Fri Nov 24 06:49:51 2006
@@ -0,0 +1,21 @@
+Library: testworks-specs
+Synopsis: A library for building specification test suites
+Author: Andy Armstrong
+Target-Type: dll
+Files: library
+ specs
+ protocol-specs
+ module-specs
+ variable-specs
+ class-specs
+ function-specs
+ macro-specs
+Other-files: Open-Source-License.txt
+Major-Version: 2
+Minor-Version: 1
+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
+
Added: trunk/libraries/programming-tools/testworks-specs/variable-specs.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-specs/variable-specs.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,114 @@
+Module: testworks-specs
+Synopsis: A library for building specification test suites
+Author: Andy Armstrong
+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
+
+/// Variable specs
+
+define abstract class <abstract-variable-spec> (<definition-spec>)
+ constant slot variable-spec-type :: <type>,
+ required-init-keyword: type:;
+ constant slot variable-spec-getter :: <function>,
+ required-init-keyword: getter:;
+end class <abstract-variable-spec>;
+
+define class <variable-spec> (<abstract-variable-spec>)
+ constant slot variable-spec-setter :: <function>,
+ required-init-keyword: setter:;
+end class <variable-spec>;
+
+define class <constant-spec> (<abstract-variable-spec>)
+end class <constant-spec>;
+
+
+/// A useful macro to define the class specs
+
+define macro variable-test-definer
+ { define ?protocol-name:name variable-test ?variable-name:name ()
+ ?body:body
+ end }
+ => { define ?protocol-name definition-test ?variable-name () ?body end }
+end macro variable-test-definer;
+
+define macro constant-test-definer
+ { define ?protocol-name:name constant-test ?constant-name:name ()
+ ?body:body
+ end }
+ => { define ?protocol-name definition-test ?constant-name () ?body end }
+end macro constant-test-definer;
+
+
+/// Variable spec modeling
+
+define method register-variable
+ (spec :: <protocol-spec>, name :: <symbol>, type :: <type>,
+ variable-getter :: <function>, variable-setter :: <function>)
+ => ()
+ register-definition(spec, name,
+ make(<variable-spec>,
+ name: name,
+ type: type,
+ getter: variable-getter,
+ setter: variable-setter))
+end method register-variable;
+
+define method register-constant
+ (spec :: <protocol-spec>, name :: <symbol>, type :: <type>,
+ constant-getter :: <function>)
+ => ()
+ register-definition(spec, name,
+ make(<constant-spec>,
+ name: name,
+ type: type,
+ getter: constant-getter))
+end method register-constant;
+
+
+/// Variable testing
+
+define function check-protocol-variable
+ (protocol-spec :: <protocol-spec>, variable-spec :: <variable-spec>) => ()
+ let title = spec-title(variable-spec);
+ with-test-unit (format-to-string("%s tests", title))
+ check-instance?(format-to-string("Variable %s has the correct type", title),
+ variable-spec-type(variable-spec),
+ variable-spec-getter(variable-spec)());
+ check-true(format-to-string("Variable %s can be set to itself", title),
+ begin
+ let value = variable-spec-getter(variable-spec)();
+ variable-spec-setter(variable-spec)(value) = value
+ end);
+ test-protocol-definition
+ (protocol-spec, spec-name(protocol-spec), spec-name(variable-spec))
+ end
+end function check-protocol-variable;
+
+define function check-protocol-variables
+ (protocol-spec :: <protocol-spec>) => ()
+ do-protocol-definitions
+ (curry(check-protocol-variable, protocol-spec),
+ protocol-spec, <variable-spec>)
+end function check-protocol-variables;
+
+define function check-protocol-constant
+ (protocol-spec :: <protocol-spec>, constant :: <constant-spec>) => ()
+ let title = spec-title(constant);
+ with-test-unit (format-to-string("%s tests", title))
+ check-instance?(format-to-string("Constant %s has the correct type", title),
+ variable-spec-type(constant),
+ variable-spec-getter(constant)());
+ test-protocol-definition
+ (protocol-spec, spec-name(protocol-spec), spec-name(constant))
+ end
+end function check-protocol-constant;
+
+define function check-protocol-constants
+ (protocol-spec :: <protocol-spec>) => ()
+ do-protocol-definitions
+ (curry(check-protocol-constant, protocol-spec),
+ protocol-spec, <constant-spec>)
+end function check-protocol-constants;
Added: trunk/libraries/programming-tools/testworks-specs/win32-testworks-specs.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks-specs/win32-testworks-specs.lid Fri Nov 24 06:49:51 2006
@@ -0,0 +1,13 @@
+Library: testworks-specs
+Author: Andy Armstrong
+Synopsis: Win32 specific options for TestWorks Specs
+Executable: Dxtstspc
+Base-Address: 0x64B00000
+LID: testworks-specs.lid
+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
+Other-files: Open-Source-License.txt
+
Added: trunk/libraries/programming-tools/testworks/Open-Source-License.txt
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks/Open-Source-License.txt Fri Nov 24 06:49:51 2006
@@ -0,0 +1,21 @@
+The contents of this library are subject to the Functional Objects Library
+Public License Version 1.0 (the "License"); you may not use this library
+except in compliance with the License. You may obtain a copy of the License
+at http://www.functionalobjects.com/licenses/library-public-license-1.0.txt
+
+Software distributed under the License is distributed on an "AS IS" basis,
+WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+for the specific language governing rights and limitations under the License.
+
+Original Code is Copyright (c) 1996-2004 Functional Objects, Inc.
+All rights reserved.
+
+Alternatively, the contents of this library may be used under the
+terms of the GNU Lesser General Public License (the "GLGPL"), in which
+case the provisions of the GLGPL are applicable instead of those above. If
+you wish to allow use of your version of this library only under the
+terms of the GLGPL and not to allow others to use your version of this
+library under the License, indicate your decision by deleting the provisions
+above and replace them with the notice and other provisions required
+by the GLGPL. If you do not delete the provisions above, a recipient
+may use your version of this library under either the License or the GLGPL.
Added: trunk/libraries/programming-tools/testworks/benchmarks.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks/benchmarks.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,127 @@
+Module: testworks
+Synopsis: Testworks benchmarks
+Author: Carl Gay
+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
+
+/// Benchmarks
+
+/// Note that <benchmark-result> is defined in tests.dylan
+
+define macro benchmark
+ { benchmark (?benchmark-name:expression, ?benchmark:expression)
+ }
+ =>
+ { do-benchmark(method ()
+ ?benchmark-name
+ end,
+ method ()
+ vector(method ()
+ ?benchmark;
+ #t // Benchmarks succeed unless they crash. Reasonable???
+ end,
+ vector())
+ end)
+ }
+end macro benchmark;
+
+// ---*** carlg 99-02-05 This shares a lot of code with do-check. Might
+// want to try to combine them with a macro or something.
+define method do-benchmark
+ (name-function :: <function>, argument-function :: <function>)
+ => (status :: <result-status>)
+ block ()
+ let name = evaluate-name-function(name-function);
+ let bench-arguments = maybe-trap-errors(argument-function());
+ case
+ instance?(name, <error>) =>
+ record-benchmark("[*** Invalid name ***]", name, name, #f, #f, #f, #f);
+ instance?(bench-arguments, <error>) =>
+ record-benchmark(name, bench-arguments, bench-arguments, #f, #f, #f, #f);
+ otherwise =>
+ let function = bench-arguments[0];
+ let arguments = bench-arguments[1];
+ let result = #f;
+ let status = #f;
+ profiling (cpu-time-seconds, cpu-time-microseconds, allocation)
+ result := maybe-trap-errors(apply(function, arguments));
+ results
+ status := if (~result)
+ #"failed"
+ elseif (instance?(result, <error>))
+ result
+ else
+ #"passed"
+ end if;
+ if (status == #"failed" & debug-failures?())
+ break("Benchmark failed: %s", name)
+ end if;
+ record-benchmark(name, status, function, arguments,
+ cpu-time-seconds, cpu-time-microseconds, allocation);
+ end;
+ status
+ end case;
+ exception (r :: <simple-restart>,
+ init-arguments: vector(format-string:, "Skip this benchmark",
+ format-arguments:, #[]))
+ #"failed"
+ end block;
+end method do-benchmark;
+
+/// Benchmark recording
+
+define method record-benchmark
+ (name :: <string>,
+ status :: <result-status>,
+ operation :: <check-operation-type>,
+ value :: <check-value-type>,
+ seconds :: false-or(<integer>),
+ microseconds :: false-or(<integer>),
+ bytes-allocated :: false-or(<integer>))
+ => (status :: <result-status>)
+ let result = make(<benchmark-result>,
+ name: name, status: status, operation: operation, value: value,
+ seconds: seconds, microseconds: microseconds,
+ bytes: bytes-allocated);
+ *check-recording-function*(result);
+ status
+end method record-benchmark;
+
+
+/// A few utilities related to benchmarks
+
+define function time-to-string
+ (seconds :: false-or(<integer>), microseconds :: false-or(<integer>),
+ #key pad-seconds-to :: false-or(<integer>))
+ => (seconds :: <string>)
+ if (seconds & microseconds)
+ format-to-string("%s.%s",
+ integer-to-string(seconds, size: pad-seconds-to, fill: ' '),
+ integer-to-string(microseconds, size: 6))
+ else
+ "N/A"
+ end
+end;
+
+
+// Add two times that are encoded as seconds + microseconds.
+// Assumes the first time is valid. The second time may be #f.
+//
+define method addtimes
+ (sec1, usec1, sec2, usec2)
+ => (sec, usec)
+ if (sec2 & usec2)
+ let sec = sec1 + sec2;
+ let usec = usec1 + usec2;
+ if (usec >= 1000000)
+ usec := usec - 1000000;
+ sec1 := sec1 + 1;
+ end if;
+ values(sec, usec)
+ else
+ values(sec1, sec2)
+ end if
+end method addtimes;
Added: trunk/libraries/programming-tools/testworks/checks.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/programming-tools/testworks/checks.dylan Fri Nov 24 06:49:51 2006
@@ -0,0 +1,284 @@
+Module: testworks
+Synopsis: Testworks testing harness
+Author: Andrew Armstrong, James Kirsch
+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
+
+/// Check macros
+
+// Note that do-check and do-check-condition wrap up the real macro
+// arguments inside methods to delay their evaluation until they are
+// within the scope of whatever condition handling is required.
+
+define macro check
+ { check (?check-name:expression,
+ ?check-function:expression, ?check-args:*) }
+ => { do-check(method () ?check-name end,
+ method () vector(?check-function, vector(?check-args)) end) }
+end macro check;
+
+define macro check-equal
+ { check-equal (?check-name:expression,
+ ?expected-value:expression, ?actual-value:expression) }
+ => { do-check(method () ?check-name end,
+ method ()
+ vector(\=, vector(?expected-value, ?actual-value))
+ end) }
+end macro check-equal;
+
+define macro check-instance?
+ { check-instance? (?check-name:expression,
+ ?value-type:expression, ?value:expression) }
+ => { do-check(method () ?check-name end,
+ method ()
+ vector(instance?, vector(?value, ?value-type))
+ end) }
+end macro check-instance?;
+
+define macro check-true
+ { check-true (?check-name:expression, ?check-expression:expression) }
+ => { do-check(method () ?check-name end,
+ method ()
+ vector(\~=, vector(#f, ?check-expression))
+ end) }
+end macro check-true;
+
+define macro check-false
+ { check-false (?check-name:expression, ?check-expression:expression) }
+ => { do-check(method () ?check-name end,
+ method ()
+ vector(\=, vector(#f, ?check-expression))
+ end) }
+end macro check-false;
+
+define macro check-condition
+ { check-condition
+ (?check-name:expression,
+ ?check-condition:expression, ?check-body:expression) }
+ => { do-check-condition(method () ?check-name end,
+ method ()
+ vector(?check-condition,
+ method () ?check-body end)
+ end) }
+end macro check-condition;
+
+define macro check-no-errors
+ { check-no-errors(?check-name:expression, ?check-body:expression) }
+ => { check-true(?check-name, begin ?check-body; #t end) }
+end macro check-no-errors;
+
+
+
+
+/// Check implementation functions
+
+define method evaluate-name-function
+ (nam