Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: 210ad264c4
Fetching contributors…

Cannot retrieve contributors at this time

507 lines (361 sloc) 13.394 kB
/*
Copyright (C) 2005-2011, Parrot Foundation.
=head1 NAME
src/hll.c - High Level Language support
=head1 DESCRIPTION
The Parrot core sometimes has to create new PMCs which should map to the
current HLL's defaults. The current language and a typemap provides this
feature.
=head1 DATA
interp->HLL_info
@HLL_info = [
[ hll_name, hll_lib, { core_type => HLL_type, ... }, namespace, hll_id ],
...
]
=head2 Functions
=over 4
=cut
*/
#include "parrot/parrot.h"
#include "parrot/dynext.h"
#include "pmc/pmc_callcontext.h"
#include "pmc/pmc_fixedintegerarray.h"
#include "hll.str"
/* HEADERIZER HFILE: include/parrot/hll.h */
/* HEADERIZER BEGIN: static */
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
PARROT_CANNOT_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
static PMC* new_hll_entry(PARROT_INTERP, ARGIN(STRING *entry_name))
__attribute__nonnull__(1)
__attribute__nonnull__(2);
#define ASSERT_ARGS_new_hll_entry __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(entry_name))
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
/* HEADERIZER END: static */
/* for shared HLL data, do COW stuff */
#define START_READ_HLL_INFO(interp, hll_info)
#define END_READ_HLL_INFO(interp, hll_info)
/*
=item C<static PMC* new_hll_entry(PARROT_INTERP, STRING *entry_name)>
Create a new HLL information table entry.
Takes an interpreter name and (optional) entry name.
Returns a pointer to the new entry.
Used by Parrot_hll_register_HLL.
=cut
*/
PARROT_CANNOT_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
static PMC*
new_hll_entry(PARROT_INTERP, ARGIN(STRING *entry_name))
{
ASSERT_ARGS(new_hll_entry)
PMC * const hll_info = interp->HLL_info;
const INTVAL id = VTABLE_elements(interp, hll_info);
PMC *entry_id;
PMC * const entry = Parrot_pmc_new_init_int(interp,
enum_class_FixedPMCArray, e_HLL_MAX);
if (entry_name && !STRING_IS_EMPTY(entry_name)) {
VTABLE_set_pmc_keyed_str(interp, hll_info, entry_name, entry);
}
else
VTABLE_push_pmc(interp, hll_info, entry);
entry_id = Parrot_pmc_new_init_int(interp, enum_class_Integer, id);
VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_id, entry_id);
VTABLE_push_pmc(interp, interp->HLL_entries, entry);
return entry;
}
/*
=item C<void Parrot_hll_init_HLL(PARROT_INTERP)>
Initialises the HLL_info and HLL_namespace fields of the interpreter structure.
Registers the default HLL namespace "parrot".
=cut
*/
void
Parrot_hll_init_HLL(PARROT_INTERP)
{
ASSERT_ARGS(Parrot_hll_init_HLL)
interp->HLL_info =
Parrot_pmc_new(interp, enum_class_OrderedHash);
interp->HLL_namespace =
Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
interp->HLL_entries =
Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
Parrot_hll_register_HLL(interp, CONST_STRING(interp, "parrot"));
}
/*
=item C<INTVAL Parrot_hll_register_HLL(PARROT_INTERP, STRING *hll_name)>
Register the HLL with the given STRING name C<hll_name> in the interpreter.
If the HLL has already been registered, the ID of the HLL is returned.
Otherwise the HLL is registered, a corresponding HLL namespace is created,
and the HLL ID is returned.
If there is an error, C<-1> is returned.
=cut
*/
PARROT_EXPORT
PARROT_IGNORABLE_RESULT
INTVAL
Parrot_hll_register_HLL(PARROT_INTERP, ARGIN(STRING *hll_name))
{
ASSERT_ARGS(Parrot_hll_register_HLL)
PMC *entry, *name, *ns_hash, *hll_info;
INTVAL idx;
/* TODO LOCK or disallow in threads */
idx = Parrot_hll_get_HLL_id(interp, hll_name);
if (idx >= 0)
return idx;
hll_info = interp->HLL_info;
idx = VTABLE_elements(interp, hll_info);
entry = new_hll_entry(interp, hll_name);
/* register HLL name */
name = Parrot_pmc_new(interp, enum_class_String);
VTABLE_set_string_native(interp, name, hll_name);
VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_name, name);
/* create HLL namespace */
hll_name = Parrot_str_downcase(interp, VTABLE_get_string(interp, name));
/* HLL type mappings aren't yet created, we can't create
* a namespace in HLL's flavor yet - maybe promote the
* ns_hash to another type, if mappings provide one
* XXX - FIXME
*/
ns_hash = Parrot_ns_make_namespace_keyed_str(interp, interp->root_namespace,
hll_name);
/* cache HLL's toplevel namespace */
VTABLE_set_pmc_keyed_int(interp, interp->HLL_namespace, idx, ns_hash);
/* create HLL typemap hash */
VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_typemap, PMCNULL);
return idx;
}
/*
=item C<INTVAL Parrot_hll_get_HLL_id(PARROT_INTERP, STRING *hll_name)>
Returns the ID number of the HLL with the given name. The default HLL namespace
C<parrot> has an ID number of 0. On error, or if an HLL with the given name
does not exist, returns -1.
=cut
*/
PARROT_EXPORT
PARROT_WARN_UNUSED_RESULT
INTVAL
Parrot_hll_get_HLL_id(PARROT_INTERP, ARGIN(STRING *hll_name))
{
ASSERT_ARGS(Parrot_hll_get_HLL_id)
PMC * entry;
PMC * const hll_info = interp->HLL_info;
INTVAL i = -1;
if (STRING_IS_NULL(hll_name))
return i;
START_READ_HLL_INFO(interp, hll_info);
entry = VTABLE_get_pmc_keyed_str(interp, hll_info, hll_name);
if (!PMC_IS_NULL(entry)) {
PMC * const entry_id = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_id);
i = VTABLE_get_integer(interp, entry_id);
}
END_READ_HLL_INFO(interp, hll_info);
return i;
}
/*
=item C<STRING * Parrot_hll_get_HLL_name(PARROT_INTERP, INTVAL id)>
Returns the STRING name of the HLL with the given C<id> number. If the id
is out of range or does not exist, the NULL value is returned instead. Note
that some HLLs are anonymous and so might also return NULL.
=cut
*/
PARROT_EXPORT
PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
STRING *
Parrot_hll_get_HLL_name(PARROT_INTERP, INTVAL id)
{
ASSERT_ARGS(Parrot_hll_get_HLL_name)
PMC * const hll_info = interp->HLL_info;
const INTVAL nelements = VTABLE_elements(interp, hll_info);
PMC *entry, *name_pmc;
if (id < 0 || id >= nelements)
return STRINGNULL;
START_READ_HLL_INFO(interp, hll_info);
entry = VTABLE_get_pmc_keyed_int(interp, hll_info, id);
name_pmc = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_name);
END_READ_HLL_INFO(interp, hll_info);
/* loadlib-created 'HLL's are nameless */
if (PMC_IS_NULL(name_pmc))
return STRINGNULL;
else
return VTABLE_get_string(interp, name_pmc);
}
/*
=item C<void Parrot_hll_register_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL
core_type, INTVAL hll_type)>
Register a type mapping of C<< core_type => hll_type >> for the given HLL.
=cut
*/
PARROT_EXPORT
void
Parrot_hll_register_HLL_type(PARROT_INTERP, INTVAL hll_id,
INTVAL core_type, INTVAL hll_type)
{
ASSERT_ARGS(Parrot_hll_register_HLL_type)
if (hll_id == Parrot_hll_get_HLL_id(interp, CONST_STRING(interp, "parrot")))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Cannot map without an HLL");
else {
PMC * const hll_info = interp->HLL_info;
const INTVAL n = VTABLE_elements(interp, hll_info);
if (hll_id >= n)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
"no such HLL ID (%vd)", hll_id);
else {
PMC *type_array;
PMC * const entry = VTABLE_get_pmc_keyed_int(interp, hll_info, hll_id);
PARROT_ASSERT(!PMC_IS_NULL(entry));
type_array = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap);
if (PMC_IS_NULL(type_array)) {
int i;
type_array = Parrot_pmc_new(interp, enum_class_FixedIntegerArray);
VTABLE_set_integer_native(interp, type_array, PARROT_MAX_CLASSES);
for (i = 0; i < PARROT_MAX_CLASSES; ++i)
VTABLE_set_integer_keyed_int(interp, type_array, i, i);
VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_typemap, type_array);
}
VTABLE_set_integer_keyed_int(interp, type_array, core_type, hll_type);
}
}
}
/*
=item C<INTVAL Parrot_hll_get_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL
core_type)>
Get an equivalent HLL type number for the language C<hll_id>. If the given HLL
doesn't remap the given type, or if C<hll_id> is the special value
C<PARROT_HLL_NONE>, returns C<core_type> unchanged.
=cut
*/
PARROT_EXPORT
INTVAL
Parrot_hll_get_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL core_type)
{
ASSERT_ARGS(Parrot_hll_get_HLL_type)
if (hll_id == PARROT_HLL_NONE || hll_id == 0)
return core_type;
if (hll_id < 0)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
"no such HLL ID (%vd)", hll_id);
else {
PMC * const hll_info = interp->HLL_info;
PMC *entry, *type_array;
Parrot_FixedIntegerArray_attributes *type_array_attrs;
START_READ_HLL_INFO(interp, hll_info);
entry = VTABLE_get_pmc_keyed_int(interp, hll_info, hll_id);
END_READ_HLL_INFO(interp, hll_info);
if (PMC_IS_NULL(entry))
Parrot_ex_throw_from_c_args(interp, NULL,
EXCEPTION_GLOBAL_NOT_FOUND, "no such HLL ID (%vd)", hll_id);
type_array = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap);
if (PMC_IS_NULL(type_array))
return core_type;
if (core_type >= PARROT_MAX_CLASSES || core_type < 0) {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_OUT_OF_BOUNDS,
"FixedIntegerArray: index out of bounds!");
}
type_array_attrs = PARROT_FIXEDINTEGERARRAY(type_array);
return type_array_attrs->int_array[core_type];
}
}
/*
=item C<INTVAL Parrot_hll_get_ctx_HLL_type(PARROT_INTERP, INTVAL core_type)>
Return an equivalent PMC type number according to the HLL settings in
the current context. If no type is registered, returns C<core_type>.
=cut
*/
PARROT_EXPORT
INTVAL
Parrot_hll_get_ctx_HLL_type(PARROT_INTERP, INTVAL core_type)
{
ASSERT_ARGS(Parrot_hll_get_ctx_HLL_type)
const INTVAL hll_id = Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp));
if (!hll_id || hll_id == PARROT_HLL_NONE)
return core_type;
return Parrot_hll_get_HLL_type(interp, hll_id, core_type);
}
/*
=item C<PMC* Parrot_hll_get_ctx_HLL_namespace(PARROT_INTERP)>
Return root namespace of the current HLL.
=cut
*/
PARROT_EXPORT
PARROT_WARN_UNUSED_RESULT
PARROT_CAN_RETURN_NULL
PMC*
Parrot_hll_get_ctx_HLL_namespace(PARROT_INTERP)
{
ASSERT_ARGS(Parrot_hll_get_ctx_HLL_namespace)
return Parrot_hll_get_HLL_namespace(interp,
Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp)));
}
/*
=item C<PMC* Parrot_hll_get_HLL_namespace(PARROT_INTERP, int hll_id)>
Return root namespace of the HLL with the ID of I<hll_id>. If C<hll_id> is the
special value C<PARROT_HLL_NONE>, return the global root namespace.
=cut
*/
PARROT_EXPORT
PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
PMC*
Parrot_hll_get_HLL_namespace(PARROT_INTERP, int hll_id)
{
ASSERT_ARGS(Parrot_hll_get_HLL_namespace)
if (hll_id == PARROT_HLL_NONE)
return interp->root_namespace;
return VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id);
}
/*
=item C<void Parrot_hll_regenerate_HLL_namespaces(PARROT_INTERP)>
Create all HLL namespaces that don't already exist. This is necessary when
creating a new interpreter which shares an old interpreter's HLL_info.
=cut
*/
PARROT_EXPORT
void
Parrot_hll_regenerate_HLL_namespaces(PARROT_INTERP)
{
ASSERT_ARGS(Parrot_hll_regenerate_HLL_namespaces)
const INTVAL n = VTABLE_elements(interp, interp->HLL_info);
INTVAL hll_id;
/* start at one since the 'parrot' namespace should already have been
* created */
for (hll_id = 1; hll_id < n; ++hll_id) {
PMC *ns_hash =
VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id);
if (PMC_IS_NULL(ns_hash) ||
ns_hash->vtable->base_type == enum_class_Undef)
{
STRING * hll_name = Parrot_hll_get_HLL_name(interp, hll_id);
if (!hll_name)
continue;
hll_name = Parrot_str_downcase(interp, hll_name);
/* XXX as in Parrot_hll_register_HLL() this needs to be fixed to use
* the correct type of namespace. It's relatively easy to do that
* here because the typemap already exists, but it is not currently
* done for consistency.
*/
ns_hash = Parrot_ns_make_namespace_keyed_str(interp,
interp->root_namespace, hll_name);
VTABLE_set_pmc_keyed_int(interp, interp->HLL_namespace,
hll_id, ns_hash);
}
}
}
/*
=back
=head1 AUTHOR
Leopold Toetsch
=head1 SEE ALSO
F<include/parrot/hll.h>
=cut
*/
/*
* Local variables:
* c-file-style: "parrot"
* End:
* vim: expandtab shiftwidth=4 cinoptions='\:2=2' :
*/
Jump to Line
Something went wrong with that request. Please try again.