// // MAKE_Function: C // // For REB_FUNCTION and "make spec", there is a function spec block and then // a block of Rebol code implementing that function. In that case we expect // that `def` should be: // // [[spec] [body]] // // With REB_COMMAND, the code is implemented via a C DLL, under a system of // APIs that pre-date Rebol's open sourcing and hence Ren/C: // // [[spec] extension command-num] // // See notes in Make_Command() regarding that mechanism and meaning. // void MAKE_Function(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) { assert(kind == REB_FUNCTION); if ( !IS_BLOCK(arg) || VAL_LEN_AT(arg) != 2 || !IS_BLOCK(VAL_ARRAY_AT(arg)) || !IS_BLOCK(VAL_ARRAY_AT(arg) + 1) ){ fail (Error_Bad_Make(kind, arg)); } REBVAL spec; COPY_VALUE(&spec, VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg)); REBVAL body; COPY_VALUE(&body, VAL_ARRAY_AT(arg) + 1, VAL_SPECIFIER(arg)); // Spec-constructed functions do *not* have definitional returns // added automatically. They are part of the generators. So the // behavior comes--as with any other generator--from the projected // code (though round-tripping it via text is not possible in // general in any case due to loss of bindings.) // REBFUN *fun = Make_Interpreted_Function_May_Fail( &spec, &body, MKF_ANY_VALUE ); *out = *FUNC_VALUE(fun); }
// // 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)); }
// // MT_Pair: C // REBFLG MT_Pair(REBVAL *out, REBVAL *data, enum Reb_Kind type) { REBD32 x; REBD32 y; if (IS_PAIR(data)) { *out = *data; return TRUE; } if (!IS_BLOCK(data)) return FALSE; data = VAL_ARRAY_AT(data); if (IS_INTEGER(data)) x = (REBD32)VAL_INT64(data); else if (IS_DECIMAL(data)) x = (REBD32)VAL_DECIMAL(data); else return FALSE; data++; if (IS_END(data)) return FALSE; if (IS_INTEGER(data)) y = (REBD32)VAL_INT64(data); else if (IS_DECIMAL(data)) y = (REBD32)VAL_DECIMAL(data); else return FALSE; VAL_RESET_HEADER(out, REB_PAIR); VAL_PAIR_X(out) = x; VAL_PAIR_Y(out) = y; return TRUE; }
// // Is_Type_Of: C // // Types can be: word or block. Each element must be either // a datatype or a typeset. // static REBOOL Is_Type_Of(const REBVAL *value, REBVAL *types) { const REBVAL *val; val = IS_WORD(types) ? GET_OPT_VAR_MAY_FAIL(types) : types; if (IS_DATATYPE(val)) return LOGICAL(VAL_TYPE_KIND(val) == VAL_TYPE(value)); if (IS_TYPESET(val)) return LOGICAL(TYPE_CHECK(val, VAL_TYPE(value))); if (IS_BLOCK(val)) { for (types = VAL_ARRAY_AT(val); NOT_END(types); types++) { val = IS_WORD(types) ? GET_OPT_VAR_MAY_FAIL(types) : types; if (IS_DATATYPE(val)) { if (VAL_TYPE_KIND(val) == VAL_TYPE(value)) return TRUE; } else if (IS_TYPESET(val)) { if (TYPE_CHECK(val, VAL_TYPE(value))) return TRUE; } else fail (Error(RE_INVALID_TYPE, Type_Of(val))); } return FALSE; } fail (Error_Invalid_Arg(types)); }
// // TO_Vector: C // void TO_Vector(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) { if (IS_BLOCK(arg)) { if (Make_Vector_Spec(VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg), out)) return; } fail (Error_Bad_Make(kind, arg)); }
// // 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; }
// // Bind_Relative_Inner_Loop: C // // Recursive function for relative function word binding. Returns TRUE if // any relative bindings were made. // static void Bind_Relative_Inner_Loop( struct Reb_Binder *binder, RELVAL *head, REBARR *paramlist, REBU64 bind_types ) { RELVAL *value = head; for (; NOT_END(value); value++) { REBU64 type_bit = FLAGIT_KIND(VAL_TYPE(value)); // The two-pass copy-and-then-bind should have gotten rid of all the // relative values to other functions during the copy. // // !!! Long term, in a single pass copy, this would have to deal // with relative values and run them through the specification // process if they were not just getting overwritten. // assert(!IS_RELATIVE(value)); if (type_bit & bind_types) { REBINT n = Try_Get_Binder_Index(binder, VAL_WORD_CANON(value)); if (n != 0) { // // Word's canon symbol is in frame. Relatively bind it. // (clear out existing binding flags first). // UNBIND_WORD(value); SET_VAL_FLAGS(value, WORD_FLAG_BOUND | VALUE_FLAG_RELATIVE); INIT_WORD_FUNC(value, AS_FUNC(paramlist)); // incomplete func INIT_WORD_INDEX(value, n); } } else if (ANY_ARRAY(value)) { Bind_Relative_Inner_Loop( binder, VAL_ARRAY_AT(value), paramlist, bind_types ); // Set the bits in the ANY-ARRAY! REBVAL to indicate that it is // relative to the function. // // !!! Technically speaking it is not necessary for an array to // be marked relative if it doesn't contain any relative words // under it. However, for uniformity in the near term, it's // easiest to debug if there is a clear mark on arrays that are // part of a deep copy of a function body either way. // SET_VAL_FLAG(value, VALUE_FLAG_RELATIVE); INIT_RELATIVE(value, AS_FUNC(paramlist)); // incomplete func } } }
// // Cmp_Array: C // // Compare two arrays and return the difference of the first // non-matching value. // REBINT Cmp_Array(const RELVAL *sval, const RELVAL *tval, REBOOL is_case) { RELVAL *s = VAL_ARRAY_AT(sval); RELVAL *t = VAL_ARRAY_AT(tval); REBINT diff; if (C_STACK_OVERFLOWING(&s)) Trap_Stack_Overflow(); if ((VAL_SERIES(sval)==VAL_SERIES(tval))&& (VAL_INDEX(sval)==VAL_INDEX(tval))) return 0; if (IS_END(s) || IS_END(t)) goto diff_of_ends; while ( (VAL_TYPE(s) == VAL_TYPE(t) || (ANY_NUMBER(s) && ANY_NUMBER(t))) ) { if ((diff = Cmp_Value(s, t, is_case)) != 0) return diff; s++; t++; if (IS_END(s) || IS_END(t)) goto diff_of_ends; } return VAL_TYPE(s) - VAL_TYPE(t); diff_of_ends: // Treat end as if it were a REB_xxx type of 0, so all other types would // compare larger than it. // if (IS_END(s)) { if (IS_END(t)) return 0; return -1; } return 1; }
// // Rebind_Values_Deep: C // // Rebind all words that reference src target to dst target. // Rebind is always deep. // void Rebind_Values_Deep( REBCTX *src, REBCTX *dst, RELVAL *head, struct Reb_Binder *opt_binder ) { RELVAL *value = head; for (; NOT_END(value); value++) { if (ANY_ARRAY(value)) { Rebind_Values_Deep(src, dst, VAL_ARRAY_AT(value), opt_binder); } else if ( ANY_WORD(value) && GET_VAL_FLAG(value, WORD_FLAG_BOUND) && !GET_VAL_FLAG(value, VALUE_FLAG_RELATIVE) && VAL_WORD_CONTEXT(KNOWN(value)) == src ) { INIT_WORD_CONTEXT(value, dst); if (opt_binder != NULL) { INIT_WORD_INDEX( value, Try_Get_Binder_Index(opt_binder, VAL_WORD_CANON(value)) ); } } else if (IS_FUNCTION(value) && IS_FUNCTION_INTERPRETED(value)) { // // !!! Extremely questionable feature--walking into function // bodies and changing them. This R3-Alpha concept was largely // broken (didn't work for closures) and created a lot of extra // garbage (inheriting an object's methods meant making deep // copies of all that object's method bodies...each time). // Ren-C has a different idea in the works. // Rebind_Values_Deep( src, dst, VAL_FUNC_BODY(value), opt_binder ); } } }
// // Unbind_Values_Core: C // // Unbind words in a block, optionally unbinding those which are // bound to a particular target (if target is NULL, then all // words will be unbound regardless of their VAL_WORD_CONTEXT). // void Unbind_Values_Core(RELVAL *head, REBCTX *context, REBOOL deep) { RELVAL *value = head; for (; NOT_END(value); value++) { if ( ANY_WORD(value) && ( !context || ( IS_WORD_BOUND(value) && !IS_RELATIVE(value) && VAL_WORD_CONTEXT(KNOWN(value)) == context ) ) ) { UNBIND_WORD(value); } else if (ANY_ARRAY(value) && deep) Unbind_Values_Core(VAL_ARRAY_AT(value), context, TRUE); } }
void Set_Vector_Row(REBSER *ser, REBVAL *blk) { REBCNT idx = VAL_INDEX(blk); REBCNT len = VAL_LEN_AT(blk); RELVAL *val; REBCNT n = 0; REBCNT bits = VECT_TYPE(ser); REBI64 i = 0; REBDEC f = 0; if (IS_BLOCK(blk)) { val = VAL_ARRAY_AT(blk); for (; NOT_END(val); val++) { if (IS_INTEGER(val)) { i = VAL_INT64(val); if (bits > VTUI64) f = (REBDEC)(i); } else if (IS_DECIMAL(val)) { f = VAL_DECIMAL(val); if (bits <= VTUI64) i = (REBINT)(f); } else fail (Error_Invalid_Arg_Core(val, VAL_SPECIFIER(blk))); //if (n >= ser->tail) Expand_Vector(ser); set_vect(bits, SER_DATA_RAW(ser), n++, i, f); } } else { REBYTE *data = VAL_BIN_AT(blk); for (; len > 0; len--, idx++) { set_vect( bits, SER_DATA_RAW(ser), n++, cast(REBI64, data[idx]), f ); } } }
// // MAKE_Tuple: C // REB_R MAKE_Tuple( REBVAL *out, enum Reb_Kind kind, const REBVAL *opt_parent, const REBVAL *arg ){ assert(kind == REB_TUPLE); if (opt_parent) fail (Error_Bad_Make_Parent(kind, opt_parent)); if (IS_TUPLE(arg)) return Move_Value(out, arg); RESET_CELL(out, REB_TUPLE, CELL_MASK_NONE); REBYTE *vp = VAL_TUPLE(out); // !!! Net lookup parses IP addresses out of `tcp://93.184.216.34` or // similar URL!s. In Rebol3 these captures come back the same type // as the input instead of as STRING!, which was a latent bug in the // network code of the 12-Dec-2012 release: // // https://github.com/rebol/rebol/blob/master/src/mezz/sys-ports.r#L110 // // All attempts to convert a URL!-flavored IP address failed. Taking // URL! here fixes it, though there are still open questions. // if (IS_TEXT(arg) or IS_URL(arg)) { REBSIZ size; const REBYTE *bp = Analyze_String_For_Scan(&size, arg, MAX_SCAN_TUPLE); if (Scan_Tuple(out, bp, size) == nullptr) fail (arg); return out; } if (ANY_ARRAY(arg)) { REBCNT len = 0; REBINT n; RELVAL *item = VAL_ARRAY_AT(arg); for (; NOT_END(item); ++item, ++vp, ++len) { if (len >= MAX_TUPLE) goto bad_make; if (IS_INTEGER(item)) { n = Int32(item); } else if (IS_CHAR(item)) { n = VAL_CHAR(item); } else goto bad_make; if (n > 255 || n < 0) goto bad_make; *vp = n; } VAL_TUPLE_LEN(out) = len; for (; len < MAX_TUPLE; len++) *vp++ = 0; return out; } REBCNT alen; if (IS_ISSUE(arg)) { REBSTR *spelling = VAL_STRING(arg); const REBYTE *ap = STR_HEAD(spelling); size_t size = STR_SIZE(spelling); // UTF-8 len if (size & 1) fail (arg); // must have even # of chars size /= 2; if (size > MAX_TUPLE) fail (arg); // valid even for UTF-8 VAL_TUPLE_LEN(out) = size; for (alen = 0; alen < size; alen++) { REBYTE decoded; if ((ap = Scan_Hex2(&decoded, ap)) == NULL) fail (arg); *vp++ = decoded; } } else if (IS_BINARY(arg)) { REBYTE *ap = VAL_BIN_AT(arg); REBCNT len = VAL_LEN_AT(arg); if (len > MAX_TUPLE) len = MAX_TUPLE; VAL_TUPLE_LEN(out) = len; for (alen = 0; alen < len; alen++) *vp++ = *ap++; } else fail (arg); for (; alen < MAX_TUPLE; alen++) *vp++ = 0; return out; bad_make: fail (Error_Bad_Make(REB_TUPLE, arg)); }
// // Modify_Array: C // // Returns new dst_idx // REBCNT Modify_Array( REBCNT action, // INSERT, APPEND, CHANGE REBARR *dst_arr, // target REBCNT dst_idx, // position const REBVAL *src_val, // source REBCNT flags, // AN_ONLY, AN_PART REBINT dst_len, // length to remove REBINT dups // dup count ) { REBCNT tail = ARR_LEN(dst_arr); REBINT ilen = 1; // length to be inserted const RELVAL *src_rel; REBCTX *specifier; if (IS_VOID(src_val) || dups < 0) { // If they are effectively asking for "no action" then all we have // to do is return the natural index result for the operation. // (APPEND will return 0, insert the tail of the insertion...so index) return (action == SYM_APPEND) ? 0 : dst_idx; } if (action == SYM_APPEND || dst_idx > tail) dst_idx = tail; // Check /PART, compute LEN: if (!GET_FLAG(flags, AN_ONLY) && ANY_ARRAY(src_val)) { // Adjust length of insertion if changing /PART: if (action != SYM_CHANGE && GET_FLAG(flags, AN_PART)) ilen = dst_len; else ilen = VAL_LEN_AT(src_val); // Are we modifying ourselves? If so, copy src_val block first: if (dst_arr == VAL_ARRAY(src_val)) { REBARR *copy = Copy_Array_At_Shallow( VAL_ARRAY(src_val), VAL_INDEX(src_val), VAL_SPECIFIER(src_val) ); MANAGE_ARRAY(copy); // !!! Review: worth it to not manage and free? src_rel = ARR_HEAD(copy); specifier = SPECIFIED; // copy already specified it } else { src_rel = VAL_ARRAY_AT(src_val); // skips by VAL_INDEX values specifier = VAL_SPECIFIER(src_val); } } else { // use passed in RELVAL and specifier src_rel = src_val; specifier = SPECIFIED; // it's a REBVAL, not a RELVAL, so specified } REBINT size = dups * ilen; // total to insert if (action != SYM_CHANGE) { // Always expand dst_arr for INSERT and APPEND actions: Expand_Series(ARR_SERIES(dst_arr), dst_idx, size); } else { if (size > dst_len) Expand_Series(ARR_SERIES(dst_arr), dst_idx, size-dst_len); else if (size < dst_len && GET_FLAG(flags, AN_PART)) Remove_Series(ARR_SERIES(dst_arr), dst_idx, dst_len-size); else if (size + dst_idx > tail) { EXPAND_SERIES_TAIL(ARR_SERIES(dst_arr), size - (tail - dst_idx)); } } tail = (action == SYM_APPEND) ? 0 : size + dst_idx; #if !defined(NDEBUG) if (IS_ARRAY_MANAGED(dst_arr)) { REBINT i; for (i = 0; i < ilen; ++i) ASSERT_VALUE_MANAGED(&src_rel[i]); } #endif for (; dups > 0; dups--) { REBINT index = 0; for (; index < ilen; ++index, ++dst_idx) { COPY_VALUE( SINK(ARR_HEAD(dst_arr) + dst_idx), src_rel + index, specifier ); } } TERM_ARRAY_LEN(dst_arr, ARR_LEN(dst_arr)); ASSERT_ARRAY(dst_arr); return tail; }
// // Bind_Values_Inner_Loop: C // // Bind_Values_Core() sets up the binding table and then calls // this recursive routine to do the actual binding. // static void Bind_Values_Inner_Loop( struct Reb_Binder *binder, RELVAL *head, REBCTX *context, REBU64 bind_types, // !!! REVIEW: force word types low enough for 32-bit? REBU64 add_midstream_types, REBFLGS flags ) { RELVAL *value = head; for (; NOT_END(value); value++) { REBU64 type_bit = FLAGIT_KIND(VAL_TYPE(value)); if (type_bit & bind_types) { REBSTR *canon = VAL_WORD_CANON(value); REBCNT n = Try_Get_Binder_Index(binder, canon); if (n != 0) { assert(n <= CTX_LEN(context)); // We're overwriting any previous binding, which may have // been relative. // CLEAR_VAL_FLAG(value, VALUE_FLAG_RELATIVE); SET_VAL_FLAG(value, WORD_FLAG_BOUND); INIT_WORD_CONTEXT(value, context); INIT_WORD_INDEX(value, n); } else if (type_bit & add_midstream_types) { // // Word is not in context, so add it if option is specified // Expand_Context(context, 1); Append_Context(context, value, 0); Add_Binder_Index(binder, canon, VAL_WORD_INDEX(value)); } } else if (ANY_ARRAY(value) && (flags & BIND_DEEP)) { Bind_Values_Inner_Loop( binder, VAL_ARRAY_AT(value), context, bind_types, add_midstream_types, flags ); } else if ( IS_FUNCTION(value) && IS_FUNCTION_INTERPRETED(value) && (flags & BIND_FUNC) ) { // !!! Likely-to-be deprecated functionality--rebinding inside the // content of an already formed function. :-/ // Bind_Values_Inner_Loop( binder, VAL_FUNC_BODY(value), context, bind_types, add_midstream_types, flags ); } } }
// // MAKE_Tuple: C // void MAKE_Tuple(REBVAL *out, enum Reb_Kind type, const REBVAL *arg) { if (IS_TUPLE(arg)) { *out = *arg; return; } VAL_RESET_HEADER(out, REB_TUPLE); REBYTE *vp = VAL_TUPLE(out); // !!! Net lookup parses IP addresses out of `tcp://93.184.216.34` or // similar URL!s. In Rebol3 these captures come back the same type // as the input instead of as STRING!, which was a latent bug in the // network code of the 12-Dec-2012 release: // // https://github.com/rebol/rebol/blob/master/src/mezz/sys-ports.r#L110 // // All attempts to convert a URL!-flavored IP address failed. Taking // URL! here fixes it, though there are still open questions. // if (IS_STRING(arg) || IS_URL(arg)) { REBCNT len; REBYTE *ap = Temp_Byte_Chars_May_Fail(arg, MAX_SCAN_TUPLE, &len, FALSE); if (Scan_Tuple(ap, len, out)) return; goto bad_arg; } if (ANY_ARRAY(arg)) { REBCNT len = 0; REBINT n; RELVAL *item = VAL_ARRAY_AT(arg); for (; NOT_END(item); ++item, ++vp, ++len) { if (len >= MAX_TUPLE) goto bad_make; if (IS_INTEGER(item)) { n = Int32(item); } else if (IS_CHAR(item)) { n = VAL_CHAR(item); } else goto bad_make; if (n > 255 || n < 0) goto bad_make; *vp = n; } VAL_TUPLE_LEN(out) = len; for (; len < MAX_TUPLE; len++) *vp++ = 0; return; } REBCNT alen; if (IS_ISSUE(arg)) { REBUNI c; const REBYTE *ap = VAL_WORD_HEAD(arg); REBCNT len = LEN_BYTES(ap); // UTF-8 len if (len & 1) goto bad_arg; // must have even # of chars len /= 2; if (len > MAX_TUPLE) goto bad_arg; // valid even for UTF-8 VAL_TUPLE_LEN(out) = len; for (alen = 0; alen < len; alen++) { const REBOOL unicode = FALSE; if (!Scan_Hex2(ap, &c, unicode)) goto bad_arg; *vp++ = cast(REBYTE, c); ap += 2; } } else if (IS_BINARY(arg)) { REBYTE *ap = VAL_BIN_AT(arg); REBCNT len = VAL_LEN_AT(arg); if (len > MAX_TUPLE) len = MAX_TUPLE; VAL_TUPLE_LEN(out) = len; for (alen = 0; alen < len; alen++) *vp++ = *ap++; } else goto bad_arg; for (; alen < MAX_TUPLE; alen++) *vp++ = 0; return; bad_arg: fail (Error_Invalid_Arg(arg)); bad_make: fail (Error_Bad_Make(REB_TUPLE, arg)); }
// // Do_Path_Throws: C // // Evaluate an ANY_PATH! REBVAL, starting from the index position of that // path value and continuing to the end. // // The evaluator may throw because GROUP! is evaluated, e.g. `foo/(throw 1020)` // // If label_sym is passed in as being non-null, then the caller is implying // readiness to process a path which may be a function with refinements. // These refinements will be left in order on the data stack in the case // that `out` comes back as IS_FUNCTION(). // // If `opt_setval` is given, the path operation will be done as a "SET-PATH!" // if the path evaluation did not throw or error. HOWEVER the set value // is NOT put into `out`. This provides more flexibility on performance in // the evaluator, which may already have the `val` where it wants it, and // so the extra assignment would just be overhead. // // !!! Path evaluation is one of the parts of R3-Alpha that has not been // vetted very heavily by Ren-C, and needs a review and overhaul. // REBOOL Do_Path_Throws( REBVAL *out, REBSYM *label_sym, const REBVAL *path, REBVAL *opt_setval ) { REBPVS pvs; REBDSP dsp_orig = DSP; assert(ANY_PATH(path)); // !!! There is a bug in the dispatch such that if you are running a // set path, it does not always assign the output, because it "thinks you // aren't going to look at it". This presumably originated from before // parens were allowed in paths, and neglects cases like: // // foo/(throw 1020): value // // We always have to check to see if a throw occurred. Until this is // streamlined, we have to at minimum set it to something that is *not* // thrown so that we aren't testing uninitialized memory. A safe trash // will do, which is unset in release builds. // if (opt_setval) SET_TRASH_SAFE(out); // None of the values passed in can live on the data stack, because // they might be relocated during the path evaluation process. // assert(!IN_DATA_STACK(out)); assert(!IN_DATA_STACK(path)); assert(!opt_setval || !IN_DATA_STACK(opt_setval)); // Not currently robust for reusing passed in path or value as the output assert(out != path && out != opt_setval); assert(!opt_setval || !THROWN(opt_setval)); // Initialize REBPVS -- see notes in %sys-do.h // pvs.opt_setval = opt_setval; pvs.store = out; pvs.orig = path; pvs.item = VAL_ARRAY_AT(pvs.orig); // may not be starting at head of PATH! // Seed the path evaluation process by looking up the first item (to // get a datatype to dispatch on for the later path items) // if (IS_WORD(pvs.item)) { pvs.value = GET_MUTABLE_VAR_MAY_FAIL(pvs.item); if (IS_UNSET(pvs.value)) fail (Error(RE_NO_VALUE, pvs.item)); } else { // !!! Ideally there would be some way to protect pvs.value during // successive path dispatches to make sure it does not get written. // This is semi-dangerously giving pvs.value a reference into the // input path, which should not be modified! pvs.value = VAL_ARRAY_AT(pvs.orig); } // Start evaluation of path: if (IS_END(pvs.item + 1)) { // If it was a single element path, return the value rather than // try to dispatch it (would cause a crash at time of writing) // // !!! Is this the desired behavior, or should it be an error? } else if (Path_Dispatch[VAL_TYPE_0(pvs.value)]) { REBOOL threw = Next_Path_Throws(&pvs); // !!! See comments about why the initialization of out is necessary. // Without it this assertion can change on some things: // // t: now // t/time: 10:20:03 // // (It thinks pvs.value has its THROWN bit set when it completed // successfully. It was a PE_USE_STORE case where pvs.value was reset to // pvs.store, and pvs.store has its thrown bit set. Valgrind does not // catch any uninitialized variables.) // // There are other cases that do trip valgrind when omitting the // initialization, though not as clearly reproducible. // assert(threw == THROWN(pvs.value)); if (threw) return TRUE; // Check for errors: if (NOT_END(pvs.item + 1) && !IS_FUNCTION(pvs.value)) { // Only function refinements should get by this line: fail (Error(RE_INVALID_PATH, pvs.orig, pvs.item)); } } else if (!IS_FUNCTION(pvs.value)) fail (Error(RE_BAD_PATH_TYPE, pvs.orig, Type_Of(pvs.value))); if (opt_setval) { // If SET then we don't return anything assert(IS_END(pvs.item) + 1); return FALSE; } // If storage was not used, then copy final value back to it: if (pvs.value != pvs.store) *pvs.store = *pvs.value; assert(!THROWN(out)); // Return 0 if not function or is :path/word... if (!IS_FUNCTION(pvs.value)) { assert(IS_END(pvs.item) + 1); return FALSE; } if (label_sym) { REBVAL refinement; VAL_INIT_WRITABLE_DEBUG(&refinement); // When a function is hit, path processing stops as soon as the // processed sub-path resolves to a function. The path is still sitting // on the position of the last component of that sub-path. Usually, // this last component in the sub-path is a word naming the function. // if (IS_WORD(pvs.item)) { *label_sym = VAL_WORD_SYM(pvs.item); } else { // In rarer cases, the final component (completing the sub-path to // the function to call) is not a word. Such as when you use a path // to pick by index out of a block of functions: // // functions: reduce [:add :subtract] // functions/1 10 20 // // Or when you have an immediate function value in a path with a // refinement. Tricky to make, but possible: // // do reduce [ // to-path reduce [:append 'only] [a] [b] // ] // // !!! When a function was not invoked through looking up a word // (or a word in a path) to use as a label, there were once three // different alternate labels used. One was SYM__APPLY_, another // was ROOT_NONAME, and another was to be the type of the function // being executed. None are fantastic, we do the type for now. *label_sym = SYM_FROM_KIND(VAL_TYPE(pvs.value)); } // Move on to the refinements (if any) ++pvs.item; // !!! Currently, the mainline path evaluation "punts" on refinements. // When it finds a function, it stops the path evaluation and leaves // the position pvs.path before the list of refinements. // // A more elegant solution would be able to process and notice (for // instance) that `:APPEND/ONLY` should yield a function value that // has been specialized with a refinement. Path chaining should thus // be able to effectively do this and give the refined function object // back to the evaluator or other client. // // If a label_sym is passed in, we recognize that a function dispatch // is going to be happening. We do not want to pay to generate the // new series that would be needed to make a temporary function that // will be invoked and immediately GC'd So we gather the refinements // on the data stack. // // This code simulates that path-processing-to-data-stack, but it // should really be something in dispatch iself. In any case, we put // refinements on the data stack...and caller knows refinements are // from dsp_orig to DSP (thanks to accounting, all other operations // should balance!) for (; NOT_END(pvs.item); ++pvs.item) { // "the refinements" if (IS_NONE(pvs.item)) continue; if (IS_GROUP(pvs.item)) { // Note it is not legal to use the data stack directly as the // output location for a DO (might be resized) if (DO_VAL_ARRAY_AT_THROWS(&refinement, pvs.item)) { *out = refinement; DS_DROP_TO(dsp_orig); return TRUE; } if (IS_NONE(&refinement)) continue; DS_PUSH(&refinement); } else if (IS_GET_WORD(pvs.item)) { DS_PUSH_TRASH; *DS_TOP = *GET_OPT_VAR_MAY_FAIL(pvs.item); if (IS_NONE(DS_TOP)) { DS_DROP; continue; } } else DS_PUSH(pvs.item); // Whatever we were trying to use as a refinement should now be // on the top of the data stack, and only words are legal ATM // if (!IS_WORD(DS_TOP)) fail (Error(RE_BAD_REFINE, DS_TOP)); // Go ahead and canonize the word symbol so we don't have to // do it each time in order to get a case-insenstive compare // INIT_WORD_SYM(DS_TOP, SYMBOL_TO_CANON(VAL_WORD_SYM(DS_TOP))); } // To make things easier for processing, reverse the refinements on // the data stack (we needed to evaluate them in forward order). // This way we can just pop them as we go, and know if they weren't // all consumed if it doesn't get back to `dsp_orig` by the end. if (dsp_orig != DSP) { REBVAL *bottom = DS_AT(dsp_orig + 1); REBVAL *top = DS_TOP; while (top > bottom) { refinement = *bottom; *bottom = *top; *top = refinement; top--; bottom++; } } } else { // !!! Historically this just ignores a result indicating this is a // function with refinements, e.g. ':append/only'. However that // ignoring seems unwise. It should presumably create a modified // function in that case which acts as if it has the refinement. // // If the caller did not pass in a label pointer we assume they are // likely not ready to process any refinements. // if (NOT_END(pvs.item + 1)) fail (Error(RE_TOO_LONG)); // !!! Better error or add feature } return FALSE; }
// // Specialize_Action_Throws: C // // Create a new ACTION! value that uses the same implementation as another, // but just takes fewer arguments or refinements. It does this by storing a // heap-based "exemplar" FRAME! in the specialized action; this stores the // values to preload in the stack frame cells when it is invoked. // // The caller may provide information on the order in which refinements are // to be specialized, using the data stack. These refinements should be // pushed in the *reverse* order of their invocation, so append/dup/part // has /DUP at DS_TOP, and /PART under it. List stops at lowest_ordered_dsp. // bool Specialize_Action_Throws( REBVAL *out, REBVAL *specializee, REBSTR *opt_specializee_name, REBVAL *opt_def, // !!! REVIEW: binding modified directly (not copied) REBDSP lowest_ordered_dsp ){ assert(out != specializee); struct Reb_Binder binder; if (opt_def) INIT_BINDER(&binder); REBACT *unspecialized = VAL_ACTION(specializee); // This produces a context where partially specialized refinement slots // will be on the stack (including any we are adding "virtually", from // the current DSP down to the lowest_ordered_dsp). // REBCTX *exemplar = Make_Context_For_Action_Push_Partials( specializee, lowest_ordered_dsp, opt_def ? &binder : nullptr, CELL_MASK_NON_STACK ); Manage_Array(CTX_VARLIST(exemplar)); // destined to be managed, guarded if (opt_def) { // code that fills the frame...fully or partially // // Bind all the SET-WORD! in the body that match params in the frame // into the frame. This means `value: value` can very likely have // `value:` bound for assignments into the frame while `value` refers // to whatever value was in the context the specialization is running // in, but this is likely the more useful behavior. // // !!! This binds the actual arg data, not a copy of it--following // OBJECT!'s lead. However, ordinary functions make a copy of the // body they are passed before rebinding. Rethink. // See Bind_Values_Core() for explanations of how the binding works. Bind_Values_Inner_Loop( &binder, VAL_ARRAY_AT(opt_def), exemplar, FLAGIT_KIND(REB_SET_WORD), // types to bind (just set-word!) 0, // types to "add midstream" to binding as we go (nothing) BIND_DEEP ); // !!! Only one binder can be in effect, and we're calling arbitrary // code. Must clean up now vs. in loop we do at the end. :-( // RELVAL *key = CTX_KEYS_HEAD(exemplar); REBVAL *var = CTX_VARS_HEAD(exemplar); for (; NOT_END(key); ++key, ++var) { if (Is_Param_Unbindable(key)) continue; // !!! is this flag still relevant? if (Is_Param_Hidden(key)) { assert(GET_CELL_FLAG(var, ARG_MARKED_CHECKED)); continue; } if (GET_CELL_FLAG(var, ARG_MARKED_CHECKED)) continue; // may be refinement from stack, now specialized out Remove_Binder_Index(&binder, VAL_KEY_CANON(key)); } SHUTDOWN_BINDER(&binder); // Run block and ignore result (unless it is thrown) // PUSH_GC_GUARD(exemplar); bool threw = Do_Any_Array_At_Throws(out, opt_def, SPECIFIED); DROP_GC_GUARD(exemplar); if (threw) { DS_DROP_TO(lowest_ordered_dsp); return true; } } REBVAL *rootkey = CTX_ROOTKEY(exemplar); // Build up the paramlist for the specialized function on the stack. // The same walk used for that is used to link and process REB_X_PARTIAL // arguments for whether they become fully specialized or not. REBDSP dsp_paramlist = DSP; Move_Value(DS_PUSH(), ACT_ARCHETYPE(unspecialized)); REBVAL *param = rootkey + 1; REBVAL *arg = CTX_VARS_HEAD(exemplar); REBDSP ordered_dsp = lowest_ordered_dsp; for (; NOT_END(param); ++param, ++arg) { if (TYPE_CHECK(param, REB_TS_REFINEMENT)) { if (IS_NULLED(arg)) { // // A refinement that is nulled is a candidate for usage at the // callsite. Hence it must be pre-empted by our ordered // overrides. -but- the overrides only apply if their slot // wasn't filled by the user code. Yet these values we are // putting in disrupt that detection (!), so use another // flag (PUSH_PARTIAL) to reflect this state. // while (ordered_dsp != dsp_paramlist) { ++ordered_dsp; REBVAL *ordered = DS_AT(ordered_dsp); if (not IS_WORD_BOUND(ordered)) // specialize 'print/asdf fail (Error_Bad_Refine_Raw(ordered)); REBVAL *slot = CTX_VAR(exemplar, VAL_WORD_INDEX(ordered)); if ( IS_NULLED(slot) or GET_CELL_FLAG(slot, PUSH_PARTIAL) ){ // It's still partial, so set up the pre-empt. // Init_Any_Word_Bound( arg, REB_SYM_WORD, VAL_STORED_CANON(ordered), exemplar, VAL_WORD_INDEX(ordered) ); SET_CELL_FLAG(arg, PUSH_PARTIAL); goto unspecialized_arg; } // Otherwise the user filled it in, so skip to next... } goto unspecialized_arg; // ran out...no pre-empt needed } if (GET_CELL_FLAG(arg, ARG_MARKED_CHECKED)) { assert( IS_BLANK(arg) or ( IS_REFINEMENT(arg) and ( VAL_REFINEMENT_SPELLING(arg) == VAL_PARAM_SPELLING(param) ) ) ); } else Typecheck_Refinement_And_Canonize(param, arg); goto specialized_arg_no_typecheck; } switch (VAL_PARAM_CLASS(param)) { case REB_P_RETURN: case REB_P_LOCAL: assert(IS_NULLED(arg)); // no bindings, you can't set these goto unspecialized_arg; default: break; } // It's an argument, either a normal one or a refinement arg. if (not IS_NULLED(arg)) goto specialized_arg_with_check; unspecialized_arg: assert(NOT_CELL_FLAG(arg, ARG_MARKED_CHECKED)); assert( IS_NULLED(arg) or (IS_SYM_WORD(arg) and TYPE_CHECK(param, REB_TS_REFINEMENT)) ); Move_Value(DS_PUSH(), param); continue; specialized_arg_with_check: // !!! If argument was previously specialized, should have been type // checked already... don't type check again (?) // if (Is_Param_Variadic(param)) fail ("Cannot currently SPECIALIZE variadic arguments."); if (TYPE_CHECK(param, REB_TS_DEQUOTE_REQUOTE) and IS_QUOTED(arg)) { // // Have to leave the quotes on, but still want to type check. if (not TYPE_CHECK(param, CELL_KIND(VAL_UNESCAPED(arg)))) fail (arg); // !!! merge w/Error_Invalid_Arg() } else if (not TYPE_CHECK(param, VAL_TYPE(arg))) fail (arg); // !!! merge w/Error_Invalid_Arg() SET_CELL_FLAG(arg, ARG_MARKED_CHECKED); specialized_arg_no_typecheck: // Specialized-out arguments must still be in the parameter list, // for enumeration in the evaluator to line up with the frame values // of the underlying function. assert(GET_CELL_FLAG(arg, ARG_MARKED_CHECKED)); Move_Value(DS_PUSH(), param); TYPE_SET(DS_TOP, REB_TS_HIDDEN); continue; } REBARR *paramlist = Pop_Stack_Values_Core( dsp_paramlist, SERIES_MASK_PARAMLIST | (SER(unspecialized)->header.bits & PARAMLIST_MASK_INHERIT) ); Manage_Array(paramlist); RELVAL *rootparam = ARR_HEAD(paramlist); VAL_ACT_PARAMLIST_NODE(rootparam) = NOD(paramlist); // Everything should have balanced out for a valid specialization // while (ordered_dsp != DSP) { ++ordered_dsp; REBVAL *ordered = DS_AT(ordered_dsp); if (not IS_WORD_BOUND(ordered)) // specialize 'print/asdf fail (Error_Bad_Refine_Raw(ordered)); REBVAL *slot = CTX_VAR(exemplar, VAL_WORD_INDEX(ordered)); assert(not IS_NULLED(slot) and NOT_CELL_FLAG(slot, PUSH_PARTIAL)); UNUSED(slot); } DS_DROP_TO(lowest_ordered_dsp); // See %sysobj.r for `specialized-meta:` object template REBVAL *example = Get_System(SYS_STANDARD, STD_SPECIALIZED_META); REBCTX *meta = Copy_Context_Shallow_Managed(VAL_CONTEXT(example)); Init_Nulled(CTX_VAR(meta, STD_SPECIALIZED_META_DESCRIPTION)); // default Move_Value( CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE), specializee ); if (not opt_specializee_name) Init_Nulled(CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE_NAME)); else Init_Word( CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE_NAME), opt_specializee_name ); MISC_META_NODE(paramlist) = NOD(meta); REBACT *specialized = Make_Action( paramlist, &Specializer_Dispatcher, ACT_UNDERLYING(unspecialized), // same underlying action as this exemplar, // also provide a context of specialization values 1 // details array capacity ); assert(CTX_KEYLIST(exemplar) == ACT_PARAMLIST(unspecialized)); assert( GET_ACTION_FLAG(specialized, IS_INVISIBLE) == GET_ACTION_FLAG(unspecialized, IS_INVISIBLE) ); // The "body" is the FRAME! value of the specialization. It takes on the // binding we want to use (which we can't put in the exemplar archetype, // that binding has to be UNBOUND). It also remembers the original // action in the phase, so Specializer_Dispatcher() knows what to call. // RELVAL *body = ARR_HEAD(ACT_DETAILS(specialized)); Move_Value(body, CTX_ARCHETYPE(exemplar)); INIT_BINDING(body, VAL_BINDING(specializee)); INIT_VAL_CONTEXT_PHASE(body, unspecialized); Init_Action_Unbound(out, specialized); return false; // code block did not throw }
// // Compose_Any_Array_Throws: C // // Compose a block from a block of un-evaluated values and GROUP! arrays that // are evaluated. This calls into Do_Core, so if 'into' is provided, then its // series must be protected from garbage collection. // // deep - recurse into sub-blocks // only - parens that return blocks are kept as blocks // // Writes result value at address pointed to by out. // REBOOL Compose_Any_Array_Throws( REBVAL *out, const REBVAL *any_array, REBOOL deep, REBOOL only, REBOOL into ) { REBDSP dsp_orig = DSP; Reb_Enumerator e; PUSH_SAFE_ENUMERATOR(&e, any_array); // evaluating could disrupt any_array while (NOT_END(e.value)) { UPDATE_EXPRESSION_START(&e); // informs the error delivery better if (IS_GROUP(e.value)) { // // We evaluate here, but disable lookahead so it only evaluates // the GROUP! and doesn't trigger errors on what's after it. // REBVAL evaluated; DO_NEXT_REFETCH_MAY_THROW(&evaluated, &e, DO_FLAG_NO_LOOKAHEAD); if (THROWN(&evaluated)) { *out = evaluated; DS_DROP_TO(dsp_orig); DROP_SAFE_ENUMERATOR(&e); return TRUE; } if (IS_BLOCK(&evaluated) && !only) { // // compose [blocks ([a b c]) merge] => [blocks a b c merge] // RELVAL *push = VAL_ARRAY_AT(&evaluated); while (NOT_END(push)) { // // `evaluated` is known to be specific, but its specifier // may be needed to derelativize its children. // DS_PUSH_RELVAL(push, VAL_SPECIFIER(&evaluated)); push++; } } else if (!IS_VOID(&evaluated)) { // // compose [(1 + 2) inserts as-is] => [3 inserts as-is] // compose/only [([a b c]) unmerged] => [[a b c] unmerged] // DS_PUSH(&evaluated); } else { // // compose [(print "Voids *vanish*!")] => [] // } } else if (deep) { if (IS_BLOCK(e.value)) { // // compose/deep [does [(1 + 2)] nested] => [does [3] nested] REBVAL specific; COPY_VALUE(&specific, e.value, e.specifier); REBVAL composed; if (Compose_Any_Array_Throws( &composed, &specific, TRUE, only, into )) { *out = composed; DS_DROP_TO(dsp_orig); DROP_SAFE_ENUMERATOR(&e); return TRUE; } DS_PUSH(&composed); } else { if (ANY_ARRAY(e.value)) { // // compose [copy/(orig) (copy)] => [copy/(orig) (copy)] // !!! path and second group are copies, first group isn't // REBARR *copy = Copy_Array_Shallow( VAL_ARRAY(e.value), IS_RELATIVE(e.value) ? e.specifier // use parent specifier if relative... : VAL_SPECIFIER(const_KNOWN(e.value)) // else child's ); DS_PUSH_TRASH; Val_Init_Array_Index( DS_TOP, VAL_TYPE(e.value), copy, VAL_INDEX(e.value) ); // ...manages } else DS_PUSH_RELVAL(e.value, e.specifier); } FETCH_NEXT_ONLY_MAYBE_END(&e); } else { // // compose [[(1 + 2)] (reverse "wollahs")] => [[(1 + 2)] "shallow"] // DS_PUSH_RELVAL(e.value, e.specifier); FETCH_NEXT_ONLY_MAYBE_END(&e); } } if (into) Pop_Stack_Values_Into(out, dsp_orig); else Val_Init_Array(out, VAL_TYPE(any_array), Pop_Stack_Values(dsp_orig)); DROP_SAFE_ENUMERATOR(&e); return FALSE; }
// // MAKE_Decimal: C // void MAKE_Decimal(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) { REBDEC d; switch (VAL_TYPE(arg)) { case REB_DECIMAL: d = VAL_DECIMAL(arg); goto dont_divide_if_percent; case REB_PERCENT: d = VAL_DECIMAL(arg); goto dont_divide_if_percent; case REB_INTEGER: d = cast(REBDEC, VAL_INT64(arg)); goto dont_divide_if_percent; case REB_MONEY: d = deci_to_decimal(VAL_MONEY_AMOUNT(arg)); goto dont_divide_if_percent; case REB_LOGIC: d = VAL_LOGIC(arg) ? 1.0 : 0.0; goto dont_divide_if_percent; case REB_CHAR: d = cast(REBDEC, VAL_CHAR(arg)); goto dont_divide_if_percent; case REB_TIME: d = VAL_TIME(arg) * NANO; break; case REB_STRING: { REBYTE *bp; REBCNT len; bp = Temp_Byte_Chars_May_Fail(arg, MAX_SCAN_DECIMAL, &len, FALSE); VAL_RESET_HEADER(out, kind); if (!Scan_Decimal( &d, bp, len, LOGICAL(kind != REB_PERCENT) )) { goto bad_make; } break; } case REB_BINARY: Binary_To_Decimal(arg, out); VAL_RESET_HEADER(out, kind); d = VAL_DECIMAL(out); break; #ifdef removed // case REB_ISSUE: { REBYTE *bp; REBCNT len; bp = Temp_Byte_Chars_May_Fail(arg, MAX_HEX_LEN, &len, FALSE); if (Scan_Hex(&VAL_INT64(out), bp, len, len) == 0) fail (Error_Bad_Make(REB_DECIMAL, val)); d = VAL_DECIMAL(out); break; } #endif default: if (ANY_ARRAY(arg) && VAL_ARRAY_LEN_AT(arg) == 2) { RELVAL *item = VAL_ARRAY_AT(arg); if (IS_INTEGER(item)) d = cast(REBDEC, VAL_INT64(item)); else if (IS_DECIMAL(item) || IS_PERCENT(item)) d = VAL_DECIMAL(item); else { REBVAL specific; COPY_VALUE(&specific, item, VAL_SPECIFIER(arg)); fail (Error_Invalid_Arg(&specific)); } ++item; REBDEC exp; if (IS_INTEGER(item)) exp = cast(REBDEC, VAL_INT64(item)); else if (IS_DECIMAL(item) || IS_PERCENT(item)) exp = VAL_DECIMAL(item); else { REBVAL specific; COPY_VALUE(&specific, item, VAL_SPECIFIER(arg)); fail (Error_Invalid_Arg(&specific)); } while (exp >= 1) { // // !!! Comment here said "funky. There must be a better way" // --exp; d *= 10.0; if (!FINITE(d)) fail (Error(RE_OVERFLOW)); } while (exp <= -1) { ++exp; d /= 10.0; } } else fail (Error_Bad_Make(kind, arg)); } if (kind == REB_PERCENT) d /= 100.0; dont_divide_if_percent: if (!FINITE(d)) fail (Error(RE_OVERFLOW)); VAL_RESET_HEADER(out, kind); VAL_DECIMAL(out) = d; return; bad_make: fail (Error_Bad_Make(kind, arg)); }
// // MAKE_Pair: C // void MAKE_Pair(REBVAL *out, enum Reb_Kind type, const REBVAL *arg) { if (IS_PAIR(arg)) { *out = *arg; return; } if (IS_STRING(arg)) { // // -1234567890x-1234567890 // REBCNT len; REBYTE *bp = Temp_Byte_Chars_May_Fail(arg, VAL_LEN_AT(arg), &len, FALSE); if (!Scan_Pair(bp, len, out)) goto bad_make; return; } REBDEC x; REBDEC y; if (IS_INTEGER(arg)) { x = VAL_INT32(arg); y = VAL_INT32(arg); } else if (IS_DECIMAL(arg)) { x = VAL_DECIMAL(arg); y = VAL_DECIMAL(arg); } else if (IS_BLOCK(arg) && VAL_LEN_AT(arg) == 2) { RELVAL *item = VAL_ARRAY_AT(arg); if (IS_INTEGER(item)) x = cast(REBDEC, VAL_INT64(item)); else if (IS_DECIMAL(item)) x = cast(REBDEC, VAL_DECIMAL(item)); else goto bad_make; ++item; if (IS_END(item)) goto bad_make; if (IS_INTEGER(item)) y = cast(REBDEC, VAL_INT64(item)); else if (IS_DECIMAL(item)) y = cast(REBDEC, VAL_DECIMAL(item)); else goto bad_make; } else goto bad_make; SET_PAIR(out, x, y); return; bad_make: fail (Error_Bad_Make(REB_PAIR, arg)); }