*/ REBINT PD_File(REBPVS *pvs) /* ***********************************************************************/ { REBSER *ser; REB_MOLD mo = {0}; REBCNT n; REBUNI c; REBSER *arg; if (pvs->setval) return PE_BAD_SET; ser = Copy_Series_Value(pvs->value); n = SERIES_TAIL(ser); if (n > 0) c = GET_ANY_CHAR(ser, n-1); if (n == 0 || c != '/') Append_Byte(ser, '/'); if (ANY_STR(pvs->select)) arg = VAL_SERIES(pvs->select); else { Reset_Mold(&mo); Mold_Value(&mo, pvs->select, 0); arg = mo.series; } c = GET_ANY_CHAR(arg, 0); n = (c == '/' || c == '\\') ? 1 : 0; Append_String(ser, arg, n, arg->tail-n); Set_Series(VAL_TYPE(pvs->value), pvs->store, ser); return PE_USE; }
STOID Mold_Error(REBVAL *value, REB_MOLD *mold, REBFLG molded) { ERROR_OBJ *err; REBVAL *msg; // Error message block // Protect against recursion. !!!! if (molded) { if (VAL_OBJ_FRAME(value) && VAL_ERR_NUM(value) >= RE_NOTE && VAL_ERR_OBJECT(value)) Mold_Object(value, mold); else { // Happens if throw or return is molded. // make error! 0-3 Pre_Mold(value, mold); Append_Int(mold->series, VAL_ERR_NUM(value)); End_Mold(mold); } return; } // If it is an unprocessed BREAK, THROW, CONTINUE, RETURN: if (VAL_ERR_NUM(value) < RE_NOTE || !VAL_ERR_OBJECT(value)) { VAL_ERR_OBJECT(value) = Make_Error(VAL_ERR_NUM(value), value, 0, 0); // spoofs field } err = VAL_ERR_VALUES(value); // Form: ** <type> Error: Emit(mold, "** WB", &err->type, RS_ERRS+0); // Append: error message ARG1, ARG2, etc. msg = Find_Error_Info(err, 0); if (msg) { if (!IS_BLOCK(msg)) Mold_Value(mold, msg, 0); else { //start = DSP + 1; //Reduce_In_Frame(VAL_ERR_OBJECT(value), VAL_BLK_DATA(msg)); //SERIES_TAIL(DS_Series) = DSP + 1; //Form_Block_Series(DS_Series, start, mold, 0); Form_Block_Series(VAL_SERIES(msg), 0, mold, VAL_ERR_OBJECT(value)); } } else Append_Boot_Str(mold->series, RS_ERRS+1); Append_Byte(mold->series, '\n'); // Form: ** Where: function value = &err->where; if (VAL_TYPE(value) > REB_NONE) { Append_Boot_Str(mold->series, RS_ERRS+2); Mold_Value(mold, value, 0); Append_Byte(mold->series, '\n'); } // Form: ** Near: location value = &err->nearest; if (VAL_TYPE(value) > REB_NONE) { Append_Boot_Str(mold->series, RS_ERRS+3); if (IS_STRING(value)) // special case: source file line number Append_String(mold->series, VAL_SERIES(value), 0, VAL_TAIL(value)); else if (IS_BLOCK(value)) Mold_Simple_Block(mold, VAL_BLK_DATA(value), 60); Append_Byte(mold->series, '\n'); } }
// // 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; }
*/ 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; }
// // 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 void Mold_Error(const REBVAL *value, REB_MOLD *mold, REBFLG molded) { ERROR_OBJ *err; REBVAL *msg; // Error message block REBSER *frame; // Protect against recursion. !!!! if (molded) { if (VAL_OBJ_FRAME(value) && VAL_ERR_NUM(value) >= RE_NOTE && VAL_ERR_OBJECT(value)) Mold_Object(value, mold); else { // Happens if throw or return is molded. // make error! 0-3 Pre_Mold(value, mold); Append_Int(mold->series, VAL_ERR_NUM(value)); End_Mold(mold); } return; } if (VAL_ERR_NUM(value) < RE_THROW_MAX) { // Though we generally do not make error objects for THROWN() errors, // we do make one here for the purposes of molding. frame = Make_Error(VAL_ERR_NUM(value), value, 0, 0); err = ERR_VALUES(frame); } else { frame = VAL_ERR_OBJECT(value); err = VAL_ERR_VALUES(value); } // Form: ** <type> Error: Emit(mold, "** WB", &err->type, RS_ERRS+0); // Append: error message ARG1, ARG2, etc. msg = Find_Error_Info(err, 0); if (msg) { if (!IS_BLOCK(msg)) Mold_Value(mold, msg, 0); else { //start = DSP + 1; //Reduce_In_Frame(frame, VAL_BLK_DATA(msg)); //SERIES_TAIL(DS_Series) = DSP + 1; //Form_Block_Series(DS_Series, start, mold, 0); Form_Block_Series(VAL_SERIES(msg), 0, mold, frame); } } else Append_Boot_Str(mold->series, RS_ERRS+1); Append_Byte(mold->series, '\n'); // Form: ** Where: function value = &err->where; if (VAL_TYPE(value) > REB_NONE) { Append_Boot_Str(mold->series, RS_ERRS+2); Mold_Value(mold, value, 0); Append_Byte(mold->series, '\n'); } // Form: ** Near: location value = &err->nearest; if (VAL_TYPE(value) > REB_NONE) { Append_Boot_Str(mold->series, RS_ERRS+3); if (IS_STRING(value)) // special case: source file line number Append_String(mold->series, VAL_SERIES(value), 0, VAL_TAIL(value)); else if (IS_BLOCK(value)) Mold_Simple_Block(mold, VAL_BLK_DATA(value), 60); Append_Byte(mold->series, '\n'); } }