I took a crack at porting the check egg (SRFI-78 lightweight testing) to
Chicken 4. Seems to work, but you need to import srfi-42 explicitly
before using 'check-ec'. Can someone show me what I missed?
Here's a summary of the changes.
* Defined module.
* Moved non-macro code from check-base.scm to check.scm. I'm
assuming that modules and import libraries get rid of the need
to have macros in a separate file. This accounts for most of
the diff.
* Changed setup script to build and install the import library.
* Added examples.scm from SRFI document
* Updated HTML file.
Only in ../check-3-egg/: check-base.scm
Files ../check-3-egg/check.egg and ./check.egg differ
diff -u ../check-3-egg/check.html ./check.html
--- ../check-3-egg/check.html 2008-01-16 09:27:48.000000000 -0500
+++ ./check.html 2009-09-07 12:27:27.000000000 -0400
@@ -118,12 +118,13 @@
<div id="body">
<div class="section">
<h3>Description</h3>
-<p>Leightweight testing</p></div>
+<p>Lightweight testing</p></div>
<div class="section">
<h3>Author</h3>Sebastian Egner</div>
<div class="section">
<h3>Version</h3>
<ul>
+<li>1.1 Ported to Chicken 4</li>
<li>1.0 Initial release</li></ul></div>
<div class="section">
<h3>Usage</h3><tt>(require-extension check)</tt></div>
@@ -131,7 +132,7 @@
<h3>Download</h3><a href="check.egg">check.egg</a></div>
<div class="section">
<h3>Documentation</h3>
-<p>This extension provides facilities for leightweight testing based on SRFI-42.</p>
+<p>This extension provides facilities for lightweight testing based on SRFI-42.</p>
<p>For a detailed specification consult the official SRFI document <a href="http://srfi.schemers.org/srfi-78/srfi-78.html";>SRFI-78</a></p></div>
<div class="section">
<h3>License</h3>
@@ -157,4 +158,4 @@
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.</pre></div></div>
<div id="footer">
<hr /><a href="index.html">< Egg index</a>
-<div id="revision-history">$Revision$ $Date$</div> </div></body></html>
\ No newline at end of file
+<div id="revision-history">$Revision$ $Date$</div> </div></body></html>
diff -u ../check-3-egg/check.meta ./check.meta
--- ../check-3-egg/check.meta 2008-01-16 09:27:48.000000000 -0500
+++ ./check.meta 2009-09-07 12:06:03.000000000 -0400
@@ -2,8 +2,8 @@
((egg "check.egg")
(author "Sebastian Egner")
- (needs syntax-case srfi-42)
+ (needs srfi-42)
(synopsis "SRFI-78 leightweight testing")
(license "SRFI")
(category testing)
- (files "check.scm" "check-base.scm" "check.html" "check.setup"))
+ (files "check.scm" "check.html" "check.setup" "examples.scm"))
diff -u ../check-3-egg/check.scm ./check.scm
--- ../check-3-egg/check.scm 2008-01-16 09:27:48.000000000 -0500
+++ ./check.scm 2009-09-07 12:00:38.000000000 -0400
@@ -1,7 +1,211 @@
-;;;; check-syntax.scm
+; <PLAINTEXT>
+; Copyright (c) 2005-2006 Sebastian Egner.
+;
+; Permission is hereby granted, free of charge, to any person obtaining
+; a copy of this software and associated documentation files (the
+; ``Software''), to deal in the Software without restriction, including
+; without limitation the rights to use, copy, modify, merge, publish,
+; distribute, sublicense, and/or sell copies of the Software, and to
+; permit persons to whom the Software is furnished to do so, subject to
+; the following conditions:
+;
+; The above copyright notice and this permission notice shall be
+; included in all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+;
+; -----------------------------------------------------------------------
+;
+; Lightweight testing (reference implementation)
+; ==============================================
+;
+; [email protected]
+; in R5RS + SRFI 23 (error) + SRFI 42 (comprehensions)
+;
+; history of this file:
+; SE, 25-Oct-2004: first version based on code used in SRFIs 42 and 67
+; SE, 19-Jan-2006: (arg ...) made optional in check-ec
+;
+; Naming convention "check:<identifier>" is used only internally.
+
+; -- portability --
+
+; PLT: (require (lib "23.ss" "srfi") (lib "42.ss" "srfi"))
+; Scheme48: ,open srfi-23 srfi-42
+
+(module check
+ (check-set-mode!
+ check-reset!
+ check-report
+ check-passed?
+ check
+ check-ec
+ check:proc
+ check:proc-ec
+ check:mode)
+ (import scheme chicken srfi-42)
+
+(require 'srfi-42)
+
+; -- utilities --
+
+(define check:write write)
+
+; You can also use a pretty printer if you have one.
+; However, the output might not improve for most cases
+; because the pretty printers usually output a trailing
+; newline.
+
+; PLT: (require (lib "pretty.ss")) (define check:write pretty-print)
+; Scheme48: ,open pp (define check:write p)
+
+; -- mode --
+
+(define check:mode #f)
+
+(define (check-set-mode! mode)
+ (set! check:mode
+ (case mode
+ ((off) 0)
+ ((summary) 1)
+ ((report-failed) 10)
+ ((report) 100)
+ (else (error "unrecognized mode" mode)))))
+
+(check-set-mode! 'report)
+
+; -- state --
+
+(define check:correct #f)
+(define check:failed #f)
+
+(define (check-reset!)
+ (set! check:correct 0)
+ (set! check:failed '()))
+
+(define (check:add-correct!)
+ (set! check:correct (+ check:correct 1)))
+
+(define (check:add-failed! expression actual-result expected-result)
+ (set! check:failed
+ (cons (list expression actual-result expected-result)
+ check:failed)))
+
+(check-reset!)
+
+; -- reporting --
+
+(define (check:report-expression expression)
+ (newline)
+ (check:write expression)
+ (display " => "))
+
+(define (check:report-actual-result actual-result)
+ (check:write actual-result)
+ (display " ; "))
+
+(define (check:report-correct cases)
+ (display "correct")
+ (if (not (= cases 1))
+ (begin (display " (")
+ (display cases)
+ (display " cases checked)")))
+ (newline))
+
+(define (check:report-failed expected-result)
+ (display "*** failed ***")
+ (newline)
+ (display " ; expected result: ")
+ (check:write expected-result)
+ (newline))
+
+(define (check-report)
+ (if (>= check:mode 1)
+ (begin
+ (newline)
+ (display "; *** checks *** : ")
+ (display check:correct)
+ (display " correct, ")
+ (display (length check:failed))
+ (display " failed.")
+ (if (or (null? check:failed) (<= check:mode 1))
+ (newline)
+ (let* ((w (car (reverse check:failed)))
+ (expression (car w))
+ (actual-result (cadr w))
+ (expected-result (caddr w)))
+ (display " First failed example:")
+ (newline)
+ (check:report-expression expression)
+ (check:report-actual-result actual-result)
+ (check:report-failed expected-result))))))
+
+(define (check-passed? expected-total-count)
+ (and (= (length check:failed) 0)
+ (= check:correct expected-total-count)))
+
+; -- simple checks --
+
+(define (check:proc expression thunk equal expected-result)
+ (case check:mode
+ ((0) #f)
+ ((1)
+ (let ((actual-result (thunk)))
+ (if (equal actual-result expected-result)
+ (check:add-correct!)
+ (check:add-failed! expression actual-result expected-result))))
+ ((10)
+ (let ((actual-result (thunk)))
+ (if (equal actual-result expected-result)
+ (check:add-correct!)
+ (begin
+ (check:report-expression expression)
+ (check:report-actual-result actual-result)
+ (check:report-failed expected-result)
+ (check:add-failed! expression actual-result expected-result)))))
+ ((100)
+ (check:report-expression expression)
+ (let ((actual-result (thunk)))
+ (check:report-actual-result actual-result)
+ (if (equal actual-result expected-result)
+ (begin (check:report-correct 1)
+ (check:add-correct!))
+ (begin (check:report-failed expected-result)
+ (check:add-failed! expression
+ actual-result
+ expected-result)))))
+ (else (error "unrecognized check:mode" check:mode)))
+ (if #f #f))
+
+; -- parametric checks --
+
+(define (check:proc-ec w)
+ (let ((correct? (car w))
+ (expression (cadr w))
+ (actual-result (caddr w))
+ (expected-result (cadddr w))
+ (cases (car (cddddr w))))
+ (if correct?
+ (begin (if (>= check:mode 100)
+ (begin (check:report-expression expression)
+ (check:report-actual-result actual-result)
+ (check:report-correct cases)))
+ (check:add-correct!))
+ (begin (if (>= check:mode 10)
+ (begin (check:report-expression expression)
+ (check:report-actual-result actual-result)
+ (check:report-failed expected-result)))
+ (check:add-failed! expression
+ actual-result
+ expected-result)))))
-(use syntax-case srfi-42)
(define-syntax check
(syntax-rules (=>)
@@ -68,3 +272,4 @@
(check-ec (nested q1 ... q) etc ...))
((check-ec q1 q2 etc ...)
(check-ec (nested q1 q2) etc ...))))
+)
diff -u ../check-3-egg/check.setup ./check.setup
--- ../check-3-egg/check.setup 2008-01-16 09:27:48.000000000 -0500
+++ ./check.setup 2009-08-12 15:27:43.000000000 -0400
@@ -1,8 +1,8 @@
-(compile -s -O2 -d1 check-base.scm)
+(compile -s -O2 -d1 check.scm -j check)
+(compile -s -O2 -d1 check.import.scm)
(install-extension
'check
- '("check.scm" "check-base.so")
- '((version 1.0)
+ '("check.so" "check.import.so")
+ '((version 1.1)
(syntax)
- (require-at-runtime check-base)
(documentation "check.html")) )
Only in .: examples.scm
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
