REB_R N_debug(REBFRM *frame_) {
PARAM(1, value);
REBVAL *value = ARG(value);
if (IS_VOID(value)) {
//
// e.g. just `>> debug` and [enter] in the console. Ideally this
// would shift the REPL into a mode where all commands issued were
// assumed to be in the debug dialect, similar to Ren Garden's
// modalities like `debug>>`.
//
Debug_Fmt("Sorry, there is no debug>> 'mode' yet in the console.");
goto modify_with_confidence;
}
if (IS_INTEGER(value) || IS_FRAME(value) || IS_FUNCTION(value)) {
REBFRM *frame;
// We pass TRUE here to account for an extra stack level... the one
// added by DEBUG itself, which presumably should not count.
//
if (!(frame = Frame_For_Stack_Level(&HG_Stack_Level, value, TRUE)))
fail (Error_Invalid_Arg(value));
Val_Init_Block(D_OUT, Make_Where_For_Frame(frame));
return R_OUT;
}
assert(IS_BLOCK(value));
Debug_Fmt(
"Sorry, but the `debug [...]` dialect is not defined yet.\n"
"Change the stack level (integer!, frame!, function!)\n"
"Or try out these commands:\n"
"\n"
" BREAKPOINT, RESUME, BACKTRACE\n"
);
modify_with_confidence:
Debug_Fmt(
"(Note: Ren-C is 'modify-with-confidence'...so just because a debug\n"
"feature you want isn't implemented doesn't mean you can't add it!)\n"
);
return R_BLANK;
}
//
// Reduce_Any_Array_Throws: C
//
// Reduce array from the index position specified in the value.
//
// If `into` then splice into the existing `out`. Otherwise, overwrite the
// `out` with all values collected from the stack, into an array matching the
// type of the input. So [1 + 1 2 + 2] => [3 4], and 1/+/1/2/+/2 => 3/4
//
REBOOL Reduce_Any_Array_Throws(
REBVAL *out,
REBVAL *any_array,
REBOOL into
) {
REBDSP dsp_orig = DSP;
Reb_Enumerator e;
PUSH_SAFE_ENUMERATOR(&e, any_array); // REDUCE-ing could disrupt any-array
while (NOT_END(e.value)) {
UPDATE_EXPRESSION_START(&e); // informs the error delivery better
REBVAL reduced;
DO_NEXT_REFETCH_MAY_THROW(&reduced, &e, DO_FLAG_NORMAL);
if (THROWN(&reduced)) {
*out = reduced;
DS_DROP_TO(dsp_orig);
DROP_SAFE_ENUMERATOR(&e);
return TRUE;
}
if (IS_VOID(&reduced)) {
//
// !!! Review if there should be a form of reduce which allows
// void expressions. The general feeling is that it shouldn't
// be allowed by default, since N expressions would not make N
// results...and reduce is often used for positional purposes.
// Substituting anything (like a NONE!, or anything else) would
// perhaps be disingenuous.
//
fail (Error(RE_REDUCE_MADE_VOID));
}
DS_PUSH(&reduced);
}
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;
}
//
// 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;
}
expv
compile_intrinsic_call0(ID id, expv args, int ignoreTypeMismatch) {
intrinsic_entry *ep = NULL;
int found = 0;
int nArgs = 0;
int nIntrArgs = 0;
int i;
expv ret = NULL;
expv a = NULL;
TYPE_DESC tp = NULL, ftp;
list lp;
INTR_OPS iOps = INTR_END;
const char *iName = NULL;
expv kindV = NULL;
int typeNotMatch = 0;
int isVarArgs = 0;
EXT_ID extid;
if (SYM_TYPE(ID_SYM(id)) != S_INTR) {
if (args == NULL) {
args = list0(LIST);
}
tp = ID_TYPE(id);
if (tp == NULL) {
warning_at_node(args,
"unknown type of '%s' declared as intrinsic",
SYM_NAME(ID_SYM(id)));
ID_TYPE(id) = BASIC_TYPE_DESC(TYPE_GNUMERIC_ALL);
TYPE_ATTR_FLAGS(ID_TYPE(id)) = TYPE_ATTR_FLAGS(id);
tp = ID_TYPE(id);
}
expv symV = expv_sym_term(F_FUNC, NULL, ID_SYM(id));
if (IS_PROCEDURE_TYPE(tp)) {
ftp = tp;
tp = FUNCTION_TYPE_RETURN_TYPE(ftp);
} else {
ftp = intrinsic_function_type(tp);
extid = new_external_id_for_external_decl(ID_SYM(id), ftp);
ID_TYPE(id) = ftp;
PROC_EXT_ID(id) = extid;
if (TYPE_IS_EXTERNAL(tp)){
ID_STORAGE(id) = STG_EXT;
}
else {
EXT_PROC_CLASS(extid) = EP_INTRINSIC;
}
}
EXPV_TYPE(symV) = ftp;
return expv_cons(FUNCTION_CALL, tp, symV, args);
}
ep = &(intrinsic_table[SYM_VAL(ID_SYM(id))]);
iOps = INTR_OP(ep);
iName = ID_NAME(id);
/* Count a number of argument, first. */
nArgs = 0;
if (args == NULL) {
args = list0(LIST);
}
FOR_ITEMS_IN_LIST(lp, args) {
nArgs++;
}
/* Search an intrinsic by checking argument types. */
found = 0;
for (;
((INTR_OP(ep) == iOps) &&
((strcasecmp(iName, INTR_NAME(ep)) == 0) ||
!(isValidString(INTR_NAME(ep)))));
ep++) {
kindV = NULL;
typeNotMatch = 0;
isVarArgs = 0;
/* Check a number of arguments. */
if (INTR_N_ARGS(ep) < 0 ||
INTR_N_ARGS(ep) == nArgs) {
/* varriable args or no kind arg. */
if (INTR_N_ARGS(ep) < 0) {
isVarArgs = 1;
}
nIntrArgs = nArgs;
} else if (INTR_HAS_KIND_ARG(ep) &&
((INTR_N_ARGS(ep) + 1) == nArgs)) {
/* could be intrinsic call with kind arg. */
expv lastV = expr_list_get_n(args, nArgs - 1);
if (lastV == NULL) {
return NULL; /* error recovery */
}
if (EXPV_KW_IS_KIND(lastV)) {
goto gotKind;
}
tp = EXPV_TYPE(lastV);
if (!(isValidType(tp))) {
return NULL; /* error recovery */
}
if (TYPE_BASIC_TYPE(tp) != TYPE_INT) {
/* kind arg must be integer type. */
continue;
}
gotKind:
nIntrArgs = INTR_N_ARGS(ep);
kindV = lastV;
} else {
continue;
}
/* The number of arguments matchs. Then check types. */
for (i = 0; i < nIntrArgs; i++) {
a = expr_list_get_n(args, i);
if (a == NULL) {
return NULL; /* error recovery */
}
tp = EXPV_TYPE(a);
if (!(isValidType(tp))) {
//return NULL; /* error recovery */
continue;
}
if (i == 1 &&
INTR_ARG_TYPE(ep)[i] == INTR_TYPE_PASSIGNABLE) {
if (expv_is_pointer_assignable(NULL, expr_list_get_n(args, 0), a)) {
break;
}
}
if (compare_intrinsic_arg_type(a, tp,
((isVarArgs == 0) ?
INTR_ARG_TYPE(ep)[i] :
INTR_ARG_TYPE(ep)[0])) != 0) {
/* Type mismatch. */
typeNotMatch = 1;
break;
}
}
if (typeNotMatch == 1) {
continue;
} else {
found = 1;
break;
}
}
if (found == 1) {
/* Yes we found an intrinsic to use. */
SYMBOL sp = NULL;
expv symV = NULL;
/* Then we have to determine return type. */
if (INTR_RETURN_TYPE(ep) != INTR_TYPE_NONE) {
tp = get_intrinsic_return_type(ep, args, kindV);
if (!(isValidType(tp))) {
//fatal("%s: can't determine return type.", __func__);
//return NULL;
tp = BASIC_TYPE_DESC(TYPE_GNUMERIC_ALL);
}
} else {
tp = type_VOID;
}
/* Finally find symbol for the intrinsic and make it expv. */
sp = find_symbol((char *)iName);
if (sp == NULL) {
fatal("%s: symbol '%s' is not created??",
__func__,
INTR_NAME(ep));
/* not reached */
return NULL;
}
symV = expv_sym_term(F_FUNC, NULL, sp);
if (symV == NULL) {
fatal("%s: symbol expv creation failure.", __func__);
/* not reached */
return NULL;
}
if (IS_VOID(tp)) {
TYPE_DESC ret = new_type_desc();
*ret = *tp;
tp = intrinsic_subroutine_type();
} else {
TYPE_DESC ret = new_type_desc();
*ret = *tp;
tp = intrinsic_function_type(ret);
}
if (ID_TYPE(id)) {
*ID_TYPE(id) = *tp;
} else {
ID_TYPE(id) = tp;
}
/* set external id for functionType's type ID.
* dont call declare_external_id() */
extid = new_external_id_for_external_decl(ID_SYM(id), tp);
PROC_EXT_ID(id) = extid;
if(TYPE_IS_EXTERNAL(tp)){
ID_STORAGE(id) = STG_EXT;
}else{
EXT_PROC_CLASS(extid) = EP_INTRINSIC;
}
ret = expv_cons(FUNCTION_CALL, FUNCTION_TYPE_RETURN_TYPE(tp), symV, args);
}
if (ret == NULL && !ignoreTypeMismatch) {
error_at_node((expr)args,
"argument(s) mismatch for an intrinsic '%s()'.",
iName);
}
return ret;
}
//
// 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;
}
//
// Next_Path_Throws: C
//
// Evaluate next part of a path.
//
REBOOL Next_Path_Throws(REBPVS *pvs)
{
REBPEF dispatcher;
// Path must have dispatcher, else return:
dispatcher = Path_Dispatch[VAL_TYPE(pvs->value)];
if (!dispatcher) return FALSE; // unwind, then check for errors
pvs->item++;
//Debug_Fmt("Next_Path: %r/%r", pvs->path-1, pvs->path);
// Determine the "selector". See notes on pvs->selector_temp for why
// a local variable can't be used for the temporary space.
//
if (IS_GET_WORD(pvs->item)) { // e.g. object/:field
pvs->selector
= GET_MUTABLE_VAR_MAY_FAIL(pvs->item, pvs->item_specifier);
if (IS_VOID(pvs->selector))
fail (Error_No_Value_Core(pvs->item, pvs->item_specifier));
SET_TRASH_IF_DEBUG(&pvs->selector_temp);
}
// object/(expr) case:
else if (IS_GROUP(pvs->item)) {
if (Do_At_Throws(
&pvs->selector_temp,
VAL_ARRAY(pvs->item),
VAL_INDEX(pvs->item),
IS_RELATIVE(pvs->item)
? pvs->item_specifier // if relative, use parent specifier...
: VAL_SPECIFIER(const_KNOWN(pvs->item)) // ...else use child's
)) {
*pvs->store = pvs->selector_temp;
return TRUE;
}
pvs->selector = &pvs->selector_temp;
}
else {
// object/word and object/value case:
//
COPY_VALUE(&pvs->selector_temp, pvs->item, pvs->item_specifier);
pvs->selector = &pvs->selector_temp;
}
switch (dispatcher(pvs)) {
case PE_OK:
break;
case PE_SET_IF_END:
if (pvs->opt_setval && IS_END(pvs->item + 1)) {
*pvs->value = *pvs->opt_setval;
pvs->opt_setval = NULL;
}
break;
case PE_NONE:
SET_BLANK(pvs->store);
case PE_USE_STORE:
pvs->value = pvs->store;
pvs->value_specifier = SPECIFIED;
break;
default:
assert(FALSE);
}
if (NOT_END(pvs->item + 1)) return Next_Path_Throws(pvs);
return FALSE;
}
//
// Do_Path_Throws_Core: 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_Core(
REBVAL *out,
REBSTR **label_out,
const RELVAL *path,
REBCTX *specifier,
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_DEBUG(out));
assert(!IN_DATA_STACK_DEBUG(path));
assert(!opt_setval || !IN_DATA_STACK_DEBUG(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!
// The path value that's coming in may be relative (in which case it
// needs to use the specifier passed in). Or it may be specific already,
// in which case we should use the specifier in the value to process
// its array contents.
//
if (IS_RELATIVE(path)) {
#if !defined(NDEBUG)
assert(specifier != SPECIFIED);
if (VAL_RELATIVE(path) != VAL_FUNC(CTX_FRAME_FUNC_VALUE(specifier))) {
Debug_Fmt("Specificity mismatch found in path dispatch");
PROBE_MSG(path, "the path being evaluated");
PROBE_MSG(FUNC_VALUE(VAL_RELATIVE(path)), "expected func");
PROBE_MSG(CTX_FRAME_FUNC_VALUE(specifier), "actual func");
assert(FALSE);
}
#endif
pvs.item_specifier = specifier;
}
else pvs.item_specifier = VAL_SPECIFIER(const_KNOWN(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, pvs.item_specifier);
pvs.value_specifier = SPECIFIED;
if (IS_VOID(pvs.value))
fail (Error_No_Value_Core(pvs.item, pvs.item_specifier));
}
else {
// !!! Ideally there would be some way to deal with writes to
// temporary locations, like this pvs.value...if a set-path sets
// it, then it will be discarded.
COPY_VALUE(pvs.store, VAL_ARRAY_AT(pvs.orig), pvs.item_specifier);
pvs.value = pvs.store;
pvs.value_specifier = SPECIFIED;
}
// 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(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:
REBVAL specified_orig;
COPY_VALUE(&specified_orig, pvs.orig, specifier);
REBVAL specified_item;
COPY_VALUE(&specified_item, pvs.item, specifier);
fail (Error(RE_INVALID_PATH, &specified_orig, &specified_item));
}
}
else if (!IS_FUNCTION(pvs.value)) {
REBVAL specified;
COPY_VALUE(&specified, pvs.orig, specifier);
fail (Error(RE_BAD_PATH_TYPE, &specified, 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)
COPY_VALUE(pvs.store, pvs.value, pvs.value_specifier);
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_out) {
REBVAL 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_out = VAL_WORD_SPELLING(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_out = Canon(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_VOID(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_At_Throws(
&refinement,
VAL_ARRAY(pvs.item),
VAL_INDEX(pvs.item),
IS_RELATIVE(pvs.item)
? pvs.item_specifier // if relative, use parent's
: VAL_SPECIFIER(const_KNOWN(pvs.item)) // else embedded
)) {
*out = refinement;
DS_DROP_TO(dsp_orig);
return TRUE;
}
if (IS_VOID(&refinement)) continue;
DS_PUSH(&refinement);
}
else if (IS_GET_WORD(pvs.item)) {
DS_PUSH_TRASH;
*DS_TOP = *GET_OPT_VAR_MAY_FAIL(pvs.item, pvs.item_specifier);
if (IS_VOID(DS_TOP)) {
DS_DROP;
continue;
}
}
else DS_PUSH_RELVAL(pvs.item, pvs.item_specifier);
// 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_SPELLING(DS_TOP, VAL_WORD_CANON(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;
}
