*/ 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; }