// // Partial1: C // // Process the /part (or /skip) and other length modifying // arguments. // REBINT Partial1(REBVAL *sval, REBVAL *lval) { REBI64 len; REBINT maxlen; REBINT is_ser = ANY_SERIES(sval); // If lval is not set or is BAR!, use the current len of the target value: if (IS_UNSET(lval) || IS_BAR(lval)) { if (!is_ser) return 1; if (VAL_INDEX(sval) >= VAL_LEN_HEAD(sval)) return 0; return (VAL_LEN_HEAD(sval) - VAL_INDEX(sval)); } if (IS_INTEGER(lval) || IS_DECIMAL(lval)) len = Int32(lval); else { if (is_ser && VAL_TYPE(sval) == VAL_TYPE(lval) && VAL_SERIES(sval) == VAL_SERIES(lval)) len = (REBINT)VAL_INDEX(lval) - (REBINT)VAL_INDEX(sval); else fail (Error(RE_INVALID_PART, lval)); } if (is_ser) { // Restrict length to the size available: if (len >= 0) { maxlen = (REBINT)VAL_LEN_AT(sval); if (len > maxlen) len = maxlen; } else { len = -len; if (len > (REBINT)VAL_INDEX(sval)) len = (REBINT)VAL_INDEX(sval); VAL_INDEX(sval) -= (REBCNT)len; } } return (REBINT)len; }
// // 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; }
// // Partial: C // // Args: // aval: target value // bval: argument to modify target (optional) // lval: length value (or none) // // Determine the length of a /PART value. It can be: // 1. integer or decimal // 2. relative to A value (bval is null) // 3. relative to B value // // NOTE: Can modify the value's index! // The result can be negative. ??? // REBINT Partial(REBVAL *aval, REBVAL *bval, REBVAL *lval) { REBVAL *val; REBINT len; REBINT maxlen; // If lval is unset, use the current len of the target value: if (IS_UNSET(lval)) { val = (bval && ANY_SERIES(bval)) ? bval : aval; if (VAL_INDEX(val) >= VAL_LEN_HEAD(val)) return 0; return (VAL_LEN_HEAD(val) - VAL_INDEX(val)); } if (IS_INTEGER(lval) || IS_DECIMAL(lval)) { len = Int32(lval); val = bval; } else { // So, lval must be relative to aval or bval series: if ( VAL_TYPE(aval) == VAL_TYPE(lval) && VAL_SERIES(aval) == VAL_SERIES(lval) ) { val = aval; } else if ( bval && VAL_TYPE(bval) == VAL_TYPE(lval) && VAL_SERIES(bval) == VAL_SERIES(lval) ) { val = bval; } else fail (Error(RE_INVALID_PART, lval)); len = cast(REBINT, VAL_INDEX(lval)) - cast(REBINT, VAL_INDEX(val)); } if (!val) val = aval; // Restrict length to the size available // if (len >= 0) { maxlen = (REBINT)VAL_LEN_AT(val); if (len > maxlen) len = maxlen; } else { len = -len; if (len > cast(REBINT, VAL_INDEX(val))) len = cast(REBINT, VAL_INDEX(val)); VAL_INDEX(val) -= (REBCNT)len; } return len; }
// // Check_Bit_Str: C // // If uncased is TRUE, try to match either upper or lower case. // REBOOL Check_Bit_Str(REBSER *bset, const REBVAL *val, REBOOL uncased) { REBCNT n = VAL_INDEX(val); if (VAL_BYTE_SIZE(val)) { REBYTE *bp = VAL_BIN(val); for (; n < VAL_LEN_HEAD(val); n++) if (Check_Bit(bset, bp[n], uncased)) return TRUE; } else { REBUNI *up = VAL_UNI(val); for (; n < VAL_LEN_HEAD(val); n++) if (Check_Bit(bset, up[n], uncased)) return TRUE; } return FALSE; }
// // Resolve_Path: C // // Given a path, return a context and index for its terminal. // REBCTX *Resolve_Path(REBVAL *path, REBCNT *index) { REBVAL *sel; // selector const REBVAL *val; REBARR *blk; REBCNT i; if (VAL_LEN_HEAD(path) < 2) return 0; blk = VAL_ARRAY(path); sel = ARR_HEAD(blk); if (!ANY_WORD(sel)) return 0; val = GET_OPT_VAR_MAY_FAIL(sel); sel = ARR_AT(blk, 1); while (TRUE) { if (!ANY_CONTEXT(val) || !IS_WORD(sel)) return 0; i = Find_Word_In_Context(VAL_CONTEXT(val), VAL_WORD_SYM(sel), FALSE); sel++; if (IS_END(sel)) { *index = i; return VAL_CONTEXT(val); } } return 0; // never happens }
// // Temp_Byte_Chars_May_Fail: C // // NOTE: This function returns a temporary result, and uses an internal // buffer. Do not use it recursively. Also, it will Trap on errors. // // Prequalifies a string before using it with a function that // expects it to be 8-bits. It would be used for instance to convert // a string that is potentially REBUNI-wide into a form that can be used // with a Scan_XXX routine, that is expecting ASCII or UTF-8 source. // (Many TO-XXX conversions from STRING re-use that scanner logic.) // // Returns a temporary string and sets the length field. // // If `allow_utf8`, the constructed result is converted to UTF8. // // Checks or converts it: // // 1. it is byte string (not unicode) // 2. if unicode, copy and return as temp byte string // 3. it's actual content (less space, newlines) <= max len // 4. it does not contain other values ("123 456") // 5. it's not empty or only whitespace // REBYTE *Temp_Byte_Chars_May_Fail( const REBVAL *val, REBINT max_len, REBCNT *length, REBOOL allow_utf8 ) { REBCNT tail = VAL_LEN_HEAD(val); REBCNT index = VAL_INDEX(val); REBCNT len; REBUNI c; REBYTE *bp; REBSER *src = VAL_SERIES(val); if (index > tail) fail (Error(RE_PAST_END)); Resize_Series(BYTE_BUF, max_len+1); bp = BIN_HEAD(BYTE_BUF); // Skip leading whitespace: for (; index < tail; index++) { c = GET_ANY_CHAR(src, index); if (!IS_SPACE(c)) break; } // Copy chars that are valid: for (; index < tail; index++) { c = GET_ANY_CHAR(src, index); if (c >= 0x80) { if (!allow_utf8) fail (Error(RE_INVALID_CHARS)); len = Encode_UTF8_Char(bp, c); max_len -= len; bp += len; } else if (!IS_SPACE(c)) { *bp++ = (REBYTE)c; max_len--; } else break; if (max_len < 0) fail (Error(RE_TOO_LONG)); } // Rest better be just spaces: for (; index < tail; index++) { c = GET_ANY_CHAR(src, index); if (!IS_SPACE(c)) fail (Error(RE_INVALID_CHARS)); } *bp = '\0'; len = bp - BIN_HEAD(BYTE_BUF); if (len == 0) fail (Error(RE_TOO_SHORT)); if (length) *length = len; return BIN_HEAD(BYTE_BUF); }
// // 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; }
// // Do_Breakpoint_Throws: C // // A call to Do_Breakpoint_Throws does delegation to a hook in the host, which // (if registered) will generally start an interactive session for probing the // environment at the break. The `resume` native cooperates by being able to // give back a value (or give back code to run to produce a value) that the // call to breakpoint returns. // // RESUME has another feature, which is to be able to actually unwind and // simulate a return /AT a function *further up the stack*. (This may be // switched to a feature of a "STEP OUT" command at some point.) // REBOOL Do_Breakpoint_Throws( REBVAL *out, REBOOL interrupted, // Ctrl-C (as opposed to a BREAKPOINT) const REBVAL *default_value, REBOOL do_default ) { REBVAL *target = NONE_VALUE; REBVAL temp; VAL_INIT_WRITABLE_DEBUG(&temp); if (!PG_Breakpoint_Quitting_Hook) { // // Host did not register any breakpoint handler, so raise an error // about this as early as possible. // fail (Error(RE_HOST_NO_BREAKPOINT)); } // We call the breakpoint hook in a loop, in order to keep running if any // inadvertent FAILs or THROWs occur during the interactive session. // Only a conscious call of RESUME speaks the protocol to break the loop. // while (TRUE) { struct Reb_State state; REBCTX *error; push_trap: PUSH_TRAP(&error, &state); // The host may return a block of code to execute, but cannot // while evaluating do a THROW or a FAIL that causes an effective // "resumption". Halt is the exception, hence we PUSH_TRAP and // not PUSH_UNHALTABLE_TRAP. QUIT is also an exception, but a // desire to quit is indicated by the return value of the breakpoint // hook (which may or may not decide to request a quit based on the // QUIT command being run). // // The core doesn't want to get involved in presenting UI, so if // an error makes it here and wasn't trapped by the host first that // is a bug in the host. It should have done its own PUSH_TRAP. // if (error) { #if !defined(NDEBUG) REBVAL error_value; VAL_INIT_WRITABLE_DEBUG(&error_value); Val_Init_Error(&error_value, error); PROBE_MSG(&error_value, "Error not trapped during breakpoint:"); Panic_Array(CTX_VARLIST(error)); #endif // In release builds, if an error managed to leak out of the // host's breakpoint hook somehow...just re-push the trap state // and try it again. // goto push_trap; } // Call the host's breakpoint hook. // if (PG_Breakpoint_Quitting_Hook(&temp, interrupted)) { // // If a breakpoint hook returns TRUE that means it wants to quit. // The value should be the /WITH value (as in QUIT/WITH) // assert(!THROWN(&temp)); *out = *ROOT_QUIT_NATIVE; CONVERT_NAME_TO_THROWN(out, &temp, FALSE); return TRUE; // TRUE = threw } // If a breakpoint handler returns FALSE, then it should have passed // back a "resume instruction" triggered by a call like: // // resume/do [fail "This is how to fail from a breakpoint"] // // So now that the handler is done, we will allow any code handed back // to do whatever FAIL it likes vs. trapping that here in a loop. // DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state); // Decode and process the "resume instruction" { struct Reb_Frame *frame; REBVAL *mode; REBVAL *payload; assert(IS_GROUP(&temp)); assert(VAL_LEN_HEAD(&temp) == RESUME_INST_MAX); mode = VAL_ARRAY_AT_HEAD(&temp, RESUME_INST_MODE); payload = VAL_ARRAY_AT_HEAD(&temp, RESUME_INST_PAYLOAD); target = VAL_ARRAY_AT_HEAD(&temp, RESUME_INST_TARGET); // The first thing we need to do is determine if the target we // want to return to has another breakpoint sandbox blocking // us. If so, what we need to do is actually retransmit the // resume instruction so it can break that wall, vs. transform // it into an EXIT/FROM that would just get intercepted. // if (!IS_NONE(target)) { #if !defined(NDEBUG) REBOOL found = FALSE; #endif for (frame = FS_TOP; frame != NULL; frame = frame->prior) { if (frame->mode != CALL_MODE_FUNCTION) continue; if ( frame != FS_TOP && FUNC_CLASS(frame->func) == FUNC_CLASS_NATIVE && ( FUNC_CODE(frame->func) == &N_pause || FUNC_CODE(frame->func) == &N_breakpoint ) ) { // We hit a breakpoint (that wasn't this call to // breakpoint, at the current FS_TOP) before finding // the sought after target. Retransmit the resume // instruction so that level will get it instead. // *out = *ROOT_RESUME_NATIVE; CONVERT_NAME_TO_THROWN(out, &temp, FALSE); return TRUE; // TRUE = thrown } if (IS_FRAME(target)) { if (NOT(frame->flags & DO_FLAG_FRAME_CONTEXT)) continue; if ( VAL_CONTEXT(target) == AS_CONTEXT(frame->data.context) ) { // Found a closure matching the target before we // reached a breakpoint, no need to retransmit. // #if !defined(NDEBUG) found = TRUE; #endif break; } } else { assert(IS_FUNCTION(target)); if (frame->flags & DO_FLAG_FRAME_CONTEXT) continue; if (VAL_FUNC(target) == frame->func) { // // Found a function matching the target before we // reached a breakpoint, no need to retransmit. // #if !defined(NDEBUG) found = TRUE; #endif break; } } } // RESUME should not have been willing to use a target that // is not on the stack. // #if !defined(NDEBUG) assert(found); #endif } if (IS_NONE(mode)) { // // If the resume instruction had no /DO or /WITH of its own, // then it doesn't override whatever the breakpoint provided // as a default. (If neither the breakpoint nor the resume // provided a /DO or a /WITH, result will be UNSET.) // goto return_default; // heeds `target` } assert(IS_LOGIC(mode)); if (VAL_LOGIC(mode)) { if (DO_VAL_ARRAY_AT_THROWS(&temp, payload)) { // // Throwing is not compatible with /AT currently. // if (!IS_NONE(target)) fail (Error_No_Catch_For_Throw(&temp)); // Just act as if the BREAKPOINT call itself threw // *out = temp; return TRUE; // TRUE = thrown } // Ordinary evaluation result... } else temp = *payload; } // The resume instruction will be GC'd. // goto return_temp; } DEAD_END; return_default: if (do_default) { if (DO_VAL_ARRAY_AT_THROWS(&temp, default_value)) { // // If the code throws, we're no longer in the sandbox...so we // bubble it up. Note that breakpoint runs this code at its // level... so even if you request a higher target, any throws // will be processed as if they originated at the BREAKPOINT // frame. To do otherwise would require the EXIT/FROM protocol // to add support for DO-ing at the receiving point. // *out = temp; return TRUE; // TRUE = thrown } } else temp = *default_value; // generally UNSET! if no /WITH return_temp: // The easy case is that we just want to return from breakpoint // directly, signaled by the target being NONE!. // if (IS_NONE(target)) { *out = temp; return FALSE; // FALSE = not thrown } // If the target is a function, then we're looking to simulate a return // from something up the stack. This uses the same mechanic as // definitional returns--a throw named by the function or closure frame. // // !!! There is a weak spot in definitional returns for FUNCTION! that // they can only return to the most recent invocation; which is a weak // spot of FUNCTION! in general with stack relative variables. Also, // natives do not currently respond to definitional returns...though // they can do so just as well as FUNCTION! can. // *out = *target; CONVERT_NAME_TO_THROWN(out, &temp, TRUE); return TRUE; // TRUE = thrown }
// // Val_Byte_Len: C // // Get length of series in bytes. // REBCNT Val_Byte_Len(const REBVAL *value) { if (VAL_INDEX(value) >= VAL_LEN_HEAD(value)) return 0; return (VAL_LEN_HEAD(value) - VAL_INDEX(value)) * SER_WIDE(VAL_SERIES(value)); }
// // Val_Series_Len_At: C // // Get length of an ANY-SERIES! value, taking the current index into account. // Avoid negative values. // REBCNT Val_Series_Len_At(const REBVAL *value) { if (VAL_INDEX(value) >= VAL_LEN_HEAD(value)) return 0; return VAL_LEN_HEAD(value) - VAL_INDEX(value); }
// // Make_Set_Operation_Series: C // // Do set operations on a series. Case-sensitive if `cased` is TRUE. // `skip` is the record size. // static REBSER *Make_Set_Operation_Series( const REBVAL *val1, const REBVAL *val2, REBFLGS flags, REBOOL cased, REBCNT skip ) { REBCNT i; REBINT h = 1; // used for both logic true/false and hash check REBOOL first_pass = TRUE; // are we in the first pass over the series? REBSER *out_ser; assert(ANY_SERIES(val1)); if (val2) { assert(ANY_SERIES(val2)); if (ANY_ARRAY(val1)) { if (!ANY_ARRAY(val2)) fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2))); // As long as they're both arrays, we're willing to do: // // >> union quote (a b c) 'b/d/e // (a b c d e) // // The type of the result will match the first value. } else if (!IS_BINARY(val1)) { // We will similarly do any two ANY-STRING! types: // // >> union <abc> "bde" // <abcde> if (IS_BINARY(val2)) fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2))); } else { // Binaries only operate with other binaries if (!IS_BINARY(val2)) fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2))); } } // Calculate `i` as maximum length of result block. The temporary buffer // will be allocated at this size, but copied out at the exact size of // the actual result. // i = VAL_LEN_AT(val1); if (flags & SOP_FLAG_BOTH) i += VAL_LEN_AT(val2); if (ANY_ARRAY(val1)) { REBSER *hser = 0; // hash table for series REBSER *hret; // hash table for return series // The buffer used for building the return series. Currently it // reuses BUF_EMIT, because that buffer is not likely to be in // use (emit doesn't call set operations, nor vice versa). However, // other routines may get the same idea and start recursing so it // may be better to use something more similar to the mold stack // approach of marking off successive ranges in the array. // REBSER *buffer = ARR_SERIES(BUF_EMIT); Resize_Series(buffer, 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 FIND on the value itself w/o the hash. do { REBARR *array1 = VAL_ARRAY(val1); // val1 and val2 swapped 2nd pass! // Check what is in series1 but not in series2 // if (flags & SOP_FLAG_CHECK) hser = Hash_Block(val2, skip, cased); // Iterate over first series // i = VAL_INDEX(val1); for (; i < ARR_LEN(array1); i += skip) { RELVAL *item = ARR_AT(array1, i); if (flags & SOP_FLAG_CHECK) { h = Find_Key_Hashed( VAL_ARRAY(val2), hser, item, VAL_SPECIFIER(val1), skip, cased, 1 ); h = (h >= 0); if (flags & SOP_FLAG_INVERT) h = !h; } if (h) { Find_Key_Hashed( AS_ARRAY(buffer), hret, item, VAL_SPECIFIER(val1), skip, cased, 2 ); } } if (i != ARR_LEN(array1)) { // // In the current philosophy, the semantics of what to do // with things like `intersect/skip [1 2 3] [7] 2` is too // shaky to deal with, so an error is reported if it does // not work out evenly to the skip size. // fail (Error(RE_BLOCK_SKIP_WRONG)); } if (flags & SOP_FLAG_CHECK) Free_Series(hser); if (!first_pass) break; first_pass = FALSE; // Iterate over second series? // if ((i = ((flags & SOP_FLAG_BOTH) != 0))) { const REBVAL *temp = val1; val1 = val2; val2 = temp; } } while (i); if (hret) Free_Series(hret); out_ser = ARR_SERIES(Copy_Array_Shallow(AS_ARRAY(buffer), SPECIFIED)); SET_SERIES_LEN(buffer, 0); // required - allow reuse } else { REB_MOLD mo; CLEARS(&mo); if (IS_BINARY(val1)) { // // All binaries use "case-sensitive" comparison (e.g. each byte // is treated distinctly) // cased = TRUE; } // ask mo.series to have at least `i` capacity beyond mo.start // mo.opts = MOPT_RESERVE; mo.reserve = i; Push_Mold(&mo); do { REBSER *ser = VAL_SERIES(val1); // val1 and val2 swapped 2nd pass! REBUNI uc; // Iterate over first series // i = VAL_INDEX(val1); for (; i < SER_LEN(ser); i += skip) { uc = GET_ANY_CHAR(ser, i); if (flags & SOP_FLAG_CHECK) { h = (NOT_FOUND != Find_Str_Char( uc, VAL_SERIES(val2), 0, VAL_INDEX(val2), VAL_LEN_HEAD(val2), skip, cased ? AM_FIND_CASE : 0 )); if (flags & SOP_FLAG_INVERT) h = !h; } if (!h) continue; if ( NOT_FOUND == Find_Str_Char( uc, // c2 (the character to find) mo.series, // ser mo.start, // head mo.start, // index SER_LEN(mo.series), // tail skip, // skip cased ? AM_FIND_CASE : 0 // flags ) ) { Append_String(mo.series, ser, i, skip); } } if (!first_pass) break; first_pass = FALSE; // Iterate over second series? // if ((i = ((flags & SOP_FLAG_BOTH) != 0))) { const REBVAL *temp = val1; val1 = val2; val2 = temp; } } while (i); out_ser = Pop_Molded_String(&mo); } return out_ser; }
// // 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; }
// // Series_Common_Action_Returns: C // // This routine is called to handle actions on ANY-SERIES! that can be taken // care of without knowing what specific kind of series it is. So generally // index manipulation, and things like LENGTH/etc. // // The strange name is to convey the result in an if statement, in the same // spirit as the `if (XXX_Throws(...)) { /* handle throw */ }` pattern. // REBOOL Series_Common_Action_Returns( REB_R *r, // `r_out` would be slightly confusing, considering R_OUT REBFRM *frame_, REBSYM action ) { REBVAL *value = D_ARG(1); REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL; REBINT index = cast(REBINT, VAL_INDEX(value)); REBINT tail = cast(REBINT, VAL_LEN_HEAD(value)); REBINT len = 0; switch (action) { //-- Navigation: case SYM_HEAD: VAL_INDEX(value) = 0; break; case SYM_TAIL: VAL_INDEX(value) = (REBCNT)tail; break; case SYM_HEAD_Q: *r = (index == 0) ? R_TRUE : R_FALSE; return TRUE; // handled case SYM_TAIL_Q: *r = (index >= tail) ? R_TRUE : R_FALSE; return TRUE; // handled case SYM_PAST_Q: *r = (index > tail) ? R_TRUE : R_FALSE; return TRUE; // handled case SYM_NEXT: if (index < tail) VAL_INDEX(value)++; break; case SYM_BACK: if (index > 0) VAL_INDEX(value)--; break; case SYM_SKIP: case SYM_AT: len = Get_Num_From_Arg(arg); { REBI64 i = (REBI64)index + (REBI64)len; if (action == SYM_SKIP) { if (IS_LOGIC(arg)) i--; } else { // A_AT if (len > 0) i--; } if (i > (REBI64)tail) i = (REBI64)tail; else if (i < 0) i = 0; VAL_INDEX(value) = (REBCNT)i; } break; case SYM_INDEX_OF: SET_INTEGER(D_OUT, cast(REBI64, index) + 1); *r = R_OUT; return TRUE; // handled case SYM_LENGTH: SET_INTEGER(D_OUT, tail > index ? tail - index : 0); *r = R_OUT; return TRUE; // handled case SYM_REMOVE: // /PART length FAIL_IF_LOCKED_SERIES(VAL_SERIES(value)); len = D_REF(2) ? Partial(value, 0, D_ARG(3)) : 1; index = cast(REBINT, VAL_INDEX(value)); if (index < tail && len != 0) Remove_Series(VAL_SERIES(value), VAL_INDEX(value), len); break; case SYM_ADD: // Join_Strings(value, arg); case SYM_SUBTRACT: // "test this" - 10 case SYM_MULTIPLY: // "t" * 4 = "tttt" case SYM_DIVIDE: case SYM_REMAINDER: case SYM_POWER: case SYM_ODD_Q: case SYM_EVEN_Q: case SYM_ABSOLUTE: fail (Error_Illegal_Action(VAL_TYPE(value), action)); default: return FALSE; // not a common operation, not handled } *D_OUT = *value; *r = R_OUT; return TRUE; // handled }
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; }
// // Mold_Vector: C // void Mold_Vector(const REBVAL *value, REB_MOLD *mold, REBOOL molded) { REBSER *vect = VAL_SERIES(value); REBYTE *data = SER_DATA_RAW(vect); REBCNT bits = VECT_TYPE(vect); // REBCNT dims = vect->size >> 8; REBCNT len; REBCNT n; REBCNT c; union {REBU64 i; REBDEC d;} v; REBYTE buf[32]; REBYTE l; if (GET_MOPT(mold, MOPT_MOLD_ALL)) { len = VAL_LEN_HEAD(value); n = 0; } else { len = VAL_LEN_AT(value); n = VAL_INDEX(value); } if (molded) { enum Reb_Kind kind = (bits >= VTSF08) ? REB_DECIMAL : REB_INTEGER; Pre_Mold(value, mold); if (!GET_MOPT(mold, MOPT_MOLD_ALL)) Append_Codepoint_Raw(mold->series, '['); if (bits >= VTUI08 && bits <= VTUI64) Append_Unencoded(mold->series, "unsigned "); Emit( mold, "N I I [", Canon(SYM_FROM_KIND(kind)), bit_sizes[bits & 3], len ); if (len) New_Indented_Line(mold); } c = 0; for (; n < SER_LEN(vect); n++) { v.i = get_vect(bits, data, n); if (bits < VTSF08) { l = Emit_Integer(buf, v.i); } else { l = Emit_Decimal(buf, v.d, 0, '.', mold->digits); } Append_Unencoded_Len(mold->series, s_cast(buf), l); if ((++c > 7) && (n + 1 < SER_LEN(vect))) { New_Indented_Line(mold); c = 0; } else Append_Codepoint_Raw(mold->series, ' '); } if (len) { // // remove final space (overwritten with terminator) // TERM_UNI_LEN(mold->series, UNI_LEN(mold->series) - 1); } if (molded) { if (len) New_Indented_Line(mold); Append_Codepoint_Raw(mold->series, ']'); if (!GET_MOPT(mold, MOPT_MOLD_ALL)) { Append_Codepoint_Raw(mold->series, ']'); } else { Post_Mold(value, mold); } } }