C++ IS_BLOCK函数代码示例

*/	REBFLG Copy_Function(REBVAL *value, REBVAL *args)
/*
***********************************************************************/
{
	REBVAL *spec = VAL_BLK(args);
	REBVAL *body = VAL_BLK_SKIP(args, 1);

	if (IS_END(spec)) body = 0;
	else {
		// Spec given, must be block or *
		if (IS_BLOCK(spec)) {
			VAL_FUNC_SPEC(value) = VAL_SERIES(spec);
			VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec));
		} else
			if (!IS_STAR(spec)) return FALSE;
	}

	if (body && !IS_END(body)) {
		if (!IS_FUNCTION(value) && !IS_CLOSURE(value)) return FALSE;
		// Body must be block:
		if (!IS_BLOCK(body)) return FALSE;
		VAL_FUNC_BODY(value) = VAL_SERIES(body);
	}
	// No body, use protytpe:
	else if (IS_FUNCTION(value) || IS_CLOSURE(value))
		VAL_FUNC_BODY(value) = Clone_Block(VAL_FUNC_BODY(value));

	// Rebind function words:
	if (IS_FUNCTION(value))
		Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value), VAL_FUNC_BODY(value));

	return TRUE;
}

*/	REBFLG Make_Function(REBCNT type, REBVAL *value, REBVAL *def)
/*
***********************************************************************/
{
	REBVAL *spec;
	REBVAL *body;
	REBCNT len;

	if (
		!IS_BLOCK(def)
////		|| type < REB_CLOSURE // for now
		|| (len = VAL_LEN(def)) < 2
		|| !IS_BLOCK(spec = VAL_BLK(def))
	) return FALSE;

	body = VAL_BLK_SKIP(def, 1);

	//	Print("Make_Func"); //: %s spec %d", Get_Sym_Name(type+1), SERIES_TAIL(spec));
	VAL_FUNC_SPEC(value) = VAL_SERIES(spec);
	VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec));

	if (type != REB_COMMAND) {
		if (len != 2 || !IS_BLOCK(body)) return FALSE;
		VAL_FUNC_BODY(value) = VAL_SERIES(body);
	}
	else
		Make_Command(value, def);

	VAL_SET(value, type);

	if (type == REB_FUNCTION)
		Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value), VAL_FUNC_BODY(value));

	return TRUE;
}

*/	REBFLG Make_Function(REBCNT type, REBVAL *value, REBVAL *def)
/*
***********************************************************************/
{
	REBVAL *spec;
	REBVAL *body;
	REBCNT len;

	if (
		!IS_BLOCK(def)
		|| (len = VAL_LEN(def)) < 2
		|| !IS_BLOCK(spec = VAL_BLK(def))
	) return FALSE;

	body = VAL_BLK_SKIP(def, 1);

	VAL_FUNC_SPEC(value) = VAL_SERIES(spec);
	VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec));

	if (type != REB_COMMAND) {
		if (len != 2 || !IS_BLOCK(body)) return FALSE;
		VAL_FUNC_BODY(value) = VAL_SERIES(body);
	}
	else
		Make_Command(value, def);

	VAL_SET(value, type);

	if (type == REB_FUNCTION || type == REB_CLOSURE)
		Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value));

	return TRUE;
}

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

*/	static REBSER *Init_Loop(REBVAL *spec, REBVAL *body_blk, REBSER **fram)
/*
**		Initialize standard for loops (copy block, make frame, bind).
**		Spec: WORD or [WORD ...]
**
***********************************************************************/
{
	REBSER *frame;
	REBINT len;
	REBVAL *word;
	REBVAL *vals;
	REBSER *body;

	// For :WORD format, get the var's value:
	if (IS_GET_WORD(spec)) spec = Get_Var(spec);

	// Hand-make a FRAME (done for for speed):
	len = IS_BLOCK(spec) ? VAL_LEN(spec) : 1;
	if (len == 0) Trap_Arg(spec);
	frame = Make_Frame(len);
	SET_SELFLESS(frame);
	SERIES_TAIL(frame) = len+1;
	SERIES_TAIL(FRM_WORD_SERIES(frame)) = len+1;

	// Setup for loop:
	word = FRM_WORD(frame, 1); // skip SELF
	vals = BLK_SKIP(frame, 1);
	if (IS_BLOCK(spec)) spec = VAL_BLK_DATA(spec);

	// Optimally create the FOREACH frame:
	while (len-- > 0) {
		if (!IS_WORD(spec) && !IS_SET_WORD(spec)) {
			// Prevent inconsistent GC state:
			Free_Series(FRM_WORD_SERIES(frame));
			Free_Series(frame);
			Trap_Arg(spec);
		}
		VAL_SET(word, VAL_TYPE(spec));
		VAL_BIND_SYM(word) = VAL_WORD_SYM(spec);
		VAL_BIND_TYPESET(word) = ALL_64;
		word++;
		SET_NONE(vals);
		vals++;
		spec++;
	}
	SET_END(word);
	SET_END(vals);

	body = Clone_Block_Value(body_blk);
	Bind_Block(frame, BLK_HEAD(body), BIND_DEEP);

	*fram = frame;

	return body;
}

*/	static REBSER *Init_Loop(const REBVAL *spec, REBVAL *body_blk, REBSER **fram)
/*
**		Initialize standard for loops (copy block, make frame, bind).
**		Spec: WORD or [WORD ...]
**
***********************************************************************/
{
	REBSER *frame;
	REBINT len;
	REBVAL *word;
	REBVAL *vals;
	REBSER *body;

	// For :WORD format, get the var's value:
	if (IS_GET_WORD(spec)) spec = GET_VAR(spec);

	// Hand-make a FRAME (done for for speed):
	len = IS_BLOCK(spec) ? VAL_LEN(spec) : 1;
	if (len == 0) raise Error_Invalid_Arg(spec);
	frame = Make_Frame(len, FALSE);
	SERIES_TAIL(frame) = len+1;
	SERIES_TAIL(FRM_WORD_SERIES(frame)) = len+1;

	// Setup for loop:
	word = FRM_WORD(frame, 1); // skip SELF
	vals = BLK_SKIP(frame, 1);
	if (IS_BLOCK(spec)) spec = VAL_BLK_DATA(spec);

	// Optimally create the FOREACH frame:
	while (len-- > 0) {
		if (!IS_WORD(spec) && !IS_SET_WORD(spec)) {
			// Prevent inconsistent GC state:
			Free_Series(FRM_WORD_SERIES(frame));
			Free_Series(frame);
			raise Error_Invalid_Arg(spec);
		}
		Val_Init_Word_Typed(word, VAL_TYPE(spec), VAL_WORD_SYM(spec), ALL_64);
		word++;
		SET_NONE(vals);
		vals++;
		spec++;
	}
	SET_END(word);
	SET_END(vals);

	body = Copy_Array_At_Deep_Managed(
		VAL_SERIES(body_blk), VAL_INDEX(body_blk)
	);
	Bind_Values_Deep(BLK_HEAD(body), frame);

	*fram = frame;

	return body;
}

*/	REBINT Awake_System(REBSER *ports, REBINT only)
/*
**	Returns:
**		-1 for errors
**		 0 for nothing to do
**		 1 for wait is satisifed
**
***********************************************************************/
{
	REBVAL *port;
	REBVAL *state;
	REBVAL *waked;
	REBVAL *awake;
	REBVAL tmp;
	REBVAL ref_only;
	REBINT result;
	REBVAL out;

	// Get the system port object:
	port = Get_System(SYS_PORTS, PORTS_SYSTEM);
	if (!IS_PORT(port)) return -10; // verify it is a port object

	// Get wait queue block (the state field):
	state = VAL_OBJ_VALUE(port, STD_PORT_STATE);
	if (!IS_BLOCK(state)) return -10;
	//Debug_Num("S", VAL_TAIL(state));

	// Get waked queue block:
	waked = VAL_OBJ_VALUE(port, STD_PORT_DATA);
	if (!IS_BLOCK(waked)) return -10;

	// If there is nothing new to do, return now:
	if (VAL_TAIL(state) == 0 && VAL_TAIL(waked) == 0) return -1;

	//Debug_Num("A", VAL_TAIL(waked));
	// Get the system port AWAKE function:
	awake = VAL_OBJ_VALUE(port, STD_PORT_AWAKE);
	if (!ANY_FUNC(awake)) return -1;
	if (ports) Val_Init_Block(&tmp, ports);
	else SET_NONE(&tmp);

	if (only) SET_TRUE(&ref_only);
	else SET_NONE(&ref_only);
	// Call the system awake function:
	if (Apply_Func_Throws(&out, awake, port, &tmp, &ref_only, 0))
		raise Error_No_Catch_For_Throw(&out);

	// Awake function returns 1 for end of WAIT:
	result = (IS_LOGIC(&out) && VAL_LOGIC(&out)) ? 1 : 0;

	return result;
}

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

*/	REBVAL *Find_Last_Event (REBINT model, REBINT type)
/*
**		Find the last event in the queue by the model
**		Check its type, if it matches, then return the event or NULL
**
**
***********************************************************************/
{
	REBVAL *port;
	REBVAL *value;
	REBVAL *state;

	port = Get_System(SYS_PORTS, PORTS_SYSTEM);
	if (!IS_PORT(port)) return NULL; // verify it is a port object

	// Get queue block:
	state = VAL_OBJ_VALUE(port, STD_PORT_STATE);
	if (!IS_BLOCK(state)) return NULL;
	for (value = VAL_BLK_TAIL(state) - 1; value >= VAL_BLK(state); -- value) {
		if (VAL_EVENT_MODEL(value) == model) {
			if (VAL_EVENT_TYPE(value) == type) {
				return value;
			} else {
				return NULL;
			}
		}
	}

	return NULL;
}

*/	REBVAL *Append_Event()
/*
**		Append an event to the end of the current event port queue.
**		Return a pointer to the event value.
**
**		Note: this function may be called from out of environment,
**		so do NOT extend the event queue here. If it does not have
**		space, return 0. (Should it overwrite or wrap???)
**
***********************************************************************/
{
	REBVAL *port;
	REBVAL *value;
	REBVAL *state;

	port = Get_System(SYS_PORTS, PORTS_SYSTEM);
	if (!IS_PORT(port)) return 0; // verify it is a port object

	// Get queue block:
	state = VAL_BLK_SKIP(port, STD_PORT_STATE);
	if (!IS_BLOCK(state)) return 0;

	// Append to tail if room:
	if (SERIES_FULL(VAL_SERIES(state))) Crash(RP_MAX_EVENTS);
	VAL_TAIL(state)++;
	value = VAL_BLK_TAIL(state);
	SET_END(value);
	value--;
	SET_NONE(value);

	//Dump_Series(VAL_SERIES(state), "state");
	//Print("Tail: %d %d", VAL_TAIL(state), nn++);

	return value;
}

*/	REBFLG MT_Pair(REBVAL *out, REBVAL *data, REBCNT type)
/*
***********************************************************************/
{
	REBD32 x;
	REBD32 y;

	if (IS_PAIR(data)) {
		*out = *data;
		return TRUE;
	}

	if (!IS_BLOCK(data)) return FALSE;

	data = VAL_BLK_DATA(data);

	if (IS_INTEGER(data)) x = (REBD32)VAL_INT64(data);
	else if (IS_DECIMAL(data)) x = (REBD32)VAL_DECIMAL(data);
	else return FALSE;

	data++;
	if (IS_INTEGER(data)) y = (REBD32)VAL_INT64(data);
	else if (IS_DECIMAL(data)) y = (REBD32)VAL_DECIMAL(data);
	else return FALSE;

	VAL_SET(out, REB_PAIR);
	VAL_PAIR_X(out) = x;
	VAL_PAIR_Y(out) = y;
	return TRUE;
}

double sem_cov_ab(VARIOGRAM *v, DPOINT *a, DPOINT *b, int sem)
/*
 * return Cov(a,b) or Sem(a,b),
 * taking care of IS_BLOCK(a) and IS_BLOCK(b):
 */
{
	static DATA *Discr_a = NULL, *Discr_b = NULL;
	static DPOINT *block_p = NULL;
	DPOINT *tmp;

	if (block_p == NULL)
		block_p = get_block_p();
	if (a == b) {
		if (IS_POINT(a))
			return sem_cov_blocks(v, NULL, NULL, sem);
		Discr_a = block_discr(Discr_a, block_p, a);
		return sem_cov_blocks(v, Discr_a, Discr_a, sem);
	}
	/*
	 * if one of them IS_BLOCK, make sure it's a: 
	 * (because block_discr() will otherwise store block
	 * discretisations in both Discr_a and Discr_b)
	 */
	if (IS_POINT(a) && IS_BLOCK(b)) {  
		tmp = a; a = b; b = tmp; /* swap a and b */
	}
	Discr_a = block_discr(Discr_a, block_p, a);
	Discr_b = block_discr(Discr_b, block_p, b);
	return sem_cov_blocks(v, Discr_a, Discr_b, sem);
}

*/	static void Write_File_Port(REBREQ *file, REBVAL *data, REBCNT len, REBCNT args)
/*
***********************************************************************/
{
	REBSER *ser;

	if (IS_BLOCK(data)) {
		// Form the values of the block
		// !! Could be made more efficient if we broke the FORM
		// into 32K chunks for writing.
		REB_MOLD mo;
		CLEARS(&mo);
		Reset_Mold(&mo);
		if (args & AM_WRITE_LINES) {
			mo.opts = 1 << MOPT_LINES;
		}
		Mold_Value(&mo, data, 0);
		Set_String(data, mo.series); // fall into next section
		len = SERIES_TAIL(mo.series);
	}

	// Auto convert string to UTF-8
	if (IS_STRING(data)) {
		ser = Encode_UTF8_Value(data, len, ENCF_OS_CRLF);
		file->common.data = ser? BIN_HEAD(ser) : VAL_BIN_DATA(data); // No encoding may be needed
		len = SERIES_TAIL(ser);
	}
	else {
		file->common.data = VAL_BIN_DATA(data);
	}
	file->length = len;
	OS_DO_DEVICE(file, RDC_WRITE);
}

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