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/trace.h>
37 #include <h/text.h>
38
39 static status initialiseVariable(Variable var, Name name, Type type,
40 Name access, StringObj doc, Name group,
41 Any initial);
42 static status typeVariable(Variable var, Type type);
43
44 Variable
createVariable(Name name,Type type,Name access)45 createVariable(Name name, Type type, Name access)
46 { Variable var;
47
48 var = alloc(sizeof(struct variable));
49 initHeaderObj(var, ClassObjOfVariable);
50 var->name = var->access = (Name) NIL;
51 var->group = NIL;
52 var->offset = (Int) NIL;
53 var->type = (Type) NIL;
54 var->dflags = (uintptr_t) ZERO;
55 var->context = NIL;
56 var->summary = NIL;
57 var->init_function = NIL;
58 var->alloc_value = NIL;
59
60 TRY(initialiseVariable(var, name, type, access, DEFAULT, DEFAULT, DEFAULT));
61 createdObject(var, NAME_new);
62
63 return var;
64 }
65
66
67 static status
initialiseVariable(Variable var,Name name,Type type,Name access,StringObj doc,Name group,Any initial)68 initialiseVariable(Variable var, Name name, Type type, Name access,
69 StringObj doc, Name group, Any initial)
70 { initialiseBehaviour((Behaviour) var, name, NIL);
71
72 if ( isDefault(type) ) type = TypeAny;
73 if ( isDefault(access) ) access = NAME_both;
74 if ( isDefault(doc) ) doc = NIL;
75
76 assign(var, group, group);
77 assign(var, access, access);
78 assign(var, offset, ZERO);
79 assign(var, summary, doc);
80
81 var->alloc_value = NIL;
82 typeVariable(var, type);
83 if ( notDefault(initial) )
84 initialValueVariable(var, initial);
85 else
86 { if ( !includesType(type, TypeNil) &&
87 includesType(type, TypeDefault) )
88 initialValueVariable(var, DEFAULT);
89 }
90
91 succeed;
92 }
93
94
95 static status
typeVariable(Variable var,Type type)96 typeVariable(Variable var, Type type)
97 { assign(var, type, type);
98 clearDFlag(var, D_CLONE|D_SAVE);
99
100 if ( type->kind == NAME_alien )
101 { setDFlag(var, D_CLONE_ALIEN|D_ALIEN);
102 var->alloc_value = NULL;
103 } else
104 { setDFlag(var, D_SAVE_NORMAL);
105 setDFlag(var, D_CLONE_RECURSIVE);
106 }
107
108 succeed;
109 }
110
111
112 status
cloneStyleVariable(Variable var,Name style)113 cloneStyleVariable(Variable var, Name style)
114 { clearDFlag(var, D_CLONE);
115
116 if ( style == NAME_recursive )
117 setDFlag(var, D_CLONE_RECURSIVE);
118 else if ( style == NAME_reference )
119 setDFlag(var, D_CLONE_REFERENCE);
120 else if ( style == NAME_value )
121 setDFlag(var, D_CLONE_VALUE);
122 else if ( style == NAME_alien )
123 setDFlag(var, D_CLONE_ALIEN);
124 else if ( style == NAME_nil )
125 setDFlag(var, D_CLONE_NIL);
126 else if ( style == NAME_referenceChain )
127 setDFlag(var, D_CLONE_REFCHAIN);
128 else
129 fail;
130
131 succeed;
132 }
133
134
135 status
saveStyleVariable(Variable var,Name style)136 saveStyleVariable(Variable var, Name style)
137 { clearDFlag(var, D_SAVE);
138
139 if ( style == NAME_normal )
140 setDFlag(var, D_SAVE_NORMAL);
141 else if ( style == NAME_nil )
142 setDFlag(var, D_SAVE_NIL);
143 else
144 fail;
145
146 succeed;
147 }
148
149
150 static Name
getCloneStyleVariable(Variable var)151 getCloneStyleVariable(Variable var)
152 { if ( onDFlag(var, D_CLONE_RECURSIVE) )
153 answer(NAME_recursive);
154 if ( onDFlag(var, D_CLONE_REFERENCE) )
155 answer(NAME_reference);
156 if ( onDFlag(var, D_CLONE_REFCHAIN) )
157 answer(NAME_referenceChain);
158 if ( onDFlag(var, D_CLONE_VALUE) )
159 answer(NAME_value);
160 if ( onDFlag(var, D_CLONE_ALIEN) )
161 answer(NAME_alien);
162 if ( onDFlag(var, D_CLONE_NIL) )
163 answer(NAME_nil);
164
165 fail;
166 }
167
168
169 static Name
getSaveStyleVariable(Variable var)170 getSaveStyleVariable(Variable var)
171 { if ( onDFlag(var, D_SAVE_NORMAL) )
172 answer(NAME_normal);
173 if ( onDFlag(var, D_SAVE_NIL) )
174 answer(NAME_nil);
175
176 fail;
177 }
178
179
180 status
sendAccessVariable(Variable var)181 sendAccessVariable(Variable var)
182 { if ( var->access == NAME_both || var->access == NAME_send )
183 succeed;
184 fail;
185 }
186
187
188 status
getAccessVariable(Variable var)189 getAccessVariable(Variable var)
190 { if ( var->access == NAME_both || var->access == NAME_get )
191 succeed;
192 fail;
193 }
194
195
196 static Type
getArgumentTypeVariable(Variable var,Int n)197 getArgumentTypeVariable(Variable var, Int n)
198 { if ( sendAccessVariable(var) && (isDefault(n) || n == ONE) )
199 answer(var->type);
200
201 fail;
202 }
203
204
205 static Type
getReturnTypeVariable(Variable var)206 getReturnTypeVariable(Variable var)
207 { if ( getAccessVariable(var) )
208 answer(var->type);
209
210 fail;
211 }
212
213 /*******************************
214 * INITIAL VALUE *
215 *******************************/
216
217 static status
allocValueVariable(Variable var,Any value)218 allocValueVariable(Variable var, Any value)
219 { Any old = var->alloc_value;
220
221 var->alloc_value = value;
222 if ( isObject(value) && !isProtectedObj(value) )
223 addRefObject(var, value);
224 if ( isObject(old) && !isProtectedObj(old) )
225 delRefObject(var, old);
226
227 succeed;
228 }
229
230
231 static Any
getAllocValueVariable(Variable var)232 getAllocValueVariable(Variable var)
233 { answer(var->alloc_value); /* alien = NULL --> fail */
234 }
235
236
237 static status
initFunctionVariable(Variable var,Any f)238 initFunctionVariable(Variable var, Any f)
239 { assign(var, init_function, f);
240
241 if ( instanceOfObject(var->context, ClassClass) )
242 unallocInstanceProtoClass(var->context);
243
244 succeed;
245 }
246
247
248 static int
is_shareable(Any value)249 is_shareable(Any value)
250 { if ( instanceOfObject(value, ClassConstant) ||
251 instanceOfObject(value, ClassName) ||
252 isInteger(value) )
253 succeed;
254
255 fail;
256 }
257
258
259 status
initialValueVariable(Variable var,Any value)260 initialValueVariable(Variable var, Any value)
261 { if ( is_shareable(value) )
262 { Any val = checkType(value, var->type, NIL);
263
264 if ( !val )
265 return errorPce(value, NAME_unexpectedType, var->type);
266
267 if ( val == value || is_shareable(val) ) /* still the case? */
268 { allocValueVariable(var, val);
269 initFunctionVariable(var, NIL);
270
271 succeed;
272 } else
273 value = val;
274 }
275
276 allocValueVariable(var, NIL);
277 initFunctionVariable(var, value);
278
279 succeed;
280 }
281
282
283 /********************************
284 * EXECUTION *
285 ********************************/
286
287 status
sendVariable(Variable var,Any rec,Any val)288 sendVariable(Variable var, Any rec, Any val)
289 { Any value;
290 Any *field = &(((Instance)rec)->slots[valInt(var->offset)]);
291
292 if ( !(value = checkType(val, var->type, rec)) )
293 return errorTypeMismatch(rec, var, 1, var->type, val);
294
295 assignField(rec, field, value);
296
297 succeed;
298 }
299
300
301 Any
getGetVariable(Variable var,Any rec)302 getGetVariable(Variable var, Any rec)
303 { Any *field = &(((Instance)rec)->slots[valInt(var->offset)]);
304 Any rval = *field;
305
306 if ( isClassDefault(rval) )
307 { Any value;
308
309 if ( (value = getClassVariableValueObject(rec, var->name)) )
310 { Any v2;
311
312 if ( (v2 = checkType(value, var->type, rec)) )
313 { assignField(rec, field, v2);
314 answer(v2);
315 } else
316 { errorPce(var, NAME_incompatibleClassVariable, 0);
317 fail;
318 }
319 } else if ( instanceOfObject(rec, ClassClass) &&
320 ((Class)rec)->realised != ON )
321 { realiseClass(rec);
322 rval = *field;
323 } else
324 { errorPce(var, NAME_noClassVariable, 0);
325 fail;
326 }
327 }
328
329 answer(rval);
330 }
331
332
333 Name
getGroupVariable(Variable v)334 getGroupVariable(Variable v)
335 { if ( isDefault(v->group) )
336 { Class class = v->context;
337
338 TRY( instanceOfObject(class, ClassClass) );
339 for( class = class->super_class; notNil(class); class = class->super_class)
340 { Vector vector = class->instance_variables;
341 int n;
342
343 for(n=0; n<valInt(vector->size); n++)
344 { Variable var = vector->elements[n];
345
346 if ( var->name == v->name && notDefault(var->group) )
347 answer(var->group);
348 }
349 }
350
351 fail;
352 }
353
354 answer(v->group);
355 }
356
357 /********************************
358 * MANUAL SUPPORT *
359 ********************************/
360
361 static Name
getAccessArrowVariable(Variable v)362 getAccessArrowVariable(Variable v)
363 { if ( v->access == NAME_none ) return CtoName("-");
364 if ( v->access == NAME_get ) return CtoName("<-");
365 if ( v->access == NAME_send ) return CtoName("->");
366 if ( v->access == NAME_both ) return CtoName("<->");
367
368 fail;
369 }
370
371
372 static Name
getContextNameVariable(Variable v)373 getContextNameVariable(Variable v)
374 { if ( instanceOfObject(v->context, ClassClass) )
375 { Class class = v->context;
376
377 answer(class->name);
378 }
379
380 answer(CtoName("???"));
381 }
382
383
384 #ifndef O_RUNTIME
385 static Name
getManIdVariable(Variable v)386 getManIdVariable(Variable v)
387 { wchar_t buf[LINESIZE];
388 wchar_t *nm, *o;
389 Name ctx = getContextNameVariable(v);
390 size_t len;
391 Name rc;
392
393 len = 4 + ctx->data.s_size + v->name->data.s_size;
394 if ( len < LINESIZE )
395 nm = buf;
396 else
397 nm = pceMalloc(sizeof(wchar_t)*len);
398
399 o = nm;
400 *o++ = 'V';
401 *o++ = '.';
402 wcscpy(o, nameToWC(ctx, &len));
403 o += len;
404 *o++ = '.';
405 wcscpy(o, nameToWC(v->name, &len));
406 o += len;
407
408 rc = WCToName(nm, o-nm);
409 if ( nm != buf )
410 pceFree(nm);
411
412 answer(rc);
413 }
414
415
416 static Name
getManIndicatorVariable(Variable v)417 getManIndicatorVariable(Variable v)
418 { answer(CtoName("V"));
419 }
420
421
422 static StringObj
getManSummaryVariable(Variable v)423 getManSummaryVariable(Variable v)
424 { TextBuffer tb;
425 StringObj str;
426
427 tb = newObject(ClassTextBuffer, EAV);
428 tb->undo_buffer_size = ZERO;
429 CAppendTextBuffer(tb, "V\t");
430
431 if ( instanceOfObject(v->context, ClassClass) )
432 { Class class = v->context;
433
434 appendTextBuffer(tb, (CharArray)class->name, ONE);
435 CAppendTextBuffer(tb, " ");
436 }
437
438 appendTextBuffer(tb, (CharArray)getAccessArrowVariable(v), ONE);
439 appendTextBuffer(tb, (CharArray)v->name, ONE);
440 CAppendTextBuffer(tb, ": ");
441 appendTextBuffer(tb, (CharArray)v->type->fullname, ONE);
442 if ( notNil(v->summary) )
443 { CAppendTextBuffer(tb, "\t");
444 appendTextBuffer(tb, (CharArray)v->summary, ONE);
445 }
446 if ( send(v, NAME_hasHelp, EAV) )
447 CAppendTextBuffer(tb, " (+)");
448
449 str = getContentsTextBuffer(tb, ZERO, DEFAULT);
450 doneObject(tb);
451
452 answer(str);
453 }
454 #endif /*O_RUNTIME*/
455
456
457 static Name
getPrintNameVariable(Variable var)458 getPrintNameVariable(Variable var)
459 { wchar_t buf[LINESIZE];
460 wchar_t *nm, *o;
461 Name ctx = getContextNameVariable(var);
462 size_t len;
463 Name rc;
464
465 len = 5 + ctx->data.s_size + var->name->data.s_size;
466 if ( len < LINESIZE )
467 nm = buf;
468 else
469 nm = pceMalloc(sizeof(wchar_t)*len);
470
471 o = nm;
472 wcscpy(o, nameToWC(ctx, &len)); o += len;
473 *o++ = ' ';
474 wcscpy(o, nameToWC(getAccessArrowVariable(var), &len)); o += len;
475 wcscpy(o, nameToWC(var->name, &len)); o += len;
476
477 rc = WCToName(nm, o-nm);
478 if ( nm != buf )
479 pceFree(nm);
480
481 answer(rc);
482 }
483
484
485 /*******************************
486 * CLASS DECLARATION *
487 *******************************/
488
489 /* Type declaractions */
490
491 static char *T_initialise[] =
492 { "name=name", "type=[type]", "access=[{none,send,get,both}]",
493 "summary=[string]*", "group=[name]",
494 "initial_value=[any|function]" };
495 static char *T_send[] =
496 { "receiver=object", "value=unchecked" };
497
498 /* Instance Variables */
499
500 static vardecl var_variable[] =
501 { IV(NAME_group, "[name]", IV_NONE,
502 NAME_manual, "Conceptual group of variable"),
503 IV(NAME_access, "{none,send,get,both}", IV_GET,
504 NAME_behaviour, "Read/write access"),
505 SV(NAME_type, "type", IV_GET|IV_STORE, typeVariable,
506 NAME_type, "Type check"),
507 IV(NAME_offset, "int", IV_GET,
508 NAME_storage, "Offset in instance structure"),
509 IV(NAME_summary, "string*", IV_BOTH,
510 NAME_manual, "Summary documentation"),
511 SV(NAME_initFunction, "any*", IV_BOTH|IV_STORE, initFunctionVariable,
512 NAME_oms, "Function to initialise the variable"),
513 IV(NAME_allocValue, "alien:void *", IV_BOTH,
514 NAME_oms, "Value used to when allocating")
515 };
516
517 /* Send Methods */
518
519 static senddecl send_variable[] =
520 { SM(NAME_initialise, 6, T_initialise, initialiseVariable,
521 DEFAULT, "Create from name, type, access, doc, group and initial value"),
522 SM(NAME_cloneStyle, 1, "{recursive,reference,reference_chain,value,alien,nil}", cloneStyleVariable,
523 NAME_copy, "Clone-style for this slot"),
524 SM(NAME_send, 2, T_send, sendVariable,
525 NAME_execute, "Invoke (write) variable in object"),
526 SM(NAME_saveStyle, 1, "{normal,nil}", saveStyleVariable,
527 NAME_file, "Slot saved as @nil or its value"),
528 SM(NAME_getAccess, 0, NULL, getAccessVariable,
529 NAME_meta, "Test if variable has read access"),
530 SM(NAME_sendAccess, 0, NULL, sendAccessVariable,
531 NAME_meta, "Test if variable has write access"),
532 SM(NAME_allocValue, 1, "any|function", initialValueVariable,
533 NAME_oms, "Value after allocation when instantiated"),
534 SM(NAME_initialValue, 1, "any|function", initialValueVariable,
535 NAME_oms, "Initial value for this variable")
536 };
537
538 /* Get Methods */
539
540 static getdecl get_variable[] =
541 { GM(NAME_cloneStyle, 0, "name", NULL, getCloneStyleVariable,
542 NAME_copy, "Clone style for this slot"),
543 GM(NAME_get, 1, "unchecked", "object", getGetVariable,
544 NAME_execute, "Invoke (read) variable in object"),
545 GM(NAME_saveStyle, 0, "{normal,nil}", NULL, getSaveStyleVariable,
546 NAME_file, "Save style for this slot"),
547 GM(NAME_accessArrow, 0, "{-,<-,->,<->}", NULL, getAccessArrowVariable,
548 NAME_manual, "Arrow indicating access-rights"),
549 GM(NAME_contextName, 0, "name", NULL, getContextNameVariable,
550 NAME_manual, "Name of context class"),
551 GM(NAME_group, 0, "name", NULL, getGroupVariable,
552 NAME_manual, "(Possible inherited) group-name"),
553 #ifndef O_RUNTIME
554 GM(NAME_manId, 0, "name", NULL, getManIdVariable,
555 NAME_manual, "Card Id for variable"),
556 GM(NAME_manIndicator, 0, "name", NULL, getManIndicatorVariable,
557 NAME_manual, "Manual type indicator (`V')"),
558 GM(NAME_manSummary, 0, "string", NULL, getManSummaryVariable,
559 NAME_manual, "New string with summary"),
560 #endif /*O_RUNTIME*/
561 GM(NAME_argumentType, 1, "type", "index=[int]", getArgumentTypeVariable,
562 NAME_meta, "Type of n-th1 argument if <-access includes `send'"),
563 GM(NAME_returnType, 0, "type", NULL, getReturnTypeVariable,
564 NAME_meta, "Return type if <-access includes `get'"),
565 GM(NAME_allocValue, 0, "unchecked", NULL, getAllocValueVariable,
566 NAME_oms, "Initial value when instantiated"),
567 GM(NAME_printName, 0, "name", NULL, getPrintNameVariable,
568 NAME_textual, "Class <->Name")
569 };
570
571 /* Resources */
572
573 #define rc_variable NULL
574 /*
575 static classvardecl rc_variable[] =
576 {
577 };
578 */
579
580 /* Class Declaration */
581
582 static Name variable_termnames[] = { NAME_name, NAME_type, NAME_access };
583
584 ClassDecl(variable_decls,
585 var_variable, send_variable, get_variable, rc_variable,
586 3, variable_termnames,
587 "$Rev$");
588
589
590 status
makeClassVariable(Class class)591 makeClassVariable(Class class)
592 { declareClass(class, &variable_decls);
593
594 succeed;
595 }
596