blob: b9b4f9514f53a2ecd59d0d51fb7b60fd963dbbbd (
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
47
48
49
50
51
52
53
|
(define-module (hnh util type)
:use-module ((srfi srfi-1) :select (every))
:export (build-validator-body
list-of pair-of
false?
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 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 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)))))
;;; For use in typechecks, since
;;; (or false? integer?)
;;; is much clearer than
;;; (or not integer?)
(define false? not)
|