1
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
2
;;;; Copyright (c) 1990, Giuseppe Attardi.
4
;;;; This program is free software; you can redistribute it and/or
5
;;;; modify it under the terms of the GNU Library General Public
6
;;;; License as published by the Free Software Foundation; either
7
;;;; version 2 of the License, or (at your option) any later version.
9
;;;; See file '../Copyright' for full details.
13
(defun read-evaluated-form ()
14
(format *query-io* "~&Type a form to be evaluated:~%")
15
(list (eval (read *query-io*))))
17
(defmacro check-type (place type &optional type-string)
18
"Args: (check-type place typespec [string-form])
19
Signals a continuable error, if the value of PLACE is not of the specified
20
type. Before continuing, receives a new value of PLACE from the user and
21
checks the type again. Repeats this process until the value of PLACE becomes
22
of the specified type. STRING-FORM, if given, is evaluated only once and the
23
value is used to indicate the expected type in the error message."
24
(let* ((tag1 (gensym))
28
(if (typep ,place ',type) (return-from ,tag1 nil))
29
(restart-case ,(if type-string
30
`(error 'SIMPLE-TYPE-ERROR
31
:FORMAT-CONTROL "The value of ~S is ~S, ~
33
:FORMAT-ARGUMENTS (list ',place ,place, type-string)
35
:EXPECTED-TYPE ',type)
36
`(error 'SIMPLE-TYPE-ERROR
37
:FORMAT-CONTROL "The value of ~S is ~S, ~
38
which is not of type ~S."
39
:FORMAT-ARGUMENTS (list ',place ,place ',type)
41
:EXPECTED-TYPE ',type))
43
:REPORT (lambda (stream)
44
(format stream "Supply a new value of ~S."
46
:INTERACTIVE read-evaluated-form
50
(defun assert-report (names stream)
51
(format stream "Retry assertion")
53
(format stream " with new value~P for ~{~S~^, ~}."
57
(defun assert-prompt (name value)
58
(cond ((y-or-n-p "The old value of ~S is ~S.~
59
~%Do you want to supply a new value? "
61
(format *query-io* "~&Type a form to be evaluated:~%")
62
(flet ((read-it () (eval (read *query-io*))))
63
(if (symbolp name) ;Help user debug lexical variables
64
(progv (list name) (list value) (read-it))
68
(defun simple-assertion-failure (assertion)
69
(error 'SIMPLE-TYPE-ERROR
71
:EXPECTED-TYPE nil ; This needs some work in next revision. -kmp
72
:FORMAT-CONTROL "The assertion ~S failed."
73
:FORMAT-ARGUMENTS (list assertion)))
75
(defmacro assert (test-form &optional places datum &rest arguments)
76
"Args: (assert form [({place}*) [string {arg}*]])
77
Evaluates FORM and signals a continuable error if the value is NIL. Before
78
continuing, receives new values of PLACEs from user. Repeats this process
79
until FORM returns a non-NIL value. Returns NIL. STRING is the format string
80
for the error message and ARGs are arguments to the format string."
84
(restart-case ,(if datum
85
`(error ,datum ,@arguments)
86
`(simple-assertion-failure ',test-form))
88
:REPORT (lambda (stream) (assert-report ',places stream))
89
,@(mapcar #'(lambda (place)
90
`(setf ,place (assert-prompt ',place ,place)))
94
(defun accumulate-cases (macro-name cases list-is-atom-p)
95
(declare (si::c-local))
96
(do ((c cases (cdr c))
98
((null c) (nreverse l))
99
(let ((keys (caar c)))
100
(cond ((atom keys) (unless (null keys) (push keys l)))
101
(list-is-atom-p (push keys l))
102
(t (setq l (append keys l)))))))
104
(defun ecase-error (keyform value values)
105
(error 'CASE-FAILURE :name 'ECASE
107
:expected-type (cons 'MEMBER values)
108
:possibilities values))
110
(defmacro ecase (keyform &rest clauses)
111
"Syntax: (ecase keyform {({key | ({key}*)} {form}*)}*)
112
Evaluates KEYFORM and tries to find the KEY that is EQL to the value of
113
KEYFORM. If found, then evaluates FORMs that follow the KEY (or the key list
114
that contains the KEY) and returns all values of the last FORM. If not,
116
(setq clauses (remove-otherwise-from-clauses clauses))
117
(let ((key (gensym)))
118
`(let ((,key ,keyform))
120
(t (si::ecase-error ',keyform ,key ',(accumulate-cases 'ECASE clauses nil)))))))
122
(defun ccase-error (keyform key values)
123
(restart-case (error 'CASE-FAILURE
126
:expected-type (cons 'MEMBER values)
127
:possibilities values)
129
:REPORT (lambda (stream)
130
(format stream "Supply a new value of ~S" keyform))
131
:INTERACTIVE read-evaluated-form
132
(return-from ccase-error value))))
134
(defun remove-otherwise-from-clauses (clauses)
135
(declare (si::c-local))
136
(mapcar #'(lambda (clause)
137
(let ((options (first clause)))
138
(if (member options '(t otherwise))
139
(cons (list options) (rest clause))
143
(defmacro ccase (keyplace &rest clauses)
144
"Syntax: (ccase place {({key | ({key}*)} {form}*)}*)
145
Searches a KEY that is EQL to the value of PLACE. If found, then evaluates
146
FORMs in order that follow the KEY (or the key list that contains the KEY) and
147
returns all values of the last FORM. If no such KEY is found, signals a
148
continuable error. Before continuing, receives a new value of PLACE from
149
user and searches a KEY again. Repeats this process until the value of PLACE
150
becomes EQL to one of the KEYs."
151
(let* ((key (gensym))
154
(setq clauses (remove-otherwise-from-clauses clauses))
157
(let ((,key ,keyplace))
161
(si::ccase-error ',keyplace ,key
162
',(accumulate-cases 'CCASE clauses nil)))
165
(defmacro typecase (keyform &rest clauses)
166
"Syntax: (typecase keyform {(type {form}*)}*)
167
Evaluates KEYFORM and searches a TYPE to which the value of KEYFORM belongs.
168
If found, then evaluates FORMs that follow the TYPE and returns all values of
169
the last FORM. If not, simply returns NIL. The symbols T and OTHERWISE may
170
be used as a TYPE to specify the default case."
171
(do ((l (reverse clauses) (cdr l))
172
(form nil) (key (gensym)))
173
((endp l) `(let ((,key ,keyform)) ,form))
174
(if (or (eq (caar l) 't) (eq (caar l) 'otherwise))
175
(setq form `(progn ,@(cdar l)))
177
`(if (typep ,key (quote ,(caar l)))
182
(defun etypecase-error (keyform value types)
183
(error 'CASE-FAILURE :name 'ETYPECASE
185
:expected-type (cons 'OR types)
186
:possibilities types))
188
(defmacro etypecase (keyform &rest clauses &aux (key (gensym)))
189
"Syntax: (etypecase keyform {(type {form}*)}*)
190
Evaluates KEYFORM and searches a TYPE to which the value of KEYFORM belongs.
191
If found, then evaluates FORMs that follow the TYPE and returns all values of
192
the last FORM. If not, signals an error."
193
(setq clauses (remove-otherwise-from-clauses clauses))
194
(do ((l (reverse clauses) (cdr l)) ; Beppe
195
(form `(etypecase-error ',keyform ,key
196
',(accumulate-cases 'ETYPECASE clauses t))))
197
((endp l) `(let ((,key ,keyform)) ,form))
198
(setq form `(if (typep ,key ',(caar l))
204
(defun ctypecase-error (keyplace value types)
205
(restart-case (error 'CASE-FAILURE
208
:expected-type (cons 'OR types)
209
:possibilities types)
211
:REPORT (lambda (stream)
212
(format stream "Supply a new value of ~S." keyplace))
213
:INTERACTIVE read-evaluated-form
214
(return-from ctypecase-error value))))
216
(defmacro ctypecase (keyplace &rest clauses &aux (key (gensym)))
217
"Syntax: (ctypecase place {(type {form}*)}*)
218
Searches a TYPE to which the value of PLACE belongs. If found, then evaluates
219
FORMs that follow the TYPE and returns all values of the last FORM. If no
220
such TYPE is found, signals a continuable error. Before continuing, receives
221
a new value of PLACE from the user and searches an appropriate TYPE again.
222
Repeats this process until the value of PLACE becomes of one of the TYPEs."
223
(setq clauses (remove-otherwise-from-clauses clauses))
225
(let ((,key ,keyplace))
226
,@(mapcar #'(lambda (l)
227
`(when (typep ,key ',(car l))
228
(return (progn ,@(cdr l)))))
230
(setf ,keyplace (ctypecase-error ',keyplace ,key
231
',(accumulate-cases 'CTYPECASE clauses t))))))
added
removed
src/lsp/assert.lsp
