1 /*
2 * ErrorProcedures.cpp -
3 *
4 * Copyright (c) 2008 Higepon(Taro Minowa) <higepon@users.sourceforge.jp>
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
18 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
19 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
20 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
21 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
22 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
23 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
24 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
25 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28 *
29 * $Id: ViolationProcedures.cpp 183 2008-07-04 06:19:28Z higepon $
30 */
31
32 #include "Object.h"
33 #include "Object-inl.h"
34 #include "Pair.h"
35 #include "Pair-inl.h"
36 #include "SString.h"
37 #include "Symbol.h"
38 #include "Closure.h"
39 #include "VM.h"
40 #include "ErrorProcedures.h"
41 #include "ProcedureMacro.h"
42 #include "PortProcedures.h"
43 #include "TextualOutputPort.h"
44 #include "StringProcedures.h"
45 #include "Closure.h"
46
47 using namespace scheme;
48
49 jmp_buf scheme::ioErrorJmpBuf;
50 IOError scheme::ioError;
51
52 #ifdef DEBUG_VERSION
53 bool scheme::isErrorBufInitialized = false;
54 #endif
55
raiseAfter2(VM * theVM,const ucs4char * procName,Object who,Object message)56 static Object raiseAfter2(VM* theVM, const ucs4char* procName, Object who, Object message)
57 {
58 const Object procedure = theVM->getGlobalValueOrFalse(Symbol::intern(procName));
59 if (procedure.isFalse()) {
60 const Object content = format(theVM, UC(" WARNING: Error occured before (~e ...) defined\n"), Pair::list1(procName));
61 theVM->currentErrorPort().toTextualOutputPort()->display(theVM, content);
62 const Object condition = format(theVM,
63 UC(" Condition components:\n"
64 " 1. ~e\n"
65 " 2. &who: ~e\n"
66 " 3. &message: ~s\n"), Pair::list3(procName, who, message));
67 theVM->throwException(condition);
68 } else {
69 theVM->setAfterTrigger2(procedure, who, message);
70 }
71 return Object::Undef;
72 }
73
raiseAfter3(VM * theVM,const ucs4char * procName,Object who,Object message,Object irritants)74 static Object raiseAfter3(VM* theVM, const ucs4char* procName, Object who, Object message, Object irritants)
75 {
76 const Object procedure = theVM->getGlobalValueOrFalse(Symbol::intern(procName));
77 if (procedure.isFalse()) {
78 const Object content = format(theVM, UC(" WARNING: Error occured before (~e ...) defined\n"), Pair::list1(procName));
79 theVM->currentErrorPort().toTextualOutputPort()->display(theVM, content);
80 const Object condition = format(theVM,
81 UC(" Condition components:\n"
82 " 1. ~e\n"
83 " 2. &who: ~e\n"
84 " 3. &message: ~s\n"
85 " 4. &irritants: ~e\n"), Pair::list4(procName, who, message, irritants));
86 theVM->throwException(condition);
87 } else {
88 theVM->setAfterTrigger3(procedure, who, message, irritants);
89 }
90 return Object::Undef;
91 }
92
raiseAfter4(VM * theVM,const ucs4char * procName,Object who,Object message,Object irritant1,Object irritant2)93 static Object raiseAfter4(VM* theVM, const ucs4char* procName, Object who, Object message, Object irritant1, Object irritant2)
94 {
95 const Object procedure = theVM->getGlobalValueOrFalse(Symbol::intern(procName));
96 if (procedure.isFalse()) {
97 const Object content = format(theVM, UC(" WARNING: Error occured before (~e ...) defined\n"), Pair::list1(procName));
98 theVM->currentErrorPort().toTextualOutputPort()->display(theVM, content);
99 const Object condition = format(theVM,
100 UC(" Condition components:\n"
101 " 1. ~e\n"
102 " 2. &who: ~e\n"
103 " 3. &message: ~s\n"
104 " 4. &irritants: ~e\n"), Pair::list4(procName, who, message, Pair::list2(irritant1, irritant2)));
105 theVM->throwException(condition);
106 } else {
107 theVM->setAfterTrigger4(procedure, who, message, irritant1, irritant2);
108 }
109 return Object::Undef;
110 }
111
callIOReadErrorAfter(VM * theVM,Object who,Object message,Object port)112 Object scheme::callIOReadErrorAfter(VM* theVM, Object who, Object message, Object port)
113 {
114 return raiseAfter3(theVM, UC("raise-i/o-read-error"), who, message, port);
115 }
116
117
callIOErrorAfter(VM * theVM,Object who,Object message,Object irritants)118 Object scheme::callIOErrorAfter(VM* theVM, Object who, Object message, Object irritants)
119 {
120 return raiseAfter3(theVM, UC("raise-i/o-read-error"), who, message, irritants);
121 }
122
callIOErrorAfter(VM * theVM,IOError e)123 Object scheme::callIOErrorAfter(VM* theVM, IOError e)
124 {
125 switch(e.type) {
126 case IOError::DECODE:
127 {
128 return raiseAfter3(theVM, UC("raise-i/o-decoding-error"), e.who, e.message, e.arg1);
129 }
130 case IOError::ENCODE:
131 {
132 return raiseAfter4(theVM, UC("raise-i/o-encoding-error"), e.who, e.message, e.arg1, e.irritants);
133 }
134 case IOError::READ:
135 {
136 return callIOReadErrorAfter(theVM, e.who, e.message, e.irritants);
137 }
138 case IOError::WRITE:
139 {
140 return raiseAfter3(theVM, UC("raise-i/o-write-error"), e.who, e.message, e.irritants);
141 }
142 default:
143 callAssertionViolationAfter(theVM, e.who, e.message, e.irritants);
144 break;
145
146 }
147 return Object::Undef;
148 }
149
throwIOError2(int type,Object message,Object irritants)150 Object scheme::throwIOError2(int type, Object message, Object irritants /* = Object::Nil */)
151 {
152 ioError = IOError(type, message, irritants);
153 MOSH_ASSERT(isErrorBufInitialized);
154 longjmp(ioErrorJmpBuf, -1);
155 return Object::Undef;
156 }
157
throwEx(VM * theVM,int argc,const Object * argv)158 Object scheme::throwEx(VM* theVM, int argc, const Object* argv)
159 {
160 DeclareProcedureName("throw");
161 checkArgumentLength(1);
162 theVM->throwException(argv[0]);
163 return Object::Undef;
164 }
165
callNotImplementedAssertionViolationAfter(VM * theVM,Object who,Object irritants)166 void scheme::callNotImplementedAssertionViolationAfter(VM* theVM, Object who, Object irritants /* = Object::Nil */)
167 {
168 callAssertionViolationAfter(theVM, who, "not implemented", irritants);
169 }
170
callWrongTypeOfArgumentViolationAfter(VM * theVM,Object who,Object requiredType,Object gotValue,Object irritants)171 void scheme::callWrongTypeOfArgumentViolationAfter(VM* theVM, Object who, Object requiredType, Object gotValue, Object irritants /* = Object::Nil */)
172 {
173 const Object message = format(theVM, UC("~e required, but got ~e"),
174 Pair::list2(requiredType, gotValue));
175 callAssertionViolationAfter(theVM, who, message, irritants);
176 }
177
callWrongNumberOfArgumentsBetweenViolationAfter(VM * theVM,Object who,int startCounts,int endCounts,int gotCounts,Object irritants)178 void scheme::callWrongNumberOfArgumentsBetweenViolationAfter(VM* theVM, Object who, int startCounts, int endCounts, int gotCounts, Object irritants /* = Object::Nil */)
179 {
180 const Object message = format(theVM, UC("wrong number of arguments (required between ~d and ~d, got ~d)"),
181 Pair::list3(Object::makeFixnum(startCounts),
182 Object::makeFixnum(endCounts),
183 Object::makeFixnum(gotCounts)));
184 callAssertionViolationAfter(theVM, who, message, irritants);
185 }
186
callWrongNumberOfArgumentsViolationAfter(VM * theVM,Object who,int requiredCounts,int gotCounts,Object irritants)187 void scheme::callWrongNumberOfArgumentsViolationAfter(VM* theVM, Object who, int requiredCounts, int gotCounts, Object irritants /* Object::Nil */ )
188 {
189 const Object message = format(theVM, UC("wrong number of arguments (required ~d, got ~d)"),
190 Pair::list2(Object::makeFixnum(requiredCounts),
191 Object::makeFixnum(gotCounts)));
192 callAssertionViolationAfter(theVM, who, message, irritants);
193 }
194
callWrongNumberOfArgumentsAtLeastViolationAfter(VM * theVM,Object who,int requiredCounts,int gotCounts,Object irritants)195 void scheme::callWrongNumberOfArgumentsAtLeastViolationAfter(VM* theVM, Object who, int requiredCounts, int gotCounts, Object irritants /* Object::Nil */ )
196 {
197 const Object message = format(theVM, UC("wrong number of arguments (required at least ~d, got ~d)"),
198 Pair::list2(Object::makeFixnum(requiredCounts),
199 Object::makeFixnum(gotCounts)));
200 callAssertionViolationAfter(theVM, who, message, irritants);
201 }
202
203 // we can't catch this!
callAssertionViolationImmidiaImmediately(VM * theVM,Object who,Object message,Object irritants)204 void scheme::callAssertionViolationImmidiaImmediately(VM* theVM, Object who, Object message, Object irritants /* = Object::Nil */)
205 {
206 MOSH_ASSERT(theVM);
207 const Object condition = format(theVM,
208 UC(" Condition components:\n"
209 " 1. &assertion\n"
210 " 2. &who: ~e\n"
211 " 3. &message: ~s\n"
212 " 4. &irritants: ~e\n"), Pair::list3(who, message, irritants));
213 theVM->currentErrorPort().toTextualOutputPort()->display(theVM, " WARNING: Error occured before (assertion-violation ...) defined\n");
214 theVM->throwException(condition);
215 }
216
callIOInvalidPositionAfter(VM * theVM,Object who,Object message,Object irritants,Object position)217 Object scheme::callIOInvalidPositionAfter(VM* theVM, Object who, Object message, Object irritants, Object position)
218 {
219 return raiseAfter4(theVM, UC("raise-i/o-invalid-position-error"), who, message, irritants, position);
220 }
221
callAssertionViolationAfter(VM * theVM,Object who,Object message,Object irritants)222 Object scheme::callAssertionViolationAfter(VM* theVM, Object who, Object message, Object irritants /* = Object::Nil */)
223 {
224 // LOG1("message=~e\n", message);
225 // LOG1("who=~e\n", who);
226 // LOG1("irritants=~e\n", irritants);
227 if (theVM->isR6RSMode()) {
228 return raiseAfter3(theVM, UC("assertion-violation"), who, message, irritants);
229 } else {
230 const Object procedure = theVM->getGlobalValueOrFalse(Symbol::intern(UC("raise")));
231 // Error occured before (raise ...) is defined.
232 if (procedure.isFalse()) {
233 Object condition = format(theVM,
234 UC(
235 " Condition components:\n"
236 " 1. ~e\n"
237 " 2. &who: ~e\n"
238 " 3. &message: ~s\n"
239 " 4. &irritants: ~e\n"), Pair::list4("&assertion", who, message, irritants));
240
241 theVM->currentErrorPort().toTextualOutputPort()->display(theVM, " WARNING: Error occured before (assertion-violation ...) defined\n");
242 theVM->throwException(condition);
243 } else {
244 Object condition = format(theVM,
245 UC(
246 " Condition components:\n"
247 " 1. ~e\n"
248 " 2. &who: ~e\n"
249 " 3. &message: ~s\n"
250 " 4. &irritants: ~e\n"), Pair::list4("&assertion", who, message, irritants));
251
252 theVM->setAfterTrigger1(procedure, condition);
253 }
254 }
255 return Object::Undef;
256 }
257
callUndefinedViolationAfter(VM * theVM,Object who,Object message)258 Object scheme::callUndefinedViolationAfter(VM* theVM, Object who, Object message)
259 {
260 return raiseAfter2(theVM, UC("undefined-violation"), who, message);
261 }
262
263 // we can't catch this!
callLexicalViolationImmidiaImmediately(VM * theVM,Object who,Object message,Object irritants)264 void scheme::callLexicalViolationImmidiaImmediately(VM* theVM, Object who, Object message, Object irritants /* = Object::Nil */)
265 {
266 MOSH_ASSERT(theVM);
267 const Object condition = format(theVM,
268 UC(
269 " Condition components:\n"
270 " 1. &lexical\n"
271 " 2. &who: ~e\n"
272 " 3. &message: ~s\n"
273 " 4. &irritants: ~e\n"), Pair::list3(who, message, irritants));
274 theVM->currentErrorPort().toTextualOutputPort()->display(theVM, " WARNING: Error occured before (lexical ...) defined\n");
275 theVM->throwException(condition);
276 }
277
callImplementationRestrictionAfter(VM * theVM,Object who,Object message,Object irritants)278 Object scheme::callImplementationRestrictionAfter(VM* theVM, Object who, Object message, Object irritants)
279 {
280 return raiseAfter3(theVM, UC("implementation-restriction-violation"), who, message, irritants);
281 }
282
callLexicalAndIOReadAfter(VM * theVM,Object who,Object message)283 Object scheme::callLexicalAndIOReadAfter(VM* theVM, Object who, Object message)
284 {
285 return raiseAfter2(theVM, UC("raise-lexical-violation-read-error"), who, message);
286 }
287
callIoFileNameErrorAfter(VM * theVM,Object who,Object message,Object filename)288 Object scheme::callIoFileNameErrorAfter(VM* theVM, Object who, Object message, Object filename)
289 {
290 return raiseAfter3(theVM, UC("raise-i/o-filename-error"), who, message, filename);
291 }
292
callIoFileNotExistAfter(VM * theVM,Object who,Object message,Object filename)293 Object scheme::callIoFileNotExistAfter(VM* theVM, Object who, Object message, Object filename)
294 {
295 return raiseAfter3(theVM, UC("raise-i/o-file-does-not-exist-error"), who, message, filename);
296 }
297
callIoFileAlreadyExistAfter(VM * theVM,Object who,Object message,Object filename)298 Object scheme::callIoFileAlreadyExistAfter(VM* theVM, Object who, Object message, Object filename)
299 {
300 return raiseAfter3(theVM, UC("raise-i/o-file-already-exists-error"), who, message, filename);
301 }
302
callIoFileProtectionAfter(VM * theVM,Object who,Object message,Object filename)303 Object scheme::callIoFileProtectionAfter(VM* theVM, Object who, Object message, Object filename)
304 {
305 return raiseAfter3(theVM, UC("raise-i/o-file-protection-error"), who, message, filename);
306 }
307
callIoFileReadOnlyAfter(VM * theVM,Object who,Object message,Object filename)308 Object scheme::callIoFileReadOnlyAfter(VM* theVM, Object who, Object message, Object filename)
309 {
310 return raiseAfter3(theVM, UC("raise-i/o-file-is-read-only-error"), who, message, filename);
311 }
312
callErrorAfter(VM * theVM,Object who,Object message,Object irritants)313 Object scheme::callErrorAfter(VM* theVM, Object who, Object message, Object irritants /* = Object::Nil */)
314 {
315 return raiseAfter3(theVM, UC("error"), who, message, irritants);
316 }
317