-
Notifications
You must be signed in to change notification settings - Fork 4
/
Copy pathexpectations.lisp
176 lines (150 loc) · 8.03 KB
/
expectations.lisp
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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
;;;; expectations.lisp
;;;;
;;;; Copyright (c) 2014 Robert Smith
(in-package #:policy-cond)
(defmacro with-expectations (policy (&rest expectations) &body body)
"Execute BODY with expectations laid out by the clauses EXPECTATIONS when the policy expression POLICY holds true. When POLICY does not hold true, then EXPECTATIONS will be explicitly checked at runtime.
EXPECTATIONS should be lists of one of the following forms.
Type Expectation: (TYPE <type> <vars-or-exprs>...)
Assert that the variables and expressions <vars-or-exprs> should
have the type <type>. If the POLICY is met, then declarations
will be made for the variables only.
Return Type Expectation: (RETURNS [<type>*])
Assert that the result of a form obeys a certain type. Multiple
types indicate multiple values are returned. If the POLICY is
met, then the assertion will be elided at runtime.
Assertion Expectation: (ASSERTION <assertion> [(place*) [datum-form argument-form*]])
Assert that the assertion <assertion> should be true. If the
POLICY is met, then the assertion will be elided at runtime.
Conditional Expectation: (OR-ELSE <predicate> <resulting action>)
Check that the predicate <predicate> is true, or else perform
<resulting action>. If the POLICY is met, elide the check and
action. This clause is principally used for having special
conditions get raised.
Inline Expectation: (INLINE [<symbol>*])
Inline the functions designated by the symbols <symbol> if POLICY
is met.
"
(let ((preamble-forms nil)
(local-declarations nil)
(return-types :not-provided))
(labels ((keywordify (s)
(intern (symbol-name s) :keyword))
(validate-expectation (e)
(assert (listp e) (e) "Expected an expectation clause. Got ~S" e)
(case (keywordify (car e))
((:type)
(assert (cdr e) () "Invalid type expectation: ~S" e)
(assert (cddr e) () "Empty variable/expression list in type expectation: ~S"
e))
((:returns) nil)
((:inline) (assert (every #'symbolp (cdr e))
()
"Invalid inline expectation received non-symbols: ~{~S~^, ~}"
(remove-if #'symbolp (cdr e))))
((:assertion)
(assert (cdr e)
()
"Invalid assertion expectation: ~S"
e))
((:or-else)
(assert (= 2 (length (cdr e)))
()
"Invalid or-else expectation. Expecting a predicate and a result, got: ~S"
e))
(otherwise (warn "Ignoring unrecognized expectation: ~S" e))))
(parse-safe-expectation (e)
(case (keywordify (car e))
((:type) (let ((type (second e))
(vars (cddr e)))
(dolist (var vars)
(push `(check-type ,var ,type) preamble-forms))))
((:returns) (setq return-types (cdr e)))
((:assertion) (push `(assert ,@(cdr e)) preamble-forms))
((:or-else) (push `(unless ,(second e)
,(third e))
preamble-forms))))
(parse-speedy-expectation (e)
(case (keywordify (car e))
((:type) (let ((type (second e))
(vars (remove-if-not #'symbolp (cddr e))))
(push `(type ,type ,@vars) local-declarations)))
((:returns) nil) ; This will already have been parsed.
((:assertion) nil)
((:or-else) nil)
((:inline) (let ((syms (cdr e)))
(when syms
(push `(inline ,@(cdr e)) local-declarations))) ))))
;; Validate the expectations.
(mapc #'validate-expectation expectations)
(assert (> 2 (count :return-type expectations
:key (lambda (ex) (keywordify (car ex)))))
()
"There are more than one return type expectations ~
provided when there should only be one.")
;; Parse the expectations.
(mapc #'parse-safe-expectation expectations)
(mapc #'parse-speedy-expectation expectations)
;; All of the forms are pushed into a list in order. Reverse
;; them so they're applied in the order they were presented.
(setf preamble-forms (nreverse preamble-forms))
;; Construct the policy form.
`(policy-if
,policy
;; Speedy version (policy is satisfied).
,(if (null expectations)
`(progn ,@body)
(let ((contents
(cond
((eql return-types :not-provided) body)
((= 1 (length return-types))
(list `(the ,@return-types (progn ,@body))))
(t (list `(the (values ,@return-types) (progn ,@body)))))))
;; XXX FIXME: MAKE THE OUTPUT BETTER
(if local-declarations
`(locally (declare ,@local-declarations)
,@contents)
`(progn ,@contents))))
;; Safe version (policy is not satisfied).
,(if (eql :not-provided return-types)
`(progn
,@preamble-forms
,@body)
(let ((result (gensym "RESULT-")))
(if (= 1 (length return-types))
;; The simple case of one return type.
`(progn
,@preamble-forms
(let ((,result (progn ,@body)))
(check-type ,result ,@return-types)
,result))
`(progn
,@preamble-forms
(let ((,result (multiple-value-list (progn ,@body))))
(assert (= ,(length return-types)
(length ,result))
()
"Expected ~D values to get returned. Got ~D."
,(length return-types)
(length ,result))
,@(loop :for i :from 0
:for type :in return-types
:collect `(unless (typep (nth ,i ,result) ',type)
(error 'simple-type-error
:format-control ,(format nil "The ~:R value returned, ~~S, is not of type ~S."
(1+ i)
type)
:format-arguments (list (nth ,i ,result))
:datum (nth ,i ,result)
:expected-type ',type)))
#+#:ignore
(loop :for ,i :from 1
:for ,value :in ,result
:for ,type :in ',return-types
:do (unless (typep ,value ,type)
(error 'simple-type-error
:format-control "The ~:R value returned, ~S, is not of type ~S."
:format-arguments (list ,i ,value ,type)
:datum ,value
:expected-type ,type)))
(values-list ,result))))))))))