*/ REBSER *Gob_To_Block(REBGOB *gob)
/*
** Used by MOLD to create a block.
**
***********************************************************************/
{
REBSER *ser = Make_Block(10);
REBVAL *val;
REBINT words[6] = {SYM_OFFSET, SYM_SIZE, SYM_ALPHA, 0};
REBVAL *vals[6];
REBINT n = 0;
REBVAL *val1;
REBCNT sym;
for (n = 0; words[n]; n++) {
val = Append_Value(ser);
Init_Word(val, words[n]);
VAL_SET(val, REB_SET_WORD);
vals[n] = Append_Value(ser);
}
SET_PAIR(vals[0], GOB_X(gob), GOB_Y(gob));
SET_PAIR(vals[1], GOB_W(gob), GOB_H(gob));
SET_INTEGER(vals[2], GOB_ALPHA(gob));
if (!GOB_TYPE(gob)) return ser;
if (GOB_CONTENT(gob)) {
val1 = Append_Value(ser);
val = Append_Value(ser);
switch (GOB_TYPE(gob)) {
case GOBT_COLOR:
sym = SYM_COLOR;
break;
case GOBT_IMAGE:
sym = SYM_IMAGE;
break;
case GOBT_STRING:
case GOBT_TEXT:
sym = SYM_TEXT;
break;
case GOBT_DRAW:
sym = SYM_DRAW;
break;
case GOBT_EFFECT:
sym = SYM_EFFECT;
break;
}
Init_Word(val1, sym);
VAL_SET(val1, REB_SET_WORD);
Get_GOB_Var(gob, val1, val);
}
return ser;
}
*/ void Trap_Word(REBCNT num, REBCNT sym, REBVAL *arg)
/*
***********************************************************************/
{
Init_Word(DS_TOP, sym);
if (arg) Trap2(num, DS_TOP, arg);
else Trap1(num, DS_TOP);
}
*/ void Trap_Security(REBCNT flag, REBCNT sym, REBVAL *value)
/*
** Take action on the policy flags provided. The sym and value
** are provided for error message purposes only.
**
***********************************************************************/
{
if (flag == SEC_THROW) {
if (!value) {
Init_Word(DS_TOP, sym);
value = DS_TOP;
}
Trap1(RE_SECURITY, value);
}
else if (flag == SEC_QUIT) OS_EXIT(101);
}
*/ static REBSER *Flags_To_Block(REBGOB *gob)
/*
***********************************************************************/
{
REBSER *ser;
REBVAL *val;
REBINT i;
ser = Make_Block(3);
for (i = 0; Gob_Flag_Words[i]; i += 2) {
if (GET_GOB_FLAG(gob, Gob_Flag_Words[i+1])) {
val = Append_Value(ser);
Init_Word(val, Gob_Flag_Words[i]);
}
}
return ser;
}
*/ REBSER *Make_Backtrace(REBINT start)
/*
** Return a block of backtrace words.
**
***********************************************************************/
{
REBCNT depth = Stack_Depth();
REBSER *blk = Make_Block(depth-start);
REBINT dsf;
REBVAL *val;
for (dsf = DSF; dsf > 0; dsf = PRIOR_DSF(dsf)) {
if (start-- <= 0) {
val = Append_Value(blk);
Init_Word(val, VAL_WORD_SYM(DSF_WORD(dsf)));
}
}
return blk;
}
*/ void Collect_Simple_Words(REBVAL *block, REBCNT modes)
/*
** Used for Collect_Block_Words().
**
***********************************************************************/
{
REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
REBVAL *val;
for (; NOT_END(block); block++) {
if (ANY_WORD(block)
&& !binds[VAL_WORD_CANON(block)]
&& (modes & BIND_ALL || IS_SET_WORD(block))
) {
binds[VAL_WORD_CANON(block)] = 1;
val = Append_Value(BUF_WORDS);
Init_Word(val, VAL_WORD_SYM(block));
}
else if (ANY_EVAL_BLOCK(block) && (modes & BIND_DEEP))
Collect_Simple_Words(VAL_BLK_DATA(block), modes);
}
}
*/ REBSER *Collect_Set_Words(REBVAL *val)
/*
** Scan a block, collecting all of its SET words as a block.
**
***********************************************************************/
{
REBCNT cnt = 0;
REBVAL *val2 = val;
REBSER *ser;
for (; NOT_END(val); val++) if (IS_SET_WORD(val)) cnt++;
val = val2;
ser = Make_Block(cnt);
val2 = BLK_HEAD(ser);
for (; NOT_END(val); val++) {
if (IS_SET_WORD(val)) Init_Word(val2++, VAL_WORD_SYM(val));
}
SET_END(val2);
SERIES_TAIL(ser) = cnt;
return ser;
}
*/ REBSER *Gob_To_Block(REBGOB *gob)
/*
** Used by MOLD to create a block.
**
***********************************************************************/
{
REBSER *ser = Make_Block(10);
REBVAL *val;
REBVAL *val1;
REBCNT sym;
val = Append_Value(ser);
Init_Word(val, SYM_OFFSET);
VAL_SET(val, REB_SET_WORD);
val = Append_Value(ser);
SET_PAIR(val, GOB_X(gob), GOB_Y(gob));
val = Append_Value(ser);
Init_Word(val, SYM_SIZE);
VAL_SET(val, REB_SET_WORD);
val = Append_Value(ser);
SET_PAIR(val, GOB_W(gob), GOB_H(gob));
if (!GET_GOB_FLAG(gob, GOBF_OPAQUE) && GOB_ALPHA(gob) < 255) {
val = Append_Value(ser);
Init_Word(val, SYM_ALPHA);
VAL_SET(val, REB_SET_WORD);
val = Append_Value(ser);
SET_INTEGER(val, 255 - GOB_ALPHA(gob));
}
if (!GOB_TYPE(gob)) return ser;
if (GOB_CONTENT(gob)) {
val1 = Append_Value(ser);
val = Append_Value(ser);
switch (GOB_TYPE(gob)) {
case GOBT_COLOR:
sym = SYM_COLOR;
break;
case GOBT_IMAGE:
sym = SYM_IMAGE;
break;
#ifdef HAS_WIDGET_GOB
case GOBT_WIDGET:
sym = SYM_WIDGET;
break;
#endif
case GOBT_STRING:
case GOBT_TEXT:
sym = SYM_TEXT;
break;
case GOBT_DRAW:
sym = SYM_DRAW;
break;
case GOBT_EFFECT:
sym = SYM_EFFECT;
break;
}
Init_Word(val1, sym);
VAL_SET(val1, REB_SET_WORD);
Get_GOB_Var(gob, val1, val);
}
return ser;
}
*/ static REBFLG Get_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
REBSER *data;
switch (VAL_WORD_CANON(word)) {
case SYM_OFFSET:
SET_PAIR(val, GOB_X(gob), GOB_Y(gob));
break;
case SYM_SIZE:
SET_PAIR(val, GOB_W(gob), GOB_H(gob));
break;
case SYM_IMAGE:
if (GOB_TYPE(gob) == GOBT_IMAGE) {
// image
}
else goto is_none;
break;
#ifdef HAS_WIDGET_GOB
case SYM_WIDGET:
data = VAL_SERIES(GOB_WIDGET_SPEC(gob));
Init_Word(val, VAL_WORD_CANON(BLK_HEAD(data)));
VAL_SET(val, REB_LIT_WORD);
break;
#endif
case SYM_DRAW:
if (GOB_TYPE(gob) == GOBT_DRAW) {
Set_Block(val, GOB_CONTENT(gob)); // Note: compiler optimizes SET_BLOCKs below
}
else goto is_none;
break;
case SYM_TEXT:
if (GOB_TYPE(gob) == GOBT_TEXT) {
Set_Block(val, GOB_CONTENT(gob));
}
else if (GOB_TYPE(gob) == GOBT_STRING) {
Set_String(val, GOB_CONTENT(gob));
}
else goto is_none;
break;
case SYM_EFFECT:
if (GOB_TYPE(gob) == GOBT_EFFECT) {
Set_Block(val, GOB_CONTENT(gob));
}
else goto is_none;
break;
case SYM_COLOR:
if (GOB_TYPE(gob) == GOBT_COLOR) {
Set_Tuple_Pixel((REBYTE*)&GOB_CONTENT(gob), val);
}
else goto is_none;
break;
case SYM_ALPHA:
SET_INTEGER(val, GOB_ALPHA(gob));
break;
case SYM_PANE:
if (GOB_PANE(gob))
Set_Block(val, Pane_To_Block(gob, 0, -1));
else
Set_Block(val, Make_Block(0));
break;
case SYM_PARENT:
if (GOB_PARENT(gob)) {
SET_GOB(val, GOB_PARENT(gob));
}
else
is_none:
SET_NONE(val);
break;
case SYM_DATA:
#ifdef HAS_WIDGET_GOB
if (GOB_TYPE(gob) == GOBT_WIDGET) {
return OS_GET_WIDGET_DATA(gob, val);
}
#endif
data = GOB_DATA(gob);
if (GOB_DTYPE(gob) == GOBD_OBJECT) {
SET_OBJECT(val, data);
}
else if (GOB_DTYPE(gob) == GOBD_BLOCK) {
Set_Block(val, data);
}
else if (GOB_DTYPE(gob) == GOBD_STRING) {
Set_String(val, data);
}
else if (GOB_DTYPE(gob) == GOBD_BINARY) {
SET_BINARY(val, data);
}
else if (GOB_DTYPE(gob) == GOBD_INTEGER) {
SET_INTEGER(val, (REBIPT)data);
}
else goto is_none;
break;
case SYM_FLAGS:
Set_Block(val, Flags_To_Block(gob));
break;
default:
return FALSE;
}
return TRUE;
}
*/ static REB_R Loop_Each(struct Reb_Call *call_, 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;
REBVAL *ds;
assert(mode >= 0 && mode < 3);
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_OUT); // Default result to NONE if the loop does not run
// If it's MAP, create result block:
if (mode == 2) {
out = Make_Block(VAL_LEN(value));
SAVE_SERIES(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_DEAD_END(FRM_WORD(frame, 3));
}
else if (IS_MAP(value)) {
series = VAL_SERIES(value);
index = 0;
//if (frame->tail > 3) Trap_Arg_DEAD_END(FRM_WORD(frame, 3));
}
else {
series = VAL_SERIES(value);
index = VAL_INDEX(value);
if (index >= cast(REBINT, SERIES_TAIL(series))) {
if (mode == 1) {
SET_INTEGER(D_OUT, 0);
} else if (mode == 2) {
Set_Block(D_OUT, out);
UNSAVE_SERIES(out);
}
return R_OUT;
}
}
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_EXT(BLK_SKIP(out, index), EXT_WORD_HIDE)) {
// Alternate between word and value parts of object:
if (j == 0) {
Init_Word(vars, REB_WORD, 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_DEAD_END(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_DEAD_END(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 SET_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_DEAD_END(words);
}
if (index == rindex) index++; //the word block has only set-words: foreach [a:] [1 2 3][]
if (!DO_BLOCK(D_OUT, body, 0)) {
if ((err = Check_Error(D_OUT)) >= 0) {
index = rindex;
break;
}
// else CONTINUE:
if (mode == 1) SET_FALSE(D_OUT); // keep the value (for mode == 1)
} else {
err = 0; // prevent later test against uninitialized value
}
if (mode > 0) {
//if (ANY_OBJECT(value)) Trap_Types_DEAD_END(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_CONDITIONAL_FALSE(D_OUT)) {
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(D_OUT)) Append_Value(out, D_OUT); // (mode == 2)
}
skip_hidden: ;
}
// Finish up:
if (mode == 1) {
// Remove hole (updates tail):
if (windex < index) Remove_Series(series, windex, index - windex);
SET_INTEGER(D_OUT, index - windex);
return R_OUT;
}
// If MAP...
if (mode == 2) {
UNSAVE_SERIES(out);
if (err != 2) {
// ...and not BREAK/RETURN:
Set_Block(D_OUT, out);
return R_OUT;
}
}
return R_OUT;
}
//
// Make_Context_For_Action_Push_Partials: C
//
// This creates a FRAME! context with NULLED cells in the unspecialized slots
// that are available to be filled. For partial refinement specializations
// in the action, it will push the refinement to the stack. In this way it
// retains the ordering information implicit in the partial refinements of an
// action's existing specialization.
//
// It is able to take in more specialized refinements on the stack. These
// will be ordered *after* partial specializations in the function already.
// The caller passes in the stack pointer of the lowest priority refinement,
// which goes up to DSP for the highest of those added specializations.
//
// Since this is walking the parameters to make the frame already--and since
// we don't want to bind to anything specialized out (including the ad-hoc
// refinements added on the stack) we go ahead and collect bindings from the
// frame if needed.
//
REBCTX *Make_Context_For_Action_Push_Partials(
const REBVAL *action, // need ->binding, so can't just be a REBACT*
REBDSP lowest_ordered_dsp, // caller can add refinement specializations
struct Reb_Binder *opt_binder,
REBFLGS prep // cell formatting mask bits, result managed if non-stack
){
REBDSP highest_ordered_dsp = DSP;
REBACT *act = VAL_ACTION(action);
REBCNT num_slots = ACT_NUM_PARAMS(act) + 1; // +1 is for CTX_ARCHETYPE()
REBARR *varlist = Make_Array_Core(num_slots, SERIES_MASK_VARLIST);
REBVAL *rootvar = RESET_CELL(
ARR_HEAD(varlist),
REB_FRAME,
CELL_MASK_CONTEXT
);
INIT_VAL_CONTEXT_VARLIST(rootvar, varlist);
INIT_VAL_CONTEXT_PHASE(rootvar, VAL_ACTION(action));
INIT_BINDING(rootvar, VAL_BINDING(action));
const REBVAL *param = ACT_PARAMS_HEAD(act);
REBVAL *arg = rootvar + 1;
const REBVAL *special = ACT_SPECIALTY_HEAD(act); // of exemplar/paramlist
REBCNT index = 1; // used to bind REFINEMENT! values to parameter slots
REBCTX *exemplar = ACT_EXEMPLAR(act); // may be null
if (exemplar)
assert(special == CTX_VARS_HEAD(exemplar));
else
assert(special == ACT_PARAMS_HEAD(act));
for (; NOT_END(param); ++param, ++arg, ++special, ++index) {
arg->header.bits = prep;
if (Is_Param_Hidden(param)) { // specialized out
assert(GET_CELL_FLAG(special, ARG_MARKED_CHECKED));
Move_Value(arg, special); // doesn't copy ARG_MARKED_CHECKED
SET_CELL_FLAG(arg, ARG_MARKED_CHECKED);
continue_specialized:
assert(not IS_NULLED(arg));
assert(GET_CELL_FLAG(arg, ARG_MARKED_CHECKED));
continue; // Eval_Core() double-checks type in debug build
}
assert(NOT_CELL_FLAG(special, ARG_MARKED_CHECKED));
REBSTR *canon = VAL_PARAM_CANON(param); // for adding to binding
if (not TYPE_CHECK(param, REB_TS_REFINEMENT)) { // nothing to push
continue_unspecialized:
assert(arg->header.bits == prep);
Init_Nulled(arg);
if (opt_binder) {
if (not Is_Param_Unbindable(param))
Add_Binder_Index(opt_binder, canon, index);
}
continue;
}
// Unspecialized refinement slots may have an SYM-WORD! in them that
// reflects a partial that needs to be pushed to the stack. (They
// are in *reverse* order of use.)
assert(
(special == param and IS_PARAM(special))
or (IS_SYM_WORD(special) or IS_NULLED(special))
);
if (IS_SYM_WORD(special)) {
REBCNT partial_index = VAL_WORD_INDEX(special);
Init_Any_Word_Bound( // push a SYM-WORD! to data stack
DS_PUSH(),
REB_SYM_WORD,
VAL_STORED_CANON(special),
exemplar,
partial_index
);
}
// Unspecialized or partially specialized refinement. Check the
// passed-in refinements on the stack for usage.
//
REBDSP dsp = highest_ordered_dsp;
for (; dsp != lowest_ordered_dsp; --dsp) {
REBVAL *ordered = DS_AT(dsp);
if (VAL_STORED_CANON(ordered) != canon)
continue; // just continuing this loop
assert(not IS_WORD_BOUND(ordered)); // we bind only one
INIT_BINDING(ordered, varlist);
INIT_WORD_INDEX_UNCHECKED(ordered, index);
if (not Is_Typeset_Invisible(param)) // needs argument
goto continue_unspecialized;
// If refinement named on stack takes no arguments, then it can't
// be partially specialized...only fully, and won't be bound:
//
// specialize 'append/only [only: false] ; only not bound
//
Init_Word(arg, VAL_STORED_CANON(ordered));
Refinify(arg);
SET_CELL_FLAG(arg, ARG_MARKED_CHECKED);
goto continue_specialized;
}
goto continue_unspecialized;
}
TERM_ARRAY_LEN(varlist, num_slots);
MISC_META_NODE(varlist) = nullptr; // GC sees this, we must initialize
// !!! Can't pass SERIES_FLAG_STACK_LIFETIME into Make_Array_Core(),
// because TERM_ARRAY_LEN won't let it set stack array lengths.
//
if (prep & CELL_FLAG_STACK_LIFETIME)
SET_SERIES_FLAG(varlist, STACK_LIFETIME);
INIT_CTX_KEYLIST_SHARED(CTX(varlist), ACT_PARAMLIST(act));
return CTX(varlist);
}
//
// 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
}
*/ REBYTE *Security_Policy(REBCNT sym, REBVAL *name)
/*
** Given a security symbol (like FILE) and a value (like the file
** path) returns the security policy (RWX) allowed for it.
**
** Args:
**
** sym: word that represents the type ['file 'net]
** name: file or path value
**
** Returns BTYE array of flags for the policy class:
**
** flags: [rrrr wwww xxxx ----]
**
** Where each byte is:
** 0: SEC_ALLOW
** 1: SEC_ASK
** 2: SEC_THROW
** 3: SEC_QUIT
**
** The secuity is defined by the system/state/policies object, that
** is of the form:
**
** [
** file: [%file1 tuple-flags %file2 ... default tuple-flags]
** net: [...]
** call: tuple-flags
** stack: tuple-flags
** eval: integer (limit)
** ]
**
***********************************************************************/
{
REBVAL *policy = Get_System(SYS_STATE, STATE_POLICIES);
REBYTE *flags;
REBCNT len;
REBCNT errcode = RE_SECURITY_ERROR;
if (!IS_OBJECT(policy)) goto error;
// Find the security class in the block: (file net call...)
policy = Find_Word_Value(VAL_OBJ_FRAME(policy), sym);
if (!policy) goto error;
// Obtain the policies for it:
// Check for a master tuple: [file rrrr.wwww.xxxx]
if (IS_TUPLE(policy)) return VAL_TUPLE(policy); // non-aligned
// removed A90: if (IS_INTEGER(policy)) return (REBYTE*)VAL_INT64(policy); // probably not used
// Only other form is detailed block:
if (!IS_BLOCK(policy)) goto error;
// Scan block of policies for the class: [file [allow read quit write]]
len = 0; // file or url length
flags = 0; // policy flags
for (policy = VAL_BLK(policy); NOT_END(policy); policy += 2) {
// Must be a policy tuple:
if (!IS_TUPLE(policy+1)) goto error;
// Is it a policy word:
if (IS_WORD(policy)) { // any word works here
// If no strings found, use the default:
if (len == 0) flags = VAL_TUPLE(policy+1); // non-aligned
}
// Is it a string (file or URL):
else if (ANY_BINSTR(policy) && name) {
//Debug_Fmt("sec: %r %r", policy, name);
if (Match_Sub_Path(VAL_SERIES(policy), VAL_SERIES(name))) {
// Is the match adequate?
if (VAL_TAIL(name) >= len) {
len = VAL_TAIL(name);
flags = VAL_TUPLE(policy+1); // non-aligned
}
}
}
else goto error;
}
if (!flags) {
errcode = RE_SECURITY;
policy = name ? name : 0;
error:
if (!policy) {
Init_Word(DS_TOP, sym);
policy = DS_TOP;
}
Trap1(errcode, policy);
}
return flags;
}
