*/ static void Binary_To_Decimal(REBVAL *bin, REBVAL *dec) /* ***********************************************************************/ { REBI64 n = 0; REBSER *ser = VAL_SERIES(bin); REBCNT idx = VAL_INDEX(bin); REBCNT len = VAL_LEN(bin); if (len > 8) len = 8; for (; len; len--, idx++) n = (n << 8) | (REBI64)(GET_ANY_CHAR(ser, idx)); VAL_SET(dec, REB_DECIMAL); VAL_INT64(dec) = n; // aliasing the bits! }
static REBSER *Make_Binary_BE64(REBVAL *arg) { REBSER *ser = Make_Binary(9); REBI64 n = VAL_INT64(arg); REBINT count; REBYTE *bp = BIN_HEAD(ser); for (count = 7; count >= 0; count--) { bp[count] = (REBYTE)(n & 0xff); n >>= 8; } bp[8] = 0; ser->tail = 8; return ser; }
*/ REBFLG MT_Decimal(REBVAL *out, REBVAL *data, REBCNT type) /* ***********************************************************************/ { if (!IS_END(data+1)) return FALSE; if (IS_DECIMAL(data)) *out = *data; else if (IS_INTEGER(data)) { SET_DECIMAL(out, (REBDEC)VAL_INT64(data)); } else return FALSE; SET_TYPE(out, type); return TRUE; }
// // PD_Pair: C // REBINT PD_Pair(REBPVS *pvs) { const REBVAL *sel = pvs->selector; REBINT n = 0; REBDEC dec; if (IS_WORD(sel)) { if (VAL_WORD_SYM(sel) == SYM_X) n = 1; else if (VAL_WORD_SYM(sel) == SYM_Y) n = 2; else fail (Error_Bad_Path_Select(pvs)); } else if (IS_INTEGER(sel)) { n = Int32(sel); if (n != 1 && n != 2) fail (Error_Bad_Path_Select(pvs)); } else fail (Error_Bad_Path_Select(pvs)); if (pvs->opt_setval) { const REBVAL *setval = pvs->opt_setval; if (IS_INTEGER(setval)) dec = cast(REBDEC, VAL_INT64(setval)); else if (IS_DECIMAL(setval)) dec = VAL_DECIMAL(setval); else fail (Error_Bad_Path_Set(pvs)); if (n == 1) VAL_PAIR_X(pvs->value) = dec; else VAL_PAIR_Y(pvs->value) = dec; } else { dec = (n == 1 ? VAL_PAIR_X(pvs->value) : VAL_PAIR_Y(pvs->value)); SET_DECIMAL(pvs->store, dec); return PE_USE_STORE; } return PE_OK; }
// // Poke_Vector_Fail_If_Locked: C // void Poke_Vector_Fail_If_Locked( REBVAL *value, const REBVAL *picker, const REBVAL *poke ) { REBSER *vect = VAL_SERIES(value); FAIL_IF_LOCKED_SERIES(vect); REBINT n; if (IS_INTEGER(picker) || IS_DECIMAL(picker)) n = Int32(picker); else fail (Error_Invalid_Arg(picker)); n += VAL_INDEX(value); if (n <= 0 || cast(REBCNT, n) > SER_LEN(vect)) fail (Error_Out_Of_Range(picker)); REBYTE *vp = SER_DATA_RAW(vect); REBINT bits = VECT_TYPE(vect); REBI64 i; REBDEC f; if (IS_INTEGER(poke)) { i = VAL_INT64(poke); if (bits > VTUI64) f = cast(REBDEC, i); else { // !!! REVIEW: f was not set in this case; compiler caught the // unused parameter. So fill with distinctive garbage to make it // easier to search for if it ever is. f = -646.699; } } else if (IS_DECIMAL(poke)) { f = VAL_DECIMAL(poke); if (bits <= VTUI64) i = cast(REBINT, f); } else fail (Error_Invalid_Arg(poke)); set_vect(bits, vp, n - 1, i, f); }
*/ static REBFLG Set_Pair(REBXYF *pair, REBVAL *val) /* ***********************************************************************/ { if (IS_PAIR(val)) { pair->x = VAL_PAIR_X(val); pair->y = VAL_PAIR_Y(val); } else if (IS_INTEGER(val)) { pair->x = pair->y = (REBD32)VAL_INT64(val); } else if (IS_DECIMAL(val)) { pair->x = pair->y = (REBD32)VAL_DECIMAL(val); } else return FALSE; return TRUE; }
*/ 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)); }
*/ void Make_Command(REBVAL *value, REBVAL *def) /* ** Assumes prior function has already stored the spec and args ** series. This function validates the body. ** ***********************************************************************/ { REBVAL *args = BLK_HEAD(VAL_FUNC_ARGS(value)); REBCNT n; REBVAL *val = VAL_BLK_SKIP(def, 1); REBEXT *ext; if ( VAL_LEN(def) != 3 || !(IS_MODULE(val) || IS_OBJECT(val)) || !IS_HANDLE(VAL_OBJ_VALUE(val, 1)) || !IS_INTEGER(val+1) || VAL_INT64(val+1) > 0xffff ) Trap1(RE_BAD_FUNC_DEF, def); val = VAL_OBJ_VALUE(val, 1); if ( !(ext = &Ext_List[VAL_I32(val)]) || !(ext->call) ) Trap1(RE_BAD_EXTENSION, def); // make command! [[arg-spec] handle cmd-index] VAL_FUNC_BODY(value) = Copy_Block_Len(VAL_SERIES(def), 1, 2); // Check for valid command arg datatypes: args++; // skip self n = 1; for (; NOT_END(args); args++, n++) { // If the typeset contains args that are not valid: // (3 is the default when no args given, for not END and UNSET) if (3 != ~VAL_TYPESET(args) && (VAL_TYPESET(args) & ~RXT_ALLOWED_TYPES)) Trap1(RE_BAD_FUNC_ARG, args); } VAL_SET(value, REB_COMMAND); }
x*/ RXIARG Value_To_RXI(const REBVAL *val) /* ***********************************************************************/ { RXIARG arg; switch (RXT_Eval_Class[Reb_To_RXT[VAL_TYPE(val)]]) { case RXX_64: arg.int64 = VAL_INT64(val); break; case RXX_SER: arg.sri.series = VAL_SERIES(val); arg.sri.index = VAL_INDEX(val); break; case RXX_PTR: arg.addr = VAL_HANDLE_DATA(val); break; case RXX_32: arg.i2.int32a = VAL_I32(val); arg.i2.int32b = 0; break; case RXX_DATE: arg.i2.int32a = VAL_ALL_BITS(val)[2]; arg.i2.int32b = 0; break; case RXX_SYM: arg.i2.int32a = VAL_WORD_CANON(val); arg.i2.int32b = 0; break; case RXX_IMAGE: arg.iwh.image = VAL_SERIES(val); arg.iwh.width = VAL_IMAGE_WIDE(val); arg.iwh.height = VAL_IMAGE_HIGH(val); break; case RXX_NULL: default: arg.int64 = 0; break; } return arg; }
// // Int64s: C // // Get integer as positive, negative 64 bit value. // Sign field can be // 0: >= 0 // 1: > 0 // -1: < 0 // REBI64 Int64s(const REBVAL *val, REBINT sign) { REBI64 n; if (IS_DECIMAL(val)) { if (VAL_DECIMAL(val) > MAX_I64 || VAL_DECIMAL(val) < MIN_I64) fail (Error_Out_Of_Range(val)); n = (REBI64)VAL_DECIMAL(val); } else { n = VAL_INT64(val); } // More efficient to use positive sense: if ( (sign == 0 && n >= 0) || (sign > 0 && n > 0) || (sign < 0 && n < 0) ) return n; fail (Error_Out_Of_Range(val)); }
void Set_Vector_Row(REBSER *ser, REBVAL *blk) { REBCNT idx = VAL_INDEX(blk); REBCNT len = VAL_LEN_AT(blk); RELVAL *val; REBCNT n = 0; REBCNT bits = VECT_TYPE(ser); REBI64 i = 0; REBDEC f = 0; if (IS_BLOCK(blk)) { val = VAL_ARRAY_AT(blk); for (; NOT_END(val); val++) { if (IS_INTEGER(val)) { i = VAL_INT64(val); if (bits > VTUI64) f = (REBDEC)(i); } else if (IS_DECIMAL(val)) { f = VAL_DECIMAL(val); if (bits <= VTUI64) i = (REBINT)(f); } else fail (Error_Invalid_Arg_Core(val, VAL_SPECIFIER(blk))); //if (n >= ser->tail) Expand_Vector(ser); set_vect(bits, SER_DATA_RAW(ser), n++, i, f); } } else { REBYTE *data = VAL_BIN_AT(blk); for (; len > 0; len--, idx++) { set_vect( bits, SER_DATA_RAW(ser), n++, cast(REBI64, data[idx]), f ); } } }
// // Vector_To_Array: C // // Convert a vector to a block. // REBARR *Vector_To_Array(const REBVAL *vect) { REBCNT len = VAL_LEN_AT(vect); REBYTE *data = SER_DATA_RAW(VAL_SERIES(vect)); REBCNT type = VECT_TYPE(VAL_SERIES(vect)); REBARR *array = NULL; REBCNT n; RELVAL *val; if (len <= 0) fail (Error_Invalid_Arg(vect)); array = Make_Array(len); val = ARR_HEAD(array); for (n = VAL_INDEX(vect); n < VAL_LEN_HEAD(vect); n++, val++) { VAL_RESET_HEADER(val, (type >= VTSF08) ? REB_DECIMAL : REB_INTEGER); VAL_INT64(val) = get_vect(type, data, n); // can be int or decimal } TERM_ARRAY_LEN(array, len); assert(IS_END(val)); return array; }
static REBSER *Make_Binary_BE64(const REBVAL *arg) { REBSER *ser = Make_Binary(9); REBI64 n; REBINT count; REBYTE *bp = BIN_HEAD(ser); if (IS_INTEGER(arg)) { n = VAL_INT64(arg); } else { assert(IS_DECIMAL(arg)); n = VAL_DECIMAL_BITS(arg); } for (count = 7; count >= 0; count--) { bp[count] = (REBYTE)(n & 0xff); n >>= 8; } bp[8] = 0; SET_SERIES_LEN(ser, 8); return ser; }
*/ static REBFLG Set_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val) /* ***********************************************************************/ { REBVAL *spec; REBVAL *hndl; switch (VAL_WORD_CANON(word)) { case SYM_OFFSET: return Set_Pair(&(gob->offset), val); case SYM_SIZE: return Set_Pair(&gob->size, val); case SYM_IMAGE: CLR_GOB_OPAQUE(gob); if (IS_IMAGE(val)) { SET_GOB_TYPE(gob, GOBT_IMAGE); GOB_W(gob) = (REBD32)VAL_IMAGE_WIDE(val); GOB_H(gob) = (REBD32)VAL_IMAGE_HIGH(val); GOB_CONTENT(gob) = VAL_SERIES(val); // if (!VAL_IMAGE_TRANSP(val)) SET_GOB_OPAQUE(gob); } else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE); else return FALSE; break; #ifdef HAS_WIDGET_GOB case SYM_WIDGET: //printf("WIDGET GOB\n"); SET_GOB_TYPE(gob, GOBT_WIDGET); SET_GOB_OPAQUE(gob); GOB_CONTENT(gob) = Make_Block(4); // [handle type spec data] hndl = Append_Value(GOB_CONTENT(gob)); Append_Value(GOB_CONTENT(gob)); // used to cache type on host's side spec = Append_Value(GOB_CONTENT(gob)); Append_Value(GOB_CONTENT(gob)); // used to cache result data SET_HANDLE(hndl, 0, SYM_WIDGET, 0); if (IS_WORD(val) || IS_LIT_WORD(val)) { Set_Block(spec, Make_Block(1)); Append_Val(VAL_SERIES(spec), val); } else if (IS_BLOCK(val)) { Set_Block(spec, VAL_SERIES(val)); } else return FALSE; break; #endif // HAS_WIDGET_GOB case SYM_DRAW: CLR_GOB_OPAQUE(gob); if (IS_BLOCK(val)) { SET_GOB_TYPE(gob, GOBT_DRAW); GOB_CONTENT(gob) = VAL_SERIES(val); } else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE); else return FALSE; break; case SYM_TEXT: CLR_GOB_OPAQUE(gob); if (IS_BLOCK(val)) { SET_GOB_TYPE(gob, GOBT_TEXT); GOB_CONTENT(gob) = VAL_SERIES(val); } else if (IS_STRING(val)) { SET_GOB_TYPE(gob, GOBT_STRING); GOB_CONTENT(gob) = VAL_SERIES(val); } else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE); else return FALSE; break; case SYM_EFFECT: CLR_GOB_OPAQUE(gob); if (IS_BLOCK(val)) { SET_GOB_TYPE(gob, GOBT_EFFECT); GOB_CONTENT(gob) = VAL_SERIES(val); } else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE); else return FALSE; break; case SYM_COLOR: CLR_GOB_OPAQUE(gob); if (IS_TUPLE(val)) { SET_GOB_TYPE(gob, GOBT_COLOR); Set_Pixel_Tuple((REBYTE*)&GOB_CONTENT(gob), val); if (VAL_TUPLE_LEN(val) < 4 || VAL_TUPLE(val)[3] == 255) SET_GOB_OPAQUE(gob); } else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE); break; case SYM_PANE: if (GOB_PANE(gob)) Clear_Series(GOB_PANE(gob)); if (IS_BLOCK(val)) Insert_Gobs(gob, VAL_BLK_DATA(val), 0, VAL_BLK_LEN(val), 0); else if (IS_GOB(val)) Insert_Gobs(gob, val, 0, 1, 0); else if (IS_NONE(val)) gob->pane = 0; else return FALSE; break; case SYM_ALPHA: GOB_ALPHA(gob) = Clip_Int(Int32(val), 0, 255); break; case SYM_DATA: #ifdef HAS_WIDGET_GOB if (GOB_TYPE(gob) == GOBT_WIDGET) { OS_SET_WIDGET_DATA(gob, val); } else { #endif SET_GOB_DTYPE(gob, GOBD_NONE); if (IS_OBJECT(val)) { SET_GOB_DTYPE(gob, GOBD_OBJECT); SET_GOB_DATA(gob, VAL_OBJ_FRAME(val)); } else if (IS_BLOCK(val)) { SET_GOB_DTYPE(gob, GOBD_BLOCK); SET_GOB_DATA(gob, VAL_SERIES(val)); } else if (IS_STRING(val)) { SET_GOB_DTYPE(gob, GOBD_STRING); SET_GOB_DATA(gob, VAL_SERIES(val)); } else if (IS_BINARY(val)) { SET_GOB_DTYPE(gob, GOBD_BINARY); SET_GOB_DATA(gob, VAL_SERIES(val)); } else if (IS_INTEGER(val)) { SET_GOB_DTYPE(gob, GOBD_INTEGER); SET_GOB_DATA(gob, (void*)(REBIPT)VAL_INT64(val)); } else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE); else return FALSE; #ifdef HAS_WIDGET_GOB } #endif break; case SYM_FLAGS: if (IS_WORD(val)) Set_Gob_Flag(gob, val); else if (IS_BLOCK(val)) { gob->flags = 0; for (val = VAL_BLK(val); NOT_END(val); val++) { if (IS_WORD(val)) Set_Gob_Flag(gob, val); } } break; case SYM_OWNER: if (IS_GOB(val)) GOB_TMP_OWNER(gob) = VAL_GOB(val); else return FALSE; break; default: return FALSE; } return TRUE; }
static REBOOL parse_field_type(struct Struct_Field *field, REBVAL *spec, REBVAL *inner, REBVAL **init) { REBVAL *val = VAL_BLK_DATA(spec); if (IS_WORD(val)){ switch (VAL_WORD_CANON(val)) { case SYM_UINT8: field->type = STRUCT_TYPE_UINT8; field->size = 1; break; case SYM_INT8: field->type = STRUCT_TYPE_INT8; field->size = 1; break; case SYM_UINT16: field->type = STRUCT_TYPE_UINT16; field->size = 2; break; case SYM_INT16: field->type = STRUCT_TYPE_INT16; field->size = 2; break; case SYM_UINT32: field->type = STRUCT_TYPE_UINT32; field->size = 4; break; case SYM_INT32: field->type = STRUCT_TYPE_INT32; field->size = 4; break; case SYM_UINT64: field->type = STRUCT_TYPE_UINT64; field->size = 8; break; case SYM_INT64: field->type = STRUCT_TYPE_INT64; field->size = 8; break; case SYM_FLOAT: field->type = STRUCT_TYPE_FLOAT; field->size = 4; break; case SYM_DOUBLE: field->type = STRUCT_TYPE_DOUBLE; field->size = 8; break; case SYM_POINTER: field->type = STRUCT_TYPE_POINTER; field->size = sizeof(void*); break; case SYM_STRUCT_TYPE: ++ val; if (IS_BLOCK(val)) { REBFLG res; res = MT_Struct(inner, val, REB_STRUCT); if (!res) { //RL_Print("Failed to make nested struct!\n"); return FALSE; } field->size = SERIES_TAIL(VAL_STRUCT_DATA_BIN(inner)); field->type = STRUCT_TYPE_STRUCT; field->fields = VAL_STRUCT_FIELDS(inner); field->spec = VAL_STRUCT_SPEC(inner); *init = inner; /* a shortcut for struct intialization */ } else raise Error_Unexpected_Type(REB_BLOCK, VAL_TYPE(val)); break; case SYM_REBVAL: field->type = STRUCT_TYPE_REBVAL; field->size = sizeof(REBVAL); break; default: raise Error_Has_Bad_Type(val); } } else if (IS_STRUCT(val)) { //[b: [struct-a] val-a] field->size = SERIES_TAIL(VAL_STRUCT_DATA_BIN(val)); field->type = STRUCT_TYPE_STRUCT; field->fields = VAL_STRUCT_FIELDS(val); field->spec = VAL_STRUCT_SPEC(val); *init = val; } else raise Error_Has_Bad_Type(val); ++ val; if (IS_BLOCK(val)) {// make struct! [a: [int32 [2]] [0 0]] REBVAL ret; if (DO_ARRAY_THROWS(&ret, val)) { // !!! Does not check for thrown cases...what should this // do in case of THROW, BREAK, QUIT? raise Error_No_Catch_For_Throw(&ret); } if (!IS_INTEGER(&ret)) raise Error_Unexpected_Type(REB_INTEGER, VAL_TYPE(val)); field->dimension = cast(REBCNT, VAL_INT64(&ret)); field->array = TRUE; ++ val; } else { field->dimension = 1; /* scalar */ field->array = FALSE; } if (NOT_END(val)) raise Error_Has_Bad_Type(val); return TRUE; }
/* parse struct attribute */ static void parse_attr (REBVAL *blk, REBINT *raw_size, REBUPT *raw_addr) { REBVAL *attr = VAL_BLK_DATA(blk); *raw_size = -1; *raw_addr = 0; while (NOT_END(attr)) { if (IS_SET_WORD(attr)) { switch (VAL_WORD_CANON(attr)) { case SYM_RAW_SIZE: ++ attr; if (IS_INTEGER(attr)) { if (*raw_size > 0) /* duplicate raw-size */ raise Error_Invalid_Arg(attr); *raw_size = VAL_INT64(attr); if (*raw_size <= 0) raise Error_Invalid_Arg(attr); } else raise Error_Invalid_Arg(attr); break; case SYM_RAW_MEMORY: ++ attr; if (IS_INTEGER(attr)) { if (*raw_addr != 0) /* duplicate raw-memory */ raise Error_Invalid_Arg(attr); *raw_addr = VAL_UNT64(attr); if (*raw_addr == 0) raise Error_Invalid_Arg(attr); } else raise Error_Invalid_Arg(attr); break; case SYM_EXTERN: ++ attr; if (*raw_addr != 0) /* raw-memory is exclusive with extern */ raise Error_Invalid_Arg(attr); if (!IS_BLOCK(attr) || VAL_LEN(attr) != 2) { raise Error_Invalid_Arg(attr); } else { REBVAL *lib; REBVAL *sym; CFUNC *addr; lib = VAL_BLK_SKIP(attr, 0); sym = VAL_BLK_SKIP(attr, 1); if (!IS_LIBRARY(lib)) raise Error_Invalid_Arg(attr); if (IS_CLOSED_LIB(VAL_LIB_HANDLE(lib))) raise Error_0(RE_BAD_LIBRARY); if (!ANY_BINSTR(sym)) raise Error_Invalid_Arg(sym); addr = OS_FIND_FUNCTION( LIB_FD(VAL_LIB_HANDLE(lib)), s_cast(VAL_DATA(sym)) ); if (!addr) raise Error_1(RE_SYMBOL_NOT_FOUND, sym); *raw_addr = cast(REBUPT, addr); } break; /* case SYM_ALIGNMENT: ++ attr; if (IS_INTEGER(attr)) { alignment = VAL_INT64(attr); } else { raise Error_Invalid_Arg(attr); } break; */ default: raise Error_Invalid_Arg(attr); } } else raise Error_Invalid_Arg(attr); ++ attr; } }
static REBOOL assign_scalar(REBSTU *stu, struct Struct_Field *field, REBCNT n, /* element index, starting from 0 */ REBVAL *val) { u64 i = 0; double d = 0; void *data = SERIES_SKIP(STRUCT_DATA_BIN(stu), STRUCT_OFFSET(stu) + field->offset + n * field->size); if (field->type == STRUCT_TYPE_REBVAL) { memcpy(data, val, sizeof(REBVAL)); return TRUE; } switch (VAL_TYPE(val)) { case REB_DECIMAL: if (!IS_NUMERIC_TYPE(field->type)) raise Error_Has_Bad_Type(val); d = VAL_DECIMAL(val); i = (u64) d; break; case REB_INTEGER: if (!IS_NUMERIC_TYPE(field->type)) if (field->type != STRUCT_TYPE_POINTER) raise Error_Has_Bad_Type(val); i = (u64) VAL_INT64(val); d = (double)i; break; case REB_STRUCT: if (STRUCT_TYPE_STRUCT != field->type) raise Error_Has_Bad_Type(val); break; default: raise Error_Has_Bad_Type(val); } switch (field->type) { case STRUCT_TYPE_INT8: *(i8*)data = (i8)i; break; case STRUCT_TYPE_UINT8: *(u8*)data = (u8)i; break; case STRUCT_TYPE_INT16: *(i16*)data = (i16)i; break; case STRUCT_TYPE_UINT16: *(u16*)data = (u16)i; break; case STRUCT_TYPE_INT32: *(i32*)data = (i32)i; break; case STRUCT_TYPE_UINT32: *(u32*)data = (u32)i; break; case STRUCT_TYPE_INT64: *(i64*)data = (i64)i; break; case STRUCT_TYPE_UINT64: *(u64*)data = (u64)i; break; case STRUCT_TYPE_POINTER: *cast(void**, data) = cast(void*, cast(REBUPT, i)); break; case STRUCT_TYPE_FLOAT: *(float*)data = (float)d; break; case STRUCT_TYPE_DOUBLE: *(double*)data = (double)d; break; case STRUCT_TYPE_STRUCT: if (field->size != VAL_STRUCT_LEN(val)) raise Error_Invalid_Arg(val); if (same_fields(field->fields, VAL_STRUCT_FIELDS(val))) { memcpy(data, SERIES_SKIP(VAL_STRUCT_DATA_BIN(val), VAL_STRUCT_OFFSET(val)), field->size); } else raise Error_Invalid_Arg(val); break; default: /* should never be here */ return FALSE; } return TRUE; }
x*/ void Modify_StringX(REBCNT action, REBVAL *string, REBVAL *arg) /* ** Actions: INSERT, APPEND, CHANGE ** ** string [string!] {Series at point to insert} ** value [any-type!] {The value to insert} ** /part {Limits to a given length or position.} ** length [number! series! pair!] ** /only {Inserts a series as a series.} ** /dup {Duplicates the insert a specified number of times.} ** count [number! pair!] ** ***********************************************************************/ { REBSER *series = VAL_SERIES(string); REBCNT index = VAL_INDEX(string); REBCNT tail = VAL_TAIL(string); REBINT rlen; // length to be removed REBINT ilen = 1; // length to be inserted REBINT cnt = 1; // DUP count REBINT size; REBVAL *val; REBSER *arg_ser = 0; // argument series // Length of target (may modify index): (arg can be anything) rlen = Partial1((action == A_CHANGE) ? string : arg, DS_ARG(AN_LENGTH)); index = VAL_INDEX(string); if (action == A_APPEND || index > tail) index = tail; // If the arg is not a string, then we need to create a string: if (IS_BINARY(string)) { if (IS_INTEGER(arg)) { if (VAL_INT64(arg) > 255 || VAL_INT64(arg) < 0) Trap_Range(arg); arg_ser = Make_Binary(1); Append_Byte(arg_ser, VAL_CHAR(arg)); // check for size!!! } else if (!ANY_BINSTR(arg)) Trap_Arg(arg); } else if (IS_BLOCK(arg)) { // MOVE! REB_MOLD mo = {0}; arg_ser = mo.series = Make_Unicode(VAL_BLK_LEN(arg) * 10); // GC!? for (val = VAL_BLK_DATA(arg); NOT_END(val); val++) Mold_Value(&mo, val, 0); } else if (IS_CHAR(arg)) { // Optimize this case !!! arg_ser = Make_Unicode(1); Append_Byte(arg_ser, VAL_CHAR(arg)); } else if (!ANY_STR(arg) || IS_TAG(arg)) { arg_ser = Copy_Form_Value(arg, 0); } if (arg_ser) Set_String(arg, arg_ser); else arg_ser = VAL_SERIES(arg); // Length of insertion: ilen = (action != A_CHANGE && DS_REF(AN_PART)) ? rlen : VAL_LEN(arg); // If Source == Destination we need to prevent possible conflicts. // Clone the argument just to be safe. // (Note: It may be possible to optimize special cases like append !!) if (series == VAL_SERIES(arg)) { arg_ser = Copy_Series_Part(arg_ser, VAL_INDEX(arg), ilen); // GC!? } // Get /DUP count: if (DS_REF(AN_DUP)) { cnt = Int32(DS_ARG(AN_COUNT)); if (cnt <= 0) return; // no changes } // Total to insert: size = cnt * ilen; if (action != A_CHANGE) { // Always expand series for INSERT and APPEND actions: Expand_Series(series, index, size); } else { if (size > rlen) Expand_Series(series, index, size-rlen); else if (size < rlen && DS_REF(AN_PART)) Remove_Series(series, index, rlen-size); else if (size + index > tail) { EXPAND_SERIES_TAIL(series, size - (tail - index)); } } // For dup count: for (; cnt > 0; cnt--) { Insert_String(series, index, arg_ser, VAL_INDEX(arg), ilen, TRUE); index += ilen; } TERM_SERIES(series); VAL_INDEX(string) = (action == A_APPEND) ? 0 : index; }
// // Serial_Actor: C // static REB_R Serial_Actor(REBFRM *frame_, REBCTX *port, REBSYM action) { REBREQ *req; // IO request REBVAL *spec; // port spec REBVAL *arg; // action argument value REBVAL *val; // e.g. port number value REBINT result; // IO result REBCNT refs; // refinement argument flags REBCNT len; // generic length REBSER *ser; // simplifier REBVAL *path; Validate_Port(port, action); *D_OUT = *D_ARG(1); // Validate PORT fields: spec = CTX_VAR(port, STD_PORT_SPEC); if (!IS_OBJECT(spec)) fail (Error(RE_INVALID_PORT)); path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF); if (!path) fail (Error(RE_INVALID_SPEC, spec)); //if (!IS_FILE(path)) fail (Error(RE_INVALID_SPEC, path)); req = cast(REBREQ*, Use_Port_State(port, RDI_SERIAL, sizeof(*req))); // Actions for an unopened serial port: if (!IS_OPEN(req)) { switch (action) { case SYM_OPEN: arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_PATH); if (! (IS_FILE(arg) || IS_STRING(arg) || IS_BINARY(arg))) fail (Error(RE_INVALID_PORT_ARG, arg)); req->special.serial.path = ALLOC_N(REBCHR, MAX_SERIAL_DEV_PATH); OS_STRNCPY( req->special.serial.path, // // !!! This is assuming VAL_DATA contains native chars. // Should it? (2 bytes on windows, 1 byte on linux/mac) // SER_AT(REBCHR, VAL_SERIES(arg), VAL_INDEX(arg)), MAX_SERIAL_DEV_PATH ); arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_SPEED); if (! IS_INTEGER(arg)) fail (Error(RE_INVALID_PORT_ARG, arg)); req->special.serial.baud = VAL_INT32(arg); //Secure_Port(SYM_SERIAL, ???, path, ser); arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_DATA_SIZE); if (!IS_INTEGER(arg) || VAL_INT64(arg) < 5 || VAL_INT64(arg) > 8 ) { fail (Error(RE_INVALID_PORT_ARG, arg)); } req->special.serial.data_bits = VAL_INT32(arg); arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_STOP_BITS); if (!IS_INTEGER(arg) || VAL_INT64(arg) < 1 || VAL_INT64(arg) > 2 ) { fail (Error(RE_INVALID_PORT_ARG, arg)); } req->special.serial.stop_bits = VAL_INT32(arg); arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_PARITY); if (IS_BLANK(arg)) { req->special.serial.parity = SERIAL_PARITY_NONE; } else { if (!IS_WORD(arg)) fail (Error(RE_INVALID_PORT_ARG, arg)); switch (VAL_WORD_SYM(arg)) { case SYM_ODD: req->special.serial.parity = SERIAL_PARITY_ODD; break; case SYM_EVEN: req->special.serial.parity = SERIAL_PARITY_EVEN; break; default: fail (Error(RE_INVALID_PORT_ARG, arg)); } } arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_FLOW_CONTROL); if (IS_BLANK(arg)) { req->special.serial.flow_control = SERIAL_FLOW_CONTROL_NONE; } else { if (!IS_WORD(arg)) fail (Error(RE_INVALID_PORT_ARG, arg)); switch (VAL_WORD_SYM(arg)) { case SYM_HARDWARE: req->special.serial.flow_control = SERIAL_FLOW_CONTROL_HARDWARE; break; case SYM_SOFTWARE: req->special.serial.flow_control = SERIAL_FLOW_CONTROL_SOFTWARE; break; default: fail (Error(RE_INVALID_PORT_ARG, arg)); } } if (OS_DO_DEVICE(req, RDC_OPEN)) fail (Error_On_Port(RE_CANNOT_OPEN, port, -12)); SET_OPEN(req); return R_OUT; case SYM_CLOSE: return R_OUT; case SYM_OPEN_Q: return R_FALSE; default: fail (Error_On_Port(RE_NOT_OPEN, port, -12)); } } // Actions for an open socket: switch (action) { case SYM_READ: refs = Find_Refines(frame_, ALL_READ_REFS); // Setup the read buffer (allocate a buffer if needed): arg = CTX_VAR(port, STD_PORT_DATA); if (!IS_STRING(arg) && !IS_BINARY(arg)) { Val_Init_Binary(arg, Make_Binary(32000)); } ser = VAL_SERIES(arg); req->length = SER_AVAIL(ser); // space available if (req->length < 32000/2) Extend_Series(ser, 32000); req->length = SER_AVAIL(ser); // This used STR_TAIL (obsolete, equivalent to BIN_TAIL) but was it // sure the series was byte sized? Added in a check. assert(BYTE_SIZE(ser)); req->common.data = BIN_TAIL(ser); // write at tail //if (SER_LEN(ser) == 0) req->actual = 0; // Actual for THIS read, not for total. #ifdef DEBUG_SERIAL printf("(max read length %d)", req->length); #endif result = OS_DO_DEVICE(req, RDC_READ); // recv can happen immediately if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, req->error)); #ifdef DEBUG_SERIAL for (len = 0; len < req->actual; len++) { if (len % 16 == 0) printf("\n"); printf("%02x ", req->common.data[len]); } printf("\n"); #endif *D_OUT = *arg; return R_OUT; case SYM_WRITE: refs = Find_Refines(frame_, ALL_WRITE_REFS); // Determine length. Clip /PART to size of string if needed. spec = D_ARG(2); len = VAL_LEN_AT(spec); if (refs & AM_WRITE_PART) { REBCNT n = Int32s(D_ARG(ARG_WRITE_LIMIT), 0); if (n <= len) len = n; } // Setup the write: *CTX_VAR(port, STD_PORT_DATA) = *spec; // keep it GC safe req->length = len; req->common.data = VAL_BIN_AT(spec); req->actual = 0; //Print("(write length %d)", len); result = OS_DO_DEVICE(req, RDC_WRITE); // send can happen immediately if (result < 0) fail (Error_On_Port(RE_WRITE_ERROR, port, req->error)); break; case SYM_UPDATE: // Update the port object after a READ or WRITE operation. // This is normally called by the WAKE-UP function. arg = CTX_VAR(port, STD_PORT_DATA); if (req->command == RDC_READ) { if (ANY_BINSTR(arg)) { SET_SERIES_LEN( VAL_SERIES(arg), VAL_LEN_HEAD(arg) + req->actual ); } } else if (req->command == RDC_WRITE) { SET_BLANK(arg); // Write is done. } return R_BLANK; case SYM_OPEN_Q: return R_TRUE; case SYM_CLOSE: if (IS_OPEN(req)) { OS_DO_DEVICE(req, RDC_CLOSE); SET_CLOSED(req); } break; default: fail (Error_Illegal_Action(REB_PORT, action)); } return R_OUT; }
*/ static To_Thru(REBPARSE *parse, REBCNT index, REBVAL *block, REBFLG is_thru) /* ***********************************************************************/ { REBSER *series = parse->series; REBCNT type = parse->type; REBVAL *blk; REBVAL *item; REBCNT cmd; REBCNT i; REBCNT len; for (; index <= series->tail; index++) { for (blk = VAL_BLK(block); NOT_END(blk); blk++) { item = blk; // Deal with words and commands if (IS_WORD(item)) { if (cmd = VAL_CMD(item)) { if (cmd == SYM_END) { if (index >= series->tail) { index = series->tail; goto found; } goto next; } else if (cmd == SYM_QUOTE) { item = ++blk; // next item is the quoted value if (IS_END(item)) goto bad_target; if (IS_PAREN(item)) { item = Do_Block_Value_Throw(item); // might GC } } else goto bad_target; } else { item = Get_Var(item); } } else if (IS_PATH(item)) { item = Get_Parse_Value(item); } // Try to match it: if (type >= REB_BLOCK) { if (ANY_BLOCK(item)) goto bad_target; i = Parse_Next_Block(parse, index, item, 0); if (i != NOT_FOUND) { if (!is_thru) i--; index = i; goto found; } } else if (type == REB_BINARY) { REBYTE ch1 = *BIN_SKIP(series, index); // Handle special string types: if (IS_CHAR(item)) { if (VAL_CHAR(item) > 0xff) goto bad_target; if (ch1 == VAL_CHAR(item)) goto found1; } else if (IS_BINARY(item)) { if (ch1 == *VAL_BIN_DATA(item)) { len = VAL_LEN(item); if (len == 1) goto found1; if (0 == Compare_Bytes(BIN_SKIP(series, index), VAL_BIN_DATA(item), len, 0)) { if (is_thru) index += len; goto found; } } } else if (IS_INTEGER(item)) { if (VAL_INT64(item) > 0xff) goto bad_target; if (ch1 == VAL_INT32(item)) goto found1; } else goto bad_target; } else { // String REBCNT ch1 = GET_ANY_CHAR(series, index); REBCNT ch2; if (!HAS_CASE(parse)) ch1 = UP_CASE(ch1); // Handle special string types: if (IS_CHAR(item)) { ch2 = VAL_CHAR(item); if (!HAS_CASE(parse)) ch2 = UP_CASE(ch2); if (ch1 == ch2) goto found1; } else if (ANY_STR(item)) { ch2 = VAL_ANY_CHAR(item); if (!HAS_CASE(parse)) ch2 = UP_CASE(ch2); if (ch1 == ch2) { len = VAL_LEN(item); if (len == 1) goto found1; i = Find_Str_Str(series, 0, index, SERIES_TAIL(series), 1, VAL_SERIES(item), VAL_INDEX(item), len, AM_FIND_MATCH | parse->flags); if (i != NOT_FOUND) { if (is_thru) i += len; index = i; goto found; } } } else if (IS_INTEGER(item)) { ch1 = GET_ANY_CHAR(series, index); // No casing! if (ch1 == (REBCNT)VAL_INT32(item)) goto found1; } else goto bad_target; } next: // Check for | (required if not end) blk++; if (IS_PAREN(blk)) blk++; if (IS_END(blk)) break; if (!IS_OR_BAR(blk)) { item = blk; goto bad_target; } } } return NOT_FOUND; found: if (IS_PAREN(blk+1)) Do_Block_Value_Throw(blk+1); return index; found1: if (IS_PAREN(blk+1)) Do_Block_Value_Throw(blk+1); return index + (is_thru ? 1 : 0); bad_target: Trap1(RE_PARSE_RULE, item); return 0; }
*/ void Make_Error_Object(REBVAL *arg, REBVAL *value) /* ** Creates an error object from arg and puts it in value. ** The arg can be a string or an object body block. ** This function is called by MAKE ERROR!. ** ***********************************************************************/ { REBSER *err; // Error object ERROR_OBJ *error; // Error object values REBINT code = 0; // Create a new error object from another object, including any non-standard fields: if (IS_ERROR(arg) || IS_OBJECT(arg)) { err = Merge_Frames(VAL_OBJ_FRAME(ROOT_ERROBJ), IS_ERROR(arg) ? VAL_OBJ_FRAME(arg) : VAL_ERR_OBJECT(arg)); error = ERR_VALUES(err); // if (!IS_INTEGER(&error->code)) { if (!Find_Error_Info(error, &code)) code = RE_INVALID_ERROR; SET_INTEGER(&error->code, code); // } SET_ERROR(value, VAL_INT32(&error->code), err); return; } // Make a copy of the error object template: err = CLONE_OBJECT(VAL_OBJ_FRAME(ROOT_ERROBJ)); error = ERR_VALUES(err); SET_NONE(&error->id); SET_ERROR(value, 0, err); // If block arg, evaluate object values (checking done later): // If user set error code, use it to setup type and id fields. if (IS_BLOCK(arg)) { DISABLE_GC; Do_Bind_Block(err, arg); // GC-OK (disabled) ENABLE_GC; if (IS_INTEGER(&error->code) && VAL_INT64(&error->code)) { Set_Error_Type(error); } else { if (Find_Error_Info(error, &code)) { SET_INTEGER(&error->code, code); } } // The error code is not valid: if (IS_NONE(&error->id)) { SET_INTEGER(&error->code, RE_INVALID_ERROR); Set_Error_Type(error); } if (VAL_INT64(&error->code) < 100 || VAL_INT64(&error->code) > 1000) Trap_Arg(arg); } // If string arg, setup other fields else if (IS_STRING(arg)) { SET_INTEGER(&error->code, RE_USER); // user error Set_String(&error->arg1, Copy_Series_Value(arg)); Set_Error_Type(error); } // No longer allowed: // else if (IS_INTEGER(arg)) { // error->code = *arg; // Set_Error_Type(error); // } else Trap_Arg(arg); if (!(VAL_ERR_NUM(value) = VAL_INT32(&error->code))) { Trap_Arg(arg); } }
// // Find_Entry: C // // Try to find the entry in the map. If not found // and val is SET, create the entry and store the key and // val. // // RETURNS: the index to the VALUE or zero if there is none. // static REBCNT Find_Entry(REBSER *series, REBVAL *key, REBVAL *val) { REBSER *hser = series->extra.series; // can be null REBCNT *hashes; REBCNT hash; REBVAL *v; REBCNT n; if (IS_NONE(key)) return 0; // We may not be large enough yet for the hash table to // be worthwhile, so just do a linear search: if (!hser) { if (series->tail < MIN_DICT*2) { v = BLK_HEAD(series); if (ANY_WORD(key)) { for (n = 0; n < series->tail; n += 2, v += 2) { if ( ANY_WORD(v) && SAME_SYM(VAL_WORD_SYM(key), VAL_WORD_SYM(v)) ) { if (val) *++v = *val; return n/2+1; } } } else if (ANY_BINSTR(key)) { for (n = 0; n < series->tail; n += 2, v += 2) { if (VAL_TYPE(key) == VAL_TYPE(v) && 0 == Compare_String_Vals(key, v, (REBOOL)!IS_BINARY(v))) { if (val) *++v = *val; return n/2+1; } } } else if (IS_INTEGER(key)) { for (n = 0; n < series->tail; n += 2, v += 2) { if (IS_INTEGER(v) && VAL_INT64(key) == VAL_INT64(v)) { if (val) *++v = *val; return n/2+1; } } } else if (IS_CHAR(key)) { for (n = 0; n < series->tail; n += 2, v += 2) { if (IS_CHAR(v) && VAL_CHAR(key) == VAL_CHAR(v)) { if (val) *++v = *val; return n/2+1; } } } else fail (Error_Has_Bad_Type(key)); if (!val) return 0; Append_Value(series, key); Append_Value(series, val); // does not copy value, e.g. if string return series->tail/2; } // Add hash table: //Print("hash added %d", series->tail); series->extra.series = hser = Make_Hash_Sequence(series->tail); MANAGE_SERIES(hser); Rehash_Hash(series); } // Get hash table, expand it if needed: if (series->tail > hser->tail/2) { Expand_Hash(hser); // modifies size value Rehash_Hash(series); } hash = Find_Key(series, hser, key, 2, 0, 0); hashes = (REBCNT*)hser->data; n = hashes[hash]; // Just a GET of value: if (!val) return n; // Must set the value: if (n) { // re-set it: *BLK_SKIP(series, ((n-1)*2)+1) = *val; // set it return n; } // Create new entry: Append_Value(series, key); Append_Value(series, val); // does not copy value, e.g. if string return (hashes[hash] = series->tail/2); }
*/ void Mold_Value(REB_MOLD *mold, REBVAL *value, REBFLG molded) /* ** Mold or form any value to string series tail. ** ***********************************************************************/ { REBYTE buf[60]; REBINT len; REBSER *ser = mold->series; CHECK_STACK(&len); ASSERT2(SERIES_WIDE(mold->series) == sizeof(REBUNI), RP_BAD_SIZE); ASSERT2(ser, RP_NO_BUFFER); // Special handling of string series: { if (ANY_STR(value) && !IS_TAG(value)) { // Forming a string: if (!molded) { Insert_String(ser, -1, VAL_SERIES(value), VAL_INDEX(value), VAL_LEN(value), 0); return; } // Special format for ALL string series when not at head: if (GET_MOPT(mold, MOPT_MOLD_ALL) && VAL_INDEX(value) != 0) { Mold_All_String(value, mold); return; } } switch (VAL_TYPE(value)) { case REB_NONE: Emit(mold, "+N", SYM_NONE); break; case REB_LOGIC: // if (!molded || !VAL_LOGIC_WORDS(value) || !GET_MOPT(mold, MOPT_MOLD_ALL)) Emit(mold, "+N", VAL_LOGIC(value) ? SYM_TRUE : SYM_FALSE); // else // Mold_Logic(mold, value); break; case REB_INTEGER: len = Emit_Integer(buf, VAL_INT64(value)); goto append; case REB_DECIMAL: case REB_PERCENT: len = Emit_Decimal(buf, VAL_DECIMAL(value), IS_PERCENT(value)?DEC_MOLD_PERCENT:0, Punctuation[GET_MOPT(mold, MOPT_COMMA_PT) ? PUNCT_COMMA : PUNCT_DOT], mold->digits); goto append; case REB_MONEY: len = Emit_Money(value, buf, mold->opts); goto append; case REB_CHAR: Mold_Uni_Char(ser, VAL_CHAR(value), (REBOOL)molded, (REBOOL)GET_MOPT(mold, MOPT_MOLD_ALL)); break; case REB_PAIR: len = Emit_Decimal(buf, VAL_PAIR_X(value), DEC_MOLD_MINIMAL, Punctuation[PUNCT_DOT], mold->digits/2); Append_Bytes_Len(ser, buf, len); Append_Byte(ser, 'x'); len = Emit_Decimal(buf, VAL_PAIR_Y(value), DEC_MOLD_MINIMAL, Punctuation[PUNCT_DOT], mold->digits/2); Append_Bytes_Len(ser, buf, len); //Emit(mold, "IxI", VAL_PAIR_X(value), VAL_PAIR_Y(value)); break; case REB_TUPLE: len = Emit_Tuple(value, buf); goto append; case REB_TIME: //len = Emit_Time(value, buf, Punctuation[GET_MOPT(mold, MOPT_COMMA_PT) ? PUNCT_COMMA : PUNCT_DOT]); Emit_Time(mold, value); break; case REB_DATE: Emit_Date(mold, value); break; case REB_STRING: // FORM happens in top section. Mold_String_Series(value, mold); break; case REB_BINARY: if (GET_MOPT(mold, MOPT_MOLD_ALL) && VAL_INDEX(value) != 0) { Mold_All_String(value, mold); return; } Mold_Binary(value, mold); break; case REB_FILE: if (VAL_LEN(value) == 0) { Append_Bytes(ser, "%\"\""); break; } Mold_File(value, mold); break; case REB_EMAIL: case REB_URL: Mold_Url(value, mold); break; case REB_TAG: if (GET_MOPT(mold, MOPT_MOLD_ALL) && VAL_INDEX(value) != 0) { Mold_All_String(value, mold); return; } Mold_Tag(value, mold); break; // Mold_Issue(value, mold); // break; case REB_BITSET: Pre_Mold(value, mold); // #[bitset! or make bitset! Mold_Bitset(value, mold); End_Mold(mold); break; case REB_IMAGE: Pre_Mold(value, mold); if (!GET_MOPT(mold, MOPT_MOLD_ALL)) { Append_Byte(ser, '['); Mold_Image_Data(value, mold); Append_Byte(ser, ']'); End_Mold(mold); } else { REBVAL val = *value; VAL_INDEX(&val) = 0; // mold all of it Mold_Image_Data(&val, mold); Post_Mold(value, mold); } break; case REB_BLOCK: case REB_PAREN: if (!molded) Form_Block_Series(VAL_SERIES(value), VAL_INDEX(value), mold, 0); else Mold_Block(value, mold); break; case REB_PATH: case REB_SET_PATH: case REB_GET_PATH: case REB_LIT_PATH: Mold_Block(value, mold); break; case REB_VECTOR: Mold_Vector(value, mold, molded); break; case REB_DATATYPE: if (!molded) Emit(mold, "N", VAL_DATATYPE(value) + 1); else Emit(mold, "+DN", SYM_DATATYPE_TYPE, VAL_DATATYPE(value) + 1); break; case REB_TYPESET: Mold_Typeset(value, mold, molded); break; case REB_WORD: // This is a high frequency function, so it is optimized. Append_UTF8(ser, Get_Sym_Name(VAL_WORD_SYM(value)), -1); break; case REB_SET_WORD: Emit(mold, "W:", value); break; case REB_GET_WORD: Emit(mold, ":W", value); break; case REB_LIT_WORD: Emit(mold, "\'W", value); break; case REB_REFINEMENT: Emit(mold, "/W", value); break; case REB_ISSUE: Emit(mold, "#W", value); break; case REB_CLOSURE: case REB_FUNCTION: case REB_NATIVE: case REB_ACTION: case REB_COMMAND: Mold_Function(value, mold); break; case REB_OBJECT: case REB_MODULE: case REB_PORT: if (!molded) Form_Object(value, mold); else Mold_Object(value, mold); break; case REB_TASK: Mold_Object(value, mold); //// | (1<<MOPT_NO_NONE)); break; case REB_ERROR: Mold_Error(value, mold, molded); break; case REB_MAP: Mold_Map(value, mold, molded); break; case REB_GOB: { REBSER *blk; Pre_Mold(value, mold); blk = Gob_To_Block(VAL_GOB(value)); Mold_Block_Series(mold, blk, 0, 0); End_Mold(mold); } break; case REB_EVENT: Mold_Event(value, mold); break; case REB_REBCODE: case REB_OP: case REB_FRAME: case REB_HANDLE: case REB_STRUCT: case REB_LIBRARY: case REB_UTYPE: // Value has no printable form, so just print its name. if (!molded) Emit(mold, "?T?", value); else Emit(mold, "+T", value); break; case REB_END: case REB_UNSET: if (molded) Emit(mold, "+T", value); break; default: Crash(RP_DATATYPE+5, VAL_TYPE(value)); } return; append: Append_Bytes_Len(ser, buf, len); }
*/ 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; }
*/ REBINT Cmp_Value(REBVAL *s, REBVAL *t, REBFLG is_case) /* ** Compare two values and return the difference. ** ** is_case TRUE for case sensitive compare ** ***********************************************************************/ { REBDEC d1, d2; if (VAL_TYPE(t) != VAL_TYPE(s) && !(IS_NUMBER(s) && IS_NUMBER(t))) return VAL_TYPE(s) - VAL_TYPE(t); switch(VAL_TYPE(s)) { case REB_INTEGER: if (IS_DECIMAL(t)) { d1 = (REBDEC)VAL_INT64(s); d2 = VAL_DECIMAL(t); goto chkDecimal; } return THE_SIGN(VAL_INT64(s) - VAL_INT64(t)); case REB_LOGIC: return VAL_LOGIC(s) - VAL_LOGIC(t); case REB_CHAR: if (is_case) return THE_SIGN(VAL_CHAR(s) - VAL_CHAR(t)); return THE_SIGN((REBINT)(UP_CASE(VAL_CHAR(s)) - UP_CASE(VAL_CHAR(t)))); case REB_DECIMAL: case REB_MONEY: d1 = VAL_DECIMAL(s); if (IS_INTEGER(t)) d2 = (REBDEC)VAL_INT64(t); else d2 = VAL_DECIMAL(t); chkDecimal: if (Eq_Decimal(d1, d2)) return 0; if (d1 < d2) return -1; return 1; case REB_PAIR: return Cmp_Pair(s, t); case REB_EVENT: return Cmp_Event(s, t); case REB_GOB: return Cmp_Gob(s, t); case REB_TUPLE: return Cmp_Tuple(s, t); case REB_TIME: return Cmp_Time(s, t); case REB_DATE: return Cmp_Date(s, t); case REB_BLOCK: case REB_PAREN: case REB_MAP: case REB_PATH: case REB_SET_PATH: case REB_GET_PATH: case REB_LIT_PATH: return Cmp_Block(s, t, is_case); case REB_STRING: case REB_FILE: case REB_EMAIL: case REB_URL: case REB_TAG: return Compare_String_Vals(s, t, (REBOOL)!is_case); case REB_BITSET: case REB_BINARY: case REB_IMAGE: return Compare_Binary_Vals(s, t); case REB_VECTOR: return Compare_Vector(s, t); case REB_DATATYPE: return VAL_DATATYPE(s) - VAL_DATATYPE(t); case REB_WORD: case REB_SET_WORD: case REB_GET_WORD: case REB_LIT_WORD: case REB_REFINEMENT: case REB_ISSUE: return Compare_Word(s,t,is_case); case REB_ERROR: return VAL_ERR_NUM(s) - VAL_ERR_NUM(s); case REB_OBJECT: case REB_MODULE: case REB_PORT: return VAL_OBJ_FRAME(s) - VAL_OBJ_FRAME(t); case REB_NATIVE: return &VAL_FUNC_CODE(s) - &VAL_FUNC_CODE(t); case REB_ACTION: case REB_COMMAND: case REB_OP: case REB_FUNCTION: return VAL_FUNC_BODY(s) - VAL_FUNC_BODY(t); case REB_NONE: case REB_UNSET: case REB_END: default: break; } return 0; }
*/ static REBCNT Find_Entry(REBSER *series, REBVAL *key, REBVAL *val) /* ** Try to find the entry in the map. If not found ** and val is SET, create the entry and store the key and ** val. ** ** RETURNS: the index to the VALUE or zero if there is none. ** ***********************************************************************/ { REBSER *hser = series->extra.series; // can be null REBCNT *hashes; REBCNT hash; REBVAL *v; REBCNT n; if (IS_NONE(key)) return 0; // We may not be large enough yet for the hash table to // be worthwhile, so just do a linear search: if (!hser) { if (series->tail < MIN_DICT*2) { v = BLK_HEAD(series); if (ANY_WORD(key)) { for (n = 0; n < series->tail; n += 2, v += 2) { if (ANY_WORD(v) && SAME_SYM(key, v)) { if (val) *++v = *val; return n/2+1; } } } else if (ANY_BINSTR(key)) { for (n = 0; n < series->tail; n += 2, v += 2) { if (VAL_TYPE(key) == VAL_TYPE(v) && 0 == Compare_String_Vals(key, v, (REBOOL)!IS_BINARY(v))) { if (val) { *++v = *val; // VAL_SERIES(v) = Copy_Series_Value(val); // VAL_INDEX(v) = 0; } return n/2+1; } } } else if (IS_INTEGER(key)) { for (n = 0; n < series->tail; n += 2, v += 2) { if (IS_INTEGER(v) && VAL_INT64(key) == VAL_INT64(v)) { if (val) *++v = *val; return n/2+1; } } } else if (IS_CHAR(key)) { for (n = 0; n < series->tail; n += 2, v += 2) { if (IS_CHAR(v) && VAL_CHAR(key) == VAL_CHAR(v)) { if (val) *++v = *val; return n/2+1; } } } else Trap_Type_DEAD_END(key); if (!val) return 0; Append_Value(series, key); Append_Value(series, val); // no Copy_Series_Value(val) on strings return series->tail/2; } // Add hash table: //Print("hash added %d", series->tail); series->extra.series = hser = Make_Hash_Array(series->tail); Rehash_Hash(series); } // Get hash table, expand it if needed: if (series->tail > hser->tail/2) { Expand_Hash(hser); // modifies size value Rehash_Hash(series); } hash = Find_Key(series, hser, key, 2, 0, 0); hashes = (REBCNT*)hser->data; n = hashes[hash]; // Just a GET of value: if (!val) return n; // Must set the value: if (n) { // re-set it: *BLK_SKIP(series, ((n-1)*2)+1) = *val; // set it return n; } // Create new entry: Append_Value(series, key); Append_Value(series, val); // no Copy_Series_Value(val) on strings return (hashes[hash] = series->tail/2); }
*/ static REBFLG Set_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val) /* ***********************************************************************/ { switch (VAL_WORD_CANON(word)) { case SYM_OFFSET: return Set_Pair(&(gob->offset), val); case SYM_SIZE: return Set_Pair(&gob->size, val); case SYM_IMAGE: CLR_GOB_OPAQUE(gob); if (IS_IMAGE(val)) { SET_GOB_TYPE(gob, GOBT_IMAGE); GOB_W(gob) = (REBD32)VAL_IMAGE_WIDE(val); GOB_H(gob) = (REBD32)VAL_IMAGE_HIGH(val); GOB_CONTENT(gob) = VAL_SERIES(val); // if (!VAL_IMAGE_TRANSP(val)) SET_GOB_OPAQUE(gob); } else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE); else return FALSE; break; case SYM_DRAW: CLR_GOB_OPAQUE(gob); if (IS_BLOCK(val)) { SET_GOB_TYPE(gob, GOBT_DRAW); GOB_CONTENT(gob) = VAL_SERIES(val); } else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE); else return FALSE; break; case SYM_TEXT: CLR_GOB_OPAQUE(gob); if (IS_BLOCK(val)) { SET_GOB_TYPE(gob, GOBT_TEXT); GOB_CONTENT(gob) = VAL_SERIES(val); } else if (IS_STRING(val)) { SET_GOB_TYPE(gob, GOBT_STRING); GOB_CONTENT(gob) = VAL_SERIES(val); } else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE); else return FALSE; break; case SYM_EFFECT: CLR_GOB_OPAQUE(gob); if (IS_BLOCK(val)) { SET_GOB_TYPE(gob, GOBT_EFFECT); GOB_CONTENT(gob) = VAL_SERIES(val); } else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE); else return FALSE; break; case SYM_COLOR: CLR_GOB_OPAQUE(gob); if (IS_TUPLE(val)) { SET_GOB_TYPE(gob, GOBT_COLOR); Set_Pixel_Tuple((REBYTE*)&GOB_CONTENT(gob), val); if (VAL_TUPLE_LEN(val) < 4 || VAL_TUPLE(val)[3] == 0) SET_GOB_OPAQUE(gob); } else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE); break; case SYM_PANE: if (GOB_PANE(gob)) Clear_Series(GOB_PANE(gob)); if (IS_BLOCK(val)) Insert_Gobs(gob, VAL_BLK_DATA(val), 0, VAL_BLK_LEN(val), 0); else if (IS_GOB(val)) Insert_Gobs(gob, val, 0, 1, 0); else if (IS_NONE(val)) gob->pane = 0; else return FALSE; break; case SYM_ALPHA: GOB_ALPHA(gob) = Clip_Int(Int32(val), 0, 255); break; case SYM_DATA: SET_GOB_DTYPE(gob, GOBD_NONE); if (IS_OBJECT(val)) { SET_GOB_DTYPE(gob, GOBD_OBJECT); SET_GOB_DATA(gob, VAL_OBJ_FRAME(val)); } else if (IS_BLOCK(val)) { SET_GOB_DTYPE(gob, GOBD_BLOCK); SET_GOB_DATA(gob, VAL_SERIES(val)); } else if (IS_STRING(val)) { SET_GOB_DTYPE(gob, GOBD_STRING); SET_GOB_DATA(gob, VAL_SERIES(val)); } else if (IS_BINARY(val)) { SET_GOB_DTYPE(gob, GOBD_BINARY); SET_GOB_DATA(gob, VAL_SERIES(val)); } else if (IS_INTEGER(val)) { SET_GOB_DTYPE(gob, GOBD_INTEGER); SET_GOB_DATA(gob, (void*)(REBIPT)VAL_INT64(val)); } else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE); else return FALSE; break; case SYM_FLAGS: if (IS_WORD(val)) Set_Gob_Flag(gob, val); else if (IS_BLOCK(val)) { gob->flags = 0; for (val = VAL_BLK(val); NOT_END(val); val++) { if (IS_WORD(val)) Set_Gob_Flag(gob, val); } } break; case SYM_OWNER: if (IS_GOB(val)) GOB_TMP_OWNER(gob) = VAL_GOB(val); else return FALSE; break; default: return FALSE; } return TRUE; }
*/ void Do_Commands(REBSER *cmds, void *context) /* ** Evaluate a block of commands as efficiently as possible. ** The arguments to each command must already be reduced or ** use only variable lookup. ** ** Returns the last evaluated value, if provided. ** ***********************************************************************/ { REBVAL *blk; REBCNT index = 0; REBVAL *set_word = 0; REBVAL *cmd_word; REBSER *words; REBVAL *args; REBVAL *val; REBVAL *func; RXIFRM frm; // args stored here REBCNT n; REBEXT *ext; REBCEC *ctx; if ((ctx = context)) ctx->block = cmds; blk = BLK_HEAD(cmds); while (NOT_END(blk)) { // var: command result if IS_SET_WORD(blk) { set_word = blk++; index++; }; // get command function if (IS_WORD(cmd_word = blk)) { // Optimized var fetch: n = VAL_WORD_INDEX(blk); if (n > 0) func = FRM_VALUES(VAL_WORD_FRAME(blk)) + n; else func = Get_Var(blk); // fallback } else func = blk; if (!IS_COMMAND(func)) Trap2(RE_EXPECT_VAL, Get_Type_Word(REB_COMMAND), blk); // Advance to next value blk++; if (ctx) ctx->index = index; // position of function index++; // get command arguments and body words = VAL_FUNC_WORDS(func); RXA_COUNT(&frm) = SERIES_TAIL(VAL_FUNC_ARGS(func))-1; // not self // collect each argument (arg list already validated on MAKE) n = 0; for (args = BLK_SKIP(words, 1); NOT_END(args); args++) { //Debug_Type(args); val = blk++; index++; if (IS_END(val)) Trap2(RE_NO_ARG, cmd_word, args); //Debug_Type(val); // actual arg is a word, lookup? if (VAL_TYPE(val) >= REB_WORD) { if (IS_WORD(val)) { if (IS_WORD(args)) val = Get_Var(val); } else if (IS_PATH(val)) { if (IS_WORD(args)) val = Get_Any_Var(val); // volatile value! } else if (IS_PAREN(val)) { val = Do_Blk(VAL_SERIES(val), 0); // volatile value! } // all others fall through } // check datatype if (!TYPE_CHECK(args, VAL_TYPE(val))) Trap3(RE_EXPECT_ARG, cmd_word, args, Of_Type(val)); // put arg into command frame n++; RXA_TYPE(&frm, n) = Reb_To_RXT[VAL_TYPE(val)]; frm.args[n] = Value_To_RXI(val); } // Call the command (also supports different extension modules): func = BLK_HEAD(VAL_FUNC_BODY(func)); n = (REBCNT)VAL_INT64(func + 1); ext = &Ext_List[VAL_I32(VAL_OBJ_VALUE(func, 1))]; // Handler n = ext->call(n, &frm, context); val = DS_RETURN; switch (n) { case RXR_VALUE: RXI_To_Value(val, frm.args[1], RXA_TYPE(&frm, 1)); break; case RXR_BLOCK: RXI_To_Block(&frm, val); break; case RXR_UNSET: SET_UNSET(val); break; case RXR_NONE: SET_NONE(val); break; case RXR_TRUE: SET_TRUE(val); break; case RXR_FALSE: SET_FALSE(val); break; case RXR_ERROR: default: SET_UNSET(val); } if (set_word) { Set_Var(set_word, val); set_word = 0; } } }
*/ REBI64 Make_Time(REBVAL *val) /* ** Returns NO_TIME if error. ** ***********************************************************************/ { REBI64 secs = 0; if (IS_TIME(val)) { secs = VAL_TIME(val); } else if (IS_STRING(val)) { REBYTE *bp; REBCNT len; bp = Qualify_String(val, 30, &len, FALSE); // can trap, ret diff str if (!Scan_Time(bp, len, val)) goto no_time; secs = VAL_TIME(val); } else if (IS_INTEGER(val)) { if (VAL_INT64(val) < -MAX_SECONDS || VAL_INT64(val) > MAX_SECONDS) Trap_Range_DEAD_END(val); secs = VAL_INT64(val) * SEC_SEC; } else if (IS_DECIMAL(val)) { if (VAL_DECIMAL(val) < (REBDEC)(-MAX_SECONDS) || VAL_DECIMAL(val) > (REBDEC)MAX_SECONDS) Trap_Range_DEAD_END(val); secs = DEC_TO_SECS(VAL_DECIMAL(val)); } else if (ANY_BLOCK(val) && VAL_BLK_LEN(val) <= 3) { REBFLG neg = FALSE; REBI64 i; val = VAL_BLK_DATA(val); if (!IS_INTEGER(val)) goto no_time; i = Int32(val); if (i < 0) i = -i, neg = TRUE; secs = i * 3600; if (secs > MAX_SECONDS) goto no_time; if (NOT_END(++val)) { if (!IS_INTEGER(val)) goto no_time; if ((i = Int32(val)) < 0) goto no_time; secs += i * 60; if (secs > MAX_SECONDS) goto no_time; if (NOT_END(++val)) { if (IS_INTEGER(val)) { if ((i = Int32(val)) < 0) goto no_time; secs += i; if (secs > MAX_SECONDS) goto no_time; } else if (IS_DECIMAL(val)) { if (secs + (REBI64)VAL_DECIMAL(val) + 1 > MAX_SECONDS) goto no_time; // added in below } else goto no_time; } } secs *= SEC_SEC; if (IS_DECIMAL(val)) secs += DEC_TO_SECS(VAL_DECIMAL(val)); if (neg) secs = -secs; } else no_time: return NO_TIME; return secs; }
*/ 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; }