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 #include <h/kernel.h>
36 #include <h/text.h>
37 #include <itf/c.h>
38 #include <h/interface.h> /* hostCallProc() */
39
40 static status recordInstancesClass(Class class, BoolObj keep, BoolObj recursive);
41 static status fill_slots_class(Class class, Class super);
42 static Variable getLocaliseInstanceVariableClass(Class class, Name name);
43 static Any bindMethod(Class class, Name code, Name selector);
44 static status lazyBindingClass(Class class, Name which, BoolObj val);
45
46 #define CLASS_PCE_SLOTS 42
47
48 #define InstanceSize(c) ((int)(intptr_t) &((Instance) NULL)->slots[valInt((c)->slots)])
49 #define SlotsClass(c) \
50 ((sizeof(struct c) - ((intptr_t) &((Instance) NULL)->slots[0])) / sizeof(Any))
51
52 static void
resetSlotsClass(Class class,Name name)53 resetSlotsClass(Class class, Name name)
54 { size_t i;
55 size_t slots = SlotsClass(class);
56
57 setProtectedObj(class);
58
59 for(i=0; i<CLASS_PCE_SLOTS; i++)
60 ((Instance)class)->slots[i] = CLASSDEFAULT;
61 for( ; i < slots; i++ )
62 ((Instance)class)->slots[i] = NULL;
63
64 class->resolve_method_message = DEFAULT;
65 class->created_messages = NIL;
66 class->freed_messages = NIL;
67 class->make_class_message = NIL;
68 class->instances = NIL;
69 class->super_class = NIL;
70 class->sub_classes = NIL;
71
72 assign(class, name, name);
73 assign(class, no_created, ZERO);
74 assign(class, no_freed, ZERO);
75 }
76
77
78 Class
typeClass(Name name)79 typeClass(Name name)
80 { Class class = alloc(sizeof(struct class));
81
82 initHeaderObj(class, ClassClass);
83 resetSlotsClass(class, name);
84
85 return class;
86 }
87
88
89 Class
nameToTypeClass(Name name)90 nameToTypeClass(Name name)
91 { Type type;
92
93 if ( (type = nameToType(name)) )
94 { if ( !inBoot &&
95 ( !isClassType(type) ||
96 type->vector != OFF ||
97 notNil(type->supers)
98 ) )
99 { errorPce(type, NAME_notClassType);
100 fail;
101 }
102
103 if ( !instanceOfObject(type->context, ClassClass) )
104 { if ( type->context == name )
105 { assign(type, context, typeClass(name));
106 } else
107 { errorPce(type, NAME_notClassType);
108 fail;
109 }
110 }
111
112 return type->context;
113 }
114
115 fail;
116 }
117
118
119 static void
linkSubClass(Class super,Class sub)120 linkSubClass(Class super, Class sub)
121 { if ( isNil(super->sub_classes) )
122 { assign(super, sub_classes, newObject(ClassChain, sub, EAV));
123 } else
124 { Cell cell;
125 int done = FALSE;
126
127 for_cell(cell, super->sub_classes)
128 { Class class = cell->value;
129
130 if ( class->name == sub->name )
131 { if ( class != sub )
132 deleteChain(super->sub_classes, class);
133 else
134 done = TRUE;
135 }
136 }
137
138 if ( !done )
139 appendChain(super->sub_classes, sub);
140 }
141
142 assign(sub, super_class, super);
143 }
144
145
146 static void
defaultAssocClass(Class class)147 defaultAssocClass(Class class)
148 { static Name suffix;
149
150 if ( !suffix )
151 suffix = CtoName("_class");
152
153 newAssoc(getAppendName(class->name, suffix), class);
154 }
155
156
157
158 Class
defineClass(Name name,Name super,StringObj summary,SendFunc makefunction)159 defineClass(Name name, Name super, StringObj summary, SendFunc makefunction)
160 { Class class, superclass;
161
162 TRY(class = nameToTypeClass(name));
163 class->make_class_function = makefunction;
164 if ( notNil(super) )
165 { TRY(superclass = nameToTypeClass(super));
166 linkSubClass(superclass, class);
167 }
168 if ( isClassDefault(class->creator) )
169 assign(class, creator, inBoot ? NAME_builtIn : NAME_host);
170 if ( notDefault(summary) )
171 assign(class, summary, summary);
172
173 if ( notClassDefault(class->realised) )
174 return class; /* existing (boot) class */
175
176 if ( isClassDefault(class->sub_classes) )
177 assign(class, sub_classes, NIL);
178
179 assign(class, realised, OFF);
180 defaultAssocClass(class);
181 appendHashTable(classTable, name, class);
182 protectObject(class);
183 createdObject(class, NAME_new);
184
185 return class;
186 }
187
188
189 status
defineClasses(struct class_definition * classes)190 defineClasses(struct class_definition *classes)
191 { for(; classes->name; classes++)
192 { Class class = defineClass(classes->name, classes->super,
193 staticCtoString(classes->summary),
194 classes->makefunction);
195
196 if ( classes->global )
197 *classes->global = class;
198 }
199
200 numberTreeClass(ClassObject, 0);
201
202 succeed;
203 }
204
205
206 static inline status
call_make_function(SendFunc f,Class class)207 call_make_function(SendFunc f, Class class)
208 { status rval;
209
210 rval = (*f)(class);
211
212 return rval;
213 }
214
215
216 status
realiseClass(Class class)217 realiseClass(Class class)
218 { if ( class->realised != ON )
219 { status rval;
220
221 DEBUG_BOOT(Cprintf("Realising class %s ... ", strName(class->name)));
222
223 if ( notNil(class->super_class) )
224 TRY(realiseClass(class->super_class));
225
226 ServiceMode(PCE_EXEC_SERVICE,
227 if ( class->make_class_function )
228 { assign(class, realised, ON);
229 rval = (fill_slots_class(class, class->super_class) &&
230 call_make_function(class->make_class_function, class) &&
231 initClass(class));
232 } else
233 rval = FAIL;);
234
235 DEBUG_BOOT(Cprintf("%s\n", rval ? "ok" : "FAILED"));
236
237 return rval;
238 }
239
240 succeed;
241 }
242
243
244 void
bindNewMethodsClass(Class class)245 bindNewMethodsClass(Class class)
246 { if ( isDefault(class->lookup_method) ||
247 isDefault(class->initialise_method) )
248 { GetMethod l = getGetMethodClass(class, NAME_lookup);
249 Any s = getSendMethodClass(class, NAME_initialise);
250
251 assert(instanceOfObject(s, ClassSendMethod));
252
253 if ( l )
254 setDFlag(l, D_TYPENOWARN);
255 else
256 l = NIL;
257
258 assign(class, lookup_method, l);
259 assign(class, initialise_method, s);
260 }
261 }
262
263
264 status
realiseBootClass(Class class)265 realiseBootClass(Class class)
266 { assign(class, realised, OFF);
267
268 realiseClass(class);
269 bindMethod(class, NAME_send, NAME_initialise);
270 bindMethod(class, NAME_get, NAME_lookup);
271 deleteHashTable(class->send_table, NAME_initialise);
272 deleteHashTable(class->get_table, NAME_lookup);
273 assign(class, lookup_method, DEFAULT);
274 assign(class, initialise_method, DEFAULT);
275
276 succeed;
277 }
278
279
280 static status
fill_slots_class(Class class,Class super)281 fill_slots_class(Class class, Class super)
282 { if ( notNil(super) )
283 linkSubClass(super, class);
284
285 initialiseProgramObject(class);
286
287 setDFlag(class, DC_LAZY_GET|DC_LAZY_SEND);
288 #ifdef O_CPLUSPLUS
289 if ( class->creator == name_cxx )
290 setDFlag(class, D_CXX);
291 #endif
292
293 assign(class, realised, ON);
294 assign(class, send_methods, newObject(ClassChain, EAV));
295 assign(class, get_methods, newObject(ClassChain, EAV));
296 assign(class, class_variables, newObject(ClassChain, EAV));
297 assign(class, send_table, newObject(ClassHashTable, EAV));
298 assign(class, get_table, newObject(ClassHashTable, EAV));
299 assign(class, local_table, newObject(ClassHashTable, EAV));
300 assign(class, class_variable_table, NIL);
301 assign(class, selection_style, NIL);
302 assign(class, rcs_revision, NIL);
303 assign(class, source, NIL);
304 if ( isClassDefault(class->summary) )
305 assign(class, summary, NIL);
306
307 /* special method cache */
308 assign(class, send_catch_all, DEFAULT);
309 assign(class, get_catch_all, DEFAULT);
310 assign(class, convert_method, DEFAULT);
311 if ( !class->boot )
312 { assign(class, initialise_method, DEFAULT);
313 assign(class, lookup_method, DEFAULT);
314 }
315
316 class->send_function = NULL;
317 class->get_function = NULL;
318 class->c_declarations = NULL;
319
320 if ( notNil(super) )
321 { assign(class, term_names, super->term_names);
322 assign(class, delegate, getCopyChain(super->delegate));
323 assign(class, instance_variables, getCopyVector(super->instance_variables));
324 assign(class, cloneStyle, super->cloneStyle);
325 assign(class, saveStyle, super->saveStyle);
326 assign(class, features, getCopySheet(super->features));
327 assign(class, solid, super->solid);
328 assign(class, handles, getCopyChain(super->handles));
329 assign(class, un_answer, super->un_answer);
330 assign(class, slots, super->slots);
331
332 if ( !class->boot )
333 { assign(class, instance_size, super->instance_size);
334 assign(class, init_variables, super->init_variables);
335 }
336 assign(class, changed_messages, getCopyChain(super->changed_messages));
337 assign(class, created_messages, getCopyChain(super->created_messages));
338 assign(class, freed_messages, getCopyChain(super->freed_messages));
339 if ( isDefault(class->resolve_method_message) )
340 assign(class, resolve_method_message, super->resolve_method_message);
341
342 if ( notNil(super->instances) )
343 recordInstancesClass(class, ON, OFF);
344
345 class->saveFunction = super->saveFunction;
346 class->loadFunction = super->loadFunction;
347 class->cloneFunction = super->cloneFunction;
348 class->redrawFunction = super->redrawFunction;
349 class->changedFunction = super->changedFunction;
350 class->in_event_area_function = super->in_event_area_function;
351 } else
352 { assign(class, term_names, NIL);
353 assign(class, delegate, newObject(ClassChain, EAV));
354 assign(class, instance_variables, newObject(ClassVector, EAV));
355 assign(class, cloneStyle, NAME_recursive);
356 assign(class, saveStyle, NAME_normal);
357 assign(class, features, NIL);
358 assign(class, solid, OFF);
359 assign(class, instance_size, toInt(sizeof(struct object)));
360 assign(class, slots, ZERO);
361 assign(class, un_answer, ON);
362 assign(class, handles, NIL);
363 assign(class, changed_messages, NIL);
364 assign(class, resolve_method_message, NIL);
365
366 assign(class, init_variables, NAME_static);
367 assign(class, changed_messages, NIL);
368 assign(class, created_messages, NIL);
369 assign(class, freed_messages, NIL);
370 }
371
372 defaultAssocClass(class);
373 appendHashTable(classTable, class->name, class);
374 protectObject(class);
375
376 succeed;
377 }
378
379
380 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
381 bootClass() should be called to initialise the most vital classes of
382 the system.
383
384 Note that the initialise_method is locked to prevent drop-out during
385 the real class definition: freeObject doesn't yet work properly.
386 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
387
388 static Class
_bootClass(Name name,Name super_name,int size,int slots,SendFunc initF,int argc,va_list args)389 _bootClass(Name name, Name super_name,
390 int size, int slots,
391 SendFunc initF,
392 int argc, va_list args)
393 { Type type = nameToType(name);
394 Class cl = type->context;
395 Class super;
396
397 if ( notNil(super_name) )
398 { Type super_type = nameToType(super_name);
399 super = super_type->context;
400 assert(notNil(super->initialise_method)); /* No super-class */
401 } else
402 super = NIL;
403
404 DEBUG_BOOT(Cprintf("Boot Class %s ... ", pp(name)));
405
406 cl->boot = slots;
407 if ( notNil(super) )
408 cl->boot += super->boot;
409
410 assign(cl, realised, ON);
411 assign(cl, super_class, super);
412 assign(cl, instance_size, toInt(size));
413 assign(cl, slots, toInt((size - ((intptr_t) &((Instance) NULL)->slots[0]))
414 / sizeof(Any)));
415
416 { int i;
417 Type types[VA_PCE_MAX_ARGS];
418 Vector tv;
419
420 for(i=0; i<argc; i++)
421 { char *type = va_arg(args, char *);
422
423 if ( !(types[i] = CtoType(type)) )
424 sysPce("Bad type in bootClass(): %s: %s\n", pp(name), type);
425 }
426
427 tv = createVectorv(argc, (Any *)types);
428
429 assign(cl, initialise_method,
430 createSendMethod(NAME_initialise, tv, NIL, initF));
431 lockObj(cl->initialise_method); /* avoid reclaim on sdcClass */
432 assign(cl, lookup_method, NIL);
433 assign(cl, init_variables, NAME_static); /* not support for boot stuff */
434 assign(cl, resolve_method_message, NIL);
435 }
436
437 DEBUG_BOOT(Cprintf("ok\n"));
438
439 return cl;
440 }
441
442
443 Class
bootClass(Name name,Name super_name,int size,int slots,SendFunc newF,int argc,...)444 bootClass(Name name, Name super_name, int size, int slots,
445 SendFunc newF, int argc, ...)
446 { va_list args;
447 Class class;
448
449 va_start(args, argc);
450 class = _bootClass(name, super_name, size, slots, newF, argc, args);
451 va_end(args);
452
453 return class;
454 }
455
456
457 void
lookupBootClass(Class class,Func f,int argc,...)458 lookupBootClass(Class class, Func f, int argc, ...)
459 { int i;
460 Type types[VA_PCE_MAX_ARGS];
461 Vector tv;
462 va_list args;
463 GetMethod m;
464
465 va_start(args, argc);
466 for(i=0; i<argc; i++)
467 { char *type = va_arg(args, char *);
468
469 if ( !(types[i] = CtoType(type)) )
470 sysPce("Bad type in lookupBootClass(): %s: %s",
471 pp(class->name), type);
472 }
473 va_end(args);
474
475 tv = createVectorv(argc, (Any *)types);
476 m = createGetMethod(NAME_lookup, TypeAny, tv, NIL, f);
477 lockObj(m); /* avoid reclaim on sdcClass */
478 setDFlag(m, D_TYPENOWARN);
479
480 assign(class, lookup_method, m);
481 }
482
483
484 Class
getConvertClass(Class class_class,Any obj)485 getConvertClass(Class class_class, Any obj)
486 { Class class;
487 Name name;
488
489 if ( instanceOfObject(obj, ClassClass) )
490 return obj;
491
492 if ( instanceOfObject(obj, ClassType) )
493 { Type t = obj;
494
495 if ( isClassType(t) )
496 return t->context;
497 }
498
499 if ( (name = toName(obj)) )
500 { if ( !(class = getMemberHashTable(classTable, name)) )
501 { exceptionPce(PCE, NAME_undefinedClass, name, EAV);
502 if ( !(class = getMemberHashTable(classTable, name)) )
503 fail;
504 }
505
506 return class;
507 }
508
509 fail;
510 }
511
512
513 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
514 Called from clearCacheClass(). Change this if this class is to do anything
515 else ...
516 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
517
518 static status
installClass(Class class)519 installClass(Class class)
520 { if ( ClassFunction && isAClass(class, ClassFunction) )
521 { Cell cell;
522 Class cl;
523
524 for(cl = class; ; cl = cl->super_class)
525 { if ( onDFlag(class, DC_LAZY_SEND) )
526 lazyBindingClass(cl, NAME_send, OFF);
527 if ( onDFlag(class, DC_LAZY_GET) )
528 lazyBindingClass(cl, NAME_get, OFF);
529
530 for_cell(cell, cl->send_methods)
531 { SendMethod m = cell->value;
532
533 if ( !getMemberHashTable(class->send_table, m->name) )
534 getResolveSendMethodClass(class, m->name);
535 }
536
537 for_cell(cell, cl->get_methods)
538 { GetMethod m = cell->value;
539
540 if ( !getMemberHashTable(class->get_table, m->name) )
541 getResolveGetMethodClass(class, m->name);
542 }
543
544 for_vector(cl->instance_variables, Variable v,
545 { if ( sendAccessVariable(v) )
546 getResolveSendMethodClass(class, v->name);
547 if ( getAccessVariable(v) )
548 getResolveGetMethodClass(class, v->name);
549 });
550
551 if ( cl == ClassFunction )
552 break;
553 }
554 } else if ( ClassGraphical && isAClass(class, ClassGraphical) )
555 { bindMethod(class, NAME_send, NAME_inEventArea);
556 }
557
558 succeed;
559 }
560
561 status
initClass(Class class)562 initClass(Class class)
563 { class->boot = 0;
564
565 #if 0
566 if ( InstanceSize(class) != valInt(class->instance_size) ) /* TBD */
567 Cprintf("Class %s has %d alien slots\n",
568 pp(class->name),
569 (valInt(class->instance_size) - InstanceSize(class)) /
570 sizeof(Any));
571 #endif
572
573 return installClass(class);
574 }
575
576
577 /********************************
578 * USER-DEFINED CLASSES *
579 ********************************/
580
581 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
582 Creating classes. Hairy. Actually it is getLookupClass() that takes
583 care of ceating new classes.
584 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
585
586 static status
initialiseClass(Class class,Name name,Class super)587 initialiseClass(Class class, Name name, Class super)
588 { Type type;
589 Class cl;
590
591 if ( (cl = getMemberHashTable(classTable, name)) &&
592 instanceOfObject(cl, ClassClass) )
593 fail; /* failure from getLookupClass() */
594
595 resetSlotsClass(class, name);
596 appendHashTable(classTable, name, class);
597
598 type = nameToType(name);
599 if ( !isClassType(type) ||
600 type->vector != OFF ||
601 notNil(type->supers) )
602 { errorPce(type, NAME_notClassType);
603 fail;
604 }
605 assign(type, context, class);
606
607 if ( isDefault(super) )
608 super = ClassObject;
609
610 realiseClass(super);
611 fill_slots_class(class, super);
612 assign(class, creator, inBoot ? NAME_builtIn : NAME_host);
613 assign(class, no_created, ZERO);
614 assign(class, no_freed, ZERO);
615 numberTreeClass(ClassObject, 0);
616
617 succeed;
618 }
619
620
621 static Class
getLookupClass(Class class,Name name,Class super)622 getLookupClass(Class class, Name name, Class super)
623 { Class cl;
624
625 if ( (cl = getMemberHashTable(classTable, name)) )
626 { if ( notNil(cl->super_class) ) /* no longer a typeClass() */
627 { if ( isDefault(super) || cl->super_class == super )
628 answer(cl);
629
630 errorPce(cl, NAME_cannotChangeSuperClass);
631 fail;
632 }
633 if ( name == NAME_object ) /* class(object) has no super! */
634 answer(cl);
635 } else if ( isDefault(super) ) /* lookup: class(box) or so */
636 { exceptionPce(PCE, NAME_undefinedClass, name, EAV);
637 if ( (cl = getMemberHashTable(classTable, name)) )
638 answer(cl);
639 }
640
641 fail;
642 }
643
644
645 static status
unlinkClass(Class cl)646 unlinkClass(Class cl)
647 { assert(0); /* classes cannot be unlinked */
648 fail;
649 }
650
651
652 static Class
getSubClassClass(Class super,Name name)653 getSubClassClass(Class super, Name name)
654 { realiseClass(super);
655
656 if ( notNil(super->sub_classes) )
657 { Cell cell;
658
659 for_cell(cell, super->sub_classes)
660 { Class sub = cell->value;
661
662 if ( sub->name == name )
663 answer(sub);
664 }
665 }
666
667 answer(newObject(super->class, name, super, EAV));
668 }
669
670
671 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
672 Adding local variables to classes
673 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
674
675 static void
fixSubClassVariableClass(Class class,Variable old,Variable new)676 fixSubClassVariableClass(Class class, Variable old, Variable new)
677 { if ( class->realised == ON )
678 { Cell cell;
679 Int offset = new->offset;
680
681 unallocInstanceProtoClass(class);
682
683 if ( (getElementVector(class->instance_variables, offset) == old) || !old )
684 { deleteHashTable(class->get_table, new->name);
685 deleteHashTable(class->send_table, new->name);
686 deleteHashTable(class->local_table, new->name);
687
688 elementVector(class->instance_variables, offset, new);
689
690 /* TBD: function subclass? */
691 if ( old && notNil(class->sub_classes) )
692 { for_cell(cell, class->sub_classes)
693 fixSubClassVariableClass(cell->value, old, new);
694 }
695 }
696 }
697 }
698
699
700 static Variable
getLocaliseInstanceVariableClass(Class class,Name name)701 getLocaliseInstanceVariableClass(Class class, Name name)
702 { Variable var;
703
704 realiseClass(class);
705 if ( (var = getInstanceVariableClass(class, name)) )
706 { if ( var->context != class )
707 { Variable var2 = getCloneObject(var);
708 assign(var2, context, class);
709 fixSubClassVariableClass(class, var, var2);
710
711 if ( ClassDelegateVariable &&
712 instanceOfObject(var2, ClassDelegateVariable) )
713 delegateClass(class, var2->name);
714
715 answer(var2);
716 }
717 }
718
719 answer(var);
720 }
721
722 status
instanceVariableClass(Class class,Variable var)723 instanceVariableClass(Class class, Variable var)
724 { Variable old;
725 Int offset;
726
727 realiseClass(class);
728 /* redefinition of a variable */
729 if ( (old = getInstanceVariableClass(class, var->name)) )
730 { if ( old->context != class &&
731 !specialisedType(var->type, old->type) )
732 return errorPce(class, NAME_cannotRefineVariable, var->name);
733
734 offset = old->offset;
735 } else
736 { if ( !inBoot )
737 { if ( class->no_created != class->no_freed )
738 return errorPce(class, NAME_hasInstances);
739 if ( notNil(class->sub_classes) )
740 { Cell cell;
741
742 for_cell(cell, class->sub_classes)
743 { Class sub = cell->value;
744 if ( sub->realised == ON )
745 return errorPce(class, NAME_hasSubClasses);
746 }
747 }
748 }
749 offset = class->slots;
750 assign(class, slots, toInt(valInt(class->slots)+1));
751 if ( InstanceSize(class) > valInt(class->instance_size) )
752 assign(class, instance_size, toInt(InstanceSize(class)));
753 }
754
755 assign(var, offset, offset);
756 assign(var, context, class);
757 fixSubClassVariableClass(class, old, var);
758
759 if ( ClassDelegateVariable && instanceOfObject(var, ClassDelegateVariable) )
760 delegateClass(class, var->name);
761
762 succeed;
763 }
764
765
766 static status
refineVariableClass(Class class,Variable var)767 refineVariableClass(Class class, Variable var)
768 { Variable old;
769
770 if ( !(old = getInstanceVariableClass(class, var->name)) )
771 return instanceVariableClass(class, var); /* no redefinition (error?) */
772
773 assign(var, offset, old->offset);
774 assign(var, context, class);
775 fixSubClassVariableClass(class, old, var);
776
777 if ( ClassDelegateVariable && instanceOfObject(var, ClassDelegateVariable) )
778 delegateClass(class, var->name);
779
780 succeed;
781 }
782
783
784 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
785 Method manipulation
786 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
787
788 static status
codeExecuteCode(Code c)789 codeExecuteCode(Code c)
790 { return vm_send(c, NAME_Execute, classOfObject(c), 0, NULL);
791 }
792
793
794 void
fixSendFunctionClass(Class class,Name selector)795 fixSendFunctionClass(Class class, Name selector)
796 { SendMethod m = getSendMethodClass(class, selector);
797
798 class->send_function = (m ? (SendFunc) m->function : (SendFunc) NULL);
799
800 if ( !class->send_function )
801 class->send_function = codeExecuteCode;
802 }
803
804
805 static Any
codeGetExecuteCode(Code c)806 codeGetExecuteCode(Code c)
807 { return vm_get(c, NAME_Execute, classOfObject(c), 0, NULL);
808 }
809
810
811 void
fixGetFunctionClass(Class class,Name selector)812 fixGetFunctionClass(Class class, Name selector)
813 { GetMethod m = getGetMethodClass(class, selector);
814
815 class->get_function = (m ? (GetFunc) m->function : (GetFunc) NULL);
816
817 if ( !class->get_function )
818 class->get_function = codeGetExecuteCode;
819 }
820
821
822 static void
fixSubClassSendMethodsClass(Class class,Method m)823 fixSubClassSendMethodsClass(Class class, Method m)
824 { if ( class->realised == ON )
825 { Cell cell;
826
827 deleteHashTable(class->send_table, m->name);
828 if ( notNil(class->sub_classes) )
829 { for_cell(cell, class->sub_classes)
830 fixSubClassSendMethodsClass(cell->value, m);
831 }
832 if ( m->name == NAME_initialise )
833 assign(class, initialise_method, DEFAULT);
834 else if ( m->name == NAME_catchAll )
835 assign(class, send_catch_all, DEFAULT);
836 else if ( m->name == NAME_inEventArea )
837 class->in_event_area_function = INVOKE_FUNC;
838 }
839 }
840
841
842 status
sendMethodClass(Class class,SendMethod m)843 sendMethodClass(Class class, SendMethod m)
844 { Cell cell;
845
846 realiseClass(class);
847
848 if ( notNil(m->context) )
849 return errorPce(class, NAME_alreadyPartOf, m, m->context);
850
851 fixSubClassSendMethodsClass(class, (Method) m);
852 for_cell(cell, class->send_methods)
853 { SendMethod old = cell->value;
854
855 if ( old->name == m->name && old != m )
856 {
857 #ifndef O_RUNTIME
858 deleteChain(class->send_methods, old);
859 #else
860 if ( onFlag(old, F_TEMPLATE_METHOD) )
861 deleteChain(class->send_methods, old);
862 else
863 return errorPce(getMethodFromFunction(sendMethodClass),
864 NAME_runtimeVersion);
865 #endif
866 break;
867 }
868 }
869
870 appendChain(class->send_methods, m);
871 assign(m, context, class);
872 if ( m->name == NAME_equal )
873 setDFlag(m, D_TYPENOWARN);
874 if ( offDFlag(class, DC_LAZY_SEND) )
875 lazyBindingClass(class, NAME_send, ON);
876
877 succeed;
878 }
879
880
881 static void
fixSubClassGetMethodsClass(Class class,Method m)882 fixSubClassGetMethodsClass(Class class, Method m)
883 { if ( class->realised == ON && !inBoot ) /* TBD */
884 { Cell cell;
885
886 deleteHashTable(class->get_table, m->name);
887 if ( notNil(class->sub_classes) )
888 { for_cell(cell, class->sub_classes)
889 fixSubClassGetMethodsClass(cell->value, m);
890 }
891 if ( m->name == NAME_lookup )
892 assign(class, lookup_method, DEFAULT);
893 else if ( m->name == NAME_convert )
894 assign(class, convert_method, DEFAULT);
895 }
896 }
897
898 status
getMethodClass(Class class,GetMethod m)899 getMethodClass(Class class, GetMethod m)
900 { Cell cell;
901
902 realiseClass(class);
903
904 if ( notNil(m->context) )
905 return errorPce(class, NAME_alreadyPartOf, m, m->context);
906
907 /* delete old definition */
908 fixSubClassGetMethodsClass(class, (Method) m);
909
910 for_cell(cell, class->get_methods)
911 { GetMethod old = cell->value;
912
913 if ( old->name == m->name && old != m )
914 {
915 #ifndef O_RUNTIME
916 deleteChain(class->get_methods, old);
917 #else
918 if ( onFlag(old, F_TEMPLATE_METHOD) )
919 deleteChain(class->get_methods, old);
920 else
921 return errorPce(getMethodFromFunction(sendMethodClass),
922 NAME_runtimeVersion);
923 #endif
924 break;
925 }
926 }
927 /* Insert new one */
928 appendChain(class->get_methods, m);
929 assign(m, context, class);
930 if ( offDFlag(class, DC_LAZY_GET) )
931 lazyBindingClass(class, NAME_get, ON);
932
933 succeed;
934 }
935
936
937 status
setChangedFunctionClass(Class class,SendFunc func)938 setChangedFunctionClass(Class class, SendFunc func)
939 { class->changedFunction = func;
940
941 succeed;
942 }
943
944
945 status
setInEventAreaFunctionClass(Class class,SendFunc func)946 setInEventAreaFunctionClass(Class class, SendFunc func)
947 { class->in_event_area_function = func;
948
949 /* TBD, but implementation needs to be cleaned first
950 sendMethod(class, NAME_inEventArea, NAME_event, 2, "x=int", "y=int",
951 "Test if location is in sensitive area",
952 func);
953 */
954
955 succeed;
956 }
957
958
959 status
isPceSlot(Class class,int n)960 isPceSlot(Class class, int n)
961 { Variable var = class->instance_variables->elements[n];
962
963 return var->type->kind == NAME_alien ? FAIL : SUCCEED;
964 }
965
966
967 status
allPceSlotsClass(Class class)968 allPceSlotsClass(Class class)
969 { for_vector(class->instance_variables, Variable var,
970 if ( var->type->kind == NAME_alien )
971 fail;);
972
973 succeed;
974 }
975
976 /********************************
977 * OBJECT -> TERM *
978 ********************************/
979
980 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
981 termClass(Class, FunctorName, Arity, Selector1 ...)
982 Define the term representation of Class to be
983
984 FunctorName(obj?Selector1, ...)
985 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
986
987 static inline void
_termClass(Class class,char * name,int argc,va_list args)988 _termClass(Class class, char *name, int argc, va_list args)
989 { realiseClass(class);
990
991 if ( argc == ARGC_UNKNOWN )
992 { assign(class, term_names, NIL);
993 } else
994 { ArgVector(names, argc);
995 int n;
996
997 for(n=0; n<argc; n++)
998 { names[n] = va_arg(args, Any);
999
1000 if ( !isProperObject(names[n]) || notName(names[n]) )
1001 { sysPce("Illegal selector (arg %d) to termClass of class %s",
1002 n+1, pp(class->name));
1003 return;
1004 }
1005 }
1006
1007 assign(class, term_names, newObjectv(ClassVector, argc, names));
1008 }
1009 }
1010
1011
1012 void
termClass(Class class,char * name,int argc,...)1013 termClass(Class class, char *name, int argc, ...)
1014 { va_list args;
1015
1016 va_start(args, argc);
1017 _termClass(class, name, argc, args);
1018 va_end(args);
1019 }
1020
1021
1022 status
sendMethodv(Class class,Name name,Name group,int argc,va_list args)1023 sendMethodv(Class class, Name name, Name group, int argc, va_list args)
1024 { SendMethod m;
1025 Type types[METHOD_MAX_ARGS];
1026 int i;
1027 SendFunc f;
1028 Vector tv;
1029 char *rawdoc;
1030 StringObj doc;
1031
1032 for(i=0; i<argc; i++)
1033 { char *type = va_arg(args, char *);
1034
1035 assert(i < METHOD_MAX_ARGS);
1036 if ( !(types[i] = CtoType(type)) )
1037 sysPce("Bad type in sendMethod(): %s->%s: %s",
1038 pp(class->name), pp(name), type);
1039 }
1040
1041 tv = inBoot ? createVectorv(argc, (Any *)types)
1042 : answerObjectv(ClassVector, argc, (Any *)types);
1043
1044 if ( (rawdoc = va_arg(args, char *)) )
1045 { checkSummaryCharp(class->name, name, rawdoc);
1046 doc = rawdoc[0] == EOS ? (StringObj) NIL : staticCtoString(rawdoc);
1047 } else
1048 doc = NIL;
1049
1050 f = va_arg(args, SendFunc);
1051 m = createSendMethod(name, tv, doc, f);
1052 if ( notDefault(group) )
1053 assign(m, group, group);
1054
1055 assign(m, context, class);
1056 appendChain(class->send_methods, m);
1057
1058 if ( isNil(m->summary) )
1059 { SendMethod super;
1060
1061 if ( (super = (SendMethod) getInheritedFromMethod((Method)m)) )
1062 assign(m, summary, super->summary);
1063 }
1064
1065 succeed;
1066 }
1067
1068
1069 status
sendMethod(Class class,Name name,Name group,int argc,...)1070 sendMethod(Class class, Name name, Name group, int argc, ...)
1071 { va_list args;
1072 status rval;
1073
1074 va_start(args, argc);
1075 rval = sendMethodv(class, name, group, argc, args);
1076 va_end(args);
1077
1078 return rval;
1079 }
1080
1081
1082 status
storeMethod(Class class,Name name,SendFunc function)1083 storeMethod(Class class, Name name, SendFunc function)
1084 { Variable var = getInstanceVariableClass(class, (Any) name);
1085 Vector tv;
1086 SendMethod m;
1087
1088 if ( !var )
1089 return sysPce("storeMethod(): no variable %s on class %s",
1090 pp(name), pp(class->name));
1091 tv = inBoot ? createVectorv(1, (Any *)(&var->type))
1092 : answerObjectv(ClassVector, 1, (Any *)(&var->type));
1093
1094 m = createSendMethod(name, tv, var->summary, function);
1095 assign(m, context, class);
1096 assign(m, group, var->group);
1097 appendChain(class->send_methods, m);
1098
1099 succeed;
1100 }
1101
1102
1103 static status
fetchMethod(Class class,Name name,void * function)1104 fetchMethod(Class class, Name name, void *function)
1105 { Variable var = getInstanceVariableClass(class, (Any) name);
1106 Vector tv;
1107 GetMethod m;
1108
1109 if ( !var )
1110 return sysPce("fetchMethod(): no variable %s on class %s",
1111 pp(name), pp(class->name));
1112 tv = inBoot ? createVectorv(0, NULL)
1113 : answerObjectv(ClassVector, 0, NULL);
1114
1115 m = createGetMethod(name, var->type, tv, var->summary, function);
1116 assign(m, context, class);
1117 assign(m, group, var->group);
1118 appendChain(class->get_methods, m);
1119
1120 succeed;
1121 }
1122
1123
1124 status
getMethodv(Class class,Name name,Name group,const char * rtype,int argc,va_list args)1125 getMethodv(Class class, Name name, Name group,
1126 const char *rtype, int argc, va_list args)
1127 { GetMethod m;
1128 Type rt;
1129 Type types[METHOD_MAX_ARGS];
1130 int i;
1131 Func f;
1132 Vector tv;
1133 char *rawdoc;
1134 StringObj doc;
1135
1136 if ( !(rt = CtoType(rtype)) )
1137 return sysPce("Bad return type in getMethod(): %s<-%s: %s",
1138 pp(class->name), pp(name), rtype);
1139 for(i=0; i<argc; i++)
1140 { char *type = va_arg(args, char *);
1141
1142 assert(i<METHOD_MAX_ARGS);
1143 if ( !(types[i] = CtoType(type)) )
1144 sysPce("Bad type in getMethod(): %s<-%s: %s",
1145 pp(class->name), pp(name), type);
1146 }
1147 tv = inBoot ? createVectorv(argc, (Any *)types)
1148 : answerObjectv(ClassVector, argc, (Any *)types);
1149
1150 if ( (rawdoc = va_arg(args, char *)) )
1151 { checkSummaryCharp(class->name, name, rawdoc);
1152 doc = rawdoc[0] == EOS ? (StringObj) NIL : staticCtoString(rawdoc);
1153 } else
1154 doc = NIL;
1155
1156 f = va_arg(args, Func);
1157 m = createGetMethod(name, rt, tv, doc, f);
1158 if ( notDefault(group) )
1159 assign(m, group, group);
1160
1161 assign(m, context, class);
1162 appendChain(class->get_methods, m);
1163 if ( isNil(m->summary) )
1164 { GetMethod super;
1165
1166 if ( (super = (GetMethod) getInheritedFromMethod((Method)m)) )
1167 assign(m, summary, super->summary);
1168 }
1169
1170 succeed;
1171 }
1172
1173 status
getMethod(Class class,Name name,Name group,const char * rtype,int argc,...)1174 getMethod(Class class, Name name, Name group, const char *rtype, int argc, ...)
1175 { va_list args;
1176 status rval;
1177
1178 va_start(args, argc);
1179 rval = getMethodv(class, name, group, rtype, argc, args);
1180 va_end(args);
1181
1182 return rval;
1183 }
1184
1185
1186 /********************************
1187 * RESERVED FUNCTIONS *
1188 ********************************/
1189
1190 status
cloneStyleClass(Class class,Name style)1191 cloneStyleClass(Class class, Name style)
1192 { realiseClass(class);
1193 assign(class, cloneStyle, style);
1194
1195 succeed;
1196 }
1197
1198
1199 status
cloneStyleVariableClass(Class class,Name slot,Name style)1200 cloneStyleVariableClass(Class class, Name slot, Name style)
1201 { Variable var;
1202
1203 if ( (var = getLocaliseInstanceVariableClass(class, slot)) )
1204 return cloneStyleVariable(var, style);
1205
1206 fail;
1207 }
1208
1209
1210 status
saveStyleVariableClass(Class class,Name slot,Name style)1211 saveStyleVariableClass(Class class, Name slot, Name style)
1212 { Variable var;
1213
1214 if ( (var = getLocaliseInstanceVariableClass(class, slot)) )
1215 return saveStyleVariable(var, style);
1216
1217 fail;
1218 }
1219
1220
1221 status
saveStyleClass(Class class,Name style)1222 saveStyleClass(Class class, Name style)
1223 { realiseClass(class);
1224 assign(class, saveStyle, style);
1225
1226 succeed;
1227 }
1228
1229
1230 status
setCloneFunctionClass(Class class,SendFunc function)1231 setCloneFunctionClass(Class class, SendFunc function)
1232 { class->cloneFunction = function;
1233 succeed;
1234 }
1235
1236
1237 status
setRedrawFunctionClass(Class class,SendFunc function)1238 setRedrawFunctionClass(Class class, SendFunc function)
1239 { class->redrawFunction = function;
1240
1241 sendMethod(class, NAME_RedrawArea, NAME_repaint, 1, "area",
1242 "Repaint the argument area",
1243 function);
1244 succeed;
1245 }
1246
1247
1248 status
setLoadStoreFunctionClass(Class class,SendFunc load,SendFunc store)1249 setLoadStoreFunctionClass(Class class, SendFunc load, SendFunc store)
1250 { class->loadFunction = load;
1251 class->saveFunction = store;
1252 succeed;
1253 }
1254
1255
1256 static status
handleClass(Class class,Handle handle)1257 handleClass(Class class, Handle handle)
1258 { realiseClass(class);
1259 if ( isNil(class->handles) )
1260 assign(class, handles, newObject(ClassChain, handle, EAV));
1261 else
1262 appendChain(class->handles, handle);
1263
1264 succeed;
1265 }
1266
1267
1268 status
solidClass(Class class,BoolObj val)1269 solidClass(Class class, BoolObj val)
1270 { realiseClass(class);
1271 assign(class, solid, val);
1272
1273 succeed;
1274 }
1275
1276
1277 status
sourceClass(Class class,SendFunc f,char * file,char * rcs)1278 sourceClass(Class class, SendFunc f, char *file, char *rcs)
1279 {
1280 #ifndef O_RUNTIME
1281 assign(class, source, newObject(ClassSourceLocation, CtoName(file), EAV));
1282 #endif
1283
1284 if ( rcs )
1285 { static char rev[] = "$Revision: ";
1286 char *s, *q;
1287 char buf[100];
1288 size_t l;
1289
1290 for(s=rcs, q=rev; *q && *s == *q; s++, q++)
1291 ;
1292 strcpy(buf, s);
1293 l = strlen(buf);
1294 if ( l >= 2 && streq(&buf[l-2], " $") )
1295 buf[l-2] = EOS;
1296
1297 assign(class, rcs_revision, CtoName(buf));
1298 }
1299
1300 succeed;
1301 }
1302
1303
1304 #ifdef O_RUNTIME
1305 static status
rtSourceClass(Class class,SourceLocation src)1306 rtSourceClass(Class class, SourceLocation src)
1307 { succeed;
1308 }
1309 #endif
1310
1311
1312 void
localClass(Class class,Name name,Name group,char * type,Name access,char * doc)1313 localClass(Class class, Name name, Name group,
1314 char *type, Name access, char *doc)
1315 { Variable v;
1316 Type t;
1317
1318 if ( !(t = CtoType(type)) )
1319 sysPce("Bad type in variable: %s.%s: %s",
1320 pp(class->name), pp(name), type);
1321
1322 v = createVariable(name, t, access);
1323
1324 if ( strlen(doc) > 0 )
1325 assign(v, summary, staticCtoString(doc));
1326 if ( notDefault(group) )
1327 assign(v, group, group);
1328
1329 instanceVariableClass(class, v);
1330 }
1331
1332
1333 static void
redefineLocalClass(Class class,Name name,Name group,char * type,Name access,char * doc)1334 redefineLocalClass(Class class, Name name, Name group,
1335 char *type, Name access, char *doc)
1336 { Variable v;
1337 Type t;
1338
1339 if ( !(t = CtoType(type)) )
1340 sysPce("Bad type in variable: %s.%s: %s",
1341 pp(class->name), pp(name), type);
1342
1343 v = createVariable(name, t, access);
1344
1345 if ( strlen(doc) > 0 )
1346 assign(v, summary, staticCtoString(doc));
1347 if ( notDefault(group) )
1348 assign(v, group, group);
1349
1350 refineVariableClass(class, v);
1351 }
1352
1353
1354 static Name iv_access_names[] = { NAME_none, NAME_get, NAME_send, NAME_both };
1355
1356 status
declareClass(Class class,const classdecl * decls)1357 declareClass(Class class, const classdecl *decls)
1358 { int i;
1359 const vardecl *iv;
1360 const classvardecl *cv;
1361
1362 class->c_declarations = (classdecl *)decls; /* TBD: const */
1363
1364 sourceClass(class, NULL, decls->source_file, decls->rcs_revision);
1365 if ( decls->term_arity != ARGC_INHERIT )
1366 { if ( decls->term_arity == ARGC_UNKNOWN )
1367 { assign(class, term_names, NIL);
1368 } else
1369 { assign(class, term_names,
1370 newObjectv(ClassVector, decls->term_arity,
1371 (Any *)decls->term_names));
1372 }
1373 }
1374
1375 for( i=decls->nvar, iv = decls->variables; i-- > 0; iv++ )
1376 { Name acs = iv_access_names[iv->flags & (IV_GET|IV_SEND)];
1377
1378 if ( iv->flags & IV_REDEFINE )
1379 redefineLocalClass(class, iv->name, iv->group,
1380 iv->type, acs, iv->summary);
1381 else
1382 localClass(class, iv->name, iv->group,
1383 iv->type, acs, iv->summary);
1384
1385 if ( iv->flags & IV_STORE )
1386 storeMethod(class, iv->name, (SendFunc) iv->context);
1387 else if ( iv->flags & IV_FETCH )
1388 fetchMethod(class, iv->name, (GetFunc) iv->context);
1389 }
1390 /* should be delayed too? */
1391 for( i=decls->nclassvars, cv=decls->class_variables; i-- > 0; cv++ )
1392 { if ( cv->type == RC_REFINE )
1393 refine_class_variable(class, strName(cv->name), cv->value);
1394 else
1395 attach_class_variable(class, cv->name, cv->type, cv->value, cv->summary);
1396 }
1397
1398 succeed;
1399 }
1400
1401
1402 status
delegateClass(Class class,Name name)1403 delegateClass(Class class, Name name)
1404 { Variable var = getInstanceVariableClass(class, name);
1405
1406 if ( var )
1407 { deleteChain(class->delegate, var);
1408 appendChain(class->delegate, var);
1409
1410 succeed;
1411 }
1412
1413 return errorPce(class, NAME_noVariable, name);
1414 }
1415
1416
1417 status
prependDelegateClass(Class class,Name name)1418 prependDelegateClass(Class class, Name name)
1419 { Variable var = getInstanceVariableClass(class, name);
1420
1421 if ( var )
1422 { deleteChain(class->delegate, var);
1423 prependChain(class->delegate, var);
1424
1425 succeed;
1426 }
1427
1428 return errorPce(class, NAME_noVariable, name);
1429 }
1430
1431
1432 static Any
getInstanceClassv(Class class,int argc,Any * argv)1433 getInstanceClassv(Class class, int argc, Any *argv)
1434 { answer(answerObjectv(class, argc, argv));
1435 }
1436
1437
1438 Variable
getInstanceVariableClass(Class class,Any which)1439 getInstanceVariableClass(Class class, Any which)
1440 { Variable var;
1441
1442 realiseClass(class);
1443
1444 if ( isInteger(which) )
1445 answer( getElementVector(class->instance_variables, (Int) which));
1446
1447 if ( (var = getMemberHashTable(class->local_table, which)) != FAIL )
1448 answer(var);
1449
1450 for_vector(class->instance_variables, var,
1451 { if ( var->name == which )
1452 { appendHashTable(class->local_table, which, var);
1453 answer(var);
1454 }
1455 });
1456
1457 fail; /* no such variable */
1458 }
1459
1460
1461 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1462 Lazy binding of methods.
1463
1464 We donot want to built the entire method representation in
1465 <-send_methods, <-get_methods, <-instance_variables, <-get_table and
1466 <-send_table in one go. Many methods are never used in an application,
1467 and it would be good practice if their definition is never loaded from
1468 disk.
1469
1470 Therefore, a <-get_table and <-send_table start of empty. If a method is
1471 needed, getSendMethodClass()/getGetMethodClass() is called, which first
1472 does a lookup in these tables. If the method is not found,
1473 getResolve(Send/Get)MethodClass() is called to find the method.
1474
1475 One day, the implementation was simple.
1476 getResolve(Send/Get)MethodClass() just walked along the methods and
1477 variables and added the method or var to the table when found,or the
1478 constant @nil if the method was not found.
1479
1480 Right now, live is harder as <-send_methods and <-get_methods are
1481 initially not filled either. There are two sources of methods: the
1482 classdecl structure from <-c_declarations and the host-language.
1483 Moreover, the definitions in the host-language may be change at runtime
1484 (recompilation of sourcefiles).
1485
1486 Two cases need to be considered. Binding all (send- or get-) methods and
1487 binding a single one. After all methods have been bound, no dynamic
1488 binding is needed until the sources are changed. If a single method
1489 needs to be bound, the system should first check whether the host has a
1490 more recent definition. If so, the host should pass its definition. If
1491 not, the current definition must be used.
1492
1493 To realise this, the class is given a `generation number', and so is
1494 each method. If a method needs to be resolved, the system will first
1495 check the method chain. If the method chain contains a method with the
1496 same generation as the class, this one is used. If the number is older,
1497 or the method is not known at all, the host binder is called. If the
1498 host binder fails, the built-in binder is called. If this fails too, the
1499 instance variables are checked.
1500
1501 class->clear_cache increments the generation number of the class.
1502 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1503
1504 static status
boundSendMethodClass(Class class,Name name)1505 boundSendMethodClass(Class class, Name name)
1506 { if ( class->realised == ON )
1507 { Cell cell;
1508
1509 for_cell(cell, class->send_methods)
1510 { SendMethod m = cell->value;
1511
1512 if ( m->name == name )
1513 succeed;
1514 }
1515 for_vector(class->instance_variables, Variable var,
1516 { if ( var->name == name &&
1517 sendAccessVariable(var) &&
1518 var->context == class )
1519 succeed;
1520 });
1521 }
1522
1523 fail;
1524 }
1525
1526
1527 static status
boundGetMethodClass(Class class,Name name)1528 boundGetMethodClass(Class class, Name name)
1529 { if ( class->realised == ON )
1530 { Cell cell;
1531
1532 for_cell(cell, class->get_methods)
1533 { SendMethod m = cell->value;
1534
1535 if ( m->name == name )
1536 succeed;
1537 }
1538 for_vector(class->instance_variables, Variable var,
1539 { if ( var->name == name &&
1540 getAccessVariable(var) &&
1541 var->context == class )
1542 succeed;
1543 });
1544 }
1545
1546 fail;
1547 }
1548
1549
1550 static SendMethod
attachLazySendMethodClass(Class class,const senddecl * sm)1551 attachLazySendMethodClass(Class class, const senddecl *sm)
1552 { SendMethod m;
1553 Type types[METHOD_MAX_ARGS];
1554 int i;
1555 Vector tv;
1556 StringObj doc;
1557 char **tps = (sm->arity == 1 ? (char **)&sm->types : (char **)sm->types);
1558 Cell cell;
1559
1560 for_cell(cell, class->send_methods)
1561 { SendMethod m = cell->value;
1562 if ( m->name == sm->name )
1563 return m;
1564 }
1565 for(i=0; i<sm->arity; i++)
1566 { if ( !(types[i] = CtoType(tps[i])) )
1567 sysPce("Bad type in argument %d of %s->%s: %s",
1568 i+1, pp(class->name), pp(sm->name), tps[i]);
1569 }
1570
1571 tv = inBoot ? createVectorv(sm->arity, (Any *)types)
1572 : answerObjectv(ClassVector, sm->arity, (Any *)types);
1573 doc = (sm->summary ? (Any) staticCtoString(sm->summary) : DEFAULT);
1574 m = createSendMethod(sm->name, tv, doc, sm->function);
1575 if ( notDefault(sm->group) )
1576 assign(m, group, sm->group);
1577
1578 appendChain(class->send_methods, m);
1579 assign(m, context, class);
1580 if ( m->name == NAME_equal )
1581 setDFlag(m, D_TYPENOWARN);
1582
1583 return m;
1584 }
1585
1586
1587 static GetMethod
attachLazyGetMethodClass(Class class,const getdecl * gm)1588 attachLazyGetMethodClass(Class class, const getdecl *gm)
1589 { GetMethod m;
1590 Type types[METHOD_MAX_ARGS];
1591 Type rtype;
1592 int i;
1593 Vector tv;
1594 StringObj doc;
1595 char **tps = (gm->arity == 1 ? (char **)&gm->types : (char **)gm->types);
1596 Cell cell;
1597
1598 for_cell(cell, class->get_methods)
1599 { GetMethod m = cell->value;
1600 if ( m->name == gm->name )
1601 return m;
1602 }
1603 for(i=0; i<gm->arity; i++)
1604 { if ( !(types[i] = CtoType(tps[i])) )
1605 sysPce("Bad type in argument %d of %s<-%s: %s",
1606 i+1, pp(class->name), pp(gm->name),tps[i]);
1607 }
1608 if ( !(rtype = CtoType(gm->rtype)) )
1609 { sysPce("Bad return-type in %s<-%s: %s",
1610 pp(class->name), pp(gm->name), gm->rtype);
1611 }
1612
1613 tv = inBoot ? createVectorv(gm->arity, (Any *)types)
1614 : answerObjectv(ClassVector, gm->arity, (Any *)types);
1615 doc = (gm->summary ? (Any) staticCtoString(gm->summary) : DEFAULT);
1616 m = createGetMethod(gm->name, rtype, tv, doc, gm->function);
1617 if ( notDefault(gm->group) )
1618 assign(m, group, gm->group);
1619
1620 appendChain(class->get_methods, m);
1621 assign(m, context, class);
1622
1623 return m;
1624 }
1625
1626 static int bind_nesting;
1627
1628 void
resetMessageResolve()1629 resetMessageResolve()
1630 { bind_nesting = 0;
1631 }
1632
1633 static Any
bindMethod(Class class,Name code,Name selector)1634 bindMethod(Class class, Name code, Name selector)
1635 { Any c;
1636 status rval = FAIL;
1637 classdecl *cdecls = class->c_declarations;
1638 int i;
1639
1640 if ( isDefault(selector) && cdecls )
1641 { if ( code == NAME_send )
1642 { const senddecl *sm;
1643
1644 for( i = cdecls->nsend, sm = cdecls->send_methods; i-- > 0; sm++ )
1645 attachLazySendMethodClass(class, sm);
1646 } else
1647 { const getdecl *gm;
1648
1649 for( i = cdecls->nget, gm = cdecls->get_methods; i-- > 0; gm++ )
1650 attachLazyGetMethodClass(class, gm);
1651 }
1652 }
1653
1654 if ( !bind_nesting )
1655 { bind_nesting++;
1656 if ( notNil((c=class->resolve_method_message)) && notDefault(c) )
1657 { if ( instanceOfObject(c, ClassCode) )
1658 { DEBUG(NAME_class,
1659 Cprintf("Asking host to resolve %s %s %s\n",
1660 pp(code), pp(class->name), pp(selector)));
1661 rval = forwardCode(c, code, class->name, selector, EAV);
1662 }
1663 }
1664 bind_nesting--;
1665 }
1666
1667 if ( isDefault(selector) )
1668 return DEFAULT;
1669
1670 if ( rval )
1671 { Chain ch = (code == NAME_send ? class->send_methods : class->get_methods);
1672 Cell cell;
1673 Method m = getTailChain(ch);
1674
1675 if ( m && m->name == selector ) /* this will be the common case! */
1676 return m;
1677
1678 for_cell(cell, ch)
1679 { Method m = cell->value;
1680
1681 if ( m->name == selector )
1682 return m;
1683 }
1684 } else
1685 { if ( cdecls )
1686 { if ( code == NAME_send )
1687 { const senddecl *sm;
1688
1689 for( i = cdecls->nsend, sm = cdecls->send_methods; i-- > 0; sm++ )
1690 { if ( sm->name == selector )
1691 return attachLazySendMethodClass(class, sm);
1692 }
1693 } else /* get */
1694 { const getdecl *gm;
1695
1696 for( i = cdecls->nget, gm = cdecls->get_methods; i-- > 0; gm++ )
1697 { if ( gm->name == selector )
1698 return attachLazyGetMethodClass(class, gm);
1699 }
1700 }
1701 }
1702 }
1703
1704 fail;
1705 }
1706
1707
1708 Any
getResolveSendMethodClass(Class class,Name name)1709 getResolveSendMethodClass(Class class, Name name)
1710 { Cell cell;
1711 Class super;
1712
1713 realiseClass(class);
1714
1715 for(super = class; notNil(super); super = super->super_class)
1716 { Any sm;
1717
1718 if ( (sm = getMemberHashTable(super->send_table, name)) )
1719 { if ( class != super )
1720 appendHashTable(class->send_table, name, sm);
1721 answer(sm);
1722 }
1723
1724 /* first do built-in, so redefines */
1725 /* need to remove a method first */
1726 for_cell(cell, super->send_methods)
1727 { SendMethod m = cell->value;
1728
1729 if ( m->name == name )
1730 { appendHashTable(class->send_table, name, m);
1731 answer(m);
1732 }
1733 }
1734
1735 if ( onDFlag(super, DC_LAZY_SEND) )
1736 { if ( (sm = bindMethod(super, NAME_send, name)) )
1737 { appendHashTable(class->send_table, name, sm);
1738 answer(sm);
1739 }
1740 }
1741
1742 for_vector(super->instance_variables, Variable var,
1743 { if ( var->name == name &&
1744 sendAccessVariable(var) &&
1745 var->context == super )
1746 { appendHashTable(class->send_table, name, var);
1747 answer(var);
1748 }
1749 });
1750 }
1751
1752 appendHashTable(class->send_table, name, NIL);
1753 fail;
1754 }
1755
1756
1757 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1758 Find the implementation for get-behaviour defined on a class. This isn't
1759 very critical, as it is shielded by getGetMethodClass(), which performs
1760 caching.
1761
1762 Class-variables are a nuisance, as it is defined that other
1763 get-implementation always precedes class-variables, even if the other
1764 behaviour is defined higher in the hierarchy.
1765 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1766
1767 Any
getResolveGetMethodClass(Class class,Name name)1768 getResolveGetMethodClass(Class class, Name name)
1769 { Class super;
1770 ClassVariable cv = NULL;
1771
1772 realiseClass(class);
1773
1774 for(super = class; notNil(super); super = super->super_class)
1775 { Any gm;
1776 Cell cell;
1777
1778 if ( (gm = getMemberHashTable(super->get_table, name)) )
1779 { if ( cv && instanceOfObject(gm, ClassClassVariable) )
1780 gm = cv;
1781 if ( class != super )
1782 appendHashTable(class->get_table, name, gm);
1783 answer(gm);
1784 }
1785
1786 for_cell(cell, super->get_methods)
1787 { GetMethod m = cell->value;
1788
1789 if ( m->name == name )
1790 { appendHashTable(class->get_table, name, m);
1791 answer(m);
1792 }
1793 }
1794
1795 if ( onDFlag(super, DC_LAZY_GET) )
1796 { if ( (gm = bindMethod(super, NAME_get, name)) )
1797 { appendHashTable(class->get_table, name, gm);
1798 answer(gm);
1799 }
1800 }
1801
1802 for_vector(super->instance_variables, Variable var,
1803 { if ( var->name == name &&
1804 getAccessVariable(var) &&
1805 var->context == super )
1806 { appendHashTable(class->get_table, name, var);
1807 answer(var);
1808 }
1809 });
1810
1811 if ( !cv )
1812 { for_cell(cell, super->class_variables)
1813 { ClassVariable v = cell->value;
1814
1815 if ( v->name == name )
1816 { cv = v;
1817 break;
1818 }
1819 }
1820 }
1821 }
1822
1823 if ( cv )
1824 { appendHashTable(class->get_table, name, cv);
1825 answer(cv);
1826 }
1827
1828 appendHashTable(class->get_table, name, NIL);
1829 fail;
1830 }
1831
1832
1833 static status
clearCacheClass(Class class)1834 clearCacheClass(Class class)
1835 { if ( class->realised == ON )
1836 { clearHashTable(class->send_table);
1837 clearHashTable(class->get_table);
1838
1839 assign(class, initialise_method, DEFAULT);
1840 assign(class, lookup_method, DEFAULT);
1841
1842 setDFlag(class, DC_LAZY_SEND|DC_LAZY_GET);
1843
1844 installClass(class); /* Enter function special methods */
1845 }
1846
1847 succeed;
1848 }
1849
1850
1851 static status
deleteSendMethodClass(Class class,Name selector)1852 deleteSendMethodClass(Class class, Name selector)
1853 { if ( class->realised == ON )
1854 { Cell cell;
1855
1856 deleteHashTable(class->send_table, selector);
1857 for_cell(cell, class->send_methods)
1858 { SendMethod sm = cell->value;
1859
1860 if ( sm->name == selector )
1861 { deleteChain(class->send_methods, sm);
1862 break;
1863 }
1864 }
1865
1866 if ( selector == NAME_initialise )
1867 assign(class, initialise_method, DEFAULT);
1868 else if ( selector == NAME_catchAll )
1869 assign(class, send_catch_all, DEFAULT);
1870 }
1871
1872 succeed;
1873 }
1874
1875
1876 static status
deleteGetMethodClass(Class class,Name selector)1877 deleteGetMethodClass(Class class, Name selector)
1878 { if ( class->realised == ON )
1879 { Cell cell;
1880
1881 deleteHashTable(class->get_table, selector);
1882 for_cell(cell, class->get_methods)
1883 { GetMethod sm = cell->value;
1884
1885 if ( sm->name == selector )
1886 { deleteChain(class->get_methods, sm);
1887 break;
1888 }
1889 }
1890
1891 if ( selector == NAME_lookup )
1892 assign(class, lookup_method, DEFAULT);
1893 else if ( selector == NAME_convert )
1894 assign(class, convert_method, DEFAULT);
1895 }
1896
1897 succeed;
1898 }
1899
1900
1901 Int
getNoCreatedClass(Class class,BoolObj subtoo)1902 getNoCreatedClass(Class class, BoolObj subtoo)
1903 { Cell cell;
1904 Int rval = class->no_created;
1905
1906 if ( notNil(class->sub_classes) && subtoo == ON )
1907 for_cell(cell, class->sub_classes)
1908 rval = add(rval, getNoCreatedClass(cell->value, subtoo));
1909
1910 answer(rval);
1911 }
1912
1913
1914 Int
getNoFreedClass(Class class,BoolObj subtoo)1915 getNoFreedClass(Class class, BoolObj subtoo)
1916 { Cell cell;
1917 Int rval = class->no_freed;
1918
1919 if ( notNil(class->sub_classes) && subtoo == ON )
1920 for_cell(cell, class->sub_classes)
1921 rval = add(rval, getNoFreedClass(cell->value, subtoo));
1922
1923 answer(rval);
1924 }
1925
1926
1927 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1928 KEEP TRACK OF INSTANCES
1929 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1930
1931 status
createdClass(Class class,Any instance,Name how)1932 createdClass(Class class, Any instance, Name how)
1933 { incrInt(class->no_created);
1934 clearCreatingObj(instance);
1935
1936 if ( notNil(class->created_messages) )
1937 { Cell cell;
1938
1939 addCodeReference(instance); /* avoid drop-out */
1940 for_cell(cell, class->created_messages)
1941 forwardCode(cell->value, class->name, instance, how, EAV);
1942 delCodeReference(instance);
1943 }
1944
1945 if ( notNil(class->instances) )
1946 appendHashTable(class->instances, instance, ON);
1947
1948 succeed;
1949 }
1950
1951
1952 status
freedClass(Class class,Any instance)1953 freedClass(Class class, Any instance)
1954 { clearFlag(instance, F_INSPECT);
1955
1956 incrInt(class->no_freed);
1957 if ( notNil(class->freed_messages) )
1958 { Cell cell;
1959
1960 addCodeReference(instance); /* avoid looping */
1961 for_cell(cell, class->freed_messages)
1962 forwardCode(cell->value, class->name, instance, EAV);
1963 if ( !isFreedObj(instance) )
1964 delCodeReference(instance);
1965 }
1966
1967 if ( notNil(class->instances) )
1968 deleteHashTable(class->instances, instance);
1969
1970 succeed;
1971 }
1972
1973
1974 static status
recordInstancesClass(Class class,BoolObj keep,BoolObj recursive)1975 recordInstancesClass(Class class, BoolObj keep, BoolObj recursive)
1976 { realiseClass(class);
1977
1978 if ( keep != OFF && isNil(class->instances) )
1979 assign(class, instances, createHashTable(toInt(16), NAME_none));
1980 else if ( keep == OFF && notNil(class->instances) )
1981 assign(class, instances, NIL);
1982
1983 if ( recursive != OFF && notNil(class->sub_classes) )
1984 { Cell cell;
1985
1986 for_cell(cell, class->sub_classes)
1987 recordInstancesClass(cell->value, keep, recursive);
1988 }
1989
1990 succeed;
1991 }
1992
1993
1994 static status
changedMessageClass(Class class,Code msg)1995 changedMessageClass(Class class, Code msg)
1996 { realiseClass(class);
1997
1998 if ( isNil(class->changed_messages) )
1999 { assign(class, changed_messages, newObject(ClassChain, msg, EAV));
2000 succeed;
2001 }
2002
2003 return addChain(class->changed_messages, msg);
2004 }
2005
2006
2007 static status
createdMessageClass(Class class,Code msg)2008 createdMessageClass(Class class, Code msg)
2009 { realiseClass(class);
2010
2011 if ( isNil(class->created_messages) )
2012 { assign(class, created_messages, newObject(ClassChain, msg, EAV));
2013 succeed;
2014 }
2015
2016 return addChain(class->created_messages, msg);
2017 }
2018
2019
2020 static status
freedMessageClass(Class class,Code msg)2021 freedMessageClass(Class class, Code msg)
2022 { realiseClass(class);
2023
2024 if ( isNil(class->freed_messages) )
2025 { assign(class, freed_messages, newObject(ClassChain, msg, EAV));
2026 succeed;
2027 }
2028
2029 return addChain(class->freed_messages, msg);
2030 }
2031
2032
2033 static Name
getSuperClassNameClass(Class cl)2034 getSuperClassNameClass(Class cl)
2035 { if ( notNil(cl->super_class) )
2036 answer(cl->super_class->name);
2037
2038 fail;
2039 }
2040
2041 #ifndef O_RUNTIME
2042
2043 /********************************
2044 * MANUAL SUPPORT *
2045 ********************************/
2046
2047 static Name
getManIdClass(Class class)2048 getManIdClass(Class class)
2049 { static Name cdot = NULL;
2050
2051 if ( !cdot )
2052 cdot = CtoName("C.");
2053
2054 answer(getAppendName(cdot, class->name));
2055 }
2056
2057
2058 static Name
getManIndicatorClass(Class class)2059 getManIndicatorClass(Class class)
2060 { answer(CtoName("C"));
2061 }
2062
2063
2064 static status
append_class_header(Class cl,TextBuffer tb)2065 append_class_header(Class cl, TextBuffer tb)
2066 { appendTextBuffer(tb, (CharArray)cl->name, ONE);
2067 CAppendTextBuffer(tb, "(");
2068
2069 if ( isNil(cl->term_names) )
2070 { CAppendTextBuffer(tb, "...object...");
2071 } else
2072 { int i;
2073
2074 for(i=1; i<=valInt(cl->term_names->size); i++)
2075 { if ( i != 1 )
2076 CAppendTextBuffer(tb, ", ");
2077 appendTextBuffer(tb, getElementVector(cl->term_names, toInt(i)), ONE);
2078 }
2079 }
2080 CAppendTextBuffer(tb, ")");
2081
2082 succeed;
2083 }
2084
2085
2086 static StringObj
getManHeaderClass(Class cl)2087 getManHeaderClass(Class cl)
2088 { TextBuffer tb;
2089 StringObj str;
2090
2091 realiseClass(cl);
2092
2093 tb = newObject(ClassTextBuffer, EAV);
2094 tb->undo_buffer_size = ZERO;
2095
2096 append_class_header(cl, tb);
2097
2098 str = getContentsTextBuffer(tb, ZERO, DEFAULT);
2099 doneObject(tb);
2100
2101 answer(str);
2102 }
2103
2104
2105 static StringObj
getManSummaryClass(Class cl)2106 getManSummaryClass(Class cl)
2107 { TextBuffer tb;
2108 StringObj str;
2109
2110 realiseClass(cl);
2111
2112 tb = newObject(ClassTextBuffer, EAV);
2113 tb->undo_buffer_size = ZERO;
2114
2115 CAppendTextBuffer(tb, "C\t");
2116 append_class_header(cl, tb);
2117
2118 if ( notNil(cl->summary) )
2119 { CAppendTextBuffer(tb, "\t");
2120 appendTextBuffer(tb, (CharArray)cl->summary, ONE);
2121 }
2122 if ( send(cl, NAME_hasHelp, EAV) )
2123 CAppendTextBuffer(tb, " (+)");
2124
2125 str = getContentsTextBuffer(tb, ZERO, DEFAULT);
2126 doneObject(tb);
2127
2128 answer(str);
2129 }
2130 #endif /*O_RUNTIME*/
2131
2132
2133 status
isAClass(Class class,Class super)2134 isAClass(Class class, Class super)
2135 { return class->tree_index >= super->tree_index &&
2136 class->tree_index < super->neighbour_index;
2137 }
2138
2139
2140 int
numberTreeClass(Class class,int n)2141 numberTreeClass(Class class, int n)
2142 { Cell cell;
2143
2144 DEBUG(NAME_class, Cprintf("numberTreeClass(%s, %d)\n", pp(class->name), n));
2145 class->tree_index = n++;
2146 if ( notNil(class->sub_classes) )
2147 { for_cell(cell, class->sub_classes )
2148 { if ( instanceOfObject(cell->value, ClassClass) ) /* stubs ... */
2149 n = numberTreeClass(cell->value, n);
2150 }
2151 }
2152 class->neighbour_index = n;
2153
2154 return n;
2155 }
2156
2157
2158 /*******************************
2159 * FEATURE ITF *
2160 *******************************/
2161
2162 status
featureClass(Class class,Name name,Any value)2163 featureClass(Class class, Name name, Any value)
2164 { realiseClass(class);
2165
2166 if ( isDefault(value) )
2167 value = ON;
2168
2169 if ( isNil(class->features) )
2170 assign(class, features, newObject(ClassSheet, EAV));
2171
2172 return valueSheet(class->features, name, value);
2173 }
2174
2175
2176 static status
hasFeatureClass(Class class,Name name,Any value)2177 hasFeatureClass(Class class, Name name, Any value)
2178 { realiseClass(class);
2179
2180 if ( notNil(class->features) )
2181 { Any fval;
2182 if ( (fval = getValueSheet(class->features, name)) &&
2183 (isDefault(value) || value == fval) )
2184 succeed;
2185 }
2186
2187 fail;
2188 }
2189
2190
2191 Any
getFeatureClass(Class class,Name name)2192 getFeatureClass(Class class, Name name)
2193 { realiseClass(class);
2194
2195 if ( notNil(class->features) )
2196 return getValueSheet(class->features, name);
2197
2198 fail;
2199 }
2200
2201
2202 /*******************************
2203 * LAZY METHOD BINDING *
2204 *******************************/
2205
2206 static BoolObj
getLazyBindingClass(Class class,Name which)2207 getLazyBindingClass(Class class, Name which)
2208 { unsigned long mask = (which == NAME_send ? DC_LAZY_SEND : DC_LAZY_GET);
2209
2210 answer(onDFlag(class, mask) ? ON : OFF);
2211 }
2212
2213
2214 static status
lazyBindingClass(Class class,Name which,BoolObj val)2215 lazyBindingClass(Class class, Name which, BoolObj val)
2216 { unsigned long mask = (which == NAME_send ? DC_LAZY_SEND : DC_LAZY_GET);
2217
2218 DEBUG(NAME_lazyBinding,
2219 Cprintf("lazyBindingClass(%s, %s, %s)\n",
2220 pp(class), pp(which), pp(val)));
2221
2222 if ( val == ON )
2223 setDFlag(class, mask);
2224 else
2225 { if ( onDFlag(class, mask ) )
2226 { bindMethod(class, which, DEFAULT);
2227 clearDFlag(class, mask);
2228 }
2229 }
2230
2231 succeed;
2232 }
2233
2234
2235 Chain
getSendMethodsClass(Class class)2236 getSendMethodsClass(Class class)
2237 { realiseClass(class);
2238 lazyBindingClass(class, NAME_send, OFF);
2239
2240 answer(class->send_methods);
2241 }
2242
2243
2244 static Chain
getGetMethodsClass(Class class)2245 getGetMethodsClass(Class class)
2246 { realiseClass(class);
2247 lazyBindingClass(class, NAME_get, OFF);
2248
2249 answer(class->get_methods);
2250 }
2251
2252
2253 static Chain
getSubClassesClass(Class class)2254 getSubClassesClass(Class class)
2255 { if ( notNil(class->sub_classes) )
2256 answer(class->sub_classes);
2257
2258 fail;
2259 }
2260
2261
2262
2263 status
makeClassClass(Class class)2264 makeClassClass(Class class)
2265 { sourceClass(class, makeClassClass, __FILE__, "$Revision$");
2266
2267 localClass(class, NAME_name, NAME_name, "name", NAME_get,
2268 "Name of the class");
2269 localClass(class, NAME_summary, NAME_manual, "string*", NAME_both,
2270 "Summary documentation for class");
2271 localClass(class, NAME_creator, NAME_manual, "{built_in,host,C++}", NAME_get,
2272 "Who created the class");
2273 localClass(class, NAME_superClass, NAME_type, "class*", NAME_get,
2274 "Immediate super class");
2275 localClass(class, NAME_subClasses, NAME_type, "chain*", NAME_none,
2276 "Sub classes");
2277 localClass(class, NAME_instanceVariables, NAME_behaviour, "vector", NAME_get,
2278 "Vector object holding all instance variables");
2279 localClass(class, NAME_sendMethods, NAME_behaviour, "chain", NAME_none,
2280 "Send methods not inherited");
2281 localClass(class, NAME_getMethods, NAME_behaviour, "chain", NAME_none,
2282 "Get methods not inherited");
2283 localClass(class, NAME_termNames, NAME_term, "vector*", NAME_both,
2284 "Selectors to obtain term arguments");
2285 localClass(class, NAME_delegate, NAME_behaviour, "chain", NAME_get,
2286 "Instance variables for delegation");
2287 localClass(class, NAME_classVariables, NAME_default, "chain", NAME_get,
2288 "User setable class-variables");
2289 localClass(class, NAME_cloneStyle, NAME_copy,
2290 "{recursive,none,relation}", NAME_both,
2291 "How to clone instances");
2292 localClass(class, NAME_saveStyle, NAME_file,
2293 "{normal,external,nil}",NAME_both,
2294 "How to save instances to file");
2295 localClass(class, NAME_features, NAME_version, "sheet*", NAME_none,
2296 "Defined features on this class");
2297 localClass(class, NAME_noCreated, NAME_statistics, "int", NAME_none,
2298 "Number of instances created");
2299 localClass(class, NAME_noFreed, NAME_statistics, "int", NAME_none,
2300 "Number of instances freed");
2301 localClass(class, NAME_solid, NAME_repaint, "bool", NAME_none,
2302 "Graphicals: image affects ALL pixels");
2303 localClass(class, NAME_selectionStyle, NAME_selection,
2304 "{none,invert,corner_handles,side_handles,corner_and_side_handles,line_handles,path_handles}*",
2305 NAME_both,
2306 "Graphicals: visual feedback of selected");
2307 localClass(class, NAME_handles, NAME_relation, "chain*", NAME_both,
2308 "Graphicals: connection points for links");
2309 localClass(class, NAME_instanceSize, NAME_oms, "int", NAME_get,
2310 "Size of an instance in bytes");
2311 localClass(class, NAME_slots, NAME_oms, "int", NAME_get,
2312 "Total number of instance variables");
2313 localClass(class, NAME_source, NAME_manual, "source_location*", NAME_both,
2314 "Location in the sources");
2315 localClass(class, NAME_rcsRevision, NAME_version, "name*", NAME_get,
2316 "RCS revision of sourcefile");
2317 localClass(class, NAME_changedMessages, NAME_change, "chain*", NAME_both,
2318 "Report (forward) changes to instances");
2319 localClass(class, NAME_createdMessages, NAME_change, "chain*", NAME_both,
2320 "Report (forward) created instances");
2321 localClass(class, NAME_freedMessages, NAME_change, "chain*", NAME_both,
2322 "Report (forward) freed instances");
2323 localClass(class, NAME_unAnswer, NAME_oms, "bool", NAME_both,
2324 "Incremental garbage collection hint");
2325
2326 localClass(class, NAME_makeClassMethod, NAME_realise, "code*", NAME_get,
2327 "Code object to ->realise the class");
2328
2329 localClass(class, NAME_initialiseMethod, NAME_cache, "[send_method]",
2330 NAME_none,
2331 "Used to initialise a new instance");
2332 localClass(class, NAME_sendCatchAll, NAME_cache, "[send_method]*", NAME_none,
2333 "Handle not-yet-handled send messages");
2334 localClass(class, NAME_getCatchAll, NAME_cache, "[get_method]*", NAME_none,
2335 "Handle not-yet-handled get messages");
2336 localClass(class, NAME_convertMethod, NAME_cache, "[get_method]*", NAME_none,
2337 "Type conversion");
2338 localClass(class, NAME_lookupMethod, NAME_cache, "[get_method]*", NAME_none,
2339 "Type conversion");
2340
2341 localClass(class, NAME_resolveMethodMessage, NAME_cache,
2342 "[code|c_pointer]*",NAME_both,
2343 "Hook for lazy attachment of methods");
2344
2345 localClass(class, NAME_sendTable, NAME_cache, "hash_table", NAME_get,
2346 "Hash table for all send methods");
2347 localClass(class, NAME_getTable, NAME_cache, "hash_table", NAME_get,
2348 "Hash table for all get methods");
2349 localClass(class, NAME_localTable, NAME_cache, "hash_table", NAME_get,
2350 "Hash table for all instance variables");
2351 localClass(class, NAME_classVariableTable, NAME_cache, "hash_table*",
2352 NAME_get,
2353 "Hash table for all class-variables");
2354
2355 localClass(class, NAME_instances, NAME_debugging, "hash_table*", NAME_get,
2356 "Hash table holding existing instances");
2357 localClass(class, NAME_realised, NAME_realise, "bool", NAME_get,
2358 "@on if class is realised");
2359 localClass(class, NAME_initVariables, NAME_cache, "{static,value,function}", NAME_get,
2360 "How variables must be initialised");
2361
2362 localClass(class, NAME_proto, NAME_cache, "alien:InstanceProto", NAME_none,
2363 "Prototype instance + info for fast creation");
2364 localClass(class, NAME_treeIndex, NAME_cache, "alien:int", NAME_none,
2365 "Index in depth-first numbering of hierarchy");
2366 localClass(class, NAME_neighbourIndex, NAME_cache, "alien:int", NAME_none,
2367 "Index of neighbour in hierarchy");
2368 localClass(class, NAME_getFunction, NAME_internal, "alien:GetFunc", NAME_none,
2369 "Execute function-objects");
2370 localClass(class, NAME_sendFunction, NAME_internal,
2371 "alien:SendFunc", NAME_none,
2372 "Execute code-objects");
2373 localClass(class, NAME_saveFunction, NAME_internal,
2374 "alien:SendFunc", NAME_none,
2375 "C-function to save alien data");
2376 localClass(class, NAME_loadFunction, NAME_internal,
2377 "alien:SendFunc", NAME_none,
2378 "C-function to reload alien data");
2379 localClass(class, NAME_cloneFunction, NAME_internal,
2380 "alien:SendFunc", NAME_none,
2381 "C function to clone alien data");
2382 localClass(class, NAME_redrawFunction, NAME_internal,
2383 "alien:SendFunc", NAME_none,
2384 "C function to repaint graphicals");
2385 localClass(class, NAME_changedFunction, NAME_internal,
2386 "alien:SendFunc", NAME_none,
2387 "C function to trap slot changes");
2388 localClass(class, NAME_inEventArea, NAME_internal,
2389 "alien:SendFunc", NAME_none,
2390 "Graphicals: test if event in area");
2391 localClass(class, NAME_makeClassFunction, NAME_internal,
2392 "alien:VoidFunc", NAME_none,
2393 "C-function that created the class");
2394 localClass(class, NAME_boot, NAME_internal,
2395 "alien:int", NAME_none,
2396 "#PCE slots when booting; 0 otherwise");
2397 localClass(class, NAME_cDeclarations, NAME_internal,
2398 "alien:classdecl*", NAME_none,
2399 "Description left by C-compiler");
2400
2401 termClass(class, "class", 2, NAME_name, NAME_superClassName);
2402 saveStyleClass(class, NAME_external);
2403 cloneStyleClass(class, NAME_none);
2404
2405 fetchMethod(class, NAME_sendMethods, getSendMethodsClass);
2406 fetchMethod(class, NAME_getMethods, getGetMethodsClass);
2407
2408 sendMethod(class, NAME_initialise, DEFAULT, 2, "name=name", "super=[class]*",
2409 "Create from name and super class",
2410 initialiseClass);
2411 sendMethod(class, NAME_unlink, DEFAULT, 0,
2412 "Remove from tables",
2413 unlinkClass);
2414 sendMethod(class, NAME_changedMessage, NAME_change, 1, "code",
2415 "Add message to trap changed slots",
2416 changedMessageClass);
2417 sendMethod(class, NAME_createdMessage, NAME_change, 1, "code",
2418 "Add message to trap created instances",
2419 createdMessageClass);
2420 sendMethod(class, NAME_freedMessage, NAME_change, 1, "code",
2421 "Add message to trap freed instances",
2422 freedMessageClass);
2423 sendMethod(class, NAME_recordInstances, NAME_debugging, 2,
2424 "record=[bool]", "recursive=[bool]",
2425 "Maintain <-instances table",
2426 recordInstancesClass);
2427 sendMethod(class, NAME_sendMethod, NAME_behaviour, 1, "send_method",
2428 "Add/redefine send method",
2429 sendMethodClass);
2430 sendMethod(class, NAME_getMethod, NAME_behaviour, 1, "get_method",
2431 "Add/redefine get method",
2432 getMethodClass);
2433 sendMethod(class, NAME_instanceVariable, NAME_behaviour, 1, "variable",
2434 "Add/redefine instance variable",
2435 instanceVariableClass);
2436 sendMethod(class, NAME_isA, NAME_type, 1, "class",
2437 "Test if I'm a subclass of argument",
2438 isAClass);
2439 sendMethod(class, NAME_handle, NAME_relation, 1, "handle",
2440 "Add handle for graphical instances",
2441 handleClass);
2442 sendMethod(class, NAME_cloneStyleVariable, NAME_copy, 2,
2443 "variable=name|int",
2444 "style={recursive,reference,reference_chain,value,alien,nil}",
2445 "Set <->clone_style of named variable",
2446 cloneStyleVariableClass);
2447 sendMethod(class, NAME_saveStyleVariable, NAME_file, 2,
2448 "variable=name|int", "style={normal,nil}",
2449 "Set the save style for named variable",
2450 saveStyleVariableClass);
2451 sendMethod(class, NAME_delegate, NAME_behaviour, 1,
2452 "variable=name|int",
2453 "Add instance-variable for delegation",
2454 delegateClass);
2455 sendMethod(class, NAME_prependDelegate, NAME_behaviour, 1,
2456 "variable=name|int",
2457 "Add instance-variable for delegation (as first)",
2458 prependDelegateClass);
2459 sendMethod(class, NAME_realise, NAME_realise, 0,
2460 "Declare methods/variables, etc.",
2461 realiseClass);
2462 sendMethod(class, NAME_install, NAME_behaviour, 0,
2463 "Prepare class for creating instances",
2464 installClass);
2465 sendMethod(class, NAME_clearCache, NAME_cache, 0,
2466 "Clear method resolution cache",
2467 clearCacheClass);
2468 sendMethod(class, NAME_deleteSendMethod, NAME_cache, 1, "name",
2469 "Delete a send-method",
2470 deleteSendMethodClass);
2471 sendMethod(class, NAME_deleteGetMethod, NAME_cache, 1, "name",
2472 "Delete a get-method",
2473 deleteGetMethodClass);
2474 sendMethod(class, NAME_feature, NAME_version, 2,
2475 "feature=name", "value=[any]",
2476 "Register class feature",
2477 featureClass);
2478 sendMethod(class, NAME_hasFeature, NAME_version, 2,
2479 "feature=name", "value=[any]",
2480 "Test if class has feature",
2481 hasFeatureClass);
2482 #ifdef O_RUNTIME
2483 sendMethod(class, NAME_source, NAME_runtime, 1, "source_location*",
2484 "Dummy method",
2485 rtSourceClass);
2486 #endif
2487 sendMethod(class, NAME_boundSendMethod, NAME_cache, 1, "name",
2488 "Test if class defines send_method `name'",
2489 boundSendMethodClass);
2490 sendMethod(class, NAME_boundGetMethod, NAME_cache, 1, "name",
2491 "Test if class defines get_method `name'",
2492 boundGetMethodClass);
2493 sendMethod(class, NAME_lazyBinding, NAME_cache, 2, "{send,get}", "bool",
2494 "Determines when messages are bound",
2495 lazyBindingClass);
2496
2497 getMethod(class, NAME_subClass, NAME_oms, "class", 1, "name",
2498 "Create a class below this one (or return existing)",
2499 getSubClassClass);
2500 getMethod(class, NAME_instance, NAME_oms, "object", 1,
2501 "argument=unchecked ...",
2502 "Create instance of the class from argument",
2503 getInstanceClassv);
2504 getMethod(class, NAME_instanceVariable, NAME_meta, "variable", 1, "name|int",
2505 "Get instance variable from name of offset",
2506 getInstanceVariableClass);
2507 #ifndef O_RUNTIME
2508 getMethod(class, NAME_manId, NAME_manual, "name", 0,
2509 "Identifier for the manual (C.<name>)",
2510 getManIdClass),
2511 getMethod(class, NAME_manIndicator, NAME_manual, "name", 0,
2512 "Indicator for the manual (C)",
2513 getManIndicatorClass),
2514 getMethod(class, NAME_manHeader, NAME_manual, "string", 0,
2515 "New string with with term description",
2516 getManHeaderClass);
2517 getMethod(class, NAME_manSummary, NAME_manual, "string", 0,
2518 "New string with header and summary",
2519 getManSummaryClass);
2520 #endif
2521 getMethod(class, NAME_getMethod, NAME_meta, "behaviour", 1, "name",
2522 "Method implementing named get behaviour",
2523 getGetMethodClass);
2524 getMethod(class, NAME_sendMethod, NAME_meta, "behaviour", 1, "name",
2525 "Method implementing named get behaviour",
2526 getSendMethodClass);
2527 getMethod(class, NAME_superClassName, NAME_type, "name", 0,
2528 "Name of super-class or @nil (term description",
2529 getSuperClassNameClass);
2530 getMethod(class, NAME_subClasses, NAME_type, "chain", 0,
2531 "Chain holding sub-classes of this class",
2532 getSubClassesClass);
2533 getMethod(class, NAME_convert, DEFAULT, "class", 1, "any",
2534 "Convert class name",
2535 getConvertClass);
2536 getMethod(class, NAME_lookup, NAME_oms, "class", 2,
2537 "name=name", "super=[class]",
2538 "Lookup in @classes and verify super",
2539 getLookupClass);
2540 getMethod(class, NAME_feature, NAME_version, "any", 1, "feature=name",
2541 "Get value of given feature",
2542 getFeatureClass);
2543 getMethod(class, NAME_lazyBinding, NAME_cache, "bool", 1, "{send,get}",
2544 "@on if methods are bound lazy",
2545 getLazyBindingClass);
2546 getMethod(class, NAME_noCreated, NAME_statistics, "int", 1, "sub_too=[bool]",
2547 "How many instances were created",
2548 getNoCreatedClass);
2549 getMethod(class, NAME_noFreed, NAME_statistics, "int", 1, "sub_too=[bool]",
2550 "How many instances were freed",
2551 getNoFreedClass);
2552
2553
2554 /*******************************
2555 * RESOURCE FUNCTIONS *
2556 *******************************/
2557
2558 sendMethod(class, NAME_classVariableValue, NAME_default, 2, "name", "any",
2559 "Set value of named class variable",
2560 classVariableValueClass);
2561 getMethod(class, NAME_classVariable, NAME_default,
2562 "class_variable", 1, "name",
2563 "Associated class variable from name",
2564 getClassVariableClass);
2565
2566 succeed;
2567 }
2568
2569