perl6lexinfo.pmc

/* This implements a container of static lexical information for
 * Perl 6. It differs from Parrot's LexInfo in that it provides
 * support for static lexical values that get set into each created
 * lexpad by default. It will also enable indexed lookups and, some day,
 * may also allow for native values to be stored too. */
pmclass Perl6LexInfo
    provides hash
    auto_attrs
    dynpmc group perl6
    hll perl6
    maps LexInfo
{
    /* The static (not closure cloned) sub that this is lexpad is used for. */
    ATTR PMC *static_code;

    /* Hash mapping a name to the register that always holds its
     * value. */
    ATTR PMC *name_to_register_map;
    
    /* The static lex pad that holds static lexical info for this block. */
    ATTR PMC *static_lexpad;

    /* Integer array of slots that we always want to pre-initialize
     * with static values; built from the static_values hash. */
    ATTR PMC *static_slots_cache;
    
    /* Matching PMC array of the values to pre-init with; built from
    * the static_values hash. */
    ATTR PMC *static_values_cache;
    
    /* Sometimes we want to clone the things we're copying. This gives
     * us a very cheap way to deal with e.g. scalar containers. */
    ATTR PMC *static_clone_flags_cache;
    
    /* Cache of the flags for when things have state. Actually the name of
     * the variable, or STRINGNULL if none. */
    ATTR PMC *state_flags_cache;
    
    /* Does this block get fresh magicals, or just steal the outer ones? */
    ATTR INTVAL fresh_magicals;

    VTABLE void init() {
        SELF.init_pmc(PMCNULL);
    }

    VTABLE void init_pmc(PMC *sub) {
        /* Set up the lex info storage. */
        PMC *name_to_register_map = Parrot_pmc_new(interp, enum_class_Hash);
        VTABLE_init_int(interp, name_to_register_map, (INTVAL)enum_type_INTVAL);
        SET_ATTR_name_to_register_map(INTERP, SELF, name_to_register_map);
        
        /* Stash the sub. */
        SET_ATTR_static_code(INTERP, SELF, sub);

        /* Need custom mark. */
        PObj_custom_mark_SET(SELF);
    }

    VTABLE void mark() {
        PMC *name_to_register_map, *static_lexpad;
        PMC *static_slots_cache, *static_values_cache, *static_clone_flags_cache, *state_flags_cache;
        GET_ATTR_name_to_register_map(INTERP, SELF, name_to_register_map);
        Parrot_gc_mark_PMC_alive(INTERP, name_to_register_map);
        GET_ATTR_static_lexpad(INTERP, SELF, static_lexpad);
        Parrot_gc_mark_PMC_alive(INTERP, static_lexpad);
        GET_ATTR_static_slots_cache(INTERP, SELF, static_slots_cache);
        Parrot_gc_mark_PMC_alive(INTERP, static_slots_cache);
        GET_ATTR_static_values_cache(INTERP, SELF, static_values_cache);
        Parrot_gc_mark_PMC_alive(INTERP, static_values_cache);
        GET_ATTR_static_clone_flags_cache(INTERP, SELF, static_clone_flags_cache);
        Parrot_gc_mark_PMC_alive(INTERP, static_clone_flags_cache);
        GET_ATTR_state_flags_cache(INTERP, SELF, state_flags_cache);
        Parrot_gc_mark_PMC_alive(INTERP, state_flags_cache);
    }

    VTABLE INTVAL elements() {
        PMC *name_to_register_map;
        GET_ATTR_name_to_register_map(INTERP, SELF, name_to_register_map);
        return VTABLE_elements(interp, name_to_register_map);
    }
    
    VTABLE INTVAL get_integer_keyed_str(STRING *key) {
        PMC *name_to_register_map;
        GET_ATTR_name_to_register_map(INTERP, SELF, name_to_register_map);
        return VTABLE_get_integer_keyed_str(interp, name_to_register_map, key);
    }
    
    VTABLE INTVAL exists_keyed_str(STRING *key) {
        PMC *name_to_register_map;
        GET_ATTR_name_to_register_map(INTERP, SELF, name_to_register_map);
        return VTABLE_exists_keyed_str(interp, name_to_register_map, key);
    }
    
    VTABLE void set_integer_keyed_str(STRING *key, INTVAL value) {
        PMC *name_to_register_map;
        GET_ATTR_name_to_register_map(INTERP, SELF, name_to_register_map);
        VTABLE_set_integer_keyed_str(interp, name_to_register_map, key, value);
    }
    
    VTABLE void visit(PMC *info) {
        VISIT_PMC_ATTR(INTERP, info, SELF, Perl6LexInfo, name_to_register_map);
        VISIT_PMC_ATTR(INTERP, info, SELF, Perl6LexInfo, static_code);
        SUPER(info);
    }
    
    VTABLE void thaw(PMC *info) {
        /* Need custom mark. */
        PObj_custom_mark_SET(SELF);
    }
    
    VTABLE PMC *get_iter() {
        PMC *name_to_register_map;
        GET_ATTR_name_to_register_map(INTERP, SELF, name_to_register_map);
        return VTABLE_get_iter(interp, name_to_register_map);
    }

/*

=item C<void declare_lex_preg(STRING *name, INTVAL preg)>

Declare a lexical variable that is an alias for a PMC register.  The PIR
compiler calls this method in response to a ".lex STRING, PREG" directive.

=cut

*/

    METHOD declare_lex_preg(STRING *name, INTVAL preg) {
        PMC *name_to_register_map;
        GET_ATTR_name_to_register_map(INTERP, SELF, name_to_register_map);
        VTABLE_set_integer_keyed_str(INTERP, name_to_register_map, name, preg);
    }
    
    METHOD set_static_lexpad(PMC *slp) {
        SET_ATTR_static_lexpad(INTERP, SELF, slp);
    }
    
    METHOD get_static_code() {
        PMC *static_code;
        GET_ATTR_static_code(INTERP, SELF, static_code);
        RETURN (PMC *static_code);
    }

/*

=item C<PMC *inspect_str(STRING *what)>

Introspects this LexInfo structure. The only valid introspection key is
C<symbols>, which gets an array of the names of the symbols in this lexpad.

=cut

*/

    VTABLE PMC *inspect_str(STRING *what) {
        if (STRING_equal(INTERP, what, CONST_STRING(INTERP, "symbols"))) {
            PMC * const result    = Parrot_pmc_new(INTERP, enum_class_ResizableStringArray);
            PMC *name_to_register_map;
            Hash *hash;
            
            GET_ATTR_name_to_register_map(INTERP, SELF, name_to_register_map);
            hash = (Hash *)VTABLE_get_pointer(interp, name_to_register_map);

            parrot_hash_iterate(hash,
                PARROT_ASSERT(_bucket->key);
                VTABLE_push_string(INTERP, result, (STRING *)_bucket->key););

            return result;
        }
        else
            Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION,
                "Unknown introspection value '%S'", what);
            return PMCNULL;
    }
}