//
// MAKE_Datatype: C
//
void MAKE_Datatype(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
if (!IS_WORD(arg))
fail (Error_Bad_Make(kind, arg));
REBSYM sym = VAL_WORD_SYM(arg);
if (sym == SYM_0 || sym > SYM_FROM_KIND(REB_MAX))
fail (Error_Bad_Make(kind, arg));
VAL_RESET_HEADER(out, REB_DATATYPE);
VAL_TYPE_KIND(out) = KIND_FROM_SYM(sym);
VAL_TYPE_SPEC(out) = 0;
}
//
// MAKE_Function: C
//
// For REB_FUNCTION and "make spec", there is a function spec block and then
// a block of Rebol code implementing that function. In that case we expect
// that `def` should be:
//
// [[spec] [body]]
//
// With REB_COMMAND, the code is implemented via a C DLL, under a system of
// APIs that pre-date Rebol's open sourcing and hence Ren/C:
//
// [[spec] extension command-num]
//
// See notes in Make_Command() regarding that mechanism and meaning.
//
void MAKE_Function(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
assert(kind == REB_FUNCTION);
if (
!IS_BLOCK(arg)
|| VAL_LEN_AT(arg) != 2
|| !IS_BLOCK(VAL_ARRAY_AT(arg))
|| !IS_BLOCK(VAL_ARRAY_AT(arg) + 1)
){
fail (Error_Bad_Make(kind, arg));
}
REBVAL spec;
COPY_VALUE(&spec, VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg));
REBVAL body;
COPY_VALUE(&body, VAL_ARRAY_AT(arg) + 1, VAL_SPECIFIER(arg));
// Spec-constructed functions do *not* have definitional returns
// added automatically. They are part of the generators. So the
// behavior comes--as with any other generator--from the projected
// code (though round-tripping it via text is not possible in
// general in any case due to loss of bindings.)
//
REBFUN *fun = Make_Interpreted_Function_May_Fail(
&spec, &body, MKF_ANY_VALUE
);
*out = *FUNC_VALUE(fun);
}
//
// TO_Vector: C
//
void TO_Vector(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
if (IS_BLOCK(arg)) {
if (Make_Vector_Spec(VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg), out))
return;
}
fail (Error_Bad_Make(kind, arg));
}
//
// MAKE_String: C
//
void MAKE_String(REBVAL *out, enum Reb_Kind kind, const REBVAL *def) {
REBSER *ser; // goto would cross initialization
if (IS_INTEGER(def)) {
//
// !!! R3-Alpha tolerated decimal, e.g. `make string! 3.14`, which
// is semantically nebulous (round up, down?) and generally bad.
//
ser = Make_Binary(Int32s(def, 0));
Val_Init_Series(out, kind, ser);
return;
}
else if (IS_BLOCK(def)) {
//
// The construction syntax for making strings or binaries that are
// preloaded with an offset into the data is #[binary [#{0001} 2]].
// In R3-Alpha make definitions didn't have to be a single value
// (they are for compatibility between construction syntax and MAKE
// in Ren-C). So the positional syntax was #[binary! #{0001} 2]...
// while #[binary [#{0001} 2]] would join the pieces together in order
// to produce #{000102}. That behavior is not available in Ren-C.
if (VAL_ARRAY_LEN_AT(def) != 2)
goto bad_make;
RELVAL *any_binstr = VAL_ARRAY_AT(def);
if (!ANY_BINSTR(any_binstr))
goto bad_make;
if (IS_BINARY(any_binstr) != LOGICAL(kind == REB_BINARY))
goto bad_make;
RELVAL *index = VAL_ARRAY_AT(def) + 1;
if (!IS_INTEGER(index))
goto bad_make;
REBINT i = Int32(index) - 1 + VAL_INDEX(any_binstr);
if (i < 0 || i > cast(REBINT, VAL_LEN_AT(any_binstr)))
goto bad_make;
Val_Init_Series_Index(out, kind, VAL_SERIES(any_binstr), i);
return;
}
if (kind == REB_BINARY)
ser = make_binary(def, TRUE);
else
ser = MAKE_TO_String_Common(def);
if (!ser)
goto bad_make;
Val_Init_Series_Index(out, kind, ser, 0);
return;
bad_make:
fail (Error_Bad_Make(kind, def));
}
//
// MAKE_Vector: C
//
void MAKE_Vector(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
// CASE: make vector! 100
if (IS_INTEGER(arg) || IS_DECIMAL(arg)) {
REBINT size = Int32s(arg, 0);
if (size < 0) goto bad_make;
REBSER *ser = Make_Vector(0, 0, 1, 32, size);
Val_Init_Vector(out, ser);
return;
}
TO_Vector(out, kind, arg); // may fail()
return;
bad_make:
fail (Error_Bad_Make(kind, arg));
}
//
// MAKE_Tuple: C
//
REB_R MAKE_Tuple(
REBVAL *out,
enum Reb_Kind kind,
const REBVAL *opt_parent,
const REBVAL *arg
){
assert(kind == REB_TUPLE);
if (opt_parent)
fail (Error_Bad_Make_Parent(kind, opt_parent));
if (IS_TUPLE(arg))
return Move_Value(out, arg);
RESET_CELL(out, REB_TUPLE, CELL_MASK_NONE);
REBYTE *vp = VAL_TUPLE(out);
// !!! Net lookup parses IP addresses out of `tcp://93.184.216.34` or
// similar URL!s. In Rebol3 these captures come back the same type
// as the input instead of as STRING!, which was a latent bug in the
// network code of the 12-Dec-2012 release:
//
// https://github.com/rebol/rebol/blob/master/src/mezz/sys-ports.r#L110
//
// All attempts to convert a URL!-flavored IP address failed. Taking
// URL! here fixes it, though there are still open questions.
//
if (IS_TEXT(arg) or IS_URL(arg)) {
REBSIZ size;
const REBYTE *bp
= Analyze_String_For_Scan(&size, arg, MAX_SCAN_TUPLE);
if (Scan_Tuple(out, bp, size) == nullptr)
fail (arg);
return out;
}
if (ANY_ARRAY(arg)) {
REBCNT len = 0;
REBINT n;
RELVAL *item = VAL_ARRAY_AT(arg);
for (; NOT_END(item); ++item, ++vp, ++len) {
if (len >= MAX_TUPLE)
goto bad_make;
if (IS_INTEGER(item)) {
n = Int32(item);
}
else if (IS_CHAR(item)) {
n = VAL_CHAR(item);
}
else
goto bad_make;
if (n > 255 || n < 0)
goto bad_make;
*vp = n;
}
VAL_TUPLE_LEN(out) = len;
for (; len < MAX_TUPLE; len++) *vp++ = 0;
return out;
}
REBCNT alen;
if (IS_ISSUE(arg)) {
REBSTR *spelling = VAL_STRING(arg);
const REBYTE *ap = STR_HEAD(spelling);
size_t size = STR_SIZE(spelling); // UTF-8 len
if (size & 1)
fail (arg); // must have even # of chars
size /= 2;
if (size > MAX_TUPLE)
fail (arg); // valid even for UTF-8
VAL_TUPLE_LEN(out) = size;
for (alen = 0; alen < size; alen++) {
REBYTE decoded;
if ((ap = Scan_Hex2(&decoded, ap)) == NULL)
fail (arg);
*vp++ = decoded;
}
}
else if (IS_BINARY(arg)) {
REBYTE *ap = VAL_BIN_AT(arg);
REBCNT len = VAL_LEN_AT(arg);
if (len > MAX_TUPLE) len = MAX_TUPLE;
VAL_TUPLE_LEN(out) = len;
for (alen = 0; alen < len; alen++) *vp++ = *ap++;
}
else
fail (arg);
for (; alen < MAX_TUPLE; alen++) *vp++ = 0;
return out;
bad_make:
fail (Error_Bad_Make(REB_TUPLE, arg));
}
//
// MAKE_Tuple: C
//
void MAKE_Tuple(REBVAL *out, enum Reb_Kind type, const REBVAL *arg)
{
if (IS_TUPLE(arg)) {
*out = *arg;
return;
}
VAL_RESET_HEADER(out, REB_TUPLE);
REBYTE *vp = VAL_TUPLE(out);
// !!! Net lookup parses IP addresses out of `tcp://93.184.216.34` or
// similar URL!s. In Rebol3 these captures come back the same type
// as the input instead of as STRING!, which was a latent bug in the
// network code of the 12-Dec-2012 release:
//
// https://github.com/rebol/rebol/blob/master/src/mezz/sys-ports.r#L110
//
// All attempts to convert a URL!-flavored IP address failed. Taking
// URL! here fixes it, though there are still open questions.
//
if (IS_STRING(arg) || IS_URL(arg)) {
REBCNT len;
REBYTE *ap = Temp_Byte_Chars_May_Fail(arg, MAX_SCAN_TUPLE, &len, FALSE);
if (Scan_Tuple(ap, len, out))
return;
goto bad_arg;
}
if (ANY_ARRAY(arg)) {
REBCNT len = 0;
REBINT n;
RELVAL *item = VAL_ARRAY_AT(arg);
for (; NOT_END(item); ++item, ++vp, ++len) {
if (len >= MAX_TUPLE) goto bad_make;
if (IS_INTEGER(item)) {
n = Int32(item);
}
else if (IS_CHAR(item)) {
n = VAL_CHAR(item);
}
else
goto bad_make;
if (n > 255 || n < 0) goto bad_make;
*vp = n;
}
VAL_TUPLE_LEN(out) = len;
for (; len < MAX_TUPLE; len++) *vp++ = 0;
return;
}
REBCNT alen;
if (IS_ISSUE(arg)) {
REBUNI c;
const REBYTE *ap = VAL_WORD_HEAD(arg);
REBCNT len = LEN_BYTES(ap); // UTF-8 len
if (len & 1) goto bad_arg; // must have even # of chars
len /= 2;
if (len > MAX_TUPLE) goto bad_arg; // valid even for UTF-8
VAL_TUPLE_LEN(out) = len;
for (alen = 0; alen < len; alen++) {
const REBOOL unicode = FALSE;
if (!Scan_Hex2(ap, &c, unicode)) goto bad_arg;
*vp++ = cast(REBYTE, c);
ap += 2;
}
}
else if (IS_BINARY(arg)) {
REBYTE *ap = VAL_BIN_AT(arg);
REBCNT len = VAL_LEN_AT(arg);
if (len > MAX_TUPLE) len = MAX_TUPLE;
VAL_TUPLE_LEN(out) = len;
for (alen = 0; alen < len; alen++) *vp++ = *ap++;
}
else goto bad_arg;
for (; alen < MAX_TUPLE; alen++) *vp++ = 0;
return;
bad_arg:
fail (Error_Invalid_Arg(arg));
bad_make:
fail (Error_Bad_Make(REB_TUPLE, arg));
}
//
// MAKE_Decimal: C
//
void MAKE_Decimal(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
REBDEC d;
switch (VAL_TYPE(arg)) {
case REB_DECIMAL:
d = VAL_DECIMAL(arg);
goto dont_divide_if_percent;
case REB_PERCENT:
d = VAL_DECIMAL(arg);
goto dont_divide_if_percent;
case REB_INTEGER:
d = cast(REBDEC, VAL_INT64(arg));
goto dont_divide_if_percent;
case REB_MONEY:
d = deci_to_decimal(VAL_MONEY_AMOUNT(arg));
goto dont_divide_if_percent;
case REB_LOGIC:
d = VAL_LOGIC(arg) ? 1.0 : 0.0;
goto dont_divide_if_percent;
case REB_CHAR:
d = cast(REBDEC, VAL_CHAR(arg));
goto dont_divide_if_percent;
case REB_TIME:
d = VAL_TIME(arg) * NANO;
break;
case REB_STRING:
{
REBYTE *bp;
REBCNT len;
bp = Temp_Byte_Chars_May_Fail(arg, MAX_SCAN_DECIMAL, &len, FALSE);
VAL_RESET_HEADER(out, kind);
if (!Scan_Decimal(
&d, bp, len, LOGICAL(kind != REB_PERCENT)
)) {
goto bad_make;
}
break;
}
case REB_BINARY:
Binary_To_Decimal(arg, out);
VAL_RESET_HEADER(out, kind);
d = VAL_DECIMAL(out);
break;
#ifdef removed
// case REB_ISSUE:
{
REBYTE *bp;
REBCNT len;
bp = Temp_Byte_Chars_May_Fail(arg, MAX_HEX_LEN, &len, FALSE);
if (Scan_Hex(&VAL_INT64(out), bp, len, len) == 0)
fail (Error_Bad_Make(REB_DECIMAL, val));
d = VAL_DECIMAL(out);
break;
}
#endif
default:
if (ANY_ARRAY(arg) && VAL_ARRAY_LEN_AT(arg) == 2) {
RELVAL *item = VAL_ARRAY_AT(arg);
if (IS_INTEGER(item))
d = cast(REBDEC, VAL_INT64(item));
else if (IS_DECIMAL(item) || IS_PERCENT(item))
d = VAL_DECIMAL(item);
else {
REBVAL specific;
COPY_VALUE(&specific, item, VAL_SPECIFIER(arg));
fail (Error_Invalid_Arg(&specific));
}
++item;
REBDEC exp;
if (IS_INTEGER(item))
exp = cast(REBDEC, VAL_INT64(item));
else if (IS_DECIMAL(item) || IS_PERCENT(item))
exp = VAL_DECIMAL(item);
else {
REBVAL specific;
COPY_VALUE(&specific, item, VAL_SPECIFIER(arg));
fail (Error_Invalid_Arg(&specific));
}
while (exp >= 1) {
//
// !!! Comment here said "funky. There must be a better way"
//
--exp;
d *= 10.0;
if (!FINITE(d))
fail (Error(RE_OVERFLOW));
}
while (exp <= -1) {
++exp;
d /= 10.0;
}
}
else
fail (Error_Bad_Make(kind, arg));
}
if (kind == REB_PERCENT)
d /= 100.0;
dont_divide_if_percent:
if (!FINITE(d))
fail (Error(RE_OVERFLOW));
VAL_RESET_HEADER(out, kind);
VAL_DECIMAL(out) = d;
return;
bad_make:
fail (Error_Bad_Make(kind, arg));
}
//
// 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));
}
