Merge typecheck macro into c-parser.

Merge branch 'new-object-system' into c-parser

4 files changed, 49 insertions, 20 deletions

diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm
index 3ce754df..d6c86f7a 100644
--- a/module/c/cpp-environment.scm
+++ b/module/c/cpp-environment.scm
@@ -3,6 +3,7 @@
   :use-module (srfi srfi-88)
   :use-module (ice-9 hash-table)
   :use-module (hnh util object)
+  :use-module (hnh util type)
   :use-module (hnh util lens)
   :use-module ((c cpp-environment function-like-macro) :prefix #{fun:}#)
   :use-module ((c cpp-environment object-like-macro)   :prefix #{obj:}#)
diff --git a/module/c/cpp-environment/function-like-macro.scm b/module/c/cpp-environment/function-like-macro.scm
index 0a0611e3..26512439 100644
--- a/module/c/cpp-environment/function-like-macro.scm
+++ b/module/c/cpp-environment/function-like-macro.scm
@@ -1,5 +1,6 @@
 (define-module (c cpp-environment function-like-macro)
   :use-module (hnh util object)
+  :use-module (hnh util type)
   :export (function-like-macro
            function-like-macro?
            identifier
diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm
index 4dbb45a8..4477b462 100644
--- a/module/hnh/util/object.scm
+++ b/module/hnh/util/object.scm
@@ -1,8 +1,8 @@
 (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)
+  :use-module (hnh util type)
   :export (define-type))
 
 
@@ -35,25 +35,6 @@
 
 
 
-;; 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 (list-of (proc args ...)))
-     (and (list? variable)
-          (every (lambda (x) (build-validator-body x (proc args ...)))
-                 variable)))
-    ((_ variable (list-of proc))     (and (list? variable)
-                                          (every proc variable)))
-    ((_ variable (pair-of a b))      (and (pair? variable)
-                                          (build-validator-body (car variable) a)
-                                          (build-validator-body (cdr variable) b)))
-    ((_ 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)))))
+