1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2008 Thomas Mertes */
5 /* */
6 /* This program is free software; you can redistribute it and/or */
7 /* modify it under the terms of the GNU General Public License as */
8 /* published by the Free Software Foundation; either version 2 of */
9 /* the License, or (at your option) any later version. */
10 /* */
11 /* This program is distributed in the hope that it will be useful, */
12 /* but WITHOUT ANY WARRANTY; without even the implied warranty of */
13 /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
14 /* GNU General Public License for more details. */
15 /* */
16 /* You should have received a copy of the GNU General Public */
17 /* License along with this program; if not, write to the */
18 /* Free Software Foundation, Inc., 51 Franklin Street, */
19 /* Fifth Floor, Boston, MA 02110-1301, USA. */
20 /* */
21 /* Module: Library */
22 /* File: seed7/src/typlib.c */
23 /* Changes: 1993, 1994, 1999, 2000 Thomas Mertes */
24 /* Content: All primitive actions for the type type. */
25 /* */
26 /********************************************************************/
27
28 #define LOG_FUNCTIONS 0
29 #define VERBOSE_EXCEPTIONS 0
30
31 #include "version.h"
32
33 #include "stdlib.h"
34 #include "stdio.h"
35 #include "string.h"
36
37 #include "common.h"
38 #include "data.h"
39 #include "data_rtl.h"
40 #include "heaputl.h"
41 #include "flistutl.h"
42 #include "datautl.h"
43 #include "syvarutl.h"
44 #include "striutl.h"
45 #include "object.h"
46 #include "typeutl.h"
47 #include "executl.h"
48 #include "objutl.h"
49 #include "runerr.h"
50 #include "traceutl.h"
51 #include "typ_data.h"
52
53 #undef EXTERN
54 #define EXTERN
55 #include "typlib.h"
56
57
58
typ_addinterface(listType arguments)59 objectType typ_addinterface (listType arguments)
60
61 {
62 typeType typ1;
63 typeType typ2;
64
65 /* typ_addinterface */
66 isit_type(arg_1(arguments));
67 isit_type(arg_2(arguments));
68 typ1 = take_type(arg_1(arguments));
69 typ2 = take_type(arg_2(arguments));
70 add_interface(typ1, typ2);
71 return SYS_EMPTY_OBJECT;
72 } /* typ_addinterface */
73
74
75
76 /**
77 * Compare two types.
78 * @return -1, 0 or 1 if the first argument is considered to be
79 * respectively less than, equal to, or greater than the
80 * second.
81 */
typ_cmp(listType arguments)82 objectType typ_cmp (listType arguments)
83
84 {
85 memSizeType typ1;
86 memSizeType typ2;
87 intType signumValue;
88
89 /* typ_cmp */
90 isit_type(arg_1(arguments));
91 isit_type(arg_2(arguments));
92 typ1 = (memSizeType) take_type(arg_1(arguments));
93 typ2 = (memSizeType) take_type(arg_2(arguments));
94 if (typ1 < typ2) {
95 signumValue = -1;
96 } else {
97 signumValue = typ1 > typ2;
98 } /* if */
99 return bld_int_temp(signumValue);
100 } /* typ_cmp */
101
102
103
104 /**
105 * Assign source/arg_3 to dest/arg_1.
106 * A copy function assumes that dest/arg_1 contains a legal value.
107 */
typ_cpy(listType arguments)108 objectType typ_cpy (listType arguments)
109
110 {
111 objectType dest;
112
113 /* typ_cpy */
114 dest = arg_1(arguments);
115 isit_type(dest);
116 is_variable(dest);
117 isit_type(arg_3(arguments));
118 dest->value.typeValue = take_type(arg_3(arguments));
119 return SYS_EMPTY_OBJECT;
120 } /* typ_cpy */
121
122
123
124 /**
125 * Initialize dest/arg_1 and assign source/arg_3 to it.
126 * A create function assumes that the contents of dest/arg_1
127 * is undefined. Create functions can be used to initialize
128 * constants.
129 */
typ_create(listType arguments)130 objectType typ_create (listType arguments)
131
132 {
133 objectType dest;
134 typeType type_from;
135
136 /* typ_create */
137 logFunction(printf("typ_create\n"););
138 isit_type(arg_3(arguments));
139 dest = arg_1(arguments);
140 type_from = take_type(arg_3(arguments));
141 #ifdef TRACE_typ_create
142 printf("\nbefore type assignment\n");
143 trace1(dest);
144 printf("\n");
145 trace1(type_from->match_obj);
146 printf("\n");
147 #endif
148 SET_CATEGORY_OF_OBJ(dest, TYPEOBJECT);
149 dest->value.typeValue = type_from;
150 if (!VAR_OBJECT(dest)) {
151 if (type_from->name == NULL &&
152 HAS_ENTITY(dest) &&
153 GET_ENTITY(dest)->ident != NULL) {
154 /* printf("typ_create: Define ");
155 trace1(dest);
156 printf("\n"); */
157 type_from->name = GET_ENTITY(dest)->ident;
158 } /* if */
159 } /* if */
160 logFunction(printf("typ_create -->\n"););
161 return SYS_EMPTY_OBJECT;
162 } /* typ_create */
163
164
165
166 /**
167 * Mark the type 'old_type/arg_1' as unused.
168 */
typ_destr(listType arguments)169 objectType typ_destr (listType arguments)
170
171 {
172 /* typeType old_type; */
173
174 /* typ_destr */
175 logFunction(printf("typ_destr\n"););
176 isit_type(arg_1(arguments));
177 /* old_type = take_type(arg_1(arguments)); */
178 /* printf("typ_destr "); trace1(old_type->match_obj); printf("\n"); */
179 SET_UNUSED_FLAG(arg_1(arguments));
180 logFunction(printf("typ_destr -->\n"););
181 return SYS_EMPTY_OBJECT;
182 } /* typ_destr */
183
184
185
186 /**
187 * Check if two types are equal.
188 * @return TRUE if the two types are equal,
189 * FALSE otherwise.
190 */
typ_eq(listType arguments)191 objectType typ_eq (listType arguments)
192
193 {
194 typeType type1;
195 typeType type2;
196
197 /* typ_eq */
198 isit_type(arg_1(arguments));
199 isit_type(arg_3(arguments));
200 type1 = take_type(arg_1(arguments));
201 type2 = take_type(arg_3(arguments));
202 if (type1 == type2) {
203 return SYS_TRUE_OBJECT;
204 } else {
205 return SYS_FALSE_OBJECT;
206 } /* if */
207 } /* typ_eq */
208
209
210
typ_func(listType arguments)211 objectType typ_func (listType arguments)
212
213 {
214 typeType basic_type;
215 typeType result;
216
217 /* typ_func */
218 logFunction(printf("typ_func\n"););
219 isit_type(arg_2(arguments));
220 basic_type = take_type(arg_2(arguments));
221 if ((result = get_func_type(NULL, basic_type)) == NULL) {
222 return raise_exception(SYS_MEM_EXCEPTION);
223 } /* if */
224 /* printf("typ_func ");
225 printobject(result);
226 prot_cstri("=");
227 prot_int((intType) result);
228 printf("\n"); */
229 logFunction(printf("typ_func -->\n"););
230 return bld_type_temp(result);
231 } /* typ_func */
232
233
234
typ_gensub(listType arguments)235 objectType typ_gensub (listType arguments)
236
237 {
238 typeType meta_type;
239 typeType result;
240
241 /* typ_gensub */
242 logFunction(printf("typ_gensub\n"););
243 isit_type(arg_1(arguments));
244 meta_type = take_type(arg_1(arguments));
245 if ((result = new_type(meta_type->owningProg, meta_type, NULL)) == NULL) {
246 return raise_exception(SYS_MEM_EXCEPTION);
247 } /* if */
248 logFunction(printf("typ_gensub -->\n"););
249 return bld_type_temp(result);
250 } /* typ_gensub */
251
252
253
typ_gentype(listType arguments)254 objectType typ_gentype (listType arguments)
255
256 {
257 typeType result;
258
259 /* typ_gentype */
260 logFunction(printf("typ_gentype\n"););
261 if ((result = new_type(prog, NULL, NULL)) == NULL) {
262 return raise_exception(SYS_MEM_EXCEPTION);
263 } /* if */
264 logFunction(printf("typ_gentype -->\n"););
265 return bld_type_temp(result);
266 } /* typ_gentype */
267
268
269
270 #ifdef OUT_OF_ORDER
typ_getinterfaces(listType arguments)271 objectType typ_getinterfaces (listType arguments)
272
273 {
274 typeType typ1;
275
276 /* typ_getinterfaces */
277 isit_type(arg_1(arguments));
278 typ1 = take_type(arg_1(arguments));
279 get_interfaces(typ1);
280 return SYS_EMPTY_OBJECT;
281 } /* typ_getinterfaces */
282 #endif
283
284
285
286 #ifdef OUT_OF_ORDER
typ_getcreate(listType arguments)287 objectType typ_getcreate (listType arguments)
288
289 {
290 typeType result;
291
292 /* typ_getcreate */
293 isit_type(arg_1(arguments));
294 ;
295 get_create_call_obj(take_type(arg_1(arguments)), errInfoType *err_info)
296 if ((result = new_type(prog, NULL, NULL)) == NULL) {
297 return raise_exception(SYS_MEM_EXCEPTION);
298 } /* if */
299 return bld_type_temp(result);
300 } /* typ_getcreate */
301 #endif
302
303
304
typ_hashcode(listType arguments)305 objectType typ_hashcode (listType arguments)
306
307 { /* typ_hashcode */
308 isit_type(arg_1(arguments));
309 return bld_int_temp((intType)
310 (((memSizeType) take_type(arg_1(arguments))) >> 6));
311 } /* typ_hashcode */
312
313
314
typ_isdeclared(listType arguments)315 objectType typ_isdeclared (listType arguments)
316
317 {
318 objectType result;
319
320 /* typ_isdeclared */
321 if (CATEGORY_OF_OBJ(arg_1(arguments)) == DECLAREDOBJECT) {
322 result = SYS_TRUE_OBJECT;
323 } else {
324 result = SYS_FALSE_OBJECT;
325 } /* if */
326 return result;
327 } /* typ_isdeclared */
328
329
330
typ_isderived(listType arguments)331 objectType typ_isderived (listType arguments)
332
333 {
334 typeType any_type;
335 objectType result;
336
337 /* typ_isderived */
338 isit_type(arg_1(arguments));
339 any_type = take_type(arg_1(arguments));
340 if (any_type->meta != NULL) {
341 result = SYS_TRUE_OBJECT;
342 } else {
343 result = SYS_FALSE_OBJECT;
344 } /* if */
345 return result;
346 } /* typ_isderived */
347
348
349
typ_isforward(listType arguments)350 objectType typ_isforward (listType arguments)
351
352 {
353 objectType result;
354
355 /* typ_isforward */
356 if (CATEGORY_OF_OBJ(arg_1(arguments)) == FORWARDOBJECT) {
357 result = SYS_TRUE_OBJECT;
358 } else {
359 result = SYS_FALSE_OBJECT;
360 } /* if */
361 return result;
362 } /* typ_isforward */
363
364
365
typ_isfunc(listType arguments)366 objectType typ_isfunc (listType arguments)
367
368 {
369 typeType any_type;
370 objectType result;
371
372 /* typ_isfunc */
373 isit_type(arg_1(arguments));
374 any_type = take_type(arg_1(arguments));
375 if (any_type->result_type != NULL && !any_type->is_varfunc_type) {
376 result = SYS_TRUE_OBJECT;
377 } else {
378 result = SYS_FALSE_OBJECT;
379 } /* if */
380 return result;
381 } /* typ_isfunc */
382
383
384
typ_isvarfunc(listType arguments)385 objectType typ_isvarfunc (listType arguments)
386
387 {
388 typeType any_type;
389 objectType result;
390
391 /* typ_isvarfunc */
392 isit_type(arg_1(arguments));
393 any_type = take_type(arg_1(arguments));
394 if (any_type->result_type != NULL && any_type->is_varfunc_type) {
395 result = SYS_TRUE_OBJECT;
396 } else {
397 result = SYS_FALSE_OBJECT;
398 } /* if */
399 return result;
400 } /* typ_isvarfunc */
401
402
403
typ_matchobj(listType arguments)404 objectType typ_matchobj (listType arguments)
405
406 {
407 typeType actual_type;
408 objectType result;
409
410 /* typ_matchobj */
411 isit_type(arg_1(arguments));
412 actual_type = take_type(arg_1(arguments));
413 result = actual_type->match_obj;
414 return bld_reference_temp(result);
415 } /* typ_matchobj */
416
417
418
typ_meta(listType arguments)419 objectType typ_meta (listType arguments)
420
421 {
422 typeType any_type;
423 typeType result;
424
425 /* typ_meta */
426 logFunction(printf("typ_meta\n"););
427 isit_type(arg_1(arguments));
428 any_type = take_type(arg_1(arguments));
429 if (any_type->meta == NULL) {
430 logError(printf("typ_meta(");
431 trace1(arg_1(arguments));
432 printf("): No meta type.\n"););
433 return raise_exception(SYS_RNG_EXCEPTION);
434 } /* if */
435 result = any_type->meta;
436 logFunction(printf("typ_meta -->\n"););
437 return bld_type_temp(result);
438 } /* typ_meta */
439
440
441
442 /**
443 * Check if two types are not equal.
444 * @return TRUE if the two types are equal,
445 * FALSE otherwise.
446 */
typ_ne(listType arguments)447 objectType typ_ne (listType arguments)
448
449 {
450 typeType type1;
451 typeType type2;
452
453 /* typ_ne */
454 isit_type(arg_1(arguments));
455 isit_type(arg_3(arguments));
456 type1 = take_type(arg_1(arguments));
457 type2 = take_type(arg_3(arguments));
458 if (type1 != type2) {
459 return SYS_TRUE_OBJECT;
460 } else {
461 return SYS_FALSE_OBJECT;
462 } /* if */
463 } /* typ_ne */
464
465
466
typ_num(listType arguments)467 objectType typ_num (listType arguments)
468
469 { /* typ_num */
470 isit_type(arg_1(arguments));
471 return bld_int_temp(
472 typNum(take_type(arg_1(arguments))));
473 } /* typ_num */
474
475
476
typ_result(listType arguments)477 objectType typ_result (listType arguments)
478
479 {
480 typeType any_type;
481 typeType result;
482
483 /* typ_result */
484 logFunction(printf("typ_result\n"););
485 isit_type(arg_1(arguments));
486 any_type = take_type(arg_1(arguments));
487 if (any_type->result_type == NULL) {
488 logError(printf("typ_result(");
489 trace1(arg_1(arguments));
490 printf("): No result type.\n"););
491 return raise_exception(SYS_RNG_EXCEPTION);
492 } /* if */
493 result = any_type->result_type;
494 logFunction(printf("typ_result\n"););
495 return bld_type_temp(result);
496 } /* typ_result */
497
498
499
typ_set_in_param_ref(listType arguments)500 objectType typ_set_in_param_ref (listType arguments)
501
502 { /* typ_set_in_param_ref */
503 isit_type(arg_1(arguments));
504 take_type(arg_1(arguments))->in_param_type = PARAM_REF;
505 return SYS_EMPTY_OBJECT;
506 } /* typ_set_in_param_ref */
507
508
509
typ_set_in_param_value(listType arguments)510 objectType typ_set_in_param_value (listType arguments)
511
512 { /* typ_set_in_param_value */
513 isit_type(arg_1(arguments));
514 take_type(arg_1(arguments))->in_param_type = PARAM_VALUE;
515 return SYS_EMPTY_OBJECT;
516 } /* typ_set_in_param_value */
517
518
519
typ_str(listType arguments)520 objectType typ_str (listType arguments)
521
522 { /* typ_str */
523 isit_type(arg_1(arguments));
524 return bld_stri_temp(
525 typStr(take_type(arg_1(arguments))));
526 } /* typ_str */
527
528
529
530 /**
531 * Get 'type' value of the object referenced by 'aReference/arg_1'.
532 * @return the 'type' value of the referenced object.
533 * @exception RANGE_ERROR If 'aReference/arg_1' is NIL or
534 * category(aReference) <> TYPEOBJECT holds.
535 */
typ_value(listType arguments)536 objectType typ_value (listType arguments)
537
538 {
539 objectType aReference;
540
541 /* typ_value */
542 isit_reference(arg_1(arguments));
543 aReference = take_reference(arg_1(arguments));
544 if (unlikely(aReference == NULL ||
545 CATEGORY_OF_OBJ(aReference) != TYPEOBJECT)) {
546 logError(printf("typ_value(");
547 trace1(aReference);
548 printf("): Category is not TYPEOBJECT.\n"););
549 return raise_exception(SYS_RNG_EXCEPTION);
550 } else {
551 return aReference;
552 } /* if */
553 } /* typ_value */
554
555
556
typ_varconv(listType arguments)557 objectType typ_varconv (listType arguments)
558
559 { /* typ_varconv */
560 is_variable(arg_3(arguments));
561 if (TEMP_OBJECT(arg_3(arguments))) {
562 prot_cstri("TYP_VARCONV of TEMP_OBJECT ");
563 trace1(arg_3(arguments));
564 prot_nl();
565 } /* if */
566 return arg_3(arguments);
567 } /* typ_varconv */
568
569
570
typ_varfunc(listType arguments)571 objectType typ_varfunc (listType arguments)
572
573 {
574 typeType basic_type;
575 typeType result;
576
577 /* typ_varfunc */
578 logFunction(printf("typ_varfunc\n"););
579 isit_type(arg_2(arguments));
580 basic_type = take_type(arg_2(arguments));
581 if ((result = get_varfunc_type(NULL, basic_type)) == NULL) {
582 return raise_exception(SYS_MEM_EXCEPTION);
583 } /* if */
584 /* printf("typ_varfunc ");
585 printobject(result);
586 prot_cstri("=");
587 prot_int((intType) result);
588 printf("\n"); */
589 logFunction(printf("typ_varfunc -->\n"););
590 return bld_type_temp(result);
591 } /* typ_varfunc */
592