//
// 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;
}
//
// 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;
}
//
// RL_Make_Block: C
//
// Allocate a series suitable for storing Rebol values. This series
// can be used as a backing store for a BLOCK!, but also for any
// other Rebol Array type (GROUP!, PATH!, GET-PATH!, SET-PATH!, or
// LIT-PATH!).
//
// Returns:
// A pointer to a block series.
// Arguments:
// size - the length of the block. The system will add one extra
// for the end-of-block marker.
// Notes:
// Blocks are allocated with REBOL's internal memory manager.
// Internal structures may change, so NO assumptions should be made!
// Blocks are automatically garbage collected if there are
// no references to them from REBOL code (C code does nothing.)
// However, you can lock blocks to prevent deallocation. (?? default)
//
RL_API REBSER *RL_Make_Block(u32 size)
{
REBARR * array = Make_Array(size);
MANAGE_ARRAY(array);
return ARR_SERIES(array);
}
