1 /* Part of XPCE --- The SWI-Prolog GUI toolkit
2
3 Author: Jan Wielemaker and Anjo Anjewierden
4 E-mail: jan@swi.psy.uva.nl
5 WWW: http://www.swi.psy.uva.nl/projects/xpce/
6 Copyright (c) 1985-2002, University of Amsterdam
7 All rights reserved.
8
9 Redistribution and use in source and binary forms, with or without
10 modification, are permitted provided that the following conditions
11 are met:
12
13 1. Redistributions of source code must retain the above copyright
14 notice, this list of conditions and the following disclaimer.
15
16 2. Redistributions in binary form must reproduce the above copyright
17 notice, this list of conditions and the following disclaimer in
18 the documentation and/or other materials provided with the
19 distribution.
20
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32 POSSIBILITY OF SUCH DAMAGE.
33 */
34
35 #define INLINE_UTILITIES 1
36 #include <h/kernel.h>
37 #include <h/trace.h>
38 #include <h/graphics.h>
39 #include <math.h>
40 #include <wctype.h>
41
42 #define MAX_TYPE_TRANSLATE_NESTING 10
43
44 static status kindType(Type t, Name kind);
45
46 #define TV_CLASS 0
47 #define TV_OBJECT 1
48 #define TV_INT 2
49 #define TV_ARG 3
50 #define TV_VALUE 4
51 #define TV_VALUESET 5
52 #define TV_UNCHECKED 6
53 #define TV_ANY 7
54 #define TV_ALIEN 8
55 #define TV_NAMEOF 9
56 #define TV_INTRANGE 10
57 #define TV_REALRANGE 11
58 #define TV_MEMBER 12
59 #define TV_COMPOUND 13
60 #define TV_ALIAS 14
61 #define TV_CHAR 15
62 #define TV_EVENTID 16
63 #define TV_ATOMIC 17
64
65 status
initialiseType(Type t,Name name,Name kind,Any context,Chain supers)66 initialiseType(Type t, Name name, Name kind, Any context, Chain supers)
67 { assign(t, fullname, name);
68 assign(t, argument_name, NIL); /* default is typename */
69
70 if ( getMemberHashTable(TypeTable, name) )
71 return errorPce(t, NAME_nameAlreadyExists, name);
72
73 initialiseProgramObject(t);
74
75 if ( isDefault(supers) )
76 supers = NIL;
77 if ( isDefault(context) )
78 context = NIL;
79
80 assign(t, context, context);
81 assign(t, supers, supers);
82 assign(t, vector, OFF);
83 TRY(kindType(t, kind));
84
85 appendHashTable(TypeTable, name, t);
86 protectObject(t);
87
88 succeed;
89 }
90
91
92 Type
getLookupType(Class class,Name name)93 getLookupType(Class class, Name name)
94 { answer(getMemberHashTable(TypeTable, name));
95 }
96
97
98 static status
storeType(Type t,FileObj file)99 storeType(Type t, FileObj file)
100 { return storeSlotsObject(t, file);
101 }
102
103
104 static status
loadType(Type t,IOSTREAM * fd,ClassDef def)105 loadType(Type t, IOSTREAM *fd, ClassDef def)
106 { TRY(loadSlotsObject(t, fd, def));
107
108 return kindType(t, t->kind);
109 }
110
111
112 static Type
getCopyType(Type t,Name name)113 getCopyType(Type t, Name name)
114 { Type t2 = newObject(ClassType, name,
115 t->kind, t->context,
116 getCopyChain(t->supers),
117 EAV);
118 if ( t2 )
119 assign(t2, vector, t->vector);
120
121 answer(t2);
122 }
123
124
125 Type
createType(Name name,Name kind,Any context)126 createType(Name name, Name kind, Any context)
127 { Type t = alloc(sizeof(struct type));
128
129 initHeaderObj(t, ClassType);
130 lockObj(t);
131 initialiseProgramObject(t);
132
133 t->fullname = name;
134 t->argument_name = name;
135 t->context = NIL;
136 t->supers = NIL;
137 t->vector = OFF;
138 t->kind = (Name) NIL;
139
140 assign(t, context, context);
141 kindType(t, kind);
142
143 appendHashTable(TypeTable, name, t);
144
145 createdObject(t, NAME_new);
146
147 return t;
148 }
149
150
151 static Type
getConvertType(Class class,Name name)152 getConvertType(Class class, Name name)
153 { answer(nameToType(name));
154 }
155
156 /********************************
157 * NAMES *
158 ********************************/
159
160 Name
getNameType(Type t)161 getNameType(Type t)
162 { PceString str = &t->fullname->data;
163
164 if ( str->s_size > 0 && iscsym(str_fetch(str,0)) )
165 { int i;
166
167 for(i=1; i<str->s_size; i++)
168 { if ( iscsym(str_fetch(str, i)) )
169 continue;
170 if ( str_fetch(str, i) == '=' )
171 { answer(getSubName(t->fullname, toInt(i+1), DEFAULT));
172 }
173 }
174 }
175
176 return t->fullname;
177 }
178
179
180 /********************************
181 * CHANGING TYPES *
182 ********************************/
183
184 void
superType(Type t,Type t2)185 superType(Type t, Type t2)
186 { if ( isNil(t->supers) )
187 assign(t, supers, newObject(ClassChain, t2, EAV));
188 else
189 appendChain(t->supers, t2);
190 }
191
192
193 status
vectorType(Type t,BoolObj val)194 vectorType(Type t, BoolObj val)
195 { assign(t, vector, val);
196
197 succeed;
198 }
199
200
201 /********************************
202 * ??? *
203 ********************************/
204
205 status
isClassType(Type t)206 isClassType(Type t)
207 { return t->kind == NAME_class || t->kind == NAME_object;
208 }
209
210 #define SpecialClass(c) ( isAClass(c, ClassFunction) || \
211 isAClass(c, ClassHostData) )
212
213 static inline status
realiseClassType(Type t)214 realiseClassType(Type t)
215 { if ( t->validate_function == TV_CLASS &&
216 onFlag(t->context, F_ISNAME) )
217 { Class class;
218
219 if ( (class=getConvertClass(ClassClass, t->context)) )
220 assign(t, context, class);
221 else
222 fail;
223 }
224
225 succeed;
226 }
227
228
229 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
230 specialisedType()
231
232 t1 is more specialised than t2. E.g
233
234 specialisedType(box, graphical) --> true
235 specialisedType(0..4, int) --> true
236 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
237
238 status
specialisedType(Type t1,Type t2)239 specialisedType(Type t1, Type t2)
240 { while(t1->validate_function == TV_ALIAS )
241 t1 = t1->context;
242 realiseClassType(t1);
243
244 l2:
245 switch(t2->validate_function)
246 { case TV_ALIAS:
247 t2 = t2->context;
248 goto l2;
249 case TV_CLASS:
250 realiseClassType(t2);
251 if ( t1->validate_function == TV_CLASS &&
252 isAClass(t1->context, t2->context) )
253 succeed;
254 break;
255 case TV_OBJECT:
256 if ( t1->validate_function == TV_CLASS && !SpecialClass(t1->context) )
257 succeed;
258 break;
259 case TV_ANY:
260 if ( !(t1->validate_function == TV_CLASS && SpecialClass(t1->context)) )
261 succeed;
262 break;
263 case TV_UNCHECKED:
264 succeed;
265 }
266
267 if ( t1->validate_function == t2->validate_function &&
268 t1->context == t2->context )
269 succeed;
270
271 switch(t1->validate_function)
272 { case TV_NAMEOF:
273 t1 = TypeName;
274 goto l2;
275 case TV_INTRANGE:
276 t1 = TypeInt;
277 goto l2;
278 case TV_REALRANGE:
279 t1 = TypeReal;
280 goto l2;
281 case TV_CHAR:
282 t1 = TypeInt;
283 goto l2;
284 }
285
286 if ( notNil(t2->supers) )
287 { Cell cell;
288
289 for_cell(cell, t2->supers)
290 { if ( specialisedType(t1, cell->value) )
291 succeed;
292 }
293 }
294
295 fail;
296 }
297
298
299 status
equalType(Type t1,Type t2)300 equalType(Type t1, Type t2)
301 { while(t1->kind == NAME_alias)
302 t1 = t1->context;
303 while(t2->kind == NAME_alias)
304 t2 = t2->context;
305
306 if ( t1 == t2 )
307 succeed;
308
309 fail;
310 }
311
312
313
314 status
includesType(Type t1,Type t2)315 includesType(Type t1, Type t2) /* t1 includes t2 */
316 { while(t1->kind == NAME_alias)
317 t1 = t1->context;
318 while(t2->kind == NAME_alias)
319 t2 = t2->context;
320
321 if ( t1 == t2 ||
322 (t1->context == t2->context && t1->kind == t2->kind) )
323 succeed;
324
325 if ( notNil(t1->supers) )
326 { Cell cell;
327
328 for_cell(cell, t1->supers)
329 { if ( includesType(cell->value, t2) )
330 succeed;
331 }
332 }
333
334 fail;
335 }
336
337
338 static void
value_set_type(Type t,Any ctx,Chain * set)339 value_set_type(Type t, Any ctx, Chain *set)
340 { Chain ch = *set;
341
342 if ( t->kind == NAME_nameOf )
343 { if ( ch )
344 mergeChain(ch, t->context);
345 else
346 ch = getCopyChain(t->context);
347 } else if ( t->kind == NAME_class )
348 { if ( t->context == ClassBool )
349 { if ( ch )
350 { appendChain(ch, ON);
351 appendChain(ch, OFF);
352 } else
353 ch = answerObject(ClassChain, ON, OFF, EAV);
354 }
355 } else if ( t->kind == NAME_value )
356 { if ( ch )
357 appendChain(ch, t->context);
358 else
359 ch = answerObject(ClassChain, t->context, EAV);
360 } else if ( t->kind == NAME_intRange )
361 { Tuple tpl = t->context;
362 int n;
363
364 if ( valInt(tpl->second) - valInt(tpl->first) < 10 )
365 { if ( !ch )
366 ch = answerObject(ClassChain, EAV);
367 for(n=valInt(tpl->first); n<=valInt(tpl->second); n++)
368 appendChain(ch, toInt(n));
369 }
370 } else if ( t->kind == NAME_valueSet )
371 { Chain ch2;
372
373 if ( isFunction(t->context) )
374 { if ( !(ch2 = getForwardReceiverFunctionv(t->context, ctx, 1, &ctx)) ||
375 !instanceOfObject(ch2, ClassChain) )
376 ch2 = FAIL;
377 } else if ( instanceOfObject(t->context, ClassQuoteFunction) )
378 { Any f = ((QuoteFunction)t->context)->function;
379
380 if ( !(ch2 = getForwardReceiverFunctionv(f, ctx, 1, &ctx)) ||
381 !instanceOfObject(ch2, ClassChain) )
382 ch2 = FAIL;
383 } else
384 ch2 = t->context;
385
386 if ( ch2 )
387 { if ( ch )
388 mergeChain(ch, ch2);
389 else
390 ch = getCopyChain(ch2);
391 }
392 } else if ( t->kind == NAME_alias )
393 { value_set_type(t->context, ctx, &ch);
394 }
395
396 if ( notNil(t->supers) )
397 { Cell cell;
398
399 for_cell(cell, t->supers)
400 value_set_type(cell->value, ctx, &ch);
401 }
402
403 *set = ch;
404 }
405
406
407 Chain
getValueSetType(Type t,Any ctx)408 getValueSetType(Type t, Any ctx)
409 { Chain rval = FAIL;
410
411 value_set_type(t, ctx, &rval);
412
413 answer(rval);
414 }
415
416 /********************************
417 * TYPE CHECKING/CONVERSION *
418 ********************************/
419
420 static int translate_type_nesting = 0;
421
422 Any
getTranslateType(Type t,Any val,Any ctx)423 getTranslateType(Type t, Any val, Any ctx)
424 { Any rval;
425
426 CheckTypeError = CTE_OK;
427
428 if ( isObject(val) && onFlag(val, F_ACTIVE|F_ISHOSTDATA) )
429 { if ( onFlag(val, F_ISHOSTDATA) )
430 { if ( !(val = (*TheCallbackFunctions.translate)(val, t)) )
431 fail;
432 if ( validateType(t, val, ctx) )
433 return val;
434 if ( !isFunction(val) )
435 goto skipf;
436 }
437 /* i.e. isFunction(val) */
438 if ( !(val = expandFunction(val)) )
439 { CheckTypeError = CTE_OBTAINER_FAILED;
440 fail;
441 }
442 if ( validateType(t, val, ctx) )
443 return val;
444 }
445
446 skipf:
447 if ( translate_type_nesting++ > MAX_TYPE_TRANSLATE_NESTING )
448 { errorPce(t, NAME_typeLoop, val);
449 fail;
450 }
451
452 rval = (*t->translate_function)(t, val, ctx);
453 if ( rval )
454 goto out;
455
456 if ( notNil(t->supers) )
457 { Cell cell;
458
459 for_cell(cell, t->supers)
460 { rval = getTranslateType(cell->value, val, ctx);
461 if ( rval )
462 goto out;
463 }
464 }
465
466 out:
467 translate_type_nesting--;
468 return rval;
469 }
470
471
472 static Any
getCheckType(Type t,Any val,Any ctx)473 getCheckType(Type t, Any val, Any ctx)
474 { if ( isDefault(ctx) )
475 ctx = NIL;
476
477 answer(checkType(val, t, ctx));
478 }
479
480
481 /********************************
482 * VALIDATE-FUNCTIONS *
483 ********************************/
484
485 static inline status
valueType(const Type t,const Any val,const Any ctx)486 valueType(const Type t, const Any val, const Any ctx)
487 { if ( val == t->context )
488 succeed;
489
490 fail;
491 }
492
493
494 static inline status
intType(const Type t,const Any val,const Any ctx)495 intType(const Type t, const Any val, const Any ctx)
496 { return isInteger(val);
497 }
498
499
500 static inline status
classType(const Type t,const Any val,const Any ctx)501 classType(const Type t, const Any val, const Any ctx)
502 { if ( onFlag(t->context, F_ISNAME) ) /* isName(), but it *is* an object */
503 { Class class;
504
505 if ( (class=getConvertClass(ClassClass, t->context)) )
506 assign(t, context, class);
507 else
508 fail;
509 }
510
511 return instanceOfObject(val, t->context);
512 }
513
514
515 static inline status
objectType(const Type t,const Any val,const Any ctx)516 objectType(const Type t, const Any val, const Any ctx)
517 { if ( isObject(val) && !onFlag(val, F_ACTIVE|F_ISHOSTDATA) )
518 succeed;
519
520 fail;
521 }
522
523
524 static inline status
anyType(const Type t,const Any val,const Any ctx)525 anyType(const Type t, const Any val, const Any ctx)
526 { if ( isObject(val) )
527 return offFlag(val, F_NOTANY);
528
529 succeed;
530 }
531
532
533 static inline status
argType(const Type t,const Any val,const Any ctx)534 argType(const Type t, const Any val, const Any ctx)
535 { return isFunction(val);
536 }
537
538
539 static inline status
charType(const Type t,const Any val,const Any ctx)540 charType(const Type t, const Any val, const Any ctx)
541 { return isInteger(val) && valInt(val) >= 0 && valInt(val) <= 2*META_OFFSET;
542 }
543
544
545 static inline status
eventIdType(const Type t,const Any val,const Any ctx)546 eventIdType(const Type t, const Any val, const Any ctx)
547 { return charType(t, val, ctx) || (isName(val) && eventName(val));
548 }
549
550
551 static inline status
atomicType(const Type t,const Any val,const Any ctx)552 atomicType(const Type t, const Any val, const Any ctx)
553 { if ( isInteger(val) )
554 succeed;
555 if ( isObject(val) && onFlag(val, F_ISREAL|F_ISNAME) )
556 succeed;
557
558 fail;
559 }
560
561
562 static inline status
nameOfType(const Type t,const Any val,const Any ctx)563 nameOfType(const Type t, const Any val, const Any ctx)
564 { if ( isName(val) )
565 return memberChain(t->context, val);
566
567 fail;
568 }
569
570
571 static inline status
valueSetType(const Type t,const Any val,const Any ctx)572 valueSetType(const Type t, const Any val, const Any ctx)
573 { if ( isFunction(t->context) )
574 { Any rval;
575
576 if ( (rval = getForwardReceiverFunctionv(t->context, ctx, 1, &ctx)) &&
577 instanceOfObject(rval, ClassChain) &&
578 memberChain(rval, val) )
579 succeed;
580 } else if ( instanceOfObject(t->context, ClassQuoteFunction) )
581 { Any rval;
582 Any f = ((QuoteFunction)t->context)->function;
583
584 if ( (rval = getForwardReceiverFunctionv(f, ctx, 1, &ctx)) &&
585 instanceOfObject(rval, ClassChain) &&
586 memberChain(rval, val) )
587 succeed;
588 } else
589 return memberChain(t->context, val);
590
591 fail;
592 }
593
594
595 static inline status
intRangeType(const Type t,const Any val,const Any ctx)596 intRangeType(const Type t, const Any val, const Any ctx)
597 { if ( isInteger(val) )
598 { Tuple tp = t->context;
599 int i = valInt(val);
600
601 if ( i >= valInt(tp->first) && i <= valInt(tp->second) )
602 succeed;
603 }
604
605 fail;
606 }
607
608
609 static inline status
realRangeType(const Type t,const Any val,const Any ctx)610 realRangeType(const Type t, const Any val, const Any ctx)
611 { if ( instanceOfObject(val, ClassReal) )
612 { Tuple tp = t->context;
613 Real low = tp->first, high = tp->second, r = val;
614
615 if ( (isNil(low) || valReal(r) >= valReal(low)) &&
616 (isNil(high) || valReal(r) <= valReal(high)) )
617 succeed;
618 }
619
620 fail;
621 }
622
623
624 static inline status
memberType(const Type t,const Any val,const Any ctx)625 memberType(const Type t, const Any val, const Any ctx)
626 { return validateType(t->context, val, ctx);
627 }
628
629
630 static inline status
aliasType(const Type t,const Any val,const Any ctx)631 aliasType(const Type t, const Any val, const Any ctx)
632 { return validateType(t->context, val, ctx);
633 }
634
635
636 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
637 NOTE: only alien and unchecked types pass HostData. Anything else will
638 force conversion.
639 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
640
641 status
validateType(Type t,const Any val,const Any ctx)642 validateType(Type t, const Any val, const Any ctx)
643 { int rval;
644 again:
645
646 switch( t->validate_function )
647 { case TV_CLASS: rval = classType(t, val, ctx); break;
648 case TV_OBJECT: rval = objectType(t, val, ctx); break;
649 case TV_INT: rval = intType(t, val, ctx); break;
650 case TV_ARG: rval = argType(t, val, ctx); break;
651 case TV_VALUE: rval = valueType(t, val, ctx); break;
652 case TV_VALUESET: rval = valueSetType(t, val, ctx); break;
653 case TV_UNCHECKED: succeed;
654 case TV_ANY: rval = anyType(t, val, ctx); break;
655 case TV_ALIEN: succeed;
656 case TV_NAMEOF: rval = nameOfType(t, val, ctx); break;
657 case TV_INTRANGE: rval = intRangeType(t, val, ctx); break;
658 case TV_REALRANGE: rval = realRangeType(t, val, ctx); break;
659 case TV_MEMBER: rval = memberType(t, val, ctx); break;
660 case TV_COMPOUND: rval = FAIL; break;
661 case TV_ALIAS: if ( isNil(t->supers) )
662 { t = t->context;
663 goto again;
664 } else
665 { rval = aliasType(t, val, ctx);
666 break;
667 }
668 case TV_CHAR: rval = charType(t, val, ctx); break;
669 case TV_EVENTID: rval = eventIdType(t, val, ctx); break;
670 case TV_ATOMIC: rval = atomicType(t, val, ctx); break;
671 default:
672 return sysPce("%s: Invalid type. Kind is %s, validate = 0x%x",
673 pp(t), pp(t->kind), (int)t->validate_function);
674 }
675
676 /*if ( isHostData(val) )
677 fail;
678 */
679
680 if ( rval )
681 return rval;
682
683 if ( notNil(t->supers) )
684 { Cell cell;
685
686 for_cell(cell, t->supers)
687 { if ( validateType(cell->value, val, ctx) )
688 succeed;
689 }
690 }
691
692 fail;
693 }
694
695 /********************************
696 * CONVERT-FUNCTIONS *
697 ********************************/
698
699 static Any
getFailType(const Type t,const Any val,const Any ctx)700 getFailType(const Type t, const Any val, const Any ctx)
701 { fail;
702 }
703
704
705 static Any
getIntType(const Type t,const Any val,const Any ctx)706 getIntType(const Type t, const Any val, const Any ctx)
707 { return (Any) toInteger(val);
708 }
709
710
711 static int
charpToChar(char * s)712 charpToChar(char *s)
713 { if ( s[0] != EOS && s[1] == EOS )
714 return s[0];
715
716 if ( s[0] == '\\' && s[2] == EOS )
717 { switch(s[1])
718 { case 'n': return '\n';
719 case 't': return '\t';
720 case 'f': return '\f';
721 case 'b': return '\b';
722 case 'r': return '\r';
723 case '\\': return '\\';
724 default: return -1;
725 }
726 } else if ( s[0] == '^' && s[1] != EOS && s[2] == EOS )
727 { return toupper(s[1]) - '@';
728 } else if ( prefixstr(s, "\\C-") && s[4] == EOS )
729 { return toupper(s[3]) - '@';
730 } else if ( prefixstr(s, "M-") || prefixstr(s, "\\e") )
731 { int c;
732
733 if ( (c = charpToChar(s+2)) >= 0 )
734 return c + META_OFFSET;
735 }
736
737 return -1;
738 }
739
740
741 static Any
getCharType(const Type t,const Any val,const Any ctx)742 getCharType(const Type t, const Any val, const Any ctx)
743 { if ( instanceOfObject(val, ClassCharArray) )
744 { CharArray ca = val;
745 PceString s = &ca->data;
746 int c;
747
748 if ( s->s_size == 1 )
749 return toInt(str_fetch(s, 0));
750 if ( isstrA(s) && (c = charpToChar((char *)s->s_text)) >= 0 )
751 return toInt(c);
752 } else
753 { Int i = toInteger(val);
754
755 if ( valInt(i) >= 0 && valInt(i) <= 2*META_OFFSET )
756 return i;
757 }
758
759 fail;
760 }
761
762
763 static Any
getEventIdType(const Type t,const Any val,const Any ctx)764 getEventIdType(const Type t, const Any val, const Any ctx)
765 { Any rval;
766
767 if ( instanceOfObject(val, ClassEvent) )
768 return getIdEvent(val);
769
770 if ( (rval = getCharType(t, val, ctx)) )
771 return rval;
772
773 TRY(rval = toName(val));
774 if ( eventName(rval) )
775 return rval;
776
777 fail;
778 }
779
780
781 static Any
getAtomicType(const Type t,const Any val,const Any ctx)782 getAtomicType(const Type t, const Any val, const Any ctx)
783 { Any rval;
784
785 if ( (rval = toInteger(val)) )
786 return rval;
787 if ( (rval = toReal(val)) )
788 return rval;
789 if ( (rval = toName(val)) )
790 return rval;
791
792 fail;
793 }
794
795
796 static Any
getClassType(const Type t,const Any val,const Any ctx)797 getClassType(const Type t, const Any val, const Any ctx)
798 { Class class = t->context;
799
800 if ( isName(class) )
801 { if ( (class = getConvertClass(ClassClass, t->context)) )
802 assign(t, context, class);
803 else
804 { errorPce(t, NAME_unresolvedType);
805 fail;
806 }
807 }
808
809 realiseClass(class);
810 if ( isDefault(class->convert_method) )
811 { GetMethod m;
812
813 if ( (m=getGetMethodClass(class, NAME_convert)) )
814 { assign(class, convert_method, m);
815 setDFlag(m, D_TYPENOWARN);
816 }
817 }
818
819 if ( notNil(class->convert_method) )
820 { Any rval = getGetGetMethod(class->convert_method, ctx, 1, &val);
821
822 if ( rval )
823 { if ( instanceOfObject(rval, class) )
824 answer(rval);
825
826 return checkType(rval, nameToType(class->name), NIL);
827 }
828 }
829
830 fail;
831 }
832
833
834 static Any
getValueType(const Type t,const Any val,const Any ctx)835 getValueType(const Type t, const Any val, const Any ctx)
836 { Any obj;
837
838 if ( (obj = getConvertObject(ctx, val)) && valueType(t, obj, ctx) )
839 return obj;
840
841 fail;
842 }
843
844
845 static Any
convertValueSetType(const Type t,const Any val,const Any ctx)846 convertValueSetType(const Type t, const Any val, const Any ctx)
847 { Any obj;
848
849 if ( (obj = getConvertObject(ctx, val)) && valueSetType(t, obj, ctx) )
850 return obj;
851
852 fail;
853 }
854
855
856 static Any
getNameOfType(const Type t,const Any val,const Any ctx)857 getNameOfType(const Type t, const Any val, const Any ctx)
858 { Name name = getClassType(TypeName, val, ctx);
859
860 if ( name != FAIL && nameOfType(t, (Any)name, ctx) )
861 return (Any) name;
862
863 fail;
864 }
865
866
867 static Any
getIntRangeType(const Type t,const Any val,const Any ctx)868 getIntRangeType(const Type t, const Any val, const Any ctx)
869 { Int i = (Int) getIntType(t, val, ctx);
870
871 if ( i != FAIL && intRangeType(t, (Any)i, ctx) )
872 return (Any) i;
873
874 fail;
875 }
876
877
878 static Any
getRealRangeType(const Type t,const Any val,const Any ctx)879 getRealRangeType(const Type t, const Any val, const Any ctx)
880 { Real r = getConvertReal(ClassReal, val);
881
882 if ( r != FAIL && realRangeType(t, r, ctx) )
883 return r;
884
885 fail;
886 }
887
888
889 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
890 This method should just call `get(ctx, NAME_member, EAV)'; but this is not
891 possible as this might give typing errors.
892 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
893
894 static Any
getMemberType(const Type t,const Any val,const Any ctx)895 getMemberType(const Type t, const Any val, const Any ctx)
896 { GetMethod m;
897 Type at;
898 Any rval, a;
899
900 if ( isObject(ctx) &&
901 (m = getGetMethodClass(classOfObject(ctx), NAME_member)) &&
902 instanceOfObject(m, ClassGetMethod) &&
903 (at = getArgumentTypeMethod((Method) m, ONE)) &&
904 (a = checkType(val, at, NIL)) &&
905 (rval = getGetGetMethod(m, ctx, 1, &a)) )
906 return rval;
907
908 fail;
909 }
910
911
912 static Any
getAliasType(const Type t,const Any val,const Any ctx)913 getAliasType(const Type t, const Any val, const Any ctx)
914 { return getTranslateType(t->context, val, ctx);
915 }
916
917
918 static status
kindType(Type t,Name kind)919 kindType(Type t, Name kind)
920 { if ( equalName(kind, NAME_class) )
921 { t->validate_function = TV_CLASS;
922 t->translate_function = getClassType;
923 } else if ( equalName(kind, NAME_object) )
924 { t->validate_function = TV_OBJECT;
925 t->translate_function = getClassType;
926 } else if ( equalName(kind, NAME_int) )
927 { t->validate_function = TV_INT;
928 t->translate_function = getIntType;
929 } else if ( equalName(kind, NAME_arg) )
930 { t->validate_function = TV_ARG;
931 t->translate_function = getFailType;
932 } else if ( equalName(kind, NAME_value) )
933 { t->validate_function = TV_VALUE;
934 t->translate_function = getValueType;
935 } else if ( equalName(kind, NAME_valueSet) )
936 { t->validate_function = TV_VALUESET;
937 t->translate_function = convertValueSetType;
938 } else if ( equalName(kind, NAME_unchecked) )
939 { t->validate_function = TV_UNCHECKED;
940 t->translate_function = getFailType;
941 } else if ( equalName(kind, NAME_any) )
942 { t->validate_function = TV_ANY;
943 t->translate_function = getFailType;
944 } else if ( equalName(kind, NAME_alien) )
945 { t->validate_function = TV_ALIEN;
946 t->translate_function = getFailType;
947 } else if ( equalName(kind, NAME_nameOf) )
948 { t->validate_function = TV_NAMEOF;
949 t->translate_function = getNameOfType;
950 } else if ( equalName(kind, NAME_intRange) )
951 { t->validate_function = TV_INTRANGE;
952 t->translate_function = getIntRangeType;
953 } else if ( equalName(kind, NAME_realRange) )
954 { t->validate_function = TV_REALRANGE;
955 t->translate_function = getRealRangeType;
956 } else if ( equalName(kind, NAME_member) )
957 { t->validate_function = TV_MEMBER;
958 t->translate_function = getMemberType;
959 } else if ( equalName(kind, NAME_compound) )
960 { t->validate_function = TV_COMPOUND;
961 t->translate_function = getFailType;
962 } else if ( equalName(kind, NAME_alias) )
963 { t->validate_function = TV_ALIAS;
964 t->translate_function = getAliasType;
965 } else if ( equalName(kind, NAME_char) )
966 { t->validate_function = TV_CHAR;
967 t->translate_function = getCharType;
968 } else if ( equalName(kind, NAME_eventId) )
969 { t->validate_function = TV_EVENTID;
970 t->translate_function = getEventIdType;
971 } else if ( equalName(kind, NAME_atomic) )
972 { t->validate_function = TV_ATOMIC;
973 t->translate_function = getAtomicType;
974 } else
975 return errorPce(t, NAME_noTypeKind, kind);
976
977 assign(t, kind, kind);
978 succeed;
979 }
980
981 /*******************************
982 * CLASS DECLARATION *
983 *******************************/
984
985 /* Type declaractions */
986
987 static char *T_initialise[] =
988 { "name=name", "kind=[name]", "context=[any]", "supers=[chain*]" };
989 static char *T_validate[] =
990 { "unchecked", "[object]*" };
991 static char *T_valueAunchecked_contextADobjectDN[] =
992 { "value=unchecked", "context=[object]*" };
993
994 /* Instance Variables */
995
996 static vardecl var_type[] =
997 { SV(NAME_kind, "name", IV_GET|IV_STORE, kindType,
998 NAME_check, "Type of type"),
999 IV(NAME_fullname, "name", IV_GET,
1000 NAME_name, "Symbolic name for this type"),
1001 IV(NAME_argumentName, "name*", IV_GET,
1002 NAME_argument, "Name of the argument"),
1003 IV(NAME_supers, "chain*", IV_GET,
1004 NAME_components, "Super-types"),
1005 IV(NAME_context, "any", IV_GET,
1006 NAME_check, "Context for check- and convert functions"),
1007 IV(NAME_vector, "bool", IV_GET,
1008 NAME_argument, "Methods: variable number of arguments"),
1009 IV(NAME_validateFunction, "alien:SendFunc", IV_NONE,
1010 NAME_internal, "C-function to check this type"),
1011 IV(NAME_translateFunction, "alien:Func", IV_NONE,
1012 NAME_internal, "C-function to convert to this")
1013 };
1014
1015 /* Send Methods */
1016
1017 static senddecl send_type[] =
1018 { SM(NAME_initialise, 4, T_initialise, initialiseType,
1019 DEFAULT, "Create type from name, kind, context and supers"),
1020 SM(NAME_validate, 2, T_validate, validateType,
1021 NAME_check, "Validate argument is of this type"),
1022 SM(NAME_equal, 1, "type", equalType,
1023 NAME_compare, "Test if both types are the same"),
1024 SM(NAME_includes, 1, "type", includesType,
1025 NAME_meta, "Type includes its argument"),
1026 SM(NAME_specialised, 1, "type", specialisedType,
1027 NAME_meta, "Test if argument is a specialised type")
1028 };
1029
1030 /* Get Methods */
1031
1032 static getdecl get_type[] =
1033 { GM(NAME_check, 2, "unchecked", T_valueAunchecked_contextADobjectDN, getCheckType,
1034 NAME_check, "Validate and translate if necessary"),
1035 GM(NAME_convert, 1, "type", "name", getConvertType,
1036 NAME_check, "Convert symbolic type-name"),
1037 GM(NAME_translate, 2, "unchecked", T_valueAunchecked_contextADobjectDN, getTranslateType,
1038 NAME_check, "Translate argument given context"),
1039 GM(NAME_copy, 1, "type", "name", getCopyType,
1040 NAME_copy, "Get a copy of a type with a different name"),
1041 GM(NAME_valueSet, 1, "chain", "[object]*", getValueSetType,
1042 NAME_meta, "Chain with values that satisfy this type"),
1043 GM(NAME_name, 0, "name", NULL, getNameType,
1044 NAME_name, "Name without argument specification"),
1045 GM(NAME_lookup, 1, "type", "name", getLookupType,
1046 NAME_oms, "Lookup type in type-database")
1047 };
1048
1049 /* Resources */
1050
1051 #define rc_type NULL
1052 /*
1053 static classvardecl rc_type[] =
1054 {
1055 };
1056 */
1057
1058 /* Class Declaration */
1059
1060 static Name type_termnames[] = { NAME_name, NAME_kind,
1061 NAME_context, NAME_supers };
1062
1063 ClassDecl(type_decls,
1064 var_type, send_type, get_type, rc_type,
1065 4, type_termnames,
1066 "$Rev$");
1067
1068
1069 status
makeClassType(Class class)1070 makeClassType(Class class)
1071 { declareClass(class, &type_decls);
1072
1073 setLoadStoreFunctionClass(class, loadType, storeType);
1074 cloneStyleClass(class, NAME_none);
1075
1076 succeed;
1077 }
1078
1079
1080 /********************************
1081 * CREATING TYPES *
1082 ********************************/
1083
1084 static Type
createClassType(Name name)1085 createClassType(Name name)
1086 { Type type;
1087
1088 if ( (type = getMemberHashTable(TypeTable, name)) )
1089 return type;
1090 else
1091 return createType(name, NAME_class, inBoot ? (Any) typeClass(name)
1092 : (Any) name);
1093 }
1094
1095 /********************************
1096 * CONVERSION *
1097 ********************************/
1098
1099 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1100 Type syntax:
1101
1102 Type ::= SingleType
1103 | SingleType '...'
1104 | 'alien:' Ctype
1105 SingleType ::= PrimType
1106 | SingleType '*'
1107 | '[' SingleType ']'
1108 | SingleType '|' SingleType
1109 SingleType ::= 'int'
1110 | 'any'
1111 | 'unchecked'
1112 | ClassName
1113 | Int '...' Int
1114 | Int '..'
1115 | '..' Int
1116 | Float '...' Float
1117 | Float '..'
1118 | '..' Float
1119 | {Atom, ...}
1120 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1121
1122 typedef struct
1123 { wchar_t *start;
1124 wchar_t *end;
1125 wchar_t text[LINESIZE];
1126 } str_part, *StrPart;
1127
1128
1129 typedef const unsigned char * cucharp;
1130
1131 static void
strip_string(StrPart s)1132 strip_string(StrPart s)
1133 { while(*s->start == ' ')
1134 s->start++;
1135 while(*s->end == ' ' && s->end >= s->start)
1136 *s->end-- = EOS;
1137 }
1138
1139
1140 static status
init_string(StrPart s,PceString t)1141 init_string(StrPart s, PceString t)
1142 { if ( t->s_size >= LINESIZE )
1143 fail;
1144
1145 if ( isstrA(t) )
1146 { wchar_t *o = s->text;
1147 cucharp i = (cucharp)t->s_textA;
1148 cucharp e = &i[t->s_size];
1149
1150 while(i<e)
1151 *o++ = *i++;
1152 *o = EOS;
1153 } else
1154 { wcscpy(s->text, t->s_textW);
1155 }
1156
1157 s->start = s->text;
1158 s->end = &s->text[t->s_size - 1];
1159 strip_string(s);
1160
1161 succeed;
1162 }
1163
1164
1165 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1166 Check whether `s' has suffix `suff' and something non-blank before the
1167 suffix. If so, delete the suffix and trailing blanks.
1168 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1169
1170 static int
suffix_string(StrPart s,const char * suff)1171 suffix_string(StrPart s, const char *suff)
1172 { cucharp ts = (cucharp)(suff + strlen(suff) - 1);
1173 wchar_t *es = s->end;
1174
1175 for(; *ts == *es; ts--, es--)
1176 { if ( ts == (cucharp)suff )
1177 { es--;
1178 while(*es == ' ' && es >= s->start)
1179 es--;
1180
1181 if ( es >= s->start )
1182 { s->end = es;
1183 s->end[1] = EOS;
1184
1185 return TRUE;
1186 } else
1187 return FALSE;
1188 }
1189 }
1190
1191 return FALSE;
1192 }
1193
1194
1195 static int
prefix_string(StrPart s,const char * prefix)1196 prefix_string(StrPart s, const char *prefix)
1197 { wchar_t *q = s->start;
1198 cucharp pref = (cucharp)prefix;
1199
1200 while(*pref && *pref == *q)
1201 pref++, q++;
1202
1203 if ( !*pref )
1204 { s->start = q;
1205 strip_string(s);
1206 return TRUE;
1207 }
1208
1209 return FALSE;
1210 }
1211
1212
1213
1214 static Type
name_of_type(StrPart str)1215 name_of_type(StrPart str)
1216 { if ( *str->start == '{' && *str->end == '}' )
1217 { Type type = newObject(ClassType, WCToName(str->start, -1),
1218 NAME_nameOf, newObject(ClassChain, EAV), EAV);
1219 wchar_t *s, *e;
1220
1221 str->start++;
1222 strip_string(str);
1223 while(str->start < str->end)
1224 { for(s=str->start; s<str->end && *s != ','; s++)
1225 ;
1226 for(e=s-1; e > str->start && *e == ' '; e--)
1227 ;
1228 e[1] = EOS;
1229 appendChain(type->context, WCToName(str->start, -1));
1230 str->start = s+1;
1231 strip_string(str);
1232 }
1233
1234 return type;
1235 }
1236
1237 fail;
1238 }
1239
1240
1241 static Type
int_range_type(StrPart str)1242 int_range_type(StrPart str)
1243 { wchar_t *e, *e2;
1244 intptr_t low, high;
1245 Type type;
1246
1247 if ( *(e=str->start) == '.' )
1248 low = PCE_MIN_INT;
1249 else
1250 { low = wcstol(str->start, &e, 10);
1251 if ( e == str->start )
1252 fail;
1253 }
1254
1255 while( *e == ' ' )
1256 e++;
1257 if ( e[0] != '.' || e[1] != '.' )
1258 fail;
1259 e += 2;
1260 if ( e == str->end + 1 )
1261 high = PCE_MAX_INT;
1262 else
1263 { high = wcstol(e, &e2, 10);
1264 if ( e2 != str->end+1 )
1265 fail;
1266 }
1267 type = newObject(ClassType, WCToName(str->start, -1), NAME_intRange, EAV);
1268
1269 assign(type, context, newObject(ClassTuple,
1270 toInt(low), toInt(high), EAV));
1271
1272 return type;
1273 }
1274
1275
1276 static Type
real_range_type(StrPart str)1277 real_range_type(StrPart str)
1278 { wchar_t *e0, *e, *e2;
1279 double low, high;
1280 Type type;
1281 Real l = NIL, h = NIL;
1282
1283 low = cwcstod(str->start, &e0);
1284 for( e=e0; *e == ' '; e++ )
1285 ;
1286 if ( e[0] != '.' || e[1] != '.' )
1287 fail;
1288 e += 2;
1289 high = cwcstod(e, &e2);
1290 if ( e2 != str->end+1 )
1291 fail;
1292 if ( e2 == e && e0 == str->start )
1293 fail; /* no high nor low */
1294
1295 type = newObject(ClassType, WCToName(str->start, -1), NAME_realRange, EAV);
1296 if ( e2 > e )
1297 h = CtoReal(high);
1298 if ( e0 > str->start )
1299 l = CtoReal(low);
1300 assign(type, context, newObject(ClassTuple, l, h, EAV));
1301
1302 return type;
1303 }
1304
1305
1306 static Type
disjunctive_type(StrPart str)1307 disjunctive_type(StrPart str)
1308 { wchar_t *s;
1309
1310 if ( (s = wcschr(str->start, '|')) != NULL )
1311 { Type type;
1312 wchar_t *e;
1313 Name name = WCToName(str->start, -1);
1314
1315 *s = EOS;
1316 TRY(type = WCtoType(str->start));
1317 TRY(type = getCopyType(type, name));
1318 s++;
1319 while( s < str->end && (e = wcschr(s, '|')) != NULL )
1320 { *e = EOS;
1321 superType(type, WCtoType(s));
1322 s = e+1;
1323 }
1324 if ( s < str->end )
1325 superType(type, WCtoType(s));
1326
1327 return type;
1328 }
1329
1330 fail;
1331 }
1332
1333
1334 static Type
kind_type(StrPart str)1335 kind_type(StrPart str)
1336 { wchar_t *s;
1337 wchar_t *e;
1338 Name name, kind;
1339 Type type;
1340
1341 if ( !iscsym(*str->start) )
1342 fail;
1343 for(s = str->start; iscsym(*s); s++)
1344 ;
1345 for(e=s; isblank(*e); e++)
1346 ;
1347 if ( *e != ':' )
1348 fail;
1349
1350 name = WCToName(str->start, -1);
1351 *s = EOS;
1352 kind = WCToName(str->start, -1);
1353 str->start = e + 1;
1354 strip_string(str);
1355
1356 TRY(type = newObject(ClassType, name, kind, EAV));
1357
1358 if ( kind == NAME_alien )
1359 assign(type, context, WCToName(str->start, -1));
1360 else if ( kind == NAME_member )
1361 assign(type, context, WCtoType(str->start));
1362 else
1363 { errorPce(type, NAME_noTypeKind, kind);
1364 fail;
1365 }
1366
1367 return type;
1368 }
1369
1370
1371 static Type
named_type(StrPart str)1372 named_type(StrPart str)
1373 { wchar_t *s;
1374 wchar_t *e;
1375 Name name, argname;
1376 Type type, rval;
1377
1378 if ( !iscsym(*str->start) )
1379 fail;
1380
1381 for(s = str->start; iscsym(*s); s++)
1382 ;
1383 for(e=s; iswspace(*e); e++)
1384 ;
1385 if ( *e != '=' )
1386 fail;
1387
1388 name = WCToName(str->start, -1);
1389 *s = EOS;
1390 argname = WCToName(str->start, -1);
1391 str->start = e + 1;
1392 strip_string(str);
1393
1394 TRY(type = WCtoType(str->start));
1395 TRY(rval = newObject(ClassType, name, NAME_alias, type, EAV));
1396 assign(rval, vector, type->vector);
1397 assign(rval, argument_name, argname);
1398
1399 return rval;
1400 }
1401
1402
1403 Type
nameToType(Name name)1404 nameToType(Name name)
1405 { Type type;
1406 str_part str;
1407
1408 if ( (type = getMemberHashTable(TypeTable, name)) )
1409 return type;
1410
1411 if ( !init_string(&str, &name->data) )
1412 fail;
1413
1414 if ( (type = named_type(&str)) )
1415 return type;
1416
1417 if ( prefix_string(&str, "alien:") )
1418 { TRY(type = newObject(ClassType, name, NAME_alien, EAV));
1419 assign(type, context, WCToName(str.start, -1));
1420
1421 return type;
1422 }
1423
1424 if ( suffix_string(&str, "...") ) /* SimpleType ... */
1425 { Name sn = WCToName(str.start, -1);
1426 Type st;
1427
1428 if ( (st = nameToType(sn)) )
1429 { Type t2 = getCopyType(st, name);
1430
1431 vectorType(t2, ON);
1432 return t2;
1433 }
1434 } else
1435 { int arg=0, def=0, var=0;
1436 int och = -1, changed = 0;
1437
1438 while(och != changed)
1439 { och = changed;
1440
1441 if ( suffix_string(&str, "*") )
1442 { var++;
1443 changed++;
1444 } else if ( suffix_string(&str, "?") )
1445 { arg++;
1446 changed++;
1447 } else if ( *str.start == '[' && *str.end == ']' )
1448 { str.start++; *str.end-- = EOS;
1449 strip_string(&str);
1450 def++;
1451 changed++;
1452 }
1453 }
1454
1455 if ( changed )
1456 { Name sn = WCToName(str.start, -1);
1457 Type st;
1458
1459 if ( (st = nameToType(sn)) )
1460 { Type t2 = getCopyType(st, name);
1461
1462 if ( var ) superType(t2, TypeNil);
1463 if ( def ) superType(t2, TypeDefault);
1464 if ( arg ) superType(t2, TypeArg);
1465
1466 return t2;
1467 }
1468 } else
1469 { if ( (type = name_of_type(&str)) )
1470 return type;
1471
1472 if ( (isdigit(*str.start) || *str.start == '.' || *str.start == '-') &&
1473 (isdigit(*str.end) || *str.end == '.') )
1474 { if ( (type = int_range_type(&str)) )
1475 return type;
1476 if ( (type = real_range_type(&str)) )
1477 return type;
1478 }
1479
1480 if ( (type = disjunctive_type(&str)) )
1481 return type;
1482
1483 if ( (type = kind_type(&str)) )
1484 return type;
1485
1486 return createClassType(WCToName(str.start, -1));
1487 }
1488 }
1489
1490 errorPce(name, NAME_badTypeSyntax);
1491 fail;
1492 }
1493
1494
1495 /********************************
1496 * RESET *
1497 ********************************/
1498
1499 void
resetTypes(void)1500 resetTypes(void)
1501 { translate_type_nesting = 0;
1502 }
1503
1504
1505 /********************************
1506 * INITIALISATION *
1507 ********************************/
1508
1509 struct built_in_type
1510 { Type * global;
1511 Name name;
1512 Name kind;
1513 Any context;
1514 } built_in_types[] =
1515 { { &TypeUnchecked, NAME_unchecked, NAME_unchecked, NIL },
1516 { &TypeAlien, NAME_alien, NAME_alien, NIL },
1517 { &TypeAny, NAME_any, NAME_any, NIL },
1518 { &TypeNil, NAME_nil, NAME_value, NIL },
1519 { &TypeDefault, NAME_default, NAME_value, DEFAULT },
1520 { &TypeArg, NAME_arg, NAME_arg, NIL },
1521 { &TypeInt, NAME_int, NAME_int, NIL },
1522 { &TypeChar, NAME_char, NAME_char, NIL },
1523 { &TypeEventId, NAME_eventId, NAME_eventId, NIL },
1524 { &TypeAtomic, NAME_atomic, NAME_atomic, NIL },
1525 { NULL, NAME_none, NAME_none, NIL }
1526 };
1527
1528
1529 static void
bootType(Name name,Class * classp,Type * typep)1530 bootType(Name name, Class *classp, Type *typep)
1531 { *classp = typeClass(name);
1532
1533 if ( typep )
1534 *typep = createType(name, NAME_class, *classp);
1535 else
1536 createType(name, NAME_class, *classp);
1537 }
1538
1539
1540 void
initTypes(void)1541 initTypes(void)
1542 { struct built_in_type *i = built_in_types;
1543
1544 TypeTable = createHashTable(toInt(256), NAME_none);
1545
1546 ClassClass = typeClass(NAME_class);
1547 ClassClass->class = ClassClass;
1548 ClassType = typeClass(NAME_type);
1549 ClassObject = typeClass(NAME_object);
1550 ClassConstant = typeClass(NAME_constant);
1551 ClassBool = typeClass(NAME_bool);
1552
1553 ((Constant)NIL)->class = ((Constant)DEFAULT)->class = ClassConstant;
1554 ON->class = OFF->class = ClassBool;
1555
1556 TypeClass = createType(NAME_class, NAME_class, ClassClass);
1557 TypeType = createType(NAME_type, NAME_class, ClassType);
1558 TypeObject = createType(NAME_object, NAME_object, ClassObject);
1559 TypeBool = createType(NAME_bool, NAME_class, ClassBool);
1560 TypeConstant = createType(NAME_constant, NAME_class, ClassConstant);
1561
1562 bootType(NAME_charArray, &ClassCharArray, &TypeCharArray);
1563 bootType(NAME_name, &ClassName, &TypeName);
1564 bootType(NAME_var, &ClassVar, &TypeVar);
1565 bootType(NAME_variable, &ClassObjOfVariable, NULL);
1566 bootType(NAME_vector, &ClassVector, &TypeVector);
1567 bootType(NAME_method, &ClassMethod, NULL);
1568 bootType(NAME_getMethod, &ClassGetMethod, NULL);
1569 bootType(NAME_sendMethod, &ClassSendMethod, NULL);
1570 bootType(NAME_hashTable, &ClassHashTable, NULL);
1571 bootType(NAME_chain, &ClassChain, &TypeChain);
1572 bootType(NAME_function, &ClassFunction, &TypeFunction);
1573 bootType(NAME_graphical, &ClassGraphical, &TypeGraphical);
1574 bootType(NAME_real, &ClassReal, &TypeReal);
1575
1576 for( ; i->global; i++ )
1577 *i->global = createType(i->name, i->kind, i->context);
1578 }
1579
1580
1581 Type
defineType(char * name,char * def)1582 defineType(char *name, char *def)
1583 { Type t = CtoType(def);
1584
1585 return getCopyType(t, CtoName(name));
1586 }
1587
1588 /*******************************
1589 * DIRECT CALLING SUPPORT *
1590 *******************************/
1591
1592 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1593 This series of functions is exported from the XPCE shared object/DLL.
1594 They are added to the interface to facilitate direct calling. I.e. calls
1595 from the host directly back into the host because the method called is
1596 defined in the host-language.
1597 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1598
1599 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1600 pceIncludesType(t, super)
1601
1602 super is more specialised than t. E.g
1603
1604 pceIncludesType(graphical, box) --> true
1605 pceIncludesType(int, 0..4) --> true
1606 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1607
1608 int
pceIncludesType(PceType t,PceType super)1609 pceIncludesType(PceType t, PceType super)
1610 { return specialisedType(super, t);
1611 }
1612
1613
1614 int
pceIncludesHostDataType(PceType t,PceClass cl)1615 pceIncludesHostDataType(PceType t, PceClass cl)
1616 { l1:
1617
1618 switch(t->validate_function)
1619 { case TV_ALIAS:
1620 t = t->context;
1621 goto l1;
1622 case TV_UNCHECKED:
1623 succeed;
1624 case TV_CLASS:
1625 realiseClassType(t);
1626 if ( isAClass(cl, t->context) )
1627 succeed;
1628 }
1629
1630 if ( notNil(t->supers) )
1631 { Cell cell;
1632
1633 for_cell(cell, t->supers)
1634 { if ( pceIncludesHostDataType(cell->value, cl) )
1635 succeed;
1636 }
1637 }
1638
1639 fail;
1640 }
1641
1642
1643 PceObject
pceCheckType(PceGoal g,PceType t,PceObject val)1644 pceCheckType(PceGoal g, PceType t, PceObject val)
1645 { PceObject rval;
1646
1647 if ( validateType(t, val, g->receiver) )
1648 return val;
1649
1650 if ( (rval = getTranslateType(t, val, g->receiver)) )
1651 return rval;
1652
1653 if ( CheckTypeError == CTE_OBTAINER_FAILED )
1654 pceSetErrorGoal(g, PCE_ERR_FUNCTION_FAILED, val);
1655
1656 fail;
1657 }
1658
1659
1660 int
pceCheckIntType(PceType t,long val)1661 pceCheckIntType(PceType t, long val)
1662 { return validateType(t, toInt(val), NIL);
1663 }
1664
1665
1666 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1667 pceCheckNameType()
1668 This is the hard one, as there is no way to create a temporary name in
1669 XPCE, and we want to avoid creating a permantent one. In many cases this
1670 is not required too, and we just want to know the type accepts an
1671 name.
1672 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1673
1674 int
pceCheckNameType(PceType t,const char * s)1675 pceCheckNameType(PceType t, const char *s)
1676 { int rval = FALSE;
1677 again:
1678
1679 switch( t->validate_function )
1680 { case TV_CLASS:
1681 { if ( onFlag(t->context, F_ISNAME) ) /* isName() */
1682 { Class class;
1683
1684 if ( (class=getConvertClass(ClassClass, t->context)) )
1685 assign(t, context, class);
1686 else
1687 fail;
1688 }
1689
1690 rval = isAClass(ClassName, t->context);
1691 break;
1692 }
1693 case TV_OBJECT:
1694 case TV_ANY:
1695 case TV_ALIEN:
1696 case TV_UNCHECKED:
1697 case TV_ATOMIC:
1698 succeed;
1699 case TV_MEMBER:
1700 case TV_COMPOUND:
1701 case TV_INT:
1702 case TV_INTRANGE:
1703 case TV_ARG:
1704 case TV_REALRANGE:
1705 case TV_CHAR:
1706 break;
1707 case TV_VALUE:
1708 if ( isName(t->context) && streq(s, strName(t->context)) )
1709 succeed;
1710 break;
1711 case TV_VALUESET:
1712 case TV_NAMEOF:
1713 { Chain ch = getValueSetType(t, NIL);
1714
1715 if ( ch )
1716 { Cell cell;
1717
1718 for_cell(cell, ch)
1719 { if ( isName(cell->value) && streq(s, strName(cell->value)) )
1720 succeed;
1721 }
1722 }
1723 break;
1724 }
1725 case TV_ALIAS:
1726 if ( isNil(t->supers) )
1727 { t = t->context;
1728 goto again;
1729 } else
1730 { rval = pceCheckNameType(t->context, s);
1731 break;
1732 }
1733 case TV_EVENTID:
1734 if ( eventName(CtoName(s)) )
1735 succeed;
1736 break;
1737 default:
1738 return sysPce("%s: Invalid type. Kind is %s, validate = %d",
1739 pp(t), pp(t->kind), t->validate_function);
1740 }
1741
1742 if ( rval )
1743 return rval;
1744
1745 if ( notNil(t->supers) )
1746 { Cell cell;
1747
1748 for_cell(cell, t->supers)
1749 { if ( pceCheckNameType(cell->value, s) )
1750 succeed;
1751 }
1752 }
1753
1754 fail;
1755 }
1756
1757
1758 int
pceCheckFloatType(PceType t,double f)1759 pceCheckFloatType(PceType t, double f)
1760 { static Real tmp = NULL;
1761
1762 if ( !tmp )
1763 { tmp = newObject(ClassReal, ZERO, EAV);
1764 assert(tmp);
1765 lockObj(tmp);
1766 }
1767
1768 setReal(tmp, f);
1769
1770 return validateType(t, tmp, NIL);
1771 }
1772
1773