1 /*
2  * ProcedureMacro.h -
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: ProcedureMacro.h 261 2008-07-25 06:16:44Z higepon $
30  */
31 
32 #ifndef SCHEME_PROCEDURE_MACRO_
33 #define SCHEME_PROCEDURE_MACRO_
34 
35 #include "scheme.h"
36 #include "ErrorProcedures.h"
37 #include "StringProcedures.h"
38 #include "VM.h"
39 
40 
41 #define checkPortIsOpen(port, obj) \
42     if (port->isClosed()) { \
43         return callIOReadErrorAfter(theVM, obj, procedureName, "port is closed"); \
44     }
45 
46 
47 // N.B For BinaryInputOutputPort Class, we use multiple inheritance.
48 // It is dangerous to reinterpret_cast<BinaryInput*>(theInstance).
49 // So we use special versio of argumentAsBinaryOutputPort and argumentAsBinaryInputPort.
50 
51 #define argumentAsPort(index, variableName) \
52     const Object obj ## variableName = argv[index];     \
53     Port* variableName;                                  \
54     if (obj ## variableName.isBinaryOutputPort()) { \
55         variableName = obj ## variableName.toBinaryOutputPort(); \
56     } else if (obj ## variableName.isBinaryInputPort()) {   \
57         variableName = obj ## variableName.toBinaryInputPort(); \
58     } else if (obj ## variableName.isTextualInputPort()) {   \
59         variableName = obj ## variableName.toTextualInputPort(); \
60     } else if (obj ## variableName.isTextualOutputPort()) {   \
61         variableName = obj ## variableName.toTextualOutputPort(); \
62     } else if (obj ## variableName.isTextualInputOutputPort()) { \
63         variableName = obj ## variableName.toTextualInputOutputPort(); \
64     } else if (obj ## variableName.isBinaryInputOutputPort()) { \
65         variableName = obj ## variableName.toBinaryInputOutputPort(); \
66     } else { \
67         callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "port", obj ## variableName); \
68         return Object::Undef; \
69     }
70 
71 
72 #define argumentAsBinaryOutputPort(index, variableName) \
73     const Object obj ## variableName = argv[index];     \
74     BinaryOutputPort* variableName;                                  \
75     if (obj ## variableName.isBinaryOutputPort()) { \
76         variableName = obj ## variableName.toBinaryOutputPort(); \
77     } else if (obj ## variableName.isBinaryInputOutputPort()) { \
78         variableName = obj ## variableName.toBinaryInputOutputPort(); \
79     } else { \
80         callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "binary-output-port", obj ## variableName); \
81         return Object::Undef; \
82     }
83 
84 #define argumentAsBinaryInputPort(index, variableName) \
85     const Object obj ## variableName = argv[index];     \
86     BinaryInputPort* variableName;                                  \
87     if (obj ## variableName.isBinaryInputPort()) { \
88         variableName = obj ## variableName.toBinaryInputPort(); \
89     } else if (obj ## variableName.isBinaryInputOutputPort()) { \
90         variableName = obj ## variableName.toBinaryInputOutputPort(); \
91     } else { \
92         callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "binary-input-port", obj ## variableName); \
93         return Object::Undef; \
94     }
95 
96 #define argumentAsU32(index, variableName) \
97     const Object obj ## variableName = argv[index];     \
98     uint32_t variableName;                              \
99     if (obj ## variableName.isFixnum()) { \
100         variableName = obj ## variableName.toFixnum(); \
101     } else if (obj ## variableName.isBignum()) { \
102         variableName = obj ## variableName.toBignum()->toU32();    \
103     } else { \
104         callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "uint32", obj ## variableName); \
105         return Object::Undef; \
106     }
107 
108 #define argumentAsTextualOutputPort(index, variableName) \
109     const Object obj ## variableName = argv[index];     \
110     TextualOutputPort* variableName;                                  \
111     if (obj ## variableName.isTextualOutputPort()) { \
112         variableName = obj ## variableName.toTextualOutputPort(); \
113     } else if (obj ## variableName.isTextualInputOutputPort()) { \
114         variableName = obj ## variableName.toTextualInputOutputPort(); \
115     } else { \
116         callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "textual-output-port", obj ## variableName); \
117         return Object::Undef; \
118     }
119 
120 #define argumentAsTextualInputPort(index, variableName) \
121     const Object obj ## variableName = argv[index];     \
122     TextualInputPort* variableName;                                  \
123     if (obj ## variableName.isTextualInputPort()) { \
124         variableName = obj ## variableName.toTextualInputPort(); \
125     } else if (obj ## variableName.isTextualInputOutputPort()) { \
126         variableName = obj ## variableName.toTextualInputOutputPort(); \
127     } else { \
128         callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "textual-input-port", obj ## variableName); \
129         return Object::Undef; \
130     }
131 
132 
133 
134 #define checkType(index, variableName, pred, required) \
135     const Object variableName = argv[index]; \
136     if (!variableName.pred()) { \
137         callWrongTypeOfArgumentViolationAfter(theVM, procedureName, #required, variableName); \
138         return Object::Undef; \
139     } \
140 
141 #define castArgument(index, variableName, pred, required, type, castFunction)    \
142     const Object obj ## variableName = argv[index]; \
143     if (!obj ## variableName.pred()) { \
144         callWrongTypeOfArgumentViolationAfter(theVM, procedureName, #required, obj ## variableName); \
145         return Object::Undef; \
146     } \
147     type variableName = obj ## variableName.castFunction();
148 
149 
150 #define checkTypeOrFalse(index, variableName, pred, required) \
151     const Object variableName = argv[index]; \
152     if (!variableName.pred() && !variableName.isFalse()) { \
153         callWrongTypeOfArgumentViolationAfter(theVM, procedureName, #required " or #f", variableName); \
154         return Object::Undef; \
155     } \
156 
157 #define checkTypeOr(index, variableName, pred1, pred2, required1, required2)  \
158     const Object variableName = argv[index]; \
159     if (!variableName.pred1() && !variableName.pred2()) { \
160         callWrongTypeOfArgumentViolationAfter(theVM, procedureName, #required1 " or " #required2, variableName); \
161         return Object::Undef; \
162     } \
163 
164 #define argumentCheckList(index, variableName) checkType(index, variableName, isList, list)
165 #define argumentAsSymbol(index, variableName) castArgument(index, variableName, isSymbol, symbol, Symbol*, toSymbol)
166 #define argumentAsVM(index, variableName) castArgument(index, variableName, isVM, vm, VM*, toVM)
167 #define argumentAsMutex(index, variableName) castArgument(index, variableName, isMutex, mutex, Mutex*, toMutex)
168 #define argumentAsConditionVariable(index, variableName) castArgument(index, variableName, isConditionVariable, condition-variable, ConditionVariable*, toConditionVariable)
169 #define argumentAsVector(index, variableName) castArgument(index, variableName, isVector, vector, Vector*, toVector)
170 #define argumentAsCodeBuilder(index, variableName) castArgument(index, variableName, isCodeBuilder, code-builder, CodeBuilder*, toCodeBuilder)
171 
172 #define argumentAsAnnotatedPair(index, variableName) castArgument(index, variableName, isAnnotatedPair, AnnotatedPair, AnnotatedPair*, toAnnotatedPair)
173 #define argumentAsPointer(index, variableName) castArgument(index, variableName, isPointer, pointer, Pointer*, toPointer)
174 #define argumentAsSocket(index, variableName) castArgument(index, variableName, isSocket, socket, Socket*, toSocket)
175 #define argumentAsSimpleStruct(index, variableName) castArgument(index, variableName, isSimpleStruct, simple-struct, SimpleStruct*, toSimpleStruct)
176 #define argumentAsFlonum(index, variableName) castArgument(index, variableName, isFlonum, flonum, Flonum*, toFlonum)
177 #define argumentAsFixnum(index, variableName) castArgument(index, variableName, isFixnum, fixnum, int, toFixnum)
178 
nth(int index)179 inline const char* nth(int index) {
180     switch(index) {
181     case(0):
182         return "1st";
183     case(1):
184         return "2nd";
185     case(2):
186         return "3rd";
187     default:
188         static char buf[16];
189         sprintf(buf, "%dth", index + 1);
190         return buf;
191     }
192 }
193 
194 #define argumentAsPositiveFixnum(index, variableName) \
195     argumentAsFixnum(index, variableName);            \
196     if (variableName <= 0) {                                             \
197         static char buf[64];                                            \
198         sprintf(buf, "%s argument: positive integer", nth(index)); \
199         callWrongTypeOfArgumentViolationAfter(theVM, procedureName, ucs4string::from_c_str(buf), argv[index]); \
200         return Object::Undef;                                           \
201     }
202 
203 #define argumentAsNonNegativeFixnum(index, variableName) \
204     argumentAsFixnum(index, variableName);            \
205     if (variableName < 0) {                                             \
206         static char buf[64];                                            \
207         sprintf(buf, "%s argument: non-negative integer", nth(index)); \
208         callWrongTypeOfArgumentViolationAfter(theVM, procedureName, ucs4string::from_c_str(buf), argv[index]); \
209         return Object::Undef;                                           \
210     }
211 
212 
213 #define argumentAsOctet(index, variableName) castArgument(index, variableName, isOctet, octet, uint8_t, toFixnum)
214 #define argumentAsCompnum(index, variableName) castArgument(index, variableName, isCompnum, Complex number, Compnum*, toCompnum)
215 #define argumentAsHashTable(index, variableName) castArgument(index, variableName, isHashTable, hashtable, HashTable*, toHashTable)
216 #define argumentCheckChar(index, variableName) checkType(index, variableName, isChar, char)
217 #define argumentCheckFixnum(index, variableName) checkType(index, variableName, isFixnum, fixnum)
218 #define argumentCheckFlonum(index, variableName) checkType(index, variableName, isFlonum, flonum)
219 #define argumentCheckExactInteger(index, variableName) checkType(index, variableName, isExactInteger, exact integer)
220 #define argumentCheckIntegerValued(index, variableName) checkType(index, variableName, isIntegerValued, integer)
221 #define argumentCheckNumber(index, variableName) checkType(index, variableName, isNumber, number)
222 #define argumentCheckRational(index, variableName) checkType(index, variableName, isRational, rational number)
223 #define argumentCheckReal(index, variableName) checkType(index, variableName, isReal, real)
224 #define argumentAsClosure(index, variableName) castArgument(index, variableName, isClosure, closure, Closure*, toClosure)
225 
226 #define argumentCheckProcedure(index, variableName) checkType(index, variableName, isProcedure, procedure)
227 
228 #define argumentCheckVector(index, variableName) checkType(index, variableName, isVector, vector)
229 
230 #define argumentCheckString(index, variableName) checkType(index, variableName, isString, string)
231 #define argumentCheckSymbol(index, variableName) checkType(index, variableName, isSymbol, symbol)
232 #define argumentCheckSimpleStruct(index, variableName) checkType(index, variableName, isSimpleStruct, simplestruct)
233 #define argumentCheckSymbolOrFalse(index, variableName) checkTypeOrFalse(index, variableName, isSymbol, symbol)
234 #define argumentCheckStringOrFalse(index, variableName) checkTypeOrFalse(index, variableName, isString, string)
235 
236 #define argumentCheckBoolean(index, variableName) checkType(index, variableName, isBoolean, boolean)
237 #define argumentCheckClosure(index, variableName) checkType(index, variableName, isClosure, closure)
238 #define argumentCheckClosureOrFalse(index, variableName) checkTypeOrFalse(index, variableName, isClosure, closure)
239 
240 
241 //#define argumentAsPort(index, variableName) castArgument(index, variableName, isPort, port, Port*, toPort)
242 #define argumentCheckPair(index, variableName) checkType(index, variableName, isPair, pair)
243 
244 //#define argumentAsTextualOutputPort(index, variableName) castArgument(index, variableName, isTextualOutputPort, textual-output-port, TextualOutputPort*, toTextualOutputPort)
245 
246 #define argumentAsRegexp(index, variableName) castArgument(index, variableName, isRegexp, regexp, Regexp*, toRegexp)
247 #define argumentAsRegMatch(index, variableName) castArgument(index, variableName, isRegMatch, regexp, RegMatch*, toRegMatch)
248 #define argumentAsString(index, variableName) castArgument(index, variableName, isString, string, String*, toString)
249 
250 
251 #define argumentAsChar(index, variableName) castArgument(index, variableName, isChar, character, ucs4char, toChar)
252 
253 #define argumentCheckProcedure(index, variableName) checkType(index, variableName, isProcedure, procedure)
254 #define argumentCheckProcedureOrFalse(index, variableName) checkTypeOrFalse(index, variableName, isProcedure, procedure)
255 
256 #define argumentAsByteVector(index, variableName) castArgument(index, variableName, isByteVector, bytevector, ByteVector*, toByteVector)
257 #define argumentAsTranscoder(index, variableName) castArgument(index, variableName, isTranscoder, transcoder, Transcoder*, toTranscoder)
258 #define argumentAsCodec(index, variableName) castArgument(index, variableName, isCodec, codec, Codec*, toCodec)
259 #define argumentCheckTextualInputPort(index, variableName) checkType(index, variableName, isTextualInputPort, textual-input-port)
260 #define argumentCheckTextualOutputPort(index, variableName) checkType(index, variableName, isTextualOutputPort, textual-output-port)
261 #define argumentCheckOutputPort(index, variableName) checkType(index, variableName, isOutputPort, output-port)
262 #define argumentCheckPort(index, variableName) checkType(index, variableName, isPort, port)
263 #define argumentCheckTranscoderOrFalse(index, variableName) checkTypeOrFalse(index, variableName, isTranscoder, transcoder)
264 
265 
266 #define DeclareProcedureName(name) const ucs4char* procedureName = UC(name); theVM->setNumValues1();
267 
268 #define checkArgumentLength(required)   \
269     if (argc != required) { \
270         callWrongNumberOfArgumentsViolationAfter(theVM, procedureName, required, argc); \
271         return Object::Undef;\
272     } \
273 
274 #define checkArgumentLengthBetween(start, end)             \
275     if (argc < start || argc > end) { \
276         callWrongNumberOfArgumentsBetweenViolationAfter(theVM, procedureName, start, end, argc); \
277         return Object::Undef;\
278     } \
279 
280 //#define argumentAsTextualInputPort(index, variableName) castArgument(index, variableName, isTextualInputPort, textual-input-port, TextualInputPort*, toTextualInputPort)
281 
282 #define checkArgumentLengthAtLeast(required)             \
283     if (argc < required) { \
284         callWrongNumberOfArgumentsAtLeastViolationAfter(theVM, procedureName, required, argc); \
285         return Object::Undef;\
286     } \
287 
288 #endif // SCHEME_PROCEDURE_MACRO_
289