// // Find_Max_Bit: C // // Return integer number for the maximum bit number defined by // the value. Used to determine how much space to allocate. // REBINT Find_Max_Bit(REBVAL *val) { REBINT maxi = 0; REBINT n; switch (VAL_TYPE(val)) { case REB_CHAR: maxi = VAL_CHAR(val)+1; break; case REB_INTEGER: maxi = Int32s(val, 0); break; case REB_STRING: case REB_FILE: case REB_EMAIL: case REB_URL: case REB_TAG: // case REB_ISSUE: n = VAL_INDEX(val); if (VAL_BYTE_SIZE(val)) { REBYTE *bp = VAL_BIN(val); for (; n < cast(REBINT, VAL_LEN_HEAD(val)); n++) if (bp[n] > maxi) maxi = bp[n]; } else { REBUNI *up = VAL_UNI(val); for (; n < cast(REBINT, VAL_LEN_HEAD(val)); n++) if (up[n] > maxi) maxi = up[n]; } maxi++; break; case REB_BINARY: maxi = VAL_LEN_AT(val) * 8 - 1; if (maxi < 0) maxi = 0; break; case REB_BLOCK: for (val = VAL_ARRAY_AT(val); NOT_END(val); val++) { n = Find_Max_Bit(val); if (n > maxi) maxi = n; } //maxi++; break; case REB_NONE: maxi = 0; break; default: return -1; } return maxi; }
// // MAKE_String: C // void MAKE_String(REBVAL *out, enum Reb_Kind kind, const REBVAL *def) { REBSER *ser; // goto would cross initialization if (IS_INTEGER(def)) { // // !!! R3-Alpha tolerated decimal, e.g. `make string! 3.14`, which // is semantically nebulous (round up, down?) and generally bad. // ser = Make_Binary(Int32s(def, 0)); Val_Init_Series(out, kind, ser); return; } else if (IS_BLOCK(def)) { // // The construction syntax for making strings or binaries that are // preloaded with an offset into the data is #[binary [#{0001} 2]]. // In R3-Alpha make definitions didn't have to be a single value // (they are for compatibility between construction syntax and MAKE // in Ren-C). So the positional syntax was #[binary! #{0001} 2]... // while #[binary [#{0001} 2]] would join the pieces together in order // to produce #{000102}. That behavior is not available in Ren-C. if (VAL_ARRAY_LEN_AT(def) != 2) goto bad_make; RELVAL *any_binstr = VAL_ARRAY_AT(def); if (!ANY_BINSTR(any_binstr)) goto bad_make; if (IS_BINARY(any_binstr) != LOGICAL(kind == REB_BINARY)) goto bad_make; RELVAL *index = VAL_ARRAY_AT(def) + 1; if (!IS_INTEGER(index)) goto bad_make; REBINT i = Int32(index) - 1 + VAL_INDEX(any_binstr); if (i < 0 || i > cast(REBINT, VAL_LEN_AT(any_binstr))) goto bad_make; Val_Init_Series_Index(out, kind, VAL_SERIES(any_binstr), i); return; } if (kind == REB_BINARY) ser = make_binary(def, TRUE); else ser = MAKE_TO_String_Common(def); if (!ser) goto bad_make; Val_Init_Series_Index(out, kind, ser, 0); return; bad_make: fail (Error_Bad_Make(kind, def)); }
*/ static void replace_with(REBSER *ser, REBCNT index, REBCNT tail, REBVAL *with) /* ** Replace whitespace chars that match WITH string. ** ** Resulting string is always smaller than it was to start. ** ***********************************************************************/ { #define MAX_WITH 32 REBCNT wlen; REBUNI with_chars[MAX_WITH]; // chars to be trimmed REBUNI *up = with_chars; REBYTE *bp; REBCNT n; REBUNI uc; // Setup WITH array from arg or the default: n = 0; if (IS_NONE(with)) { bp = "\n \r\t"; wlen = n = 4; } else if (IS_CHAR(with)) { wlen = 1; *up++ = VAL_CHAR(with); } else if (IS_INTEGER(with)) { wlen = 1; *up++ = Int32s(with, 0); } else if (ANY_BINSTR(with)) { n = VAL_LEN(with); if (n >= MAX_WITH) n = MAX_WITH-1; wlen = n; if (VAL_BYTE_SIZE(with)) { bp = VAL_BIN_DATA(with); } else { memcpy(up, VAL_UNI_DATA(with), n * sizeof(REBUNI)); n = 0; } } for (; n > 0; n--) *up++ = (REBUNI)*bp++; // Remove all occurances of chars found in WITH string: for (n = index; index < tail; index++) { uc = GET_ANY_CHAR(ser, index); if (!find_in_uni(with_chars, wlen, uc)) { SET_ANY_CHAR(ser, n, uc); n++; } } SET_ANY_CHAR(ser, n, 0); SERIES_TAIL(ser) = n; }
static REBSER *make_string(REBVAL *arg, REBOOL make) { REBSER *ser = 0; // MAKE <type> 123 if (make && (IS_INTEGER(arg) || IS_DECIMAL(arg))) { ser = Make_Binary(Int32s(arg, 0)); } // MAKE/TO <type> <binary!> else if (IS_BINARY(arg)) { REBYTE *bp = VAL_BIN_DATA(arg); REBCNT len = VAL_LEN(arg); switch (What_UTF(bp, len)) { case 0: break; case 8: // UTF-8 encoded bp += 3; len -= 3; break; default: Trap0(RE_BAD_DECODE); } ser = Decode_UTF_String(bp, len, 8); // UTF-8 } // MAKE/TO <type> <any-string> else if (ANY_BINSTR(arg)) { ser = Copy_String(VAL_SERIES(arg), VAL_INDEX(arg), VAL_LEN(arg)); } // MAKE/TO <type> <any-word> else if (ANY_WORD(arg)) { ser = Copy_Mold_Value(arg, TRUE); //ser = Append_UTF8(0, Get_Word_Name(arg), -1); } // MAKE/TO <type> #"A" else if (IS_CHAR(arg)) { ser = (VAL_CHAR(arg) > 0xff) ? Make_Unicode(2) : Make_Binary(2); Append_Byte(ser, VAL_CHAR(arg)); } // MAKE/TO <type> <any-value> // else if (IS_NONE(arg)) { // ser = Make_Binary(0); // } else ser = Copy_Form_Value(arg, 1<<MOPT_TIGHT); return ser; }
// // MAKE_Vector: C // void MAKE_Vector(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) { // CASE: make vector! 100 if (IS_INTEGER(arg) || IS_DECIMAL(arg)) { REBINT size = Int32s(arg, 0); if (size < 0) goto bad_make; REBSER *ser = Make_Vector(0, 0, 1, 32, size); Val_Init_Vector(out, ser); return; } TO_Vector(out, kind, arg); // may fail() return; bad_make: fail (Error_Bad_Make(kind, arg)); }
*/ 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; }
static REBSER *make_binary(REBVAL *arg, REBOOL make) { REBSER *ser; // MAKE BINARY! 123 switch (VAL_TYPE(arg)) { case REB_INTEGER: case REB_DECIMAL: if (make) ser = Make_Binary(Int32s(arg, 0)); else ser = Make_Binary_BE64(arg); break; // MAKE/TO BINARY! BINARY! case REB_BINARY: ser = Copy_Bytes(VAL_BIN_DATA(arg), VAL_LEN(arg)); break; // MAKE/TO BINARY! <any-string> case REB_STRING: case REB_FILE: case REB_EMAIL: case REB_URL: case REB_TAG: // case REB_ISSUE: ser = Encode_UTF8_Value(arg, VAL_LEN(arg), 0); break; case REB_BLOCK: ser = Join_Binary(arg); break; // MAKE/TO BINARY! <tuple!> case REB_TUPLE: ser = Copy_Bytes(VAL_TUPLE(arg), VAL_TUPLE_LEN(arg)); break; // MAKE/TO BINARY! <char!> case REB_CHAR: ser = Make_Binary(6); ser->tail = Encode_UTF8_Char(BIN_HEAD(ser), VAL_CHAR(arg)); break; // MAKE/TO BINARY! <bitset!> case REB_BITSET: ser = Copy_Bytes(VAL_BIN(arg), VAL_TAIL(arg)); break; // MAKE/TO BINARY! <image!> case REB_IMAGE: ser = Make_Image_Binary(arg); break; case REB_MONEY: ser = Make_Binary(12); ser->tail = 12; deci_to_binary(ser->data, VAL_DECI(arg)); ser->data[12] = 0; break; default: ser = 0; } return ser; }
// // 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; }
*/ REBINT PD_Date(REBPVS *pvs) /* ***********************************************************************/ { REBVAL *data = pvs->value; REBVAL *arg = pvs->select; REBVAL *val = pvs->setval; REBINT i; REBINT n; REBI64 secs; REBINT tz; REBDAT date; REBCNT day, month, year; REBINT num; REBVAL dat; REB_TIMEF time; // !zone! - adjust date by zone (unless /utc given) if (IS_WORD(arg)) { //!!! change this to an array!? switch (VAL_WORD_CANON(arg)) { case SYM_YEAR: i = 0; break; case SYM_MONTH: i = 1; break; case SYM_DAY: i = 2; break; case SYM_TIME: i = 3; break; case SYM_ZONE: i = 4; break; case SYM_DATE: i = 5; break; case SYM_WEEKDAY: i = 6; break; case SYM_JULIAN: case SYM_YEARDAY: i = 7; break; case SYM_UTC: i = 8; break; case SYM_HOUR: i = 9; break; case SYM_MINUTE: i = 10; break; case SYM_SECOND: i = 11; break; default: return PE_BAD_SELECT; } } else if (IS_INTEGER(arg)) { i = Int32(arg) - 1; if (i < 0 || i > 8) return PE_BAD_SELECT; } else return PE_BAD_SELECT; if (IS_DATE(data)) { dat = *data; // recode! data = &dat; if (i != 8) Adjust_Date_Zone(data, FALSE); // adjust for timezone date = VAL_DATE(data); day = VAL_DAY(data) - 1; month = VAL_MONTH(data) - 1; year = VAL_YEAR(data); secs = VAL_TIME(data); tz = VAL_ZONE(data); if (i > 8) Split_Time(secs, &time); } else { Trap_Arg_DEAD_END(data); // this should never happen } if (val == 0) { val = pvs->store; switch(i) { case 0: num = year; break; case 1: num = month + 1; break; case 2: num = day + 1; break; case 3: if (secs == NO_TIME) return PE_NONE; *val = *data; VAL_SET(val, REB_TIME); return PE_USE; case 4: if (secs == NO_TIME) return PE_NONE; *val = *data; VAL_TIME(val) = (i64)tz * ZONE_MINS * MIN_SEC; VAL_SET(val, REB_TIME); return PE_USE; case 5: // date *val = *data; VAL_TIME(val) = NO_TIME; VAL_ZONE(val) = 0; return PE_USE; case 6: // weekday num = Week_Day(date); break; case 7: // yearday num = (REBINT)Julian_Date(date); break; case 8: // utc *val = *data; VAL_ZONE(val) = 0; return PE_USE; case 9: num = time.h; break; case 10: num = time.m; break; case 11: if (time.n == 0) num = time.s; else { SET_DECIMAL(val, (REBDEC)time.s + (time.n * NANO)); return PE_USE; } break; default: return PE_NONE; } SET_INTEGER(val, num); return PE_USE; } else { if (IS_INTEGER(val) || IS_DECIMAL(val)) n = Int32s(val, 0); else if (IS_NONE(val)) n = 0; else if (IS_TIME(val) && (i == 3 || i == 4)); else if (IS_DATE(val) && (i == 3 || i == 5)); else return PE_BAD_SET_TYPE; switch(i) { case 0: year = n; break; case 1: month = n - 1; break; case 2: day = n - 1; break; case 3: // time if (IS_NONE(val)) { secs = NO_TIME; tz = 0; break; } else if (IS_TIME(val) || IS_DATE(val)) secs = VAL_TIME(val); else if (IS_INTEGER(val)) secs = n * SEC_SEC; else if (IS_DECIMAL(val)) secs = DEC_TO_SECS(VAL_DECIMAL(val)); else return PE_BAD_SET_TYPE; break; case 4: // zone if (IS_TIME(val)) tz = (REBINT)(VAL_TIME(val) / (ZONE_MINS * MIN_SEC)); else if (IS_DATE(val)) tz = VAL_ZONE(val); else tz = n * (60 / ZONE_MINS); if (tz > MAX_ZONE || tz < -MAX_ZONE) return PE_BAD_RANGE; break; case 5: // date if (!IS_DATE(val)) return PE_BAD_SET_TYPE; date = VAL_DATE(val); goto setDate; case 9: time.h = n; secs = Join_Time(&time, FALSE); break; case 10: time.m = n; secs = Join_Time(&time, FALSE); break; case 11: if (IS_INTEGER(val)) { time.s = n; time.n = 0; } else { //if (f < 0.0) Trap_Range_DEAD_END(val); time.s = (REBINT)VAL_DECIMAL(val); time.n = (REBINT)((VAL_DECIMAL(val) - time.s) * SEC_SEC); } secs = Join_Time(&time, FALSE); break; default: return PE_BAD_SET; } Normalize_Time(&secs, &day); date = Normalize_Date(day, month, year, tz); setDate: data = pvs->value; VAL_SET(data, REB_DATE); VAL_DATE(data) = date; VAL_TIME(data) = secs; Adjust_Date_Zone(data, TRUE); return PE_USE; } }
*/ 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; }
*/ static REBCNT Parse_Rules_Loop(REBPARSE *parse, REBCNT index, REBVAL *rules, REBCNT depth) /* ***********************************************************************/ { REBSER *series = parse->series; REBVAL *item; // current rule item REBVAL *word; // active word to be set REBCNT start; // recovery restart point REBCNT i; // temp index point REBCNT begin; // point at beginning of match REBINT count; // iterated pattern counter REBINT mincount; // min pattern count REBINT maxcount; // max pattern count REBVAL *item_hold; REBVAL *val; // spare REBCNT rulen; REBSER *ser; REBFLG flags; REBCNT cmd; REBVAL *rule_head = rules; CHECK_STACK(&flags); //if (depth > MAX_PARSE_DEPTH) Trap_Word(RE_LIMIT_HIT, SYM_PARSE, 0); flags = 0; word = 0; mincount = maxcount = 1; start = begin = index; // For each rule in the rule block: while (NOT_END(rules)) { //Print_Parse_Index(parse->type, rules, series, index); if (--Eval_Count <= 0 || Eval_Signals) Do_Signals(); //-------------------------------------------------------------------- // Pre-Rule Processing Section // // For non-iterated rules, including setup for iterated rules. // The input index is not advanced here, but may be changed by // a GET-WORD variable. //-------------------------------------------------------------------- item = rules++; // If word, set-word, or get-word, process it: if (VAL_TYPE(item) >= REB_WORD && VAL_TYPE(item) <= REB_GET_WORD) { // Is it a command word? if (cmd = VAL_CMD(item)) { if (!IS_WORD(item)) Trap1(RE_PARSE_COMMAND, item); // SET or GET not allowed if (cmd <= SYM_BREAK) { // optimization switch (cmd) { case SYM_OR_BAR: return index; // reached it successfully // Note: mincount = maxcount = 1 on entry case SYM_WHILE: SET_FLAG(flags, PF_WHILE); case SYM_ANY: mincount = 0; case SYM_SOME: maxcount = MAX_I32; continue; case SYM_OPT: mincount = 0; continue; case SYM_COPY: SET_FLAG(flags, PF_COPY); case SYM_SET: SET_FLAG(flags, PF_SET); item = rules++; if (!IS_WORD(item)) Trap1(RE_PARSE_VARIABLE, item); if (VAL_CMD(item)) Trap1(RE_PARSE_COMMAND, item); word = item; continue; case SYM_NOT: SET_FLAG(flags, PF_NOT); flags ^= (1<<PF_NOT2); continue; case SYM_AND: SET_FLAG(flags, PF_AND); continue; case SYM_THEN: SET_FLAG(flags, PF_THEN); continue; case SYM_REMOVE: SET_FLAG(flags, PF_REMOVE); continue; case SYM_INSERT: SET_FLAG(flags, PF_INSERT); goto post; case SYM_CHANGE: SET_FLAG(flags, PF_CHANGE); continue; case SYM_RETURN: if (IS_PAREN(rules)) { item = Do_Block_Value_Throw(rules); // might GC Throw_Return_Value(item); } SET_FLAG(flags, PF_RETURN); continue; case SYM_ACCEPT: case SYM_BREAK: parse->result = 1; return index; case SYM_REJECT: parse->result = -1; return index; case SYM_FAIL: index = NOT_FOUND; goto post; case SYM_IF: item = rules++; if (IS_END(item)) goto bad_end; if (!IS_PAREN(item)) Trap1(RE_PARSE_RULE, item); item = Do_Block_Value_Throw(item); // might GC if (IS_TRUE(item)) continue; else { index = NOT_FOUND; goto post; } case SYM_LIMIT: Trap0(RE_NOT_DONE); //val = Get_Parse_Value(rules++); // if (IS_INTEGER(val)) limit = index + Int32(val); // else if (ANY_SERIES(val)) limit = VAL_INDEX(val); // else goto //goto bad_rule; // goto post; case SYM_QQ: Print_Parse_Index(parse->type, rules, series, index); continue; } } // Any other cmd must be a match command, so proceed... } else { // It's not a PARSE command, get or set it: // word: - set a variable to the series at current index if (IS_SET_WORD(item)) { Set_Var_Series(item, parse->type, series, index); continue; } // :word - change the index for the series to a new position if (IS_GET_WORD(item)) { item = Get_Var(item); // CureCode #1263 change //if (parse->type != VAL_TYPE(item) || VAL_SERIES(item) != series) // Trap1(RE_PARSE_SERIES, rules-1); if (!ANY_SERIES(item)) Trap1(RE_PARSE_SERIES, rules-1); index = Set_Parse_Series(parse, item); series = parse->series; continue; } // word - some other variable if (IS_WORD(item)) { item = Get_Var(item); } // item can still be 'word or /word } } else if (ANY_PATH(item)) { item = Do_Parse_Path(item, parse, &index); // index can be modified if (index > series->tail) index = series->tail; if (item == 0) continue; // for SET and GET cases } if (IS_PAREN(item)) { Do_Block_Value_Throw(item); // might GC if (index > series->tail) index = series->tail; continue; } // Counter? 123 if (IS_INTEGER(item)) { // Specify count or range count SET_FLAG(flags, PF_WHILE); mincount = maxcount = Int32s(item, 0); item = Get_Parse_Value(rules++); if (IS_END(item)) Trap1(RE_PARSE_END, rules-2); if (IS_INTEGER(item)) { maxcount = Int32s(item, 0); item = Get_Parse_Value(rules++); if (IS_END(item)) Trap1(RE_PARSE_END, rules-2); } } // else fall through on other values and words //-------------------------------------------------------------------- // Iterated Rule Matching Section: // // Repeats the same rule N times or until the rule fails. // The index is advanced and stored in a temp variable i until // the entire rule has been satisfied. //-------------------------------------------------------------------- item_hold = item; // a command or literal match value if (VAL_TYPE(item) <= REB_UNSET || VAL_TYPE(item) >= REB_NATIVE) goto bad_rule; begin = index; // input at beginning of match section rulen = 0; // rules consumed (do not use rule++ below) i = index; //note: rules var already advanced for (count = 0; count < maxcount;) { item = item_hold; if (IS_WORD(item)) { switch (cmd = VAL_WORD_CANON(item)) { case SYM_SKIP: i = (index < series->tail) ? index+1 : NOT_FOUND; break; case SYM_END: i = (index < series->tail) ? NOT_FOUND : series->tail; break; case SYM_TO: case SYM_THRU: if (IS_END(rules)) goto bad_end; item = Get_Parse_Value(rules); rulen = 1; i = Parse_To(parse, index, item, cmd == SYM_THRU); break; case SYM_QUOTE: if (IS_END(rules)) goto bad_end; rulen = 1; if (IS_PAREN(rules)) { item = Do_Block_Value_Throw(rules); // might GC } else item = rules; i = (0 == Cmp_Value(BLK_SKIP(series, index), item, parse->flags & AM_FIND_CASE)) ? index+1 : NOT_FOUND; break; case SYM_INTO: if (IS_END(rules)) goto bad_end; rulen = 1; item = Get_Parse_Value(rules); // sub-rules if (!IS_BLOCK(item)) goto bad_rule; val = BLK_SKIP(series, index); i = ( (ANY_BINSTR(val) || ANY_BLOCK(val)) && (Parse_Series(val, VAL_BLK_DATA(item), parse->flags, depth+1) == VAL_TAIL(val)) ) ? index+1 : NOT_FOUND; break; case SYM_DO: if (!IS_BLOCK_INPUT(parse)) goto bad_rule; i = Do_Eval_Rule(parse, index, &rules); rulen = 1; break; default: goto bad_rule; } } else if (IS_BLOCK(item)) { item = VAL_BLK_DATA(item); //if (IS_END(rules) && item == rule_head) { // rules = item; // goto top; //} i = Parse_Rules_Loop(parse, index, item, depth+1); if (parse->result) { index = (parse->result > 0) ? i : NOT_FOUND; parse->result = 0; break; } } // Parse according to datatype: else { if (IS_BLOCK_INPUT(parse)) i = Parse_Next_Block(parse, index, item, depth+1); else i = Parse_Next_String(parse, index, item, depth+1); } // Necessary for special cases like: some [to end] // i: indicates new index or failure of the match, but // that does not mean failure of the rule, because optional // matches can still succeed, if if the last match failed. if (i != NOT_FOUND) { count++; // may overflow to negative if (count < 0) count = MAX_I32; // the forever case // If input did not advance: if (i == index && !GET_FLAG(flags, PF_WHILE)) { if (count < mincount) index = NOT_FOUND; // was not enough break; } } //if (i >= series->tail) { // OLD check: no more input else { if (count < mincount) index = NOT_FOUND; // was not enough else if (i != NOT_FOUND) index = i; // else keep index as is. break; } index = i; // A BREAK word stopped us: //if (parse->result) {parse->result = 0; break;} } rules += rulen; //if (index > series->tail && index != NOT_FOUND) index = series->tail; if (index > series->tail) index = NOT_FOUND; //-------------------------------------------------------------------- // Post Match Processing: //-------------------------------------------------------------------- post: // Process special flags: if (flags) { // NOT before all others: if (GET_FLAG(flags, PF_NOT)) { if (GET_FLAG(flags, PF_NOT2) && index != NOT_FOUND) index = NOT_FOUND; else index = begin; } if (index == NOT_FOUND) { // Failure actions: // not decided: if (word) Set_Var_Basic(word, REB_NONE); if (GET_FLAG(flags, PF_THEN)) { SKIP_TO_BAR(rules); if (!IS_END(rules)) rules++; } } else { // Success actions: count = (begin > index) ? 0 : index - begin; // how much we advanced the input if (GET_FLAG(flags, PF_COPY)) { ser = (IS_BLOCK_INPUT(parse)) ? Copy_Block_Len(series, begin, count) : Copy_String(series, begin, count); // condenses Set_Var_Series(word, parse->type, ser, 0); } else if (GET_FLAG(flags, PF_SET)) { if (IS_BLOCK_INPUT(parse)) { item = Get_Var_Safe(word); if (count == 0) SET_NONE(item); else *item = *BLK_SKIP(series, begin); } else { item = Get_Var_Safe(word); if (count == 0) SET_NONE(item); else { i = GET_ANY_CHAR(series, begin); if (parse->type == REB_BINARY) { SET_INTEGER(item, i); } else { SET_CHAR(item, i); } } } } if (GET_FLAG(flags, PF_RETURN)) { ser = (IS_BLOCK_INPUT(parse)) ? Copy_Block_Len(series, begin, count) : Copy_String(series, begin, count); // condenses Throw_Return_Series(parse->type, ser); } if (GET_FLAG(flags, PF_REMOVE)) { if (count) Remove_Series(series, begin, count); index = begin; } if (flags & (1<<PF_INSERT | 1<<PF_CHANGE)) { count = GET_FLAG(flags, PF_INSERT) ? 0 : count; cmd = GET_FLAG(flags, PF_INSERT) ? 0 : (1<<AN_PART); item = rules++; if (IS_END(item)) goto bad_end; // Check for ONLY flag: if (IS_WORD(item) && NZ(cmd = VAL_CMD(item))) { if (cmd != SYM_ONLY) goto bad_rule; cmd |= (1<<AN_ONLY); item = rules++; } // CHECK FOR QUOTE!! item = Get_Parse_Value(item); // new value if (IS_UNSET(item)) Trap1(RE_NO_VALUE, rules-1); if (IS_END(item)) goto bad_end; if (IS_BLOCK_INPUT(parse)) { index = Modify_Block(GET_FLAG(flags, PF_CHANGE) ? A_CHANGE : A_INSERT, series, begin, item, cmd, count, 1); if (IS_LIT_WORD(item)) SET_TYPE(BLK_SKIP(series, index-1), REB_WORD); } else { if (parse->type == REB_BINARY) cmd |= (1<<AN_SERIES); // special flag index = Modify_String(GET_FLAG(flags, PF_CHANGE) ? A_CHANGE : A_INSERT, series, begin, item, cmd, count, 1); } } if (GET_FLAG(flags, PF_AND)) index = begin; } flags = 0; word = 0; } // Goto alternate rule and reset input: if (index == NOT_FOUND) { SKIP_TO_BAR(rules); if (IS_END(rules)) break; rules++; index = begin = start; } begin = index; mincount = maxcount = 1; } return index; bad_rule: Trap1(RE_PARSE_RULE, rules-1); bad_end: Trap1(RE_PARSE_END, rules-1); return 0; }
// // 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 REBSER *make_binary(const REBVAL *arg, REBOOL make) { REBSER *ser; // MAKE BINARY! 123 switch (VAL_TYPE(arg)) { case REB_INTEGER: case REB_DECIMAL: if (make) ser = Make_Binary(Int32s(arg, 0)); else ser = Make_Binary_BE64(arg); break; // MAKE/TO BINARY! BINARY! case REB_BINARY: ser = Copy_Bytes(VAL_BIN_AT(arg), VAL_LEN_AT(arg)); break; // MAKE/TO BINARY! <any-string> case REB_STRING: case REB_FILE: case REB_EMAIL: case REB_URL: case REB_TAG: // case REB_ISSUE: ser = Make_UTF8_From_Any_String(arg, VAL_LEN_AT(arg), 0); break; case REB_BLOCK: // Join_Binary returns a shared buffer, so produce a copy: ser = Copy_Sequence(Join_Binary(arg, -1)); break; // MAKE/TO BINARY! <tuple!> case REB_TUPLE: ser = Copy_Bytes(VAL_TUPLE(arg), VAL_TUPLE_LEN(arg)); break; // MAKE/TO BINARY! <char!> case REB_CHAR: ser = Make_Binary(6); TERM_SEQUENCE_LEN(ser, Encode_UTF8_Char(BIN_HEAD(ser), VAL_CHAR(arg))); break; // MAKE/TO BINARY! <bitset!> case REB_BITSET: ser = Copy_Bytes(VAL_BIN(arg), VAL_LEN_HEAD(arg)); break; // MAKE/TO BINARY! <image!> case REB_IMAGE: ser = Make_Image_Binary(arg); break; case REB_MONEY: ser = Make_Binary(12); deci_to_binary(BIN_HEAD(ser), VAL_MONEY_AMOUNT(arg)); TERM_SEQUENCE_LEN(ser, 12); break; default: ser = 0; } return ser; }
// "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)) fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2))); *D_OUT = *val1; VAL_TYPESET_BITS(D_OUT) |= VAL_TYPESET_BITS(val2);
*/ void Make_Block_Type(REBFLG make, REBVAL *value, REBVAL *arg) /* ** Value can be: ** 1. a datatype (e.g. BLOCK!) ** 2. a value (e.g. [...]) ** ** Arg can be: ** 1. integer (length of block) ** 2. block (copy it) ** 3. value (convert to a block) ** ***********************************************************************/ { REBCNT type; REBCNT len; REBSER *ser; // make block! ... if (IS_DATATYPE(value)) type = VAL_DATATYPE(value); else // make [...] .... type = VAL_TYPE(value); // make block! [1 2 3] if (ANY_BLOCK(arg)) { len = VAL_BLK_LEN(arg); if (len > 0 && type >= REB_PATH && type <= REB_LIT_PATH) No_Nones(arg); ser = Copy_Values(VAL_BLK_DATA(arg), len); goto done; } if (IS_STRING(arg)) { REBCNT index, len = 0; VAL_SERIES(arg) = Prep_Bin_Str(arg, &index, &len); // (keeps safe) ser = Scan_Source(VAL_BIN(arg), VAL_LEN(arg)); goto done; } if (IS_BINARY(arg)) { ser = Scan_Source(VAL_BIN_DATA(arg), VAL_LEN(arg)); goto done; } if (IS_MAP(arg)) { ser = Map_To_Block(VAL_SERIES(arg), 0); goto done; } if (ANY_OBJECT(arg)) { ser = Make_Object_Block(VAL_OBJ_FRAME(arg), 3); goto done; } if (IS_VECTOR(arg)) { ser = Make_Vector_Block(arg); goto done; } // if (make && IS_NONE(arg)) { // ser = Make_Block(0); // goto done; // } // to block! typset if (!make && IS_TYPESET(arg) && type == REB_BLOCK) { Set_Block(value, Typeset_To_Block(arg)); return; } if (make) { // make block! 10 if (IS_INTEGER(arg) || IS_DECIMAL(arg)) { len = Int32s(arg, 0); Set_Series(type, value, Make_Block(len)); return; } Trap_Arg(arg); } ser = Copy_Values(arg, 1); done: Set_Series(type, value, ser); return; }
*/ REBINT Find_Max_Bit(REBVAL *val) /* ** Return integer number for the maximum bit number defined by ** the value. Used to determine how much space to allocate. ** ***********************************************************************/ { REBINT maxi = 0; REBINT n; switch (VAL_TYPE(val)) { case REB_CHAR: maxi = VAL_CHAR(val)+1; break; case REB_INTEGER: maxi = Int32s(val, 0); break; case REB_STRING: case REB_FILE: case REB_EMAIL: case REB_URL: case REB_TAG: // case REB_ISSUE: n = VAL_INDEX(val); if (VAL_BYTE_SIZE(val)) { REBYTE *bp = VAL_BIN(val); for (; n < (REBINT)VAL_TAIL(val); n++) if (bp[n] > maxi) maxi = bp[n]; } else { REBUNI *up = VAL_UNI(val); for (; n < (REBINT)VAL_TAIL(val); n++) if (up[n] > maxi) maxi = up[n]; } maxi++; break; case REB_BINARY: maxi = VAL_LEN(val) * 8 - 1; if (maxi < 0) maxi = 0; break; case REB_BLOCK: for (val = VAL_BLK_DATA(val); NOT_END(val); val++) { n = Find_Max_Bit(val); if (n > maxi) maxi = n; } //maxi++; break; case REB_NONE: maxi = 0; break; default: return -1; } return maxi; }
*/ REBFLG MT_Date(REBVAL *val, REBVAL *arg, REBCNT type) /* ** Given a block of values, construct a date datatype. ** ***********************************************************************/ { REBI64 secs = NO_TIME; REBINT tz = 0; REBDAT date; REBCNT year, month, day; if (IS_DATE(arg)) { *val = *arg; return TRUE; } if (!IS_INTEGER(arg)) return FALSE; day = Int32s(arg++, 1); if (!IS_INTEGER(arg)) return FALSE; month = Int32s(arg++, 1); if (!IS_INTEGER(arg)) return FALSE; if (day > 99) { year = day; day = Int32s(arg++, 1); } else year = Int32s(arg++, 0); if (month < 1 || month > 12) return FALSE; if (year > MAX_YEAR || day < 1 || day > Month_Max_Days[month-1]) return FALSE; // Check February for leap year or century: if (month == 2 && day == 29) { if (((year % 4) != 0) || // not leap year ((year % 100) == 0 && // century? (year % 400) != 0)) return FALSE; // not leap century } day--; month--; if (IS_TIME(arg)) { secs = VAL_TIME(arg); arg++; } if (IS_TIME(arg)) { tz = (REBINT)(VAL_TIME(arg) / (ZONE_MINS * MIN_SEC)); if (tz < -MAX_ZONE || tz > MAX_ZONE) Trap_Range_DEAD_END(arg); arg++; } if (!IS_END(arg)) return FALSE; Normalize_Time(&secs, &day); date = Normalize_Date(day, month, year, tz); VAL_SET(val, REB_DATE); VAL_DATE(val) = date; VAL_TIME(val) = secs; Adjust_Date_Zone(val, TRUE); return TRUE; }
*/ REBINT PD_Time(REBPVS *pvs) /* ***********************************************************************/ { REBVAL *val; REBINT i; REBINT n; REBDEC f; REB_TIMEF tf; if (IS_WORD(pvs->select)) { switch (VAL_WORD_CANON(pvs->select)) { case SYM_HOUR: i = 0; break; case SYM_MINUTE: i = 1; break; case SYM_SECOND: i = 2; break; default: return PE_BAD_SELECT; } } else if (IS_INTEGER(pvs->select)) i = VAL_INT32(pvs->select) - 1; else return PE_BAD_SELECT; Split_Time(VAL_TIME(pvs->value), &tf); // loses sign if (!(val = pvs->setval)) { val = pvs->store; switch(i) { case 0: // hours SET_INTEGER(val, tf.h); break; case 1: SET_INTEGER(val, tf.m); break; case 2: if (tf.n == 0) SET_INTEGER(val, tf.s); else SET_DECIMAL(val, (REBDEC)tf.s + (tf.n * NANO)); break; default: return PE_NONE; } return PE_USE; } else { if (IS_INTEGER(val) || IS_DECIMAL(val)) n = Int32s(val, 0); else if (IS_NONE(val)) n = 0; else return PE_BAD_SET; switch(i) { case 0: tf.h = n; break; case 1: tf.m = n; break; case 2: if (IS_DECIMAL(val)) { f = VAL_DECIMAL(val); if (f < 0.0) Trap_Range_DEAD_END(val); tf.s = (REBINT)f; tf.n = (REBINT)((f - tf.s) * SEC_SEC); } else { tf.s = n; tf.n = 0; } break; default: return PE_BAD_SELECT; } VAL_TIME(pvs->value) = Join_Time(&tf, FALSE); return PE_OK; } }
// // Make_Vector_Spec: C // // Make a vector from a block spec. // // make vector! [integer! 32 100] // make vector! [decimal! 64 100] // make vector! [unsigned integer! 32] // Fields: // signed: signed, unsigned // datatypes: integer, decimal // dimensions: 1 - N // bitsize: 1, 8, 16, 32, 64 // size: integer units // init: block of values // REBVAL *Make_Vector_Spec(RELVAL *bp, REBCTX *specifier, REBVAL *value) { REBINT type = -1; // 0 = int, 1 = float REBINT sign = -1; // 0 = signed, 1 = unsigned REBINT dims = 1; REBINT bits = 32; REBCNT size = 1; REBSER *vect; REBVAL *iblk = 0; // UNSIGNED if (IS_WORD(bp) && VAL_WORD_SYM(bp) == SYM_UNSIGNED) { sign = 1; bp++; } // INTEGER! or DECIMAL! if (IS_WORD(bp)) { if (SAME_SYM_NONZERO(VAL_WORD_SYM(bp), SYM_FROM_KIND(REB_INTEGER))) type = 0; else if ( SAME_SYM_NONZERO(VAL_WORD_SYM(bp), SYM_FROM_KIND(REB_DECIMAL)) ){ type = 1; if (sign > 0) return 0; } else return 0; bp++; } if (type < 0) type = 0; if (sign < 0) sign = 0; // BITS if (IS_INTEGER(bp)) { bits = Int32(KNOWN(bp)); if ( (bits == 32 || bits == 64) || (type == 0 && (bits == 8 || bits == 16)) ) bp++; else return 0; } else return 0; // SIZE if (NOT_END(bp) && IS_INTEGER(bp)) { if (Int32(KNOWN(bp)) < 0) return 0; size = Int32(KNOWN(bp)); bp++; } // Initial data: if (NOT_END(bp) && (IS_BLOCK(bp) || IS_BINARY(bp))) { REBCNT len = VAL_LEN_AT(bp); if (IS_BINARY(bp) && type == 1) return 0; if (len > size) size = len; iblk = KNOWN(bp); bp++; } VAL_RESET_HEADER(value, REB_VECTOR); // Index offset: if (NOT_END(bp) && IS_INTEGER(bp)) { VAL_INDEX(value) = (Int32s(KNOWN(bp), 1) - 1); bp++; } else VAL_INDEX(value) = 0; if (NOT_END(bp)) return 0; vect = Make_Vector(type, sign, dims, bits, size); if (!vect) return 0; if (iblk) Set_Vector_Row(vect, iblk); INIT_VAL_SERIES(value, vect); MANAGE_SERIES(vect); // index set earlier return value; }