3 files changed, 93 insertions(+), 5 deletions(-)

M .gitignore
M contracts-test.scm
M package.sh

@@ 1,2 1,2 @@
 /nytpu-contracts-*.tgz
-/contracts.log
+/*.log

@@ 6,7 6,95 @@
 ;;; Home Page: <https://git.sr.ht/~nytpu/dbc-scheme>
 
 (import (scheme base)
-        (srfi 64)
-        (nytpu contracts))
+        (srfi 1)
+        (srfi 64))
 
-;; TODO
+(import (scheme lazy)) (include "contracts.scm")
+#;(import (nytpu contracts))
+
+(test-begin "(nytpu contracts)")
+
+(test-begin "define-contract")
+(define-contract (add-map . lists)
+  (pre (>= (length lists) 2)
+       (every list? lists)
+       (apply = (map length lists))
+       (every (lambda (x) (every number? x)) lists))
+  (post list?
+        (lambda (ret) (every number? ret))
+        (lambda (ret) (= (length ret) (length (car lists)))))
+  (apply map + lists))
+(test-equal (add-map '(1 2 3 4) '(4 3 2 1))
+            '(5 5 5 5))
+(test-equal (add-map '(1 2 3) '(1 2 3) '(1 2 3))
+            '(3 6 9))
+(test-error (add-map '(1 2 3 4)))
+(test-error (add-map '(1 2 3 4) 4))
+(test-error (add-map '(1 2 3 4) '(3 2 bazinga)))
+(test-end "define-contract")
+
+(test-begin "lambda-contract")
+(set! add-map #f)
+(define add-map
+  (lambda-contract lists
+    (pre (>= (length lists) 2)
+         (every list? lists)
+         (apply = (map length lists))
+         (every (lambda (x) (every number? x)) lists))
+    (post list?
+          (lambda (ret) (every number? ret))
+          (lambda (ret) (= (length ret) (length (car lists)))))
+    (apply map + lists)))
+(test-equal (add-map '(1 2 3 4) '(4 3 2 1))
+            '(5 5 5 5))
+(test-equal (add-map '(1 2 3) '(1 2 3) '(1 2 3))
+            '(3 6 9))
+(test-error (add-map '(1 2 3 4)))
+(test-error (add-map '(1 2 3 4) 4))
+(test-error (add-map '(1 2 3 4) '(3 2 bazinga)))
+(test-end "lambda-contract")
+
+(test-begin "define-contract alternates")
+(define-contract (add-map . lists)
+  (pre (>= (length lists) 2)
+       (every list? lists)
+       (apply = (map length lists))
+       (every (lambda (x) (every number? x)) lists))
+  "hello, world!")
+(test-equal (add-map '(1 2 3 4) '(4 3 2 1))
+            "hello, world!")
+(test-equal (add-map '(1 2 3) '(1 2 3) '(1 2 3))
+            "hello, world!")
+(test-error (add-map '(1 2 3 4)))
+(test-error (add-map '(1 2 3 4) 4))
+(test-error (add-map '(1 2 3 4) '(3 2 bazinga)))
+
+(define-contract (add-map . lists)
+  (post list?
+        (lambda (ret) (every number? ret))
+        (lambda (ret) (= (length ret) (length (car lists)))))
+  "hello, world!")
+(test-error (add-map '(1 2 3 4) '(4 3 2 1)))
+(test-error (add-map '(1 2 3) '(1 2 3) '(1 2 3)))
+(test-error (add-map '(1 2 3 4)))
+(test-error (add-map '(1 2 3 4) 4))
+(test-error (add-map '(1 2 3 4) '(3 2 bazinga)))
+
+(define-contract (add-map list1 list2)
+  (pre (and (list? list1) (list? list2))
+       (= (length list1) (length list2))
+       (every (lambda (x) (every number? x)) (list list1 list2)))
+  (post list?
+        (lambda (ret) (every number? ret))
+        (lambda (ret) (= (length ret) (length list1))))
+  (map + list1 list2))
+(test-equal (add-map '(1 2 3 4) '(4 3 2 1))
+            '(5 5 5 5))
+(test-equal (add-map '(1 2 3) '(1 2 3))
+            '(2 4 6))
+(test-error (add-map '(1 2 3 4)))
+(test-error (add-map '(1 2 3 4) 4))
+(test-error (add-map '(1 2 3 4) '(3 2 bazinga)))
+(test-end "define-contract alternates")
+
+(test-end "(nytpu contracts)")

@@ 13,7 13,7 @@ libfile="contracts.sld"
 license="MPL-2.0"
 test_file="contracts-test.scm"
 description="Design by Contracts for R7RS"
-log_file="contracts.log"
+log_file="_nytpu contracts_.log"
 
 # this first build will NOT have documentation built for some reason!
 printf "Building broken package\n"