blob: 800834e534dd0dd25fa061a20a0583baf1073fb7 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
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)))))
|
