static COMMAND_FUNC( do_disp_obj )
{
Data_Obj *dp;
FILE *fp;
dp=PICK_OBJ("");
if( dp==NO_OBJ ) return;
// We used to insist that the object be in RAM,
// but we make life easier by automatically creating
// a temporary object...
dp = insure_ram_obj(QSP_ARG dp);
if( dp == NO_OBJ ) return;
fp = tell_msgfile(SINGLE_QSP_ARG);
if( fp == stdout ){
if( IS_IMAGE(dp) || IS_SEQUENCE(dp) )
if( !CONFIRM(
"are you sure you want to display an image/sequence in ascii") )
return;
list_dobj(QSP_ARG dp);
}
pntvec(QSP_ARG dp,fp);
fflush(fp);
DELETE_IF_COPY(dp)
}
LOCAL void*
cl_mem_map_auto(cl_mem mem)
{
if (IS_IMAGE(mem) && cl_mem_image(mem)->tiling != CL_NO_TILE)
return cl_mem_map_gtt(mem);
else
return cl_mem_map(mem);
}
LOCAL cl_int
cl_mem_unmap_auto(cl_mem mem)
{
if (IS_IMAGE(mem) && cl_mem_image(mem)->tiling != CL_NO_TILE)
cl_buffer_unmap_gtt(mem->bo);
else
cl_buffer_unmap(mem->bo);
return CL_SUCCESS;
}
static COMMAND_FUNC( do_wrt_obj )
{
Data_Obj *dp;
FILE *fp;
/* BUG what if pathname is longer than 256??? */
const char *filename;
dp=PICK_OBJ("");
filename = NAMEOF("output file");
if( dp==NO_OBJ ) return;
if( strcmp(filename,"-") && strcmp(filename,"stdout") ){
// BUG? we don't check append flag here,
// but there is a separate append command...
fp=TRYNICE( filename, "w" );
if( !fp ) return;
} else {
// If the invoking script has redirected stdout,
// then use that
if( QS_MSG_FILE(THIS_QSP)!=NULL )
fp = QS_MSG_FILE(THIS_QSP);
else
fp = stdout;
}
if( IS_IMAGE(dp) || IS_SEQUENCE(dp) )
if( !CONFIRM(
"are you sure you want to write an image/sequence in ascii") ){
fclose(fp);
return;
}
dp = insure_ram_obj(QSP_ARG dp);
if( dp == NO_OBJ ) return;
pntvec(QSP_ARG dp,fp);
if( fp != stdout && QS_MSG_FILE(THIS_QSP)!=NULL && fp != QS_MSG_FILE(THIS_QSP) ) {
if( verbose ){
sprintf(MSG_STR,"closing file %s",filename);
prt_msg(MSG_STR);
}
fclose(fp);
}
DELETE_IF_COPY(dp)
}
*/ REBINT Compare_Binary_Vals(REBVAL *v1, REBVAL *v2)
/*
** Compare two binary values.
**
** Compares bytes, not chars. Return the difference.
**
** Used for: Binary comparision function
**
***********************************************************************/
{
REBCNT l1 = VAL_LEN(v1);
REBCNT l2 = VAL_LEN(v2);
REBCNT len = MIN(l1, l2);
REBINT n;
if (IS_IMAGE(v1)) len *= 4;
n = memcmp(VAL_BIN_DATA(v1), VAL_BIN_DATA(v2), len);
if (n != 0) return n;
return l1 - l2;
}
static COMMAND_FUNC( do_append )
{
Data_Obj *dp;
FILE *fp;
dp=PICK_OBJ("");
if( dp==NO_OBJ ) return;
if( IS_IMAGE(dp) || IS_SEQUENCE(dp) )
if( !CONFIRM(
"are you sure you want to write an image/sequence in ascii") )
return;
fp=TRYNICE( NAMEOF("output file"), "a" );
if( !fp ) return;
dp = insure_ram_obj(QSP_ARG dp);
if( dp == NO_OBJ ) return;
pntvec(QSP_ARG dp,fp);
fclose(fp);
DELETE_IF_COPY(dp)
}
*/ static REBFLG Set_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
switch (VAL_WORD_CANON(word)) {
case SYM_OFFSET:
return Set_Pair(&(gob->offset), val);
case SYM_SIZE:
return Set_Pair(&gob->size, val);
case SYM_IMAGE:
CLR_GOB_OPAQUE(gob);
if (IS_IMAGE(val)) {
SET_GOB_TYPE(gob, GOBT_IMAGE);
GOB_W(gob) = (REBD32)VAL_IMAGE_WIDE(val);
GOB_H(gob) = (REBD32)VAL_IMAGE_HIGH(val);
GOB_CONTENT(gob) = VAL_SERIES(val);
// if (!VAL_IMAGE_TRANSP(val)) SET_GOB_OPAQUE(gob);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_DRAW:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_DRAW);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_TEXT:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_TEXT);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_STRING(val)) {
SET_GOB_TYPE(gob, GOBT_STRING);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_EFFECT:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_EFFECT);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_COLOR:
CLR_GOB_OPAQUE(gob);
if (IS_TUPLE(val)) {
SET_GOB_TYPE(gob, GOBT_COLOR);
Set_Pixel_Tuple((REBYTE*)&GOB_CONTENT(gob), val);
if (VAL_TUPLE_LEN(val) < 4 || VAL_TUPLE(val)[3] == 0)
SET_GOB_OPAQUE(gob);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
break;
case SYM_PANE:
if (GOB_PANE(gob)) Clear_Series(GOB_PANE(gob));
if (IS_BLOCK(val))
Insert_Gobs(gob, VAL_BLK_DATA(val), 0, VAL_BLK_LEN(val), 0);
else if (IS_GOB(val))
Insert_Gobs(gob, val, 0, 1, 0);
else if (IS_NONE(val))
gob->pane = 0;
else
return FALSE;
break;
case SYM_ALPHA:
GOB_ALPHA(gob) = Clip_Int(Int32(val), 0, 255);
break;
case SYM_DATA:
SET_GOB_DTYPE(gob, GOBD_NONE);
if (IS_OBJECT(val)) {
SET_GOB_DTYPE(gob, GOBD_OBJECT);
SET_GOB_DATA(gob, VAL_OBJ_FRAME(val));
}
else if (IS_BLOCK(val)) {
SET_GOB_DTYPE(gob, GOBD_BLOCK);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_STRING(val)) {
SET_GOB_DTYPE(gob, GOBD_STRING);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_BINARY(val)) {
SET_GOB_DTYPE(gob, GOBD_BINARY);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_INTEGER(val)) {
SET_GOB_DTYPE(gob, GOBD_INTEGER);
SET_GOB_DATA(gob, (void*)(REBIPT)VAL_INT64(val));
}
else if (IS_NONE(val))
SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_FLAGS:
if (IS_WORD(val)) Set_Gob_Flag(gob, val);
else if (IS_BLOCK(val)) {
gob->flags = 0;
for (val = VAL_BLK(val); NOT_END(val); val++) {
if (IS_WORD(val)) Set_Gob_Flag(gob, val);
}
}
break;
case SYM_OWNER:
if (IS_GOB(val))
GOB_TMP_OWNER(gob) = VAL_GOB(val);
else
return FALSE;
break;
default:
return FALSE;
}
return TRUE;
}
*/ static REBFLG Set_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
REBVAL *spec;
REBVAL *hndl;
switch (VAL_WORD_CANON(word)) {
case SYM_OFFSET:
return Set_Pair(&(gob->offset), val);
case SYM_SIZE:
return Set_Pair(&gob->size, val);
case SYM_IMAGE:
CLR_GOB_OPAQUE(gob);
if (IS_IMAGE(val)) {
SET_GOB_TYPE(gob, GOBT_IMAGE);
GOB_W(gob) = (REBD32)VAL_IMAGE_WIDE(val);
GOB_H(gob) = (REBD32)VAL_IMAGE_HIGH(val);
GOB_CONTENT(gob) = VAL_SERIES(val);
// if (!VAL_IMAGE_TRANSP(val)) SET_GOB_OPAQUE(gob);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
#ifdef HAS_WIDGET_GOB
case SYM_WIDGET:
//printf("WIDGET GOB\n");
SET_GOB_TYPE(gob, GOBT_WIDGET);
SET_GOB_OPAQUE(gob);
GOB_CONTENT(gob) = Make_Block(4); // [handle type spec data]
hndl = Append_Value(GOB_CONTENT(gob));
Append_Value(GOB_CONTENT(gob)); // used to cache type on host's side
spec = Append_Value(GOB_CONTENT(gob));
Append_Value(GOB_CONTENT(gob)); // used to cache result data
SET_HANDLE(hndl, 0, SYM_WIDGET, 0);
if (IS_WORD(val) || IS_LIT_WORD(val)) {
Set_Block(spec, Make_Block(1));
Append_Val(VAL_SERIES(spec), val);
}
else if (IS_BLOCK(val)) {
Set_Block(spec, VAL_SERIES(val));
}
else return FALSE;
break;
#endif // HAS_WIDGET_GOB
case SYM_DRAW:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_DRAW);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_TEXT:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_TEXT);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_STRING(val)) {
SET_GOB_TYPE(gob, GOBT_STRING);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_EFFECT:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_EFFECT);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_COLOR:
CLR_GOB_OPAQUE(gob);
if (IS_TUPLE(val)) {
SET_GOB_TYPE(gob, GOBT_COLOR);
Set_Pixel_Tuple((REBYTE*)&GOB_CONTENT(gob), val);
if (VAL_TUPLE_LEN(val) < 4 || VAL_TUPLE(val)[3] == 255)
SET_GOB_OPAQUE(gob);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
break;
case SYM_PANE:
if (GOB_PANE(gob)) Clear_Series(GOB_PANE(gob));
if (IS_BLOCK(val))
Insert_Gobs(gob, VAL_BLK_DATA(val), 0, VAL_BLK_LEN(val), 0);
else if (IS_GOB(val))
Insert_Gobs(gob, val, 0, 1, 0);
else if (IS_NONE(val))
gob->pane = 0;
else
return FALSE;
break;
case SYM_ALPHA:
GOB_ALPHA(gob) = Clip_Int(Int32(val), 0, 255);
break;
case SYM_DATA:
#ifdef HAS_WIDGET_GOB
if (GOB_TYPE(gob) == GOBT_WIDGET) {
OS_SET_WIDGET_DATA(gob, val);
} else {
#endif
SET_GOB_DTYPE(gob, GOBD_NONE);
if (IS_OBJECT(val)) {
SET_GOB_DTYPE(gob, GOBD_OBJECT);
SET_GOB_DATA(gob, VAL_OBJ_FRAME(val));
}
else if (IS_BLOCK(val)) {
SET_GOB_DTYPE(gob, GOBD_BLOCK);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_STRING(val)) {
SET_GOB_DTYPE(gob, GOBD_STRING);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_BINARY(val)) {
SET_GOB_DTYPE(gob, GOBD_BINARY);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_INTEGER(val)) {
SET_GOB_DTYPE(gob, GOBD_INTEGER);
SET_GOB_DATA(gob, (void*)(REBIPT)VAL_INT64(val));
}
else if (IS_NONE(val))
SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
#ifdef HAS_WIDGET_GOB
}
#endif
break;
case SYM_FLAGS:
if (IS_WORD(val)) Set_Gob_Flag(gob, val);
else if (IS_BLOCK(val)) {
gob->flags = 0;
for (val = VAL_BLK(val); NOT_END(val); val++) {
if (IS_WORD(val)) Set_Gob_Flag(gob, val);
}
}
break;
case SYM_OWNER:
if (IS_GOB(val))
GOB_TMP_OWNER(gob) = VAL_GOB(val);
else
return FALSE;
break;
default:
return FALSE;
}
return TRUE;
}
int xform_chk(Data_Obj *dpto,Data_Obj *dpfr,Data_Obj *xform)
{
if( dpto==NO_OBJ || dpfr==NO_OBJ || xform==NO_OBJ )
return(-1);
if( !IS_IMAGE(xform) ){
sprintf(DEFAULT_ERROR_STRING,
"xform_chk: transformation %s must be a matrix (image)",
OBJ_NAME(xform));
NWARN(DEFAULT_ERROR_STRING);
return(-1);
}
if( OBJ_COMPS(xform) != 1 ){
sprintf(DEFAULT_ERROR_STRING,
"xform_chk: transform matrix %s must have single-component elements",OBJ_NAME(xform));
NWARN(DEFAULT_ERROR_STRING);
return(-1);
}
if( OBJ_COMPS(dpto) != OBJ_ROWS(xform) ){
sprintf(DEFAULT_ERROR_STRING,
"xform_chk: target %s component dimension (%d) must match # rows of xform %s (%d)",
OBJ_NAME(dpto),OBJ_COMPS(dpto),OBJ_NAME(xform),OBJ_ROWS(xform));
NWARN(DEFAULT_ERROR_STRING);
return(-1);
}
if( OBJ_COMPS(dpfr) != OBJ_COLS(xform) ){
sprintf(DEFAULT_ERROR_STRING,
"xform_chk: source %s component dimension (%d) must match # columns of xform %s (%d)",
OBJ_NAME(dpto),OBJ_COMPS(dpto),OBJ_NAME(xform),OBJ_ROWS(xform));
NWARN(DEFAULT_ERROR_STRING);
return(-1);
}
if( OBJ_N_TYPE_ELTS(dpto)/OBJ_COMPS(dpto) != OBJ_N_TYPE_ELTS(dpfr)/OBJ_COMPS(dpfr) ){
sprintf(DEFAULT_ERROR_STRING,
"xform_chk: target %s (%d/%d) and source %s (%d/%d) must have same # of elements",
OBJ_NAME(dpto),OBJ_N_TYPE_ELTS(dpto),OBJ_COMPS(dpto),
OBJ_NAME(dpfr),OBJ_N_TYPE_ELTS(dpfr),OBJ_COMPS(dpfr));
NWARN(DEFAULT_ERROR_STRING);
return(-1);
}
/* BUG these contiguity requirements may no longer be necessary... */
if( !is_contiguous(DEFAULT_QSP_ARG dpto) ){
sprintf(DEFAULT_ERROR_STRING,
"xform_chk: xform target %s must be contiguous",OBJ_NAME(dpto));
NWARN(DEFAULT_ERROR_STRING);
return(-1);
}
if( !is_contiguous(DEFAULT_QSP_ARG dpfr) ){
sprintf(DEFAULT_ERROR_STRING,
"xform_chk: xform source %s must be contiguous",OBJ_NAME(dpfr));
NWARN(DEFAULT_ERROR_STRING);
return(-1);
}
if( !is_contiguous(DEFAULT_QSP_ARG xform) ){
sprintf(DEFAULT_ERROR_STRING,
"xform_chk: xform %s must be contiguous",OBJ_NAME(xform));
NWARN(DEFAULT_ERROR_STRING);
return(-1);
}
return(0);
} // end xform_chk
*/ 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;
}
*/ REBINT Effect_Gob(void *effects, REBSER *block)
/*
** Handles all commands for the EFFECT dialect as specified
** in the system/dialects/effect object.
**
** This function calls the REBOL_Dialect interpreter to
** parse the dialect and build and return the command number
** (the index offset in the draw object above) and a block
** of arguments. (For now, just a REBOL block, but this could
** be changed to isolate it from changes in REBOL's internals).
**
** Each arg will be of the specified datatype (given in the
** dialect) or NONE when no argument of that type was given
** and this code must determine the proper default value.
**
** If the cmd result is zero, then it is either the end of
** the block, or an error has occurred. If the error value
** is non-zero, then it was an error.
**
***********************************************************************/
{
// REBSER *block;
REBCNT index = 0;
REBINT cmd;
REBSER *args = 0;
REBVAL *arg;
REBCNT nargs;
//default values
REBYTE def_color1[4] = {0,0,0,0};
REBYTE def_color2[4] = {255,255,255,0};
REBPAR def_pair = {1,0};
do {
cmd = Reb_Dialect(DIALECTS_EFFECT, block, &index, &args);
if (cmd == 0) return 0;
if (cmd < 0) {
// Reb_Print("ERROR: %d, Index %d", -cmd, index);
return -((REBINT)index+1);
}
// else
// Reb_Print("EFFECT: Cmd %d, Index %d, Args %m", cmd, index, args);
arg = BLK_HEAD(args);
nargs = SERIES_TAIL(args);
// Reb_Print("Number of args: %d", nargs);
switch (cmd) {
case EW_ADD:
FX_Add(effects, ARG_OPT_IMAGE(0), ARG_OPT_IMAGE(1));
break;
case EW_ALPHAMUL:
if (IS_IMAGE(arg))
FX_Alphamul(effects, ARG_IMAGE(0), IS_NONE(arg+1) ? 127 : ARG_INTEGER(1));
break;
case EW_ASPECT:
{
REBINT type = 1, mode = 2;
if (ARG_WORD(0) == EW_RESAMPLE){
type = 2;
mode = 1;
}
FX_Fit(effects,ARG_OPT_IMAGE(0), ARG_WORDS(type,EW_NEAREST,EW_GAUSSIAN), ARG_WORD(mode) == EW_RESAMPLE, IS_NONE(arg+3) ? 1.0 : ARG_DECIMAL(3), TRUE);
}
break;
case EW_BLUR:
// FX_Blur(effects, ARG_OPT_IMAGE(0));
{
REBDEC filter[9] = {0, 1, 0, 1, 1, 1, 0, 1, 0};
FX_Convolve(effects, ARG_OPT_IMAGE(0),filter , 5.0, 0, FALSE);
}
break;
case EW_COLORIFY:
FX_Colorify(effects, IS_NONE(arg+1) ? def_color2 : ARG_TUPLE(1) , IS_NONE(arg+2) ? 255 : max(0, min(255,ARG_INTEGER(2))), ARG_OPT_IMAGE(0));
break;
case EW_COLORIZE:
FX_Colorize(effects, IS_NONE(arg+1) ? def_color2 : ARG_TUPLE(1) , ARG_OPT_IMAGE(0));
break;
case EW_CONTRAST:
FX_Contrast(effects, IS_NONE(arg+1) ? 127 : ARG_INTEGER(1), ARG_OPT_IMAGE(0));
break;
case EW_CONVOLVE:
//[image! block! decimal! decimal! logic!]
if (IS_BLOCK(arg+1)) {
REBDEC filter[9];
REBSER* mtx = (REBSER*)ARG_BLOCK(1);
REBVAL* slot = BLK_HEAD(mtx);
REBCNT len = SERIES_TAIL(mtx) ,i, num = 0;
for (i = 0;i<len;i++){
if (IS_DECIMAL(slot+i))
filter[i] = VAL_DECIMAL(slot+i);
else if (IS_INTEGER(slot+i))
filter[i] = VAL_INT32(slot+i);
else
return -cmd;
num++;
}
if (num != 9) return -cmd;
FX_Convolve(effects, ARG_OPT_IMAGE(0),filter , ARG_DECIMAL(2), ARG_INTEGER(3), ARG_LOGIC(4));
}
break;
case EW_CROP:
FX_Crop(effects,ARG_OPT_IMAGE(0), IS_NONE(arg+1) ? 0 : &ARG_PAIR(1), IS_NONE(arg+2) ? 0 : &ARG_PAIR(2));
break;
case EW_DIFFERENCE:
FX_Difference(effects, IS_NONE(arg+2) ? def_color2 : ARG_TUPLE(2), ARG_OPT_IMAGE(0), ARG_OPT_IMAGE(1), (IS_NONE(arg+2)) ? 1 : 0);
break;
case EW_EMBOSS:
{
REBDEC filter[9] = {-1, 0, 1, -2, 0, 2, -1, 0, 1};
FX_Convolve(effects, ARG_OPT_IMAGE(0),filter , 6.0, 127, FALSE);
}
break;
case EW_EXTEND:
FX_Extend(effects,ARG_OPT_IMAGE(0), IS_NONE(arg+1) ? 0 : &ARG_PAIR(1), IS_NONE(arg+2) ? 0 : &ARG_PAIR(2));
break;
case EW_FIT:
if (IS_IMAGE(arg)){
REBINT type = 1, mode = 2;
if (ARG_WORD(0) == EW_RESAMPLE){
type = 2;
mode = 1;
}
FX_Fit(effects,ARG_IMAGE(0), ARG_WORDS(type,EW_NEAREST,EW_GAUSSIAN), ARG_WORD(mode) == EW_RESAMPLE, IS_NONE(arg+3) ? 1.0 : ARG_DECIMAL(3), FALSE);
}
break;
case EW_FLIP:
FX_Flip(effects, IS_NONE(arg+1) ? &def_pair : &ARG_PAIR(1), ARG_OPT_IMAGE(0));
break;
case EW_GRADCOL:
FX_Gradcol(effects, &ARG_PAIR(1), IS_NONE(arg+2) ? def_color1 : ARG_TUPLE(2), IS_NONE(arg+3) ? def_color2 : ARG_TUPLE(3),ARG_OPT_IMAGE(0));
break;
case EW_GRADIENT:
FX_Gradient(effects, &ARG_PAIR(1), IS_NONE(arg+2) ? def_color1 : ARG_TUPLE(2), IS_NONE(arg+3) ? def_color2 : ARG_TUPLE(3), ARG_OPT_IMAGE(0));
break;
case EW_GRADMUL:
FX_Gradmul(effects, &ARG_PAIR(1), IS_NONE(arg+2) ? def_color1 : ARG_TUPLE(2), IS_NONE(arg+3) ? def_color2 : ARG_TUPLE(3), ARG_OPT_IMAGE(0));
break;
case EW_GRAYSCALE:
FX_Grayscale(effects,ARG_OPT_IMAGE(0));
break;
case EW_HSV:
FX_HSV(effects, IS_NONE(arg+1) ? def_color2 : ARG_TUPLE(1), ARG_OPT_IMAGE(0));
break;
case EW_INVERT:
FX_Invert(effects,ARG_OPT_IMAGE(0));
break;
case EW_KEY:
if (IS_IMAGE(arg))
FX_Key(effects, IS_NONE(arg+1) ? def_color1 : ARG_TUPLE(1), ARG_IMAGE(0));
break;
case EW_LUMA:
FX_Luma(effects, IS_NONE(arg+1) ? 127 : ARG_INTEGER(1),ARG_OPT_IMAGE(0));
break;
case EW_MIX:
FX_Mix(effects, ARG_OPT_IMAGE(0), ARG_OPT_IMAGE(1));
break;
case EW_MULTIPLY:
{
REBINT i = 0x00FFFFFF;
REBYTE* color = (REBYTE*)&i;
if (IS_INTEGER(arg+3)) {
i = ARG_INTEGER(3);
i = i + (i << 8) + (i << 16);
} else if (IS_TUPLE(arg+2))
color = ARG_TUPLE(2);
FX_Multiply(effects, color ,ARG_OPT_IMAGE(0), ARG_OPT_IMAGE(1), (IS_NONE(arg+2) && IS_NONE(arg+3)) ? 1 : 0);
}
break;
case EW_REFLECT:
FX_Reflect(effects, IS_NONE(arg+1) ? &def_pair : &ARG_PAIR(1), ARG_OPT_IMAGE(0));
break;
case EW_ROTATE:
FX_Rotate(effects, IS_NONE(arg+1) ? 90 : ARG_INTEGER(1), ARG_OPT_IMAGE(0));
break;
case EW_SHADOW:
if (IS_IMAGE(arg))
FX_Shadow(effects, ARG_IMAGE(0), IS_NONE(arg+1) ? 0 : &ARG_PAIR(1), IS_NONE(arg+2) ? 0 : &ARG_PAIR(2), IS_NONE(arg+3) ? 0 : ARG_TUPLE(3), IS_NONE(arg+4) ? 0 : ARG_DECIMAL(4), IS_NONE(arg+5) ? 0 : ARG_WORD(5) == EW_ONLY);
break;
case EW_SHARPEN:
// FX_Sharpen(effects, ARG_OPT_IMAGE(0));
{
REBDEC filter[9] = {0, -1, 0, -1, 8, -1, 0, -1, 0};
FX_Convolve(effects, ARG_OPT_IMAGE(0),filter , 4.0, 0, FALSE);
}
break;
case EW_TILE:
if (IS_IMAGE(arg))
FX_Tile(effects, ARG_IMAGE(0), &ARG_PAIR(1));
break;
case EW_TILE_VIEW:
if (IS_IMAGE(arg)) {
REBPAR p;
Effect_Offset(effects, &p);
FX_Tile(effects, ARG_IMAGE(0), &p);
}
break;
case EW_TINT:
FX_Tint(effects, IS_NONE(arg+1) ? 127 : ARG_INTEGER(1),ARG_OPT_IMAGE(0));
break;
}
} while (TRUE);
}
*/ static REB_R Loop_Each(struct Reb_Call *call_, LOOP_MODE mode)
/*
** Common implementation code of FOR-EACH, REMOVE-EACH, MAP-EACH,
** and EVERY.
**
***********************************************************************/
{
REBSER *body;
REBVAL *vars;
REBVAL *words;
REBSER *frame;
// `data` is the series/object/map/etc. being iterated over
// Note: `data_is_object` flag is optimized out, but hints static analyzer
REBVAL *data = D_ARG(2);
REBSER *series;
const REBOOL data_is_object = ANY_OBJECT(data);
REBSER *out; // output block (needed for MAP-EACH)
REBINT index; // !!!! should these be REBCNT?
REBINT tail;
REBINT windex; // write
REBINT rindex; // read
REBOOL break_with = FALSE;
REBOOL every_true = TRUE;
REBCNT i;
REBCNT j;
REBVAL *ds;
if (IS_NONE(data)) return R_NONE;
body = Init_Loop(D_ARG(1), D_ARG(3), &frame); // vars, body
Val_Init_Object(D_ARG(1), frame); // keep GC safe
Val_Init_Block(D_ARG(3), body); // keep GC safe
SET_NONE(D_OUT); // Default result to NONE if the loop does not run
if (mode == LOOP_MAP_EACH) {
// Must be managed *and* saved...because we are accumulating results
// into it, and those results must be protected from GC
// !!! This means we cannot Free_Series in case of a BREAK, we
// have to leave it to the GC. Should there be a variant which
// lets a series be a GC root for a temporary time even if it is
// not SER_KEEP?
out = Make_Array(VAL_LEN(data));
MANAGE_SERIES(out);
SAVE_SERIES(out);
}
// Get series info:
if (data_is_object) {
series = VAL_OBJ_FRAME(data);
out = FRM_WORD_SERIES(series); // words (the out local reused)
index = 1;
//if (frame->tail > 3) raise Error_Invalid_Arg(FRM_WORD(frame, 3));
}
else if (IS_MAP(data)) {
series = VAL_SERIES(data);
index = 0;
//if (frame->tail > 3) raise Error_Invalid_Arg(FRM_WORD(frame, 3));
}
else {
series = VAL_SERIES(data);
index = VAL_INDEX(data);
if (index >= cast(REBINT, SERIES_TAIL(series))) {
if (mode == LOOP_REMOVE_EACH) {
SET_INTEGER(D_OUT, 0);
}
else if (mode == LOOP_MAP_EACH) {
UNSAVE_SERIES(out);
Val_Init_Block(D_OUT, out);
}
return R_OUT;
}
}
windex = index;
// Iterate over each value in the data 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(data)) {
*vars = *BLK_SKIP(series, index);
}
else if (data_is_object) {
if (!VAL_GET_EXT(BLK_SKIP(out, index), EXT_WORD_HIDE)) {
// Alternate between word and value parts of object:
if (j == 0) {
Val_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
raise Error_Invalid_Arg(words);
j++;
}
else {
// Do not evaluate this iteration
index++;
goto skip_hidden;
}
}
else if (IS_VECTOR(data)) {
Set_Vector_Value(vars, series, index);
}
else if (IS_MAP(data)) {
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
raise Error_Invalid_Arg(words);
j++;
}
else {
index += 2;
goto skip_hidden;
}
}
else { // A string or binary
if (IS_BINARY(data)) {
SET_INTEGER(vars, (REBI64)(BIN_HEAD(series)[index]));
}
else if (IS_IMAGE(data)) {
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(data) || IS_MAP(data))
*vars = *data;
else
Val_Init_Block_Index(vars, series, index);
//if (index < tail) index++; // do not increment block.
}
else
raise Error_Invalid_Arg(words);
}
if (index == rindex) {
// the word block has only set-words: for-each [a:] [1 2 3][]
index++;
}
if (Do_Block_Throws(D_OUT, body, 0)) {
if (IS_WORD(D_OUT) && VAL_WORD_SYM(D_OUT) == SYM_CONTINUE) {
if (mode == LOOP_REMOVE_EACH) {
// signal the post-body-execution processing that we
// *do not* want to remove the element on a CONTINUE
SET_FALSE(D_OUT);
}
else {
// CONTINUE otherwise acts "as if" the loop body execution
// returned an UNSET!
SET_UNSET(D_OUT);
}
}
else if (IS_WORD(D_OUT) && VAL_WORD_SYM(D_OUT) == SYM_BREAK) {
// If it's a BREAK, get the /WITH value (UNSET! if no /WITH)
// Though technically this doesn't really tell us if a
// BREAK/WITH happened, as you can BREAK/WITH an UNSET!
TAKE_THROWN_ARG(D_OUT, D_OUT);
if (!IS_UNSET(D_OUT))
break_with = TRUE;
index = rindex;
break;
}
else {
// Any other kind of throw, with a WORD! name or otherwise...
index = rindex;
break;
}
}
switch (mode) {
case LOOP_FOR_EACH:
// no action needed after body is run
break;
case LOOP_REMOVE_EACH:
// If FALSE return, copy values to the write location
// !!! Should UNSET! also act as conditional false here? Error?
if (IS_CONDITIONAL_FALSE(D_OUT)) {
REBYTE wide = SERIES_WIDE(series);
// memory areas may overlap, so use memmove and not memcpy!
// !!! This seems a slow way to do it, but there's probably
// not a lot that can be done as the series is expected to
// be in a good state for the next iteration of the body. :-/
memmove(
series->data + (windex * wide),
series->data + (rindex * wide),
(index - rindex) * wide
);
windex += index - rindex;
}
break;
case LOOP_MAP_EACH:
// anything that's not an UNSET! will be added to the result
if (!IS_UNSET(D_OUT)) Append_Value(out, D_OUT);
break;
case LOOP_EVERY:
if (every_true) {
// !!! This currently treats UNSET! as true, which ALL
// effectively does right now. That's likely a bad idea.
// When ALL changes, so should this.
//
every_true = IS_CONDITIONAL_TRUE(D_OUT);
}
break;
default:
assert(FALSE);
}
skip_hidden: ;
}
switch (mode) {
case LOOP_FOR_EACH:
// Nothing to do but return last result (will be UNSET! if an
// ordinary BREAK was used, the /WITH if a BREAK/WITH was used,
// and an UNSET! if the last loop iteration did a CONTINUE.)
return R_OUT;
case LOOP_REMOVE_EACH:
// Remove hole (updates tail):
if (windex < index) Remove_Series(series, windex, index - windex);
SET_INTEGER(D_OUT, index - windex);
return R_OUT;
case LOOP_MAP_EACH:
UNSAVE_SERIES(out);
if (break_with) {
// If BREAK is given a /WITH parameter that is not an UNSET!, it
// is assumed that you want to override the accumulated mapped
// data so far and return the /WITH value. (which will be in
// D_OUT when the loop above is `break`-ed)
// !!! Would be nice if we could Free_Series(out), but it is owned
// by GC (we had to make it that way to use SAVE_SERIES on it)
return R_OUT;
}
// If you BREAK/WITH an UNSET! (or just use a BREAK that has no
// /WITH, which is indistinguishable in the thrown value) then it
// returns the accumulated results so far up to the break.
Val_Init_Block(D_OUT, out);
return R_OUT;
case LOOP_EVERY:
// Result is the cumulative TRUE? state of all the input (with any
// unsets taken out of the consideration). The last TRUE? input
// if all valid and NONE! otherwise. (Like ALL.) If the loop
// never runs, `every_true` will be TRUE *but* D_OUT will be NONE!
if (!every_true)
SET_NONE(D_OUT);
return R_OUT;
}
DEAD_END;
}