1 files changed, 21 insertions, 13 deletions
diff --git a/module/hnh/util/type.scm b/module/hnh/util/type.scm
index 50008a3a..b998d59c 100644
--- a/module/hnh/util/type.scm
+++ b/module/hnh/util/type.scm
@@ -1,11 +1,26 @@
 (define-module (hnh util type)
   :use-module ((srfi srfi-1) :select (every))
   :export (build-validator-body
-           list-of pair-of
+           list-of pair-of alist-of alist-of
+           list-of-length
            of-type?
            typecheck
            current-procedure-name))
 
+;; 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 not)
+    ((_ variable (and clauses ...))  (and (build-validator-body variable clauses) ...))
+    ((_ variable (or clauses ...))   (or (build-validator-body variable clauses) ...))
+    ((_ variable (not clause))       (not (build-validator-body variable clause)))
+    ((_ 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 list-of
   (syntax-rules ()
     ((_ variable (rule ...))
@@ -20,19 +35,12 @@
        (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 not)
-    ((_ variable (and clauses ...))  (and (build-validator-body variable clauses) ...))
-    ((_ variable (or clauses ...))   (or (build-validator-body variable clauses) ...))
-    ((_ variable (not clause))       (not (build-validator-body variable clause)))
-    ((_ variable (proc args ...))    (proc variable args ...))
-    ((_ variable proc)               (proc variable))))
+(define-syntax-rule (alist-of variable key-type value-type)
+  (build-validator-body variable (list-of (pair-of key-type value-type))))
 
-(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 (list-of-length lst n)
+  (and (list? lst)
+       (= n (length lst))))
 
 (define-syntax of-type?
   (syntax-rules ()