*/ 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 REBFLG Print_Native_Modifying_Throws(
REBVAL *value, // Value may be modified. Contents must be GC-safe!
REBOOL newline
) {
if (IS_UNSET(value)) {
#if !defined(NDEBUG)
if (LEGACY(OPTIONS_PRINT_FORMS_EVERYTHING))
goto form_it;
#endif
// No effect (not even a newline). Previously this also was the
// behavior for NONE, but now that none is considered "reified" it
// does not opt out from rendering.
}
else if (IS_BINARY(value)) {
#if !defined(NDEBUG)
if (LEGACY(OPTIONS_PRINT_FORMS_EVERYTHING))
goto form_it;
#endif
// Send raw bytes to the console. CGI+ANSI+VT100 etc. require it
// for full 8-bit byte transport (UTF-8 is by definition not good
// enough...some bytes are illegal to occur in UTF-8 at all).
//
// Given that PRINT is not a general-purpose PROBE tool (it has
// never output values purely "as is", evaluating blocks for
// instance) it's worth doing a "strange" thing (though no stranger
// than WRITE) to be able to access the facility.
Prin_OS_String(VAL_BIN_DATA(value), VAL_LEN(value), OPT_ENC_RAW);
// !!! Binary print should never output a newline. This would seem
// more natural if PRINT's decision to output newlines was guided
// by whether it was given a block or not (under consideration).
}
else if (IS_BLOCK(value)) {
// !!! Pending plan for PRINT of BLOCK! is to do something like
// COMBINE where NONE! is elided, single characters are not spaced out,
// nested blocks are recursed, etc. So:
//
// print ["A" newline "B" if 1 > 2 [newline] if 1 < 2 ["C"]]]
//
// Would output the following (where _ is space):
//
// A
// B_C
//
// As opposed to historical output, which is:
//
// A_
// B_none_C
//
// Currently it effectively FORM REDUCEs the output.
if (Reduce_Block_Throws(
value, VAL_SERIES(value), VAL_INDEX(value), FALSE
)) {
return TRUE;
}
Prin_Value(value, 0, 0);
if (newline)
Print_OS_Line();
}
else {
#if !defined(NDEBUG)
form_it: // used only by OPTIONS_PRINT_FORMS_EVERYTHING
#endif
// !!! Full behavior review needed for all types.
Prin_Value(value, 0, 0);
if (newline)
Print_OS_Line();
}
return FALSE;
}
