1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2013, 2015, 2021 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: General */
22 /* File: seed7/src/typeutl.c */
23 /* Changes: 1999, 2013, 2015, 2021 Thomas Mertes */
24 /* Content: Procedures to maintain objects of type typeType. */
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
36 #include "common.h"
37 #include "data.h"
38 #include "heaputl.h"
39 #include "flistutl.h"
40 #include "listutl.h"
41 #include "identutl.h"
42 #include "entutl.h"
43 #include "traceutl.h"
44
45 #undef EXTERN
46 #define EXTERN
47 #include "typeutl.h"
48
49
50
new_type(progType owningProg,typeType meta_type,typeType result_type)51 typeType new_type (progType owningProg, typeType meta_type, typeType result_type)
52
53 {
54 objectType match_obj;
55 listType list_elem;
56 typeType created_type;
57
58 /* new_type */
59 logFunction(printf("new_type(" FMT_U_MEM ", ", (memSizeType) owningProg);
60 printtype(meta_type);
61 printf(", ");
62 printtype(result_type);
63 printf(")\n"););
64 if (ALLOC_OBJECT(match_obj)) {
65 if (ALLOC_L_ELEM(list_elem)) {
66 if (ALLOC_RECORD(created_type, typeRecord, count.type)) {
67 match_obj->type_of = NULL;
68 match_obj->descriptor.property = NULL;
69 match_obj->value.typeValue = created_type;
70 INIT_CATEGORY_OF_OBJ(match_obj, TYPEOBJECT);
71 created_type->match_obj = match_obj;
72 created_type->meta = meta_type;
73 created_type->func_type = NULL;
74 created_type->varfunc_type = NULL;
75 created_type->result_type = result_type;
76 created_type->is_varfunc_type = FALSE;
77 if (meta_type != NULL) {
78 created_type->in_param_type = meta_type->in_param_type;
79 } else {
80 created_type->in_param_type = PARAM_UNDEFINED;
81 } /* if */
82 created_type->interfaces = NULL;
83 created_type->name = NULL;
84 created_type->owningProg = owningProg;
85 created_type->inout_f_param_prototype = NULL;
86 created_type->other_f_param_prototype = NULL;
87 created_type->create_call_obj = NULL;
88 created_type->destroy_call_obj = NULL;
89 created_type->copy_call_obj = NULL;
90 created_type->ord_call_obj = NULL;
91 created_type->in_call_obj = NULL;
92 created_type->value_obj = NULL;
93 list_elem->obj = match_obj;
94 list_elem->next = owningProg->types;
95 owningProg->types = list_elem;
96 } else {
97 FREE_L_ELEM(list_elem);
98 FREE_OBJECT(match_obj);
99 created_type = NULL;
100 } /* if */
101 } else {
102 FREE_OBJECT(match_obj);
103 created_type = NULL;
104 } /* if */
105 } else {
106 created_type = NULL;
107 } /* if */
108 logFunction(printf("new_type --> ");
109 printtype(created_type);
110 printf("\n"););
111 return created_type;
112 } /* new_type */
113
114
115
free_type(typeType old_type)116 static void free_type (typeType old_type)
117
118 {
119 typeListType typelist_elem;
120 typeListType next_elem;
121
122 /* free_type */
123 logFunction(printf("free_type(");
124 printtype(old_type);
125 printf(")\n"););
126 FREE_OBJECT(old_type->match_obj);
127 typelist_elem = old_type->interfaces;
128 while (typelist_elem != NULL) {
129 next_elem = typelist_elem->next;
130 FREE_RECORD(typelist_elem, typeListRecord, count.typelist_elems);
131 typelist_elem = next_elem;
132 } /* while */
133 FREE_RECORD(old_type, typeRecord, count.type);
134 logFunction(printf("free_type -->\n"););
135 } /* free_type */
136
137
138
close_type(progType currentProg)139 void close_type (progType currentProg)
140
141 {
142 listType type_elem;
143 listType next_elem;
144
145 /* close_type */
146 logFunction(printf("close_type\n"););
147 type_elem = currentProg->types;
148 while (type_elem != NULL) {
149 next_elem = type_elem->next;
150 free_type(type_elem->obj->value.typeValue);
151 type_elem = next_elem;
152 } /* while */
153 free_list(currentProg->types);
154 logFunction(printf("close_type -->\n"););
155 } /* close_type */
156
157
158
get_func_type(typeType meta_type,typeType basic_type)159 typeType get_func_type (typeType meta_type, typeType basic_type)
160
161 {
162 typeType func_type;
163
164 /* get_func_type */
165 logFunction(printf("get_func_type(");
166 printtype(meta_type);
167 printf(", ");
168 printtype(basic_type);
169 printf(")\n"););
170 if (basic_type->func_type != NULL) {
171 func_type = basic_type->func_type;
172 } else {
173 func_type = new_type(basic_type->owningProg, meta_type, basic_type);
174 basic_type->func_type = func_type;
175 } /* if */
176 logFunction(printf("get_func_type --> ");
177 printtype(func_type);
178 printf("\n"););
179 return func_type;
180 } /* get_func_type */
181
182
183
get_varfunc_type(typeType meta_type,typeType basic_type)184 typeType get_varfunc_type (typeType meta_type, typeType basic_type)
185
186 {
187 typeType varfunc_type;
188
189 /* get_varfunc_type */
190 logFunction(printf("get_varfunc_type(");
191 printtype(meta_type);
192 printf(", ");
193 printtype(basic_type);
194 printf(")\n"););
195 if (basic_type->varfunc_type != NULL) {
196 varfunc_type = basic_type->varfunc_type;
197 } else {
198 varfunc_type = new_type(basic_type->owningProg, meta_type, basic_type);
199 if (varfunc_type != NULL) {
200 varfunc_type->is_varfunc_type = TRUE;
201 } /* if */
202 basic_type->varfunc_type = varfunc_type;
203 } /* if */
204 logFunction(printf("get_varfunc_type --> ");
205 printtype(varfunc_type);
206 printf("\n"););
207 return varfunc_type;
208 } /* get_varfunc_type */
209
210
211
add_interface(typeType basic_type,typeType interface_type)212 void add_interface (typeType basic_type, typeType interface_type)
213
214 {
215 typeListType typelist_elem;
216 typeListType current_elem;
217
218 /* add_interface */
219 logFunction(printf("add_interface(");
220 printtype(basic_type);
221 printf(", ");
222 printtype(interface_type);
223 printf(")\n"););
224 if (ALLOC_RECORD(typelist_elem, typeListRecord, count.typelist_elems)) {
225 typelist_elem->next = NULL;
226 typelist_elem->type_elem = interface_type;
227 if (basic_type->interfaces == NULL) {
228 basic_type->interfaces = typelist_elem;
229 } else {
230 current_elem = basic_type->interfaces;
231 while (current_elem->next != NULL) {
232 current_elem = current_elem->next;
233 } /* while */
234 current_elem->next = typelist_elem;
235 } /* if */
236 } /* if */
237 logFunction(printf("add_interface\n"););
238 } /* add_interface */
239
240
241
242 #ifdef OUT_OF_ORDER
get_interfaces(typeType basic_type)243 void get_interfaces (typeType basic_type)
244
245 {
246 typeListType typelist_elem;
247 listType *list_insert_place;
248 errInfoType err_info = OKAY_NO_ERROR;
249 listType result;
250
251 /* get_interfaces */
252 result = NULL;
253 list_insert_place = &result;
254 typelist_elem = basic_type->interfaces;
255 while (typelist_elem->next != NULL) {
256 list_insert_place = append_element_to_list(list_insert_place,
257 typelist_elem->type_elem, &err_info);
258 typelist_elem = typelist_elem->next;
259 } /* while */
260 if (err_info != OKAY_NO_ERROR) {
261 free_list(result);
262 return raise_exception(SYS_MEM_EXCEPTION);
263 } /* if */
264 return bld_reflist_temp(result);
265 } /* get_interfaces */
266 #endif
267