Ejemplo n.º 1
0
//
//  Resolve_Path: C
//
// Given a path, determine if it is ultimately specifying a selection out
// of a context...and if it is, return that context.  So `a/obj/key` would
// return the object assocated with obj, while `a/str/1` would return
// NULL if `str` were a string as it's not an object selection.
//
// !!! This routine overlaps the logic of Do_Path, and should potentially
// be a mode of that instead.  It is not very complete, considering that it
// does not execute GROUP! (and perhaps shouldn't?) and only supports a
// path that picks contexts out of other contexts, via word selection.
//
REBCTX *Resolve_Path(const REBVAL *path, REBCNT *index_out)
{
    RELVAL *selector;
    const REBVAL *var;
    REBARR *array;
    REBCNT i;

    array = VAL_ARRAY(path);
    selector = ARR_HEAD(array);

    if (IS_END(selector) || !ANY_WORD(selector))
        return NULL; // !!! only handles heads of paths that are ANY-WORD!

    var = GET_OPT_VAR_MAY_FAIL(selector, VAL_SPECIFIER(path));

    ++selector;
    if (IS_END(selector))
        return NULL; // !!! does not handle single-element paths

    while (ANY_CONTEXT(var) && IS_WORD(selector)) {
        i = Find_Canon_In_Context(
            VAL_CONTEXT(var), VAL_WORD_CANON(selector), FALSE
        );
        ++selector;
        if (IS_END(selector)) {
            *index_out = i;
            return VAL_CONTEXT(var);
        }

        var = CTX_VAR(VAL_CONTEXT(var), i);
    }

    DEAD_END;
}
Ejemplo n.º 2
0
//
//  Resolve_Path: C
//
// Given a path, return a context and index for its terminal.
//
REBCTX *Resolve_Path(REBVAL *path, REBCNT *index)
{
    REBVAL *sel; // selector
    const REBVAL *val;
    REBARR *blk;
    REBCNT i;

    if (VAL_LEN_HEAD(path) < 2) return 0;
    blk = VAL_ARRAY(path);
    sel = ARR_HEAD(blk);
    if (!ANY_WORD(sel)) return 0;
    val = GET_OPT_VAR_MAY_FAIL(sel);

    sel = ARR_AT(blk, 1);
    while (TRUE) {
        if (!ANY_CONTEXT(val) || !IS_WORD(sel)) return 0;
        i = Find_Word_In_Context(VAL_CONTEXT(val), VAL_WORD_SYM(sel), FALSE);
        sel++;
        if (IS_END(sel)) {
            *index = i;
            return VAL_CONTEXT(val);
        }
    }

    return 0; // never happens
}
Ejemplo n.º 3
0
//
//  Copy_Array_At_Max_Shallow: C
//
// Shallow copy an array from the given index for given maximum
// length (clipping if it exceeds the array length)
//
REBARR *Copy_Array_At_Max_Shallow(
    REBARR *original,
    REBCNT index,
    REBSPC *specifier,
    REBCNT max
){
    const REBFLGS flags = 0;

    if (index > ARR_LEN(original))
        return Make_Array_For_Copy(0, flags, original);

    if (index + max > ARR_LEN(original))
        max = ARR_LEN(original) - index;

    REBARR *copy = Make_Array_For_Copy(max, flags, original);

    REBCNT count = 0;
    const RELVAL *src = ARR_AT(original, index);
    RELVAL *dest = ARR_HEAD(copy);
    for (; count < max; ++count, ++src, ++dest)
        Derelativize(dest, src, specifier);

    TERM_ARRAY_LEN(copy, max);

    return copy;
}
Ejemplo n.º 4
0
//
//  Dump_Series: C
//
void Dump_Series(REBSER *series, const char *memo)
{
    if (!series) return;
    Debug_Fmt(
        "%s Series %x \"%s\":"
            " wide: %2d"
            " size: %6d"
            " bias: %d"
            " tail: %d"
            " rest: %d"
            " flags: %x",
        memo,
        series,
        "-", // !label
        SER_WIDE(series),
        SER_TOTAL(series),
        SER_BIAS(series),
        SER_LEN(series),
        SER_REST(series),
        series->info.bits // flags + width
    );
    if (Is_Array_Series(series)) {
        Dump_Values(ARR_HEAD(AS_ARRAY(series)), SER_LEN(series));
    } else
        Dump_Bytes(
            SER_DATA_RAW(series),
            (SER_LEN(series) + 1) * SER_WIDE(series)
        );
}
Ejemplo n.º 5
0
//
//  Copy_Array_At_Extra_Shallow: C
//
// Shallow copy an array from the given index thru the tail.
// Additional capacity beyond what is required can be added
// by giving an `extra` count of how many value cells one needs.
//
REBARR *Copy_Array_At_Extra_Shallow(
    REBARR *original,
    REBCNT index,
    REBSPC *specifier,
    REBCNT extra,
    REBFLGS flags
){
    REBCNT len = ARR_LEN(original);

    if (index > len)
        return Make_Array_For_Copy(extra, flags, original);

    len -= index;

    REBARR *copy = Make_Array_For_Copy(len + extra, flags, original);

    RELVAL *src = ARR_AT(original, index);
    RELVAL *dest = ARR_HEAD(copy);
    REBCNT count = 0;
    for (; count < len; ++count, ++dest, ++src)
        Derelativize(dest, src, specifier);

    TERM_ARRAY_LEN(copy, len);

    return copy;
}
Ejemplo n.º 6
0
//
//  Copy_Array_Core_Managed_Inner_Loop: C
//
//
static REBARR *Copy_Array_Core_Managed_Inner_Loop(
    REBARR *original,
    REBCNT index,
    REBSPC *specifier,
    REBCNT tail,
    REBCNT extra, // currently no one uses--would it also apply deep (?)
    REBFLGS flags,
    REBU64 types
){
    assert(index <= tail and tail <= ARR_LEN(original));
    assert(flags & NODE_FLAG_MANAGED);

    REBCNT len = tail - index;

    // Currently we start by making a shallow copy and then adjust it

    REBARR *copy = Make_Array_For_Copy(len + extra, flags, original);

    RELVAL *src = ARR_AT(original, index);
    RELVAL *dest = ARR_HEAD(copy);
    REBCNT count = 0;
    for (; count < len; ++count, ++dest, ++src) {
        Clonify(
            Derelativize(dest, src, specifier),
            flags,
            types
        );
    }

    TERM_ARRAY_LEN(copy, len);

    return copy;
}
Ejemplo n.º 7
0
//
//  Copy_And_Bind_Relative_Deep_Managed: C
//
// This routine is called by Make_Function in order to take the raw material
// given as a function body, and de-relativize any IS_RELATIVE(value)s that
// happen to be in it already (as any Copy does).  But it also needs to make
// new relative references to ANY-WORD! that are referencing function
// parameters, as well as to relativize the copies of ANY-ARRAY! that contain
// these relative words...so that they refer to the archetypal function
// to which they should be relative.
//
REBARR *Copy_And_Bind_Relative_Deep_Managed(
    const REBVAL *body,
    REBARR *paramlist, // body of function is not actually ready yet
    REBU64 bind_types
) {
    // !!! Currently this is done in two phases, because the historical code
    // would use the generic copying code and then do a bind phase afterward.
    // Both phases are folded into this routine to make it easier to make
    // a one-pass version when time permits.
    //
    REBARR *copy = COPY_ANY_ARRAY_AT_DEEP_MANAGED(body);

    struct Reb_Binder binder;
    INIT_BINDER(&binder);

    // Setup binding table from the argument word list
    //
    REBCNT index = 1;
    RELVAL *param = ARR_AT(paramlist, 1); // [0] is FUNCTION! value
    for (; NOT_END(param); param++, index++)
        Add_Binder_Index(&binder, VAL_KEY_CANON(param), index);

    Bind_Relative_Inner_Loop(&binder, ARR_HEAD(copy), paramlist, bind_types);

    // Reset binding table
    //
    param = ARR_AT(paramlist, 1); // [0] is FUNCTION! value
    for (; NOT_END(param); param++)
        Remove_Binder_Index(&binder, VAL_KEY_CANON(param));

    SHUTDOWN_BINDER(&binder);
    return copy;
}
Ejemplo n.º 8
0
//
//  Copy_Rerelativized_Array_Deep_Managed: C
//
// The invariant of copying in general is that when you are done with the
// copy, there are no relative values in that copy.  One exception to this
// is the deep copy required to make a relative function body in the first
// place (which it currently does in two passes--a normal deep copy followed
// by a relative binding).  The other exception is when a relativized
// function body is copied to make another relativized function body.
//
// This is specialized logic for the latter case.  It's constrained enough
// to be simple (all relative values are known to be relative to the same
// function), and the feature is questionable anyway.  So it's best not to
// further complicate ordinary copying with a parameterization to copy
// and change all the relative binding information from one function's
// paramlist to another.
//
REBARR *Copy_Rerelativized_Array_Deep_Managed(
    REBARR *original,
    REBACT *before, // references to `before` will be changed to `after`
    REBACT *after
){
    const REBFLGS flags = NODE_FLAG_MANAGED;

    REBARR *copy = Make_Array_For_Copy(ARR_LEN(original), flags, original);
    RELVAL *src = ARR_HEAD(original);
    RELVAL *dest = ARR_HEAD(copy);

    for (; NOT_END(src); ++src, ++dest) {
        if (not IS_RELATIVE(src)) {
            Move_Value(dest, KNOWN(src));
            continue;
        }

        // All relative values under a sub-block must be relative to the
        // same function.
        //
        assert(VAL_RELATIVE(src) == before);

        Move_Value_Header(dest, src);

        if (ANY_ARRAY_OR_PATH(src)) {
            INIT_VAL_NODE(
                dest,
                Copy_Rerelativized_Array_Deep_Managed(
                    VAL_ARRAY(src), before, after
                )
            );
            PAYLOAD(Any, dest).second = PAYLOAD(Any, src).second;
            INIT_BINDING(dest, after); // relative binding
        }
        else {
            assert(ANY_WORD(src));
            PAYLOAD(Any, dest) = PAYLOAD(Any, src);
            INIT_BINDING(dest, after);
        }

    }

    TERM_ARRAY_LEN(copy, ARR_LEN(original));

    return copy;
}
Ejemplo n.º 9
0
//
//  Find_In_Array_Simple: C
// 
// Simple search for a value in an array. Return the index of
// the value or the TAIL index if not found.
//
REBCNT Find_In_Array_Simple(REBARR *array, REBCNT index, const RELVAL *target)
{
    RELVAL *value = ARR_HEAD(array);

    for (; index < ARR_LEN(array); index++) {
        if (0 == Cmp_Value(value + index, target, FALSE))
            return index;
    }

    return ARR_LEN(array);
}
Ejemplo n.º 10
0
//
//  Specializer_Dispatcher: C
//
// The evaluator does not do any special "running" of a specialized frame.
// All of the contribution that the specialization had to make was taken care
// of when Eval_Core() used f->special to fill from the exemplar.  So all this
// does is change the phase and binding to match the function this layer wa
// specializing.
//
REB_R Specializer_Dispatcher(REBFRM *f)
{
    REBARR *details = ACT_DETAILS(FRM_PHASE(f));

    REBVAL *exemplar = KNOWN(ARR_HEAD(details));
    assert(IS_FRAME(exemplar));

    INIT_FRM_PHASE(f, VAL_PHASE(exemplar));
    FRM_BINDING(f) = VAL_BINDING(exemplar);

    return R_REDO_UNCHECKED; // redo uses the updated phase and binding
}
Ejemplo n.º 11
0
//
//  Uncolor_Array: C
//
void Uncolor_Array(REBARR *a)
{
    if (Is_Series_White(SER(a)))
        return; // avoid loop

    Flip_Series_To_White(SER(a));

    RELVAL *val;
    for (val = ARR_HEAD(a); NOT_END(val); ++val)
        if (ANY_ARRAY_OR_PATH(val) or IS_MAP(val) or ANY_CONTEXT(val))
            Uncolor(val);
}
Ejemplo n.º 12
0
//
//  Assert_No_Relative: C
//
// Check to make sure there are no relative values in an array, maybe deeply.
//
// !!! What if you have an ANY-ARRAY! inside your array at a position N,
// but there is a relative value in the VAL_ARRAY() of that value at an
// index earlier than N?  This currently considers that an error since it
// checks the whole array...which is more conservative (asserts on more
// cases).  But should there be a flag to ask to honor the index?
//
void Assert_No_Relative(REBARR *array, REBOOL deep)
{
    RELVAL *item = ARR_HEAD(array);
    while (NOT_END(item)) {
        if (IS_RELATIVE(item)) {
            Debug_Fmt("Array contained relative item and wasn't supposed to.");
            PROBE_MSG(item, "relative item");
            Panic_Array(array);
        }
        if (!IS_VOID_OR_SAFE_TRASH(item) && ANY_ARRAY(item) && deep)
             Assert_No_Relative(VAL_ARRAY(item), deep);
        ++item;
    }
}
Ejemplo n.º 13
0
//
//  RL_Map_Words: C
// 
// Given a block of word values, return an array of word ids.
// 
// Returns:
//     An array of global word identifiers (integers). The [0] value is the size.
// Arguments:
//     series - block of words as values (from REBOL blocks, not strings.)
// Notes:
//     Word identifiers are persistent, and you can use them anytime.
//     The block can include any kind of word, including set-words, lit-words, etc.
//     If the input block contains non-words, they will be skipped.
//     The array is allocated with OS_ALLOC and you can OS_FREE it any time.
//
RL_API u32 *RL_Map_Words(REBARR *array)
{
    REBCNT i = 1;
    u32 *words;
    REBVAL *val = ARR_HEAD(array);

    words = OS_ALLOC_N(u32, ARR_LEN(array) + 2);

    for (; NOT_END(val); val++) {
        if (ANY_WORD(val)) words[i++] = VAL_WORD_CANON(val);
    }

    words[0] = i;
    words[i] = 0;

    return words;
}
Ejemplo n.º 14
0
//
//  Collect_Set_Words: C
// 
// Scan a block, collecting all of its SET words as a block.
//
REBARR *Collect_Set_Words(REBVAL *val)
{
    REBCNT count = 0;
    REBVAL *val2 = val;
    REBARR *array;

    for (; NOT_END(val); val++) if (IS_SET_WORD(val)) count++;
    val = val2;

    array = Make_Array(count);
    val2 = ARR_HEAD(array);
    for (; NOT_END(val); val++) {
        if (IS_SET_WORD(val))
            Val_Init_Word(val2++, REB_WORD, VAL_WORD_SYM(val));
    }
    SET_END(val2);
    SET_ARRAY_LEN(array, count);

    return array;
}
Ejemplo n.º 15
0
//
//  Copy_Values_Len_Extra_Shallow_Core: C
//
// Shallow copy the first 'len' values of `head` into a new series created to
// hold that many entries, with an optional bit of extra space at the end.
//
REBARR *Copy_Values_Len_Extra_Shallow_Core(
    const RELVAL *head,
    REBSPC *specifier,
    REBCNT len,
    REBCNT extra,
    REBFLGS flags
){
    REBARR *a = Make_Array_Core(len + extra, flags);

    REBCNT count = 0;
    const RELVAL *src = head;
    RELVAL *dest = ARR_HEAD(a);
    for (; count < len; ++count, ++src, ++dest) {
        if (KIND_BYTE(src) == REB_NULLED)
            assert(flags & ARRAY_FLAG_NULLEDS_LEGAL);

        Derelativize(dest, src, specifier);
    }

    TERM_ARRAY_LEN(a, len);
    return a;
}
Ejemplo n.º 16
0
//
//  Vector_To_Array: C
// 
// Convert a vector to a block.
//
REBARR *Vector_To_Array(const REBVAL *vect)
{
    REBCNT len = VAL_LEN_AT(vect);
    REBYTE *data = SER_DATA_RAW(VAL_SERIES(vect));
    REBCNT type = VECT_TYPE(VAL_SERIES(vect));
    REBARR *array = NULL;
    REBCNT n;
    RELVAL *val;

    if (len <= 0)
        fail (Error_Invalid_Arg(vect));

    array = Make_Array(len);
    val = ARR_HEAD(array);
    for (n = VAL_INDEX(vect); n < VAL_LEN_HEAD(vect); n++, val++) {
        VAL_RESET_HEADER(val, (type >= VTSF08) ? REB_DECIMAL : REB_INTEGER);
        VAL_INT64(val) = get_vect(type, data, n); // can be int or decimal
    }

    TERM_ARRAY_LEN(array, len);
    assert(IS_END(val));

    return array;
}
Ejemplo n.º 17
0
//
//  Specialize_Action_Throws: C
//
// Create a new ACTION! value that uses the same implementation as another,
// but just takes fewer arguments or refinements.  It does this by storing a
// heap-based "exemplar" FRAME! in the specialized action; this stores the
// values to preload in the stack frame cells when it is invoked.
//
// The caller may provide information on the order in which refinements are
// to be specialized, using the data stack.  These refinements should be
// pushed in the *reverse* order of their invocation, so append/dup/part
// has /DUP at DS_TOP, and /PART under it.  List stops at lowest_ordered_dsp.
//
bool Specialize_Action_Throws(
    REBVAL *out,
    REBVAL *specializee,
    REBSTR *opt_specializee_name,
    REBVAL *opt_def, // !!! REVIEW: binding modified directly (not copied)
    REBDSP lowest_ordered_dsp
){
    assert(out != specializee);

    struct Reb_Binder binder;
    if (opt_def)
        INIT_BINDER(&binder);

    REBACT *unspecialized = VAL_ACTION(specializee);

    // This produces a context where partially specialized refinement slots
    // will be on the stack (including any we are adding "virtually", from
    // the current DSP down to the lowest_ordered_dsp).
    //
    REBCTX *exemplar = Make_Context_For_Action_Push_Partials(
        specializee,
        lowest_ordered_dsp,
        opt_def ? &binder : nullptr,
        CELL_MASK_NON_STACK
    );
    Manage_Array(CTX_VARLIST(exemplar)); // destined to be managed, guarded

    if (opt_def) { // code that fills the frame...fully or partially
        //
        // Bind all the SET-WORD! in the body that match params in the frame
        // into the frame.  This means `value: value` can very likely have
        // `value:` bound for assignments into the frame while `value` refers
        // to whatever value was in the context the specialization is running
        // in, but this is likely the more useful behavior.
        //
        // !!! This binds the actual arg data, not a copy of it--following
        // OBJECT!'s lead.  However, ordinary functions make a copy of the
        // body they are passed before rebinding.  Rethink.

        // See Bind_Values_Core() for explanations of how the binding works.

        Bind_Values_Inner_Loop(
            &binder,
            VAL_ARRAY_AT(opt_def),
            exemplar,
            FLAGIT_KIND(REB_SET_WORD), // types to bind (just set-word!)
            0, // types to "add midstream" to binding as we go (nothing)
            BIND_DEEP
        );

        // !!! Only one binder can be in effect, and we're calling arbitrary
        // code.  Must clean up now vs. in loop we do at the end.  :-(
        //
        RELVAL *key = CTX_KEYS_HEAD(exemplar);
        REBVAL *var = CTX_VARS_HEAD(exemplar);
        for (; NOT_END(key); ++key, ++var) {
            if (Is_Param_Unbindable(key))
                continue; // !!! is this flag still relevant?
            if (Is_Param_Hidden(key)) {
                assert(GET_CELL_FLAG(var, ARG_MARKED_CHECKED));
                continue;
            }
            if (GET_CELL_FLAG(var, ARG_MARKED_CHECKED))
                continue; // may be refinement from stack, now specialized out
            Remove_Binder_Index(&binder, VAL_KEY_CANON(key));
        }
        SHUTDOWN_BINDER(&binder);

        // Run block and ignore result (unless it is thrown)
        //
        PUSH_GC_GUARD(exemplar);
        bool threw = Do_Any_Array_At_Throws(out, opt_def, SPECIFIED);
        DROP_GC_GUARD(exemplar);

        if (threw) {
            DS_DROP_TO(lowest_ordered_dsp);
            return true;
        }
    }

    REBVAL *rootkey = CTX_ROOTKEY(exemplar);

    // Build up the paramlist for the specialized function on the stack.
    // The same walk used for that is used to link and process REB_X_PARTIAL
    // arguments for whether they become fully specialized or not.

    REBDSP dsp_paramlist = DSP;
    Move_Value(DS_PUSH(), ACT_ARCHETYPE(unspecialized));

    REBVAL *param = rootkey + 1;
    REBVAL *arg = CTX_VARS_HEAD(exemplar);

    REBDSP ordered_dsp = lowest_ordered_dsp;

    for (; NOT_END(param); ++param, ++arg) {
        if (TYPE_CHECK(param, REB_TS_REFINEMENT)) {
            if (IS_NULLED(arg)) {
                //
                // A refinement that is nulled is a candidate for usage at the
                // callsite.  Hence it must be pre-empted by our ordered
                // overrides.  -but- the overrides only apply if their slot
                // wasn't filled by the user code.  Yet these values we are
                // putting in disrupt that detection (!), so use another
                // flag (PUSH_PARTIAL) to reflect this state.
                //
                while (ordered_dsp != dsp_paramlist) {
                    ++ordered_dsp;
                    REBVAL *ordered = DS_AT(ordered_dsp);

                    if (not IS_WORD_BOUND(ordered))  // specialize 'print/asdf
                        fail (Error_Bad_Refine_Raw(ordered));

                    REBVAL *slot = CTX_VAR(exemplar, VAL_WORD_INDEX(ordered));
                    if (
                        IS_NULLED(slot) or GET_CELL_FLAG(slot, PUSH_PARTIAL)
                    ){
                        // It's still partial, so set up the pre-empt.
                        //
                        Init_Any_Word_Bound(
                            arg,
                            REB_SYM_WORD,
                            VAL_STORED_CANON(ordered),
                            exemplar,
                            VAL_WORD_INDEX(ordered)
                        );
                        SET_CELL_FLAG(arg, PUSH_PARTIAL);
                        goto unspecialized_arg;
                    }
                    // Otherwise the user filled it in, so skip to next...
                }

                goto unspecialized_arg;  // ran out...no pre-empt needed
            }

            if (GET_CELL_FLAG(arg, ARG_MARKED_CHECKED)) {
                assert(
                    IS_BLANK(arg)
                    or (
                        IS_REFINEMENT(arg)
                        and (
                            VAL_REFINEMENT_SPELLING(arg)
                            == VAL_PARAM_SPELLING(param)
                        )
                    )
                );
            }
            else
                Typecheck_Refinement_And_Canonize(param, arg);

            goto specialized_arg_no_typecheck;
        }

        switch (VAL_PARAM_CLASS(param)) {
          case REB_P_RETURN:
          case REB_P_LOCAL:
            assert(IS_NULLED(arg)); // no bindings, you can't set these
            goto unspecialized_arg;

          default:
            break;
        }

        // It's an argument, either a normal one or a refinement arg.

        if (not IS_NULLED(arg))
            goto specialized_arg_with_check;

    unspecialized_arg:

        assert(NOT_CELL_FLAG(arg, ARG_MARKED_CHECKED));
        assert(
            IS_NULLED(arg)
            or (IS_SYM_WORD(arg) and TYPE_CHECK(param, REB_TS_REFINEMENT))
        );
        Move_Value(DS_PUSH(), param);
        continue;

    specialized_arg_with_check:

        // !!! If argument was previously specialized, should have been type
        // checked already... don't type check again (?)
        //
        if (Is_Param_Variadic(param))
            fail ("Cannot currently SPECIALIZE variadic arguments.");

        if (TYPE_CHECK(param, REB_TS_DEQUOTE_REQUOTE) and IS_QUOTED(arg)) {
            //
            // Have to leave the quotes on, but still want to type check.

            if (not TYPE_CHECK(param, CELL_KIND(VAL_UNESCAPED(arg))))
                fail (arg); // !!! merge w/Error_Invalid_Arg()
        }
        else if (not TYPE_CHECK(param, VAL_TYPE(arg)))
            fail (arg); // !!! merge w/Error_Invalid_Arg()

       SET_CELL_FLAG(arg, ARG_MARKED_CHECKED);

    specialized_arg_no_typecheck:

        // Specialized-out arguments must still be in the parameter list,
        // for enumeration in the evaluator to line up with the frame values
        // of the underlying function.

        assert(GET_CELL_FLAG(arg, ARG_MARKED_CHECKED));
        Move_Value(DS_PUSH(), param);
        TYPE_SET(DS_TOP, REB_TS_HIDDEN);
        continue;
    }

    REBARR *paramlist = Pop_Stack_Values_Core(
        dsp_paramlist,
        SERIES_MASK_PARAMLIST
            | (SER(unspecialized)->header.bits & PARAMLIST_MASK_INHERIT)
    );
    Manage_Array(paramlist);
    RELVAL *rootparam = ARR_HEAD(paramlist);
    VAL_ACT_PARAMLIST_NODE(rootparam) = NOD(paramlist);

    // Everything should have balanced out for a valid specialization
    //
    while (ordered_dsp != DSP) {
        ++ordered_dsp;
        REBVAL *ordered = DS_AT(ordered_dsp);
        if (not IS_WORD_BOUND(ordered))  // specialize 'print/asdf
            fail (Error_Bad_Refine_Raw(ordered));

        REBVAL *slot = CTX_VAR(exemplar, VAL_WORD_INDEX(ordered));
        assert(not IS_NULLED(slot) and NOT_CELL_FLAG(slot, PUSH_PARTIAL));
        UNUSED(slot);
    }
    DS_DROP_TO(lowest_ordered_dsp);

    // See %sysobj.r for `specialized-meta:` object template

    REBVAL *example = Get_System(SYS_STANDARD, STD_SPECIALIZED_META);

    REBCTX *meta = Copy_Context_Shallow_Managed(VAL_CONTEXT(example));

    Init_Nulled(CTX_VAR(meta, STD_SPECIALIZED_META_DESCRIPTION)); // default
    Move_Value(
        CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE),
        specializee
    );
    if (not opt_specializee_name)
        Init_Nulled(CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE_NAME));
    else
        Init_Word(
            CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE_NAME),
            opt_specializee_name
        );

    MISC_META_NODE(paramlist) = NOD(meta);

    REBACT *specialized = Make_Action(
        paramlist,
        &Specializer_Dispatcher,
        ACT_UNDERLYING(unspecialized), // same underlying action as this
        exemplar, // also provide a context of specialization values
        1 // details array capacity
    );
    assert(CTX_KEYLIST(exemplar) == ACT_PARAMLIST(unspecialized));

    assert(
        GET_ACTION_FLAG(specialized, IS_INVISIBLE)
        == GET_ACTION_FLAG(unspecialized, IS_INVISIBLE)
    );

    // The "body" is the FRAME! value of the specialization.  It takes on the
    // binding we want to use (which we can't put in the exemplar archetype,
    // that binding has to be UNBOUND).  It also remembers the original
    // action in the phase, so Specializer_Dispatcher() knows what to call.
    //
    RELVAL *body = ARR_HEAD(ACT_DETAILS(specialized));
    Move_Value(body, CTX_ARCHETYPE(exemplar));
    INIT_BINDING(body, VAL_BINDING(specializee));
    INIT_VAL_CONTEXT_PHASE(body, unspecialized);

    Init_Action_Unbound(out, specialized);
    return false; // code block did not throw
}
Ejemplo n.º 18
0
//
//  Make_Where_For_Frame: C
//
// Each call frame maintains the array it is executing in, the current index
// in that array, and the index of where the current expression started.
// This can be deduced into a segment of code to display in the debug views
// to indicate roughly "what's running" at that stack level.
//
// Unfortunately, Rebol doesn't formalize this very well.  There is no lock
// on segments of blocks during their evaluation, and it's possible for
// self-modifying code to scramble the blocks being executed.  The DO
// evaluator is robust in terms of not *crashing*, but the semantics may well
// suprise users.
//
// !!! Should blocks on the stack be locked from modification, at least by
// default unless a special setting for self-modifying code unlocks it?
//
// So long as WHERE information is unreliable, this has to check that
// `expr_index` (where the evaluation started) and `index` (where the
// evaluation thinks it currently is) aren't out of bounds here.  We could
// be giving back positions now unrelated to the call...but it won't crash!
//
REBARR *Make_Where_For_Frame(struct Reb_Frame *frame)
{
    REBCNT start;
    REBCNT end;

    REBARR *where;
    REBOOL pending;

    if (FRM_IS_VALIST(frame)) {
        const REBOOL truncated = TRUE;
        Reify_Va_To_Array_In_Frame(frame, truncated);
    }

    // WARNING: MIN is a C macro and repeats its arguments.
    //
    start = MIN(ARR_LEN(FRM_ARRAY(frame)), cast(REBCNT, frame->expr_index));
    end = MIN(ARR_LEN(FRM_ARRAY(frame)), FRM_INDEX(frame));

    assert(end >= start);
    assert(frame->mode != CALL_MODE_GUARD_ARRAY_ONLY);
    pending = NOT(frame->mode == CALL_MODE_FUNCTION);

    // Do a shallow copy so that the WHERE information only includes
    // the range of the array being executed up to the point of
    // currently relevant evaluation, not all the way to the tail
    // of the block (where future potential evaluation would be)
    {
        REBCNT n = 0;

        REBCNT len =
            1 // fake function word (compensates for prefetch)
            + (end - start) // data from expr_index to the current index
            + (pending ? 1 : 0); // if it's pending we put "..." to show that

        where = Make_Array(len);

        // !!! Due to "prefetch" the expr_index will be *past* the invocation
        // of the function.  So this is a lie, as a placeholder for what a
        // real debug mode would need to actually save the data to show.
        // If the execution were a path or anything other than a word, this
        // will lose it.
        //
        Val_Init_Word(ARR_AT(where, n), REB_WORD, FRM_LABEL(frame));
        ++n;

        for (n = 1; n < len; ++n)
            *ARR_AT(where, n) = *ARR_AT(FRM_ARRAY(frame), start + n - 1);

        SET_ARRAY_LEN(where, len);
        TERM_ARRAY(where);
    }

    // Making a shallow copy offers another advantage, that it's
    // possible to get rid of the newline marker on the first element,
    // that would visually disrupt the backtrace for no reason.
    //
    if (end - start > 0)
        CLEAR_VAL_FLAG(ARR_HEAD(where), VALUE_FLAG_LINE);

    // We add an ellipsis to a pending frame to make it a little bit
    // clearer what is going on.  If someone sees a where that looks
    // like just `* [print]` the asterisk alone doesn't quite send
    // home the message that print is not running and it is
    // argument fulfillment that is why it's not "on the stack"
    // yet, so `* [print ...]` is an attempt to say that better.
    //
    // !!! This is in-band, which can be mixed up with literal usage
    // of ellipsis.  Could there be a better "out-of-band" conveyance?
    // Might the system use colorization in a value option bit.
    //
    if (pending)
        Val_Init_Word(Alloc_Tail_Array(where), REB_WORD, SYM_ELLIPSIS);

    return where;
}
Ejemplo n.º 19
0
//
//  Modify_Array: C
//
// Returns new dst_idx
//
REBCNT Modify_Array(
    REBCNT action,          // INSERT, APPEND, CHANGE
    REBARR *dst_arr,        // target
    REBCNT dst_idx,         // position
    const REBVAL *src_val,  // source
    REBCNT flags,           // AN_ONLY, AN_PART
    REBINT dst_len,         // length to remove
    REBINT dups             // dup count
) {
    REBCNT tail = ARR_LEN(dst_arr);

    REBINT ilen = 1; // length to be inserted

    const RELVAL *src_rel;
    REBCTX *specifier;

    if (IS_VOID(src_val) || dups < 0) {
        // If they are effectively asking for "no action" then all we have
        // to do is return the natural index result for the operation.
        // (APPEND will return 0, insert the tail of the insertion...so index)

        return (action == SYM_APPEND) ? 0 : dst_idx;
    }

    if (action == SYM_APPEND || dst_idx > tail) dst_idx = tail;

    // Check /PART, compute LEN:
    if (!GET_FLAG(flags, AN_ONLY) && ANY_ARRAY(src_val)) {
        // Adjust length of insertion if changing /PART:
        if (action != SYM_CHANGE && GET_FLAG(flags, AN_PART))
            ilen = dst_len;
        else
            ilen = VAL_LEN_AT(src_val);

        // Are we modifying ourselves? If so, copy src_val block first:
        if (dst_arr == VAL_ARRAY(src_val)) {
            REBARR *copy = Copy_Array_At_Shallow(
                VAL_ARRAY(src_val), VAL_INDEX(src_val), VAL_SPECIFIER(src_val)
            );
            MANAGE_ARRAY(copy); // !!! Review: worth it to not manage and free?
            src_rel = ARR_HEAD(copy);
            specifier = SPECIFIED; // copy already specified it
        }
        else {
            src_rel = VAL_ARRAY_AT(src_val); // skips by VAL_INDEX values
            specifier = VAL_SPECIFIER(src_val);
        }
    }
    else {
        // use passed in RELVAL and specifier
        src_rel = src_val;
        specifier = SPECIFIED; // it's a REBVAL, not a RELVAL, so specified
    }

    REBINT size = dups * ilen; // total to insert

    if (action != SYM_CHANGE) {
        // Always expand dst_arr for INSERT and APPEND actions:
        Expand_Series(ARR_SERIES(dst_arr), dst_idx, size);
    }
    else {
        if (size > dst_len)
            Expand_Series(ARR_SERIES(dst_arr), dst_idx, size-dst_len);
        else if (size < dst_len && GET_FLAG(flags, AN_PART))
            Remove_Series(ARR_SERIES(dst_arr), dst_idx, dst_len-size);
        else if (size + dst_idx > tail) {
            EXPAND_SERIES_TAIL(ARR_SERIES(dst_arr), size - (tail - dst_idx));
        }
    }

    tail = (action == SYM_APPEND) ? 0 : size + dst_idx;

#if !defined(NDEBUG)
    if (IS_ARRAY_MANAGED(dst_arr)) {
        REBINT i;
        for (i = 0; i < ilen; ++i)
            ASSERT_VALUE_MANAGED(&src_rel[i]);
    }
#endif

    for (; dups > 0; dups--) {
        REBINT index = 0;
        for (; index < ilen; ++index, ++dst_idx) {
            COPY_VALUE(
                SINK(ARR_HEAD(dst_arr) + dst_idx),
                src_rel + index,
                specifier
            );
        }
    }
    TERM_ARRAY_LEN(dst_arr, ARR_LEN(dst_arr));

    ASSERT_ARRAY(dst_arr);

    return tail;
}
Ejemplo n.º 20
0
//
//  Make_Context_For_Action_Push_Partials: C
//
// This creates a FRAME! context with NULLED cells in the unspecialized slots
// that are available to be filled.  For partial refinement specializations
// in the action, it will push the refinement to the stack.  In this way it
// retains the ordering information implicit in the partial refinements of an
// action's existing specialization.
//
// It is able to take in more specialized refinements on the stack.  These
// will be ordered *after* partial specializations in the function already.
// The caller passes in the stack pointer of the lowest priority refinement,
// which goes up to DSP for the highest of those added specializations.
//
// Since this is walking the parameters to make the frame already--and since
// we don't want to bind to anything specialized out (including the ad-hoc
// refinements added on the stack) we go ahead and collect bindings from the
// frame if needed.
//
REBCTX *Make_Context_For_Action_Push_Partials(
    const REBVAL *action,  // need ->binding, so can't just be a REBACT*
    REBDSP lowest_ordered_dsp,  // caller can add refinement specializations
    struct Reb_Binder *opt_binder,
    REBFLGS prep  // cell formatting mask bits, result managed if non-stack
){
    REBDSP highest_ordered_dsp = DSP;

    REBACT *act = VAL_ACTION(action);

    REBCNT num_slots = ACT_NUM_PARAMS(act) + 1;  // +1 is for CTX_ARCHETYPE()
    REBARR *varlist = Make_Array_Core(num_slots, SERIES_MASK_VARLIST);

    REBVAL *rootvar = RESET_CELL(
        ARR_HEAD(varlist),
        REB_FRAME,
        CELL_MASK_CONTEXT
    );
    INIT_VAL_CONTEXT_VARLIST(rootvar, varlist);
    INIT_VAL_CONTEXT_PHASE(rootvar, VAL_ACTION(action));
    INIT_BINDING(rootvar, VAL_BINDING(action));

    const REBVAL *param = ACT_PARAMS_HEAD(act);
    REBVAL *arg = rootvar + 1;
    const REBVAL *special = ACT_SPECIALTY_HEAD(act);  // of exemplar/paramlist

    REBCNT index = 1; // used to bind REFINEMENT! values to parameter slots

    REBCTX *exemplar = ACT_EXEMPLAR(act); // may be null
    if (exemplar)
        assert(special == CTX_VARS_HEAD(exemplar));
    else
        assert(special == ACT_PARAMS_HEAD(act));

    for (; NOT_END(param); ++param, ++arg, ++special, ++index) {
        arg->header.bits = prep;

        if (Is_Param_Hidden(param)) {  // specialized out
            assert(GET_CELL_FLAG(special, ARG_MARKED_CHECKED));
            Move_Value(arg, special); // doesn't copy ARG_MARKED_CHECKED
            SET_CELL_FLAG(arg, ARG_MARKED_CHECKED);

          continue_specialized:

            assert(not IS_NULLED(arg));
            assert(GET_CELL_FLAG(arg, ARG_MARKED_CHECKED));
            continue;  // Eval_Core() double-checks type in debug build
        }

        assert(NOT_CELL_FLAG(special, ARG_MARKED_CHECKED));

        REBSTR *canon = VAL_PARAM_CANON(param);  // for adding to binding
        if (not TYPE_CHECK(param, REB_TS_REFINEMENT)) {  // nothing to push

          continue_unspecialized:

            assert(arg->header.bits == prep);
            Init_Nulled(arg);
            if (opt_binder) {
                if (not Is_Param_Unbindable(param))
                    Add_Binder_Index(opt_binder, canon, index);
            }
            continue;
        }

        // Unspecialized refinement slots may have an SYM-WORD! in them that
        // reflects a partial that needs to be pushed to the stack.  (They
        // are in *reverse* order of use.)

        assert(
            (special == param and IS_PARAM(special))
            or (IS_SYM_WORD(special) or IS_NULLED(special))
        );

        if (IS_SYM_WORD(special)) {
            REBCNT partial_index = VAL_WORD_INDEX(special);
            Init_Any_Word_Bound( // push a SYM-WORD! to data stack
                DS_PUSH(),
                REB_SYM_WORD,
                VAL_STORED_CANON(special),
                exemplar,
                partial_index
            );
        }

        // Unspecialized or partially specialized refinement.  Check the
        // passed-in refinements on the stack for usage.
        //
        REBDSP dsp = highest_ordered_dsp;
        for (; dsp != lowest_ordered_dsp; --dsp) {
            REBVAL *ordered = DS_AT(dsp);
            if (VAL_STORED_CANON(ordered) != canon)
                continue;  // just continuing this loop

            assert(not IS_WORD_BOUND(ordered));  // we bind only one
            INIT_BINDING(ordered, varlist);
            INIT_WORD_INDEX_UNCHECKED(ordered, index);

            if (not Is_Typeset_Invisible(param))  // needs argument
                goto continue_unspecialized;

            // If refinement named on stack takes no arguments, then it can't
            // be partially specialized...only fully, and won't be bound:
            //
            //     specialize 'append/only [only: false]  ; only not bound
            //
            Init_Word(arg, VAL_STORED_CANON(ordered));
            Refinify(arg);
            SET_CELL_FLAG(arg, ARG_MARKED_CHECKED);
            goto continue_specialized;
        }

        goto continue_unspecialized;
    }

    TERM_ARRAY_LEN(varlist, num_slots);
    MISC_META_NODE(varlist) = nullptr;  // GC sees this, we must initialize

    // !!! Can't pass SERIES_FLAG_STACK_LIFETIME into Make_Array_Core(),
    // because TERM_ARRAY_LEN won't let it set stack array lengths.
    //
    if (prep & CELL_FLAG_STACK_LIFETIME)
        SET_SERIES_FLAG(varlist, STACK_LIFETIME);

    INIT_CTX_KEYLIST_SHARED(CTX(varlist), ACT_PARAMLIST(act));
    return CTX(varlist);
}
Ejemplo n.º 21
0
//
//  Clonify: C
//
// Clone the series embedded in a value *if* it's in the given set of types
// (and if "cloning" makes sense for them, e.g. they are not simple scalars).
//
// Note: The resulting clones will be managed.  The model for lists only
// allows the topmost level to contain unmanaged values...and we *assume* the
// values we are operating on here live inside of an array.
//
void Clonify(
    REBVAL *v,
    REBFLGS flags,
    REBU64 types
){
    if (C_STACK_OVERFLOWING(&types))
        Fail_Stack_Overflow();

    // !!! It may be possible to do this faster/better, the impacts on higher
    // quoting levels could be incurring more cost than necessary...but for
    // now err on the side of correctness.  Unescape the value while cloning
    // and then escape it back.
    //
    REBCNT num_quotes = VAL_NUM_QUOTES(v);
    Dequotify(v);

    enum Reb_Kind kind = cast(enum Reb_Kind, KIND_BYTE_UNCHECKED(v));
    assert(kind < REB_MAX_PLUS_MAX); // we dequoted it (pseudotypes ok)

    if (types & FLAGIT_KIND(kind) & TS_SERIES_OBJ) {
        //
        // Objects and series get shallow copied at minimum
        //
        REBSER *series;
        if (ANY_CONTEXT(v)) {
            INIT_VAL_CONTEXT_VARLIST(
                v,
                CTX_VARLIST(Copy_Context_Shallow_Managed(VAL_CONTEXT(v)))
            );
            series = SER(CTX_VARLIST(VAL_CONTEXT(v)));
        }
        else {
            if (IS_SER_ARRAY(VAL_SERIES(v))) {
                series = SER(
                    Copy_Array_At_Extra_Shallow(
                        VAL_ARRAY(v),
                        0, // !!! what if VAL_INDEX() is nonzero?
                        VAL_SPECIFIER(v),
                        0,
                        NODE_FLAG_MANAGED
                    )
                );

                INIT_VAL_NODE(v, series); // copies args

                // If it was relative, then copying with a specifier
                // means it isn't relative any more.
                //
                INIT_BINDING(v, UNBOUND);
            }
            else {
                series = Copy_Sequence_Core(
                    VAL_SERIES(v),
                    NODE_FLAG_MANAGED
                );
                INIT_VAL_NODE(v, series);
            }
        }

        // If we're going to copy deeply, we go back over the shallow
        // copied series and "clonify" the values in it.
        //
        if (types & FLAGIT_KIND(kind) & TS_ARRAYS_OBJ) {
            REBVAL *sub = KNOWN(ARR_HEAD(ARR(series)));
            for (; NOT_END(sub); ++sub)
                Clonify(sub, flags, types);
        }
    }
    else if (types & FLAGIT_KIND(kind) & FLAGIT_KIND(REB_ACTION)) {
        //
        // !!! While Ren-C has abandoned the concept of copying the body
        // of functions (they are black boxes which may not *have* a
        // body), it would still theoretically be possible to do what
        // COPY does and make a function with a new and independently
        // hijackable identity.  Assume for now it's better that the
        // HIJACK of a method for one object will hijack it for all
        // objects, and one must filter in the hijacking's body if one
        // wants to take more specific action.
        //
        assert(false);
    }
    else {
        // We're not copying the value, so inherit the const bit from the
        // original value's point of view, if applicable.
        //
        if (NOT_CELL_FLAG(v, EXPLICITLY_MUTABLE))
            v->header.bits |= (flags & ARRAY_FLAG_CONST_SHALLOW);
    }

    Quotify(v, num_quotes);
}
Ejemplo n.º 22
0
//
//  Do_String()
//
// This is a version of a routine that was offered by the RL_Api, which has
// been expanded here in order to permit the necessary customizations for
// interesting REPL behavior w.r.t. binding, error handling, and response
// to throws.
//
// !!! Now that this code has been moved into the host, the convoluted
// integer-return-scheme can be eliminated and the code integrated more
// clearly into the surrounding calls.
//
int Do_String(
    int *exit_status,
    REBVAL *out,
    const REBYTE *text,
    REBOOL at_breakpoint
) {
    struct Reb_State state;
    REBCTX *error;

    // Breakpoint REPLs are nested, and we may wish to jump out of them to
    // the topmost level via a HALT.  However, all other errors need to be
    // confined, so that if one is doing evaluations during the pause of
    // a breakpoint an error doesn't "accidentally resume" by virtue of
    // jumping the stack out of the REPL.
    //
    // The topmost layer REPL, however, needs to catch halts in order to
    // keep control and not crash out.
    //
    if (at_breakpoint)
        PUSH_TRAP(&error, &state);
    else
        PUSH_UNHALTABLE_TRAP(&error, &state);

// The first time through the following code 'error' will be NULL, but...
// `fail` can longjmp here, so 'error' won't be NULL *if* that happens!

    if (error) {
        // Save error for WHY?
        REBVAL *last = Get_System(SYS_STATE, STATE_LAST_ERROR);

        if (ERR_NUM(error) == RE_HALT) {
            assert(!at_breakpoint);
            return -1; // !!! Revisit hardcoded #
        }

        Val_Init_Error(out, error);
        *last = *out;
        return -cast(REBINT, ERR_NUM(error));
    }

    REBARR *code = Scan_UTF8_Managed(text, LEN_BYTES(text));

    // Where code ends up being bound when loaded at the REPL prompt should
    // be more generally configurable.  (It may be, for instance, that one
    // wants to run something with it not bound at all.)  Such choices
    // must come from this REPL host...not from the interpreter itself.
    {
        // First the scanned code is bound into the user context with a
        // fallback to the lib context.
        //
        // !!! This code is very old, and is how the REPL has bound since
        // R3-Alpha.  It comes from RL_Do_String, but should receive a modern
        // review of why it's written exactly this way.
        //
        REBCTX *user_ctx = VAL_CONTEXT(Get_System(SYS_CONTEXTS, CTX_USER));

        REBVAL vali;
        SET_INTEGER(&vali, CTX_LEN(user_ctx) + 1);

        Bind_Values_All_Deep(ARR_HEAD(code), user_ctx);
        Resolve_Context(user_ctx, Lib_Context, &vali, FALSE, FALSE);

        // If we're stopped at a breakpoint, the REPL should have a concept
        // of what stack level it is inspecting (conveyed by the |#|>> in the
        // prompt).  This does a binding pass using the function for that
        // stack level, just the way a body is bound during Make_Function()
        //
        if (at_breakpoint) {
            REBVAL level;
            SET_INTEGER(&level, HG_Stack_Level);

            REBFRM *frame = Frame_For_Stack_Level(NULL, &level, FALSE);
            assert(frame);

            // Need to manage because it may be no words get bound into it,
            // and we're not putting it into a FRAME! value, so it might leak
            // otherwise if it's reified.
            //
            REBCTX *frame_ctx = Context_For_Frame_May_Reify_Managed(frame);

            Bind_Values_Deep(ARR_HEAD(code), frame_ctx);
        }

        // !!! This was unused code that used to be in Do_String from
        // RL_Api.  It was an alternative path under `flags` which said
        // "Bind into lib or user spaces?" and then "Top words will be
        // added to lib".  Is it relevant in any way?
        //
        /* Bind_Values_Set_Midstream_Shallow(ARR_HEAD(code), Lib_Context);
        Bind_Values_Deep(ARR_HEAD(code), Lib_Context); */
    }

    if (Do_At_Throws(out, code, 0, SPECIFIED)) { // `code` will be GC protected
        if (at_breakpoint) {
            if (
                IS_FUNCTION(out)
                && VAL_FUNC_DISPATCHER(out) == &N_resume
            ) {
                //
                // This means we're done with the embedded REPL.  We want to
                // resume and may be returning a piece of code that will be
                // run by the finishing BREAKPOINT command in the target
                // environment.
                //
                // We'll never return a halt, so we reuse -1 (in this very
                // temporary scheme built on the very clunky historical REPL,
                // which will not last much longer...fingers crossed.)
                //
                DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
                CATCH_THROWN(out, out);
                *exit_status = -1;
                return -1;
            }

            if (
                IS_FUNCTION(out)
                && VAL_FUNC_DISPATCHER(out) == &N_quit
            ) {
                //
                // It would be frustrating if the system did not respond to
                // a QUIT and forced you to do `resume/with [quit]`.  So
                // this is *not* caught, rather passed back up with the
                // special -2 status code.
                //
                DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
                CATCH_THROWN(out, out);
                *exit_status = -2;
                return -2;
            }
        }
        else {
            // We are at the top level REPL, where we catch QUIT and for
            // now, also EXIT as meaning you want to leave.
            //
            if (
                IS_FUNCTION(out)
                && (
                    VAL_FUNC_DISPATCHER(out) == &N_quit
                    || VAL_FUNC_DISPATCHER(out) == &N_exit
                )
            ) {
                DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
                CATCH_THROWN(out, out);
                *exit_status = Exit_Status_From_Value(out);
                return -2; // Revisit hardcoded #
            }
        }

        fail (Error_No_Catch_For_Throw(out));
    }

    DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);

    return 0;
}
Ejemplo n.º 23
0
//
//  RL_Do_String: C
// 
// Load a string and evaluate the resulting block.
// 
// Returns:
//     The datatype of the result if a positive number (or 0 if the
//     type has no representation in the "RXT" API).  An error code
//     if it's a negative number.  Two negative numbers are reserved
//     for non-error conditions: -1 for halting (e.g. Escape), and
//     -2 is reserved for exiting with exit_status set.
// 
// Arguments:
//     text - A null terminated UTF-8 (or ASCII) string to transcode
//         into a block and evaluate.
//     flags - set to zero for now
//     result - value returned from evaluation, if NULL then result
//         will be returned on the top of the stack
// 
// Notes:
//     This API was from before Rebol's open sourcing and had little
//     vetting and few clients.  The one client it did have was the
//     "sample" console code (which wound up being the "only"
//     console code for quite some time).
//
RL_API int RL_Do_String(
    int *exit_status,
    const REBYTE *text,
    REBCNT flags,
    RXIARG *out
) {
    REBARR *code;

    struct Reb_State state;
    REBCTX *error;

    REBVAL result;
    VAL_INIT_WRITABLE_DEBUG(&result);

    // assumes it can only be run at the topmost level where
    // the data stack is completely empty.
    //
    assert(DSP == 0);

    PUSH_UNHALTABLE_TRAP(&error, &state);

// The first time through the following code 'error' will be NULL, but...
// `fail` can longjmp here, so 'error' won't be NULL *if* that happens!

    if (error) {
        // Save error for WHY?
        REBVAL *last = Get_System(SYS_STATE, STATE_LAST_ERROR);
        Val_Init_Error(last, error);

        if (ERR_NUM(error) == RE_HALT)
            return -1; // !!! Revisit hardcoded #

        if (out)
            Value_To_RXI(out, last);
        else
            DS_PUSH(last);

        return -ERR_NUM(error);
    }

    code = Scan_Source(text, LEN_BYTES(text));
    PUSH_GUARD_ARRAY(code);

    // Bind into lib or user spaces?
    if (flags) {
        // Top words will be added to lib:
        Bind_Values_Set_Midstream_Shallow(ARR_HEAD(code), Lib_Context);
        Bind_Values_Deep(ARR_HEAD(code), Lib_Context);
    }
    else {
        REBCTX *user = VAL_CONTEXT(Get_System(SYS_CONTEXTS, CTX_USER));

        REBVAL vali;
        VAL_INIT_WRITABLE_DEBUG(&vali);
        SET_INTEGER(&vali, CTX_LEN(user) + 1);

        Bind_Values_All_Deep(ARR_HEAD(code), user);
        Resolve_Context(user, Lib_Context, &vali, FALSE, FALSE);
    }

    if (Do_At_Throws(&result, code, 0)) {
        DROP_GUARD_ARRAY(code);

        if (
            IS_FUNCTION_AND(&result, FUNC_CLASS_NATIVE) && (
                VAL_FUNC_CODE(&result) == &N_quit
                || VAL_FUNC_CODE(&result) == &N_exit
            )
        ) {
            CATCH_THROWN(&result, &result);
            DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);

            *exit_status = Exit_Status_From_Value(&result);
            return -2; // Revisit hardcoded #
        }

        fail (Error_No_Catch_For_Throw(&result));
    }

    DROP_GUARD_ARRAY(code);

    DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);

    if (out)
        Value_To_RXI(out, &result);
    else
        DS_PUSH(&result);

    return Reb_To_RXT[VAL_TYPE_0(&result)];
}