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 #ifdef __WINDOWS__
36 #define USE_WIN32_CRITICAL_SECTION
37 #endif
38
39 #define _GNU_SOURCE 1 /* for recursive mutexes */
40 #define INLINE_UTILITIES 1
41 #include <h/kernel.h>
42 #include <h/trace.h>
43 #include <itf/c.h>
44
45 /* Win32 native locking */
46 #ifdef USE_WIN32_CRITICAL_SECTION
47 #define HAS_LOCK 1
48
49 static CRITICAL_SECTION mutex;
50 int lock_count;
51 DWORD lock_owner;
52
53 int
pceMTTryLock(int lock)54 pceMTTryLock(int lock)
55 { if ( XPCE_mt == TRUE )
56 { if ( TryEnterCriticalSection(&mutex) ) /* NT 4 and later! */
57 { if ( lock_count++ == 0 )
58 lock_owner = GetCurrentThreadId();
59 return TRUE;
60 } else
61 return FALSE;
62 }
63
64 return TRUE;
65 }
66
67 static inline void
LOCK()68 LOCK()
69 { if ( XPCE_mt == TRUE )
70 { EnterCriticalSection(&mutex);
71 if ( lock_count++ == 0 )
72 lock_owner = GetCurrentThreadId();
73 }
74 }
75
76 static inline void
UNLOCK()77 UNLOCK()
78 { if ( XPCE_mt == TRUE )
79 { if ( --lock_count == 0 )
80 lock_owner = 0;
81 LeaveCriticalSection(&mutex);
82 }
83 }
84
85 #define Code SWI_Code
86 #include <SWI-Prolog.h>
87 static foreign_t
pce_lock_owner(term_t owner,term_t count)88 pce_lock_owner(term_t owner, term_t count)
89 { if ( PL_unify_integer(owner, lock_owner) &&
90 PL_unify_integer(count, lock_count) )
91 return TRUE;
92
93 return FALSE;
94 }
95
96 int
pceMTinit()97 pceMTinit()
98 { InitializeCriticalSection(&mutex);
99 XPCE_mt = TRUE;
100
101 PL_register_foreign("pce_lock_owner", 2, pce_lock_owner, 0);
102
103 succeed;
104 }
105
106 #endif /*USE_WIN32_CRITICAL_SECTION*/
107
108 /* POSIX thread based locking */
109
110 #if defined(_REENTRANT) && !defined(HAS_LOCK)
111 #define HAS_LOCK 1
112 #define var pthread_sys_var /* avoid AIX name conflict */
113 #include <pthread.h>
114 #undef var
115
116 #ifdef PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP
117
118 static pthread_mutex_t mutex = PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP;
119
120 #define LOCK() \
121 if ( XPCE_mt ) pthread_mutex_lock(&mutex)
122 #define UNLOCK() \
123 if ( XPCE_mt ) pthread_mutex_unlock(&mutex)
124
125 int
pceMTTryLock(int lock)126 pceMTTryLock(int lock)
127 { if ( XPCE_mt == TRUE )
128 { if ( pthread_mutex_trylock(&mutex) != 0 )
129 return FALSE;
130 }
131
132 return TRUE;
133 }
134
135 #else /*PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP*/
136
137 typedef struct _mutex_t
138 { pthread_t owner;
139 int count;
140 pthread_mutex_t lock;
141 } recursive_mutex_t;
142
143 #define RECURSIVE_MUTEX_INIT { 0, 0, PTHREAD_MUTEX_INITIALIZER }
144
145 static recursive_mutex_t mutex = RECURSIVE_MUTEX_INIT;
146
147 static inline void
LOCK()148 LOCK()
149 { if ( XPCE_mt )
150 { if ( mutex.owner != pthread_self() )
151 { pthread_mutex_lock(&(mutex.lock));
152 mutex.owner = pthread_self();
153 mutex.count = 1;
154 } else
155 mutex.count++;
156 }
157 }
158
159
160 static inline void
UNLOCK()161 UNLOCK()
162 { if ( XPCE_mt )
163 { if ( mutex.owner == pthread_self() )
164 { if ( --mutex.count < 1 )
165 { mutex.owner = 0;
166 pthread_mutex_unlock(&(mutex.lock));
167 }
168 } else
169 assert(0);
170 }
171 }
172
173
174 int
pceMTTryLock(int lock)175 pceMTTryLock(int lock)
176 { if ( XPCE_mt )
177 { if ( mutex.owner != pthread_self() )
178 { if ( pthread_mutex_trylock(&(mutex.lock)) != 0 )
179 return FALSE;
180
181 mutex.owner = pthread_self();
182 mutex.count = 1;
183 } else
184 mutex.count++;
185 }
186
187 return TRUE;
188 }
189
190 #endif /*PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP*/
191
192 int
pceMTinit()193 pceMTinit()
194 { XPCE_mt = TRUE;
195
196 succeed;
197 }
198
199 #endif /*_REENTRANT*/
200
201 /* No threading */
202 #ifndef HAS_LOCK
203 #define LOCK()
204 #define UNLOCK()
205
206 int /* signal we can't do this */
pceMTinit()207 pceMTinit()
208 { fail;
209 }
210
211 int
pceMTTryLock(int lock)212 pceMTTryLock(int lock)
213 { return TRUE;
214 }
215
216 #endif
217
218 void
pceMTLock(int lock)219 pceMTLock(int lock)
220 { LOCK();
221 }
222
223 void
pceMTUnlock(int lock)224 pceMTUnlock(int lock)
225 { UNLOCK();
226 }
227
228 #define pushGoal(g) { LOCK(); \
229 (g)->parent = CurrentGoal; \
230 CurrentGoal = g; \
231 }
232 #define popGoal(g) { CurrentGoal = (g)->parent; \
233 UNLOCK(); \
234 }
235
236 int
pceSetErrorGoal(PceGoal g,int err,...)237 pceSetErrorGoal(PceGoal g, int err, ...)
238 { va_list args;
239
240 if ( g->errcode != PCE_ERR_OK )
241 fail;
242 g->errcode = err;
243
244 va_start(args, err);
245 switch(err)
246 { case PCE_ERR_OK:
247 case PCE_ERR_NO_BEHAVIOUR:
248 case PCE_ERR_TOO_MANY_ARGS:
249 break;
250 case PCE_ERR_ARGTYPE:
251 case PCE_ERR_RETTYPE:
252 case PCE_ERR_ANONARG_AFTER_NAMED:
253 g->errc1 = va_arg(args, PceObject); /* argument value */
254 break;
255 case PCE_ERR_NO_NAMED_ARGUMENT:
256 g->errc1 = va_arg(args, PceObject); /* argument name */
257 break;
258 case PCE_ERR_MISSING_ARGUMENT:
259 g->errc1 = va_arg(args, PceObject); /* index of missing arg */
260 break;
261 case PCE_ERR_CODE_AS_GETMETHOD:
262 g->errc1 = va_arg(args, PceObject); /* offending code object */
263 break;
264 case PCE_ERR_PERMISSION:
265 g->errc1 = va_arg(args, PceObject); /* offending operation */
266 break;
267 case PCE_ERR_FUNCTION_FAILED:
268 g->errc1 = va_arg(args, PceObject); /* failing function */
269 break;
270 case PCE_ERR_ERROR:
271 break;
272 }
273 va_end(args);
274
275 fail;
276 }
277
278
279 static Method
getMethodMethodList(Any list,Name sel)280 getMethodMethodList(Any list, Name sel)
281 { if ( instanceOfObject(list, ClassMethod) )
282 { Method m = list;
283
284 if ( m->name == sel )
285 answer(m);
286
287 fail;
288 } else if ( instanceOfObject(list, ClassChain) )
289 { Chain ch = list;
290 Cell cell;
291 Method m;
292
293 for_cell(cell, ch)
294 { if ( (m = getMethodMethodList(cell->value, sel)) )
295 answer(m);
296 }
297
298 fail;
299 } else
300 { errorPce(list, NAME_unexpectedType, CtoType("method|chain"));
301 fail;
302 }
303 }
304
305
306 static Method
getCatchAllMethodGoal(PceGoal g)307 getCatchAllMethodGoal(PceGoal g)
308 { Class cl = g->class;
309 Method m, *mp;
310
311 if ( !cl )
312 cl = classOfObject(g->receiver);
313
314 mp = ((g->flags & PCE_GF_SEND) ? (Method *)&cl->send_catch_all
315 : (Method *)&cl->get_catch_all);
316 m = *mp;
317
318 if ( isDefault(m) )
319 { if ( g->flags & PCE_GF_SEND )
320 m = getSendMethodClass(cl, NAME_catchAll);
321 else
322 m = getGetMethodClass(cl, NAME_catchAll);
323
324 if ( m )
325 { setDFlag(m, D_TYPENOWARN);
326 assignField((Instance)cl, (Any *)mp, m);
327 } else
328 assignField((Instance)cl, (Any *)mp, NIL);
329 }
330
331 if ( notNil(m) )
332 return m;
333
334 return NULL;
335 }
336
337
338 static status
resolveImplementationGoal(PceGoal g)339 resolveImplementationGoal(PceGoal g)
340 { Any m;
341 Any obj = g->receiver;
342 int issend = (g->flags & PCE_GF_SEND);
343
344 if ( isInteger(obj) )
345 g->receiver = obj = answerObject(ClassNumber, obj, EAV);
346
347 if ( !g->class )
348 { if ( onFlag(obj, F_ACTIVE|F_ATTRIBUTE|F_SENDMETHOD|F_GETMETHOD) )
349 { while( isFunction(obj) )
350 { m = (issend ? getSendMethodFunction(obj, g->selector)
351 : getGetMethodFunction(obj, g->selector));
352
353 if ( m )
354 { g->implementation = m;
355 succeed;
356 }
357
358 if ( (obj = getExecuteFunction((Function) obj)) )
359 { if ( isInteger(obj) )
360 obj = answerObject(ClassNumber, obj, EAV);
361 g->receiver = obj;
362 } else
363 return pceSetErrorGoal(g, PCE_ERR_FUNCTION_FAILED, obj);
364 }
365
366 if ( onFlag(obj, F_SENDMETHOD|F_GETMETHOD) )
367 { Chain ch;
368
369 if ( issend )
370 ch = getAllSendMethodsObject(obj, OFF);
371 else
372 ch = getAllGetMethodsObject(obj, OFF);
373
374 if ( ch && (m = getMethodMethodList(ch, g->selector)) )
375 { g->implementation = m;
376 succeed;
377 }
378 }
379
380 if ( onFlag(obj, F_ATTRIBUTE) )
381 { Chain ch = getAllAttributesObject(obj, ON);
382 Cell cell;
383
384 for_cell(cell, ch)
385 { Attribute att = cell->value;
386
387 if ( att->name == g->selector )
388 { g->implementation = att;
389 succeed;
390 }
391 }
392 }
393 }
394
395 g->class = classOfObject(obj);
396 }
397
398 if ( issend )
399 m = getSendMethodClass(g->class, g->selector);
400 else
401 m = getGetMethodClass(g->class, g->selector);
402
403 if ( m )
404 { g->implementation = m;
405 succeed;
406 } else
407 { Chain delegate = g->class->delegate;
408 Cell cell;
409 Class old = g->class;
410
411 for_cell(cell, delegate)
412 { Variable var = cell->value;
413 Any val;
414
415 if ( (val = getGetVariable(var, obj)) )
416 { g->receiver = val;
417 g->class = NULL;
418
419 if ( resolveImplementationGoal(g) && !(g->flags & PCE_GF_CATCHALL) )
420 succeed;
421 g->flags &= ~PCE_GF_CATCHALL;
422 g->errcode = PCE_ERR_OK;
423 }
424 }
425
426 g->class = old;
427 g->receiver = obj;
428 }
429
430 if ( (m=getCatchAllMethodGoal(g)) )
431 { g->flags |= PCE_GF_CATCHALL;
432 g->implementation = m;
433
434 succeed;
435 }
436
437 g->implementation = NIL; /* so isProperGoal() succeeds */
438 g->errcode = PCE_ERR_NO_BEHAVIOUR; /* cause this need not be fatal */
439 /*return pceSetErrorGoal(g, PCE_ERR_NO_BEHAVIOUR);*/
440 fail;
441 }
442
443
444 status
pceResolveImplementation(PceGoal g)445 pceResolveImplementation(PceGoal g)
446 { g->va_allocated = 0;
447 g->va_type = NULL;
448 g->argn = 0;
449
450 if ( !resolveImplementationGoal(g) )
451 fail;
452
453 pushGoal(g);
454
455 if ( objectIsInstanceOf(g->implementation, ClassMethod) )
456 { Method m = g->implementation;
457
458 g->argc = valInt(m->types->size);
459 g->types = (PceType *)m->types->elements;
460 if ( g->argc > 0 && g->types[g->argc-1]->vector == ON )
461 { g->va_type = g->types[g->argc-1];
462 g->argc--;
463 g->va_argc = 0;
464 }
465
466 if ( g->flags & PCE_GF_GET )
467 { GetMethod gm = (GetMethod)m;
468 g->return_type = gm->return_type;
469 }
470
471 if ( onDFlag(m, D_HOSTMETHOD) )
472 g->flags |= PCE_GF_HOST;
473 } else /* TBD: reorganise hierarchy! */
474 { if ( g->flags & PCE_GF_SEND )
475 { g->argc = 1;
476 if ( objectIsInstanceOf(g->implementation, ClassObjOfVariable) )
477 { Variable v = g->implementation;
478
479 g->types = &v->type;
480 } else if ( objectIsInstanceOf(g->implementation, ClassClassVariable) )
481 { ClassVariable cv = g->implementation;
482
483 g->types = &cv->type;
484 } else /* Attribute */
485 { g->types = &TypeAny;
486 }
487 } else
488 { g->argc = 0;
489 }
490 }
491
492 succeed;
493 }
494
495
496 void
pceInitArgumentsGoal(PceGoal g)497 pceInitArgumentsGoal(PceGoal g)
498 { int an = g->argc;
499 PceObject *ap;
500
501 if ( an <= PCE_GOAL_DIRECT_ARGS )
502 ap = g->_av;
503 else
504 { ap = alloc(an*sizeof(PceObject));
505 g->flags |= PCE_GF_ALLOCATED;
506 }
507
508 g->argv = ap;
509
510 while( --an >= 0 )
511 *ap++ = NULL;
512
513 if ( (g->flags & PCE_GF_CATCHALL) && !(g->flags & PCE_GF_HOSTARGS) )
514 pcePushArgument(g, g->selector);
515 }
516
517
518 void
pceVaAddArgGoal(PceGoal g,Any value)519 pceVaAddArgGoal(PceGoal g, Any value)
520 { if ( g->va_argc >= g->va_allocated )
521 { if ( g->va_allocated )
522 { int nsize = g->va_allocated*2;
523 Any *nav = alloc(nsize * sizeof(Any));
524
525 cpdata(nav, g->va_argv, Any, g->va_allocated);
526 unalloc(g->va_allocated*sizeof(Any), g->va_argv);
527 g->va_argv = nav;
528 g->va_allocated = nsize;
529 } else
530 { g->va_allocated = 8;
531 g->va_argv = alloc(g->va_allocated * sizeof(Any));
532 g->flags |= PCE_GF_VA_ALLOCATED;
533 }
534 }
535
536 g->va_argv[g->va_argc++] = value;
537 }
538
539
540 void
pcePushGoal(PceGoal g)541 pcePushGoal(PceGoal g)
542 { pushGoal(g);
543 }
544
545
546 void
pceFreeGoal(PceGoal g)547 pceFreeGoal(PceGoal g)
548 { if ( g == CurrentGoal )
549 { popGoal(g);
550
551 if ( g->flags & (PCE_GF_ALLOCATED|PCE_GF_VA_ALLOCATED) )
552 { if ( g->flags & PCE_GF_ALLOCATED )
553 unalloc(g->argc * sizeof(Any), g->argv);
554 if ( g->flags & PCE_GF_VA_ALLOCATED )
555 unalloc(g->va_allocated*sizeof(Any), g->va_argv);
556 }
557 }
558 }
559
560
561 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
562 pcePushArgument(PceGoal g, Any argument)
563 Push anonymous argument.
564 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
565
566 int
pcePushArgument(PceGoal g,Any arg)567 pcePushArgument(PceGoal g, Any arg)
568 { if ( g->argn >= 0 )
569 { if ( g->argn < g->argc )
570 { Type t = g->types[g->argn];
571 Any v = checkType(arg, t, g->receiver);
572
573 if ( v )
574 { g->argv[g->argn++] = v;
575 succeed;
576 } else
577 { err_argtype:
578 if ( offDFlag(g->implementation, D_TYPENOWARN) )
579 pceSetErrorGoal(g, PCE_ERR_ARGTYPE, arg);
580
581 fail;
582 }
583 } else
584 { if ( g->va_type )
585 { Any v = checkType(arg, g->va_type, g->receiver);
586
587 if ( v )
588 { pceVaAddArgGoal(g, v);
589 succeed;
590 } else
591 goto err_argtype;
592 } else
593 { if ( offDFlag(g->implementation, D_TYPENOWARN) )
594 pceSetErrorGoal(g, PCE_ERR_TOO_MANY_ARGS);
595
596 fail;
597 }
598 }
599 } else
600 return pceSetErrorGoal(g, PCE_ERR_ANONARG_AFTER_NAMED, arg);
601 }
602
603
604 int
pcePushNamedArgument(PceGoal g,PceName name,Any arg)605 pcePushNamedArgument(PceGoal g, PceName name, Any arg)
606 { int i;
607
608 if ( !name )
609 return pcePushArgument(g, arg);
610
611 if ( g->argn >= g->argc && g->va_type )
612 return pcePushArgument(g, answerObject(ClassBinding, name, arg, EAV));
613
614 for(i=0; i<g->argc; i++)
615 { if ( g->types[i]->argument_name == name )
616 { Any v = checkType(arg, g->types[i], g->receiver);
617
618 g->argn = -1;
619
620 if ( v )
621 { g->argv[i] = v;
622 succeed;
623 } else
624 { if ( offDFlag(g->implementation, D_TYPENOWARN) )
625 { g->argn = i;
626 pceSetErrorGoal(g, PCE_ERR_ARGTYPE, arg);
627 }
628 fail;
629 }
630 }
631 }
632
633 pceSetErrorGoal(g, PCE_ERR_NO_NAMED_ARGUMENT, name);
634
635 return FALSE;
636 }
637
638
639 static inline int
fillDefaultsGoal(PceGoal g)640 fillDefaultsGoal(PceGoal g)
641 { int n = g->argc;
642 int i;
643
644 for(i=0; i<n; i++)
645 { if ( !g->argv[i] )
646 { PceObject val;
647
648 if ( (val = checkType(DEFAULT, g->types[i], g->receiver)) )
649 g->argv[i] = val;
650 else
651 { if ( offDFlag(g->implementation, D_TYPENOWARN) )
652 pceSetErrorGoal(g, PCE_ERR_MISSING_ARGUMENT, toInt(i));
653
654 fail;
655 }
656 }
657 }
658
659 succeed;
660 }
661
662
663 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
664 status pceExecuteGoal(g)
665 Execute the goal. For get-goals, the return-value is stored in g->rval.
666 Success/failure of the goal is indicated using the return value of this
667 function.
668 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
669
670 #ifdef O_RUNTIME
671 #define DEBUGGER(g)
672 #else
673 #define DEBUGGER(g) if ( PCEdebugging ) g
674 #endif
675
676 status
pceExecuteGoal(PceGoal g)677 pceExecuteGoal(PceGoal g)
678 { if ( !fillDefaultsGoal(g) )
679 { pceReportErrorGoal(g);
680 fail;
681 }
682
683 if ( objectIsInstanceOf(g->implementation, ClassMethod) )
684 { status rval;
685 Method m = g->implementation;
686 void *prof_node;
687
688 DEBUGGER(pcePrintEnterGoal(g));
689 if ( PceProfile.call )
690 prof_node = (*PceProfile.call)(g->implementation,
691 PceProfile.handle);
692 else
693 prof_node = NULL;
694
695 if ( m->function )
696 { Any r = g->receiver;
697 Func f = m->function;
698 Any *a = g->argv;
699 Any fval;
700
701 if ( g->va_type )
702 { int vaac = g->va_argc;
703 Any *vaav = g->va_argv;
704
705 switch(g->argc)
706 { case 0:
707 fval = (*f)(r, vaac, vaav);
708 break;
709 case 1:
710 fval = (*f)(r, a[0], vaac, vaav);
711 break;
712 case 2:
713 fval = (*f)(r, a[0], a[1], vaac, vaav);
714 break;
715 case 3:
716 fval = (*f)(r, a[0], a[1], a[2], vaac, vaav);
717 break;
718 case 4:
719 fval = (*f)(r, a[0], a[1], a[2], a[3], vaac, vaav);
720 break;
721 case 5:
722 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4], vaac, vaav);
723 break;
724 case 6:
725 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4], a[5], vaac, vaav);
726 break;
727 case 7:
728 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4], a[5],
729 a[6], vaac, vaav);
730 break;
731 case 8:
732 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4], a[5],
733 a[6], a[7], vaac, vaav);
734 break;
735 case 9:
736 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4], a[5],
737 a[6], a[7], a[8], vaac, vaav);
738 break;
739 case 10:
740 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4], a[5],
741 a[6], a[7], a[8], a[9], vaac, vaav);
742 break;
743 default:
744 fval = (Any)FAIL;
745 assert(0);
746 }
747 } else
748 { switch(g->argc)
749 { case 0:
750 fval = (*f)(r);
751 break;
752 case 1:
753 fval = (*f)(r, a[0]);
754 break;
755 case 2:
756 fval = (*f)(r, a[0], a[1]);
757 break;
758 case 3:
759 fval = (*f)(r, a[0], a[1], a[2]);
760 break;
761 case 4:
762 fval = (*f)(r, a[0], a[1], a[2], a[3]);
763 break;
764 case 5:
765 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4]);
766 break;
767 case 6:
768 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4], a[5]);
769 break;
770 case 7:
771 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4], a[5], a[6]);
772 break;
773 case 8:
774 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7]);
775 break;
776 case 9:
777 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
778 a[8]);
779 break;
780 case 10:
781 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
782 a[8], a[9]);
783 break;
784 case 11:
785 fval = (*f)(r, a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
786 a[8], a[9], a[10]);
787 break;
788 default:
789 fval = (Any)FAIL;
790 assert(0);
791 }
792 }
793
794 /* end of function-implemation */
795
796 if ( fval )
797 { if ( g->flags & PCE_GF_GET )
798 g->rval = fval;
799 rval = SUCCEED;
800 } else
801 rval = FAIL;
802 } else /* not a C-function */
803 { if ( objectIsInstanceOf(m->message, ClassCode) )
804 { /* A function object */
805 if ( objectIsInstanceOf(m->message, ClassFunction) )
806 { Any fval;
807 Function f = (Function)m->message;
808
809 if ( g->va_type )
810 { Any cv = createCodeVectorv(g->va_argc, g->va_argv);
811 ArgVector(av, g->argc+1);
812 int i;
813
814 for(i=0; i<g->argc; i++)
815 av[i] = g->argv[i];
816 av[i] = cv;
817 addCodeReference(cv);
818
819 withReceiver(g->receiver, m->context,
820 fval = getForwardFunctionv(f, i, av));
821
822 delCodeReference(cv);
823 doneCodeVector(cv);
824 } else
825 { withReceiver(g->receiver, m->context,
826 fval = getForwardFunctionv(f, g->argc, g->argv));
827 }
828
829 if ( fval )
830 { if ( g->flags & PCE_GF_GET )
831 g->rval = fval;
832 rval = SUCCEED;
833 } else
834 rval = FAIL;
835 } else /* a procedure (code) object */
836 { if ( g->flags & PCE_GF_GET )
837 { pceSetErrorGoal(g, PCE_ERR_CODE_AS_GETMETHOD, m->message);
838 rval = FAIL;
839 goto out;
840 }
841
842 if ( g->va_type )
843 { Any cv = createCodeVectorv(g->va_argc, g->va_argv);
844 ArgVector(av, g->argc+1);
845 int i;
846
847 for(i=0; i<g->argc; i++)
848 av[i] = g->argv[i];
849 av[i] = cv;
850 addCodeReference(cv);
851
852 withReceiver(g->receiver, m->context,
853 rval = forwardCodev(m->message, i, av));
854
855 delCodeReference(cv);
856 doneCodeVector(cv);
857 } else
858 { withReceiver(g->receiver, m->context,
859 rval = forwardCodev(m->message, g->argc, g->argv));
860 }
861 }
862 } else
863 rval = hostCall(g);
864 }
865
866 out:
867 if ( prof_node && PceProfile.exit )
868 (*PceProfile.exit)(prof_node);
869 DEBUGGER(pcePrintReturnGoal(g, rval));
870 return rval;
871 /* end of method-implemtation */
872
873 } else if ( objectIsInstanceOf(g->implementation, ClassObjOfVariable) )
874 { Variable var = g->implementation;
875 Any *field = &(((Instance)g->receiver)->slots[valInt(var->offset)]);
876
877 if ( g->flags & PCE_GF_SEND )
878 assignField(g->receiver, field, g->argv[0]);
879 else
880 { if ( isClassDefault(*field) )
881 { Any v = getGetVariable(var, g->receiver);
882
883 if ( v )
884 g->rval = v;
885 else
886 { DEBUGGER(pcePrintReturnGoal(g, FAIL));
887 fail;
888 }
889 } else
890 g->rval = *field;
891
892 DEBUGGER(pcePrintReturnGoal(g, SUCCEED));
893 }
894
895 succeed;
896 } else if ( objectIsInstanceOf(g->implementation, ClassClassVariable) )
897 { ClassVariable cv = g->implementation;
898
899 if ( g->flags & PCE_GF_SEND )
900 { return pceSetErrorGoal(g, PCE_ERR_PERMISSION, NAME_write);
901 } else
902 { g->rval = getValueClassVariable(cv);
903
904 DEBUGGER(pcePrintReturnGoal(g, SUCCEED));
905 succeed;
906 }
907 } else if ( objectIsInstanceOf(g->implementation, ClassAttribute) )
908 { Attribute a = g->implementation;
909
910 DEBUGGER(pcePrintReturnGoal(g, SUCCEED));
911 if ( g->flags & PCE_GF_SEND )
912 assign(a, value, g->argv[0]);
913 else
914 g->rval = a->value;
915
916 succeed;
917 }
918
919 assert(0);
920 fail;
921 }
922
923
924 static int
getNamedArgument(Any obj,Name * an,Any * av)925 getNamedArgument(Any obj, Name *an, Any *av)
926 { if ( isObject(obj) && onFlag(obj, F_ISBINDING) )
927 { Binding b = obj;
928
929 *an = b->name;
930 *av = b->value;
931
932 succeed;
933 }
934
935 fail;
936 }
937
938
939 void
pceReportErrorGoal(PceGoal g)940 pceReportErrorGoal(PceGoal g)
941 { int pushed;
942
943 if ( g->flags & PCE_GF_THROW ) /* already an exception pending! */
944 return;
945
946 if ( CurrentGoal != g ) /* if there is no implementation */
947 { pushGoal(g);
948 pushed = TRUE;
949 } else
950 pushed = FALSE;
951
952 switch(g->errcode)
953 { case PCE_ERR_OK:
954 break;
955 case PCE_ERR_NO_BEHAVIOUR:
956 { Name arrow = ((g->flags & PCE_GF_SEND) ? CtoName("->") : CtoName("<-"));
957
958 g->argc = 0; /* make the goal argument sane */
959 g->va_type = 0;
960 errorPce(g->receiver, NAME_noBehaviour, arrow, g->selector);
961 break;
962 }
963 case PCE_ERR_ARGTYPE:
964 { int an = g->argn;
965 Type t = g->types[an];
966
967 errorTypeMismatch(g->receiver, g->implementation, an+1, t, g->errc1);
968 break;
969 }
970 case PCE_ERR_RETTYPE:
971 errorPce(g->implementation, NAME_badReturnValue,
972 g->errc1, g->return_type);
973 break;
974 case PCE_ERR_TOO_MANY_ARGS:
975 errorPce(g->implementation, NAME_argumentCount, toInt(g->argc));
976 break;
977 case PCE_ERR_ANONARG_AFTER_NAMED:
978 errorPce(g->implementation, NAME_unboundAfterBoundArgument);
979 break;
980 case PCE_ERR_NO_NAMED_ARGUMENT:
981 errorPce(g->implementation, NAME_noNamedArgument, g->errc1);
982 break;
983 case PCE_ERR_MISSING_ARGUMENT:
984 { int an = valInt(g->errc1);
985 Type t = g->types[an];
986 Name argname;
987
988 if ( instanceOfObject(g->implementation, ClassObjOfVariable) )
989 { Variable v = g->implementation;
990 argname = v->name;
991 } else
992 { argname = t->argument_name;
993 if ( isNil(argname) )
994 argname = CtoName("?");
995 }
996
997 errorPce(g->implementation, NAME_missingArgument,
998 toInt(an+1), argname, getNameType(t));
999
1000 break;
1001 }
1002 case PCE_ERR_FUNCTION_FAILED: /* this is not (yet) reported */
1003 break;
1004 case PCE_ERR_ERROR:
1005 break;
1006 default:
1007 Cprintf("Unknown error: %d\n", g->errcode);
1008 }
1009
1010 if ( pushed )
1011 popGoal(g);
1012 }
1013
1014
1015 status
vm_send(Any receiver,Name selector,Class class,int argc,const Any argv[])1016 vm_send(Any receiver, Name selector, Class class, int argc, const Any argv[])
1017 { pce_goal g;
1018
1019 g.va_argc = 0;
1020 g.flags = PCE_GF_SEND;
1021 g.receiver = receiver;
1022 g.class = class;
1023 g.selector = selector;
1024 g.errcode = PCE_ERR_OK;
1025
1026 if ( pceResolveImplementation(&g) )
1027 { int i;
1028 status rval;
1029
1030 pceInitArgumentsGoal(&g);
1031 for(i=0; i<argc; i++)
1032 { Name an;
1033 Any av;
1034
1035 if ( getNamedArgument(argv[i], &an, &av) )
1036 { if ( !pcePushNamedArgument(&g, an, av) )
1037 { if ( g.errcode == PCE_ERR_NO_NAMED_ARGUMENT )
1038 { if ( pcePushArgument(&g, argv[i]) )
1039 { g.errcode = PCE_ERR_OK;
1040 continue;
1041 }
1042 pceSetErrorGoal(&g, PCE_ERR_NO_NAMED_ARGUMENT, an);
1043 }
1044 goto error;
1045 }
1046 } else
1047 { if ( !pcePushArgument(&g, argv[i]) )
1048 goto error;
1049 }
1050 }
1051 rval = pceExecuteGoal(&g);
1052 pceFreeGoal(&g);
1053 return rval;
1054 }
1055
1056 error:
1057 pceReportErrorGoal(&g);
1058 pceFreeGoal(&g);
1059
1060 fail;
1061 }
1062
1063
1064 Any
vm_get(Any receiver,Name selector,Class class,int argc,const Any argv[])1065 vm_get(Any receiver, Name selector, Class class, int argc, const Any argv[])
1066 { pce_goal g;
1067
1068 g.va_argc = 0;
1069 g.flags = PCE_GF_GET;
1070 g.receiver = receiver;
1071 g.class = class;
1072 g.selector = selector;
1073 g.errcode = PCE_ERR_OK;
1074
1075 if ( pceResolveImplementation(&g) )
1076 { int i;
1077 status rval;
1078
1079 pceInitArgumentsGoal(&g);
1080 for(i=0; i<argc; i++)
1081 { Name an;
1082 Any av;
1083
1084 if ( getNamedArgument(argv[i], &an, &av) )
1085 { if ( !pcePushNamedArgument(&g, an, av) )
1086 goto error;
1087 } else
1088 { if ( !pcePushArgument(&g, argv[i]) )
1089 goto error;
1090 }
1091 }
1092 rval = pceExecuteGoal(&g);
1093 pceFreeGoal(&g);
1094 if ( rval )
1095 return g.rval;
1096 fail;
1097
1098 error:
1099 pceFreeGoal(&g);
1100 }
1101
1102 pceReportErrorGoal(&g);
1103
1104 fail;
1105 }
1106
1107
1108 status
sendSendMethod(SendMethod sm,Any receiver,int argc,const Any argv[])1109 sendSendMethod(SendMethod sm, Any receiver, int argc, const Any argv[])
1110 { pce_goal g;
1111 int i;
1112 status rval;
1113
1114 /* this is pceResolveImplementation() */
1115 g.selector = sm->name;
1116 g.va_allocated = 0;
1117 g.va_argc = 0;
1118 g.argn = 0;
1119 g.flags = PCE_GF_SEND;
1120 g.receiver = receiver;
1121 g.implementation = sm;
1122 g.errcode = PCE_ERR_OK;
1123
1124 if ( onDFlag(sm, D_HOSTMETHOD) )
1125 g.flags |= PCE_GF_HOST;
1126
1127 pushGoal(&g);
1128
1129 g.argc = valInt(sm->types->size);
1130 g.types = (PceType *)sm->types->elements;
1131 if ( g.argc > 0 && g.types[g.argc-1]->vector == ON )
1132 { g.va_type = g.types[g.argc-1];
1133 g.argc--;
1134 g.va_argc = 0;
1135 } else
1136 { g.va_type = NULL;
1137 }
1138
1139 /* and this is as vm_send() */
1140 pceInitArgumentsGoal(&g);
1141 for(i=0; i<argc; i++)
1142 { Name an;
1143 Any av;
1144
1145 if ( getNamedArgument(argv[i], &an, &av) )
1146 { if ( !pcePushNamedArgument(&g, an, av) )
1147 goto error;
1148 } else
1149 { if ( !pcePushArgument(&g, argv[i]) )
1150 goto error;
1151 }
1152 }
1153 rval = pceExecuteGoal(&g);
1154 pceFreeGoal(&g);
1155 return rval;
1156
1157 error:
1158 popGoal(&g);
1159 pceReportErrorGoal(&g);
1160
1161 fail;
1162 }
1163
1164
1165 Any
getGetGetMethod(GetMethod gm,Any receiver,int argc,const Any argv[])1166 getGetGetMethod(GetMethod gm, Any receiver, int argc, const Any argv[])
1167 { pce_goal g;
1168 int i;
1169 status rval;
1170
1171 /* this is pceResolveSend() */
1172 g.selector = gm->name;
1173 g.va_allocated = 0;
1174 g.va_argc = 0;
1175 g.argn = 0;
1176 g.flags = PCE_GF_GET;
1177 g.receiver = receiver;
1178 g.implementation = gm;
1179 g.errcode = PCE_ERR_OK;
1180 g.return_type = gm->return_type;
1181
1182 if ( onDFlag(gm, D_HOSTMETHOD) )
1183 g.flags |= PCE_GF_HOST;
1184
1185 g.argc = valInt(gm->types->size);
1186 g.types = (PceType *)gm->types->elements;
1187 if ( g.argc > 0 && g.types[g.argc-1]->vector == ON )
1188 { g.va_type = g.types[g.argc-1];
1189 g.argc--;
1190 g.va_argc = 0;
1191 } else
1192 { g.va_type = NULL;
1193 }
1194
1195 /* and this is as vm_get() */
1196 pceInitArgumentsGoal(&g);
1197 for(i=0; i<argc; i++)
1198 { Name an;
1199 Any av;
1200
1201 if ( getNamedArgument(argv[i], &an, &av) )
1202 { if ( !pcePushNamedArgument(&g, an, av) )
1203 goto error;
1204 } else
1205 { if ( !pcePushArgument(&g, argv[i]) )
1206 goto error;
1207 }
1208 }
1209 rval = pceExecuteGoal(&g);
1210 pceFreeGoal(&g);
1211 if ( rval )
1212 return g.rval;
1213 fail;
1214
1215 error:
1216 pceReportErrorGoal(&g);
1217
1218 fail;
1219 }
1220
1221 /*******************************
1222 * HOST-CALLING SUPPORT *
1223 *******************************/
1224
1225 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1226 pceGetArgumentTypeGoal()
1227 Deternimes type and argument location for the next argument. Location
1228 -1 indicates the argument must be placed in the variable-argument list.
1229 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1230
1231
1232 int
pceGetArgumentTypeGoal(PceGoal g,PceName name,PceType * type,int * ai)1233 pceGetArgumentTypeGoal(PceGoal g, PceName name, PceType *type, int *ai)
1234 { if ( name )
1235 { int i;
1236
1237 if ( g->argn >= g->argc && g->va_type )
1238 { *type = g->va_type;
1239 *ai = -1; /* Means use vararg list */
1240 succeed;
1241 }
1242
1243 g->argn = -1;
1244
1245 for(i=0; i<g->argc; i++)
1246 { if ( g->types[i]->argument_name == name )
1247 { *type = g->types[i];
1248 *ai = i;
1249
1250 succeed;
1251 }
1252 }
1253
1254 return pceSetErrorGoal(g, PCE_ERR_NO_NAMED_ARGUMENT, name);
1255 }
1256
1257 if ( g->argn >= 0 )
1258 { if ( g->argn < g->argc )
1259 { *type = g->types[g->argn];
1260 *ai = g->argn++;
1261
1262 succeed;
1263 } else
1264 { if ( g->va_type )
1265 { *type = g->types[g->argn];
1266 *ai = -1;
1267
1268 succeed;
1269 } else
1270 { if ( offDFlag(g->implementation, D_TYPENOWARN) )
1271 pceSetErrorGoal(g, PCE_ERR_TOO_MANY_ARGS);
1272
1273 fail;
1274 }
1275 }
1276 } else
1277 return pceSetErrorGoal(g, PCE_ERR_ANONARG_AFTER_NAMED, NIL);
1278 }
1279
1280
1281 #undef sendv
1282 status
sendv(Any receiver,Name selector,int argc,Any * argv)1283 sendv(Any receiver, Name selector, int argc, Any *argv)
1284 { return vm_send(receiver, selector, NULL, argc, argv);
1285 }
1286
1287
1288 status /* QuickAndDirtySend */
qadSendv(Any r,Name selector,int ac,Any * av)1289 qadSendv(Any r, Name selector, int ac, Any *av)
1290 { SendMethod implementation = getSendMethodClass(classOfObject(r), selector);
1291 SendFunc f;
1292
1293 if ( instanceOfObject(implementation, ClassSendMethod) &&
1294 (f=implementation->function) &&
1295 offDFlag(implementation, D_CXX|D_TRACE|D_BREAK))
1296 { switch(ac)
1297 { case 0: return (*f)(r);
1298 case 1: return (*f)(r, av[0]);
1299 case 2: return (*f)(r, av[0],av[1]);
1300 case 3: return (*f)(r, av[0],av[1],av[2]);
1301 case 4: return (*f)(r, av[0],av[1],av[2],av[3]);
1302 case 5: return (*f)(r, av[0],av[1],av[2],av[3],av[4]);
1303 case 6: return (*f)(r, av[0],av[1],av[2],av[3],av[4],av[5]);
1304 }
1305 }
1306
1307 return vm_send(r, selector, classOfObject(r), ac, av);
1308 }
1309
1310
1311 #undef getv
1312 Any
getv(Any receiver,Name selector,int argc,Any * argv)1313 getv(Any receiver, Name selector, int argc, Any *argv)
1314 { return vm_get(receiver, selector, NULL, argc, argv);
1315 }
1316
1317
1318 Any /* QuickAndDirtyGet */
qadGetv(Any r,Name selector,int ac,Any * av)1319 qadGetv(Any r, Name selector, int ac, Any *av)
1320 { GetMethod implementation = getGetMethodClass(classOfObject(r), selector);
1321 Func f;
1322
1323 if ( instanceOfObject(implementation, ClassGetMethod) &&
1324 (f=implementation->function) &&
1325 offDFlag(implementation, D_CXX|D_TRACE|D_BREAK) )
1326 { switch(ac)
1327 { case 0: return (*f)(r);
1328 case 1: return (*f)(r, av[0]);
1329 case 2: return (*f)(r, av[0],av[1]);
1330 case 3: return (*f)(r, av[0],av[1],av[2]);
1331 case 4: return (*f)(r, av[0],av[1],av[2],av[3]);
1332 case 5: return (*f)(r, av[0],av[1],av[2],av[3],av[4]);
1333 case 6: return (*f)(r, av[0],av[1],av[2],av[3],av[4],av[5]);
1334 }
1335 }
1336
1337 return vm_get(r, selector, classOfObject(r), ac, av);
1338 }
1339
1340
1341 /********************************
1342 * VARARG VERSIONS *
1343 ********************************/
1344
1345 status
send(Any receiver,Name selector,...)1346 send(Any receiver, Name selector, ...)
1347 { va_list args;
1348 Any argv[VA_PCE_MAX_ARGS];
1349 int argc;
1350
1351 va_start(args, selector);
1352 for(argc=0; (argv[argc] = va_arg(args, Any)) != NULL; argc++)
1353 assert(argc <= VA_PCE_MAX_ARGS);
1354 va_end(args);
1355
1356 return vm_send(receiver, selector, NULL, argc, argv);
1357 }
1358
1359
1360 Any
get(Any receiver,Name selector,...)1361 get(Any receiver, Name selector, ...)
1362 { va_list args;
1363 Any argv[VA_PCE_MAX_ARGS];
1364 int argc;
1365
1366 va_start(args, selector);
1367 for(argc=0; (argv[argc] = va_arg(args, Any)) != NULL; argc++)
1368 assert(argc <= VA_PCE_MAX_ARGS);
1369 va_end(args);
1370
1371 return vm_get(receiver, selector, NULL, argc, argv);
1372 }
1373
1374 /*******************************
1375 * PUBLIC RESOLVE SUPPORT *
1376 *******************************/
1377
1378 Any
resolveSendMethodObject(Any obj,Class class,Name sel,Any * receiver)1379 resolveSendMethodObject(Any obj, Class class, Name sel, Any *receiver)
1380 { pce_goal g;
1381
1382 g.receiver = obj;
1383 g.class = class;
1384 g.selector = sel;
1385 g.flags = PCE_GF_SEND;
1386 g.errcode = PCE_ERR_OK;
1387
1388 if ( resolveImplementationGoal(&g) && !(g.flags & PCE_GF_CATCHALL) )
1389 { *receiver = g.receiver;
1390 return g.implementation;
1391 }
1392
1393 fail;
1394 }
1395
1396
1397 Any
resolveGetMethodObject(Any obj,Class class,Name sel,Any * receiver)1398 resolveGetMethodObject(Any obj, Class class, Name sel, Any *receiver)
1399 { pce_goal g;
1400
1401 g.receiver = obj;
1402 g.class = class;
1403 g.selector = sel;
1404 g.flags = PCE_GF_GET;
1405 g.errcode = PCE_ERR_OK;
1406
1407 if ( resolveImplementationGoal(&g) && !(g.flags & PCE_GF_CATCHALL) )
1408 { *receiver = g.receiver;
1409 return g.implementation;
1410 }
1411
1412 fail;
1413 }
1414
1415
1416