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