//
// Ret_Query_Net: C
//
static void Ret_Query_Net(REBSER *port, REBREQ *sock, REBVAL *ret)
{
REBVAL *info = In_Object(port, STD_PORT_SCHEME, STD_SCHEME_INFO, 0);
REBSER *obj;
if (!info || !IS_OBJECT(info))
fail (Error_On_Port(RE_INVALID_SPEC, port, -10));
obj = Copy_Array_Shallow(VAL_OBJ_FRAME(info));
MANAGE_SERIES(obj);
Val_Init_Object(ret, obj);
Set_Tuple(
OFV(obj, STD_NET_INFO_LOCAL_IP),
cast(REBYTE*, &sock->special.net.local_ip),
4
);
Set_Tuple(
OFV(obj, STD_NET_INFO_REMOTE_IP),
cast(REBYTE*, &sock->special.net.remote_ip),
4
);
SET_INTEGER(OFV(obj, STD_NET_INFO_LOCAL_PORT), sock->special.net.local_port);
SET_INTEGER(OFV(obj, STD_NET_INFO_REMOTE_PORT), sock->special.net.remote_port);
}
//
// Accept_New_Port: C
//
// Clone a listening port as a new accept port.
//
static void Accept_New_Port(REBVAL *out, REBSER *port, REBREQ *sock)
{
REBREQ *nsock;
// Get temp sock struct created by the device:
nsock = sock->common.sock;
if (!nsock) return; // false alarm
sock->common.sock = nsock->next;
nsock->common.data = 0;
nsock->next = 0;
// Create a new port using ACCEPT request passed by sock->common.sock:
port = Copy_Array_Shallow(port);
MANAGE_SERIES(port);
Val_Init_Port(out, port); // Also for GC protect
SET_NONE(OFV(port, STD_PORT_DATA)); // just to be sure.
SET_NONE(OFV(port, STD_PORT_STATE)); // just to be sure.
// Copy over the new sock data:
sock = cast(REBREQ*, Use_Port_State(port, RDI_NET, sizeof(*sock)));
*sock = *nsock;
sock->clen = sizeof(*sock);
sock->port = port;
OS_FREE(nsock); // allocated by dev_net.c (MT issues?)
}
*/ RL_API void *RL_Make_String(u32 size, int unicode)
/*
** Allocate a new string or binary series.
**
** Returns:
** A pointer to a string or binary series.
** Arguments:
** size - the length of the string. The system will add one extra
** for a null terminator (not strictly required, but good for C.)
** unicode - set FALSE for ASCII/Latin1 strings, set TRUE for Unicode.
** Notes:
** Strings can be REBYTE or REBCHR sized (depends on R3 config.)
** Strings are allocated with REBOL's internal memory manager.
** Internal structures may change, so NO assumptions should be made!
** Strings are automatically garbage collected if there are
** no references to them from REBOL code (C code does nothing.)
** However, you can lock strings to prevent deallocation. (?? default)
**
***********************************************************************/
{
REBSER *result = unicode ? Make_Unicode(size) : Make_Binary(size);
// !!! Assume client does not have Free_Series() or MANAGE_SERIES()
// APIs, so the series we give back must be managed. But how can
// we be sure they get what usage they needed before the GC happens?
MANAGE_SERIES(result);
return result;
}
//
// RL_Make_String: C
//
// Allocate a new string or binary series.
//
// Returns:
// A pointer to a string or binary series.
// Arguments:
// size - the length of the string. The system will add one extra
// for a null terminator (not strictly required, but good for C.)
// unicode - set FALSE for ASCII/Latin1 strings, set TRUE for Unicode.
// Notes:
// Strings can be REBYTE or REBCHR sized (depends on R3 config.)
// Strings are allocated with REBOL's internal memory manager.
// Internal structures may change, so NO assumptions should be made!
// Strings are automatically garbage collected if there are
// no references to them from REBOL code (C code does nothing.)
// However, you can lock strings to prevent deallocation. (?? default)
//
RL_API REBSER *RL_Make_String(u32 size, REBOOL unicode)
{
REBSER *result = unicode ? Make_Unicode(size) : Make_Binary(size);
// !!! Assume client does not have Free_Series() or MANAGE_SERIES()
// APIs, so the series we give back must be managed. But how can
// we be sure they get what usage they needed before the GC happens?
MANAGE_SERIES(result);
return result;
}
*/ REBSER *Temp_Bin_Str_Managed(REBVAL *val, REBCNT *index, REBCNT *length)
/*
** Determines if UTF8 conversion is needed for a series before it
** is used with a byte-oriented function.
**
** If conversion is needed, a UTF8 series will be created. Otherwise,
** the source series is returned as-is.
**
** Note: This routine should only be used to generate a value used
** for temporary purposes, because it has a "surprising variance"
** regarding its input. If the value's series can be reused, it is--
** and this depends on an implementation detail of internal encoding
** that the user should not be aware of (they need not know if the
** internal representation of an ASCII string uses 1, 2, or however
** many bytes). But copying vs. non-copying means the resulting
** data might or might not have previous values available to step
** back into from the originating series!
**
** !!! Should performance dictate it, the callsites could be
** adapted to know whether this produced a new series or not, and
** instead of managing a created result they could be responsible
** for freeing it if so.
**
***********************************************************************/
{
REBCNT len = (length && *length) ? *length : VAL_LEN(val);
REBSER *series;
assert(IS_BINARY(val) || ANY_STR(val));
if (len == 0 || IS_BINARY(val) || VAL_STR_IS_ASCII(val)) {
// If it's zero length, BINARY!, or an ANY-STRING! whose bytes are
// all values less than 128, we reuse the series.
series = VAL_SERIES(val);
ASSERT_SERIES_MANAGED(series);
if (index) *index = VAL_INDEX(val);
if (length) *length = len;
}
else {
// UTF-8 conversion is required, and we manage the result.
series = Make_UTF8_From_Any_String(val, len, OPT_ENC_CRLF_MAYBE);
MANAGE_SERIES(series);
if (index) *index = 0;
if (length) *length = SERIES_TAIL(series);
}
return series;
}
/* set storage memory to external addr: raw_addr */
static void set_ext_storage (REBVAL *out, REBINT raw_size, REBUPT raw_addr)
{
REBSER *data_ser = VAL_STRUCT_DATA_BIN(out);
REBSER *ser = NULL;
if (raw_size >= 0 && raw_size != cast(REBINT, VAL_STRUCT_LEN(out)))
raise Error_0(RE_INVALID_DATA);
ser = Make_Series(
SERIES_LEN(data_ser) + 1, // include term.
SERIES_WIDE(data_ser),
Is_Array_Series(data_ser) ? (MKS_ARRAY | MKS_EXTERNAL) : MKS_EXTERNAL
);
ser->data = (REBYTE*)raw_addr;
VAL_STRUCT_DATA_BIN(out) = ser;
MANAGE_SERIES(ser);
}
*/ REBCHR *Val_Str_To_OS_Managed(REBSER **out, REBVAL *val)
/*
** This is used to pass a REBOL value string to an OS API.
**
** The REBOL (input) string can be byte or wide sized.
** The OS (output) string is in the native OS format.
** On Windows, its a wide-char, but on Linux, its UTF-8.
**
** If we know that the string can be used directly as-is,
** (because it's in the OS size format), we can used it
** like that.
**
** !!! The series is created but just let up to the garbage
** collector to free. This is a "leaky" approach. You may
** optionally request to have the series returned if it is
** important for you to protect it from GC, but you cannot
** currently get a "freeable" series out of this.
**
***********************************************************************/
{
#ifdef OS_WIDE_CHAR
if (VAL_BYTE_SIZE(val)) {
// On windows, we need to convert byte to wide:
REBINT n = VAL_LEN(val);
REBSER *up = Make_Unicode(n);
// !!!"Leaks" in the sense that the GC has to take care of this
MANAGE_SERIES(up);
n = Decode_UTF8(UNI_HEAD(up), VAL_BIN_DATA(val), n, FALSE);
SERIES_TAIL(up) = abs(n);
UNI_TERM(up);
if (out) *out = up;
return cast(REBCHR*, UNI_HEAD(up));
}
else {
// Already wide, we can use it as-is:
// !Assumes the OS uses same wide format!
if (out) *out = VAL_SERIES(val);
*/ void Expand_Frame(REBSER *frame, REBCNT delta, REBCNT copy)
/*
** Expand a frame. Copy words if flagged.
**
***********************************************************************/
{
REBSER *words = FRM_WORD_SERIES(frame);
Extend_Series(frame, delta);
BLK_TERM(frame);
// Expand or copy WORDS block:
if (copy) {
REBOOL managed = SERIES_GET_FLAG(FRM_WORD_SERIES(frame), SER_MANAGED);
FRM_WORD_SERIES(frame) = Copy_Array_Extra_Shallow(words, delta);
if (managed) MANAGE_SERIES(FRM_WORD_SERIES(frame));
}
else {
Extend_Series(words, delta);
BLK_TERM(words);
}
}
*/ 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;
}
//
// Find_Entry: C
//
// Try to find the entry in the map. If not found
// and val is SET, create the entry and store the key and
// val.
//
// RETURNS: the index to the VALUE or zero if there is none.
//
static REBCNT Find_Entry(REBSER *series, REBVAL *key, REBVAL *val)
{
REBSER *hser = series->extra.series; // can be null
REBCNT *hashes;
REBCNT hash;
REBVAL *v;
REBCNT n;
if (IS_NONE(key)) return 0;
// We may not be large enough yet for the hash table to
// be worthwhile, so just do a linear search:
if (!hser) {
if (series->tail < MIN_DICT*2) {
v = BLK_HEAD(series);
if (ANY_WORD(key)) {
for (n = 0; n < series->tail; n += 2, v += 2) {
if (
ANY_WORD(v)
&& SAME_SYM(VAL_WORD_SYM(key), VAL_WORD_SYM(v))
) {
if (val) *++v = *val;
return n/2+1;
}
}
}
else if (ANY_BINSTR(key)) {
for (n = 0; n < series->tail; n += 2, v += 2) {
if (VAL_TYPE(key) == VAL_TYPE(v) && 0 == Compare_String_Vals(key, v, (REBOOL)!IS_BINARY(v))) {
if (val)
*++v = *val;
return n/2+1;
}
}
}
else if (IS_INTEGER(key)) {
for (n = 0; n < series->tail; n += 2, v += 2) {
if (IS_INTEGER(v) && VAL_INT64(key) == VAL_INT64(v)) {
if (val) *++v = *val;
return n/2+1;
}
}
}
else if (IS_CHAR(key)) {
for (n = 0; n < series->tail; n += 2, v += 2) {
if (IS_CHAR(v) && VAL_CHAR(key) == VAL_CHAR(v)) {
if (val) *++v = *val;
return n/2+1;
}
}
}
else
fail (Error_Has_Bad_Type(key));
if (!val) return 0;
Append_Value(series, key);
Append_Value(series, val); // does not copy value, e.g. if string
return series->tail/2;
}
// Add hash table:
//Print("hash added %d", series->tail);
series->extra.series = hser = Make_Hash_Sequence(series->tail);
MANAGE_SERIES(hser);
Rehash_Hash(series);
}
// Get hash table, expand it if needed:
if (series->tail > hser->tail/2) {
Expand_Hash(hser); // modifies size value
Rehash_Hash(series);
}
hash = Find_Key(series, hser, key, 2, 0, 0);
hashes = (REBCNT*)hser->data;
n = hashes[hash];
// Just a GET of value:
if (!val) return n;
// Must set the value:
if (n) { // re-set it:
*BLK_SKIP(series, ((n-1)*2)+1) = *val; // set it
return n;
}
// Create new entry:
Append_Value(series, key);
Append_Value(series, val); // does not copy value, e.g. if string
return (hashes[hash] = series->tail/2);
}
//
// Temp_Bin_Str_Managed: C
//
// Determines if UTF8 conversion is needed for a series before it
// is used with a byte-oriented function.
//
// If conversion is needed, a UTF8 series will be created. Otherwise,
// the source series is returned as-is.
//
// Note: This routine should only be used to generate a value used
// for temporary purposes, because it has a "surprising variance"
// regarding its input. If the value's series can be reused, it is--
// and this depends on an implementation detail of internal encoding
// that the user should not be aware of (they need not know if the
// internal representation of an ASCII string uses 1, 2, or however
// many bytes). But copying vs. non-copying means the resulting
// data might or might not have previous values available to step
// back into from the originating series!
//
// !!! Should performance dictate it, the callsites could be
// adapted to know whether this produced a new series or not, and
// instead of managing a created result they could be responsible
// for freeing it if so.
//
REBSER *Temp_Bin_Str_Managed(const REBVAL *val, REBCNT *index, REBCNT *length)
{
REBCNT len = (length && *length) ? *length : VAL_LEN_AT(val);
REBSER *series;
assert(IS_BINARY(val) || ANY_STRING(val));
// !!! This used to check `len == 0` and reuse a zero length string.
// However, the zero length string could have the wrong width. We are
// expected to be returning a BYTE_SIZE() string, and that confused
// things. It's not a good idea to mutate the source string (e.g.
// reallocate under a new width) so consider having an EMPTY_BYTE_STRING
// like EMPTY_ARRAY which is protected to hand back.
//
if (
IS_BINARY(val)
|| (
VAL_BYTE_SIZE(val)
&& All_Bytes_ASCII(VAL_BIN_AT(val), VAL_LEN_AT(val))
)
){
//
// It's BINARY!, or an ANY-STRING! whose codepoints are all values in
// ASCII (0x00 => 0x7F), hence not needing any UTF-8 encoding.
//
series = VAL_SERIES(val);
ASSERT_SERIES_MANAGED(series);
if (index)
*index = VAL_INDEX(val);
if (length)
*length = len;
}
else {
// UTF-8 conversion is required, and we manage the result.
series = Make_UTF8_From_Any_String(val, len, OPT_ENC_CRLF_MAYBE);
MANAGE_SERIES(series);
#if !defined(NDEBUG)
//
// Also, PROTECT the result in the debug build...because since the
// caller doesn't know if a new series was created or if the initial
// data is being used, they should not be modifying it! (We don't
// want to protect the original data, because we wouldn't know when
// we were allowed to unlock it...there's no later call in this
// model to clean up the series.)
{
REBVAL protect;
Val_Init_String(&protect, series);
Protect_Value(&protect, FLAGIT(PROT_SET));
// just a string...not /DEEP...shouldn't need to Unmark()
}
#endif
if (index)
*index = 0;
if (length)
*length = SER_LEN(series);
}
assert(BYTE_SIZE(series));
return series;
}
//
// Make_Vector_Spec: C
//
// Make a vector from a block spec.
//
// make vector! [integer! 32 100]
// make vector! [decimal! 64 100]
// make vector! [unsigned integer! 32]
// Fields:
// signed: signed, unsigned
// datatypes: integer, decimal
// dimensions: 1 - N
// bitsize: 1, 8, 16, 32, 64
// size: integer units
// init: block of values
//
REBVAL *Make_Vector_Spec(RELVAL *bp, REBCTX *specifier, REBVAL *value)
{
REBINT type = -1; // 0 = int, 1 = float
REBINT sign = -1; // 0 = signed, 1 = unsigned
REBINT dims = 1;
REBINT bits = 32;
REBCNT size = 1;
REBSER *vect;
REBVAL *iblk = 0;
// UNSIGNED
if (IS_WORD(bp) && VAL_WORD_SYM(bp) == SYM_UNSIGNED) {
sign = 1;
bp++;
}
// INTEGER! or DECIMAL!
if (IS_WORD(bp)) {
if (SAME_SYM_NONZERO(VAL_WORD_SYM(bp), SYM_FROM_KIND(REB_INTEGER)))
type = 0;
else if (
SAME_SYM_NONZERO(VAL_WORD_SYM(bp), SYM_FROM_KIND(REB_DECIMAL))
){
type = 1;
if (sign > 0) return 0;
}
else return 0;
bp++;
}
if (type < 0) type = 0;
if (sign < 0) sign = 0;
// BITS
if (IS_INTEGER(bp)) {
bits = Int32(KNOWN(bp));
if (
(bits == 32 || bits == 64)
||
(type == 0 && (bits == 8 || bits == 16))
) bp++;
else return 0;
} else return 0;
// SIZE
if (NOT_END(bp) && IS_INTEGER(bp)) {
if (Int32(KNOWN(bp)) < 0) return 0;
size = Int32(KNOWN(bp));
bp++;
}
// Initial data:
if (NOT_END(bp) && (IS_BLOCK(bp) || IS_BINARY(bp))) {
REBCNT len = VAL_LEN_AT(bp);
if (IS_BINARY(bp) && type == 1) return 0;
if (len > size) size = len;
iblk = KNOWN(bp);
bp++;
}
VAL_RESET_HEADER(value, REB_VECTOR);
// Index offset:
if (NOT_END(bp) && IS_INTEGER(bp)) {
VAL_INDEX(value) = (Int32s(KNOWN(bp), 1) - 1);
bp++;
}
else VAL_INDEX(value) = 0;
if (NOT_END(bp)) return 0;
vect = Make_Vector(type, sign, dims, bits, size);
if (!vect) return 0;
if (iblk) Set_Vector_Row(vect, iblk);
INIT_VAL_SERIES(value, vect);
MANAGE_SERIES(vect);
// index set earlier
return value;
}
//
// RL_Make_Image: C
//
// Allocate a new image of the given size.
//
// Returns:
// A pointer to an image series, or zero if size is too large.
// Arguments:
// width - the width of the image in pixels
// height - the height of the image in lines
// Notes:
// Images are allocated with REBOL's internal memory manager.
// Image are automatically garbage collected if there are
// no references to them from REBOL code (C code does nothing.)
//
RL_API REBSER *RL_Make_Image(u32 width, u32 height)
{
REBSER *ser = Make_Image(width, height, FALSE);
MANAGE_SERIES(ser);
return ser;
}
*/ REBSER *Make_Object(REBSER *parent, REBVAL value[])
/*
** Create an object from a parent object and a spec block.
** The words within the resultant object are not bound.
**
***********************************************************************/
{
REBSER *words;
REBSER *object;
PG_Reb_Stats->Objects++;
if (!value || IS_END(value)) {
if (parent) {
object = Copy_Array_Core_Managed(
parent, 0, SERIES_TAIL(parent), TRUE, TS_CLONE
);
}
else {
object = Make_Frame(0, TRUE);
MANAGE_FRAME(object);
}
}
else {
words = Collect_Frame(parent, &value[0], BIND_ONLY); // GC safe
object = Create_Frame(words, 0); // GC safe
if (parent) {
if (Reb_Opts->watch_obj_copy)
Debug_Fmt(cs_cast(BOOT_STR(RS_WATCH, 2)), SERIES_TAIL(parent) - 1, FRM_WORD_SERIES(object));
// Bitwise copy parent values (will have bits fixed by Clonify)
memcpy(
FRM_VALUES(object) + 1,
FRM_VALUES(parent) + 1,
(SERIES_TAIL(parent) - 1) * sizeof(REBVAL)
);
// For values we copied that were blocks and strings, replace
// their series components with deep copies of themselves:
Clonify_Values_Len_Managed(
BLK_SKIP(object, 1), SERIES_TAIL(object) - 1, TRUE, TS_CLONE
);
// The *word series* might have been reused from the parent,
// based on whether any words were added, or we could have gotten
// a fresh one back. Force our invariant here (as the screws
// tighten...)
ENSURE_SERIES_MANAGED(FRM_WORD_SERIES(object));
MANAGE_SERIES(object);
}
else {
MANAGE_FRAME(object);
}
assert(words == FRM_WORD_SERIES(object));
}
ASSERT_SERIES_MANAGED(object);
ASSERT_SERIES_MANAGED(FRM_WORD_SERIES(object));
ASSERT_FRAME(object);
return object;
}
static REBOOL get_scalar(const REBSTU *stu,
const struct Struct_Field *field,
REBCNT n, /* element index, starting from 0 */
REBVAL *val)
{
REBYTE *data = SERIES_SKIP(STRUCT_DATA_BIN(stu),
STRUCT_OFFSET(stu) + field->offset + n * field->size);
switch (field->type) {
case STRUCT_TYPE_UINT8:
SET_INTEGER(val, *(u8*)data);
break;
case STRUCT_TYPE_INT8:
SET_INTEGER(val, *(i8*)data);
break;
case STRUCT_TYPE_UINT16:
SET_INTEGER(val, *(u16*)data);
break;
case STRUCT_TYPE_INT16:
SET_INTEGER(val, *(i8*)data);
break;
case STRUCT_TYPE_UINT32:
SET_INTEGER(val, *(u32*)data);
break;
case STRUCT_TYPE_INT32:
SET_INTEGER(val, *(i32*)data);
break;
case STRUCT_TYPE_UINT64:
SET_INTEGER(val, *(u64*)data);
break;
case STRUCT_TYPE_INT64:
SET_INTEGER(val, *(i64*)data);
break;
case STRUCT_TYPE_FLOAT:
SET_DECIMAL(val, *(float*)data);
break;
case STRUCT_TYPE_DOUBLE:
SET_DECIMAL(val, *(double*)data);
break;
case STRUCT_TYPE_POINTER:
SET_INTEGER(val, cast(REBUPT, *cast(void**, data)));
break;
case STRUCT_TYPE_STRUCT:
{
SET_TYPE(val, REB_STRUCT);
VAL_STRUCT_FIELDS(val) = field->fields;
VAL_STRUCT_SPEC(val) = field->spec;
VAL_STRUCT_DATA(val) = Make_Series(
1, sizeof(struct Struct_Data), MKS_NONE
);
MANAGE_SERIES(VAL_STRUCT_DATA(val));
VAL_STRUCT_DATA_BIN(val) = STRUCT_DATA_BIN(stu);
VAL_STRUCT_OFFSET(val) = data - SERIES_DATA(VAL_STRUCT_DATA_BIN(val));
VAL_STRUCT_LEN(val) = field->size;
}
break;
case STRUCT_TYPE_REBVAL:
memcpy(val, data, sizeof(REBVAL));
break;
default:
/* should never be here */
return FALSE;
}
return TRUE;
}
*/ REBFLG MT_Struct(REBVAL *out, REBVAL *data, enum Reb_Kind type)
/*
* Format:
* make struct! [
* field1 [type1]
* field2: [type2] field2-init-value
* field3: [struct [field1 [type1]]]
* field4: [type1[3]]
* ...
* ]
***********************************************************************/
{
//RL_Print("%s\n", __func__);
REBINT max_fields = 16;
VAL_STRUCT_FIELDS(out) = Make_Series(
max_fields, sizeof(struct Struct_Field), MKS_NONE
);
MANAGE_SERIES(VAL_STRUCT_FIELDS(out));
if (IS_BLOCK(data)) {
//if (Reduce_Block_No_Set_Throws(VAL_SERIES(data), 0, NULL))...
//data = DS_POP;
REBVAL *blk = VAL_BLK_DATA(data);
REBINT field_idx = 0; /* for field index */
u64 offset = 0; /* offset in data */
REBCNT eval_idx = 0; /* for spec block evaluation */
REBVAL *init = NULL; /* for result to save in data */
REBOOL expect_init = FALSE;
REBINT raw_size = -1;
REBUPT raw_addr = 0;
REBCNT alignment = 0;
VAL_STRUCT_SPEC(out) = Copy_Array_Shallow(VAL_SERIES(data));
VAL_STRUCT_DATA(out) = Make_Series(
1, sizeof(struct Struct_Data), MKS_NONE
);
EXPAND_SERIES_TAIL(VAL_STRUCT_DATA(out), 1);
VAL_STRUCT_DATA_BIN(out) = Make_Series(max_fields << 2, 1, MKS_NONE);
VAL_STRUCT_OFFSET(out) = 0;
// We tell the GC to manage this series, but it will not cause a
// synchronous garbage collect. Still, when's the right time?
ENSURE_SERIES_MANAGED(VAL_STRUCT_SPEC(out));
MANAGE_SERIES(VAL_STRUCT_DATA(out));
MANAGE_SERIES(VAL_STRUCT_DATA_BIN(out));
/* set type early such that GC will handle it correctly, i.e, not collect series in the struct */
SET_TYPE(out, REB_STRUCT);
if (IS_BLOCK(blk)) {
parse_attr(blk, &raw_size, &raw_addr);
++ blk;
}
while (NOT_END(blk)) {
REBVAL *inner;
struct Struct_Field *field = NULL;
u64 step = 0;
EXPAND_SERIES_TAIL(VAL_STRUCT_FIELDS(out), 1);
DS_PUSH_NONE;
inner = DS_TOP; /* save in stack so that it won't be GC'ed when MT_Struct is recursively called */
field = (struct Struct_Field *)SERIES_SKIP(VAL_STRUCT_FIELDS(out), field_idx);
field->offset = (REBCNT)offset;
if (IS_SET_WORD(blk)) {
field->sym = VAL_WORD_SYM(blk);
expect_init = TRUE;
if (raw_addr) {
/* initialization is not allowed for raw memory struct */
raise Error_Invalid_Arg(blk);
}
} else if (IS_WORD(blk)) {
field->sym = VAL_WORD_SYM(blk);
expect_init = FALSE;
}
else
raise Error_Has_Bad_Type(blk);
++ blk;
if (!IS_BLOCK(blk))
raise Error_Invalid_Arg(blk);
if (!parse_field_type(field, blk, inner, &init)) { return FALSE; }
++ blk;
STATIC_assert(sizeof(field->size) <= 4);
STATIC_assert(sizeof(field->dimension) <= 4);
step = (u64)field->size * (u64)field->dimension;
if (step > VAL_STRUCT_LIMIT)
raise Error_1(RE_SIZE_LIMIT, out);
EXPAND_SERIES_TAIL(VAL_STRUCT_DATA_BIN(out), step);
if (expect_init) {
REBVAL safe; // result of reduce or do (GC saved during eval)
init = &safe;
if (IS_BLOCK(blk)) {
if (Reduce_Block_Throws(init, VAL_SERIES(blk), 0, FALSE))
raise Error_No_Catch_For_Throw(init);
++ blk;
} else {
DO_NEXT_MAY_THROW(
eval_idx,
init,
VAL_SERIES(data),
blk - VAL_BLK_DATA(data)
);
if (eval_idx == THROWN_FLAG)
raise Error_No_Catch_For_Throw(init);
blk = VAL_BLK_SKIP(data, eval_idx);
}
if (field->array) {
if (IS_INTEGER(init)) { /* interpreted as a C pointer */
void *ptr = cast(void *, cast(REBUPT, VAL_INT64(init)));
/* assuming it's an valid pointer and holding enough space */
memcpy(SERIES_SKIP(VAL_STRUCT_DATA_BIN(out), (REBCNT)offset), ptr, field->size * field->dimension);
} else if (IS_BLOCK(init)) {
REBCNT n = 0;
if (VAL_LEN(init) != field->dimension)
raise Error_Invalid_Arg(init);
/* assign */
for (n = 0; n < field->dimension; n ++) {
if (!assign_scalar(&VAL_STRUCT(out), field, n, VAL_BLK_SKIP(init, n))) {
//RL_Print("Failed to assign element value\n");
goto failed;
}
}
}
else
raise Error_Unexpected_Type(REB_BLOCK, VAL_TYPE(blk));
} else {
/* scalar */
if (!assign_scalar(&VAL_STRUCT(out), field, 0, init)) {
//RL_Print("Failed to assign scalar value\n");
goto failed;
}
}
} else if (raw_addr == 0) {
*/ static REB_R Loop_Each(struct Reb_Call *call_, LOOP_MODE mode)
/*
** Common implementation code of FOR-EACH, REMOVE-EACH, MAP-EACH,
** and EVERY.
**
***********************************************************************/
{
REBSER *body;
REBVAL *vars;
REBVAL *words;
REBSER *frame;
// `data` is the series/object/map/etc. being iterated over
// Note: `data_is_object` flag is optimized out, but hints static analyzer
REBVAL *data = D_ARG(2);
REBSER *series;
const REBOOL data_is_object = ANY_OBJECT(data);
REBSER *out; // output block (needed for MAP-EACH)
REBINT index; // !!!! should these be REBCNT?
REBINT tail;
REBINT windex; // write
REBINT rindex; // read
REBOOL break_with = FALSE;
REBOOL every_true = TRUE;
REBCNT i;
REBCNT j;
REBVAL *ds;
if (IS_NONE(data)) return R_NONE;
body = Init_Loop(D_ARG(1), D_ARG(3), &frame); // vars, body
Val_Init_Object(D_ARG(1), frame); // keep GC safe
Val_Init_Block(D_ARG(3), body); // keep GC safe
SET_NONE(D_OUT); // Default result to NONE if the loop does not run
if (mode == LOOP_MAP_EACH) {
// Must be managed *and* saved...because we are accumulating results
// into it, and those results must be protected from GC
// !!! This means we cannot Free_Series in case of a BREAK, we
// have to leave it to the GC. Should there be a variant which
// lets a series be a GC root for a temporary time even if it is
// not SER_KEEP?
out = Make_Array(VAL_LEN(data));
MANAGE_SERIES(out);
SAVE_SERIES(out);
}
// Get series info:
if (data_is_object) {
series = VAL_OBJ_FRAME(data);
out = FRM_WORD_SERIES(series); // words (the out local reused)
index = 1;
//if (frame->tail > 3) raise Error_Invalid_Arg(FRM_WORD(frame, 3));
}
else if (IS_MAP(data)) {
series = VAL_SERIES(data);
index = 0;
//if (frame->tail > 3) raise Error_Invalid_Arg(FRM_WORD(frame, 3));
}
else {
series = VAL_SERIES(data);
index = VAL_INDEX(data);
if (index >= cast(REBINT, SERIES_TAIL(series))) {
if (mode == LOOP_REMOVE_EACH) {
SET_INTEGER(D_OUT, 0);
}
else if (mode == LOOP_MAP_EACH) {
UNSAVE_SERIES(out);
Val_Init_Block(D_OUT, out);
}
return R_OUT;
}
}
windex = index;
// Iterate over each value in the data series block:
while (index < (tail = SERIES_TAIL(series))) {
rindex = index; // remember starting spot
j = 0;
// Set the FOREACH loop variables from the series:
for (i = 1; i < frame->tail; i++) {
vars = FRM_VALUE(frame, i);
words = FRM_WORD(frame, i);
// var spec is WORD
if (IS_WORD(words)) {
if (index < tail) {
if (ANY_BLOCK(data)) {
*vars = *BLK_SKIP(series, index);
}
else if (data_is_object) {
if (!VAL_GET_EXT(BLK_SKIP(out, index), EXT_WORD_HIDE)) {
// Alternate between word and value parts of object:
if (j == 0) {
Val_Init_Word(vars, REB_WORD, VAL_WORD_SYM(BLK_SKIP(out, index)), series, index);
if (NOT_END(vars+1)) index--; // reset index for the value part
}
else if (j == 1)
*vars = *BLK_SKIP(series, index);
else
raise Error_Invalid_Arg(words);
j++;
}
else {
// Do not evaluate this iteration
index++;
goto skip_hidden;
}
}
else if (IS_VECTOR(data)) {
Set_Vector_Value(vars, series, index);
}
else if (IS_MAP(data)) {
REBVAL *val = BLK_SKIP(series, index | 1);
if (!IS_NONE(val)) {
if (j == 0) {
*vars = *BLK_SKIP(series, index & ~1);
if (IS_END(vars+1)) index++; // only words
}
else if (j == 1)
*vars = *BLK_SKIP(series, index);
else
raise Error_Invalid_Arg(words);
j++;
}
else {
index += 2;
goto skip_hidden;
}
}
else { // A string or binary
if (IS_BINARY(data)) {
SET_INTEGER(vars, (REBI64)(BIN_HEAD(series)[index]));
}
else if (IS_IMAGE(data)) {
Set_Tuple_Pixel(BIN_SKIP(series, index), vars);
}
else {
VAL_SET(vars, REB_CHAR);
VAL_CHAR(vars) = GET_ANY_CHAR(series, index);
}
}
index++;
}
else SET_NONE(vars);
}
// var spec is SET_WORD:
else if (IS_SET_WORD(words)) {
if (ANY_OBJECT(data) || IS_MAP(data))
*vars = *data;
else
Val_Init_Block_Index(vars, series, index);
//if (index < tail) index++; // do not increment block.
}
else
raise Error_Invalid_Arg(words);
}
if (index == rindex) {
// the word block has only set-words: for-each [a:] [1 2 3][]
index++;
}
if (Do_Block_Throws(D_OUT, body, 0)) {
if (IS_WORD(D_OUT) && VAL_WORD_SYM(D_OUT) == SYM_CONTINUE) {
if (mode == LOOP_REMOVE_EACH) {
// signal the post-body-execution processing that we
// *do not* want to remove the element on a CONTINUE
SET_FALSE(D_OUT);
}
else {
// CONTINUE otherwise acts "as if" the loop body execution
// returned an UNSET!
SET_UNSET(D_OUT);
}
}
else if (IS_WORD(D_OUT) && VAL_WORD_SYM(D_OUT) == SYM_BREAK) {
// If it's a BREAK, get the /WITH value (UNSET! if no /WITH)
// Though technically this doesn't really tell us if a
// BREAK/WITH happened, as you can BREAK/WITH an UNSET!
TAKE_THROWN_ARG(D_OUT, D_OUT);
if (!IS_UNSET(D_OUT))
break_with = TRUE;
index = rindex;
break;
}
else {
// Any other kind of throw, with a WORD! name or otherwise...
index = rindex;
break;
}
}
switch (mode) {
case LOOP_FOR_EACH:
// no action needed after body is run
break;
case LOOP_REMOVE_EACH:
// If FALSE return, copy values to the write location
// !!! Should UNSET! also act as conditional false here? Error?
if (IS_CONDITIONAL_FALSE(D_OUT)) {
REBYTE wide = SERIES_WIDE(series);
// memory areas may overlap, so use memmove and not memcpy!
// !!! This seems a slow way to do it, but there's probably
// not a lot that can be done as the series is expected to
// be in a good state for the next iteration of the body. :-/
memmove(
series->data + (windex * wide),
series->data + (rindex * wide),
(index - rindex) * wide
);
windex += index - rindex;
}
break;
case LOOP_MAP_EACH:
// anything that's not an UNSET! will be added to the result
if (!IS_UNSET(D_OUT)) Append_Value(out, D_OUT);
break;
case LOOP_EVERY:
if (every_true) {
// !!! This currently treats UNSET! as true, which ALL
// effectively does right now. That's likely a bad idea.
// When ALL changes, so should this.
//
every_true = IS_CONDITIONAL_TRUE(D_OUT);
}
break;
default:
assert(FALSE);
}
skip_hidden: ;
}
switch (mode) {
case LOOP_FOR_EACH:
// Nothing to do but return last result (will be UNSET! if an
// ordinary BREAK was used, the /WITH if a BREAK/WITH was used,
// and an UNSET! if the last loop iteration did a CONTINUE.)
return R_OUT;
case LOOP_REMOVE_EACH:
// Remove hole (updates tail):
if (windex < index) Remove_Series(series, windex, index - windex);
SET_INTEGER(D_OUT, index - windex);
return R_OUT;
case LOOP_MAP_EACH:
UNSAVE_SERIES(out);
if (break_with) {
// If BREAK is given a /WITH parameter that is not an UNSET!, it
// is assumed that you want to override the accumulated mapped
// data so far and return the /WITH value. (which will be in
// D_OUT when the loop above is `break`-ed)
// !!! Would be nice if we could Free_Series(out), but it is owned
// by GC (we had to make it that way to use SAVE_SERIES on it)
return R_OUT;
}
// If you BREAK/WITH an UNSET! (or just use a BREAK that has no
// /WITH, which is indistinguishable in the thrown value) then it
// returns the accumulated results so far up to the break.
Val_Init_Block(D_OUT, out);
return R_OUT;
case LOOP_EVERY:
// Result is the cumulative TRUE? state of all the input (with any
// unsets taken out of the consideration). The last TRUE? input
// if all valid and NONE! otherwise. (Like ALL.) If the loop
// never runs, `every_true` will be TRUE *but* D_OUT will be NONE!
if (!every_true)
SET_NONE(D_OUT);
return R_OUT;
}
DEAD_END;
}
