*/ static REBVAL *Do_Parse_Path(REBVAL *item, REBPARSE *parse, REBCNT *index) /* ** Handle a PATH, including get and set, that's found in a rule. ** ***********************************************************************/ { REBVAL *path = item; REBVAL tmp; if (IS_PATH(item)) { if (Do_Path(&path, 0)) return item; // found a function item = DS_TOP; } else if (IS_SET_PATH(item)) { Set_Series(parse->type, &tmp, parse->series); VAL_INDEX(&tmp) = *index; if (Do_Path(&path, &tmp)) return item; // found a function return 0; } else if (IS_GET_PATH(item)) { if (Do_Path(&path, 0)) return item; // found a function item = DS_TOP; // CureCode #1263 change // if (parse->type != VAL_TYPE(item) || VAL_SERIES(item) != parse->series) if (!ANY_SERIES(item)) Trap1(RE_PARSE_SERIES, path); *index = Set_Parse_Series(parse, item); return 0; } return item; }
// // 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; }
*/ static REBFLG Get_Index_Var(REBVAL *item, REBSER *series, REBINT *index) /* ** Get the series index from a word or path or integer. ** ** Returns: TRUE if value was a series. FALSE if integer. ** ***********************************************************************/ { REBVAL *hold = item; if (IS_END(item)) Trap1(RE_PARSE_END, item); if (IS_WORD(item)) { if (!VAL_CMD(item)) item = Get_Var(item); } else if (IS_PATH(item)) { REBVAL *path = item; Do_Path(&path, 0); //!!! function! item = DS_TOP; } else if (!IS_INTEGER(item)) Trap1(RE_PARSE_VARIABLE, hold); if (IS_INTEGER(item)) { *index = Int32(item); return FALSE; } if (!ANY_SERIES(item) || VAL_SERIES(item) != series) Trap1(RE_PARSE_SERIES, hold); *index = VAL_INDEX(item); return TRUE; }
// // 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; }
*/ REBINT Partial1(REBVAL *sval, REBVAL *lval) /* ** Process the /part (or /skip) and other length modifying ** arguments. ** ***********************************************************************/ { REBI64 len; REBINT maxlen; REBINT is_ser = ANY_SERIES(sval); // If lval = NONE, use the current len of the target value: if (IS_NONE(lval)) { if (!is_ser) return 1; if (VAL_INDEX(sval) >= VAL_TAIL(sval)) return 0; return (VAL_TAIL(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 Trap1(RE_INVALID_PART, lval); } if (is_ser) { // Restrict length to the size available: if (len >= 0) { maxlen = (REBINT)VAL_LEN(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; }
// // Uncolor: C // // Clear the recusion markers for series and object trees. // void Uncolor(RELVAL *v) { REBARR *array; if (ANY_ARRAY_OR_PATH(v)) array = VAL_ARRAY(v); else if (IS_MAP(v)) array = MAP_PAIRLIST(VAL_MAP(v)); else if (ANY_CONTEXT(v)) array = CTX_VARLIST(VAL_CONTEXT(v)); else { // Shouldn't have marked recursively any non-array series (no need) // assert( not ANY_SERIES(v) or Is_Series_White(VAL_SERIES(v)) ); return; } Uncolor_Array(array); }
// // 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, REBCNT flags, REBCNT cased, REBCNT skip) { REBSER *buffer; // buffer for building the return series REBCNT i; REBINT h = TRUE; REBFLG first_pass = TRUE; // are we in the first pass over the series? REBSER *out_ser; // This routine should only be called with SERIES! values 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 length of result block. i = VAL_LEN(val1); if (flags & SOP_FLAG_BOTH) i += VAL_LEN(val2); if (ANY_ARRAY(val1)) { REBSER *hser = 0; // hash table for series REBSER *hret; // hash table for return series buffer = BUF_EMIT; // use preallocated shared block 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 do a FIND on the value itself w/o the hash. do { REBSER *ser = VAL_SERIES(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, cased); // Iterate over first series: i = VAL_INDEX(val1); for (; i < SERIES_TAIL(ser); i += skip) { REBVAL *item = BLK_SKIP(ser, i); if (flags & SOP_FLAG_CHECK) { h = Find_Key(VAL_SERIES(val2), hser, item, skip, cased, 1); h = (h >= 0); if (flags & SOP_FLAG_INVERT) h = !h; } if (h) Find_Key(buffer, hret, item, skip, cased, 2); } 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 = Copy_Array_Shallow(buffer); RESET_TAIL(buffer); // required - allow reuse } else { if (IS_BINARY(val1)) { // All binaries use "case-sensitive" comparison (e.g. each byte // is treated distinctly) cased = TRUE; } buffer = BUF_MOLD; Reset_Buffer(buffer, i); RESET_TAIL(buffer); do { REBSER *ser = VAL_SERIES(val1); // val1 and val2 swapped 2nd pass! REBUNI uc; // Iterate over first series: i = VAL_INDEX(val1); for (; i < SERIES_TAIL(ser); i += skip) { uc = GET_ANY_CHAR(ser, i); if (flags & SOP_FLAG_CHECK) { h = (NOT_FOUND != Find_Str_Char( VAL_SERIES(val2), 0, VAL_INDEX(val2), VAL_TAIL(val2), skip, uc, cased ? AM_FIND_CASE : 0 )); if (flags & SOP_FLAG_INVERT) h = !h; } if (!h) continue; if ( NOT_FOUND == Find_Str_Char( buffer, 0, 0, SERIES_TAIL(buffer), skip, uc, cased ? AM_FIND_CASE : 0 ) ) { Append_String(buffer, 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 = Copy_String(buffer, 0, -1); } return out_ser; }
*/ REBINT Partial(REBVAL *aval, REBVAL *bval, REBVAL *lval, REBFLG flag) /* ** 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 ** ** Flag: indicates special treatment for CHANGE. As in: ** CHANGE/part "abcde" "xy" 3 => "xyde" ** ** NOTE: Can modify the value's index! ** The result can be negative. ??? ** ***********************************************************************/ { REBVAL *val; REBINT len; REBINT maxlen; // If lval = NONE, use the current len of the target value: if (IS_NONE(lval)) { val = (bval && ANY_SERIES(bval)) ? bval : aval; if (VAL_INDEX(val) >= VAL_TAIL(val)) return 0; return (VAL_TAIL(val) - VAL_INDEX(val)); } if (IS_INTEGER(lval)) { len = Int32(lval); val = flag ? aval : bval; } else if (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 Trap1(RE_INVALID_PART, lval); len = (REBINT)VAL_INDEX(lval) - (REBINT)VAL_INDEX(val); } if (!val) val = aval; // Restrict length to the size available: if (len >= 0) { maxlen = (REBINT)VAL_LEN(val); if (len > maxlen) len = maxlen; } else { len = -len; if (len > (REBINT)VAL_INDEX(val)) len = (REBINT)VAL_INDEX(val); VAL_INDEX(val) -= (REBCNT)len; // if ((-len) > (REBINT)VAL_INDEX(val)) len = -(REBINT)VAL_INDEX(val); } return len; }
// // 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; }
*/ static int Loop_All(struct Reb_Call *call_, REBINT mode) /* ** 0: forall ** 1: forskip ** ***********************************************************************/ { REBVAL *var; REBSER *body; REBCNT bodi; REBSER *dat; REBINT idx; REBINT inc = 1; REBCNT type; REBVAL *ds; var = GET_MUTABLE_VAR(D_ARG(1)); if (IS_NONE(var)) return R_NONE; // Save the starting var value: *D_ARG(1) = *var; SET_NONE(D_OUT); if (mode == 1) inc = Int32(D_ARG(2)); type = VAL_TYPE(var); body = VAL_SERIES(D_ARG(mode+2)); bodi = VAL_INDEX(D_ARG(mode+2)); // Starting location when past end with negative skip: if (inc < 0 && VAL_INDEX(var) >= VAL_TAIL(var)) { VAL_INDEX(var) = VAL_TAIL(var) + inc; } // NOTE: This math only works for index in positive ranges! if (ANY_SERIES(var)) { while (TRUE) { dat = VAL_SERIES(var); idx = VAL_INDEX(var); if (idx < 0) break; if (idx >= cast(REBINT, SERIES_TAIL(dat))) { if (inc >= 0) break; idx = SERIES_TAIL(dat) + inc; // negative if (idx < 0) break; VAL_INDEX(var) = idx; } if (!DO_BLOCK(D_OUT, body, bodi)) { // Break, throw, continue, error. if (Check_Error(D_OUT) >= 0) { break; } } if (VAL_TYPE(var) != type) Trap_Arg_DEAD_END(var); VAL_INDEX(var) += inc; } } else Trap_Arg_DEAD_END(var); // !!!!! ???? allowed to write VAR???? *var = *D_ARG(1); return R_OUT; }
// // 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; }
*/ 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; }
*/ static int Loop_All(REBVAL *ds, REBINT mode) /* ** 0: forall ** 1: forskip ** ***********************************************************************/ { REBVAL *var; REBSER *body; REBCNT bodi; REBSER *dat; REBINT idx; REBINT inc = 1; REBCNT type; var = Get_Var(D_ARG(1)); if (IS_NONE(var)) return R_NONE; // Save the starting var value: *D_ARG(1) = *var; SET_NONE(D_RET); if (mode == 1) inc = Int32(D_ARG(2)); type = VAL_TYPE(var); body = VAL_SERIES(D_ARG(mode+2)); bodi = VAL_INDEX(D_ARG(mode+2)); // Starting location when past end with negative skip: if (inc < 0 && VAL_INDEX(var) >= (REBINT)VAL_TAIL(var)) { VAL_INDEX(var) = (REBINT)VAL_TAIL(var) + inc; } // NOTE: This math only works for index in positive ranges! if (ANY_SERIES(var)) { while (TRUE) { dat = VAL_SERIES(var); idx = (REBINT)VAL_INDEX(var); if (idx < 0) break; if (idx >= (REBINT)SERIES_TAIL(dat)) { if (inc >= 0) break; idx = (REBINT)SERIES_TAIL(dat) + inc; // negative if (idx < 0) break; VAL_INDEX(var) = idx; } ds = Do_Blk(body, bodi); // (may move stack) if (THROWN(ds)) { // Break, throw, continue, error. if (Check_Error(ds) >= 0) { *DS_RETURN = *DS_NEXT; break; } } *DS_RETURN = *ds; if (VAL_TYPE(var) != type) Trap_Arg(var); VAL_INDEX(var) += inc; } } else Trap_Arg(var); // !!!!! ???? allowed to write VAR???? *var = *DS_ARG(1); return R_RET; }
*/ static int Loop_All(struct Reb_Call *call_, REBINT mode) /* ** 0: forall ** 1: forskip ** ***********************************************************************/ { REBVAL *var; REBSER *body; REBCNT bodi; REBSER *dat; REBINT idx; REBINT inc = 1; REBCNT type; REBVAL *ds; var = GET_MUTABLE_VAR(D_ARG(1)); if (IS_NONE(var)) return R_NONE; // Save the starting var value: *D_ARG(1) = *var; SET_NONE(D_OUT); if (mode == 1) inc = Int32(D_ARG(2)); type = VAL_TYPE(var); body = VAL_SERIES(D_ARG(mode+2)); bodi = VAL_INDEX(D_ARG(mode+2)); // Starting location when past end with negative skip: if (inc < 0 && VAL_INDEX(var) >= VAL_TAIL(var)) { VAL_INDEX(var) = VAL_TAIL(var) + inc; } // NOTE: This math only works for index in positive ranges! if (ANY_SERIES(var)) { while (TRUE) { dat = VAL_SERIES(var); idx = VAL_INDEX(var); if (idx < 0) break; if (idx >= cast(REBINT, SERIES_TAIL(dat))) { if (inc >= 0) break; idx = SERIES_TAIL(dat) + inc; // negative if (idx < 0) break; VAL_INDEX(var) = idx; } if (Do_Block_Throws(D_OUT, body, bodi)) { if (Loop_Throw_Should_Return(D_OUT)) { // return value is set, but we still need to assign var break; } } if (VAL_TYPE(var) != type) raise Error_Invalid_Arg(var); VAL_INDEX(var) += inc; } } else raise Error_Invalid_Arg(var); // !!!!! ???? allowed to write VAR???? *var = *D_ARG(1); return R_OUT; }