コード例 #1
0
ファイル: t-pair.c プロジェクト: Oldes/r3
*/	REBINT Min_Max_Pair(REBVAL *ds, REBFLG maxed)
/*
***********************************************************************/
{
	REBXYF aa;
	REBXYF bb;
	REBXYF *cc;
	REBVAL *a = D_ARG(1);
	REBVAL *b = D_ARG(2);
	REBVAL *c = D_RET;

	if (IS_PAIR(a)) aa = VAL_PAIR(a);
	else if (IS_INTEGER(a)) aa.x = aa.y = (REBD32)VAL_INT64(a);
	else Trap_Arg(a);

	if (IS_PAIR(b)) bb = VAL_PAIR(b);
	else if (IS_INTEGER(b)) bb.x = bb.y = (REBD32)VAL_INT64(b);
	else Trap_Arg(b);

	cc = &VAL_PAIR(c);
	if (maxed) {
		cc->x = MAX(aa.x, bb.x);
		cc->y = MAX(aa.y, bb.y);
	}
	else {
		cc->x = MIN(aa.x, bb.x);
		cc->y = MIN(aa.y, bb.y);
	}
	SET_TYPE(c, REB_PAIR);

	return R_RET;
}
コード例 #2
0
ファイル: c-function.c プロジェクト: RamchandraApte/rebol
*/	void Do_Native(REBVAL *func)
/*
***********************************************************************/
{
	REBVAL *ds;
	REBINT n;
#ifdef DEBUGGING
	REBYTE *fname = Get_Word_Name(DSF_WORD(DSF));	// for DEBUG
	Debug_Str(fname);
#endif

	Eval_Natives++;

	if (NZ(n = VAL_FUNC_CODE(func)(DS_RETURN))) {
		ds = DS_RETURN;
		switch (n) {
		case R_RET: // for compiler opt
			break;
		case R_TOS:
			*ds = *DS_TOP;
			break;
		case R_TOS1:
			*ds = *DS_NEXT;
			break;
		case R_NONE:
			SET_NONE(ds);
			break;
		case R_UNSET:
			SET_UNSET(ds);
			break;
		case R_TRUE:
			SET_TRUE(ds);
			break;
		case R_FALSE:
			SET_FALSE(ds);
			break;
		case R_ARG1:
			*ds = *D_ARG(1);
			break;
		case R_ARG2:
			*ds = *D_ARG(2);
			break;
		case R_ARG3:
			*ds = *D_ARG(3);
			break;
		}
	}
}
コード例 #3
0
ファイル: c-function.c プロジェクト: draegtun/ren-c
*/	void Do_Native(REBVAL *func)
/*
***********************************************************************/
{
	REBVAL *ds;
	REBINT n;

#if !defined(NDEBUG)
	const REBYTE *fname = Get_Word_Name(DSF_LABEL(DSF));
#endif

	Eval_Natives++;

	if ((n = VAL_FUNC_CODE(func)(DS_OUT))) {
		ds = DS_OUT;
		switch (n) {
		case R_OUT: // for compiler opt
			break;
		case R_TOS:
			*ds = *DS_TOP;
			break;
		case R_TOS1:
			*ds = *DS_NEXT;
			break;
		case R_NONE:
			SET_NONE(ds);
			break;
		case R_UNSET:
			SET_UNSET(ds);
			break;
		case R_TRUE:
			SET_TRUE(ds);
			break;
		case R_FALSE:
			SET_FALSE(ds);
			break;
		case R_ARG1:
			*ds = *D_ARG(1);
			break;
		case R_ARG2:
			*ds = *D_ARG(2);
			break;
		case R_ARG3:
			*ds = *D_ARG(3);
			break;
		}
	}
}
コード例 #4
0
ファイル: t-object.c プロジェクト: 51weekend/r3
/***********************************************************************
**
**	Get_Obj_Mods -- return a block of modified words from an object
**
***********************************************************************/
REBVAL *Get_Obj_Mods(REBFRM *frame, REBVAL **inter_block)
{
	REBVAL *obj  = D_ARG(1);
	REBVAL *words, *val;
	REBFRM *frm  = VAL_OBJ_FRAME(obj);
	REBSER *ser  = Make_Block(2);
	REBOOL clear = D_REF(2);
	//DISABLE_GC;

	val   = BLK_HEAD(frm->values);
	words = BLK_HEAD(frm->words);
	for (; NOT_END(val); val++, words++)
		if (!(VAL_FLAGS(val) & FLAGS_CLEAN)) {
			Append_Val(ser, words);
			if (clear) VAL_FLAGS(val) |= FLAGS_CLEAN;
		}
	if (!STR_LEN(ser)) {
		ENABLE_GC;
		goto is_none;
	}

	Bind_Block(frm, BLK_HEAD(ser), FALSE);
	VAL_SERIES(Temp_Blk_Value) = ser;
	//ENABLE_GC;
	return Temp_Blk_Value;
}
コード例 #5
0
ファイル: n-data.c プロジェクト: RamchandraApte/rebol
static int Do_Ordinal(REBVAL *ds, REBINT n)
{
	// Is only valid when returned from ACTION function itself.
	REBACT action = Value_Dispatch[VAL_TYPE(D_ARG(1))];
	DS_PUSH_INTEGER(n);
	//DSF_FUNC(ds) // needs to be set to PICK action!
	return action(ds, A_PICK);  // returns R_RET and other cases
}
コード例 #6
0
ファイル: c-function.c プロジェクト: draegtun/ren-c
*/	void Do_Act(REBVAL *ds, REBCNT type, REBCNT act)
/*
***********************************************************************/
{
	REBACT action;
	REBINT ret;

	action = Value_Dispatch[type];
	//assert(action != 0, RP_NO_ACTION);
	if (!action) Trap_Action(type, act);
	ret = action(ds, act);
	if (ret > 0) {
		ds = DS_OUT;
		switch (ret) {
		case R_OUT: // for compiler opt
			break;
		case R_TOS:
			*ds = *DS_TOP;
			break;
		case R_TOS1:
			*ds = *DS_NEXT;
			break;
		case R_NONE:
			SET_NONE(ds);
			break;
		case R_UNSET:
			SET_UNSET(ds);
			break;
		case R_TRUE:
			SET_TRUE(ds);
			break;
		case R_FALSE:
			SET_FALSE(ds);
			break;
		case R_ARG1:
			*ds = *D_ARG(1);
			break;
		case R_ARG2:
			*ds = *D_ARG(2);
			break;
		case R_ARG3:
			*ds = *D_ARG(3);
			break;
		}
	}
}
コード例 #7
0
ファイル: c-function.c プロジェクト: draegtun/ren-c
*/	void Do_Action(REBVAL *func)
/*
***********************************************************************/
{
	REBVAL *ds = DS_OUT;
	REBCNT type = VAL_TYPE(D_ARG(1));

	Eval_Natives++;

	assert(type < REB_MAX);

	// Handle special datatype test cases (eg. integer?)
	if (VAL_FUNC_ACT(func) == 0) {
		VAL_SET(D_OUT, REB_LOGIC);
		VAL_LOGIC(D_OUT) = (type == VAL_INT64(BLK_LAST(VAL_FUNC_SPEC(func))));
		return;
	}

	Do_Act(D_OUT, type, VAL_FUNC_ACT(func));
}
コード例 #8
0
ファイル: n-sets.c プロジェクト: kealist/ren-c
*/	static REBINT Do_Set_Operation(struct Reb_Call *call_, REBCNT flags)
/*
**		Do set operations on a series.
**
***********************************************************************/
{
	REBVAL *val;
	REBVAL *val1;
	REBVAL *val2 = 0;
	REBSER *ser;
	REBSER *hser = 0;	// hash table for series
	REBSER *retser;		// return series
	REBSER *hret;		// hash table for return series
	REBCNT i;
	REBINT h = TRUE;
	REBCNT skip = 1;	// record size
	REBCNT cased = 0;	// case sensitive when TRUE

	SET_NONE(D_OUT);
	val1 = D_ARG(1);
	i = 2;

	// Check for second series argument:
	if (flags != SET_OP_UNIQUE) {
		val2 = D_ARG(i++);
		if (VAL_TYPE(val1) != VAL_TYPE(val2))
			raise Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2));
	}

	// Refinements /case and /skip N
	cased = D_REF(i++); // cased
	if (D_REF(i++)) skip = Int32s(D_ARG(i), 1);

	switch (VAL_TYPE(val1)) {

	case REB_BLOCK:
		i = VAL_LEN(val1);
		// Setup result block:
		if (GET_FLAG(flags, SOP_BOTH)) i += VAL_LEN(val2);
		retser = BUF_EMIT;			// use preallocated shared block
		Resize_Series(retser, i);
		hret = Make_Hash_Sequence(i);	// allocated

		// Optimization note: !!
		// This code could be optimized for small blocks by not hashing them
		// and extending Find_Key to do a FIND on the value itself w/o the hash.

		do {
			// Check what is in series1 but not in series2:
			if (GET_FLAG(flags, SOP_CHECK))
				hser = Hash_Block(val2, cased);

			// Iterate over first series:
			ser = VAL_SERIES(val1);
			i = VAL_INDEX(val1);
			for (; val = BLK_SKIP(ser, i), i < SERIES_TAIL(ser); i += skip) {
				if (GET_FLAG(flags, SOP_CHECK)) {
					h = Find_Key(VAL_SERIES(val2), hser, val, skip, cased, 1) >= 0;
					if (GET_FLAG(flags, SOP_INVERT)) h = !h;
				}
				if (h) Find_Key(retser, hret, val, skip, cased, 2);
			}

			// Iterate over second series?
			if ((i = GET_FLAG(flags, SOP_BOTH))) {
				val = val1;
				val1 = val2;
				val2 = val;
				CLR_FLAG(flags, SOP_BOTH);
			}

			if (GET_FLAG(flags, SOP_CHECK))
				Free_Series(hser);
		} while (i);

		if (hret)
			Free_Series(hret);

		Val_Init_Block(D_OUT, Copy_Array_Shallow(retser));
		RESET_TAIL(retser); // required - allow reuse

		break;

	case REB_BINARY:
		cased = TRUE;
		SET_TYPE(D_OUT, REB_BINARY);
	case REB_STRING:
		i = VAL_LEN(val1);
		// Setup result block:
		if (GET_FLAG(flags, SOP_BOTH)) i += VAL_LEN(val2);

		retser = BUF_MOLD;
		Reset_Buffer(retser, i);
		RESET_TAIL(retser);

		do {
			REBUNI uc;

			cased = cased ? AM_FIND_CASE : 0;

			// Iterate over first series:
			ser = VAL_SERIES(val1);
			i = VAL_INDEX(val1);
			for (; i < SERIES_TAIL(ser); i += skip) {
				uc = GET_ANY_CHAR(ser, i);
				if (GET_FLAG(flags, SOP_CHECK)) {
					h = Find_Str_Char(VAL_SERIES(val2), 0, VAL_INDEX(val2), VAL_TAIL(val2), skip, uc, cased) != NOT_FOUND;
					if (GET_FLAG(flags, SOP_INVERT)) h = !h;
				}
				if (h && (Find_Str_Char(retser, 0, 0, SERIES_TAIL(retser), skip, uc, cased) == NOT_FOUND)) {
					Append_String(retser, ser, i, skip);
				}
			}

			// Iterate over second series?
			if ((i = GET_FLAG(flags, SOP_BOTH))) {
				val = val1;
				val1 = val2;
				val2 = val;
				CLR_FLAG(flags, SOP_BOTH);
			}
		} while (i);

		ser = Copy_String(retser, 0, -1);
		if (IS_BINARY(D_OUT))
			Val_Init_Binary(D_OUT, ser);
		else
			Val_Init_String(D_OUT, ser);
		break;

	case REB_BITSET:
		switch (flags) {
		case SET_OP_UNIQUE:
			return R_ARG1;
		case SET_OP_UNION:
			i = A_OR;
			break;
		case SET_OP_INTERSECT:
			i = A_AND;
			break;
		case SET_OP_DIFFERENCE:
			i = A_XOR;
			break;
		case SET_OP_EXCLUDE:
			i = 0; // special case
			break;
		}
		ser = Xandor_Binary(i, val1, val2);
		Val_Init_Bitset(D_OUT, ser);
		break;

	case REB_TYPESET:
		switch (flags) {
		case SET_OP_UNIQUE:
			break;
		case SET_OP_UNION:
			VAL_TYPESET(val1) |= VAL_TYPESET(val2);
			break;
		case SET_OP_INTERSECT:
			VAL_TYPESET(val1) &= VAL_TYPESET(val2);
			break;
		case SET_OP_DIFFERENCE:
			VAL_TYPESET(val1) ^= VAL_TYPESET(val2);
			break;
		case SET_OP_EXCLUDE:
			VAL_TYPESET(val1) &= ~VAL_TYPESET(val2);
			break;
		}
		return R_ARG1;

	default:
		raise Error_Invalid_Arg(val1);
	}

	return R_OUT;
}
コード例 #9
0
ファイル: n-loop.c プロジェクト: mbk/ren-c
*/	static REB_R Loop_Each(struct Reb_Call *call_, REBINT mode)
/*
**		Supports these natives (modes):
**			0: foreach
**			1: remove-each
**			2: map
**
***********************************************************************/
{
	REBSER *body;
	REBVAL *vars;
	REBVAL *words;
	REBSER *frame;
	REBVAL *value;
	REBSER *series;
	REBSER *out;	// output block (for MAP, mode = 2)

	REBINT index;	// !!!! should these be REBCNT?
	REBINT tail;
	REBINT windex;	// write
	REBINT rindex;	// read
	REBINT err;
	REBCNT i;
	REBCNT j;
	REBVAL *ds;

	assert(mode >= 0 && mode < 3);

	value = D_ARG(2); // series
	if (IS_NONE(value)) return R_NONE;

	body = Init_Loop(D_ARG(1), D_ARG(3), &frame); // vars, body
	SET_OBJECT(D_ARG(1), frame); // keep GC safe
	Set_Block(D_ARG(3), body);	 // keep GC safe

	SET_NONE(D_OUT); // Default result to NONE if the loop does not run

	// If it's MAP, create result block:
	if (mode == 2) {
		out = Make_Block(VAL_LEN(value));
		SAVE_SERIES(out);
	}

	// Get series info:
	if (ANY_OBJECT(value)) {
		series = VAL_OBJ_FRAME(value);
		out = FRM_WORD_SERIES(series); // words (the out local reused)
		index = 1;
		//if (frame->tail > 3) Trap_Arg_DEAD_END(FRM_WORD(frame, 3));
	}
	else if (IS_MAP(value)) {
		series = VAL_SERIES(value);
		index = 0;
		//if (frame->tail > 3) Trap_Arg_DEAD_END(FRM_WORD(frame, 3));
	}
	else {
		series = VAL_SERIES(value);
		index  = VAL_INDEX(value);
		if (index >= cast(REBINT, SERIES_TAIL(series))) {
			if (mode == 1) {
				SET_INTEGER(D_OUT, 0);
			} else if (mode == 2) {
				Set_Block(D_OUT, out);
				UNSAVE_SERIES(out);
			}
			return R_OUT;
		}
	}

	windex = index;

	// Iterate over each value in the series block:
	while (index < (tail = SERIES_TAIL(series))) {

		rindex = index;  // remember starting spot
		j = 0;

		// Set the FOREACH loop variables from the series:
		for (i = 1; i < frame->tail; i++) {

			vars = FRM_VALUE(frame, i);
			words = FRM_WORD(frame, i);

			// var spec is WORD
			if (IS_WORD(words)) {

				if (index < tail) {

					if (ANY_BLOCK(value)) {
						*vars = *BLK_SKIP(series, index);
					}

					else if (ANY_OBJECT(value)) {
						if (!VAL_GET_EXT(BLK_SKIP(out, index), EXT_WORD_HIDE)) {
							// Alternate between word and value parts of object:
							if (j == 0) {
								Init_Word(vars, REB_WORD, VAL_WORD_SYM(BLK_SKIP(out, index)), series, index);
								if (NOT_END(vars+1)) index--; // reset index for the value part
							}
							else if (j == 1)
								*vars = *BLK_SKIP(series, index);
							else
								Trap_Arg_DEAD_END(words);
							j++;
						}
						else {
							// Do not evaluate this iteration
							index++;
							goto skip_hidden;
						}
					}

					else if (IS_VECTOR(value)) {
						Set_Vector_Value(vars, series, index);
					}

					else if (IS_MAP(value)) {
						REBVAL *val = BLK_SKIP(series, index | 1);
						if (!IS_NONE(val)) {
							if (j == 0) {
								*vars = *BLK_SKIP(series, index & ~1);
								if (IS_END(vars+1)) index++; // only words
							}
							else if (j == 1)
								*vars = *BLK_SKIP(series, index);
							else
								Trap_Arg_DEAD_END(words);
							j++;
						}
						else {
							index += 2;
							goto skip_hidden;
						}
					}

					else { // A string or binary
						if (IS_BINARY(value)) {
							SET_INTEGER(vars, (REBI64)(BIN_HEAD(series)[index]));
						}
						else if (IS_IMAGE(value)) {
							Set_Tuple_Pixel(BIN_SKIP(series, index), vars);
						}
						else {
							VAL_SET(vars, REB_CHAR);
							VAL_CHAR(vars) = GET_ANY_CHAR(series, index);
						}
					}
					index++;
				}
				else SET_NONE(vars);
			}

			// var spec is SET_WORD:
			else if (IS_SET_WORD(words)) {
				if (ANY_OBJECT(value) || IS_MAP(value)) {
					*vars = *value;
				} else {
					VAL_SET(vars, REB_BLOCK);
					VAL_SERIES(vars) = series;
					VAL_INDEX(vars) = index;
				}
				//if (index < tail) index++; // do not increment block.
			}
			else Trap_Arg_DEAD_END(words);
		}
		if (index == rindex) index++; //the word block has only set-words: foreach [a:] [1 2 3][]

		if (!DO_BLOCK(D_OUT, body, 0)) {
			if ((err = Check_Error(D_OUT)) >= 0) {
				index = rindex;
				break;
			}
			// else CONTINUE:
			if (mode == 1) SET_FALSE(D_OUT); // keep the value (for mode == 1)
		} else {
			err = 0; // prevent later test against uninitialized value
		}

		if (mode > 0) {
			//if (ANY_OBJECT(value)) Trap_Types_DEAD_END(words, REB_BLOCK, VAL_TYPE(value)); //check not needed

			// If FALSE return, copy values to the write location:
			if (mode == 1) {  // remove-each
				if (IS_CONDITIONAL_FALSE(D_OUT)) {
					REBCNT wide = SERIES_WIDE(series);
					// memory areas may overlap, so use memmove and not memcpy!
					memmove(series->data + (windex * wide), series->data + (rindex * wide), (index - rindex) * wide);
					windex += index - rindex;
					// old: while (rindex < index) *BLK_SKIP(series, windex++) = *BLK_SKIP(series, rindex++);
				}
			}
			else
				if (!IS_UNSET(D_OUT)) Append_Value(out, D_OUT); // (mode == 2)
		}
skip_hidden: ;
	}

	// Finish up:
	if (mode == 1) {
		// Remove hole (updates tail):
		if (windex < index) Remove_Series(series, windex, index - windex);
		SET_INTEGER(D_OUT, index - windex);

		return R_OUT;
	}

	// If MAP...
	if (mode == 2) {
		UNSAVE_SERIES(out);
		if (err != 2) {
			// ...and not BREAK/RETURN:
			Set_Block(D_OUT, out);
			return R_OUT;
		}
	}

	return R_OUT;
}
コード例 #10
0
ファイル: p-net.c プロジェクト: fort-ascension/ren-c
//
//  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;
}
コード例 #11
0
ファイル: n-loop.c プロジェクト: mbk/ren-c
	return R_OUT;
}


/***********************************************************************
**
*/	REBNATIVE(for)
/*
**		FOR var start end bump [ body ]
**
***********************************************************************/
{
	REBSER *body;
	REBSER *frame;
	REBVAL *var;
	REBVAL *start = D_ARG(2);
	REBVAL *end   = D_ARG(3);
	REBVAL *incr  = D_ARG(4);

	// Copy body block, make a frame, bind loop var to it:
	body = Init_Loop(D_ARG(1), D_ARG(5), &frame);
	var = FRM_VALUE(frame, 1); // safe: not on stack
	SET_OBJECT(D_ARG(1), frame); // keep GC safe
	Set_Block(D_ARG(5), body);	 // keep GC safe

	if (IS_INTEGER(start) && IS_INTEGER(end) && IS_INTEGER(incr)) {
		Loop_Integer(D_OUT, var, body, VAL_INT64(start),
			IS_DECIMAL(end) ? (REBI64)VAL_DECIMAL(end) : VAL_INT64(end), VAL_INT64(incr));
	}
	else if (ANY_SERIES(start)) {
		// Check that start and end are same type and series:
コード例 #12
0
ファイル: n-loop.c プロジェクト: mbk/ren-c
*/	static int Loop_All(struct Reb_Call *call_, REBINT mode)
/*
**		0: forall
**		1: forskip
**
***********************************************************************/
{
	REBVAL *var;
	REBSER *body;
	REBCNT bodi;
	REBSER *dat;
	REBINT idx;
	REBINT inc = 1;
	REBCNT type;
	REBVAL *ds;

	var = GET_MUTABLE_VAR(D_ARG(1));
	if (IS_NONE(var)) return R_NONE;

	// Save the starting var value:
	*D_ARG(1) = *var;

	SET_NONE(D_OUT);

	if (mode == 1) inc = Int32(D_ARG(2));

	type = VAL_TYPE(var);
	body = VAL_SERIES(D_ARG(mode+2));
	bodi = VAL_INDEX(D_ARG(mode+2));

	// Starting location when past end with negative skip:
	if (inc < 0 && VAL_INDEX(var) >= VAL_TAIL(var)) {
		VAL_INDEX(var) = VAL_TAIL(var) + inc;
	}

	// NOTE: This math only works for index in positive ranges!

	if (ANY_SERIES(var)) {
		while (TRUE) {
			dat = VAL_SERIES(var);
			idx = VAL_INDEX(var);
			if (idx < 0) break;
			if (idx >= cast(REBINT, SERIES_TAIL(dat))) {
				if (inc >= 0) break;
				idx = SERIES_TAIL(dat) + inc; // negative
				if (idx < 0) break;
				VAL_INDEX(var) = idx;
			}

			if (!DO_BLOCK(D_OUT, body, bodi)) {	// Break, throw, continue, error.
				if (Check_Error(D_OUT) >= 0) {
					break;
				}
			}

			if (VAL_TYPE(var) != type) Trap_Arg_DEAD_END(var);

			VAL_INDEX(var) += inc;
		}
	}
	else Trap_Arg_DEAD_END(var);

	// !!!!! ???? allowed to write VAR????
	*var = *D_ARG(1);

	return R_OUT;
}
コード例 #13
0
ファイル: n-loop.c プロジェクト: Pointillistic/rebol-lang
*/	static int Loop_All(REBVAL *ds, REBINT mode)
/*
**		0: forall
**		1: forskip
**
***********************************************************************/
{
	REBVAL *var;
	REBSER *body;
	REBCNT bodi;
	REBSER *dat;
	REBINT idx;
	REBINT inc = 1;
	REBCNT type;

	var = Get_Var(D_ARG(1));
	if (IS_NONE(var)) return R_NONE;

	// Save the starting var value:
	*D_ARG(1) = *var;

	SET_NONE(D_RET);

	if (mode == 1) inc = Int32(D_ARG(2));

	type = VAL_TYPE(var);
	body = VAL_SERIES(D_ARG(mode+2));
	bodi = VAL_INDEX(D_ARG(mode+2));

	// Starting location when past end with negative skip:
	if (inc < 0 && VAL_INDEX(var) >= (REBINT)VAL_TAIL(var)) {
		VAL_INDEX(var) = (REBINT)VAL_TAIL(var) + inc;
	}

	// NOTE: This math only works for index in positive ranges!

	if (ANY_SERIES(var)) {
		while (TRUE) {
			dat = VAL_SERIES(var);
			idx = (REBINT)VAL_INDEX(var);
			if (idx < 0) break;
			if (idx >= (REBINT)SERIES_TAIL(dat)) {
				if (inc >= 0) break;
				idx = (REBINT)SERIES_TAIL(dat) + inc; // negative
				if (idx < 0) break;
				VAL_INDEX(var) = idx;
			}

			ds = Do_Blk(body, bodi); // (may move stack)

			if (THROWN(ds)) {	// Break, throw, continue, error.
				if (Check_Error(ds) >= 0) {
					*DS_RETURN = *DS_NEXT;
					break;
				}
			}
			*DS_RETURN = *ds;

			if (VAL_TYPE(var) != type) Trap_Arg(var);

			VAL_INDEX(var) += inc;
		}
	}
	else Trap_Arg(var);

	// !!!!! ???? allowed to write VAR????
	*var = *DS_ARG(1);

	return R_RET;
}
コード例 #14
0
ファイル: p-console.c プロジェクト: mbk/ren-c
*/	static REB_R Console_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
***********************************************************************/
{
	REBREQ *req;
	REBINT result;
	REBVAL *arg = D_ARG(2);
	REBSER *ser;

	Validate_Port(port, action);

	arg = D_ARG(2);
	*D_OUT = *D_ARG(1);

	req = cast(REBREQ*, Use_Port_State(port, RDI_STDIO, sizeof(REBREQ)));

	switch (action) {

	case A_READ:

		// If not open, open it:
		if (!IS_OPEN(req)) {
			if (OS_DO_DEVICE(req, RDC_OPEN)) Trap_Port_DEAD_END(RE_CANNOT_OPEN, port, req->error);
		}

		// If no buffer, create a buffer:
		arg = OFV(port, STD_PORT_DATA);
		if (!IS_STRING(arg) && !IS_BINARY(arg)) {
			Set_Binary(arg, MAKE_OS_BUFFER(OUT_BUF_SIZE));
		}
		ser = VAL_SERIES(arg);
		RESET_SERIES(ser);

		req->common.data = BIN_HEAD(ser);
		req->length = SERIES_AVAIL(ser);

#ifdef nono
		// Is the buffer large enough?
		req->length = SERIES_AVAIL(ser); // space available
		if (req->length < OUT_BUF_SIZE/2) Extend_Series(ser, OUT_BUF_SIZE);
		req->length = SERIES_AVAIL(ser);

		// Don't make buffer too large:  Bug #174   ?????
		if (req->length > 1024) req->length = 1024;  //???
		req->common.data = STR_TAIL(ser); // write at tail  //???
		if (SERIES_TAIL(ser) == 0) req->actual = 0;  //???
#endif

		result = OS_DO_DEVICE(req, RDC_READ);
		if (result < 0) Trap_Port_DEAD_END(RE_READ_ERROR, port, req->error);

#ifdef nono
		// Does not belong here!!
		// Remove or replace CRs:
		result = 0;
		for (n = 0; n < req->actual; n++) {
			chr = GET_ANY_CHAR(ser, n);
			if (chr == CR) {
				chr = LF;
				// Skip LF if it follows:
				if ((n+1) < req->actual &&
					LF == GET_ANY_CHAR(ser, n+1)) n++;
			}
			SET_ANY_CHAR(ser, result, chr);
			result++;
		}
#endif
		// !!! Among many confusions in this file, it said "Another copy???"
		//Set_String(D_OUT, Copy_OS_Str(ser->data, result));
		Set_Binary(D_OUT, Copy_Bytes(req->common.data, req->actual));
		break;

	case A_OPEN:
		// ?? why???
		//if (OS_DO_DEVICE(req, RDC_OPEN)) Trap_Port_DEAD_END(RE_CANNOT_OPEN, port);
		SET_OPEN(req);
		break;

	case A_CLOSE:
		SET_CLOSED(req);
		//OS_DO_DEVICE(req, RDC_CLOSE);
		break;

	case A_OPENQ:
		if (IS_OPEN(req)) return R_TRUE;
		return R_FALSE;

	default:
		Trap_Action_DEAD_END(REB_PORT, action);
	}

	return R_OUT;
}
コード例 #15
0
ファイル: n-loop.c プロジェクト: kealist/ren-c
*/	static REB_R Loop_Each(struct Reb_Call *call_, LOOP_MODE mode)
/*
**		Common implementation code of FOR-EACH, REMOVE-EACH, MAP-EACH,
**		and EVERY.
**
***********************************************************************/
{
	REBSER *body;
	REBVAL *vars;
	REBVAL *words;
	REBSER *frame;

	// `data` is the series/object/map/etc. being iterated over
	// Note: `data_is_object` flag is optimized out, but hints static analyzer
	REBVAL *data = D_ARG(2);
	REBSER *series;
	const REBOOL data_is_object = ANY_OBJECT(data);

	REBSER *out;	// output block (needed for MAP-EACH)

	REBINT index;	// !!!! should these be REBCNT?
	REBINT tail;
	REBINT windex;	// write
	REBINT rindex;	// read
	REBOOL break_with = FALSE;
	REBOOL every_true = TRUE;
	REBCNT i;
	REBCNT j;
	REBVAL *ds;

	if (IS_NONE(data)) return R_NONE;

	body = Init_Loop(D_ARG(1), D_ARG(3), &frame); // vars, body
	Val_Init_Object(D_ARG(1), frame); // keep GC safe
	Val_Init_Block(D_ARG(3), body); // keep GC safe

	SET_NONE(D_OUT); // Default result to NONE if the loop does not run

	if (mode == LOOP_MAP_EACH) {
		// Must be managed *and* saved...because we are accumulating results
		// into it, and those results must be protected from GC

		// !!! This means we cannot Free_Series in case of a BREAK, we
		// have to leave it to the GC.  Should there be a variant which
		// lets a series be a GC root for a temporary time even if it is
		// not SER_KEEP?

		out = Make_Array(VAL_LEN(data));
		MANAGE_SERIES(out);
		SAVE_SERIES(out);
	}

	// Get series info:
	if (data_is_object) {
		series = VAL_OBJ_FRAME(data);
		out = FRM_WORD_SERIES(series); // words (the out local reused)
		index = 1;
		//if (frame->tail > 3) raise Error_Invalid_Arg(FRM_WORD(frame, 3));
	}
	else if (IS_MAP(data)) {
		series = VAL_SERIES(data);
		index = 0;
		//if (frame->tail > 3) raise Error_Invalid_Arg(FRM_WORD(frame, 3));
	}
	else {
		series = VAL_SERIES(data);
		index  = VAL_INDEX(data);
		if (index >= cast(REBINT, SERIES_TAIL(series))) {
			if (mode == LOOP_REMOVE_EACH) {
				SET_INTEGER(D_OUT, 0);
			}
			else if (mode == LOOP_MAP_EACH) {
				UNSAVE_SERIES(out);
				Val_Init_Block(D_OUT, out);
			}
			return R_OUT;
		}
	}

	windex = index;

	// Iterate over each value in the data series block:
	while (index < (tail = SERIES_TAIL(series))) {

		rindex = index;  // remember starting spot
		j = 0;

		// Set the FOREACH loop variables from the series:
		for (i = 1; i < frame->tail; i++) {

			vars = FRM_VALUE(frame, i);
			words = FRM_WORD(frame, i);

			// var spec is WORD
			if (IS_WORD(words)) {

				if (index < tail) {

					if (ANY_BLOCK(data)) {
						*vars = *BLK_SKIP(series, index);
					}
					else if (data_is_object) {
						if (!VAL_GET_EXT(BLK_SKIP(out, index), EXT_WORD_HIDE)) {
							// Alternate between word and value parts of object:
							if (j == 0) {
								Val_Init_Word(vars, REB_WORD, VAL_WORD_SYM(BLK_SKIP(out, index)), series, index);
								if (NOT_END(vars+1)) index--; // reset index for the value part
							}
							else if (j == 1)
								*vars = *BLK_SKIP(series, index);
							else
								raise Error_Invalid_Arg(words);
							j++;
						}
						else {
							// Do not evaluate this iteration
							index++;
							goto skip_hidden;
						}
					}
					else if (IS_VECTOR(data)) {
						Set_Vector_Value(vars, series, index);
					}
					else if (IS_MAP(data)) {
						REBVAL *val = BLK_SKIP(series, index | 1);
						if (!IS_NONE(val)) {
							if (j == 0) {
								*vars = *BLK_SKIP(series, index & ~1);
								if (IS_END(vars+1)) index++; // only words
							}
							else if (j == 1)
								*vars = *BLK_SKIP(series, index);
							else
								raise Error_Invalid_Arg(words);
							j++;
						}
						else {
							index += 2;
							goto skip_hidden;
						}
					}
					else { // A string or binary
						if (IS_BINARY(data)) {
							SET_INTEGER(vars, (REBI64)(BIN_HEAD(series)[index]));
						}
						else if (IS_IMAGE(data)) {
							Set_Tuple_Pixel(BIN_SKIP(series, index), vars);
						}
						else {
							VAL_SET(vars, REB_CHAR);
							VAL_CHAR(vars) = GET_ANY_CHAR(series, index);
						}
					}
					index++;
				}
				else SET_NONE(vars);
			}
			// var spec is SET_WORD:
			else if (IS_SET_WORD(words)) {
				if (ANY_OBJECT(data) || IS_MAP(data))
					*vars = *data;
				else
					Val_Init_Block_Index(vars, series, index);

				//if (index < tail) index++; // do not increment block.
			}
			else
				raise Error_Invalid_Arg(words);
		}

		if (index == rindex) {
			// the word block has only set-words: for-each [a:] [1 2 3][]
			index++;
		}

		if (Do_Block_Throws(D_OUT, body, 0)) {
			if (IS_WORD(D_OUT) && VAL_WORD_SYM(D_OUT) == SYM_CONTINUE) {
				if (mode == LOOP_REMOVE_EACH) {
					// signal the post-body-execution processing that we
					// *do not* want to remove the element on a CONTINUE
					SET_FALSE(D_OUT);
				}
				else {
					// CONTINUE otherwise acts "as if" the loop body execution
					// returned an UNSET!
					SET_UNSET(D_OUT);
				}
			}
			else if (IS_WORD(D_OUT) && VAL_WORD_SYM(D_OUT) == SYM_BREAK) {
				// If it's a BREAK, get the /WITH value (UNSET! if no /WITH)
				// Though technically this doesn't really tell us if a
				// BREAK/WITH happened, as you can BREAK/WITH an UNSET!
				TAKE_THROWN_ARG(D_OUT, D_OUT);
				if (!IS_UNSET(D_OUT))
					break_with = TRUE;
				index = rindex;
				break;
			}
			else {
				// Any other kind of throw, with a WORD! name or otherwise...
				index = rindex;
				break;
			}
		}

		switch (mode) {
		case LOOP_FOR_EACH:
			// no action needed after body is run
			break;
		case LOOP_REMOVE_EACH:
			// If FALSE return, copy values to the write location
			// !!! Should UNSET! also act as conditional false here?  Error?
			if (IS_CONDITIONAL_FALSE(D_OUT)) {
				REBYTE wide = SERIES_WIDE(series);
				// memory areas may overlap, so use memmove and not memcpy!

				// !!! This seems a slow way to do it, but there's probably
				// not a lot that can be done as the series is expected to
				// be in a good state for the next iteration of the body. :-/
				memmove(
					series->data + (windex * wide),
					series->data + (rindex * wide),
					(index - rindex) * wide
				);
				windex += index - rindex;
			}
			break;
		case LOOP_MAP_EACH:
			// anything that's not an UNSET! will be added to the result
			if (!IS_UNSET(D_OUT)) Append_Value(out, D_OUT);
			break;
		case LOOP_EVERY:
			if (every_true) {
				// !!! This currently treats UNSET! as true, which ALL
				// effectively does right now.  That's likely a bad idea.
				// When ALL changes, so should this.
				//
				every_true = IS_CONDITIONAL_TRUE(D_OUT);
			}
			break;
		default:
			assert(FALSE);
		}
skip_hidden: ;
	}

	switch (mode) {
	case LOOP_FOR_EACH:
		// Nothing to do but return last result (will be UNSET! if an
		// ordinary BREAK was used, the /WITH if a BREAK/WITH was used,
		// and an UNSET! if the last loop iteration did a CONTINUE.)
		return R_OUT;

	case LOOP_REMOVE_EACH:
		// Remove hole (updates tail):
		if (windex < index) Remove_Series(series, windex, index - windex);
		SET_INTEGER(D_OUT, index - windex);

		return R_OUT;

	case LOOP_MAP_EACH:
		UNSAVE_SERIES(out);
		if (break_with) {
			// If BREAK is given a /WITH parameter that is not an UNSET!, it
			// is assumed that you want to override the accumulated mapped
			// data so far and return the /WITH value. (which will be in
			// D_OUT when the loop above is `break`-ed)

			// !!! Would be nice if we could Free_Series(out), but it is owned
			// by GC (we had to make it that way to use SAVE_SERIES on it)
			return R_OUT;
		}

		// If you BREAK/WITH an UNSET! (or just use a BREAK that has no
		// /WITH, which is indistinguishable in the thrown value) then it
		// returns the accumulated results so far up to the break.

		Val_Init_Block(D_OUT, out);
		return R_OUT;

	case LOOP_EVERY:
		// Result is the cumulative TRUE? state of all the input (with any
		// unsets taken out of the consideration).  The last TRUE? input
		// if all valid and NONE! otherwise.  (Like ALL.)  If the loop
		// never runs, `every_true` will be TRUE *but* D_OUT will be NONE!
		if (!every_true)
			SET_NONE(D_OUT);
		return R_OUT;
	}

	DEAD_END;
}
コード例 #16
0
ファイル: f-series.c プロジェクト: rgchris/ren-c
//
//  Series_Common_Action_Returns: C
// 
// This routine is called to handle actions on ANY-SERIES! that can be taken
// care of without knowing what specific kind of series it is.  So generally
// index manipulation, and things like LENGTH/etc.
//
// The strange name is to convey the result in an if statement, in the same
// spirit as the `if (XXX_Throws(...)) { /* handle throw */ }` pattern.
//
REBOOL Series_Common_Action_Returns(
    REB_R *r, // `r_out` would be slightly confusing, considering R_OUT
    REBFRM *frame_,
    REBSYM action
) {
    REBVAL *value = D_ARG(1);
    REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;

    REBINT index = cast(REBINT, VAL_INDEX(value));
    REBINT tail = cast(REBINT, VAL_LEN_HEAD(value));
    REBINT len = 0;

    switch (action) {

    //-- Navigation:

    case SYM_HEAD:
        VAL_INDEX(value) = 0;
        break;

    case SYM_TAIL:
        VAL_INDEX(value) = (REBCNT)tail;
        break;

    case SYM_HEAD_Q:
        *r = (index == 0) ? R_TRUE : R_FALSE;
        return TRUE; // handled

    case SYM_TAIL_Q:
        *r = (index >= tail) ? R_TRUE : R_FALSE;
        return TRUE; // handled

    case SYM_PAST_Q:
        *r = (index > tail) ? R_TRUE : R_FALSE;
        return TRUE; // handled

    case SYM_NEXT:
        if (index < tail) VAL_INDEX(value)++;
        break;

    case SYM_BACK:
        if (index > 0) VAL_INDEX(value)--;
        break;

    case SYM_SKIP:
    case SYM_AT:
        len = Get_Num_From_Arg(arg);
        {
            REBI64 i = (REBI64)index + (REBI64)len;
            if (action == SYM_SKIP) {
                if (IS_LOGIC(arg)) i--;
            } else { // A_AT
                if (len > 0) i--;
            }
            if (i > (REBI64)tail) i = (REBI64)tail;
            else if (i < 0) i = 0;
            VAL_INDEX(value) = (REBCNT)i;
        }
        break;

    case SYM_INDEX_OF:
        SET_INTEGER(D_OUT, cast(REBI64, index) + 1);
        *r = R_OUT;
        return TRUE; // handled

    case SYM_LENGTH:
        SET_INTEGER(D_OUT, tail > index ? tail - index : 0);
        *r = R_OUT;
        return TRUE; // handled

    case SYM_REMOVE:
        // /PART length
        FAIL_IF_LOCKED_SERIES(VAL_SERIES(value));
        len = D_REF(2) ? Partial(value, 0, D_ARG(3)) : 1;
        index = cast(REBINT, VAL_INDEX(value));
        if (index < tail && len != 0)
            Remove_Series(VAL_SERIES(value), VAL_INDEX(value), len);
        break;

    case SYM_ADD:         // Join_Strings(value, arg);
    case SYM_SUBTRACT:    // "test this" - 10
    case SYM_MULTIPLY:    // "t" * 4 = "tttt"
    case SYM_DIVIDE:
    case SYM_REMAINDER:
    case SYM_POWER:
    case SYM_ODD_Q:
    case SYM_EVEN_Q:
    case SYM_ABSOLUTE:
        fail (Error_Illegal_Action(VAL_TYPE(value), action));

    default:
        return FALSE; // not a common operation, not handled
    }

    *D_OUT = *value;
    *r = R_OUT;
    return TRUE; // handled
}
コード例 #17
0
ファイル: p-dir.c プロジェクト: 51weekend/r3
*/	static int Dir_Actor(REBVAL *ds, REBSER *port, REBCNT action)
/*
**		Internal port handler for file directories.
**
***********************************************************************/
{
	REBVAL *spec;
	REBVAL *path;
	REBVAL *state;
	REBREQ dir;
	REBCNT args = 0;
	REBINT result;
	REBCNT len;
	//REBYTE *flags;

	Validate_Port(port, action);

	*D_RET = *D_ARG(1);
	CLEARS(&dir);

	// Validate and fetch relevant PORT fields:
	spec  = BLK_SKIP(port, STD_PORT_SPEC);
	if (!IS_OBJECT(spec)) Trap1(RE_INVALID_SPEC, spec);
	path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
	if (!path) Trap1(RE_INVALID_SPEC, spec);

	if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
	else if (!IS_FILE(path)) Trap1(RE_INVALID_SPEC, path);
	
	state = BLK_SKIP(port, STD_PORT_STATE); // if block, then port is open.

	//flags = Security_Policy(SYM_FILE, path);

	// Get or setup internal state data:
	dir.port = port;
	dir.device = RDI_FILE;

	switch (action) {

	case A_READ:
		//Trap_Security(flags[POL_READ], POL_READ, path);
		args = Find_Refines(ds, ALL_READ_REFS);
		if (!IS_BLOCK(state)) {		// !!! ignores /SKIP and /PART, for now
			Init_Dir_Path(&dir, path, 1, POL_READ);
			Set_Block(state, Make_Block(7)); // initial guess
			result = Read_Dir(&dir, VAL_SERIES(state));
			///OS_FREE(dir.file.path);
			if (result < 0) Trap_Port(RE_CANNOT_OPEN, port, dir.error);
			*D_RET = *state;
			SET_NONE(state);
		} else {
			len = VAL_BLK_LEN(state);
			// !!? Why does this need to copy the block??
			Set_Block(D_RET, Copy_Block_Values(VAL_SERIES(state), 0, len, TS_STRING));
		}
		break;

	case A_CREATE:
		//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
		if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
create:
		Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
		result = OS_DO_DEVICE(&dir, RDC_CREATE);
		///OS_FREE(dir.file.path);
		if (result < 0) Trap1(RE_NO_CREATE, path);
		if (action == A_CREATE) return R_ARG2;
		SET_NONE(state);
		break;

	case A_RENAME:
		if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
		else {
			REBSER *target;

			Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
			// Convert file name to OS format:
			if (!(target = Value_To_OS_Path(D_ARG(2)))) Trap1(RE_BAD_FILE_PATH, D_ARG(2));
			dir.data = BIN_DATA(target);
			OS_DO_DEVICE(&dir, RDC_RENAME);
			Free_Series(target);
			if (dir.error) Trap1(RE_NO_RENAME, path);
		}
		break;

	case A_DELETE:
		//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
		SET_NONE(state);
		Init_Dir_Path(&dir, path, 0, POL_WRITE);
		// !!! add *.r deletion
		// !!! add recursive delete (?)
		result = OS_DO_DEVICE(&dir, RDC_DELETE);
		///OS_FREE(dir.file.path);
		if (result < 0) Trap1(RE_NO_DELETE, path);
		return R_ARG2;

	case A_OPEN:
		// !! If open fails, what if user does a READ w/o checking for error?
		if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
		//Trap_Security(flags[POL_READ], POL_READ, path);
		args = Find_Refines(ds, ALL_OPEN_REFS);
		if (args & AM_OPEN_NEW) goto create;
		//if (args & ~AM_OPEN_READ) Trap1(RE_INVALID_SPEC, path);
		Set_Block(state, Make_Block(7));
		Init_Dir_Path(&dir, path, 1, POL_READ);
		result = Read_Dir(&dir, VAL_SERIES(state));
		///OS_FREE(dir.file.path);
		if (result < 0) Trap_Port(RE_CANNOT_OPEN, port, dir.error);
		break;

	case A_OPENQ:
		if (IS_BLOCK(state)) return R_TRUE;
		return R_FALSE;

	case A_CLOSE:
		SET_NONE(state);
		break;

	case A_QUERY:
		//Trap_Security(flags[POL_READ], POL_READ, path);
		SET_NONE(state);
		Init_Dir_Path(&dir, path, -1, REMOVE_TAIL_SLASH | POL_READ);
		if (OS_DO_DEVICE(&dir, RDC_QUERY) < 0) return R_NONE;
		Ret_Query_File(port, &dir, D_RET);
		///OS_FREE(dir.file.path);
		break;

	//-- Port Series Actions (only called if opened as a port)

	case A_LENGTHQ:
		len = IS_BLOCK(state) ? VAL_BLK_LEN(state) : 0;
		SET_INTEGER(D_RET, len);
		break;

	default:
		Trap_Action(REB_PORT, action);
	}

	return R_RET;
}
コード例 #18
0
ファイル: n-loop.c プロジェクト: kealist/ren-c
*/	static int Loop_All(struct Reb_Call *call_, REBINT mode)
/*
**		0: forall
**		1: forskip
**
***********************************************************************/
{
	REBVAL *var;
	REBSER *body;
	REBCNT bodi;
	REBSER *dat;
	REBINT idx;
	REBINT inc = 1;
	REBCNT type;
	REBVAL *ds;

	var = GET_MUTABLE_VAR(D_ARG(1));
	if (IS_NONE(var)) return R_NONE;

	// Save the starting var value:
	*D_ARG(1) = *var;

	SET_NONE(D_OUT);

	if (mode == 1) inc = Int32(D_ARG(2));

	type = VAL_TYPE(var);
	body = VAL_SERIES(D_ARG(mode+2));
	bodi = VAL_INDEX(D_ARG(mode+2));

	// Starting location when past end with negative skip:
	if (inc < 0 && VAL_INDEX(var) >= VAL_TAIL(var)) {
		VAL_INDEX(var) = VAL_TAIL(var) + inc;
	}

	// NOTE: This math only works for index in positive ranges!

	if (ANY_SERIES(var)) {
		while (TRUE) {
			dat = VAL_SERIES(var);
			idx = VAL_INDEX(var);
			if (idx < 0) break;
			if (idx >= cast(REBINT, SERIES_TAIL(dat))) {
				if (inc >= 0) break;
				idx = SERIES_TAIL(dat) + inc; // negative
				if (idx < 0) break;
				VAL_INDEX(var) = idx;
			}

			if (Do_Block_Throws(D_OUT, body, bodi)) {
				if (Loop_Throw_Should_Return(D_OUT)) {
					// return value is set, but we still need to assign var
					break;
				}
			}

			if (VAL_TYPE(var) != type) raise Error_Invalid_Arg(var);

			VAL_INDEX(var) += inc;
		}
	}
	else
		raise Error_Invalid_Arg(var);

	// !!!!! ???? allowed to write VAR????
	*var = *D_ARG(1);

	return R_OUT;
}
コード例 #19
0
ファイル: p-clipboard.c プロジェクト: fort-ascension/ren-c
//
//  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);
        }
コード例 #20
0
ファイル: p-timer.c プロジェクト: RamchandraApte/rebol
*/	static int Event_Actor(REBVAL *ds, REBSER *port, REBCNT action)
/*
***********************************************************************/
{
	REBVAL *spec;
	REBVAL *state;
	REBCNT result;
	REBVAL *arg;
	REBVAL save_port;

	Validate_Port(port, action);

	arg = D_ARG(2);
	*D_RET = *D_ARG(1);

	// Validate and fetch relevant PORT fields:
	state = BLK_SKIP(port, STD_PORT_STATE);
	spec  = BLK_SKIP(port, STD_PORT_SPEC);
	if (!IS_OBJECT(spec)) Trap1(RE_INVALID_SPEC, spec);

	// Get or setup internal state data:
	if (!IS_BLOCK(state)) Set_Block(state, Make_Block(127));

	switch (action) {

	case A_UPDATE:
		return R_NONE;

	// Normal block actions done on events:
	case A_POKE:
		if (!IS_EVENT(D_ARG(3))) Trap_Arg(D_ARG(3));
		goto act_blk;
	case A_INSERT:
	case A_APPEND:
	//case A_PATH:		// not allowed: port/foo is port object field access
	//case A_PATH_SET:	// not allowed: above
		if (!IS_EVENT(arg)) Trap_Arg(arg);
	case A_PICK:
act_blk:
		save_port = *D_ARG(1); // save for return
		*D_ARG(1) = *state;
		result = T_Block(ds, action);
		SET_FLAG(Eval_Signals, SIG_EVENT_PORT);
		if (action == A_INSERT || action == A_APPEND || action == A_REMOVE) {
			*D_RET = save_port;
			break;
		}
		return result; // return condition

	case A_CLEAR:
		VAL_TAIL(state) = 0;
		VAL_BLK_TERM(state);
		CLR_FLAG(Eval_Signals, SIG_EVENT_PORT);
		break;

	case A_LENGTHQ:
		SET_INTEGER(D_RET, VAL_TAIL(state));
		break;

	case A_OPEN:
		if (!req) { //!!!
			req = OS_MAKE_DEVREQ(RDI_EVENT);
			SET_OPEN(req);
			OS_DO_DEVICE(req, RDC_CONNECT);		// stays queued
		}
		break;

	default:
		Trap_Action(REB_PORT, action);
	}

	return R_RET;
}
コード例 #21
0
ファイル: p-serial.c プロジェクト: rhencke/rebol
//
//  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;
}
コード例 #22
0
ファイル: n-sets.c プロジェクト: fort-ascension/ren-c
//
//  union: native [
//  
//  "Returns the union of two data sets."
//  
//      set1 [any-array! any-string! binary! bitset! typeset!] "first set"
//      set2 [any-array! any-string! binary! bitset! typeset!] "second set"
//      /case "Use case-sensitive comparison"
//      /skip "Treat the series as records of fixed size"
//      size [integer!]
//  ]
//
REBNATIVE(union)
{
    REBVAL *val1 = D_ARG(1);
    REBVAL *val2 = D_ARG(2);

    const REBOOL cased = D_REF(3);
    const REBOOL skip = D_REF(4) ? Int32s(D_ARG(5), 1) : 1;

    if (IS_BITSET(val1) || IS_BITSET(val2)) {
        if (VAL_TYPE(val1) != VAL_TYPE(val2))
            fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));

        Val_Init_Bitset(D_OUT, Xandor_Binary(A_OR, val1, val2));
        return R_OUT;
    }

    if (IS_TYPESET(val1) || IS_TYPESET(val2)) {
        if (VAL_TYPE(val1) != VAL_TYPE(val2))
コード例 #23
0
ファイル: p-file.c プロジェクト: mbk/ren-c
*/	static REB_R File_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
**		Internal port handler for files.
**
***********************************************************************/
{
	REBVAL *spec;
	REBVAL *path;
	REBREQ *file = 0;
	REBCNT args = 0;
	REBCNT len;
	REBOOL opened = FALSE;	// had to be opened (shortcut case)

	//Print("FILE ACTION: %r", Get_Action_Word(action));

	Validate_Port(port, action);

	*D_OUT = *D_ARG(1);

	// Validate PORT fields:
	spec = BLK_SKIP(port, STD_PORT_SPEC);
	if (!IS_OBJECT(spec)) Trap1_DEAD_END(RE_INVALID_SPEC, spec);
	path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
	if (!path) Trap1_DEAD_END(RE_INVALID_SPEC, spec);

	if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
	else if (!IS_FILE(path)) Trap1_DEAD_END(RE_INVALID_SPEC, path);

	// Get or setup internal state data:
	file = (REBREQ*)Use_Port_State(port, RDI_FILE, sizeof(*file));

	switch (action) {

	case A_READ:
		args = Find_Refines(call_, ALL_READ_REFS);

		// Handle the READ %file shortcut case:
		if (!IS_OPEN(file)) {
			REBCNT nargs = AM_OPEN_READ;
			if (args & AM_READ_SEEK) nargs |= AM_OPEN_SEEK;
			Setup_File(file, nargs, path);
			Open_File_Port(port, file, path);
			opened = TRUE;
		}

		if (args & AM_READ_SEEK) Set_Seek(file, D_ARG(ARG_READ_INDEX));
		len = Set_Length(
			file, D_REF(ARG_READ_PART) ? VAL_INT64(D_ARG(ARG_READ_LENGTH)) : -1
		);
		Read_File_Port(D_OUT, port, file, path, args, len);

		if (opened) {
			OS_DO_DEVICE(file, RDC_CLOSE);
			Cleanup_File(file);
		}

		if (file->error) Trap_Port_DEAD_END(RE_READ_ERROR, port, file->error);
		break;

	case A_APPEND:
		if (!(IS_BINARY(D_ARG(2)) || IS_STRING(D_ARG(2)) || IS_BLOCK(D_ARG(2))))
			Trap1_DEAD_END(RE_INVALID_ARG, D_ARG(2));
		file->special.file.index = file->special.file.size;
		SET_FLAG(file->modes, RFM_RESEEK);

	case A_WRITE:
		args = Find_Refines(call_, ALL_WRITE_REFS);
		spec = D_ARG(2); // data (binary, string, or block)

		// Handle the READ %file shortcut case:
		if (!IS_OPEN(file)) {
			REBCNT nargs = AM_OPEN_WRITE;
			if (args & AM_WRITE_SEEK || args & AM_WRITE_APPEND) nargs |= AM_OPEN_SEEK;
			else nargs |= AM_OPEN_NEW;
			Setup_File(file, nargs, path);
			Open_File_Port(port, file, path);
			opened = TRUE;
		}
		else {
			if (!GET_FLAG(file->modes, RFM_WRITE)) Trap1_DEAD_END(RE_READ_ONLY, path);
		}

		// Setup for /append or /seek:
		if (args & AM_WRITE_APPEND) {
			file->special.file.index = -1; // append
			SET_FLAG(file->modes, RFM_RESEEK);
		}
		if (args & AM_WRITE_SEEK) Set_Seek(file, D_ARG(ARG_WRITE_INDEX));

		// Determine length. Clip /PART to size of string if needed.
		len = VAL_LEN(spec);
		if (args & AM_WRITE_PART) {
			REBCNT n = Int32s(D_ARG(ARG_WRITE_LENGTH), 0);
			if (n <= len) len = n;
		}

		Write_File_Port(file, spec, len, args);

		if (opened) {
			OS_DO_DEVICE(file, RDC_CLOSE);
			Cleanup_File(file);
		}

		if (file->error) Trap1_DEAD_END(RE_WRITE_ERROR, path);
		break;

	case A_OPEN:
		args = Find_Refines(call_, ALL_OPEN_REFS);
		// Default file modes if not specified:
		if (!(args & (AM_OPEN_READ | AM_OPEN_WRITE))) args |= (AM_OPEN_READ | AM_OPEN_WRITE);
		Setup_File(file, args, path);
		Open_File_Port(port, file, path); // !!! needs to change file modes to R/O if necessary
		break;

	case A_COPY:
		if (!IS_OPEN(file)) Trap1_DEAD_END(RE_NOT_OPEN, path); //!!!! wrong msg
		len = Set_Length(file, D_REF(2) ? VAL_INT64(D_ARG(3)) : -1);
		Read_File_Port(D_OUT, port, file, path, args, len);
		break;

	case A_OPENQ:
		if (IS_OPEN(file)) return R_TRUE;
		return R_FALSE;

	case A_CLOSE:
		if (IS_OPEN(file)) {
			OS_DO_DEVICE(file, RDC_CLOSE);
			Cleanup_File(file);
		}
		break;

	case A_DELETE:
		if (IS_OPEN(file)) Trap1_DEAD_END(RE_NO_DELETE, path);
		Setup_File(file, 0, path);
		if (OS_DO_DEVICE(file, RDC_DELETE) < 0 ) Trap1_DEAD_END(RE_NO_DELETE, path);
		break;

	case A_RENAME:
		if (IS_OPEN(file)) Trap1_DEAD_END(RE_NO_RENAME, path);
		else {
			REBSER *target;

			Setup_File(file, 0, path);

			// Convert file name to OS format:
			if (!(target = Value_To_OS_Path(D_ARG(2), TRUE)))
				Trap1_DEAD_END(RE_BAD_FILE_PATH, D_ARG(2));
			file->common.data = BIN_DATA(target);
			OS_DO_DEVICE(file, RDC_RENAME);
			Free_Series(target);
			if (file->error) Trap1_DEAD_END(RE_NO_RENAME, path);
		}
		break;

	case A_CREATE:
		// !!! should it leave file open???
		if (!IS_OPEN(file)) {
			Setup_File(file, AM_OPEN_WRITE | AM_OPEN_NEW, path);
			if (OS_DO_DEVICE(file, RDC_CREATE) < 0) Trap_Port_DEAD_END(RE_CANNOT_OPEN, port, file->error);
			OS_DO_DEVICE(file, RDC_CLOSE);
		}
		break;

	case A_QUERY:
		if (!IS_OPEN(file)) {
			Setup_File(file, 0, path);
			if (OS_DO_DEVICE(file, RDC_QUERY) < 0) return R_NONE;
		}
		Ret_Query_File(port, file, D_OUT);
		// !!! free file path?
		break;

	case A_MODIFY:
		Set_Mode_Value(file, Get_Mode_Id(D_ARG(2)), D_ARG(3));
		if (!IS_OPEN(file)) {
			Setup_File(file, 0, path);
			if (OS_DO_DEVICE(file, RDC_MODIFY) < 0) return R_NONE;
		}
		return R_TRUE;
		break;

	case A_INDEXQ:
		SET_INTEGER(D_OUT, file->special.file.index + 1);
		break;

	case A_LENGTHQ:
		SET_INTEGER(D_OUT, file->special.file.size - file->special.file.index); // !clip at zero
		break;

	case A_HEAD:
		file->special.file.index = 0;
		goto seeked;

    case A_TAIL:
		file->special.file.index = file->special.file.size;
		goto seeked;

	case A_NEXT:
		file->special.file.index++;
		goto seeked;

	case A_BACK:
		if (file->special.file.index > 0) file->special.file.index--;
		goto seeked;

	case A_SKIP:
		file->special.file.index += Get_Num_Arg(D_ARG(2));
		goto seeked;

    case A_HEADQ:
		DECIDE(file->special.file.index == 0);

    case A_TAILQ:
		DECIDE(file->special.file.index >= file->special.file.size);

    case A_PASTQ:
		DECIDE(file->special.file.index > file->special.file.size);

	case A_CLEAR:
		// !! check for write enabled?
		SET_FLAG(file->modes, RFM_RESEEK);
		SET_FLAG(file->modes, RFM_TRUNCATE);
		file->length = 0;
		if (OS_DO_DEVICE(file, RDC_WRITE) < 0) Trap1_DEAD_END(RE_WRITE_ERROR, path);
		break;

	/* Not yet implemented:
		A_AT,					// 38
		A_PICK,					// 41
		A_PATH,					// 42
		A_PATH_SET,				// 43
		A_FIND,					// 44
		A_SELECT,				// 45
		A_TAKE,					// 49
		A_INSERT,				// 50
		A_REMOVE,				// 52
		A_CHANGE,				// 53
		A_POKE,					// 54
		A_QUERY,				// 64
		A_FLUSH,				// 65
	*/

	default:
		Trap_Action_DEAD_END(REB_PORT, action);
	}

	return R_OUT;

seeked:
	SET_FLAG(file->modes, RFM_RESEEK);
	return R_ARG1;

is_true:
	return R_TRUE;

is_false:
	return R_FALSE;
}
コード例 #24
0
ファイル: f-extension.c プロジェクト: fort-ascension/ren-c
        }

        // Obtain info string as UTF8:
        if (!(code = cast(INFO_FUNC*, info)(0, Extension_Lib()))) {
            OS_CLOSE_LIBRARY(dll);
            fail (Error(RE_EXTENSION_INIT, val));
        }

        // Import the string into REBOL-land:
        src = Copy_Bytes(code, -1); // Nursery protected
        call = OS_FIND_FUNCTION(dll, cs_cast(BOOT_STR(RS_EXTENSION, 2))); // zero is allowed
    }
    else {
        // Hosted extension:
        src = VAL_SERIES(val);
        call = VAL_HANDLE_CODE(D_ARG(3));
        dll = 0;
    }

    ext = &Ext_List[Ext_Next];
    CLEARS(ext);
    ext->call = cast(RXICAL, call);
    ext->dll = dll;
    ext->index = Ext_Next++;

    // Extension return: dll, info, filename
    obj = VAL_OBJ_FRAME(Get_System(SYS_STANDARD, STD_EXTENSION));
    obj = Copy_Array_Shallow(obj);

    // Shallow copy means we reuse STD_EXTENSION's word list, which is
    // already managed.  We manage our copy to match.
コード例 #25
0
ファイル: p-event.c プロジェクト: mbk/ren-c
*/	static REB_R Event_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
**		Internal port handler for events.
**
***********************************************************************/
{
	REBVAL *spec;
	REBVAL *state;
	REB_R result;
	REBVAL *arg;
	REBVAL save_port;

	Validate_Port(port, action);

	arg = D_ARG(2);
	*D_OUT = *D_ARG(1);

	// Validate and fetch relevant PORT fields:
	state = BLK_SKIP(port, STD_PORT_STATE);
	spec  = BLK_SKIP(port, STD_PORT_SPEC);
	if (!IS_OBJECT(spec)) Trap1_DEAD_END(RE_INVALID_SPEC, spec);

	// Get or setup internal state data:
	if (!IS_BLOCK(state)) Set_Block(state, Make_Block(EVENTS_CHUNK - 1));

	switch (action) {

	case A_UPDATE:
		return R_NONE;

	// Normal block actions done on events:
	case A_POKE:
		if (!IS_EVENT(D_ARG(3))) Trap_Arg_DEAD_END(D_ARG(3));
		goto act_blk;
	case A_INSERT:
	case A_APPEND:
	//case A_PATH:		// not allowed: port/foo is port object field access
	//case A_PATH_SET:	// not allowed: above
		if (!IS_EVENT(arg)) Trap_Arg_DEAD_END(arg);
	case A_PICK:
act_blk:
		save_port = *D_ARG(1); // save for return
		*D_ARG(1) = *state;
		result = T_Block(call_, action);
		SET_SIGNAL(SIG_EVENT_PORT);
		if (action == A_INSERT || action == A_APPEND || action == A_REMOVE) {
			*D_OUT = save_port;
			break;
		}
		return result; // return condition

	case A_CLEAR:
		VAL_TAIL(state) = 0;
		VAL_BLK_TERM(state);
		CLR_SIGNAL(SIG_EVENT_PORT);
		break;

	case A_LENGTHQ:
		SET_INTEGER(D_OUT, VAL_TAIL(state));
		break;

	case A_OPEN:
		if (!req) { //!!!
			req = OS_MAKE_DEVREQ(RDI_EVENT);
			if (req) {
				SET_OPEN(req);
				OS_DO_DEVICE(req, RDC_CONNECT);		// stays queued
			}
		}
		break;

	case A_CLOSE:
		OS_ABORT_DEVICE(req);
		OS_DO_DEVICE(req, RDC_CLOSE);
		// free req!!!
		SET_CLOSED(req);
		req = 0;
		break;

	case A_FIND: // add it

	default:
		Trap_Action_DEAD_END(REB_PORT, action);
	}

	return R_OUT;
}
コード例 #26
0
ファイル: n-loop.c プロジェクト: kealist/ren-c
	DEAD_END;
}


/***********************************************************************
**
*/	REBNATIVE(for)
/*
**		FOR var start end bump [ body ]
**
***********************************************************************/
{
	REBSER *body;
	REBSER *frame;
	REBVAL *var;
	REBVAL *start = D_ARG(2);
	REBVAL *end   = D_ARG(3);
	REBVAL *incr  = D_ARG(4);

	// Copy body block, make a frame, bind loop var to it:
	body = Init_Loop(D_ARG(1), D_ARG(5), &frame);
	var = FRM_VALUE(frame, 1); // safe: not on stack
	Val_Init_Object(D_ARG(1), frame); // keep GC safe
	Val_Init_Block(D_ARG(5), body); // keep GC safe

	if (IS_INTEGER(start) && IS_INTEGER(end) && IS_INTEGER(incr)) {
		Loop_Integer(D_OUT, var, body, VAL_INT64(start),
			IS_DECIMAL(end) ? (REBI64)VAL_DECIMAL(end) : VAL_INT64(end), VAL_INT64(incr));
	}
	else if (ANY_SERIES(start)) {
		if (ANY_SERIES(end))
コード例 #27
0
ファイル: p-dir.c プロジェクト: kealist/ren-c
*/	static REB_R Dir_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
**		Internal port handler for file directories.
**
***********************************************************************/
{
	REBVAL *spec;
	REBVAL *path;
	REBVAL *state;
	REBREQ dir;
	REBCNT args = 0;
	REBINT result;
	REBCNT len;
	//REBYTE *flags;

	Validate_Port(port, action);

	*D_OUT = *D_ARG(1);
	CLEARS(&dir);

	// Validate and fetch relevant PORT fields:
	spec  = BLK_SKIP(port, STD_PORT_SPEC);
	if (!IS_OBJECT(spec)) raise Error_1(RE_INVALID_SPEC, spec);
	path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
	if (!path) raise Error_1(RE_INVALID_SPEC, spec);

	if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
	else if (!IS_FILE(path)) raise Error_1(RE_INVALID_SPEC, path);

	state = BLK_SKIP(port, STD_PORT_STATE); // if block, then port is open.

	//flags = Security_Policy(SYM_FILE, path);

	// Get or setup internal state data:
	dir.port = port;
	dir.device = RDI_FILE;

	switch (action) {

	case A_READ:
		//Trap_Security(flags[POL_READ], POL_READ, path);
		args = Find_Refines(call_, ALL_READ_REFS);
		if (!IS_BLOCK(state)) {		// !!! ignores /SKIP and /PART, for now
			Init_Dir_Path(&dir, path, 1, POL_READ);
			Val_Init_Block(state, Make_Array(7)); // initial guess
			result = Read_Dir(&dir, VAL_SERIES(state));
			///OS_FREE(dir.file.path);
			if (result < 0)
				raise Error_On_Port(RE_CANNOT_OPEN, port, dir.error);
			*D_OUT = *state;
			SET_NONE(state);
		}
		else {
			// !!! This copies the strings in the block, shallowly.  What is
			// the purpose of doing this?  Why copy at all?
			Val_Init_Block(
				D_OUT,
				Copy_Array_Core_Managed(
					VAL_SERIES(state),
					0,
					VAL_BLK_LEN(state),
					FALSE, // !deep
					TS_STRING
				)
			);
		}
		break;

	case A_CREATE:
		//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
		if (IS_BLOCK(state)) raise Error_1(RE_ALREADY_OPEN, path);
create:
		Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
		result = OS_DO_DEVICE(&dir, RDC_CREATE);
		///OS_FREE(dir.file.path);
		if (result < 0) raise Error_1(RE_NO_CREATE, path);
		if (action == A_CREATE) {
			// !!! Used to return R_ARG2, but create is single arity.  :-/
			return R_ARG1;
		}
		SET_NONE(state);
		break;

	case A_RENAME:
		if (IS_BLOCK(state)) raise Error_1(RE_ALREADY_OPEN, path);
		else {
			REBSER *target;

			Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
			// Convert file name to OS format:
			if (!(target = Value_To_OS_Path(D_ARG(2), TRUE)))
				raise Error_1(RE_BAD_FILE_PATH, D_ARG(2));
			dir.common.data = BIN_DATA(target);
			OS_DO_DEVICE(&dir, RDC_RENAME);
			Free_Series(target);
			if (dir.error) raise Error_1(RE_NO_RENAME, path);
		}
		break;

	case A_DELETE:
		//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
		SET_NONE(state);
		Init_Dir_Path(&dir, path, 0, POL_WRITE);
		// !!! add *.r deletion
		// !!! add recursive delete (?)
		result = OS_DO_DEVICE(&dir, RDC_DELETE);
		///OS_FREE(dir.file.path);
		if (result < 0) raise Error_1(RE_NO_DELETE, path);
		// !!! Returned R_ARG2 before, but there is no second argument :-/
		return R_ARG1;

	case A_OPEN:
		// !! If open fails, what if user does a READ w/o checking for error?
		if (IS_BLOCK(state)) raise Error_1(RE_ALREADY_OPEN, path);
		//Trap_Security(flags[POL_READ], POL_READ, path);
		args = Find_Refines(call_, ALL_OPEN_REFS);
		if (args & AM_OPEN_NEW) goto create;
		//if (args & ~AM_OPEN_READ) raise Error_1(RE_INVALID_SPEC, path);
		Val_Init_Block(state, Make_Array(7));
		Init_Dir_Path(&dir, path, 1, POL_READ);
		result = Read_Dir(&dir, VAL_SERIES(state));
		///OS_FREE(dir.file.path);
		if (result < 0) raise Error_On_Port(RE_CANNOT_OPEN, port, dir.error);
		break;

	case A_OPENQ:
		if (IS_BLOCK(state)) return R_TRUE;
		return R_FALSE;

	case A_CLOSE:
		SET_NONE(state);
		break;

	case A_QUERY:
		//Trap_Security(flags[POL_READ], POL_READ, path);
		SET_NONE(state);
		Init_Dir_Path(&dir, path, -1, REMOVE_TAIL_SLASH | POL_READ);
		if (OS_DO_DEVICE(&dir, RDC_QUERY) < 0) return R_NONE;
		Ret_Query_File(port, &dir, D_OUT);
		///OS_FREE(dir.file.path);
		break;

	//-- Port Series Actions (only called if opened as a port)

	case A_LENGTH:
		len = IS_BLOCK(state) ? VAL_BLK_LEN(state) : 0;
		SET_INTEGER(D_OUT, len);
		break;

	default:
		raise Error_Illegal_Action(REB_PORT, action);
	}

	return R_OUT;
}