//
// Is_Type_Of: C
//
// Types can be: word or block. Each element must be either
// a datatype or a typeset.
//
static REBOOL Is_Type_Of(const REBVAL *value, REBVAL *types)
{
const REBVAL *val;
val = IS_WORD(types) ? GET_OPT_VAR_MAY_FAIL(types) : types;
if (IS_DATATYPE(val))
return LOGICAL(VAL_TYPE_KIND(val) == VAL_TYPE(value));
if (IS_TYPESET(val))
return LOGICAL(TYPE_CHECK(val, VAL_TYPE(value)));
if (IS_BLOCK(val)) {
for (types = VAL_ARRAY_AT(val); NOT_END(types); types++) {
val = IS_WORD(types) ? GET_OPT_VAR_MAY_FAIL(types) : types;
if (IS_DATATYPE(val)) {
if (VAL_TYPE_KIND(val) == VAL_TYPE(value)) return TRUE;
}
else if (IS_TYPESET(val)) {
if (TYPE_CHECK(val, VAL_TYPE(value))) return TRUE;
}
else
fail (Error(RE_INVALID_TYPE, Type_Of(val)));
}
return FALSE;
}
fail (Error_Invalid_Arg(types));
}
//
// Update_Typeset_Bits_Core: C
//
// This sets the bits in a bitset according to a block of datatypes. There
// is special handling by which BAR! will set the "variadic" bit on the
// typeset, which is heeded by functions only.
//
// !!! R3-Alpha supported fixed word symbols for datatypes and typesets.
// Confusingly, this means that if you have said `word!: integer!` and use
// WORD!, you will get the integer type... but if WORD! is unbound then it
// will act as WORD!. Also, is essentially having "keywords" and should be
// reviewed to see if anything actually used it.
//
REBOOL Update_Typeset_Bits_Core(
REBVAL *typeset,
const REBVAL *head,
REBOOL trap // if TRUE, then return FALSE instead of failing
) {
const REBVAL *item = head;
REBARR *types = VAL_ARRAY(ROOT_TYPESETS);
assert(IS_TYPESET(typeset));
VAL_TYPESET_BITS(typeset) = 0;
for (; NOT_END(item); item++) {
const REBVAL *var = NULL;
if (IS_BAR(item)) {
SET_VAL_FLAG(typeset, TYPESET_FLAG_VARIADIC);
continue;
}
if (IS_WORD(item) && !(var = TRY_GET_OPT_VAR(item))) {
REBSYM sym = VAL_WORD_SYM(item);
// See notes: if a word doesn't look up to a variable, then its
// symbol is checked as a second chance.
//
if (IS_KIND_SYM(sym)) {
TYPE_SET(typeset, KIND_FROM_SYM(sym));
continue;
}
else if (sym >= SYM_ANY_NOTHING_X && sym < SYM_DATATYPES)
var = ARR_AT(types, sym - SYM_ANY_NOTHING_X);
}
if (!var) var = item;
if (IS_DATATYPE(var)) {
TYPE_SET(typeset, VAL_TYPE_KIND(var));
}
else if (IS_TYPESET(var)) {
VAL_TYPESET_BITS(typeset) |= VAL_TYPESET_BITS(var);
}
else {
if (trap) return FALSE;
fail (Error_Invalid_Arg(item));
}
}
return TRUE;
}
//
// VAL_TYPESET_SYM_Ptr_Debug: C
//
// !!! Needed temporarily due to reorganization (though it should
// be checked via C++ build's static typing eventually...)
//
REBCNT *VAL_TYPESET_SYM_Ptr_Debug(const REBVAL *typeset)
{
assert(IS_TYPESET(typeset));
// loses constness, but that's not the particular concern needed
// to be caught in the wake of the UNWORD => TYPESET change...
return cast(REBCNT*, &typeset->payload.typeset.sym);
}
*/ static REBOOL Is_Of_Type(REBVAL *value, REBVAL *types)
/*
** Types can be: word or block. Each element must be either
** a datatype or a typeset.
**
***********************************************************************/
{
REBVAL *val;
val = IS_WORD(types) ? Get_Var(types) : types;
if (IS_DATATYPE(val)) {
return (VAL_DATATYPE(val) == (REBINT)VAL_TYPE(value));
}
if (IS_TYPESET(val)) {
return (TYPE_CHECK(val, VAL_TYPE(value)));
}
if (IS_BLOCK(val)) {
for (types = VAL_BLK_DATA(val); NOT_END(types); types++) {
val = IS_WORD(types) ? Get_Var(types) : types;
if (IS_DATATYPE(val))
if (VAL_DATATYPE(val) == (REBINT)VAL_TYPE(value)) return TRUE;
else if (IS_TYPESET(val))
if (TYPE_CHECK(val, VAL_TYPE(value))) return TRUE;
else
Trap1(RE_INVALID_TYPE, Of_Type(val));
}
return FALSE;
}
Trap_Arg(types);
return 0; // for compiler
}
*/ static int Count_Dia_Args(REBVAL *args)
/*
** Return number of formal args provided to the function.
** This is just a guess, because * repeats count as zero.
**
***********************************************************************/
{
REBINT n = 0;
for (; NOT_END(args); args++) {
if (IS_WORD(args)) {
if (VAL_WORD_SYM(args) == SYM__P) { // skip: * type
if (NOT_END(args+1)) args++;
} else n++;
}
else if (IS_DATATYPE(args) || IS_TYPESET(args)) n++;
}
return n;
}
*/ REBFLG Make_Typeset(REBVAL *block, REBVAL *value, REBFLG load)
/*
** block - block of datatypes (datatype words ok too)
** value - value to hold result (can be word-spec type too)
**
***********************************************************************/
{
const REBVAL *val;
REBCNT sym;
REBSER *types = VAL_SERIES(ROOT_TYPESETS);
VAL_TYPESET(value) = 0;
for (; NOT_END(block); block++) {
val = NULL;
if (IS_WORD(block)) {
//Print("word: %s", Get_Word_Name(block));
sym = VAL_WORD_SYM(block);
if (VAL_WORD_FRAME(block)) { // Get word value
val = GET_VAR(block);
} else if (sym < REB_MAX) { // Accept datatype word
TYPE_SET(value, VAL_WORD_SYM(block)-1);
continue;
} // Special typeset symbols:
else if (sym >= SYM_ANY_TYPEX && sym <= SYM_ANY_BLOCKX)
val = BLK_SKIP(types, sym - SYM_ANY_TYPEX + 1);
}
if (!val) val = block;
if (IS_DATATYPE(val)) {
TYPE_SET(value, VAL_DATATYPE(val));
} else if (IS_TYPESET(val)) {
VAL_TYPESET(value) |= VAL_TYPESET(val);
} else {
if (load) return FALSE;
Trap_Arg_DEAD_END(block);
}
}
return TRUE;
}
*/ REBCNT Find_Block(REBSER *series, REBCNT index, REBCNT end, REBVAL *target, REBCNT len, REBCNT flags, REBINT skip)
/*
** Flags are set according to: ALL_FIND_REFS
**
** Main Parameters:
** start - index to start search
** end - ending position
** len - length of target
** skip - skip factor
** dir - direction
**
** Comparison Parameters:
** case - case sensitivity
** wild - wild cards/keys
**
** Final Parmameters:
** tail - tail position
** match - sequence
** SELECT - (value that follows)
**
***********************************************************************/
{
REBVAL *value;
REBVAL *val;
REBCNT cnt;
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--;
}
// Optimized find word in block:
if (ANY_WORD(target)) {
for (; index >= start && index < end; index += skip) {
value = BLK_SKIP(series, index);
if (ANY_WORD(value)) {
cnt = (VAL_WORD_SYM(value) == VAL_WORD_SYM(target));
if (flags & AM_FIND_CASE) {
// Must be same type and spelling:
if (cnt && VAL_TYPE(value) == VAL_TYPE(target)) return index;
}
else {
// Can be different type or alias:
if (cnt || VAL_WORD_CANON(value) == VAL_WORD_CANON(target)) return index;
}
}
if (flags & AM_FIND_MATCH) break;
}
return NOT_FOUND;
}
// Match a block against a block:
else if (ANY_BLOCK(target) && !(flags & AM_FIND_ONLY)) {
for (; index >= start && index < end; index += skip) {
cnt = 0;
value = BLK_SKIP(series, index);
for (val = VAL_BLK_DATA(target); NOT_END(val); val++, value++) {
if (0 != Cmp_Value(value, val, (REBOOL)(flags & AM_FIND_CASE))) break;
if (++cnt >= len) {
return index;
}
}
if (flags & AM_FIND_MATCH) break;
}
return NOT_FOUND;
}
// Find a datatype in block:
else if (IS_DATATYPE(target) || IS_TYPESET(target)) {
for (; index >= start && index < end; index += skip) {
value = BLK_SKIP(series, index);
// Used if's so we can trace it...
if (IS_DATATYPE(target)) {
if ((REBINT)VAL_TYPE(value) == VAL_DATATYPE(target)) return index;
if (IS_DATATYPE(value) && VAL_DATATYPE(value) == VAL_DATATYPE(target)) return index;
}
if (IS_TYPESET(target)) {
if (TYPE_CHECK(target, VAL_TYPE(value))) return index;
if (IS_DATATYPE(value) && TYPE_CHECK(target, VAL_DATATYPE(value))) return index;
if (IS_TYPESET(value) && EQUAL_TYPESET(value, target)) return index;
}
if (flags & AM_FIND_MATCH) break;
}
return NOT_FOUND;
}
// All other cases:
else {
for (; index >= start && index < end; index += skip) {
value = BLK_SKIP(series, index);
if (0 == Cmp_Value(value, target, (REBOOL)(flags & AM_FIND_CASE))) return index;
if (flags & AM_FIND_MATCH) break;
}
return NOT_FOUND;
}
}
*/ void Make_Block_Type(REBFLG make, REBVAL *value, REBVAL *arg)
/*
** Value can be:
** 1. a datatype (e.g. BLOCK!)
** 2. a value (e.g. [...])
**
** Arg can be:
** 1. integer (length of block)
** 2. block (copy it)
** 3. value (convert to a block)
**
***********************************************************************/
{
REBCNT type;
REBCNT len;
REBSER *ser;
// make block! ...
if (IS_DATATYPE(value))
type = VAL_DATATYPE(value);
else // make [...] ....
type = VAL_TYPE(value);
// make block! [1 2 3]
if (ANY_BLOCK(arg)) {
len = VAL_BLK_LEN(arg);
if (len > 0 && type >= REB_PATH && type <= REB_LIT_PATH)
No_Nones(arg);
ser = Copy_Values(VAL_BLK_DATA(arg), len);
goto done;
}
if (IS_STRING(arg)) {
REBCNT index, len = 0;
VAL_SERIES(arg) = Prep_Bin_Str(arg, &index, &len); // (keeps safe)
ser = Scan_Source(VAL_BIN(arg), VAL_LEN(arg));
goto done;
}
if (IS_BINARY(arg)) {
ser = Scan_Source(VAL_BIN_DATA(arg), VAL_LEN(arg));
goto done;
}
if (IS_MAP(arg)) {
ser = Map_To_Block(VAL_SERIES(arg), 0);
goto done;
}
if (ANY_OBJECT(arg)) {
ser = Make_Object_Block(VAL_OBJ_FRAME(arg), 3);
goto done;
}
if (IS_VECTOR(arg)) {
ser = Make_Vector_Block(arg);
goto done;
}
// if (make && IS_NONE(arg)) {
// ser = Make_Block(0);
// goto done;
// }
// to block! typset
if (!make && IS_TYPESET(arg) && type == REB_BLOCK) {
Set_Block(value, Typeset_To_Block(arg));
return;
}
if (make) {
// make block! 10
if (IS_INTEGER(arg) || IS_DECIMAL(arg)) {
len = Int32s(arg, 0);
Set_Series(type, value, Make_Block(len));
return;
}
Trap_Arg(arg);
}
ser = Copy_Values(arg, 1);
done:
Set_Series(type, value, ser);
return;
}
*/ static REBINT Add_Arg(REBDIA *dia, REBVAL *value)
/*
** Add an actual argument to the output block.
**
** Note that the argument may be out sequence with the formal
** arguments so we must scan for a slot that matches.
**
** Returns:
** 1: arg matches a formal arg and has been stored
** 0: no arg of that type was found
** -N: error (type block contains a bad value)
**
***********************************************************************/
{
REBINT type = 0;
REBINT accept = 0;
REBVAL *fargs;
REBINT fargi;
REBVAL *outp;
REBINT rept = 0;
outp = BLK_SKIP(dia->out, dia->outi);
// Scan all formal args, looking for one that matches given value:
for (fargi = dia->fargi;; fargi++) {
//Debug_Fmt("Add_Arg fargi: %d outi: %d", fargi, outi);
if (IS_END(fargs = BLK_SKIP(dia->fargs, fargi))) return 0;
again:
// Formal arg can be a word (type or refinement), datatype, or * (repeater):
if (IS_WORD(fargs)) {
// If word is a datatype name:
type = VAL_WORD_CANON(fargs);
if (type < REB_MAX) {
type--; // the type id
}
else if (type == SYM__P) {
// repeat: * integer!
rept = 1;
fargs++;
goto again;
}
else {
// typeset or refinement
REBVAL *temp;
type = -1;
// Is it a refinement word?
if (IS_WORD(value) && VAL_WORD_CANON(fargs) == VAL_WORD_CANON(value)) {
accept = 4;
}
// Is it a typeset?
else if (NZ(temp = Get_Var_No_Trap(fargs)) && IS_TYPESET(temp)) {
if (TYPE_CHECK(temp, VAL_TYPE(value))) accept = 1;
}
else if (!IS_WORD(value)) return 0; // do not search past a refinement
//else return -REB_DIALECT_BAD_SPEC;
}
}
// It's been reduced and is an actual datatype or typeset:
else if (IS_DATATYPE(fargs)) {
type = VAL_DATATYPE(fargs);
}
else if (IS_TYPESET(fargs)) {
if (TYPE_CHECK(fargs, VAL_TYPE(value))) accept = 1;
} else
return -REB_DIALECT_BAD_SPEC;
// Make room for it in the output block:
if (IS_END(outp))
outp = Append_Value(dia->out);
else if (!IS_NONE(outp)) {
// There's already an arg in this slot, so skip it...
if (dia->cmd > 1) outp++;
if (!rept) continue; // see if there's another farg that will work for it
// Look for first empty slot:
while (NOT_END(outp) && !IS_NONE(outp)) outp++;
if (IS_END(outp)) outp = Append_Value(dia->out);
}
// The datatype was correct from above!
if (accept) break;
//Debug_Fmt("want: %d got: %d rept: %d", type, VAL_TYPE(value), rept);
// Direct match to datatype or to integer/decimal coersions:
if (type == (REBINT)VAL_TYPE(value)) {
accept = 1;
break;
}
else if (type == REB_INTEGER && IS_DECIMAL(value)) {
accept = 2;
break;
}
else if (type == REB_DECIMAL && IS_INTEGER(value)) {
accept = 3;
break;
}
dia->missed++; // for debugging
// Repeat did not match, so stop repeating and remove unused output slot:
if (rept) {
Remove_Last(dia->out);
outp--;
rept = 0;
continue;
}
if (dia->cmd > 1) outp++; // skip output slot (for non-default values)
}
// Process the result:
switch (accept) {
case 1:
*outp = *value;
break;
case 2:
SET_INTEGER(outp, (REBI64)VAL_DECIMAL(value));
break;
case 3:
SET_DECIMAL(outp, (REBDEC)VAL_INT64(value));
break;
case 4: // refinement:
dia->fargi = fargs - BLK_HEAD(dia->fargs) + 1;
dia->outi = outp - BLK_HEAD(dia->out) + 1;
*outp = *value;
return 1;
case 0:
return 0;
}
// Optimization: arg was in correct order:
if (!rept && fargi == (signed)(dia->fargi)) {
dia->fargi++;
dia->outi++;
}
return 1;
}
*/ RL_API void RL_Print_TOS(REBCNT flags, REBYTE *marker)
/*
** Print top REBOL stack value to the console. (pending changes)
**
** Returns:
** Nothing
** Arguments:
** flags - special flags (set to zero at this time).
** marker - placed at beginning of line to indicate output.
** Notes:
** This function is used for the main console evaluation
** input loop to print the results of evaluation from stack.
** The REBOL data stack is an abstract structure that can
** change between releases. This function allows the host
** to print the result of processed functions.
** Note that what is printed is actually TOS+1.
** Marker is usually "==" to show output.
** The system/options/result-types determine which values
** are automatically printed.
**
***********************************************************************/
{
REBINT dsp = DSP;
REBVAL *top = DS_VALUE(dsp+1);
REBOL_STATE state;
REBVAL *types;
if (dsp != 0) Debug_Fmt(Str_Stack_Misaligned, dsp);
PUSH_STATE(state, Saved_State);
if (SET_JUMP(state)) {
POP_STATE(state, Saved_State);
Catch_Error(DS_NEXT); // Stores error value here
Out_Value(DS_NEXT, 0, FALSE, 0); // error
DSP = 0;
return;
}
SET_STATE(state, Saved_State);
if (!IS_UNSET(top)) {
if (!IS_ERROR(top)) {
types = Get_System(SYS_OPTIONS, OPTIONS_RESULT_TYPES);
if (IS_TYPESET(types) && TYPE_CHECK(types, VAL_TYPE(top))) {
if (marker) Out_Str(marker, 0);
Out_Value(top, 500, TRUE, 1); // limit, molded
}
// else {
// Out_Str(Get_Type_Name(top), 1);
// }
} else {
if (VAL_ERR_NUM(top) != RE_HALT) {
Out_Value(top, 640, FALSE, 0); // error FORMed
// if (VAL_ERR_NUM(top) > RE_THROW_MAX) {
// Out_Str("** Note: use WHY? for more about this error", 1);
// }
}
}
}
POP_STATE(state, Saved_State);
DSP = 0;
}
