/* slower, but we get clean output */
cStr *read_file(filec_t * file)
{
register char *p, *s;
register int len;
cStr *str;
if (feof(file->fp))
THROWN((eof_id, "End of file.")) str = fgetstring(file->fp);
if (!str)
THROWN((eof_id, "End of file."))
/* ok, munch meta-characters */
p = s = string_chars(str);
len = string_length(str);
while (len-- && *s) {
if (ISPRINT(*s)) {
*p = *s;
p++;
} else if (*s == '\t') {
*p = ' ';
p++;
}
s++;
}
*p = '\0';
str->len = p - string_chars(str);
return str;
}
*/ void Get_Var_Into_Core(REBVAL *out, const REBVAL *word)
/*
** Variant of Get_Var_Core that always traps and never returns a
** direct pointer into a frame. It is thus able to give back
** `self` lookups, and doesn't have to check the word's protection
** status before returning.
**
** See comments in Get_Var_Core for what it's actually doing.
**
***********************************************************************/
{
REBSER *context = VAL_WORD_FRAME(word);
if (context) {
REBINT index = VAL_WORD_INDEX(word);
if (index > 0) {
*out = *(FRM_VALUES(context) + index);
assert(!IS_TRASH(out));
assert(!THROWN(out));
return;
}
if (index < 0) {
struct Reb_Call *call = DSF;
while (call) {
if (
call->args_ready
&& context == VAL_FUNC_WORDS(DSF_FUNC(call))
) {
assert(!IS_CLOSURE(DSF_FUNC(call)));
*out = *DSF_ARG(call, -index);
assert(!IS_TRASH(out));
assert(!THROWN(out));
return;
}
call = PRIOR_DSF(call);
}
raise Error_1(RE_NO_RELATIVE, word);
}
// Key difference between Get_Var_Into and Get_Var...fabricating
// an object REBVAL.
// !!! Could fake function frames stow the function value itself
// so 'binding-of' can return it and use for binding (vs. TRUE)?
assert(!IS_SELFLESS(context));
Val_Init_Object(out, context);
return;
}
raise Error_1(RE_NOT_DEFINED, word);
}
*/ RL_API void RL_Print_TOS(REBOOL mold, const REBYTE *marker)
/*
** Print top REBOL stack value to the console.
**
** Returns:
** Nothing
** Arguments:
** mold - should value be MOLDed instead of FORMed.
** marker - placed at beginning of line to indicate output.
** Notes:
** This function is used for the main console evaluation
** input loop to print the results of evaluation from stack.
** The REBOL data stack is an abstract structure that can
** change between releases. This function allows the host
** to print the result of processed functions.
** Marker is usually "==" to show output.
** The system/options/result-types determine which values
** are automatically printed.
**
***********************************************************************/
{
if (DSP != 0)
Debug_Fmt(Str_Stack_Misaligned, DSP);
// We shouldn't get any THROWN() values exposed to the client
assert(!THROWN(DS_TOP));
if (!IS_UNSET(DS_TOP)) {
if (marker) Out_Str(marker, 0);
Out_Value(DS_TOP, 500, mold, 1); // limit print length
}
}
*/ REBSER *Form_Reduce(REBSER *block, REBCNT index)
/*
** Reduce a block and then form each value into a string. Return the
** string or NULL if an unwind triggered while reducing.
**
***********************************************************************/
{
REBINT start = DSP + 1;
REBINT n;
REB_MOLD mo = {0};
while (index < BLK_LEN(block)) {
index = Do_Next(block, index, 0);
if (THROWN(DS_TOP)) {
*DS_VALUE(start) = *DS_TOP;
DSP = start;
return NULL;
}
}
Reset_Mold(&mo);
for (n = start; n <= DSP; n++)
Mold_Value(&mo, &DS_Base[n], 0);
DSP = start;
return Copy_String(mo.series, 0, -1);
}
*/ void Set_Var(const REBVAL *word, const REBVAL *value)
/*
** Set the word (variable) value. (Use macro when possible).
**
***********************************************************************/
{
REBINT index = VAL_WORD_INDEX(word);
struct Reb_Call *call;
REBSER *frm;
assert(!THROWN(value));
if (!HAS_FRAME(word)) raise Error_1(RE_NOT_DEFINED, word);
assert(VAL_WORD_FRAME(word));
// Print("Set %s to %s [frame: %x idx: %d]", Get_Word_Name(word), Get_Type_Name(value), VAL_WORD_FRAME(word), VAL_WORD_INDEX(word));
if (index > 0) {
frm = VAL_WORD_FRAME(word);
if (VAL_GET_EXT(FRM_WORDS(frm) + index, EXT_WORD_LOCK))
raise Error_1(RE_LOCKED_WORD, word);
FRM_VALUES(frm)[index] = *value;
return;
}
if (index == 0) raise Error_0(RE_SELF_PROTECTED);
// Find relative value:
call = DSF;
while (VAL_WORD_FRAME(word) != VAL_WORD_FRAME(DSF_LABEL(call))) {
call = PRIOR_DSF(call);
if (!call) raise Error_1(RE_NOT_DEFINED, word); // change error !!!
}
*DSF_ARG(call, -index) = *value;
}
*/ static void Loop_Number(REBVAL *var, REBSER* body, REBVAL *start, REBVAL *end, REBVAL *incr)
/*
***********************************************************************/
{
REBVAL *result;
REBDEC s;
REBDEC e;
REBDEC i;
if (IS_INTEGER(start)) s = (REBDEC)VAL_INT64(start);
else if (IS_DECIMAL(start) || IS_PERCENT(start)) s = VAL_DECIMAL(start);
else Trap_Arg(start);
if (IS_INTEGER(end)) e = (REBDEC)VAL_INT64(end);
else if (IS_DECIMAL(end) || IS_PERCENT(end)) e = VAL_DECIMAL(end);
else Trap_Arg(end);
if (IS_INTEGER(incr)) i = (REBDEC)VAL_INT64(incr);
else if (IS_DECIMAL(incr) || IS_PERCENT(incr)) i = VAL_DECIMAL(incr);
else Trap_Arg(incr);
VAL_SET(var, REB_DECIMAL);
for (; (i > 0.0) ? s <= e : s >= e; s += i) {
VAL_DECIMAL(var) = s;
result = Do_Blk(body, 0);
if (THROWN(result) && Check_Error(result) >= 0) break;
if (!IS_DECIMAL(var)) Trap_Type(var);
s = VAL_DECIMAL(var);
}
}
cStr *build_path(char *fname, struct stat * sbuf, Int nodir)
{
Int len = strlen(fname);
cStr *str = NULL;
if (len == 0)
THROWN((file_id, "No file specified."))
#ifdef RESTRICTIVE_FILES
if (strstr(fname, "../") || strstr(fname, "/..")
|| !strcmp(fname, ".."))
THROWN((perm_id, "Filename \"%s\" is not legal.", fname))
str = string_from_chars(c_dir_root, strlen(c_dir_root));
str = string_addc(str, '/');
str = string_add_chars(str, fname, len);
#else
if (*fname != '/') {
str = string_from_chars(c_dir_root, strlen(c_dir_root));
str = string_addc(str, '/');
str = string_add_chars(str, fname, len);
} else {
str = string_from_chars(fname, len);
}
#endif
if (sbuf != NULL) {
if (stat(str->s, sbuf) < 0) {
cthrow(file_id, "Cannot find file \"%s\".", str->s);
string_discard(str);
return NULL;
}
if (nodir) {
if (S_ISDIR(sbuf->st_mode)) {
cthrow(directory_id, "\"%s\" is a directory.", str->s);
string_discard(str);
return NULL;
}
}
}
return str;
}
//
// 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;
}
*/ static void Loop_Integer(REBVAL *var, REBSER* body, REBI64 start, REBI64 end, REBI64 incr)
/*
***********************************************************************/
{
REBVAL *result;
VAL_SET(var, REB_INTEGER);
while ((incr > 0) ? start <= end : start >= end) {
VAL_INT64(var) = start;
result = Do_Blk(body, 0);
if (THROWN(result) && Check_Error(result) >= 0) break;
if (!IS_INTEGER(var)) Trap_Type(var);
start = VAL_INT64(var);
if (REB_I64_ADD_OF(start, incr, &start)) {
Trap0(RE_OVERFLOW);
}
}
}
*/ static void Loop_Series(REBVAL *var, REBSER* body, REBVAL *start, REBINT ei, REBINT ii)
/*
***********************************************************************/
{
REBVAL *result;
REBINT si = VAL_INDEX(start);
REBCNT type = VAL_TYPE(start);
*var = *start;
if (ei >= (REBINT)VAL_TAIL(start)) ei = (REBINT)VAL_TAIL(start);
if (ei < 0) ei = 0;
for (; (ii > 0) ? si <= ei : si >= ei; si += ii) {
VAL_INDEX(var) = si;
result = Do_Blk(body, 0);
if (THROWN(result) && Check_Error(result) >= 0) break;
if (VAL_TYPE(var) != type) Trap1(RE_INVALID_TYPE, var);
si = VAL_INDEX(var);
}
}
*/ REBOOL Loop_Throw_Should_Return(REBVAL *val)
/*
** Process values thrown during loop, and tell the loop whether
** to take that processed value and return it up the stack.
** If not, then the throw was a continue...and the code
** should just keep going.
**
** Note: This modifies the input value. If it returns FALSE
** then the value is guaranteed to not be THROWN(), but it
** may-or-may-not be THROWN() if TRUE is returned.
**
***********************************************************************/
{
assert(THROWN(val));
// Using words for BREAK and CONTINUE to parallel old VAL_ERR_SYM()
// code. So if the throw wasn't a word it can't be either of those,
// hence the loop doesn't handle it and needs to bubble up the THROWN()
if (!IS_WORD(val))
return TRUE;
// If it's a CONTINUE then wipe out the THROWN() value with UNSET,
// and tell the loop it doesn't have to return.
if (VAL_WORD_SYM(val) == SYM_CONTINUE) {
SET_UNSET(val);
return FALSE;
}
// If it's a BREAK, get the /WITH value (UNSET! if no /WITH) and
// say it should be returned.
if (VAL_WORD_SYM(val) == SYM_BREAK) {
TAKE_THROWN_ARG(val, val);
return TRUE;
}
// Else: Let all other THROWN() values bubble up.
return TRUE;
}
//
// 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;
}
*/ static REBCNT Do_Eval_Rule(REBPARSE *parse, REBCNT index, REBVAL **rule)
/*
** Evaluate the input as a code block. Advance input if
** rule succeeds. Return new index or failure.
**
** Examples:
** do skip
** do end
** do "abc"
** do 'abc
** do [...]
** do variable
** do datatype!
** do quote 123
** do into [...]
**
** Problem: cannot write: set var do datatype!
**
***********************************************************************/
{
REBVAL value;
REBVAL *item = *rule;
REBCNT n;
REBPARSE newparse;
// First, check for end of input:
if (index >= parse->series->tail) {
if (IS_WORD(item) && VAL_CMD(item) == SYM_END) return index;
else return NOT_FOUND;
}
// Evaluate next N input values:
index = Do_Next(parse->series, index, FALSE);
// Value is on top of stack (volatile!):
value = *DS_POP;
if (THROWN(&value)) Throw_Break(&value);
// Get variable or command:
if (IS_WORD(item)) {
n = VAL_CMD(item);
if (n == SYM_SKIP)
return (IS_SET(&value)) ? index : NOT_FOUND;
if (n == SYM_QUOTE) {
item = item + 1;
(*rule)++;
if (IS_END(item)) Trap1(RE_PARSE_END, item-2);
if (IS_PAREN(item)) {
item = Do_Block_Value_Throw(item); // might GC
}
}
else if (n == SYM_INTO) {
item = item + 1;
(*rule)++;
if (IS_END(item)) Trap1(RE_PARSE_END, item-2);
item = Get_Parse_Value(item); // sub-rules
if (!IS_BLOCK(item)) Trap1(RE_PARSE_RULE, item-2);
if (!ANY_BINSTR(&value) && !ANY_BLOCK(&value)) return NOT_FOUND;
return (Parse_Series(&value, VAL_BLK_DATA(item), parse->flags, 0) == VAL_TAIL(&value))
? index : NOT_FOUND;
}
else if (n > 0)
Trap1(RE_PARSE_RULE, item);
else
item = Get_Parse_Value(item); // variable
}
else if (IS_PATH(item)) {
item = Get_Parse_Value(item); // variable
}
else if (IS_SET_WORD(item) || IS_GET_WORD(item) || IS_SET_PATH(item) || IS_GET_PATH(item))
Trap1(RE_PARSE_RULE, item);
if (IS_NONE(item)) {
return (VAL_TYPE(&value) > REB_NONE) ? NOT_FOUND : index;
}
// Copy the value into its own block:
newparse.series = Make_Block(1);
SAVE_SERIES(newparse.series);
Append_Val(newparse.series, &value);
newparse.type = REB_BLOCK;
newparse.flags = parse->flags;
newparse.result = 0;
n = (Parse_Next_Block(&newparse, 0, item, 0) != NOT_FOUND) ? index : NOT_FOUND;
UNSAVE_SERIES(newparse.series);
return n;
}
//
// 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;
}
*/ static int Loop_Each(REBVAL *ds, REBINT mode)
/*
** Supports these natives (modes):
** 0: foreach
** 1: remove-each
** 2: map
**
***********************************************************************/
{
REBSER *body;
REBVAL *vars;
REBVAL *words;
REBSER *frame;
REBVAL *value;
REBSER *series;
REBSER *out; // output block (for MAP, mode = 2)
REBINT index; // !!!! should these be REBCNT?
REBINT tail;
REBINT windex; // write
REBINT rindex; // read
REBINT err;
REBCNT i;
REBCNT j;
value = D_ARG(2); // series
if (IS_NONE(value)) return R_NONE;
body = Init_Loop(D_ARG(1), D_ARG(3), &frame); // vars, body
SET_OBJECT(D_ARG(1), frame); // keep GC safe
Set_Block(D_ARG(3), body); // keep GC safe
SET_NONE(D_RET);
SET_NONE(DS_NEXT);
// If it's MAP, create result block:
if (mode == 2) {
out = Make_Block(VAL_LEN(value));
Set_Block(D_RET, out);
}
// Get series info:
if (ANY_OBJECT(value)) {
series = VAL_OBJ_FRAME(value);
out = FRM_WORD_SERIES(series); // words (the out local reused)
index = 1;
//if (frame->tail > 3) Trap_Arg(FRM_WORD(frame, 3));
}
else if (IS_MAP(value)) {
series = VAL_SERIES(value);
index = 0;
//if (frame->tail > 3) Trap_Arg(FRM_WORD(frame, 3));
}
else {
series = VAL_SERIES(value);
index = VAL_INDEX(value);
if (index >= (REBINT)SERIES_TAIL(series)) {
if (mode == 1) {
SET_INTEGER(D_RET, 0);
}
return R_RET;
}
}
windex = index;
// Iterate over each value in the series block:
while (index < (tail = SERIES_TAIL(series))) {
rindex = index; // remember starting spot
j = 0;
// Set the FOREACH loop variables from the series:
for (i = 1; i < frame->tail; i++) {
vars = FRM_VALUE(frame, i);
words = FRM_WORD(frame, i);
// var spec is WORD
if (IS_WORD(words)) {
if (index < tail) {
if (ANY_BLOCK(value)) {
*vars = *BLK_SKIP(series, index);
}
else if (ANY_OBJECT(value)) {
if (!VAL_GET_OPT(BLK_SKIP(out, index), OPTS_HIDE)) {
// Alternate between word and value parts of object:
if (j == 0) {
Set_Word(vars, VAL_WORD_SYM(BLK_SKIP(out, index)), series, index);
if (NOT_END(vars+1)) index--; // reset index for the value part
}
else if (j == 1)
*vars = *BLK_SKIP(series, index);
else
Trap_Arg(words);
j++;
}
else {
// Do not evaluate this iteration
index++;
goto skip_hidden;
}
}
else if (IS_VECTOR(value)) {
Set_Vector_Value(vars, series, index);
}
else if (IS_MAP(value)) {
REBVAL *val = BLK_SKIP(series, index | 1);
if (!IS_NONE(val)) {
if (j == 0) {
*vars = *BLK_SKIP(series, index & ~1);
if (IS_END(vars+1)) index++; // only words
}
else if (j == 1)
*vars = *BLK_SKIP(series, index);
else
Trap_Arg(words);
j++;
}
else {
index += 2;
goto skip_hidden;
}
}
else { // A string or binary
if (IS_BINARY(value)) {
SET_INTEGER(vars, (REBI64)(BIN_HEAD(series)[index]));
}
else if (IS_IMAGE(value)) {
Set_Tuple_Pixel(BIN_SKIP(series, index), vars);
}
else {
VAL_SET(vars, REB_CHAR);
VAL_CHAR(vars) = GET_ANY_CHAR(series, index);
}
}
index++;
}
else SET_NONE(vars);
}
// var spec is WORD:
else if (IS_SET_WORD(words)) {
if (ANY_OBJECT(value) || IS_MAP(value)) {
*vars = *value;
} else {
VAL_SET(vars, REB_BLOCK);
VAL_SERIES(vars) = series;
VAL_INDEX(vars) = index;
}
//if (index < tail) index++; // do not increment block.
}
else Trap_Arg(words);
}
ds = Do_Blk(body, 0);
if (THROWN(ds)) {
if ((err = Check_Error(ds)) >= 0) break;
// else CONTINUE:
if (mode == 1) SET_FALSE(ds); // keep the value (for mode == 1)
} else {
err = 0; // prevent later test against uninitialized value
}
if (mode > 0) {
//if (ANY_OBJECT(value)) Trap_Types(words, REB_BLOCK, VAL_TYPE(value)); //check not needed
// If FALSE return, copy values to the write location:
if (mode == 1) { // remove-each
if (IS_FALSE(ds)) {
REBCNT wide = SERIES_WIDE(series);
// memory areas may overlap, so use memmove and not memcpy!
memmove(series->data + (windex * wide), series->data + (rindex * wide), (index - rindex) * wide);
windex += index - rindex;
// old: while (rindex < index) *BLK_SKIP(series, windex++) = *BLK_SKIP(series, rindex++);
}
}
else
if (!IS_UNSET(ds)) Append_Val(out, ds); // (mode == 2)
}
skip_hidden: ;
}
// Finish up:
if (mode == 1) {
// Remove hole (updates tail):
if (windex < index) Remove_Series(series, windex, index - windex);
SET_INTEGER(DS_RETURN, index - windex);
return R_RET;
}
// If MAP and not BREAK/RETURN:
if (mode == 2 && err != 2) return R_RET;
return R_TOS1;
}
*/ 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;
}
//
// Do_Breakpoint_Throws: C
//
// A call to Do_Breakpoint_Throws does delegation to a hook in the host, which
// (if registered) will generally start an interactive session for probing the
// environment at the break. The `resume` native cooperates by being able to
// give back a value (or give back code to run to produce a value) that the
// call to breakpoint returns.
//
// RESUME has another feature, which is to be able to actually unwind and
// simulate a return /AT a function *further up the stack*. (This may be
// switched to a feature of a "STEP OUT" command at some point.)
//
REBOOL Do_Breakpoint_Throws(
REBVAL *out,
REBOOL interrupted, // Ctrl-C (as opposed to a BREAKPOINT)
const REBVAL *default_value,
REBOOL do_default
) {
REBVAL *target = NONE_VALUE;
REBVAL temp;
VAL_INIT_WRITABLE_DEBUG(&temp);
if (!PG_Breakpoint_Quitting_Hook) {
//
// Host did not register any breakpoint handler, so raise an error
// about this as early as possible.
//
fail (Error(RE_HOST_NO_BREAKPOINT));
}
// We call the breakpoint hook in a loop, in order to keep running if any
// inadvertent FAILs or THROWs occur during the interactive session.
// Only a conscious call of RESUME speaks the protocol to break the loop.
//
while (TRUE) {
struct Reb_State state;
REBCTX *error;
push_trap:
PUSH_TRAP(&error, &state);
// The host may return a block of code to execute, but cannot
// while evaluating do a THROW or a FAIL that causes an effective
// "resumption". Halt is the exception, hence we PUSH_TRAP and
// not PUSH_UNHALTABLE_TRAP. QUIT is also an exception, but a
// desire to quit is indicated by the return value of the breakpoint
// hook (which may or may not decide to request a quit based on the
// QUIT command being run).
//
// The core doesn't want to get involved in presenting UI, so if
// an error makes it here and wasn't trapped by the host first that
// is a bug in the host. It should have done its own PUSH_TRAP.
//
if (error) {
#if !defined(NDEBUG)
REBVAL error_value;
VAL_INIT_WRITABLE_DEBUG(&error_value);
Val_Init_Error(&error_value, error);
PROBE_MSG(&error_value, "Error not trapped during breakpoint:");
Panic_Array(CTX_VARLIST(error));
#endif
// In release builds, if an error managed to leak out of the
// host's breakpoint hook somehow...just re-push the trap state
// and try it again.
//
goto push_trap;
}
// Call the host's breakpoint hook.
//
if (PG_Breakpoint_Quitting_Hook(&temp, interrupted)) {
//
// If a breakpoint hook returns TRUE that means it wants to quit.
// The value should be the /WITH value (as in QUIT/WITH)
//
assert(!THROWN(&temp));
*out = *ROOT_QUIT_NATIVE;
CONVERT_NAME_TO_THROWN(out, &temp, FALSE);
return TRUE; // TRUE = threw
}
// If a breakpoint handler returns FALSE, then it should have passed
// back a "resume instruction" triggered by a call like:
//
// resume/do [fail "This is how to fail from a breakpoint"]
//
// So now that the handler is done, we will allow any code handed back
// to do whatever FAIL it likes vs. trapping that here in a loop.
//
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
// Decode and process the "resume instruction"
{
struct Reb_Frame *frame;
REBVAL *mode;
REBVAL *payload;
assert(IS_GROUP(&temp));
assert(VAL_LEN_HEAD(&temp) == RESUME_INST_MAX);
mode = VAL_ARRAY_AT_HEAD(&temp, RESUME_INST_MODE);
payload = VAL_ARRAY_AT_HEAD(&temp, RESUME_INST_PAYLOAD);
target = VAL_ARRAY_AT_HEAD(&temp, RESUME_INST_TARGET);
// The first thing we need to do is determine if the target we
// want to return to has another breakpoint sandbox blocking
// us. If so, what we need to do is actually retransmit the
// resume instruction so it can break that wall, vs. transform
// it into an EXIT/FROM that would just get intercepted.
//
if (!IS_NONE(target)) {
#if !defined(NDEBUG)
REBOOL found = FALSE;
#endif
for (frame = FS_TOP; frame != NULL; frame = frame->prior) {
if (frame->mode != CALL_MODE_FUNCTION)
continue;
if (
frame != FS_TOP
&& FUNC_CLASS(frame->func) == FUNC_CLASS_NATIVE
&& (
FUNC_CODE(frame->func) == &N_pause
|| FUNC_CODE(frame->func) == &N_breakpoint
)
) {
// We hit a breakpoint (that wasn't this call to
// breakpoint, at the current FS_TOP) before finding
// the sought after target. Retransmit the resume
// instruction so that level will get it instead.
//
*out = *ROOT_RESUME_NATIVE;
CONVERT_NAME_TO_THROWN(out, &temp, FALSE);
return TRUE; // TRUE = thrown
}
if (IS_FRAME(target)) {
if (NOT(frame->flags & DO_FLAG_FRAME_CONTEXT))
continue;
if (
VAL_CONTEXT(target)
== AS_CONTEXT(frame->data.context)
) {
// Found a closure matching the target before we
// reached a breakpoint, no need to retransmit.
//
#if !defined(NDEBUG)
found = TRUE;
#endif
break;
}
}
else {
assert(IS_FUNCTION(target));
if (frame->flags & DO_FLAG_FRAME_CONTEXT)
continue;
if (VAL_FUNC(target) == frame->func) {
//
// Found a function matching the target before we
// reached a breakpoint, no need to retransmit.
//
#if !defined(NDEBUG)
found = TRUE;
#endif
break;
}
}
}
// RESUME should not have been willing to use a target that
// is not on the stack.
//
#if !defined(NDEBUG)
assert(found);
#endif
}
if (IS_NONE(mode)) {
//
// If the resume instruction had no /DO or /WITH of its own,
// then it doesn't override whatever the breakpoint provided
// as a default. (If neither the breakpoint nor the resume
// provided a /DO or a /WITH, result will be UNSET.)
//
goto return_default; // heeds `target`
}
assert(IS_LOGIC(mode));
if (VAL_LOGIC(mode)) {
if (DO_VAL_ARRAY_AT_THROWS(&temp, payload)) {
//
// Throwing is not compatible with /AT currently.
//
if (!IS_NONE(target))
fail (Error_No_Catch_For_Throw(&temp));
// Just act as if the BREAKPOINT call itself threw
//
*out = temp;
return TRUE; // TRUE = thrown
}
// Ordinary evaluation result...
}
else
temp = *payload;
}
// The resume instruction will be GC'd.
//
goto return_temp;
}
DEAD_END;
return_default:
if (do_default) {
if (DO_VAL_ARRAY_AT_THROWS(&temp, default_value)) {
//
// If the code throws, we're no longer in the sandbox...so we
// bubble it up. Note that breakpoint runs this code at its
// level... so even if you request a higher target, any throws
// will be processed as if they originated at the BREAKPOINT
// frame. To do otherwise would require the EXIT/FROM protocol
// to add support for DO-ing at the receiving point.
//
*out = temp;
return TRUE; // TRUE = thrown
}
}
else
temp = *default_value; // generally UNSET! if no /WITH
return_temp:
// The easy case is that we just want to return from breakpoint
// directly, signaled by the target being NONE!.
//
if (IS_NONE(target)) {
*out = temp;
return FALSE; // FALSE = not thrown
}
// If the target is a function, then we're looking to simulate a return
// from something up the stack. This uses the same mechanic as
// definitional returns--a throw named by the function or closure frame.
//
// !!! There is a weak spot in definitional returns for FUNCTION! that
// they can only return to the most recent invocation; which is a weak
// spot of FUNCTION! in general with stack relative variables. Also,
// natives do not currently respond to definitional returns...though
// they can do so just as well as FUNCTION! can.
//
*out = *target;
CONVERT_NAME_TO_THROWN(out, &temp, TRUE);
return TRUE; // TRUE = thrown
}
*/ REBVAL *Get_Var_Core(const REBVAL *word, REBOOL trap, REBOOL writable)
/*
** Get the word--variable--value. (Generally, use the macros like
** GET_VAR or GET_MUTABLE_VAR instead of this). This routine is
** called quite a lot and so attention to performance is important.
**
** Coded assuming most common case is trap=TRUE and writable=FALSE
**
***********************************************************************/
{
REBSER *context = VAL_WORD_FRAME(word);
if (context) {
REBINT index = VAL_WORD_INDEX(word);
// POSITIVE INDEX: The word is bound directly to a value inside
// a frame, and represents the zero-based offset into that series.
// This is how values would be picked out of object-like things...
// (Including looking up 'append' in the user context.)
if (index > 0) {
REBVAL *value;
if (
writable &&
VAL_GET_EXT(FRM_WORDS(context) + index, EXT_WORD_LOCK)
) {
if (trap) raise Error_1(RE_LOCKED_WORD, word);
return NULL;
}
value = FRM_VALUES(context) + index;
assert(!THROWN(value));
return value;
}
// NEGATIVE INDEX: Word is stack-relative bound to a function with
// no persistent frame held by the GC. The value *might* be found
// on the stack (or not, if all instances of the function on the
// call stack have finished executing). We walk backward in the call
// stack to see if we can find the function's "identifying series"
// in a call frame...and take the first instance we see (even if
// multiple invocations are on the stack, most recent wins)
if (index < 0) {
struct Reb_Call *call = DSF;
// Get_Var could theoretically be called with no evaluation on
// the stack, so check for no DSF first...
while (call) {
if (
call->args_ready
&& context == VAL_FUNC_WORDS(DSF_FUNC(call))
) {
REBVAL *value;
assert(!IS_CLOSURE(DSF_FUNC(call)));
if (
writable &&
VAL_GET_EXT(
VAL_FUNC_PARAM(DSF_FUNC(call), -index),
EXT_WORD_LOCK
)
) {
if (trap) raise Error_1(RE_LOCKED_WORD, word);
return NULL;
}
value = DSF_ARG(call, -index);
assert(!THROWN(value));
return value;
}
call = PRIOR_DSF(call);
}
if (trap) raise Error_1(RE_NO_RELATIVE, word);
return NULL;
}
// ZERO INDEX: The word is SELF. Although the information needed
// to produce an OBJECT!-style REBVAL lives in the zero offset
// of the frame, it's not a value that we can return a direct
// pointer to. Use GET_VAR_INTO instead for that.
assert(!IS_SELFLESS(context));
if (trap) raise Error_0(RE_SELF_PROTECTED);
return NULL; // is this a case where we should *always* trap?
}
if (trap) raise Error_1(RE_NOT_DEFINED, word);
return NULL;
}
