*/ void Set_Error_Type(ERROR_OBJ *error)
/*
** Sets error type and id fields based on code number.
**
***********************************************************************/
{
REBSER *cats; // Error catalog object
REBSER *cat; // Error category object
REBCNT n; // Word symbol number
REBCNT code;
code = VAL_INT32(&error->code);
// Set error category:
n = code / 100 + 1;
cats = VAL_OBJ_FRAME(Get_System(SYS_CATALOG, CAT_ERRORS));
if (code >= 0 && n < SERIES_TAIL(cats) &&
NZ(cat = VAL_SERIES(BLK_SKIP(cats, n)))
) {
Set_Word(&error->type, FRM_WORD_SYM(cats, n), cats, n);
// Find word related to the error itself:
n = code % 100 + 3;
if (n < SERIES_TAIL(cat))
Set_Word(&error->id, FRM_WORD_SYM(cat, n), cat, n);
}
}
*/ REBVAL *Find_Error_Info(ERROR_OBJ *error, REBINT *num)
/*
** Return the error message needed to print an error.
** Must scan the error catalog and its error lists.
** Note that the error type and id words no longer need
** to be bound to the error catalog context.
** If the message is not found, return null.
**
***********************************************************************/
{
REBSER *frame;
REBVAL *obj1;
REBVAL *obj2;
if (!IS_WORD(&error->type) || !IS_WORD(&error->id)) return 0;
// Find the correct error type object in the catalog:
frame = VAL_OBJ_FRAME(Get_System(SYS_CATALOG, CAT_ERRORS));
obj1 = Find_Word_Value(frame, VAL_WORD_SYM(&error->type));
if (!obj1) return 0;
// Now find the correct error message for that type:
frame = VAL_OBJ_FRAME(obj1);
obj2 = Find_Word_Value(frame, VAL_WORD_SYM(&error->id));
if (!obj2) return 0;
if (num) {
obj1 = Find_Word_Value(frame, SYM_CODE);
*num = VAL_INT32(obj1)
+ Find_Word_Index(frame, VAL_WORD_SYM(&error->id), FALSE)
- Find_Word_Index(frame, SYM_TYPE, FALSE) - 1;
}
return obj2;
}
*/ REBINT Get_Num_Arg(REBVAL *val)
/*
** Get the amount to skip or pick.
** Allow multiple types. Throw error if not valid.
** Note that the result is one-based.
**
***********************************************************************/
{
REBINT n;
if (IS_INTEGER(val)) {
if (VAL_INT64(val) > (i64)MAX_I32 || VAL_INT64(val) < (i64)MIN_I32)
Trap_Range(val);
n = VAL_INT32(val);
}
else if (IS_DECIMAL(val) || IS_PERCENT(val)) {
if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
Trap_Range(val);
n = (REBINT)VAL_DECIMAL(val);
}
else if (IS_LOGIC(val)) n = (VAL_LOGIC(val) ? 1 : 2);
else Trap_Arg(val);
return n;
}
static REBCNT find_string(REBSER *series, REBCNT index, REBCNT end, REBVAL *target, REBCNT len, REBCNT flags, REBINT skip)
{
REBCNT start = index;
if (flags & (AM_FIND_REVERSE | AM_FIND_LAST)) {
skip = -1;
start = 0;
if (flags & AM_FIND_LAST) index = end - len;
else index--;
}
if (ANY_BINSTR(target)) {
// Do the optimal search or the general search?
if (BYTE_SIZE(series) && VAL_BYTE_SIZE(target) && !(flags & ~(AM_FIND_CASE|AM_FIND_MATCH)))
return Find_Byte_Str(series, start, VAL_BIN_DATA(target), len, !GET_FLAG(flags, ARG_FIND_CASE-1), GET_FLAG(flags, ARG_FIND_MATCH-1));
else
return Find_Str_Str(series, start, index, end, skip, VAL_SERIES(target), VAL_INDEX(target), len, flags & (AM_FIND_MATCH|AM_FIND_CASE));
}
else if (IS_BINARY(target)) {
return Find_Byte_Str(series, start, VAL_BIN_DATA(target), len, 0, GET_FLAG(flags, ARG_FIND_MATCH-1));
}
else if (IS_CHAR(target)) {
return Find_Str_Char(series, start, index, end, skip, VAL_CHAR(target), flags);
}
else if (IS_INTEGER(target)) {
return Find_Str_Char(series, start, index, end, skip, (REBUNI)VAL_INT32(target), flags);
}
else if (IS_BITSET(target)) {
return Find_Str_Bitset(series, start, index, end, skip, VAL_SERIES(target), flags);
}
return NOT_FOUND;
}
//
// Int32s: C
//
// Get integer as positive, negative 32 bit value.
// Sign field can be
// 0: >= 0
// 1: > 0
// -1: < 0
//
REBINT Int32s(const REBVAL *val, REBINT sign)
{
REBINT n = 0;
if (IS_DECIMAL(val)) {
if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
fail (Error_Out_Of_Range(val));
n = (REBINT)VAL_DECIMAL(val);
} else {
if (VAL_INT64(val) > (i64)MAX_I32 || VAL_INT64(val) < (i64)MIN_I32)
fail (Error_Out_Of_Range(val));
n = VAL_INT32(val);
}
// More efficient to use positive sense:
if (
(sign == 0 && n >= 0) ||
(sign > 0 && n > 0) ||
(sign < 0 && n < 0)
)
return n;
fail (Error_Out_Of_Range(val));
}
//
// Int8u: C
//
REBINT Int8u(const REBVAL *val)
{
if (VAL_INT64(val) > cast(i64, 255) || VAL_INT64(val) < cast(i64, 0))
fail (Error_Out_Of_Range(val));
return VAL_INT32(val);
}
*/ REBINT Int8u(REBVAL *val)
/*
***********************************************************************/
{
if (VAL_INT64(val) > (i64)255 || VAL_INT64(val) < (i64)0) Trap_Range(val);
return VAL_INT32(val);
}
*/ REBINT Int32s(REBVAL *val, REBINT sign)
/*
** Get integer as positive, negative 32 bit value.
** Sign field can be
** 0: >= 0
** 1: > 0
** -1: < 0
**
***********************************************************************/
{
REBINT n = 0;
if (IS_DECIMAL(val)) {
if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
Trap_Range(val);
n = (REBINT)VAL_DECIMAL(val);
} else {
if (VAL_INT64(val) > (i64)MAX_I32 || VAL_INT64(val) < (i64)MIN_I32)
Trap_Range(val);
n = VAL_INT32(val);
}
// More efficient to use positive sense:
if (
(sign == 0 && n >= 0) ||
(sign > 0 && n > 0) ||
(sign < 0 && n < 0)
)
return n;
Trap_Range(val);
return 0;
}
*/ REBINT Get_System_Int(REBCNT i1, REBCNT i2, REBINT default_int)
/*
** Get an integer from system object.
**
***********************************************************************/
{
REBVAL *val = Get_System(i1, i2);
if (IS_INTEGER(val)) return VAL_INT32(val);
return default_int;
}
static void
test_write_number_int32(void)
{
struct spdk_json_write_ctx *w;
BEGIN();
VAL_INT32(0);
END("0");
BEGIN();
VAL_INT32(1);
END("1");
BEGIN();
VAL_INT32(123);
END("123");
BEGIN();
VAL_INT32(-123);
END("-123");
BEGIN();
VAL_INT32(2147483647);
END("2147483647");
BEGIN();
VAL_INT32(-2147483648);
END("-2147483648");
}
*/ static REBFLG Set_Struct_Var(REBSTU *stu, REBVAL *word, REBVAL *elem, REBVAL *val)
/*
***********************************************************************/
{
struct Struct_Field *field = NULL;
REBCNT i = 0;
field = (struct Struct_Field *)SERIES_DATA(stu->fields);
for (i = 0; i < SERIES_TAIL(stu->fields); i ++, field ++) {
if (VAL_WORD_CANON(word) == VAL_SYM_CANON(BLK_SKIP(PG_Word_Table.series, field->sym))) {
if (field->array) {
if (elem == NULL) { //set the whole array
REBCNT n = 0;
if ((!IS_BLOCK(val) || field->dimension != VAL_LEN(val))) {
return FALSE;
}
for(n = 0; n < field->dimension; n ++) {
if (!assign_scalar(stu, field, n, VAL_BLK_SKIP(val, n))) {
return FALSE;
}
}
} else {// set only one element
if (!IS_INTEGER(elem)
|| VAL_INT32(elem) <= 0
|| VAL_INT32(elem) > cast(REBINT, field->dimension)) {
return FALSE;
}
return assign_scalar(stu, field, VAL_INT32(elem) - 1, val);
}
return TRUE;
} else {
return assign_scalar(stu, field, 0, val);
}
return TRUE;
}
}
return FALSE;
}
//
// Int32: C
//
REBINT Int32(const REBVAL *val)
{
REBINT n = 0;
if (IS_DECIMAL(val)) {
if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
fail (Error_Out_Of_Range(val));
n = (REBINT)VAL_DECIMAL(val);
} else {
if (VAL_INT64(val) > (i64)MAX_I32 || VAL_INT64(val) < (i64)MIN_I32)
fail (Error_Out_Of_Range(val));
n = VAL_INT32(val);
}
return n;
}
*/ REBINT Int32(REBVAL *val)
/*
***********************************************************************/
{
REBINT n = 0;
if (IS_DECIMAL(val)) {
if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
Trap_Range(val);
n = (REBINT)VAL_DECIMAL(val);
} else {
if (VAL_INT64(val) > (i64)MAX_I32 || VAL_INT64(val) < (i64)MIN_I32)
Trap_Range(val);
n = VAL_INT32(val);
}
return n;
}
//
// Get_Num_From_Arg: C
//
// Get the amount to skip or pick.
// Allow multiple types. Throw error if not valid.
// Note that the result is one-based.
//
REBINT Get_Num_From_Arg(const REBVAL *val)
{
REBINT n;
if (IS_INTEGER(val)) {
if (VAL_INT64(val) > (i64)MAX_I32 || VAL_INT64(val) < (i64)MIN_I32)
fail (Error_Out_Of_Range(val));
n = VAL_INT32(val);
}
else if (IS_DECIMAL(val) || IS_PERCENT(val)) {
if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
fail (Error_Out_Of_Range(val));
n = (REBINT)VAL_DECIMAL(val);
}
else if (IS_LOGIC(val))
n = (VAL_LOGIC(val) ? 1 : 2);
else
fail (Error_Invalid_Arg(val));
return n;
}
static void
test_write_object(void)
{
struct spdk_json_write_ctx *w;
BEGIN();
VAL_OBJECT_BEGIN();
VAL_OBJECT_END();
END("{}");
BEGIN();
VAL_OBJECT_BEGIN();
VAL_NAME("a");
VAL_INT32(0);
VAL_OBJECT_END();
END("{\"a\":0}");
BEGIN();
VAL_OBJECT_BEGIN();
VAL_NAME("a");
VAL_INT32(0);
VAL_NAME("b");
VAL_INT32(1);
VAL_OBJECT_END();
END("{\"a\":0,\"b\":1}");
BEGIN();
VAL_OBJECT_BEGIN();
VAL_NAME("a");
VAL_INT32(0);
VAL_NAME("b");
VAL_INT32(1);
VAL_NAME("c");
VAL_INT32(2);
VAL_OBJECT_END();
END("{\"a\":0,\"b\":1,\"c\":2}");
}
//
// Get_System_Int: C
//
// Get an integer from system object.
//
REBINT Get_System_Int(REBCNT i1, REBCNT i2, REBINT default_int)
{
REBVAL *val = Get_System(i1, i2);
if (IS_INTEGER(val)) return VAL_INT32(val);
return default_int;
}
static void
test_write_nesting(void)
{
struct spdk_json_write_ctx *w;
BEGIN();
VAL_ARRAY_BEGIN();
VAL_ARRAY_BEGIN();
VAL_ARRAY_END();
VAL_ARRAY_END();
END("[[]]");
BEGIN();
VAL_ARRAY_BEGIN();
VAL_ARRAY_BEGIN();
VAL_ARRAY_BEGIN();
VAL_ARRAY_END();
VAL_ARRAY_END();
VAL_ARRAY_END();
END("[[[]]]");
BEGIN();
VAL_ARRAY_BEGIN();
VAL_INT32(0);
VAL_ARRAY_BEGIN();
VAL_ARRAY_END();
VAL_ARRAY_END();
END("[0,[]]");
BEGIN();
VAL_ARRAY_BEGIN();
VAL_ARRAY_BEGIN();
VAL_ARRAY_END();
VAL_INT32(0);
VAL_ARRAY_END();
END("[[],0]");
BEGIN();
VAL_ARRAY_BEGIN();
VAL_INT32(0);
VAL_ARRAY_BEGIN();
VAL_INT32(1);
VAL_ARRAY_END();
VAL_INT32(2);
VAL_ARRAY_END();
END("[0,[1],2]");
BEGIN();
VAL_ARRAY_BEGIN();
VAL_INT32(0);
VAL_INT32(1);
VAL_ARRAY_BEGIN();
VAL_INT32(2);
VAL_INT32(3);
VAL_ARRAY_END();
VAL_INT32(4);
VAL_INT32(5);
VAL_ARRAY_END();
END("[0,1,[2,3],4,5]");
BEGIN();
VAL_OBJECT_BEGIN();
VAL_NAME("a");
VAL_OBJECT_BEGIN();
VAL_OBJECT_END();
VAL_OBJECT_END();
END("{\"a\":{}}");
BEGIN();
VAL_OBJECT_BEGIN();
VAL_NAME("a");
VAL_OBJECT_BEGIN();
VAL_NAME("b");
VAL_INT32(0);
VAL_OBJECT_END();
VAL_OBJECT_END();
END("{\"a\":{\"b\":0}}");
BEGIN();
VAL_OBJECT_BEGIN();
VAL_NAME("a");
VAL_ARRAY_BEGIN();
VAL_INT32(0);
VAL_ARRAY_END();
VAL_OBJECT_END();
END("{\"a\":[0]}");
BEGIN();
VAL_ARRAY_BEGIN();
VAL_OBJECT_BEGIN();
VAL_NAME("a");
VAL_INT32(0);
VAL_OBJECT_END();
VAL_ARRAY_END();
END("[{\"a\":0}]");
BEGIN();
VAL_ARRAY_BEGIN();
VAL_OBJECT_BEGIN();
VAL_NAME("a");
VAL_OBJECT_BEGIN();
VAL_NAME("b");
VAL_ARRAY_BEGIN();
VAL_OBJECT_BEGIN();
VAL_NAME("c");
VAL_INT32(1);
VAL_OBJECT_END();
VAL_INT32(2);
VAL_ARRAY_END();
VAL_NAME("d");
VAL_INT32(3);
VAL_OBJECT_END();
VAL_NAME("e");
VAL_INT32(4);
VAL_OBJECT_END();
VAL_INT32(5);
VAL_ARRAY_END();
END("[{\"a\":{\"b\":[{\"c\":1},2],\"d\":3},\"e\":4},5]");
/* Examples from RFC 7159 */
BEGIN();
VAL_OBJECT_BEGIN();
VAL_NAME("Image");
VAL_OBJECT_BEGIN();
VAL_NAME("Width");
VAL_INT32(800);
VAL_NAME("Height");
VAL_INT32(600);
VAL_NAME("Title");
VAL_STRING("View from 15th Floor");
VAL_NAME("Thumbnail");
VAL_OBJECT_BEGIN();
VAL_NAME("Url");
VAL_STRING("http://www.example.com/image/481989943");
VAL_NAME("Height");
VAL_INT32(125);
VAL_NAME("Width");
VAL_INT32(100);
VAL_OBJECT_END();
VAL_NAME("Animated");
VAL_FALSE();
VAL_NAME("IDs");
VAL_ARRAY_BEGIN();
VAL_INT32(116);
VAL_INT32(943);
VAL_INT32(234);
VAL_INT32(38793);
VAL_ARRAY_END();
VAL_OBJECT_END();
VAL_OBJECT_END();
END(
"{\"Image\":"
"{"
"\"Width\":800,"
"\"Height\":600,"
"\"Title\":\"View from 15th Floor\","
"\"Thumbnail\":{"
"\"Url\":\"http://www.example.com/image/481989943\","
"\"Height\":125,"
"\"Width\":100"
"},"
"\"Animated\":false,"
"\"IDs\":[116,943,234,38793]"
"}"
"}");
}
static REBCNT find_string(
REBSER *series,
REBCNT index,
REBCNT end,
REBVAL *target,
REBCNT target_len,
REBCNT flags,
REBINT skip
) {
assert(end >= index);
if (target_len > end - index) // series not long enough to have target
return NOT_FOUND;
REBCNT start = index;
if (flags & (AM_FIND_REVERSE | AM_FIND_LAST)) {
skip = -1;
start = 0;
if (flags & AM_FIND_LAST) index = end - target_len;
else index--;
}
if (ANY_BINSTR(target)) {
// Do the optimal search or the general search?
if (
BYTE_SIZE(series)
&& VAL_BYTE_SIZE(target)
&& !(flags & ~(AM_FIND_CASE|AM_FIND_MATCH))
) {
return Find_Byte_Str(
series,
start,
VAL_BIN_AT(target),
target_len,
NOT(GET_FLAG(flags, ARG_FIND_CASE - 1)),
GET_FLAG(flags, ARG_FIND_MATCH - 1)
);
}
else {
return Find_Str_Str(
series,
start,
index,
end,
skip,
VAL_SERIES(target),
VAL_INDEX(target),
target_len,
flags & (AM_FIND_MATCH|AM_FIND_CASE)
);
}
}
else if (IS_BINARY(target)) {
const REBOOL uncase = FALSE;
return Find_Byte_Str(
series,
start,
VAL_BIN_AT(target),
target_len,
uncase, // "don't treat case insensitively"
GET_FLAG(flags, ARG_FIND_MATCH - 1)
);
}
else if (IS_CHAR(target)) {
return Find_Str_Char(
VAL_CHAR(target),
series,
start,
index,
end,
skip,
flags
);
}
else if (IS_INTEGER(target)) {
return Find_Str_Char(
cast(REBUNI, VAL_INT32(target)),
series,
start,
index,
end,
skip,
flags
);
}
else if (IS_BITSET(target)) {
return Find_Str_Bitset(
series,
start,
index,
end,
skip,
VAL_SERIES(target),
flags
);
}
return NOT_FOUND;
}
*/ static REBFLG Set_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
switch (VAL_WORD_CANON(word)) {
case SYM_OFFSET:
return Set_Pair(&(gob->offset), val);
case SYM_SIZE:
return Set_Pair(&gob->size, val);
case SYM_IMAGE:
CLR_GOB_OPAQUE(gob);
if (IS_IMAGE(val)) {
SET_GOB_TYPE(gob, GOBT_IMAGE);
GOB_W(gob) = (REBD32)VAL_IMAGE_WIDE(val);
GOB_H(gob) = (REBD32)VAL_IMAGE_HIGH(val);
GOB_CONTENT(gob) = VAL_SERIES(val);
// if (!VAL_IMAGE_TRANSP(val)) SET_GOB_OPAQUE(gob);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_DRAW:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_DRAW);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_TEXT:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_TEXT);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_STRING(val)) {
SET_GOB_TYPE(gob, GOBT_STRING);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_EFFECT:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_EFFECT);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_COLOR:
CLR_GOB_OPAQUE(gob);
if (IS_TUPLE(val)) {
SET_GOB_TYPE(gob, GOBT_COLOR);
Set_Pixel_Tuple((REBYTE*)&GOB_CONTENT(gob), val);
if (VAL_TUPLE_LEN(val) < 4 || VAL_TUPLE(val)[3] == 0)
SET_GOB_OPAQUE(gob);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
break;
case SYM_PANE:
if (GOB_PANE(gob)) Clear_Series(GOB_PANE(gob));
if (IS_BLOCK(val))
Insert_Gobs(gob, VAL_BLK_DATA(val), 0, VAL_BLK_LEN(val), 0);
else if (IS_GOB(val))
Insert_Gobs(gob, val, 0, 1, 0);
else if (IS_NONE(val))
gob->pane = 0;
else
return FALSE;
break;
case SYM_ALPHA:
GOB_ALPHA(gob) = Clip_Int(Int32(val), 0, 255);
break;
case SYM_DATA:
SET_GOB_DTYPE(gob, GOBD_NONE);
if (IS_OBJECT(val)) {
SET_GOB_DTYPE(gob, GOBD_OBJECT);
SET_GOB_DATA(gob, VAL_OBJ_FRAME(val));
}
else if (IS_BLOCK(val)) {
SET_GOB_DTYPE(gob, GOBD_BLOCK);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_STRING(val)) {
SET_GOB_DTYPE(gob, GOBD_STRING);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_BINARY(val)) {
SET_GOB_DTYPE(gob, GOBD_BINARY);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_INTEGER(val)) {
SET_GOB_DTYPE(gob, GOBD_INTEGER);
SET_GOB_DATA(gob, (void*)VAL_INT32(val));
}
else if (IS_NONE(val))
SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_FLAGS:
if (IS_WORD(val)) Set_Gob_Flag(gob, val);
else if (IS_BLOCK(val)) {
REBINT i;
//clear only flags defined by words
for (i = 0; Gob_Flag_Words[i]; i += 2)
CLR_FLAG(gob->flags, Gob_Flag_Words[i+1]);
for (val = VAL_BLK(val); NOT_END(val); val++)
if (IS_WORD(val)) Set_Gob_Flag(gob, val);
}
break;
case SYM_OWNER:
if (IS_GOB(val))
GOB_TMP_OWNER(gob) = VAL_GOB(val);
else
return FALSE;
break;
default:
return FALSE;
}
return TRUE;
}
*/ void Resolve_Context(REBSER *target, REBSER *source, REBVAL *only_words, REBFLG all, REBFLG expand)
/*
** Only_words can be a block of words or an index in the target
** (for new words).
**
***********************************************************************/
{
REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
REBVAL *words;
REBVAL *vals;
REBINT n;
REBINT m;
REBCNT i = 0;
CHECK_BIND_TABLE;
if (IS_PROTECT_SERIES(target)) Trap0(RE_PROTECTED);
if (IS_INTEGER(only_words)) { // Must be: 0 < i <= tail
i = VAL_INT32(only_words); // never <= 0
if (i == 0) i = 1;
if (i >= target->tail) return;
}
Collect_Start(BIND_NO_SELF); // DO NOT TRAP IN THIS SECTION
n = 0;
// If limited resolve, tag the word ids that need to be copied:
if (i) {
// Only the new words of the target:
for (words = FRM_WORD(target, i); NOT_END(words); words++)
binds[VAL_BIND_CANON(words)] = -1;
n = SERIES_TAIL(target) - 1;
}
else if (IS_BLOCK(only_words)) {
// Limit exports to only these words:
for (words = VAL_BLK_DATA(only_words); NOT_END(words); words++) {
if (IS_WORD(words) || IS_SET_WORD(words)) {
binds[VAL_WORD_CANON(words)] = -1;
n++;
}
}
}
// Expand target as needed:
if (expand && n > 0) {
// Determine how many new words to add:
for (words = FRM_WORD(target, 1); NOT_END(words); words++)
if (binds[VAL_BIND_CANON(words)]) n--;
// Expand frame by the amount required:
if (n > 0) Expand_Frame(target, n, 0);
else expand = 0;
}
// Maps a word to its value index in the source context.
// Done by marking all source words (in bind table):
words = FRM_WORDS(source)+1;
for (n = 1; NOT_END(words); n++, words++) {
if (IS_NONE(only_words) || binds[VAL_BIND_CANON(words)])
binds[VAL_WORD_CANON(words)] = n;
}
// Foreach word in target, copy the correct value from source:
n = i ? i : 1;
vals = FRM_VALUE(target, n);
for (words = FRM_WORD(target, n); NOT_END(words); words++, vals++) {
if ((m = binds[VAL_BIND_CANON(words)])) {
binds[VAL_BIND_CANON(words)] = 0; // mark it as set
if (!VAL_PROTECTED(words) && (all || IS_UNSET(vals))) {
if (m < 0) SET_UNSET(vals); // no value in source context
else *vals = *FRM_VALUE(source, m);
//Debug_Num("type:", VAL_TYPE(vals));
//Debug_Str(Get_Word_Name(words));
}
}
}
// Add any new words and values:
if (expand) {
REBVAL *val;
words = FRM_WORDS(source)+1;
for (n = 1; NOT_END(words); n++, words++) {
if (binds[VAL_BIND_CANON(words)]) {
// Note: no protect check is needed here
binds[VAL_BIND_CANON(words)] = 0;
val = Append_Frame(target, 0, VAL_BIND_SYM(words));
*val = *FRM_VALUE(source, n);
}
}
}
else {
// Reset bind table (do not use Collect_End):
if (i) {
for (words = FRM_WORD(target, i); NOT_END(words); words++)
binds[VAL_BIND_CANON(words)] = 0;
}
else if (IS_BLOCK(only_words)) {
for (words = VAL_BLK_DATA(only_words); NOT_END(words); words++) {
if (IS_WORD(words) || IS_SET_WORD(words)) binds[VAL_WORD_CANON(words)] = 0;
}
}
else {
for (words = FRM_WORDS(source)+1; NOT_END(words); words++)
binds[VAL_BIND_CANON(words)] = 0;
}
}
CHECK_BIND_TABLE;
RESET_TAIL(BUF_WORDS); // allow reuse, trapping ok now
}
//
// Serial_Actor: C
//
static REB_R Serial_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
{
REBREQ *req; // IO request
REBVAL *spec; // port spec
REBVAL *arg; // action argument value
REBVAL *val; // e.g. port number value
REBINT result; // IO result
REBCNT refs; // refinement argument flags
REBCNT len; // generic length
REBSER *ser; // simplifier
REBVAL *path;
Validate_Port(port, action);
*D_OUT = *D_ARG(1);
// Validate PORT fields:
spec = CTX_VAR(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) fail (Error(RE_INVALID_PORT));
path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
if (!path) fail (Error(RE_INVALID_SPEC, spec));
//if (!IS_FILE(path)) fail (Error(RE_INVALID_SPEC, path));
req = cast(REBREQ*, Use_Port_State(port, RDI_SERIAL, sizeof(*req)));
// Actions for an unopened serial port:
if (!IS_OPEN(req)) {
switch (action) {
case SYM_OPEN:
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_PATH);
if (! (IS_FILE(arg) || IS_STRING(arg) || IS_BINARY(arg)))
fail (Error(RE_INVALID_PORT_ARG, arg));
req->special.serial.path = ALLOC_N(REBCHR, MAX_SERIAL_DEV_PATH);
OS_STRNCPY(
req->special.serial.path,
//
// !!! This is assuming VAL_DATA contains native chars.
// Should it? (2 bytes on windows, 1 byte on linux/mac)
//
SER_AT(REBCHR, VAL_SERIES(arg), VAL_INDEX(arg)),
MAX_SERIAL_DEV_PATH
);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_SPEED);
if (! IS_INTEGER(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
req->special.serial.baud = VAL_INT32(arg);
//Secure_Port(SYM_SERIAL, ???, path, ser);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_DATA_SIZE);
if (!IS_INTEGER(arg)
|| VAL_INT64(arg) < 5
|| VAL_INT64(arg) > 8
) {
fail (Error(RE_INVALID_PORT_ARG, arg));
}
req->special.serial.data_bits = VAL_INT32(arg);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_STOP_BITS);
if (!IS_INTEGER(arg)
|| VAL_INT64(arg) < 1
|| VAL_INT64(arg) > 2
) {
fail (Error(RE_INVALID_PORT_ARG, arg));
}
req->special.serial.stop_bits = VAL_INT32(arg);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_PARITY);
if (IS_BLANK(arg)) {
req->special.serial.parity = SERIAL_PARITY_NONE;
} else {
if (!IS_WORD(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
switch (VAL_WORD_SYM(arg)) {
case SYM_ODD:
req->special.serial.parity = SERIAL_PARITY_ODD;
break;
case SYM_EVEN:
req->special.serial.parity = SERIAL_PARITY_EVEN;
break;
default:
fail (Error(RE_INVALID_PORT_ARG, arg));
}
}
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_FLOW_CONTROL);
if (IS_BLANK(arg)) {
req->special.serial.flow_control = SERIAL_FLOW_CONTROL_NONE;
} else {
if (!IS_WORD(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
switch (VAL_WORD_SYM(arg)) {
case SYM_HARDWARE:
req->special.serial.flow_control = SERIAL_FLOW_CONTROL_HARDWARE;
break;
case SYM_SOFTWARE:
req->special.serial.flow_control = SERIAL_FLOW_CONTROL_SOFTWARE;
break;
default:
fail (Error(RE_INVALID_PORT_ARG, arg));
}
}
if (OS_DO_DEVICE(req, RDC_OPEN))
fail (Error_On_Port(RE_CANNOT_OPEN, port, -12));
SET_OPEN(req);
return R_OUT;
case SYM_CLOSE:
return R_OUT;
case SYM_OPEN_Q:
return R_FALSE;
default:
fail (Error_On_Port(RE_NOT_OPEN, port, -12));
}
}
// Actions for an open socket:
switch (action) {
case SYM_READ:
refs = Find_Refines(frame_, ALL_READ_REFS);
// Setup the read buffer (allocate a buffer if needed):
arg = CTX_VAR(port, STD_PORT_DATA);
if (!IS_STRING(arg) && !IS_BINARY(arg)) {
Val_Init_Binary(arg, Make_Binary(32000));
}
ser = VAL_SERIES(arg);
req->length = SER_AVAIL(ser); // space available
if (req->length < 32000/2) Extend_Series(ser, 32000);
req->length = SER_AVAIL(ser);
// This used STR_TAIL (obsolete, equivalent to BIN_TAIL) but was it
// sure the series was byte sized? Added in a check.
assert(BYTE_SIZE(ser));
req->common.data = BIN_TAIL(ser); // write at tail
//if (SER_LEN(ser) == 0)
req->actual = 0; // Actual for THIS read, not for total.
#ifdef DEBUG_SERIAL
printf("(max read length %d)", req->length);
#endif
result = OS_DO_DEVICE(req, RDC_READ); // recv can happen immediately
if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, req->error));
#ifdef DEBUG_SERIAL
for (len = 0; len < req->actual; len++) {
if (len % 16 == 0) printf("\n");
printf("%02x ", req->common.data[len]);
}
printf("\n");
#endif
*D_OUT = *arg;
return R_OUT;
case SYM_WRITE:
refs = Find_Refines(frame_, ALL_WRITE_REFS);
// Determine length. Clip /PART to size of string if needed.
spec = D_ARG(2);
len = VAL_LEN_AT(spec);
if (refs & AM_WRITE_PART) {
REBCNT n = Int32s(D_ARG(ARG_WRITE_LIMIT), 0);
if (n <= len) len = n;
}
// Setup the write:
*CTX_VAR(port, STD_PORT_DATA) = *spec; // keep it GC safe
req->length = len;
req->common.data = VAL_BIN_AT(spec);
req->actual = 0;
//Print("(write length %d)", len);
result = OS_DO_DEVICE(req, RDC_WRITE); // send can happen immediately
if (result < 0) fail (Error_On_Port(RE_WRITE_ERROR, port, req->error));
break;
case SYM_UPDATE:
// Update the port object after a READ or WRITE operation.
// This is normally called by the WAKE-UP function.
arg = CTX_VAR(port, STD_PORT_DATA);
if (req->command == RDC_READ) {
if (ANY_BINSTR(arg)) {
SET_SERIES_LEN(
VAL_SERIES(arg),
VAL_LEN_HEAD(arg) + req->actual
);
}
}
else if (req->command == RDC_WRITE) {
SET_BLANK(arg); // Write is done.
}
return R_BLANK;
case SYM_OPEN_Q:
return R_TRUE;
case SYM_CLOSE:
if (IS_OPEN(req)) {
OS_DO_DEVICE(req, RDC_CLOSE);
SET_CLOSED(req);
}
break;
default:
fail (Error_Illegal_Action(REB_PORT, action));
}
return R_OUT;
}
*/ static To_Thru(REBPARSE *parse, REBCNT index, REBVAL *block, REBFLG is_thru)
/*
***********************************************************************/
{
REBSER *series = parse->series;
REBCNT type = parse->type;
REBVAL *blk;
REBVAL *item;
REBCNT cmd;
REBCNT i;
REBCNT len;
for (; index <= series->tail; index++) {
for (blk = VAL_BLK(block); NOT_END(blk); blk++) {
item = blk;
// Deal with words and commands
if (IS_WORD(item)) {
if (cmd = VAL_CMD(item)) {
if (cmd == SYM_END) {
if (index >= series->tail) {
index = series->tail;
goto found;
}
goto next;
}
else if (cmd == SYM_QUOTE) {
item = ++blk; // next item is the quoted value
if (IS_END(item)) goto bad_target;
if (IS_PAREN(item)) {
item = Do_Block_Value_Throw(item); // might GC
}
}
else goto bad_target;
}
else {
item = Get_Var(item);
}
}
else if (IS_PATH(item)) {
item = Get_Parse_Value(item);
}
// Try to match it:
if (type >= REB_BLOCK) {
if (ANY_BLOCK(item)) goto bad_target;
i = Parse_Next_Block(parse, index, item, 0);
if (i != NOT_FOUND) {
if (!is_thru) i--;
index = i;
goto found;
}
}
else if (type == REB_BINARY) {
REBYTE ch1 = *BIN_SKIP(series, index);
// Handle special string types:
if (IS_CHAR(item)) {
if (VAL_CHAR(item) > 0xff) goto bad_target;
if (ch1 == VAL_CHAR(item)) goto found1;
}
else if (IS_BINARY(item)) {
if (ch1 == *VAL_BIN_DATA(item)) {
len = VAL_LEN(item);
if (len == 1) goto found1;
if (0 == Compare_Bytes(BIN_SKIP(series, index), VAL_BIN_DATA(item), len, 0)) {
if (is_thru) index += len;
goto found;
}
}
}
else if (IS_INTEGER(item)) {
if (VAL_INT64(item) > 0xff) goto bad_target;
if (ch1 == VAL_INT32(item)) goto found1;
}
else goto bad_target;
}
else { // String
REBCNT ch1 = GET_ANY_CHAR(series, index);
REBCNT ch2;
if (!HAS_CASE(parse)) ch1 = UP_CASE(ch1);
// Handle special string types:
if (IS_CHAR(item)) {
ch2 = VAL_CHAR(item);
if (!HAS_CASE(parse)) ch2 = UP_CASE(ch2);
if (ch1 == ch2) goto found1;
}
else if (ANY_STR(item)) {
ch2 = VAL_ANY_CHAR(item);
if (!HAS_CASE(parse)) ch2 = UP_CASE(ch2);
if (ch1 == ch2) {
len = VAL_LEN(item);
if (len == 1) goto found1;
i = Find_Str_Str(series, 0, index, SERIES_TAIL(series), 1, VAL_SERIES(item), VAL_INDEX(item), len, AM_FIND_MATCH | parse->flags);
if (i != NOT_FOUND) {
if (is_thru) i += len;
index = i;
goto found;
}
}
}
else if (IS_INTEGER(item)) {
ch1 = GET_ANY_CHAR(series, index); // No casing!
if (ch1 == (REBCNT)VAL_INT32(item)) goto found1;
}
else goto bad_target;
}
next: // Check for | (required if not end)
blk++;
if (IS_PAREN(blk)) blk++;
if (IS_END(blk)) break;
if (!IS_OR_BAR(blk)) {
item = blk;
goto bad_target;
}
}
}
return NOT_FOUND;
found:
if (IS_PAREN(blk+1)) Do_Block_Value_Throw(blk+1);
return index;
found1:
if (IS_PAREN(blk+1)) Do_Block_Value_Throw(blk+1);
return index + (is_thru ? 1 : 0);
bad_target:
Trap1(RE_PARSE_RULE, item);
return 0;
}
*/ void Make_Error_Object(REBVAL *arg, REBVAL *value)
/*
** Creates an error object from arg and puts it in value.
** The arg can be a string or an object body block.
** This function is called by MAKE ERROR!.
**
***********************************************************************/
{
REBSER *err; // Error object
ERROR_OBJ *error; // Error object values
REBINT code = 0;
// Create a new error object from another object, including any non-standard fields:
if (IS_ERROR(arg) || IS_OBJECT(arg)) {
err = Merge_Frames(VAL_OBJ_FRAME(ROOT_ERROBJ),
IS_ERROR(arg) ? VAL_OBJ_FRAME(arg) : VAL_ERR_OBJECT(arg));
error = ERR_VALUES(err);
// if (!IS_INTEGER(&error->code)) {
if (!Find_Error_Info(error, &code)) code = RE_INVALID_ERROR;
SET_INTEGER(&error->code, code);
// }
SET_ERROR(value, VAL_INT32(&error->code), err);
return;
}
// Make a copy of the error object template:
err = CLONE_OBJECT(VAL_OBJ_FRAME(ROOT_ERROBJ));
error = ERR_VALUES(err);
SET_NONE(&error->id);
SET_ERROR(value, 0, err);
// If block arg, evaluate object values (checking done later):
// If user set error code, use it to setup type and id fields.
if (IS_BLOCK(arg)) {
DISABLE_GC;
Do_Bind_Block(err, arg); // GC-OK (disabled)
ENABLE_GC;
if (IS_INTEGER(&error->code) && VAL_INT64(&error->code)) {
Set_Error_Type(error);
} else {
if (Find_Error_Info(error, &code)) {
SET_INTEGER(&error->code, code);
}
}
// The error code is not valid:
if (IS_NONE(&error->id)) {
SET_INTEGER(&error->code, RE_INVALID_ERROR);
Set_Error_Type(error);
}
if (VAL_INT64(&error->code) < 100 || VAL_INT64(&error->code) > 1000)
Trap_Arg(arg);
}
// If string arg, setup other fields
else if (IS_STRING(arg)) {
SET_INTEGER(&error->code, RE_USER); // user error
Set_String(&error->arg1, Copy_Series_Value(arg));
Set_Error_Type(error);
}
// No longer allowed:
// else if (IS_INTEGER(arg)) {
// error->code = *arg;
// Set_Error_Type(error);
// }
else
Trap_Arg(arg);
if (!(VAL_ERR_NUM(value) = VAL_INT32(&error->code))) {
Trap_Arg(arg);
}
}
//
// Transport_Actor: C
//
static REB_R Transport_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action, enum Transport_Types proto)
{
REBREQ *sock; // IO request
REBVAL *spec; // port spec
REBVAL *arg; // action argument value
REBVAL *val; // e.g. port number value
REBINT result; // IO result
REBCNT refs; // refinement argument flags
REBCNT len; // generic length
REBSER *ser; // simplifier
Validate_Port(port, action);
*D_OUT = *D_ARG(1);
arg = DS_ARGC > 1 ? D_ARG(2) : NULL;
sock = cast(REBREQ*, Use_Port_State(port, RDI_NET, sizeof(*sock)));
if (proto == TRANSPORT_UDP) {
SET_FLAG(sock->modes, RST_UDP);
}
//Debug_Fmt("Sock: %x", sock);
spec = OFV(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) fail (Error(RE_INVALID_PORT));
// sock->timeout = 4000; // where does this go? !!!
// HOW TO PREVENT OVERWRITE DURING BUSY OPERATION!!!
// Should it just ignore it or cause an error?
// Actions for an unopened socket:
if (!IS_OPEN(sock)) {
switch (action) { // Ordered by frequency
case A_OPEN:
arg = Obj_Value(spec, STD_PORT_SPEC_NET_HOST);
val = Obj_Value(spec, STD_PORT_SPEC_NET_PORT_ID);
if (OS_DO_DEVICE(sock, RDC_OPEN))
fail (Error_On_Port(RE_CANNOT_OPEN, port, -12));
SET_OPEN(sock);
// Lookup host name (an extra TCP device step):
if (IS_STRING(arg)) {
sock->common.data = VAL_BIN(arg);
sock->special.net.remote_port = IS_INTEGER(val) ? VAL_INT32(val) : 80;
result = OS_DO_DEVICE(sock, RDC_LOOKUP); // sets remote_ip field
if (result < 0)
fail (Error_On_Port(RE_NO_CONNECT, port, sock->error));
return R_OUT;
}
// Host IP specified:
else if (IS_TUPLE(arg)) {
sock->special.net.remote_port = IS_INTEGER(val) ? VAL_INT32(val) : 80;
memcpy(&sock->special.net.remote_ip, VAL_TUPLE(arg), 4);
break;
}
// No host, must be a LISTEN socket:
else if (IS_NONE(arg)) {
SET_FLAG(sock->modes, RST_LISTEN);
sock->common.data = 0; // where ACCEPT requests are queued
sock->special.net.local_port = IS_INTEGER(val) ? VAL_INT32(val) : 8000;
break;
}
else
fail (Error_On_Port(RE_INVALID_SPEC, port, -10));
case A_CLOSE:
return R_OUT;
case A_OPENQ:
return R_FALSE;
case A_UPDATE: // allowed after a close
break;
default:
fail (Error_On_Port(RE_NOT_OPEN, port, -12));
}
}
// Actions for an open socket:
switch (action) { // Ordered by frequency
case A_UPDATE:
// Update the port object after a READ or WRITE operation.
// This is normally called by the WAKE-UP function.
arg = OFV(port, STD_PORT_DATA);
if (sock->command == RDC_READ) {
if (ANY_BINSTR(arg)) VAL_TAIL(arg) += sock->actual;
}
else if (sock->command == RDC_WRITE) {
SET_NONE(arg); // Write is done.
}
return R_NONE;
case A_READ:
// Read data into a buffer, expanding the buffer if needed.
// If no length is given, program must stop it at some point.
refs = Find_Refines(call_, ALL_READ_REFS);
if (
!GET_FLAG(sock->modes, RST_UDP)
&& !GET_FLAG(sock->state, RSM_CONNECT)
) {
fail (Error_On_Port(RE_NOT_CONNECTED, port, -15));
}
// Setup the read buffer (allocate a buffer if needed):
arg = OFV(port, STD_PORT_DATA);
if (!IS_STRING(arg) && !IS_BINARY(arg)) {
Val_Init_Binary(arg, Make_Binary(NET_BUF_SIZE));
}
ser = VAL_SERIES(arg);
sock->length = SERIES_AVAIL(ser); // space available
if (sock->length < NET_BUF_SIZE/2) Extend_Series(ser, NET_BUF_SIZE);
sock->length = SERIES_AVAIL(ser);
sock->common.data = STR_TAIL(ser); // write at tail
//if (SERIES_TAIL(ser) == 0)
sock->actual = 0; // Actual for THIS read, not for total.
//Print("(max read length %d)", sock->length);
result = OS_DO_DEVICE(sock, RDC_READ); // recv can happen immediately
if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, sock->error));
break;
case A_WRITE:
// Write the entire argument string to the network.
// The lower level write code continues until done.
refs = Find_Refines(call_, ALL_WRITE_REFS);
if (!GET_FLAG(sock->modes, RST_UDP)
&& !GET_FLAG(sock->state, RSM_CONNECT))
fail (Error_On_Port(RE_NOT_CONNECTED, port, -15));
// Determine length. Clip /PART to size of string if needed.
spec = D_ARG(2);
len = VAL_LEN(spec);
if (refs & AM_WRITE_PART) {
REBCNT n = Int32s(D_ARG(ARG_WRITE_LIMIT), 0);
if (n <= len) len = n;
}
// Setup the write:
*OFV(port, STD_PORT_DATA) = *spec; // keep it GC safe
sock->length = len;
sock->common.data = VAL_BIN_DATA(spec);
sock->actual = 0;
//Print("(write length %d)", len);
result = OS_DO_DEVICE(sock, RDC_WRITE); // send can happen immediately
if (result < 0) fail (Error_On_Port(RE_WRITE_ERROR, port, sock->error));
if (result == DR_DONE) SET_NONE(OFV(port, STD_PORT_DATA));
break;
case A_PICK:
// FIRST server-port returns new port connection.
len = Get_Num_Arg(arg); // Position
if (len == 1 && GET_FLAG(sock->modes, RST_LISTEN) && sock->common.data)
Accept_New_Port(D_OUT, port, sock); // sets D_OUT
else
fail (Error_Out_Of_Range(arg));
break;
case A_QUERY:
// Get specific information - the scheme's info object.
// Special notation allows just getting part of the info.
Ret_Query_Net(port, sock, D_OUT);
break;
case A_OPENQ:
// Connect for clients, bind for servers:
if (sock->state & ((1<<RSM_CONNECT) | (1<<RSM_BIND))) return R_TRUE;
return R_FALSE;
case A_CLOSE:
if (IS_OPEN(sock)) {
OS_DO_DEVICE(sock, RDC_CLOSE);
SET_CLOSED(sock);
}
break;
case A_LENGTH:
arg = OFV(port, STD_PORT_DATA);
len = ANY_SERIES(arg) ? VAL_TAIL(arg) : 0;
SET_INTEGER(D_OUT, len);
break;
case A_OPEN:
result = OS_DO_DEVICE(sock, RDC_CONNECT);
if (result < 0)
fail (Error_On_Port(RE_NO_CONNECT, port, sock->error));
break;
case A_DELETE: // Temporary to TEST error handler!
{
REBVAL *event = Append_Event(); // sets signal
VAL_SET(event, REB_EVENT); // (has more space, if we need it)
VAL_EVENT_TYPE(event) = EVT_ERROR;
VAL_EVENT_DATA(event) = 101;
VAL_EVENT_REQ(event) = sock;
}
break;
default:
fail (Error_Illegal_Action(REB_PORT, action));
}
return R_OUT;
}
*/ REBINT Effect_Gob(void *effects, REBSER *block)
/*
** Handles all commands for the EFFECT dialect as specified
** in the system/dialects/effect object.
**
** This function calls the REBOL_Dialect interpreter to
** parse the dialect and build and return the command number
** (the index offset in the draw object above) and a block
** of arguments. (For now, just a REBOL block, but this could
** be changed to isolate it from changes in REBOL's internals).
**
** Each arg will be of the specified datatype (given in the
** dialect) or NONE when no argument of that type was given
** and this code must determine the proper default value.
**
** If the cmd result is zero, then it is either the end of
** the block, or an error has occurred. If the error value
** is non-zero, then it was an error.
**
***********************************************************************/
{
// REBSER *block;
REBCNT index = 0;
REBINT cmd;
REBSER *args = 0;
REBVAL *arg;
REBCNT nargs;
//default values
REBYTE def_color1[4] = {0,0,0,0};
REBYTE def_color2[4] = {255,255,255,0};
REBPAR def_pair = {1,0};
do {
cmd = Reb_Dialect(DIALECTS_EFFECT, block, &index, &args);
if (cmd == 0) return 0;
if (cmd < 0) {
// Reb_Print("ERROR: %d, Index %d", -cmd, index);
return -((REBINT)index+1);
}
// else
// Reb_Print("EFFECT: Cmd %d, Index %d, Args %m", cmd, index, args);
arg = BLK_HEAD(args);
nargs = SERIES_TAIL(args);
// Reb_Print("Number of args: %d", nargs);
switch (cmd) {
case EW_ADD:
FX_Add(effects, ARG_OPT_IMAGE(0), ARG_OPT_IMAGE(1));
break;
case EW_ALPHAMUL:
if (IS_IMAGE(arg))
FX_Alphamul(effects, ARG_IMAGE(0), IS_NONE(arg+1) ? 127 : ARG_INTEGER(1));
break;
case EW_ASPECT:
{
REBINT type = 1, mode = 2;
if (ARG_WORD(0) == EW_RESAMPLE){
type = 2;
mode = 1;
}
FX_Fit(effects,ARG_OPT_IMAGE(0), ARG_WORDS(type,EW_NEAREST,EW_GAUSSIAN), ARG_WORD(mode) == EW_RESAMPLE, IS_NONE(arg+3) ? 1.0 : ARG_DECIMAL(3), TRUE);
}
break;
case EW_BLUR:
// FX_Blur(effects, ARG_OPT_IMAGE(0));
{
REBDEC filter[9] = {0, 1, 0, 1, 1, 1, 0, 1, 0};
FX_Convolve(effects, ARG_OPT_IMAGE(0),filter , 5.0, 0, FALSE);
}
break;
case EW_COLORIFY:
FX_Colorify(effects, IS_NONE(arg+1) ? def_color2 : ARG_TUPLE(1) , IS_NONE(arg+2) ? 255 : max(0, min(255,ARG_INTEGER(2))), ARG_OPT_IMAGE(0));
break;
case EW_COLORIZE:
FX_Colorize(effects, IS_NONE(arg+1) ? def_color2 : ARG_TUPLE(1) , ARG_OPT_IMAGE(0));
break;
case EW_CONTRAST:
FX_Contrast(effects, IS_NONE(arg+1) ? 127 : ARG_INTEGER(1), ARG_OPT_IMAGE(0));
break;
case EW_CONVOLVE:
//[image! block! decimal! decimal! logic!]
if (IS_BLOCK(arg+1)) {
REBDEC filter[9];
REBSER* mtx = (REBSER*)ARG_BLOCK(1);
REBVAL* slot = BLK_HEAD(mtx);
REBCNT len = SERIES_TAIL(mtx) ,i, num = 0;
for (i = 0;i<len;i++){
if (IS_DECIMAL(slot+i))
filter[i] = VAL_DECIMAL(slot+i);
else if (IS_INTEGER(slot+i))
filter[i] = VAL_INT32(slot+i);
else
return -cmd;
num++;
}
if (num != 9) return -cmd;
FX_Convolve(effects, ARG_OPT_IMAGE(0),filter , ARG_DECIMAL(2), ARG_INTEGER(3), ARG_LOGIC(4));
}
break;
case EW_CROP:
FX_Crop(effects,ARG_OPT_IMAGE(0), IS_NONE(arg+1) ? 0 : &ARG_PAIR(1), IS_NONE(arg+2) ? 0 : &ARG_PAIR(2));
break;
case EW_DIFFERENCE:
FX_Difference(effects, IS_NONE(arg+2) ? def_color2 : ARG_TUPLE(2), ARG_OPT_IMAGE(0), ARG_OPT_IMAGE(1), (IS_NONE(arg+2)) ? 1 : 0);
break;
case EW_EMBOSS:
{
REBDEC filter[9] = {-1, 0, 1, -2, 0, 2, -1, 0, 1};
FX_Convolve(effects, ARG_OPT_IMAGE(0),filter , 6.0, 127, FALSE);
}
break;
case EW_EXTEND:
FX_Extend(effects,ARG_OPT_IMAGE(0), IS_NONE(arg+1) ? 0 : &ARG_PAIR(1), IS_NONE(arg+2) ? 0 : &ARG_PAIR(2));
break;
case EW_FIT:
if (IS_IMAGE(arg)){
REBINT type = 1, mode = 2;
if (ARG_WORD(0) == EW_RESAMPLE){
type = 2;
mode = 1;
}
FX_Fit(effects,ARG_IMAGE(0), ARG_WORDS(type,EW_NEAREST,EW_GAUSSIAN), ARG_WORD(mode) == EW_RESAMPLE, IS_NONE(arg+3) ? 1.0 : ARG_DECIMAL(3), FALSE);
}
break;
case EW_FLIP:
FX_Flip(effects, IS_NONE(arg+1) ? &def_pair : &ARG_PAIR(1), ARG_OPT_IMAGE(0));
break;
case EW_GRADCOL:
FX_Gradcol(effects, &ARG_PAIR(1), IS_NONE(arg+2) ? def_color1 : ARG_TUPLE(2), IS_NONE(arg+3) ? def_color2 : ARG_TUPLE(3),ARG_OPT_IMAGE(0));
break;
case EW_GRADIENT:
FX_Gradient(effects, &ARG_PAIR(1), IS_NONE(arg+2) ? def_color1 : ARG_TUPLE(2), IS_NONE(arg+3) ? def_color2 : ARG_TUPLE(3), ARG_OPT_IMAGE(0));
break;
case EW_GRADMUL:
FX_Gradmul(effects, &ARG_PAIR(1), IS_NONE(arg+2) ? def_color1 : ARG_TUPLE(2), IS_NONE(arg+3) ? def_color2 : ARG_TUPLE(3), ARG_OPT_IMAGE(0));
break;
case EW_GRAYSCALE:
FX_Grayscale(effects,ARG_OPT_IMAGE(0));
break;
case EW_HSV:
FX_HSV(effects, IS_NONE(arg+1) ? def_color2 : ARG_TUPLE(1), ARG_OPT_IMAGE(0));
break;
case EW_INVERT:
FX_Invert(effects,ARG_OPT_IMAGE(0));
break;
case EW_KEY:
if (IS_IMAGE(arg))
FX_Key(effects, IS_NONE(arg+1) ? def_color1 : ARG_TUPLE(1), ARG_IMAGE(0));
break;
case EW_LUMA:
FX_Luma(effects, IS_NONE(arg+1) ? 127 : ARG_INTEGER(1),ARG_OPT_IMAGE(0));
break;
case EW_MIX:
FX_Mix(effects, ARG_OPT_IMAGE(0), ARG_OPT_IMAGE(1));
break;
case EW_MULTIPLY:
{
REBINT i = 0x00FFFFFF;
REBYTE* color = (REBYTE*)&i;
if (IS_INTEGER(arg+3)) {
i = ARG_INTEGER(3);
i = i + (i << 8) + (i << 16);
} else if (IS_TUPLE(arg+2))
color = ARG_TUPLE(2);
FX_Multiply(effects, color ,ARG_OPT_IMAGE(0), ARG_OPT_IMAGE(1), (IS_NONE(arg+2) && IS_NONE(arg+3)) ? 1 : 0);
}
break;
case EW_REFLECT:
FX_Reflect(effects, IS_NONE(arg+1) ? &def_pair : &ARG_PAIR(1), ARG_OPT_IMAGE(0));
break;
case EW_ROTATE:
FX_Rotate(effects, IS_NONE(arg+1) ? 90 : ARG_INTEGER(1), ARG_OPT_IMAGE(0));
break;
case EW_SHADOW:
if (IS_IMAGE(arg))
FX_Shadow(effects, ARG_IMAGE(0), IS_NONE(arg+1) ? 0 : &ARG_PAIR(1), IS_NONE(arg+2) ? 0 : &ARG_PAIR(2), IS_NONE(arg+3) ? 0 : ARG_TUPLE(3), IS_NONE(arg+4) ? 0 : ARG_DECIMAL(4), IS_NONE(arg+5) ? 0 : ARG_WORD(5) == EW_ONLY);
break;
case EW_SHARPEN:
// FX_Sharpen(effects, ARG_OPT_IMAGE(0));
{
REBDEC filter[9] = {0, -1, 0, -1, 8, -1, 0, -1, 0};
FX_Convolve(effects, ARG_OPT_IMAGE(0),filter , 4.0, 0, FALSE);
}
break;
case EW_TILE:
if (IS_IMAGE(arg))
FX_Tile(effects, ARG_IMAGE(0), &ARG_PAIR(1));
break;
case EW_TILE_VIEW:
if (IS_IMAGE(arg)) {
REBPAR p;
Effect_Offset(effects, &p);
FX_Tile(effects, ARG_IMAGE(0), &p);
}
break;
case EW_TINT:
FX_Tint(effects, IS_NONE(arg+1) ? 127 : ARG_INTEGER(1),ARG_OPT_IMAGE(0));
break;
}
} while (TRUE);
}
*/ REBINT Text_Gob(void *richtext, REBSER *block)
/*
** Handles all commands for the TEXT dialect as specified
** in the system/dialects/text object.
**
** This function calls the REBOL_Dialect interpreter to
** parse the dialect and build and return the command number
** (the index offset in the text object above) and a block
** of arguments. (For now, just a REBOL block, but this could
** be changed to isolate it from changes in REBOL's internals).
**
** Each arg will be of the specified datatype (given in the
** dialect) or NONE when no argument of that type was given
** and this code must determine the proper default value.
**
** If the cmd result is zero, then it is either the end of
** the block, or an error has occurred. If the error value
** is non-zero, then it was an error.
**
***********************************************************************/
{
REBCNT index = 0;
REBINT cmd;
REBSER *args = 0;
REBVAL *arg;
REBCNT nargs;
//font object conversion related values
REBFNT* font;
REBVAL* val;
REBPAR offset;
REBPAR space;
//para object conversion related values
REBPRA* para;
REBPAR origin;
REBPAR margin;
REBPAR indent;
REBPAR scroll;
do {
cmd = Reb_Dialect(DIALECTS_TEXT, block, &index, &args);
if (cmd == 0) return 0;
if (cmd < 0) {
// Reb_Print("ERROR: %d, Index %d", -cmd, index);
return -((REBINT)index+1);
}
// else
// Reb_Print("TEXT: Cmd %d, Index %d, Args %m", cmd, index, args);
arg = BLK_HEAD(args);
nargs = SERIES_TAIL(args);
// Reb_Print("Number of args: %d", nargs);
switch (cmd) {
case TW_TYPE_SPEC:
if (IS_STRING(arg)) {
rt_text(richtext, ARG_STRING(0), index);
} else if (IS_TUPLE(arg)) {
rt_color(richtext, ARG_TUPLE(0));
}
break;
case TW_ANTI_ALIAS:
rt_anti_alias(richtext, ARG_OPT_LOGIC(0));
break;
case TW_SCROLL:
rt_scroll(richtext, ARG_PAIR(0));
break;
case TW_BOLD:
case TW_B:
rt_bold(richtext, ARG_OPT_LOGIC(0));
break;
case TW_ITALIC:
case TW_I:
rt_italic(richtext, ARG_OPT_LOGIC(0));
break;
case TW_UNDERLINE:
case TW_U:
rt_underline(richtext, ARG_OPT_LOGIC(0));
break;
case TW_CENTER:
rt_center(richtext);
break;
case TW_LEFT:
rt_left(richtext);
break;
case TW_RIGHT:
rt_right(richtext);
break;
case TW_FONT:
if (!IS_OBJECT(arg)) break;
font = (REBFNT*)rt_get_font(richtext);
val = BLK_HEAD(ARG_OBJECT(0))+1;
if (IS_STRING(val)) {
font->name = VAL_STRING(val);
}
// Reb_Print("font/name: %s", font->name);
val++;
if (IS_BLOCK(val)) {
REBSER* styles = VAL_SERIES(val);
REBVAL* slot = BLK_HEAD(styles);
REBCNT len = SERIES_TAIL(styles) ,i;
for (i = 0;i<len;i++){
if (IS_WORD(slot+i)){
set_font_styles(font, slot+i);
}
}
} else if (IS_WORD(val)) {
set_font_styles(font, val);
}
val++;
if (IS_INTEGER(val)) {
font->size = VAL_INT32(val);
}
// Reb_Print("font/size: %d", font->size);
val++;
if ((IS_TUPLE(val)) || (IS_NONE(val))) {
COPY_MEM(font->color,VAL_TUPLE(val), 4);
}
// Reb_Print("font/color: %d.%d.%d.%d", font->color[0],font->color[1],font->color[2],font->color[3]);
val++;
if ((IS_PAIR(val)) || (IS_NONE(val))) {
offset = VAL_PAIR(val);
font->offset_x = offset.x;
font->offset_y = offset.y;
}
// Reb_Print("font/offset: %dx%d", offset.x,offset.y);
val++;
if ((IS_PAIR(val)) || (IS_NONE(val))) {
space = VAL_PAIR(val);
font->space_x = space.x;
font->space_y = space.y;
}
// Reb_Print("font/space: %dx%d", space.x, space.y);
val++;
font->shadow_x = 0;
font->shadow_y = 0;
if (IS_BLOCK(val)) {
REBSER* ser = VAL_SERIES(val);
REBVAL* slot = BLK_HEAD(ser);
REBCNT len = SERIES_TAIL(ser) ,i;
for (i = 0;i<len;i++){
if (IS_PAIR(slot)) {
REBPAR shadow = VAL_PAIR(slot);
font->shadow_x = shadow.x;
font->shadow_y = shadow.y;
} else if (IS_TUPLE(slot)) {
COPY_MEM(font->shadow_color,VAL_TUPLE(slot), 4);
} else if (IS_INTEGER(slot)) {
font->shadow_blur = VAL_INT32(slot);
}
slot++;
}
} else if (IS_PAIR(val)) {
REBPAR shadow = VAL_PAIR(val);
font->shadow_x = shadow.x;
font->shadow_y = shadow.y;
}
rt_font(richtext, font);
break;
case TW_PARA:
if (!IS_OBJECT(arg)) break;
para = (REBPRA*)rt_get_para(richtext);
val = BLK_HEAD(ARG_OBJECT(0))+1;
if (IS_PAIR(val)) {
origin = VAL_PAIR(val);
para->origin_x = origin.x;
para->origin_y = origin.y;
}
// Reb_Print("para/origin: %dx%d", origin.x, origin.y);
val++;
if (IS_PAIR(val)) {
margin = VAL_PAIR(val);
para->margin_x = margin.x;
para->margin_y = margin.y;
}
// Reb_Print("para/margin: %dx%d", margin.x, margin.y);
val++;
if (IS_PAIR(val)) {
indent = VAL_PAIR(val);
para->indent_x = indent.x;
para->indent_y = indent.y;
}
// Reb_Print("para/indent: %dx%d", indent.x, indent.y);
val++;
if (IS_INTEGER(val)) {
para->tabs = VAL_INT32(val);
}
// Reb_Print("para/tabs: %d", para->tabs);
val++;
if (IS_LOGIC(val)) {
para->wrap = VAL_LOGIC(val);
}
// Reb_Print("para/wrap?: %d", para->wrap);
val++;
if (IS_PAIR(val)) {
scroll = VAL_PAIR(val);
para->scroll_x = scroll.x;
para->scroll_y = scroll.y;
}
// Reb_Print("para/scroll: %dx%d", scroll.x, scroll.y);
val++;
if (IS_WORD(val)) {
REBINT result = Reb_Find_Word(VAL_WORD_SYM(val), Symbol_Ids, 0);
switch (result){
case SW_RIGHT:
case SW_LEFT:
case SW_CENTER:
para->align = result;
break;
default:
para->align = SW_LEFT;
break;
}
}
val++;
if (IS_WORD(val)) {
REBINT result = Reb_Find_Word(VAL_WORD_SYM(val), Symbol_Ids, 0);
switch (result){
case SW_TOP:
case SW_BOTTOM:
case SW_MIDDLE:
para->valign = result;
break;
default:
para->valign = SW_TOP;
break;
}
}
rt_para(richtext, para);
break;
case TW_SIZE:
rt_font_size(richtext, ARG_INTEGER(0));
break;
case TW_SHADOW:
rt_shadow(richtext, &ARG_PAIR(0), ARG_TUPLE(1), ARG_INTEGER(2));
break;
case TW_DROP:
rt_drop(richtext, ARG_OPT_INTEGER(0));
break;
case TW_NEWLINE:
case TW_NL:
rt_newline(richtext, index);
break;
case TW_CARET:
{
REBPAR caret = {0,0};
REBPAR highlightStart = {0,0};
REBPAR highlightEnd = {0,0};
REBVAL *slot;
if (!IS_OBJECT(arg)) break;
val = BLK_HEAD(ARG_OBJECT(0))+1;
if (IS_BLOCK(val)) {
slot = BLK_HEAD(VAL_SERIES(val));
if (SERIES_TAIL(VAL_SERIES(val)) == 2 && IS_BLOCK(slot) && IS_STRING(slot+1)){
caret.x = 1 + slot->data.series.index;
caret.y = 1 + (slot+1)->data.series.index;;
//Reb_Print("caret %d, %d", caret.x, caret.y);
}
}
val++;
if (IS_BLOCK(val)) {
slot = BLK_HEAD(VAL_SERIES(val));
if (SERIES_TAIL(VAL_SERIES(val)) == 2 && IS_BLOCK(slot) && IS_STRING(slot+1)){
highlightStart.x = 1 + slot->data.series.index;
highlightStart.y = 1 + (slot+1)->data.series.index;;
//Reb_Print("highlight-start %d, %d", highlightStart.x, highlightStart.y);
}
}
val++;
if (IS_BLOCK(val)) {
slot = BLK_HEAD(VAL_SERIES(val));
if (SERIES_TAIL(VAL_SERIES(val)) == 2 && IS_BLOCK(slot) && IS_STRING(slot+1)){
highlightEnd.x = 1 + slot->data.series.index;
highlightEnd.y = 1 + (slot+1)->data.series.index;;
//Reb_Print("highlight-End %d, %d", highlightEnd.x, highlightEnd.y);
}
}
rt_caret(richtext, &caret, &highlightStart,&highlightEnd);
}
break;
}
} while (TRUE);
}
//
// Frame_For_Stack_Level: C
//
// Level can be an UNSET!, an INTEGER!, an ANY-FUNCTION!, or a FRAME!. If
// level is UNSET! then it means give whatever the first call found is.
//
// Returns NULL if the given level number does not correspond to a running
// function on the stack.
//
// Can optionally give back the index number of the stack level (counting
// where the most recently pushed stack level is the lowest #)
//
// !!! Unfortunate repetition of logic inside of BACKTRACE; find a way to
// unify the logic for omitting things like breakpoint frames, or either
// considering pending frames or not...
//
struct Reb_Frame *Frame_For_Stack_Level(
REBCNT *number_out,
const REBVAL *level,
REBOOL skip_current
) {
struct Reb_Frame *frame = FS_TOP;
REBOOL first = TRUE;
REBINT num = 0;
if (IS_INTEGER(level)) {
if (VAL_INT32(level) < 0) {
//
// !!! fail() here, or just return NULL?
//
return NULL;
}
}
// We may need to skip some number of frames, if there have been stack
// levels added since the numeric reference point that "level" was
// supposed to refer to has changed. For now that's only allowed to
// be one level, because it's rather fuzzy which stack levels to
// omit otherwise (pending? parens?)
//
if (skip_current)
frame = frame->prior;
for (; frame != NULL; frame = frame->prior) {
if (frame->mode != CALL_MODE_FUNCTION) {
//
// Don't consider pending calls, or GROUP!, or any non-invoked
// function as a candidate to target.
//
// !!! The inability to target a GROUP! by number is an artifact
// of implementation, in that there's no hook in Do_Core() at
// the point of group evaluation to process the return. The
// matter is different with a pending function call, because its
// arguments are only partially processed--hence something
// like a RESUME/AT or an EXIT/FROM would not know which array
// index to pick up running from.
//
continue;
}
if (first) {
if (
IS_FUNCTION_AND(FUNC_VALUE(frame->func), FUNC_CLASS_NATIVE)
&& (
FUNC_CODE(frame->func) == &N_pause
|| FUNC_CODE(frame->func) == N_breakpoint
)
) {
// this is considered the "0". Return it only if 0 was requested
// specifically (you don't "count down to it");
//
if (IS_INTEGER(level) && num == VAL_INT32(level))
goto return_maybe_set_number_out;
else {
first = FALSE;
continue;
}
}
else {
++num; // bump up from 0
}
}
if (IS_INTEGER(level) && num == VAL_INT32(level))
goto return_maybe_set_number_out;
first = FALSE;
if (frame->mode != CALL_MODE_FUNCTION) {
//
// Pending frames don't get numbered
//
continue;
}
if (IS_UNSET(level) || IS_NONE(level)) {
//
// Take first actual frame if unset or none
//
goto return_maybe_set_number_out;
}
else if (IS_INTEGER(level)) {
++num;
if (num == VAL_INT32(level))
goto return_maybe_set_number_out;
}
else if (IS_FRAME(level)) {
if (
(frame->flags & DO_FLAG_FRAME_CONTEXT)
&& frame->data.context == VAL_CONTEXT(level)
) {
goto return_maybe_set_number_out;
}
}
else {
assert(IS_FUNCTION(level));
if (VAL_FUNC(level) == frame->func)
goto return_maybe_set_number_out;
}
}
// Didn't find it...
//
return NULL;
return_maybe_set_number_out:
if (number_out)
*number_out = num;
return frame;
}
//
// MAKE_Pair: C
//
void MAKE_Pair(REBVAL *out, enum Reb_Kind type, const REBVAL *arg)
{
if (IS_PAIR(arg)) {
*out = *arg;
return;
}
if (IS_STRING(arg)) {
//
// -1234567890x-1234567890
//
REBCNT len;
REBYTE *bp
= Temp_Byte_Chars_May_Fail(arg, VAL_LEN_AT(arg), &len, FALSE);
if (!Scan_Pair(bp, len, out)) goto bad_make;
return;
}
REBDEC x;
REBDEC y;
if (IS_INTEGER(arg)) {
x = VAL_INT32(arg);
y = VAL_INT32(arg);
}
else if (IS_DECIMAL(arg)) {
x = VAL_DECIMAL(arg);
y = VAL_DECIMAL(arg);
}
else if (IS_BLOCK(arg) && VAL_LEN_AT(arg) == 2) {
RELVAL *item = VAL_ARRAY_AT(arg);
if (IS_INTEGER(item))
x = cast(REBDEC, VAL_INT64(item));
else if (IS_DECIMAL(item))
x = cast(REBDEC, VAL_DECIMAL(item));
else
goto bad_make;
++item;
if (IS_END(item))
goto bad_make;
if (IS_INTEGER(item))
y = cast(REBDEC, VAL_INT64(item));
else if (IS_DECIMAL(item))
y = cast(REBDEC, VAL_DECIMAL(item));
else
goto bad_make;
}
else
goto bad_make;
SET_PAIR(out, x, y);
return;
bad_make:
fail (Error_Bad_Make(REB_PAIR, arg));
}
*/ REBINT PD_Time(REBPVS *pvs)
/*
***********************************************************************/
{
REBVAL *val;
REBINT i;
REBINT n;
REBDEC f;
REB_TIMEF tf;
if (IS_WORD(pvs->select)) {
switch (VAL_WORD_CANON(pvs->select)) {
case SYM_HOUR: i = 0; break;
case SYM_MINUTE: i = 1; break;
case SYM_SECOND: i = 2; break;
default: return PE_BAD_SELECT;
}
}
else if (IS_INTEGER(pvs->select))
i = VAL_INT32(pvs->select) - 1;
else
return PE_BAD_SELECT;
Split_Time(VAL_TIME(pvs->value), &tf); // loses sign
if (!(val = pvs->setval)) {
val = pvs->store;
switch(i) {
case 0: // hours
SET_INTEGER(val, tf.h);
break;
case 1:
SET_INTEGER(val, tf.m);
break;
case 2:
if (tf.n == 0)
SET_INTEGER(val, tf.s);
else
SET_DECIMAL(val, (REBDEC)tf.s + (tf.n * NANO));
break;
default:
return PE_NONE;
}
return PE_USE;
} else {
if (IS_INTEGER(val) || IS_DECIMAL(val)) n = Int32s(val, 0);
else if (IS_NONE(val)) n = 0;
else return PE_BAD_SET;
switch(i) {
case 0:
tf.h = n;
break;
case 1:
tf.m = n;
break;
case 2:
if (IS_DECIMAL(val)) {
f = VAL_DECIMAL(val);
if (f < 0.0) Trap_Range_DEAD_END(val);
tf.s = (REBINT)f;
tf.n = (REBINT)((f - tf.s) * SEC_SEC);
}
else {
tf.s = n;
tf.n = 0;
}
break;
default:
return PE_BAD_SELECT;
}
VAL_TIME(pvs->value) = Join_Time(&tf, FALSE);
return PE_OK;
}
}
//
// Clipboard_Actor: C
//
static REB_R Clipboard_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
{
REBREQ *req;
REBINT result;
REBVAL *arg;
REBCNT refs; // refinement argument flags
REBINT len;
REBSER *ser;
Validate_Port(port, action);
arg = DS_ARGC > 1 ? D_ARG(2) : NULL;
req = cast(REBREQ*, Use_Port_State(port, RDI_CLIPBOARD, sizeof(REBREQ)));
switch (action) {
case A_UPDATE:
// Update the port object after a READ or WRITE operation.
// This is normally called by the WAKE-UP function.
arg = OFV(port, STD_PORT_DATA);
if (req->command == RDC_READ) {
// this could be executed twice:
// once for an event READ, once for the CLOSE following the READ
if (!req->common.data) return R_NONE;
len = req->actual;
if (GET_FLAG(req->flags, RRF_WIDE)) {
// convert to UTF8, so that it can be converted back to string!
Val_Init_Binary(arg, Make_UTF8_Binary(
req->common.data,
len / sizeof(REBUNI),
0,
OPT_ENC_UNISRC
));
}
else {
REBSER *ser = Make_Binary(len);
memcpy(BIN_HEAD(ser), req->common.data, len);
SERIES_TAIL(ser) = len;
Val_Init_Binary(arg, ser);
}
OS_FREE(req->common.data); // release the copy buffer
req->common.data = 0;
}
else if (req->command == RDC_WRITE) {
SET_NONE(arg); // Write is done.
}
return R_NONE;
case A_READ:
// This device is opened on the READ:
if (!IS_OPEN(req)) {
if (OS_DO_DEVICE(req, RDC_OPEN))
fail (Error_On_Port(RE_CANNOT_OPEN, port, req->error));
}
// Issue the read request:
CLR_FLAG(req->flags, RRF_WIDE); // allow byte or wide chars
result = OS_DO_DEVICE(req, RDC_READ);
if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, req->error));
if (result > 0) return R_NONE; /* pending */
// Copy and set the string result:
arg = OFV(port, STD_PORT_DATA);
len = req->actual;
if (GET_FLAG(req->flags, RRF_WIDE)) {
// convert to UTF8, so that it can be converted back to string!
Val_Init_Binary(arg, Make_UTF8_Binary(
req->common.data,
len / sizeof(REBUNI),
0,
OPT_ENC_UNISRC
));
}
else {
REBSER *ser = Make_Binary(len);
memcpy(BIN_HEAD(ser), req->common.data, len);
SERIES_TAIL(ser) = len;
Val_Init_Binary(arg, ser);
}
*D_OUT = *arg;
return R_OUT;
case A_WRITE:
if (!IS_STRING(arg) && !IS_BINARY(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
// This device is opened on the WRITE:
if (!IS_OPEN(req)) {
if (OS_DO_DEVICE(req, RDC_OPEN))
fail (Error_On_Port(RE_CANNOT_OPEN, port, req->error));
}
refs = Find_Refines(call_, ALL_WRITE_REFS);
// Handle /part refinement:
len = VAL_LEN(arg);
if (refs & AM_WRITE_PART && VAL_INT32(D_ARG(ARG_WRITE_LIMIT)) < len)
len = VAL_INT32(D_ARG(ARG_WRITE_LIMIT));
// If bytes, see if we can fit it:
if (SERIES_WIDE(VAL_SERIES(arg)) == 1) {
#ifdef ARG_STRINGS_ALLOWED
if (!All_Bytes_ASCII(VAL_BIN_DATA(arg), len)) {
Val_Init_String(
arg, Copy_Bytes_To_Unicode(VAL_BIN_DATA(arg), len)
);
} else
req->common.data = VAL_BIN_DATA(arg);
#endif
// Temp conversion:!!!
ser = Make_Unicode(len);
len = Decode_UTF8(UNI_HEAD(ser), VAL_BIN_DATA(arg), len, FALSE);
SERIES_TAIL(ser) = len = abs(len);
UNI_TERM(ser);
Val_Init_String(arg, ser);
req->common.data = cast(REBYTE*, UNI_HEAD(ser));
SET_FLAG(req->flags, RRF_WIDE);
}
else
// If unicode (may be from above conversion), handle it:
if (SERIES_WIDE(VAL_SERIES(arg)) == sizeof(REBUNI)) {
req->common.data = cast(REBYTE *, VAL_UNI_DATA(arg));
SET_FLAG(req->flags, RRF_WIDE);
}
