1 /*
2 Copyright (C) 2005-2014, Parrot Foundation.
3
4 =head1 NAME
5
6 src/hll.c - High Level Language support
7
8 =head1 DESCRIPTION
9
10 The Parrot core sometimes has to create new PMCs which should map to the
11 current HLL's defaults. The current language and a typemap provides this
12 feature.
13
14 =head1 DATA
15
16 interp->HLL_info
17
18 @HLL_info = [
19 [ hll_name, hll_lib, { core_type => HLL_type, ... }, namespace, hll_id ],
20 ...
21 ]
22
23 =head2 Functions
24
25 =over 4
26
27 =cut
28
29 */
30
31 #include "parrot/parrot.h"
32 #include "parrot/dynext.h"
33 #include "pmc/pmc_callcontext.h"
34 #include "pmc/pmc_fixedintegerarray.h"
35 #include "hll.str"
36
37 /* HEADERIZER HFILE: include/parrot/hll.h */
38
39 /* HEADERIZER BEGIN: static */
40 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
41
42 PARROT_CANNOT_RETURN_NULL
43 PARROT_WARN_UNUSED_RESULT
44 static PMC* new_hll_entry(PARROT_INTERP, ARGIN(STRING *entry_name))
45 __attribute__nonnull__(1)
46 __attribute__nonnull__(2);
47
48 #define ASSERT_ARGS_new_hll_entry __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
49 PARROT_ASSERT_ARG(interp) \
50 , PARROT_ASSERT_ARG(entry_name))
51 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
52 /* HEADERIZER END: static */
53
54 /* for shared HLL data, do COW stuff */
55 #define START_READ_HLL_INFO(interp, hll_info)
56 #define END_READ_HLL_INFO(interp, hll_info)
57
58
59 /*
60
61 =item C<static PMC* new_hll_entry(PARROT_INTERP, STRING *entry_name)>
62
63 Create a new HLL information table entry.
64 Takes an interpreter name and (optional) entry name.
65 Returns a pointer to the new entry.
66 Used by Parrot_hll_register_HLL.
67
68 =cut
69
70 */
71
72 PARROT_CANNOT_RETURN_NULL
73 PARROT_WARN_UNUSED_RESULT
74 static PMC*
new_hll_entry(PARROT_INTERP,ARGIN (STRING * entry_name))75 new_hll_entry(PARROT_INTERP, ARGIN(STRING *entry_name))
76 {
77 ASSERT_ARGS(new_hll_entry)
78 PMC * const hll_info = interp->HLL_info;
79 const INTVAL id = VTABLE_elements(interp, hll_info);
80 PMC *entry_id;
81
82 PMC * const entry = Parrot_pmc_new_init_int(interp,
83 enum_class_FixedPMCArray, e_HLL_MAX);
84
85 if (entry_name && !STRING_IS_EMPTY(entry_name))
86 VTABLE_set_pmc_keyed_str(interp, hll_info, entry_name, entry);
87 else
88 VTABLE_push_pmc(interp, hll_info, entry);
89
90 entry_id = Parrot_pmc_new_init_int(interp, enum_class_Integer, id);
91 VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_id, entry_id);
92
93 VTABLE_push_pmc(interp, interp->HLL_entries, entry);
94 return entry;
95 }
96
97
98 /*
99
100 =item C<void Parrot_hll_init_HLL(PARROT_INTERP)>
101
102 Initialises the HLL_info and HLL_namespace fields of the interpreter structure.
103 Registers the default HLL namespace "parrot".
104
105 =cut
106
107 */
108
109 void
Parrot_hll_init_HLL(PARROT_INTERP)110 Parrot_hll_init_HLL(PARROT_INTERP)
111 {
112 ASSERT_ARGS(Parrot_hll_init_HLL)
113 interp->HLL_info =
114 Parrot_pmc_new(interp, enum_class_OrderedHash);
115 interp->HLL_namespace =
116 Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
117 interp->HLL_entries =
118 Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
119
120 Parrot_hll_register_HLL(interp, CONST_STRING(interp, "parrot"));
121 }
122
123 /*
124
125 =item C<INTVAL Parrot_hll_register_HLL(PARROT_INTERP, STRING *hll_name)>
126
127 Register the HLL with the given STRING name C<hll_name> in the interpreter.
128
129 If the HLL has already been registered, the ID of the HLL is returned.
130 Otherwise the HLL is registered, a corresponding HLL namespace is created,
131 and the HLL ID is returned.
132
133 If there is an error, C<-1> is returned.
134
135 =cut
136
137 */
138
139 PARROT_EXPORT
140 PARROT_IGNORABLE_RESULT
141 INTVAL
Parrot_hll_register_HLL(PARROT_INTERP,ARGIN (STRING * hll_name))142 Parrot_hll_register_HLL(PARROT_INTERP, ARGIN(STRING *hll_name))
143 {
144 ASSERT_ARGS(Parrot_hll_register_HLL)
145 PMC *entry, *name, *ns_hash, *hll_info;
146 INTVAL idx;
147
148 /* TODO LOCK or disallow in threads */
149
150 idx = Parrot_hll_get_HLL_id(interp, hll_name);
151
152 if (idx >= 0)
153 return idx;
154
155 hll_info = interp->HLL_info;
156
157 idx = VTABLE_elements(interp, hll_info);
158 entry = new_hll_entry(interp, hll_name);
159
160 /* register HLL name */
161 name = Parrot_pmc_new(interp, enum_class_String);
162
163 VTABLE_set_string_native(interp, name, hll_name);
164 VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_name, name);
165
166 /* create HLL namespace */
167 hll_name = Parrot_str_downcase(interp, VTABLE_get_string(interp, name));
168
169 /* HLL type mappings aren't yet created, we can't create
170 * a namespace in HLL's flavor yet - maybe promote the
171 * ns_hash to another type, if mappings provide one
172 * XXX - FIXME
173 */
174 ns_hash = Parrot_ns_make_namespace_keyed_str(interp, interp->root_namespace,
175 hll_name);
176
177 /* cache HLL's toplevel namespace */
178 VTABLE_set_pmc_keyed_int(interp, interp->HLL_namespace, idx, ns_hash);
179
180 /* create HLL typemap hash */
181 VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_typemap, PMCNULL);
182
183 return idx;
184 }
185
186
187 /*
188
189 =item C<INTVAL Parrot_hll_get_HLL_id(PARROT_INTERP, STRING *hll_name)>
190
191 Returns the ID number of the HLL with the given name. The default HLL namespace
192 C<parrot> has an ID number of 0. On error, or if an HLL with the given name
193 does not exist, returns -1.
194
195 =cut
196
197 */
198
199 PARROT_EXPORT
200 PARROT_WARN_UNUSED_RESULT
201 INTVAL
Parrot_hll_get_HLL_id(PARROT_INTERP,ARGIN (STRING * hll_name))202 Parrot_hll_get_HLL_id(PARROT_INTERP, ARGIN(STRING *hll_name))
203 {
204 ASSERT_ARGS(Parrot_hll_get_HLL_id)
205 PMC * entry;
206 PMC * const hll_info = interp->HLL_info;
207 INTVAL i = -1;
208
209 if (STRING_IS_NULL(hll_name))
210 return i;
211
212 START_READ_HLL_INFO(interp, hll_info);
213
214 entry = VTABLE_get_pmc_keyed_str(interp, hll_info, hll_name);
215
216 if (!PMC_IS_NULL(entry)) {
217 PMC * const entry_id = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_id);
218 i = VTABLE_get_integer(interp, entry_id);
219 }
220
221 END_READ_HLL_INFO(interp, hll_info);
222
223 return i;
224 }
225
226 /*
227
228 =item C<STRING * Parrot_hll_get_HLL_name(PARROT_INTERP, INTVAL id)>
229
230 Returns the STRING name of the HLL with the given C<id> number. If the id
231 is out of range or does not exist, the NULL value is returned instead. Note
232 that some HLLs are anonymous and so might also return NULL.
233
234 =cut
235
236 */
237
238 PARROT_EXPORT
239 PARROT_WARN_UNUSED_RESULT
240 PARROT_CANNOT_RETURN_NULL
241 STRING *
Parrot_hll_get_HLL_name(PARROT_INTERP,INTVAL id)242 Parrot_hll_get_HLL_name(PARROT_INTERP, INTVAL id)
243 {
244 ASSERT_ARGS(Parrot_hll_get_HLL_name)
245 PMC * const hll_info = interp->HLL_info;
246 const INTVAL nelements = VTABLE_elements(interp, hll_info);
247
248 PMC *entry, *name_pmc;
249
250 if (id < 0 || id >= nelements)
251 return STRINGNULL;
252
253 START_READ_HLL_INFO(interp, hll_info);
254
255 entry = VTABLE_get_pmc_keyed_int(interp, hll_info, id);
256 name_pmc = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_name);
257
258 END_READ_HLL_INFO(interp, hll_info);
259
260 /* loadlib-created 'HLL's are nameless */
261 if (PMC_IS_NULL(name_pmc))
262 return STRINGNULL;
263 else
264 return VTABLE_get_string(interp, name_pmc);
265 }
266
267 /*
268
269 =item C<void Parrot_hll_register_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL
270 core_type, INTVAL hll_type)>
271
272 Register a type mapping of C<< core_type => hll_type >> for the given HLL.
273
274 =cut
275
276 */
277
278 PARROT_EXPORT
279 void
Parrot_hll_register_HLL_type(PARROT_INTERP,INTVAL hll_id,INTVAL core_type,INTVAL hll_type)280 Parrot_hll_register_HLL_type(PARROT_INTERP, INTVAL hll_id,
281 INTVAL core_type, INTVAL hll_type)
282 {
283 ASSERT_ARGS(Parrot_hll_register_HLL_type)
284
285 if (hll_id == Parrot_hll_get_HLL_id(interp, CONST_STRING(interp, "parrot")))
286 Parrot_ex_throw_from_c_noargs(interp, EXCEPTION_INVALID_OPERATION,
287 "Cannot map without an HLL");
288 else {
289 PMC * const hll_info = interp->HLL_info;
290 const INTVAL n = VTABLE_elements(interp, hll_info);
291 if (hll_id >= n)
292 Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
293 "no such HLL ID (%vd)", hll_id);
294 else {
295 PMC *type_array;
296 PMC * const entry = VTABLE_get_pmc_keyed_int(interp, hll_info, hll_id);
297 PARROT_ASSERT(!PMC_IS_NULL(entry));
298 type_array = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap);
299 if (PMC_IS_NULL(type_array)) {
300 int i;
301 type_array = Parrot_pmc_new(interp, enum_class_FixedIntegerArray);
302 VTABLE_set_integer_native(interp, type_array, PARROT_MAX_CLASSES);
303 for (i = 0; i < PARROT_MAX_CLASSES; ++i)
304 VTABLE_set_integer_keyed_int(interp, type_array, i, i);
305 VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_typemap, type_array);
306 }
307 VTABLE_set_integer_keyed_int(interp, type_array, core_type, hll_type);
308 }
309 }
310 }
311
312 /*
313
314 =item C<INTVAL Parrot_hll_get_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL
315 core_type)>
316
317 Get an equivalent HLL type number for the language C<hll_id>. If the given HLL
318 doesn't remap the given type, or if C<hll_id> is the special value
319 C<PARROT_HLL_NONE>, returns C<core_type> unchanged.
320
321 =cut
322
323 */
324
325 PARROT_EXPORT
326 INTVAL
Parrot_hll_get_HLL_type(PARROT_INTERP,INTVAL hll_id,INTVAL core_type)327 Parrot_hll_get_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL core_type)
328 {
329 ASSERT_ARGS(Parrot_hll_get_HLL_type)
330
331 if (hll_id == PARROT_HLL_NONE || hll_id == 0)
332 return core_type;
333
334 if (hll_id < 0)
335 Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
336 "no such HLL ID (%vd)", hll_id);
337 else {
338 PMC * const hll_info = interp->HLL_info;
339 PMC *entry, *type_array;
340 Parrot_FixedIntegerArray_attributes *type_array_attrs;
341
342 START_READ_HLL_INFO(interp, hll_info);
343 entry = VTABLE_get_pmc_keyed_int(interp, hll_info, hll_id);
344 END_READ_HLL_INFO(interp, hll_info);
345
346 if (PMC_IS_NULL(entry))
347 Parrot_ex_throw_from_c_args(interp, NULL,
348 EXCEPTION_GLOBAL_NOT_FOUND, "no such HLL ID (%vd)", hll_id);
349
350 type_array = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap);
351
352 if (PMC_IS_NULL(type_array))
353 return core_type;
354
355 if (core_type >= PARROT_MAX_CLASSES || core_type < 0) {
356 Parrot_ex_throw_from_c_noargs(interp, EXCEPTION_OUT_OF_BOUNDS,
357 "index out of bounds");
358 }
359
360 type_array_attrs = PARROT_FIXEDINTEGERARRAY(type_array);
361 return type_array_attrs->int_array[core_type];
362 }
363 }
364
365 /*
366
367 =item C<INTVAL Parrot_hll_get_ctx_HLL_type(PARROT_INTERP, INTVAL core_type)>
368
369 Return an equivalent PMC type number according to the HLL settings in
370 the current context. If no type is registered, returns C<core_type>.
371
372 =cut
373
374 */
375
376 PARROT_EXPORT
377 INTVAL
Parrot_hll_get_ctx_HLL_type(PARROT_INTERP,INTVAL core_type)378 Parrot_hll_get_ctx_HLL_type(PARROT_INTERP, INTVAL core_type)
379 {
380 ASSERT_ARGS(Parrot_hll_get_ctx_HLL_type)
381 const INTVAL hll_id = Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp));
382 if (!hll_id || hll_id == PARROT_HLL_NONE)
383 return core_type;
384
385 return Parrot_hll_get_HLL_type(interp, hll_id, core_type);
386 }
387
388 /*
389
390 =item C<PMC* Parrot_hll_get_ctx_HLL_namespace(PARROT_INTERP)>
391
392 Return root namespace of the current HLL.
393
394 =cut
395
396 */
397
398 PARROT_EXPORT
399 PARROT_WARN_UNUSED_RESULT
400 PARROT_CAN_RETURN_NULL
401 PMC*
Parrot_hll_get_ctx_HLL_namespace(PARROT_INTERP)402 Parrot_hll_get_ctx_HLL_namespace(PARROT_INTERP)
403 {
404 ASSERT_ARGS(Parrot_hll_get_ctx_HLL_namespace)
405 return Parrot_hll_get_HLL_namespace(interp,
406 Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp)));
407 }
408
409 /*
410
411 =item C<PMC* Parrot_hll_get_HLL_namespace(PARROT_INTERP, int hll_id)>
412
413 Return root namespace of the HLL with the ID of I<hll_id>. If C<hll_id> is the
414 special value C<PARROT_HLL_NONE>, return the global root namespace.
415
416 =cut
417
418 */
419
420 PARROT_EXPORT
421 PARROT_WARN_UNUSED_RESULT
422 PARROT_CANNOT_RETURN_NULL
423 PMC*
Parrot_hll_get_HLL_namespace(PARROT_INTERP,int hll_id)424 Parrot_hll_get_HLL_namespace(PARROT_INTERP, int hll_id)
425 {
426 ASSERT_ARGS(Parrot_hll_get_HLL_namespace)
427 if (hll_id == PARROT_HLL_NONE)
428 return interp->root_namespace;
429
430 return VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id);
431 }
432
433 /*
434
435 =item C<void Parrot_hll_regenerate_HLL_namespaces(PARROT_INTERP)>
436
437 Create all HLL namespaces that don't already exist. This is necessary when
438 creating a new interpreter which shares an old interpreter's HLL_info.
439
440 =cut
441
442 */
443
444 PARROT_EXPORT
445 void
Parrot_hll_regenerate_HLL_namespaces(PARROT_INTERP)446 Parrot_hll_regenerate_HLL_namespaces(PARROT_INTERP)
447 {
448 ASSERT_ARGS(Parrot_hll_regenerate_HLL_namespaces)
449 const INTVAL n = VTABLE_elements(interp, interp->HLL_info);
450 INTVAL hll_id;
451
452 /* start at one since the 'parrot' namespace should already have been
453 * created */
454
455 for (hll_id = 1; hll_id < n; ++hll_id) {
456 PMC *ns_hash =
457 VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id);
458
459 if (PMC_IS_NULL(ns_hash) ||
460 ns_hash->vtable->base_type == enum_class_Undef)
461 {
462 STRING * hll_name = Parrot_hll_get_HLL_name(interp, hll_id);
463 if (!hll_name)
464 continue;
465
466 hll_name = Parrot_str_downcase(interp, hll_name);
467
468 /* XXX as in Parrot_hll_register_HLL() this needs to be fixed to use
469 * the correct type of namespace. It's relatively easy to do that
470 * here because the typemap already exists, but it is not currently
471 * done for consistency.
472 */
473 ns_hash = Parrot_ns_make_namespace_keyed_str(interp,
474 interp->root_namespace, hll_name);
475
476 VTABLE_set_pmc_keyed_int(interp, interp->HLL_namespace,
477 hll_id, ns_hash);
478 }
479 }
480 }
481
482 /*
483
484 =back
485
486 =head1 AUTHOR
487
488 Leopold Toetsch
489
490 =head1 SEE ALSO
491
492 F<include/parrot/hll.h>
493
494 =cut
495
496 */
497
498 /*
499 * Local variables:
500 * c-file-style: "parrot"
501 * End:
502 * vim: expandtab shiftwidth=4 cinoptions='\:2=2' :
503 */
504