Exemplo n.º 1
0
//
//  RL_Extend: C
// 
// Appends embedded extension to system/catalog/boot-exts.
// 
// Returns:
//     A pointer to the REBOL library (see reb-lib.h).
// Arguments:
//     source - A pointer to a UTF-8 (or ASCII) string that provides
//         extension module header, function definitions, and other
//         related functions and data.
//     call - A pointer to the extension's command dispatcher.
// Notes:
//     This function simply adds the embedded extension to the
//     boot-exts list. All other processing and initialization
//     happens later during startup. Each embedded extension is
//     queried and init using LOAD-EXTENSION system native.
//     See c:extensions-embedded
//
RL_API void *RL_Extend(const REBYTE *source, RXICAL call)
{
    REBVAL *value;
    REBARR *array;

    value = CTX_VAR(Sys_Context, SYS_CTX_BOOT_EXTS);
    if (IS_BLOCK(value))
        array = VAL_ARRAY(value);
    else {
        array = Make_Array(2);
        Val_Init_Block(value, array);
    }
    value = Alloc_Tail_Array(array);
    Val_Init_Binary(value, Copy_Bytes(source, -1)); // UTF-8
    value = Alloc_Tail_Array(array);
    SET_HANDLE_CODE(value, cast(CFUNC*, call));

    return Extension_Lib();
}
Exemplo n.º 2
0
*/  REBSER *Split_Lines(REBVAL *val)
/*
**      Given a string series, split lines on CR-LF.
**		Series can be bytes or Unicode.
**
***********************************************************************/
{
	REBSER *ser = BUF_EMIT; // GC protected (because it is emit buffer)
	REBSER *str = VAL_SERIES(val);
	REBCNT len = VAL_LEN(val);
	REBCNT idx = VAL_INDEX(val);
	REBCNT start = idx;
	REBSER *out;
	REBUNI c;

	BLK_RESET(ser);

	while (idx < len) {
		c = GET_ANY_CHAR(str, idx);
		if (c == LF || c == CR) {
			out = Copy_String(str, start, idx - start);
			val = Alloc_Tail_Array(ser);
			Val_Init_String(val, out);
			VAL_SET_OPT(val, OPT_VALUE_LINE);
			idx++;
			if (c == CR && GET_ANY_CHAR(str, idx) == LF)
				idx++;
			start = idx;
		}
		else idx++;
	}
	// Possible remainder (no terminator)
	if (idx > start) {
		out = Copy_String(str, start, idx - start);
		val = Alloc_Tail_Array(ser);
		Val_Init_String(val, out);
		VAL_SET_OPT(val, OPT_VALUE_LINE);
	}

	return Copy_Array_Shallow(ser);
}
Exemplo n.º 3
0
//
//  Destroy_External_Storage: C
//
// Destroy the external storage pointed by `->data` by calling the routine
// `free_func` if it's not NULL
//
// out            Result
// ser            The series
// free_func    A routine to free the storage, if it's NULL, only mark the
//         external storage non-accessible
//
REB_R Destroy_External_Storage(REBVAL *out,
                               REBSER *ser,
                               REBVAL *free_func)
{
    SET_VOID(out);

    if (!GET_SER_FLAG(ser, SERIES_FLAG_EXTERNAL)) {
        fail (Error(RE_NO_EXTERNAL_STORAGE));
    }
    if (!GET_SER_FLAG(ser, SERIES_FLAG_ACCESSIBLE)) {
        REBVAL i;
        SET_INTEGER(&i, cast(REBUPT, SER_DATA_RAW(ser)));

        fail (Error(RE_ALREADY_DESTROYED, &i));
    }
    CLEAR_SER_FLAG(ser, SERIES_FLAG_ACCESSIBLE);
    if (free_func) {
        REBVAL safe;
        REBARR *array;
        REBVAL *elem;
        REBOOL threw;

        array = Make_Array(2);
        MANAGE_ARRAY(array);
        PUSH_GUARD_ARRAY(array);

        elem = Alloc_Tail_Array(array);
        *elem = *free_func;

        elem = Alloc_Tail_Array(array);
        SET_INTEGER(elem, cast(REBUPT, SER_DATA_RAW(ser)));

        threw = Do_At_Throws(&safe, array, 0, SPECIFIED); // 2 non-relative val

        DROP_GUARD_ARRAY(array);

        if (threw) return R_OUT_IS_THROWN;
    }
    return R_OUT;
}
Exemplo n.º 4
0
x*/ void RXI_To_Block(RXIFRM *frm, REBVAL *out) {
/*
***********************************************************************/
    REBCNT n;
    REBSER *blk;
    REBVAL *val;
    REBCNT len;

    blk = Make_Array(len = RXA_COUNT(frm));
    for (n = 1; n <= len; n++) {
        val = Alloc_Tail_Array(blk);
        RXI_To_Value(val, frm->args[n], RXA_TYPE(frm, n));
    }
    Val_Init_Block(out, blk);
}
Exemplo n.º 5
0
//
//  Split_Lines: C
// 
// Given a string series, split lines on CR-LF.
// Series can be bytes or Unicode.
//
REBARR *Split_Lines(REBVAL *val)
{
    REBARR *array = BUF_EMIT; // GC protected (because it is emit buffer)
    REBSER *str = VAL_SERIES(val);
    REBCNT len = VAL_LEN_AT(val);
    REBCNT idx = VAL_INDEX(val);
    REBCNT start = idx;
    REBSER *out;
    REBUNI c;

    RESET_ARRAY(array);

    while (idx < len) {
        c = GET_ANY_CHAR(str, idx);
        if (c == LF || c == CR) {
            out = Copy_String_Slimming(str, start, idx - start);
            val = Alloc_Tail_Array(array);
            Val_Init_String(val, out);
            SET_VAL_FLAG(val, VALUE_FLAG_LINE);
            idx++;
            if (c == CR && GET_ANY_CHAR(str, idx) == LF)
                idx++;
            start = idx;
        }
        else idx++;
    }
    // Possible remainder (no terminator)
    if (idx > start) {
        out = Copy_String_Slimming(str, start, idx - start);
        val = Alloc_Tail_Array(array);
        Val_Init_String(val, out);
        SET_VAL_FLAG(val, VALUE_FLAG_LINE);
    }

    return Copy_Array_Shallow(array, SPECIFIED); // no relative values
}
Exemplo n.º 6
0
*/	RL_API void *RL_Extend(const REBYTE *source, RXICAL call)
/*
**	Appends embedded extension to system/catalog/boot-exts.
**
**	Returns:
**		A pointer to the REBOL library (see reb-lib.h).
**	Arguments:
**		source - A pointer to a UTF-8 (or ASCII) string that provides
**			extension module header, function definitions, and other
**			related functions and data.
**		call - A pointer to the extension's command dispatcher.
**	Notes:
**		This function simply adds the embedded extension to the
**		boot-exts list. All other processing and initialization
**		happens later during startup. Each embedded extension is
**		queried and init using LOAD-EXTENSION system native.
**		See c:extensions-embedded
**
***********************************************************************/
{
	REBVAL *value;
	REBSER *ser;

	value = BLK_SKIP(Sys_Context, SYS_CTX_BOOT_EXTS);
	if (IS_BLOCK(value)) ser = VAL_SERIES(value);
	else {
		ser = Make_Array(2);
		Val_Init_Block(value, ser);
	}
	value = Alloc_Tail_Array(ser);
	Val_Init_Binary(value, Copy_Bytes(source, -1)); // UTF-8
	value = Alloc_Tail_Array(ser);
	SET_HANDLE_CODE(value, cast(CFUNC*, call));

	return Extension_Lib();
}
Exemplo n.º 7
0
*/  REBSER *Make_Frame(REBINT len, REBOOL has_self)
/*
**      Create a frame of a given size, allocating space for both
**		words and values. Normally used for global frames.
**
***********************************************************************/
{
	REBSER *frame;
	REBSER *words;
	REBVAL *value;

	words = Make_Array(len + 1); // size + room for SELF
	frame = Make_Array(len + 1);

	// Note: cannot use Append_Frame for first word.
	value = Alloc_Tail_Array(frame);
	SET_FRAME(value, 0, words);
	value = Alloc_Tail_Array(words);
	Val_Init_Word_Typed(
		value, REB_WORD, has_self ? SYM_SELF : SYM_NOT_USED, ALL_64
	);

	return frame;
}
Exemplo n.º 8
0
*/	static int Read_Dir(REBREQ *dir, REBSER *files)
/*
**		Provide option to get file info too.
**		Provide option to prepend dir path.
**		Provide option to use wildcards.
**
***********************************************************************/
{
	REBINT result;
	REBCNT len;
	REBSER *fname;
	REBSER *name;
	REBREQ file;

	RESET_TAIL(files);
	CLEARS(&file);

	// Temporary filename storage:
	fname = BUF_OS_STR;
	file.special.file.path = cast(REBCHR*, Reset_Buffer(fname, MAX_FILE_NAME));

	SET_FLAG(dir->modes, RFM_DIR);

	dir->common.data = cast(REBYTE*, &file);

	while ((result = OS_DO_DEVICE(dir, RDC_READ)) == 0 && !GET_FLAG(dir->flags, RRF_DONE)) {
		len = OS_STRLEN(file.special.file.path);
		if (GET_FLAG(file.modes, RFM_DIR)) len++;
		name = Copy_OS_Str(file.special.file.path, len);
		if (GET_FLAG(file.modes, RFM_DIR))
			SET_ANY_CHAR(name, name->tail-1, '/');
		Val_Init_File(Alloc_Tail_Array(files), name);
	}

	if (result < 0 && dir->error != -RFE_OPEN_FAIL
		&& (
			OS_STRCHR(dir->special.file.path, '*')
			|| OS_STRCHR(dir->special.file.path, '?')
		)
	) {
		result = 0;  // no matches found, but not an error
	}

	return result;
}
Exemplo n.º 9
0
//
//  Init_Typesets: C
// 
// Create typeset variables that are defined above.
// For example: NUMBER is both integer and decimal.
// Add the new variables to the system context.
//
void Init_Typesets(void)
{
    REBVAL *value;
    REBINT n;

    Set_Root_Series(ROOT_TYPESETS, ARR_SERIES(Make_Array(40)));

    for (n = 0; Typesets[n].sym != SYM_0; n++) {
        value = Alloc_Tail_Array(VAL_ARRAY(ROOT_TYPESETS));

        // Note: the symbol in the typeset is not the symbol of a word holding
        // the typesets, rather an extra data field used when the typeset is
        // in a context key slot to identify that field's name
        //
        Val_Init_Typeset(value, Typesets[n].bits, SYM_0);

        *Append_Context(Lib_Context, NULL, Typesets[n].sym) = *value;
    }
}
Exemplo n.º 10
0
*/  REBSER *Make_Object_Block(REBSER *frame, REBINT mode)
/*
**      Return a block containing words, values, or set-word: value
**      pairs for the given object. Note: words are bound to original
**      object.
**
**      Modes:
**          1 for word
**          2 for value
**          3 for words and values
**
***********************************************************************/
{
	REBVAL *words  = FRM_WORDS(frame);
	REBVAL *values = FRM_VALUES(frame);
	REBSER *block;
	REBVAL *value;
	REBCNT n;

	n = (mode & 4) ? 0 : 1;
	block = Make_Array(SERIES_TAIL(frame) * (n + 1));

	for (; n < SERIES_TAIL(frame); n++) {
		if (!VAL_GET_EXT(words + n, EXT_WORD_HIDE)) {
			if (mode & 1) {
				value = Alloc_Tail_Array(block);
				if (mode & 2) {
					VAL_SET(value, REB_SET_WORD);
					VAL_SET_OPT(value, OPT_VALUE_LINE);
				}
				else VAL_SET(value, REB_WORD); //VAL_TYPE(words+n));
				VAL_WORD_SYM(value) = VAL_BIND_SYM(words+n);
				VAL_WORD_INDEX(value) = n;
				VAL_WORD_FRAME(value) = frame;
			}
			if (mode & 2) {
				Append_Value(block, values+n);
			}
		}
	}

	return block;
}
Exemplo n.º 11
0
*/  static void Collect_Words_Inner_Loop(REBINT *binds, REBVAL value[], REBCNT modes)
/*
**		Used for Collect_Words() after the binds table has
**		been set up.
**
***********************************************************************/
{
	for (; NOT_END(value); value++) {
		if (ANY_WORD(value)
			&& !binds[VAL_WORD_CANON(value)]
			&& (modes & BIND_ALL || IS_SET_WORD(value))
		) {
			REBVAL *word;
			binds[VAL_WORD_CANON(value)] = 1;
			word = Alloc_Tail_Array(BUF_WORDS);
			Val_Init_Word_Unbound(word, REB_WORD, VAL_WORD_SYM(value));
		}
		else if (ANY_EVAL_BLOCK(value) && (modes & BIND_DEEP))
			Collect_Words_Inner_Loop(binds, VAL_BLK_DATA(value), modes);
	}
}
Exemplo n.º 12
0
//
//  Typeset_To_Array: C
// 
// Converts typeset value to a block of datatypes.
// No order is specified.
//
REBARR *Typeset_To_Array(REBVAL *tset)
{
    REBARR *block;
    REBVAL *value;
    REBINT n;
    REBINT size = 0;

    for (n = 0; n < REB_MAX_0; n++) {
        if (TYPE_CHECK(tset, KIND_FROM_0(n))) size++;
    }

    block = Make_Array(size);

    // Convert bits to types:
    for (n = 0; n < REB_MAX_0; n++) {
        if (TYPE_CHECK(tset, KIND_FROM_0(n))) {
            value = Alloc_Tail_Array(block);
            Val_Init_Datatype(value, KIND_FROM_0(n));
        }
    }
    return block;
}
Exemplo n.º 13
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;
}
Exemplo n.º 14
0
*/	REBSER *Struct_To_Block(const REBSTU *stu)
/*
**		Used by MOLD to create a block.
**
***********************************************************************/
{
	REBSER *ser = Make_Array(10);
	struct Struct_Field *field = (struct Struct_Field*) SERIES_DATA(stu->fields);
	REBCNT i;

	// We are building a recursive structure.  So if we did not hand each
	// sub-series over to the GC then a single Free_Series() would not know
	// how to free them all.  There would have to be a specialized walk to
	// free the resulting structure.  Hence, don't invoke the GC until the
	// root series being returned is done being used or is safe from GC!
	MANAGE_SERIES(ser);

	for(i = 0; i < SERIES_TAIL(stu->fields); i ++, field ++) {
		REBVAL *val = NULL;
		REBVAL *type_blk = NULL;

		/* required field name */
		val = Alloc_Tail_Array(ser);
		Val_Init_Word_Unbound(val, REB_SET_WORD, field->sym);

		/* required type */
		type_blk = Alloc_Tail_Array(ser);
		Val_Init_Block(type_blk, Make_Array(1));

		val = Alloc_Tail_Array(VAL_SERIES(type_blk));
		if (field->type == STRUCT_TYPE_STRUCT) {
			REBVAL *nested = NULL;
			DS_PUSH_NONE;
			nested = DS_TOP;

			Val_Init_Word_Unbound(val, REB_WORD, SYM_STRUCT_TYPE);
			get_scalar(stu, field, 0, nested);
			val = Alloc_Tail_Array(VAL_SERIES(type_blk));
			Val_Init_Block(val, Struct_To_Block(&VAL_STRUCT(nested)));

			DS_DROP;
		} else
			Val_Init_Word_Unbound(val, REB_WORD, type_to_sym[field->type]);

		/* optional dimension */
		if (field->dimension > 1) {
			REBSER *dim = Make_Array(1);
			REBVAL *dv = NULL;
			val = Alloc_Tail_Array(VAL_SERIES(type_blk));
			Val_Init_Block(val, dim);

			dv = Alloc_Tail_Array(dim);
			SET_INTEGER(dv, field->dimension);
		}

		/* optional initialization */
		if (field->dimension > 1) {
			REBSER *dim = Make_Array(1);
			REBCNT n = 0;
			val = Alloc_Tail_Array(ser);
			Val_Init_Block(val, dim);
			for (n = 0; n < field->dimension; n ++) {
				REBVAL *dv = Alloc_Tail_Array(dim);
				get_scalar(stu, field, n, dv);
			}
		} else {
			val = Alloc_Tail_Array(ser);
			get_scalar(stu, field, 0, val);
		}
	}
	return ser;
}
Exemplo n.º 15
0
*/  REBSER *Merge_Frames(REBSER *parent1, REBSER *parent2)
/*
**      Create a child frame from two parent frames. Merge common fields.
**      Values from the second parent take precedence.
**
**		Deep copy and rebind the child.
**
***********************************************************************/
{
	REBSER *wrds;
	REBSER *child;
	REBVAL *words;
	REBVAL *value;
	REBCNT n;
	REBINT *binds = WORDS_HEAD(Bind_Table);

	// Merge parent1 and parent2 words.
	// Keep the binding table.
	Collect_Start(BIND_ALL);
	// Setup binding table and BUF_WORDS with parent1 words:
	Collect_Object(parent1);
	// Add parent2 words to binding table and BUF_WORDS:
	Collect_Frame_Inner_Loop(
		binds, BLK_SKIP(FRM_WORD_SERIES(parent2), 1), BIND_ALL
	);

	// Allocate child (now that we know the correct size):
	wrds = Copy_Array_Shallow(BUF_WORDS);
	child = Make_Array(SERIES_TAIL(wrds));
	value = Alloc_Tail_Array(child);
	VAL_SET(value, REB_FRAME);
	VAL_FRM_WORDS(value) = wrds;
	VAL_FRM_SPEC(value) = 0;

	// Copy parent1 values:
	memcpy(
		FRM_VALUES(child) + 1,
		FRM_VALUES(parent1) + 1,
		(SERIES_TAIL(parent1) - 1) * sizeof(REBVAL)
	);

	// Copy parent2 values:
	words = FRM_WORDS(parent2)+1;
	value = FRM_VALUES(parent2)+1;
	for (; NOT_END(words); words++, value++) {
		// no need to search when the binding table is available
		n = binds[VAL_WORD_CANON(words)];
		BLK_HEAD(child)[n] = *value;
	}

	// Terminate the child frame:
	SERIES_TAIL(child) = SERIES_TAIL(wrds);
	BLK_TERM(child);

	// Deep copy the child
	Clonify_Values_Len_Managed(
		BLK_SKIP(child, 1), SERIES_TAIL(child) - 1, TRUE, TS_CLONE
	);

	// Rebind the child
	Rebind_Block(parent1, child, BLK_SKIP(child, 1), REBIND_FUNC);
	Rebind_Block(parent2, child, BLK_SKIP(child, 1), REBIND_FUNC | REBIND_TABLE);

	// release the bind table
	Collect_End(child);

	return child;
}