Пример #1
0
//
//  MAKE_Function: C
// 
// For REB_FUNCTION and "make spec", there is a function spec block and then
// a block of Rebol code implementing that function.  In that case we expect
// that `def` should be:
// 
//     [[spec] [body]]
// 
// With REB_COMMAND, the code is implemented via a C DLL, under a system of
// APIs that pre-date Rebol's open sourcing and hence Ren/C:
// 
//     [[spec] extension command-num]
// 
// See notes in Make_Command() regarding that mechanism and meaning.
//
void MAKE_Function(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
    assert(kind == REB_FUNCTION);

    if (
        !IS_BLOCK(arg)
        || VAL_LEN_AT(arg) != 2
        || !IS_BLOCK(VAL_ARRAY_AT(arg))
        || !IS_BLOCK(VAL_ARRAY_AT(arg) + 1)
    ){
        fail (Error_Bad_Make(kind, arg));
    }

    REBVAL spec;
    COPY_VALUE(&spec, VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg));

    REBVAL body;
    COPY_VALUE(&body, VAL_ARRAY_AT(arg) + 1, VAL_SPECIFIER(arg));

    // Spec-constructed functions do *not* have definitional returns
    // added automatically.  They are part of the generators.  So the
    // behavior comes--as with any other generator--from the projected
    // code (though round-tripping it via text is not possible in
    // general in any case due to loss of bindings.)
    //
    REBFUN *fun = Make_Interpreted_Function_May_Fail(
        &spec, &body, MKF_ANY_VALUE
    );

    *out = *FUNC_VALUE(fun);
}
Пример #2
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;
}
Пример #3
0
//
//  TO_Vector: C
//
void TO_Vector(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
    if (IS_BLOCK(arg)) {
        if (Make_Vector_Spec(VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg), out))
            return;
    }
    fail (Error_Bad_Make(kind, arg));
}
Пример #4
0
void Set_Vector_Row(REBSER *ser, REBVAL *blk)
{
    REBCNT idx = VAL_INDEX(blk);
    REBCNT len = VAL_LEN_AT(blk);
    RELVAL *val;
    REBCNT n = 0;
    REBCNT bits = VECT_TYPE(ser);
    REBI64 i = 0;
    REBDEC f = 0;

    if (IS_BLOCK(blk)) {
        val = VAL_ARRAY_AT(blk);

        for (; NOT_END(val); val++) {
            if (IS_INTEGER(val)) {
                i = VAL_INT64(val);
                if (bits > VTUI64) f = (REBDEC)(i);
            }
            else if (IS_DECIMAL(val)) {
                f = VAL_DECIMAL(val);
                if (bits <= VTUI64) i = (REBINT)(f);
            }
            else fail (Error_Invalid_Arg_Core(val, VAL_SPECIFIER(blk)));
            //if (n >= ser->tail) Expand_Vector(ser);
            set_vect(bits, SER_DATA_RAW(ser), n++, i, f);
        }
    }
    else {
        REBYTE *data = VAL_BIN_AT(blk);
        for (; len > 0; len--, idx++) {
            set_vect(
                bits, SER_DATA_RAW(ser), n++, cast(REBI64, data[idx]), f
            );
        }
    }
}
Пример #5
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;
}
Пример #6
0
//
//  Make_Set_Operation_Series: C
// 
// Do set operations on a series.  Case-sensitive if `cased` is TRUE.
// `skip` is the record size.
//
static REBSER *Make_Set_Operation_Series(
    const REBVAL *val1,
    const REBVAL *val2,
    REBFLGS flags,
    REBOOL cased,
    REBCNT skip
) {
    REBCNT i;
    REBINT h = 1; // used for both logic true/false and hash check
    REBOOL first_pass = TRUE; // are we in the first pass over the series?
    REBSER *out_ser;

    assert(ANY_SERIES(val1));

    if (val2) {
        assert(ANY_SERIES(val2));

        if (ANY_ARRAY(val1)) {
            if (!ANY_ARRAY(val2))
                fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));

            // As long as they're both arrays, we're willing to do:
            //
            //     >> union quote (a b c) 'b/d/e
            //     (a b c d e)
            //
            // The type of the result will match the first value.
        }
        else if (!IS_BINARY(val1)) {

            // We will similarly do any two ANY-STRING! types:
            //
            //      >> union <abc> "bde"
            //      <abcde>

            if (IS_BINARY(val2))
                fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
        }
        else {
            // Binaries only operate with other binaries

            if (!IS_BINARY(val2))
                fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
        }
    }

    // Calculate `i` as maximum length of result block.  The temporary buffer
    // will be allocated at this size, but copied out at the exact size of
    // the actual result.
    //
    i = VAL_LEN_AT(val1);
    if (flags & SOP_FLAG_BOTH) i += VAL_LEN_AT(val2);

    if (ANY_ARRAY(val1)) {
        REBSER *hser = 0;   // hash table for series
        REBSER *hret;       // hash table for return series

        // The buffer used for building the return series.  Currently it
        // reuses BUF_EMIT, because that buffer is not likely to be in
        // use (emit doesn't call set operations, nor vice versa).  However,
        // other routines may get the same idea and start recursing so it
        // may be better to use something more similar to the mold stack
        // approach of marking off successive ranges in the array.
        //
        REBSER *buffer = ARR_SERIES(BUF_EMIT);
        Resize_Series(buffer, i);
        hret = Make_Hash_Sequence(i);   // allocated

        // Optimization note: !!
        // This code could be optimized for small blocks by not hashing them
        // and extending Find_Key to FIND on the value itself w/o the hash.

        do {
            REBARR *array1 = VAL_ARRAY(val1); // val1 and val2 swapped 2nd pass!

            // Check what is in series1 but not in series2
            //
            if (flags & SOP_FLAG_CHECK)
                hser = Hash_Block(val2, skip, cased);

            // Iterate over first series
            //
            i = VAL_INDEX(val1);
            for (; i < ARR_LEN(array1); i += skip) {
                RELVAL *item = ARR_AT(array1, i);
                if (flags & SOP_FLAG_CHECK) {
                    h = Find_Key_Hashed(
                        VAL_ARRAY(val2),
                        hser,
                        item,
                        VAL_SPECIFIER(val1),
                        skip,
                        cased,
                        1
                    );
                    h = (h >= 0);
                    if (flags & SOP_FLAG_INVERT) h = !h;
                }
                if (h) {
                    Find_Key_Hashed(
                        AS_ARRAY(buffer),
                        hret,
                        item,
                        VAL_SPECIFIER(val1),
                        skip,
                        cased,
                        2
                    );
                }
            }

            if (i != ARR_LEN(array1)) {
                //
                // In the current philosophy, the semantics of what to do
                // with things like `intersect/skip [1 2 3] [7] 2` is too
                // shaky to deal with, so an error is reported if it does
                // not work out evenly to the skip size.
                //
                fail (Error(RE_BLOCK_SKIP_WRONG));
            }

            if (flags & SOP_FLAG_CHECK)
                Free_Series(hser);

            if (!first_pass) break;
            first_pass = FALSE;

            // Iterate over second series?
            //
            if ((i = ((flags & SOP_FLAG_BOTH) != 0))) {
                const REBVAL *temp = val1;
                val1 = val2;
                val2 = temp;
            }
        } while (i);

        if (hret)
            Free_Series(hret);

        out_ser = ARR_SERIES(Copy_Array_Shallow(AS_ARRAY(buffer), SPECIFIED));
        SET_SERIES_LEN(buffer, 0); // required - allow reuse
    }
    else {
        REB_MOLD mo;
        CLEARS(&mo);

        if (IS_BINARY(val1)) {
            //
            // All binaries use "case-sensitive" comparison (e.g. each byte
            // is treated distinctly)
            //
            cased = TRUE;
        }

        // ask mo.series to have at least `i` capacity beyond mo.start
        //
        mo.opts = MOPT_RESERVE;
        mo.reserve = i;
        Push_Mold(&mo);

        do {
            REBSER *ser = VAL_SERIES(val1); // val1 and val2 swapped 2nd pass!
            REBUNI uc;

            // Iterate over first series
            //
            i = VAL_INDEX(val1);
            for (; i < SER_LEN(ser); i += skip) {
                uc = GET_ANY_CHAR(ser, i);
                if (flags & SOP_FLAG_CHECK) {
                    h = (NOT_FOUND != Find_Str_Char(
                        uc,
                        VAL_SERIES(val2),
                        0,
                        VAL_INDEX(val2),
                        VAL_LEN_HEAD(val2),
                        skip,
                        cased ? AM_FIND_CASE : 0
                    ));

                    if (flags & SOP_FLAG_INVERT) h = !h;
                }

                if (!h) continue;

                if (
                    NOT_FOUND == Find_Str_Char(
                        uc, // c2 (the character to find)
                        mo.series, // ser
                        mo.start, // head
                        mo.start, // index
                        SER_LEN(mo.series), // tail
                        skip, // skip
                        cased ? AM_FIND_CASE : 0 // flags
        )
                ) {
                    Append_String(mo.series, ser, i, skip);
                }
            }

            if (!first_pass) break;
            first_pass = FALSE;

            // Iterate over second series?
            //
            if ((i = ((flags & SOP_FLAG_BOTH) != 0))) {
                const REBVAL *temp = val1;
                val1 = val2;
                val2 = temp;
            }
        } while (i);

        out_ser = Pop_Molded_String(&mo);
    }

    return out_ser;
}
Пример #7
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);
}
Пример #8
0
//
//  Compose_Any_Array_Throws: C
//
// Compose a block from a block of un-evaluated values and GROUP! arrays that
// are evaluated.  This calls into Do_Core, so if 'into' is provided, then its
// series must be protected from garbage collection.
//
//     deep - recurse into sub-blocks
//     only - parens that return blocks are kept as blocks
//
// Writes result value at address pointed to by out.
//
REBOOL Compose_Any_Array_Throws(
    REBVAL *out,
    const REBVAL *any_array,
    REBOOL deep,
    REBOOL only,
    REBOOL into
) {
    REBDSP dsp_orig = DSP;

    Reb_Enumerator e;
    PUSH_SAFE_ENUMERATOR(&e, any_array); // evaluating could disrupt any_array

    while (NOT_END(e.value)) {
        UPDATE_EXPRESSION_START(&e); // informs the error delivery better

        if (IS_GROUP(e.value)) {
            //
            // We evaluate here, but disable lookahead so it only evaluates
            // the GROUP! and doesn't trigger errors on what's after it.
            //
            REBVAL evaluated;
            DO_NEXT_REFETCH_MAY_THROW(&evaluated, &e, DO_FLAG_NO_LOOKAHEAD);
            if (THROWN(&evaluated)) {
                *out = evaluated;
                DS_DROP_TO(dsp_orig);
                DROP_SAFE_ENUMERATOR(&e);
                return TRUE;
            }

            if (IS_BLOCK(&evaluated) && !only) {
                //
                // compose [blocks ([a b c]) merge] => [blocks a b c merge]
                //
                RELVAL *push = VAL_ARRAY_AT(&evaluated);
                while (NOT_END(push)) {
                    //
                    // `evaluated` is known to be specific, but its specifier
                    // may be needed to derelativize its children.
                    //
                    DS_PUSH_RELVAL(push, VAL_SPECIFIER(&evaluated));
                    push++;
                }
            }
            else if (!IS_VOID(&evaluated)) {
                //
                // compose [(1 + 2) inserts as-is] => [3 inserts as-is]
                // compose/only [([a b c]) unmerged] => [[a b c] unmerged]
                //
                DS_PUSH(&evaluated);
            }
            else {
                //
                // compose [(print "Voids *vanish*!")] => []
                //
            }
        }
        else if (deep) {
            if (IS_BLOCK(e.value)) {
                //
                // compose/deep [does [(1 + 2)] nested] => [does [3] nested]

                REBVAL specific;
                COPY_VALUE(&specific, e.value, e.specifier);

                REBVAL composed;
                if (Compose_Any_Array_Throws(
                    &composed,
                    &specific,
                    TRUE,
                    only,
                    into
                )) {
                    *out = composed;
                    DS_DROP_TO(dsp_orig);
                    DROP_SAFE_ENUMERATOR(&e);
                    return TRUE;
                }

                DS_PUSH(&composed);
            }
            else {
                if (ANY_ARRAY(e.value)) {
                    //
                    // compose [copy/(orig) (copy)] => [copy/(orig) (copy)]
                    // !!! path and second group are copies, first group isn't
                    //
                    REBARR *copy = Copy_Array_Shallow(
                        VAL_ARRAY(e.value),
                        IS_RELATIVE(e.value)
                            ? e.specifier // use parent specifier if relative...
                            : VAL_SPECIFIER(const_KNOWN(e.value)) // else child's
                    );
                    DS_PUSH_TRASH;
                    Val_Init_Array_Index(
                        DS_TOP, VAL_TYPE(e.value), copy, VAL_INDEX(e.value)
                    ); // ...manages
                }
                else
                    DS_PUSH_RELVAL(e.value, e.specifier);
            }
            FETCH_NEXT_ONLY_MAYBE_END(&e);
        }
        else {
            //
            // compose [[(1 + 2)] (reverse "wollahs")] => [[(1 + 2)] "shallow"]
            //
            DS_PUSH_RELVAL(e.value, e.specifier);
            FETCH_NEXT_ONLY_MAYBE_END(&e);
        }
    }

    if (into)
        Pop_Stack_Values_Into(out, dsp_orig);
    else
        Val_Init_Array(out, VAL_TYPE(any_array), Pop_Stack_Values(dsp_orig));

    DROP_SAFE_ENUMERATOR(&e);
    return FALSE;
}
Пример #9
0
//
//  MAKE_Decimal: C
//
void MAKE_Decimal(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
    REBDEC d;

    switch (VAL_TYPE(arg)) {
    case REB_DECIMAL:
        d = VAL_DECIMAL(arg);
        goto dont_divide_if_percent;

    case REB_PERCENT:
        d = VAL_DECIMAL(arg);
        goto dont_divide_if_percent;

    case REB_INTEGER:
        d = cast(REBDEC, VAL_INT64(arg));
        goto dont_divide_if_percent;

    case REB_MONEY:
        d = deci_to_decimal(VAL_MONEY_AMOUNT(arg));
        goto dont_divide_if_percent;

    case REB_LOGIC:
        d = VAL_LOGIC(arg) ? 1.0 : 0.0;
        goto dont_divide_if_percent;

    case REB_CHAR:
        d = cast(REBDEC, VAL_CHAR(arg));
        goto dont_divide_if_percent;

    case REB_TIME:
        d = VAL_TIME(arg) * NANO;
        break;

    case REB_STRING:
        {
        REBYTE *bp;
        REBCNT len;
        bp = Temp_Byte_Chars_May_Fail(arg, MAX_SCAN_DECIMAL, &len, FALSE);

        VAL_RESET_HEADER(out, kind);
        if (!Scan_Decimal(
            &d, bp, len, LOGICAL(kind != REB_PERCENT)
        )) {
            goto bad_make;
        }
        break;
        }

    case REB_BINARY:
        Binary_To_Decimal(arg, out);
        VAL_RESET_HEADER(out, kind);
        d = VAL_DECIMAL(out);
        break;

#ifdef removed
//          case REB_ISSUE:
    {
        REBYTE *bp;
        REBCNT len;
        bp = Temp_Byte_Chars_May_Fail(arg, MAX_HEX_LEN, &len, FALSE);
        if (Scan_Hex(&VAL_INT64(out), bp, len, len) == 0)
            fail (Error_Bad_Make(REB_DECIMAL, val));
        d = VAL_DECIMAL(out);
        break;
    }
#endif

    default:
        if (ANY_ARRAY(arg) && VAL_ARRAY_LEN_AT(arg) == 2) {
            RELVAL *item = VAL_ARRAY_AT(arg);
            if (IS_INTEGER(item))
                d = cast(REBDEC, VAL_INT64(item));
            else if (IS_DECIMAL(item) || IS_PERCENT(item))
                d = VAL_DECIMAL(item);
            else {
                REBVAL specific;
                COPY_VALUE(&specific, item, VAL_SPECIFIER(arg));

                fail (Error_Invalid_Arg(&specific));
            }

            ++item;

            REBDEC exp;
            if (IS_INTEGER(item))
                exp = cast(REBDEC, VAL_INT64(item));
            else if (IS_DECIMAL(item) || IS_PERCENT(item))
                exp = VAL_DECIMAL(item);
            else {
                REBVAL specific;
                COPY_VALUE(&specific, item, VAL_SPECIFIER(arg));
                fail (Error_Invalid_Arg(&specific));
            }

            while (exp >= 1) {
                //
                // !!! Comment here said "funky. There must be a better way"
                //
                --exp;
                d *= 10.0;
                if (!FINITE(d))
                    fail (Error(RE_OVERFLOW));
            }

            while (exp <= -1) {
                ++exp;
                d /= 10.0;
            }
        }
        else
            fail (Error_Bad_Make(kind, arg));
    }

    if (kind == REB_PERCENT)
        d /= 100.0;

dont_divide_if_percent:
    if (!FINITE(d))
        fail (Error(RE_OVERFLOW));

    VAL_RESET_HEADER(out, kind);
    VAL_DECIMAL(out) = d;
    return;

bad_make:
    fail (Error_Bad_Make(kind, arg));
}
Пример #10
0
//
//  Next_Path_Throws: C
//
// Evaluate next part of a path.
//
REBOOL Next_Path_Throws(REBPVS *pvs)
{
    REBPEF dispatcher;

    // Path must have dispatcher, else return:
    dispatcher = Path_Dispatch[VAL_TYPE(pvs->value)];
    if (!dispatcher) return FALSE; // unwind, then check for errors

    pvs->item++;

    //Debug_Fmt("Next_Path: %r/%r", pvs->path-1, pvs->path);

    // Determine the "selector".  See notes on pvs->selector_temp for why
    // a local variable can't be used for the temporary space.
    //
    if (IS_GET_WORD(pvs->item)) { // e.g. object/:field
        pvs->selector
            = GET_MUTABLE_VAR_MAY_FAIL(pvs->item, pvs->item_specifier);

        if (IS_VOID(pvs->selector))
            fail (Error_No_Value_Core(pvs->item, pvs->item_specifier));

        SET_TRASH_IF_DEBUG(&pvs->selector_temp);
    }
    // object/(expr) case:
    else if (IS_GROUP(pvs->item)) {
        if (Do_At_Throws(
            &pvs->selector_temp,
            VAL_ARRAY(pvs->item),
            VAL_INDEX(pvs->item),
            IS_RELATIVE(pvs->item)
                ? pvs->item_specifier // if relative, use parent specifier...
                : VAL_SPECIFIER(const_KNOWN(pvs->item)) // ...else use child's
        )) {
            *pvs->store = pvs->selector_temp;
            return TRUE;
        }

        pvs->selector = &pvs->selector_temp;
    }
    else {
        // object/word and object/value case:
        //
        COPY_VALUE(&pvs->selector_temp, pvs->item, pvs->item_specifier);
        pvs->selector = &pvs->selector_temp;
    }

    switch (dispatcher(pvs)) {
    case PE_OK:
        break;

    case PE_SET_IF_END:
        if (pvs->opt_setval && IS_END(pvs->item + 1)) {
            *pvs->value = *pvs->opt_setval;
            pvs->opt_setval = NULL;
        }
        break;

    case PE_NONE:
        SET_BLANK(pvs->store);
    case PE_USE_STORE:
        pvs->value = pvs->store;
        pvs->value_specifier = SPECIFIED;
        break;

    default:
        assert(FALSE);
    }

    if (NOT_END(pvs->item + 1)) return Next_Path_Throws(pvs);

    return FALSE;
}
Пример #11
0
//
//  Do_Path_Throws_Core: C
//
// Evaluate an ANY_PATH! REBVAL, starting from the index position of that
// path value and continuing to the end.
//
// The evaluator may throw because GROUP! is evaluated, e.g. `foo/(throw 1020)`
//
// If label_sym is passed in as being non-null, then the caller is implying
// readiness to process a path which may be a function with refinements.
// These refinements will be left in order on the data stack in the case
// that `out` comes back as IS_FUNCTION().
//
// If `opt_setval` is given, the path operation will be done as a "SET-PATH!"
// if the path evaluation did not throw or error.  HOWEVER the set value
// is NOT put into `out`.  This provides more flexibility on performance in
// the evaluator, which may already have the `val` where it wants it, and
// so the extra assignment would just be overhead.
//
// !!! Path evaluation is one of the parts of R3-Alpha that has not been
// vetted very heavily by Ren-C, and needs a review and overhaul.
//
REBOOL Do_Path_Throws_Core(
    REBVAL *out,
    REBSTR **label_out,
    const RELVAL *path,
    REBCTX *specifier,
    REBVAL *opt_setval
) {
    REBPVS pvs;
    REBDSP dsp_orig = DSP;

    assert(ANY_PATH(path));

    // !!! There is a bug in the dispatch such that if you are running a
    // set path, it does not always assign the output, because it "thinks you
    // aren't going to look at it".  This presumably originated from before
    // parens were allowed in paths, and neglects cases like:
    //
    //     foo/(throw 1020): value
    //
    // We always have to check to see if a throw occurred.  Until this is
    // streamlined, we have to at minimum set it to something that is *not*
    // thrown so that we aren't testing uninitialized memory.  A safe trash
    // will do, which is unset in release builds.
    //
    if (opt_setval)
        SET_TRASH_SAFE(out);

    // None of the values passed in can live on the data stack, because
    // they might be relocated during the path evaluation process.
    //
    assert(!IN_DATA_STACK_DEBUG(out));
    assert(!IN_DATA_STACK_DEBUG(path));
    assert(!opt_setval || !IN_DATA_STACK_DEBUG(opt_setval));

    // Not currently robust for reusing passed in path or value as the output
    assert(out != path && out != opt_setval);

    assert(!opt_setval || !THROWN(opt_setval));

    // Initialize REBPVS -- see notes in %sys-do.h
    //
    pvs.opt_setval = opt_setval;
    pvs.store = out;
    pvs.orig = path;
    pvs.item = VAL_ARRAY_AT(pvs.orig); // may not be starting at head of PATH!

    // The path value that's coming in may be relative (in which case it
    // needs to use the specifier passed in).  Or it may be specific already,
    // in which case we should use the specifier in the value to process
    // its array contents.
    //
    if (IS_RELATIVE(path)) {
    #if !defined(NDEBUG)
        assert(specifier != SPECIFIED);

        if (VAL_RELATIVE(path) != VAL_FUNC(CTX_FRAME_FUNC_VALUE(specifier))) {
            Debug_Fmt("Specificity mismatch found in path dispatch");
            PROBE_MSG(path, "the path being evaluated");
            PROBE_MSG(FUNC_VALUE(VAL_RELATIVE(path)), "expected func");
            PROBE_MSG(CTX_FRAME_FUNC_VALUE(specifier), "actual func");
            assert(FALSE);
        }
    #endif
        pvs.item_specifier = specifier;
    }
    else pvs.item_specifier = VAL_SPECIFIER(const_KNOWN(path));

    // Seed the path evaluation process by looking up the first item (to
    // get a datatype to dispatch on for the later path items)
    //
    if (IS_WORD(pvs.item)) {
        pvs.value = GET_MUTABLE_VAR_MAY_FAIL(pvs.item, pvs.item_specifier);
        pvs.value_specifier = SPECIFIED;
        if (IS_VOID(pvs.value))
            fail (Error_No_Value_Core(pvs.item, pvs.item_specifier));
    }
    else {
        // !!! Ideally there would be some way to deal with writes to
        // temporary locations, like this pvs.value...if a set-path sets
        // it, then it will be discarded.

        COPY_VALUE(pvs.store, VAL_ARRAY_AT(pvs.orig), pvs.item_specifier);
        pvs.value = pvs.store;
        pvs.value_specifier = SPECIFIED;
    }

    // Start evaluation of path:
    if (IS_END(pvs.item + 1)) {
        // If it was a single element path, return the value rather than
        // try to dispatch it (would cause a crash at time of writing)
        //
        // !!! Is this the desired behavior, or should it be an error?
    }
    else if (Path_Dispatch[VAL_TYPE(pvs.value)]) {
        REBOOL threw = Next_Path_Throws(&pvs);

        // !!! See comments about why the initialization of out is necessary.
        // Without it this assertion can change on some things:
        //
        //     t: now
        //     t/time: 10:20:03
        //
        // (It thinks pvs.value has its THROWN bit set when it completed
        // successfully.  It was a PE_USE_STORE case where pvs.value was reset to
        // pvs.store, and pvs.store has its thrown bit set.  Valgrind does not
        // catch any uninitialized variables.)
        //
        // There are other cases that do trip valgrind when omitting the
        // initialization, though not as clearly reproducible.
        //
        assert(threw == THROWN(pvs.value));

        if (threw) return TRUE;

        // Check for errors:
        if (NOT_END(pvs.item + 1) && !IS_FUNCTION(pvs.value)) {
            //
            // Only function refinements should get by this line:

            REBVAL specified_orig;
            COPY_VALUE(&specified_orig, pvs.orig, specifier);

            REBVAL specified_item;
            COPY_VALUE(&specified_item, pvs.item, specifier);

            fail (Error(RE_INVALID_PATH, &specified_orig, &specified_item));
        }
    }
    else if (!IS_FUNCTION(pvs.value)) {
        REBVAL specified;
        COPY_VALUE(&specified, pvs.orig, specifier);
        fail (Error(RE_BAD_PATH_TYPE, &specified, Type_Of(pvs.value)));
    }

    if (opt_setval) {
        // If SET then we don't return anything
        assert(IS_END(pvs.item) + 1);
        return FALSE;
    }

    // If storage was not used, then copy final value back to it:
    if (pvs.value != pvs.store)
        COPY_VALUE(pvs.store, pvs.value, pvs.value_specifier);

    assert(!THROWN(out));

    // Return 0 if not function or is :path/word...
    if (!IS_FUNCTION(pvs.value)) {
        assert(IS_END(pvs.item) + 1);
        return FALSE;
    }

    if (label_out) {
        REBVAL refinement;

        // When a function is hit, path processing stops as soon as the
        // processed sub-path resolves to a function. The path is still sitting
        // on the position of the last component of that sub-path. Usually,
        // this last component in the sub-path is a word naming the function.
        //
        if (IS_WORD(pvs.item)) {
            *label_out = VAL_WORD_SPELLING(pvs.item);
        }
        else {
            // In rarer cases, the final component (completing the sub-path to
            // the function to call) is not a word. Such as when you use a path
            // to pick by index out of a block of functions:
            //
            //      functions: reduce [:add :subtract]
            //      functions/1 10 20
            //
            // Or when you have an immediate function value in a path with a
            // refinement. Tricky to make, but possible:
            //
            //      do reduce [
            //          to-path reduce [:append 'only] [a] [b]
            //      ]
            //

            // !!! When a function was not invoked through looking up a word
            // (or a word in a path) to use as a label, there were once three
            // different alternate labels used.  One was SYM__APPLY_, another
            // was ROOT_NONAME, and another was to be the type of the function
            // being executed.  None are fantastic, we do the type for now.

            *label_out = Canon(SYM_FROM_KIND(VAL_TYPE(pvs.value)));
        }

        // Move on to the refinements (if any)
        ++pvs.item;

        // !!! Currently, the mainline path evaluation "punts" on refinements.
        // When it finds a function, it stops the path evaluation and leaves
        // the position pvs.path before the list of refinements.
        //
        // A more elegant solution would be able to process and notice (for
        // instance) that `:APPEND/ONLY` should yield a function value that
        // has been specialized with a refinement.  Path chaining should thus
        // be able to effectively do this and give the refined function object
        // back to the evaluator or other client.
        //
        // If a label_sym is passed in, we recognize that a function dispatch
        // is going to be happening.  We do not want to pay to generate the
        // new series that would be needed to make a temporary function that
        // will be invoked and immediately GC'd  So we gather the refinements
        // on the data stack.
        //
        // This code simulates that path-processing-to-data-stack, but it
        // should really be something in dispatch iself.  In any case, we put
        // refinements on the data stack...and caller knows refinements are
        // from dsp_orig to DSP (thanks to accounting, all other operations
        // should balance!)

        for (; NOT_END(pvs.item); ++pvs.item) { // "the refinements"
            if (IS_VOID(pvs.item)) continue;

            if (IS_GROUP(pvs.item)) {
                //
                // Note it is not legal to use the data stack directly as the
                // output location for a DO (might be resized)

                if (Do_At_Throws(
                    &refinement,
                    VAL_ARRAY(pvs.item),
                    VAL_INDEX(pvs.item),
                    IS_RELATIVE(pvs.item)
                        ? pvs.item_specifier // if relative, use parent's
                        : VAL_SPECIFIER(const_KNOWN(pvs.item)) // else embedded
                )) {
                    *out = refinement;
                    DS_DROP_TO(dsp_orig);
                    return TRUE;
                }
                if (IS_VOID(&refinement)) continue;
                DS_PUSH(&refinement);
            }
            else if (IS_GET_WORD(pvs.item)) {
                DS_PUSH_TRASH;
                *DS_TOP = *GET_OPT_VAR_MAY_FAIL(pvs.item, pvs.item_specifier);
                if (IS_VOID(DS_TOP)) {
                    DS_DROP;
                    continue;
                }
            }
            else DS_PUSH_RELVAL(pvs.item, pvs.item_specifier);

            // Whatever we were trying to use as a refinement should now be
            // on the top of the data stack, and only words are legal ATM
            //
            if (!IS_WORD(DS_TOP)) {
                fail (Error(RE_BAD_REFINE, DS_TOP));
            }

            // Go ahead and canonize the word symbol so we don't have to
            // do it each time in order to get a case-insenstive compare
            //
            INIT_WORD_SPELLING(DS_TOP, VAL_WORD_CANON(DS_TOP));
        }

        // To make things easier for processing, reverse the refinements on
        // the data stack (we needed to evaluate them in forward order).
        // This way we can just pop them as we go, and know if they weren't
        // all consumed if it doesn't get back to `dsp_orig` by the end.

        if (dsp_orig != DSP) {
            REBVAL *bottom = DS_AT(dsp_orig + 1);
            REBVAL *top = DS_TOP;
            while (top > bottom) {
                refinement = *bottom;
                *bottom = *top;
                *top = refinement;

                top--;
                bottom++;
            }
        }
    }
    else {
        // !!! Historically this just ignores a result indicating this is a
        // function with refinements, e.g. ':append/only'.  However that
        // ignoring seems unwise.  It should presumably create a modified
        // function in that case which acts as if it has the refinement.
        //
        // If the caller did not pass in a label pointer we assume they are
        // likely not ready to process any refinements.
        //
        if (NOT_END(pvs.item + 1))
            fail (Error(RE_TOO_LONG)); // !!! Better error or add feature
    }

    return FALSE;
}