Implement seal module

diff --git a/test/seal.scm b/test/seal.scm
new file mode 100644 (file)
index 0000000..db99e86
--- /dev/null
+++ b/test/seal.scm
@@ -0,0 +1,97 @@
+(define-module (seal)
+    #:export (sealed))
+(use-modules (ice-9 match))
+(use-modules (srfi srfi-1))
+(use-modules (srfi srfi-26))
+
+(eval-when (eval load compile)
+    (read-hash-extend #\[
+        (lambda (ch stream)
+           (unread-char ch stream)
+           (cons 'cute (read stream)))))
+
+(define-syntax push
+    (syntax-rules ()
+       ((_ val list)
+        (set! list (cons val list)))))
+
+(define load-once
+    (let ((already-loaded '()))
+       (lambda  (filename)
+           "Load file, unless it was not already loaded with this function."
+           (unless (member filename already-loaded)
+                   (primitive-load filename)
+                   (push filename already-loaded)))))
+
+(define (error:broken-seal form expect result)
+    (format #t "\nCompilation aborted: seal broken.
+Eval: ~a\nExpect: ~a\nReceived: ~a\n" form expect result)
+    (exit 1))
+
+(define-syntax call-and-catch
+    (syntax-rules ()
+       ((_ <form> <on-values> <on-throw>)
+        (let ((throw-handler-called #f))
+            (call-with-values #[catch #t
+                                      (lambda () <form>)
+                                      (lambda args
+                                          (apply <on-throw> args)
+                                          (set! throw-handler-called #t))]
+                (lambda args
+                    (unless throw-handler-called
+                            (apply <on-values> args))))))))
+
+(define-syntax seal-clause
+    (syntax-rules (=> -->)
+       ((_ <form>) (seal-clause <form> => #t))
+       ((_ <form> => <val> <vals> ... )
+        (let ((expected (cons 'values '(<val> <vals> ...))))
+            (call-and-catch <form>
+                 (lambda args
+                    (unless (equal? args (cdr expected))
+                            (error:broken-seal '<form>
+                                               expected
+                                               (cons 'values args))))
+                (lambda throw-args
+                    (error:broken-seal '<form>
+                                       expected
+                                       (cons 'throw throw-args))))))
+       ((_ <form> <forms> ... => <val> <vals> ...)
+        (seal-clause (<form> <forms> ...) => <val> <vals> ...))
+       ((_ <form> --> <val> ...)
+        (let ((expected (cons 'throw '(<val> ...))))
+            (call-and-catch <form>
+                (lambda args
+                   (error:broken-seal '<form>
+                                      (append expected '(....))
+                                      (cons 'values args)))
+               (lambda throw-args
+                   (unless (and (<= (length (cdr expected)) (length throw-args))
+                                (every equal? (cdr expected) throw-args))
+                           (error:broken-seal '<form>
+                                              (append expected '(....))
+                                              (cons 'throw throw-args)))))))
+       ((_ <form> <forms> ... --> <val> ...)
+        (seal-clause (<form> <forms> ...) --> <val> ...))
+       ((_ obj ...)
+        (error "Macro seal-clause usage:
+Assert, that evaluation of EXPR returns value(s).
+    (seal-clause expr => value [values])
+Assert, that evaluation of EXPR is #t
+    (seal-clause expr)
+Assert, that evaluation of EXPR throws with argument list, starting with value(s)
+    (seal-clause expr --> value [values])
+In particular, (seal-clause expr -->) asserts, that EXPR throws something."))))
+
+
+(define-syntax sealed
+    (lambda (env)
+       (syntax-case env ()
+           ((_ f (obj ...) ...)
+            (with-syntax ((& (datum->syntax env '&)))
+                #'(eval-when (compile)
+                             (load-once (current-filename))
+                             (let ((& f))
+                                 (format #t "Checking seals with & = ~a... " 'f)
+                                 (seal-clause obj ...) ...
+                                 (format #t "ok\n"))))))))

diff --git a/test/test.scm b/test/test.scm
index b0f6a079fe1c1b3753435a9c69e429c9316c22d0..728e34e41de006094a947aad94e039ba8c1ce207 100644 (file)
--- a/test/test.scm
+++ b/test/test.scm
@@ -1,69 +1,16 @@
-;; (define-module (foo))
-(use-modules (ice-9 match))
-(use-modules (srfi srfi-1))
-(use-modules (srfi srfi-26))
-
-(eval-when (eval load compile)
-          (read-hash-extend #\[ (lambda (ch stream)
-                                    (unread-char ch stream)
-                                    (cons 'cute (read stream)))))
-
-(define (error:broken-seal form expect result)
-    (error 'broken-seal (format #f "Compilation aborted: seal broken.
-Eval: ~a\nExpect: ~a\nReceived: ~a\n"
-                  form expect result)))
-
-(define-syntax call-and-catch
-    (syntax-rules ()
-       ((_ <form> <on-values> <on-throw>)
-        (let ((throw-handler-called #f))
-            (call-with-values #[catch #t
-                                      (lambda () <form>)
-                                      (lambda args
-                                          (apply <on-throw> args)
-                                          (set! throw-handler-called #t))]
-                (lambda args
-                    (unless throw-handler-called
-                            (apply <on-values> args))))))))
-
-(define-syntax seal-clause
-    (syntax-rules (=> -->)
-       ((_ <form>) (seal-clause <form> => #t))
-       ((_ <form> => <val> <vals> ... )
-        (let ((expected (cons 'values '(<val> <vals> ...))))
-            (call-and-catch <form>
-                 (lambda args
-                    (unless (equal? args (cdr expected))
-                            (error:broken-seal '<form>
-                                               expected
-                                               (cons 'values args))))
-                (lambda throw-args
-                    (error:broken-seal '<form> expected (cons 'throw throw-args))))))
-       ((_ <form> --> <val> ...)
-        (let ((expected (cons 'throw '(<val> ...))))
-            (call-and-catch <form>
-                (lambda args
-                   (error:broken-seal '<form>
-                                      (append expected '(....))
-                                      (cons 'values args)))
-               (lambda throw-args
-                   (unless (and (<= (length (cdr expected)) (length throw-args))
-                                (every equal? (cdr expected) throw-args))
-                           (error:broken-seal '<form>
-                                              (append expected '(....))
-                                              (cons 'throw throw-args)))))))
-       ((_ obj ...)
-        (error "Macro seal-clause usage:
-Assert, that evaluation of EXPR returns value(s).
-    (seal-clause expr => value [values])
-Assert, that evaluation of EXPR is #t
-    (seal-clause expr)
-Assert, that evaluation of EXPR throws with argument list, starting with value(s)
-    (seal-clause expr --> value [values])
-In particular, (seal-clause expr -->) asserts, that EXPR throws something."))))
+(define-module (test)
+    #:export (frap))
+(use-modules (seal))
 
+(sealed frap
+    (frap 1 => 9))
 (define (frap x)
     (+ (bar x) 8))
 
+
+
+(sealed bar
+    (& 5 => 1)
+    (& 3 => 9))
 (define (bar y)
     (* y y))