1 /* Part of XPCE --- The SWI-Prolog GUI toolkit
2
3 Author: Jan Wielemaker and Anjo Anjewierden
4 E-mail: jan@swi.psy.uva.nl
5 WWW: http://www.swi.psy.uva.nl/projects/xpce/
6 Copyright (c) 1985-2002, University of Amsterdam
7 All rights reserved.
8
9 Redistribution and use in source and binary forms, with or without
10 modification, are permitted provided that the following conditions
11 are met:
12
13 1. Redistributions of source code must retain the above copyright
14 notice, this list of conditions and the following disclaimer.
15
16 2. Redistributions in binary form must reproduce the above copyright
17 notice, this list of conditions and the following disclaimer in
18 the documentation and/or other materials provided with the
19 distribution.
20
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32 POSSIBILITY OF SUCH DAMAGE.
33 */
34
35 #define INLINE_UTILITIES 1
36 #include <h/kernel.h>
37
38 status
initialiseCode(Code c)39 initialiseCode(Code c)
40 { return initialiseProgramObject(c);
41 }
42
43
44 static Function
getConvertCode(Class class,QuoteFunction q)45 getConvertCode(Class class, QuoteFunction q)
46 { answer(q->function);
47 }
48
49
50 static status
debugClassCode(Code c,Name cls)51 debugClassCode(Code c, Name cls)
52 { if ( cls == NAME_user )
53 clearDFlag(c, D_SERVICE);
54 else
55 setDFlag(c, D_SERVICE);
56
57 succeed;
58 }
59
60
61 static Name
getDebugClassCode(Code c)62 getDebugClassCode(Code c)
63 { if ( onDFlag(c, D_SERVICE) )
64 return NAME_service;
65 else
66 return NAME_user;
67 }
68
69
70 /********************************
71 * FORWARDING *
72 ********************************/
73
74 static status
forwardVarsCodev(Code c,int argc,Assignment * argv)75 forwardVarsCodev(Code c, int argc, Assignment *argv)
76 { status rval;
77 int errors = 0;
78 int i;
79
80 withLocalVars({ for(i=0; i<argc; i++, argv++)
81 { Any value;
82
83 if ( (value = expandCodeArgument(argv[0]->value)) )
84 { assignVar(argv[0]->var, value, NAME_local);
85 if ( argv[0]->var == RECEIVER && isObject(value) )
86 assignVar(RECEIVER_CLASS, classOfObject(value),
87 NAME_local);
88 } else
89 { errors++;
90 break;
91 }
92 }
93
94 rval = (errors ? FAIL : executeCode(c));
95 });
96
97 return rval;
98 }
99
100
101
102 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
103 FORWARDING WITH PUSH OF @RECEIVER
104
105 The test of `if ( RECEIVER->value != receiver )' is dubious: we should
106 check whether the message actually is send to @receiver
107
108 TBD: Seems we can throw away all the sendSuperObject() and related stuff
109 using the XPCE 5 message passing code and only keep @receiver for
110 messages in dialog items.
111 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
112
113 status
userForwardReceiverCodev(Code c,Any receiver,int argc,const Any argv[])114 userForwardReceiverCodev(Code c, Any receiver, int argc, const Any argv[])
115 { Any receiver_save = RECEIVER->value;
116 Any receiver_class_save = RECEIVER_CLASS->value;
117 status rval;
118
119 RECEIVER->value = receiver;
120 RECEIVER_CLASS->value = classOfObject(receiver);
121 rval = forwardCodev(c, argc, argv);
122 RECEIVER_CLASS->value = receiver_class_save;
123 RECEIVER->value = receiver_save;
124
125 return rval;
126 }
127
128
129 status
forwardReceiverCodev(Code c,Any receiver,int argc,const Any argv[])130 forwardReceiverCodev(Code c, Any receiver, int argc, const Any argv[])
131 { if ( RECEIVER->value != receiver )
132 return userForwardReceiverCodev(c, receiver, argc, argv);
133 else
134 return forwardCodev(c, argc, argv);
135 }
136
137
138 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
139 VECTOR BASED FORWARDING
140 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
141
142 static status
forwardVectorCodev(Code c,int argc,const Any argv[])143 forwardVectorCodev(Code c, int argc, const Any argv[])
144 { Vector v;
145 int shift;
146 int args;
147
148 if ( argc == 0 )
149 goto usage;
150 if ( argc >= 2 && isInteger(argv[argc-1]) )
151 { v = argv[argc-2];
152 shift = valInt(argv[argc-1]);
153 args = argc-2;
154 } else
155 { v = argv[argc-1];
156 shift = 0;
157 args = argc-1;
158 }
159
160 if ( !instanceOfObject(v, ClassVector) )
161 goto usage;
162 else
163 { int argn = args+valInt(v->size)-shift;
164 ArgVector(av, args+valInt(v->size)-shift);
165 int i, n;
166
167 for(i=0; i<args; i++)
168 av[i] = argv[i];
169 for(n=shift; n<=valInt(v->size); n++)
170 av[i++] = v->elements[n];
171
172 return forwardCodev(c, argn, av);
173 }
174
175 usage:
176 return errorPce(c, NAME_badVectorUsage);
177 }
178
179
180 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
181 ARGLIST CODE INVOKATION
182 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
183
184 status
forwardCode(Code c,...)185 forwardCode(Code c, ...)
186 { va_list args;
187 Any argv[VA_PCE_MAX_ARGS];
188 int argc;
189
190 va_start(args, c);
191 for(argc=0; (argv[argc] = va_arg(args, Any)) != NULL; argc++)
192 assert(argc <= VA_PCE_MAX_ARGS);
193 va_end(args);
194
195 return forwardCodev(c, argc, argv);
196 }
197
198
199 status
forwardReceiverCode(Code c,Any rec,...)200 forwardReceiverCode(Code c, Any rec, ...)
201 { va_list args;
202 Any argv[VA_PCE_MAX_ARGS];
203 int argc;
204
205 va_start(args, rec);
206 for(argc=0; (argv[argc] = va_arg(args, Any)) != NULL; argc++)
207 assert(argc <= VA_PCE_MAX_ARGS);
208 va_end(args);
209
210 return forwardReceiverCodev(c, rec, argc, argv);
211 }
212
213
214 static status
ExecuteCode(Code c)215 ExecuteCode(Code c)
216 { Class cl = classOfObject(c);
217
218 FixGetFunctionClass(cl, NAME_Execute);
219 if ( cl->get_function )
220 { status rval;
221
222 if ( onDFlag(c, D_SERVICE) )
223 { ServiceMode(PCE_EXEC_SERVICE,
224 rval = ((*cl->get_function)(c) ? SUCCEED : FAIL));
225 } else
226 rval = (*cl->get_function)(c) ? SUCCEED : FAIL;
227
228 return rval;
229 }
230
231 return errorPce(c, NAME_cannotExecute);
232 }
233
234 static Any
getExecuteCode(Code c)235 getExecuteCode(Code c)
236 { errorPce(c, NAME_noFunction);
237
238 fail;
239 }
240
241
242
243 /********************************
244 * CLASS CODE_VECTOR *
245 ********************************/
246
247 Vector
createCodeVectorv(int argc,const Any argv[])248 createCodeVectorv(int argc, const Any argv[])
249 { Vector v = alloc(sizeof(struct vector));
250 int n;
251
252 initHeaderObj(v, ClassCodeVector);
253 v->offset = ZERO;
254 v->size = toInt(argc);
255 v->allocated = v->size;
256 v->elements = alloc(argc * sizeof(Any));
257
258 for(n=0; n < argc; n++)
259 { v->elements[n] = argv[n];
260 if ( isObject(argv[n]) && !isProtectedObj(argv[n]) )
261 addRefObj(argv[n]);
262 }
263
264 clearCreatingObj(v);
265
266 return v;
267 }
268
269
270 static Vector
getConvertCodeVector(Any ctx,Any in)271 getConvertCodeVector(Any ctx, Any in)
272 { if ( in == name_nil )
273 answer(createCodeVectorv(0, NULL));
274
275 fail;
276 }
277
278
279 static status
unlinkCodeVector(Vector v)280 unlinkCodeVector(Vector v)
281 { if ( v->elements != NULL )
282 { int size = valInt(v->size);
283 int n;
284 Any *argv = v->elements;
285
286 for(n=0; n<size; n++)
287 { if ( isObject(argv[n]) && !isProtectedObj(argv[n]) )
288 delRefObj(argv[n]);
289 }
290
291 unalloc(valInt(v->allocated)*sizeof(Any), v->elements);
292 v->elements = NULL;
293 }
294
295 succeed;
296 }
297
298
299 void
doneCodeVector(Vector v)300 doneCodeVector(Vector v)
301 { if ( isVirginObj(v) )
302 { unlinkCodeVector(v);
303 unalloc(sizeof(struct vector), v);
304 }
305 }
306
307
308 /*******************************
309 * CLASS DECLARATION *
310 *******************************/
311
312 /* Type declarations */
313
314 static char *T_element[] =
315 { "index=int", "value=any|function" };
316 static char *T_fill[] =
317 { "value=any|function", "from=[int]", "to=[int]" };
318
319 /* Instance Variables */
320
321 #define var_codeVector NULL
322 /*
323 static vardecl var_codeVector[] =
324 {
325 };
326 */
327
328 /* Send Methods */
329
330 static senddecl send_codeVector[] =
331 { SM(NAME_append, 1, "value=any|function ...", appendVector,
332 DEFAULT, NULL),
333 SM(NAME_element, 2, T_element, elementVector,
334 DEFAULT, NULL),
335 SM(NAME_fill, 3, T_fill, fillVector,
336 DEFAULT, NULL),
337 SM(NAME_initialise, 1, "element=any|function ...", initialiseVectorv,
338 DEFAULT, NULL),
339 SM(NAME_unlink, 0, NULL, unlinkCodeVector,
340 DEFAULT, NULL)
341 };
342
343 /* Get Methods */
344
345 static getdecl get_codeVector[] =
346 { GM(NAME_convert, 1, "code_vector", "any", getConvertCodeVector,
347 DEFAULT, "Convert [] into empty code-vector"),
348
349 };
350
351 /* Resources */
352
353 #define rc_codeVector NULL
354 /*
355 static classvardecl rc_codeVector[] =
356 {
357 };
358 */
359
360 /* Class Declaration */
361
362 ClassDecl(codeVector_decls,
363 var_codeVector, send_codeVector, get_codeVector, rc_codeVector,
364 ARGC_INHERIT, NULL,
365 "$Rev$");
366
367 status
makeClassCodeVector(Class class)368 makeClassCodeVector(Class class)
369 { declareClass(class, &codeVector_decls);
370
371 assign(class, un_answer, OFF);
372 assign(class, summary, CtoString("Argument vector"));
373
374 succeed;
375 }
376
377
378 /*******************************
379 * CLASS DECLARATION *
380 *******************************/
381
382 /* Type declarations */
383
384 static char *T_fwdrec[] =
385 { "receiver=any", "any ..."
386 };
387
388 /* Instance Variables */
389
390 #define var_code NULL
391 /*
392 static vardecl var_code[] =
393 {
394 };
395 */
396
397 /* Send Methods */
398
399 static senddecl send_code[] =
400 { SM(NAME_execute, 0, NULL, executeCode,
401 NAME_execute, "Execute code"),
402 SM(NAME_forward, 1, "any ...", forwardCodev,
403 NAME_execute, "Push @arg1, ... and execute"),
404 SM(NAME_forwardVars, 1, "assign ...", forwardVarsCodev,
405 NAME_execute, "Push vars and execute"),
406 SM(NAME_forwardVector, 1, "any ...", forwardVectorCodev,
407 NAME_execute, "Push @arg1, ... from a vector and execute"),
408 SM(NAME_forwardReceiver, 2, T_fwdrec, userForwardReceiverCodev,
409 NAME_execute, "Push @receiver, @arg1, ... and execute"),
410 SM(NAME_Execute, 0, NULL, ExecuteCode,
411 NAME_internal, "Execute the code object (redefined)"),
412 SM(NAME_debugClass, 1, "{user,service}", debugClassCode,
413 NAME_debugging, "Specify debug-capabilities")
414 };
415
416 /* Get Methods */
417
418 static getdecl get_code[] =
419 { GM(NAME_Execute, 0, "unchecked", NULL, getExecuteCode,
420 NAME_internal, "Execute the function object (error)"),
421 GM(NAME_convert, 1, "function", "quote=quote_function", getConvertCode,
422 DEFAULT, "Convert quoted function to value quoted"),
423 GM(NAME_debugClass, 0, "{user,service}", NULL, getDebugClassCode,
424 NAME_debugging, "Specify debug-capabilities")
425 };
426
427 /* Resources */
428
429 #define rc_code NULL
430 /*
431 static classvardecl rc_code[] =
432 {
433 };
434 */
435
436 /* Class Declaration */
437
438 ClassDecl(code_decls,
439 var_code, send_code, get_code, rc_code,
440 0, NULL,
441 "$Rev$");
442
443
444 status
makeClassCode(Class class)445 makeClassCode(Class class)
446 { declareClass(class, &code_decls);
447
448 cloneStyleClass(class, NAME_none);
449 assign(class, un_answer, OFF);
450
451 succeed;
452 }
453
454