Move type checking macros to own module.

2 files changed, 48 insertions, 28 deletions

diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm
index d6fa6273..4477b462 100644
--- a/module/hnh/util/object.scm
+++ b/module/hnh/util/object.scm
@@ -1,11 +1,9 @@
 (define-module (hnh util object)
-  :use-module (srfi srfi-1)
   :use-module (srfi srfi-9 gnu)
   :use-module (ice-9 curried-definitions)
   :use-module (hnh util)
-  :export (define-type
-            build-validator-body
-            list-of pair-of))
+  :use-module (hnh util type)
+  :export (define-type))
 
 
 
@@ -37,30 +35,6 @@
 
 
 
-(define-syntax list-of
-  (syntax-rules ()
-    ((_ variable (rule ...))
-     (and (list? variable)
-          (every (lambda (x) (build-validator-body x (rule ...))) variable)))
-    ((_ variable rule)
-     (and (list? variable)
-          (every rule variable)))))
-
-(define-syntax-rule (pair-of variable a b)
-  (and (pair? variable)
-       (build-validator-body (car variable) a)
-       (build-validator-body (cdr variable) b)))
-
-;; DSL for specifying type predicates
-;; Basically a procedure body, but the variable to test is implicit.
-(define-syntax build-validator-body
-  (syntax-rules (and or list-of)
-    ((_ variable (and clauses ...))  (and (build-validator-body variable clauses) ...))
-    ((_ variable (or clauses ...))   (or (build-validator-body variable clauses) ...))
-    ((_ variable (proc args ...))    (proc variable args ...))
-    ((_ variable proc)               (proc variable))))
-
-
 ;; Given (x type: predicate?), expand to a single `unless' form (otherwise #f)
 (define-syntax (validator stx)
   (syntax-case stx ()
diff --git a/module/hnh/util/type.scm b/module/hnh/util/type.scm
new file mode 100644
index 00000000..800834e5
--- /dev/null
+++ b/module/hnh/util/type.scm
@@ -0,0 +1,46 @@
+(define-module (hnh util type)
+  :use-module ((srfi srfi-1) :select (every))
+  :export (build-validator-body
+           list-of pair-of
+           typecheck
+           current-procedure-name))
+
+(define-syntax list-of
+  (syntax-rules ()
+    ((_ variable (rule ...))
+     (and (list? variable)
+          (every (lambda (x) (build-validator-body x (rule ...))) variable)))
+    ((_ variable rule)
+     (and (list? variable)
+          (every rule variable)))))
+
+(define-syntax-rule (pair-of variable a b)
+  (and (pair? variable)
+       (build-validator-body (car variable) a)
+       (build-validator-body (cdr variable) b)))
+
+;; DSL for specifying type predicates
+;; Basically a procedure body, but the variable to test is implicit.
+(define-syntax build-validator-body
+  (syntax-rules (and or list-of)
+    ((_ variable (and clauses ...))  (and (build-validator-body variable clauses) ...))
+    ((_ variable (or clauses ...))   (or (build-validator-body variable clauses) ...))
+    ((_ variable (proc args ...))    (proc variable args ...))
+    ((_ variable proc)               (proc variable))))
+
+(define-syntax-rule (current-procedure-name)
+  ;; 1 since make-stack is at top of stack
+  (frame-procedure-name (stack-ref (make-stack #t) 1)))
+
+(define-syntax typecheck
+  (syntax-rules ()
+    ((_ variable type-clause)
+     (let ((procedure-name (current-procedure-name)))
+       (typecheck variable type-clause procedure-name)))
+    ((_ variable type-clause procedure-name)
+     (unless (build-validator-body variable type-clause)
+       (scm-error 'wrong-type-arg procedure-name
+                  "Invalid value for ~s. Expected ~s, got ~s"
+                  (list (quote variable) (quote type-clause) variable)
+                  #f)))))
+