//
// Min_Max_Pair: C
//
void Min_Max_Pair(REBVAL *out, const REBVAL *a, const REBVAL *b, REBOOL maxed)
{
REBXYF aa;
if (IS_PAIR(a)) {
aa.x = VAL_PAIR_X(a);
aa.y = VAL_PAIR_Y(a);
}
else if (IS_INTEGER(a))
aa.x = aa.y = cast(REBDEC, VAL_INT64(a));
else
fail (Error_Invalid_Arg(a));
REBXYF bb;
if (IS_PAIR(b)) {
bb.x = VAL_PAIR_X(b);
bb.y = VAL_PAIR_Y(b);
}
else if (IS_INTEGER(b))
bb.x = bb.y = cast(REBDEC, VAL_INT64(b));
else
fail (Error_Invalid_Arg(b));
if (maxed)
SET_PAIR(out, MAX(aa.x, bb.x), MAX(aa.y, bb.y));
else
SET_PAIR(out, MIN(aa.x, bb.x), MIN(aa.y, bb.y));
}
//
// Min_Max_Pair: C
//
void Min_Max_Pair(REBVAL *out, const REBVAL *a, const REBVAL *b, REBFLG maxed)
{
REBXYF aa;
REBXYF bb;
REBXYF *cc;
if (IS_PAIR(a))
aa = VAL_PAIR(a);
else if (IS_INTEGER(a))
aa.x = aa.y = (REBD32)VAL_INT64(a);
else
fail (Error_Invalid_Arg(a));
if (IS_PAIR(b))
bb = VAL_PAIR(b);
else if (IS_INTEGER(b))
bb.x = bb.y = (REBD32)VAL_INT64(b);
else
fail (Error_Invalid_Arg(b));
SET_TYPE(out, REB_PAIR);
cc = &VAL_PAIR(out);
if (maxed) {
cc->x = MAX(aa.x, bb.x);
cc->y = MAX(aa.y, bb.y);
}
else {
cc->x = MIN(aa.x, bb.x);
cc->y = MIN(aa.y, bb.y);
}
}
*/ REBINT Min_Max_Pair(REBVAL *ds, REBFLG maxed)
/*
***********************************************************************/
{
REBXYF aa;
REBXYF bb;
REBXYF *cc;
REBVAL *a = D_ARG(1);
REBVAL *b = D_ARG(2);
REBVAL *c = D_RET;
if (IS_PAIR(a)) aa = VAL_PAIR(a);
else if (IS_INTEGER(a)) aa.x = aa.y = (REBD32)VAL_INT64(a);
else Trap_Arg(a);
if (IS_PAIR(b)) bb = VAL_PAIR(b);
else if (IS_INTEGER(b)) bb.x = bb.y = (REBD32)VAL_INT64(b);
else Trap_Arg(b);
cc = &VAL_PAIR(c);
if (maxed) {
cc->x = MAX(aa.x, bb.x);
cc->y = MAX(aa.y, bb.y);
}
else {
cc->x = MIN(aa.x, bb.x);
cc->y = MIN(aa.y, bb.y);
}
SET_TYPE(c, REB_PAIR);
return R_RET;
}
SCM last(SCM l) {
SCM p = l;
if (!(IS_PAIR(p) || IS_NULL(p)))
wta_error("last", 1);
if (IS_PAIR(p))
while (IS_PAIR(CDR(p)))
p = CDR(p);
return p;
}
int check_nargs(char *fname, SCM args, int min, int max) {
if (!(IS_PAIR(args) || IS_NULL(args)))
error0("wrong arguments");
int i;
for (i = 0; IS_PAIR(args); i++)
args = CDR(args);
if (!IS_NULL(args))
error0("wrong arguments");
if (!((min <= i) && (i <= max)))
wna_error(fname, i);
return i;
}
*/ REBFLG MT_Pair(REBVAL *out, REBVAL *data, REBCNT type)
/*
***********************************************************************/
{
REBD32 x;
REBD32 y;
if (IS_PAIR(data)) {
*out = *data;
return TRUE;
}
if (!IS_BLOCK(data)) return FALSE;
data = VAL_BLK_DATA(data);
if (IS_INTEGER(data)) x = (REBD32)VAL_INT64(data);
else if (IS_DECIMAL(data)) x = (REBD32)VAL_DECIMAL(data);
else return FALSE;
data++;
if (IS_INTEGER(data)) y = (REBD32)VAL_INT64(data);
else if (IS_DECIMAL(data)) y = (REBD32)VAL_DECIMAL(data);
else return FALSE;
VAL_SET(out, REB_PAIR);
VAL_PAIR_X(out) = x;
VAL_PAIR_Y(out) = y;
return TRUE;
}
void _show(value_t p, FILE* stream) {
if (IS_FIXNUM(p)) {
fprintf(stream, "%ld", VALUE_TO_FIXNUM(p));
} else if (IS_PAIR(p)) {
pair_t pair = VALUE_TO_PAIR(p);
fprintf(stream, "(");
_show(pair.first, stream);
fprintf(stream, " ");
_show(pair.second, stream);
fprintf(stream, ")");
} else if (IS_CLOSURE(p)) {
fprintf(stream, "#<closure 0x%08lx>", p);
} else if (IS_IMMEDIATE(p)) {
if (p == BOOL_F) {
fprintf(stream, "#f");
} else if (p == BOOL_T) {
fprintf(stream, "#t");
} else if (p == NIL) {
fprintf(stream, "()");
} else {
fprintf(stream, "#<immediate 0x%08lx>", p);
}
} else {
fprintf(stream, "#<unknown 0x%08lx>", p);
}
}
//
// MT_Pair: C
//
REBFLG MT_Pair(REBVAL *out, REBVAL *data, enum Reb_Kind type)
{
REBD32 x;
REBD32 y;
if (IS_PAIR(data)) {
*out = *data;
return TRUE;
}
if (!IS_BLOCK(data)) return FALSE;
data = VAL_ARRAY_AT(data);
if (IS_INTEGER(data)) x = (REBD32)VAL_INT64(data);
else if (IS_DECIMAL(data)) x = (REBD32)VAL_DECIMAL(data);
else return FALSE;
data++;
if (IS_END(data))
return FALSE;
if (IS_INTEGER(data)) y = (REBD32)VAL_INT64(data);
else if (IS_DECIMAL(data)) y = (REBD32)VAL_DECIMAL(data);
else return FALSE;
VAL_RESET_HEADER(out, REB_PAIR);
VAL_PAIR_X(out) = x;
VAL_PAIR_Y(out) = y;
return TRUE;
}
// Handy for pretty-printing local variables in an env
char* print_env(cell c) {
if (!buf) {
buf = GC_MALLOC(64);
buf_len = 64;
}
buf_index = 0;
catf("(");
while (IS_PAIR(c)) {
if (!IS_PAIR(car(c))) break;
if (TYPE(caar(c)) != SYMBOL) break;
if (!strcmp(SYM_STR(caar(c)), "GLOBALS")) break;
catf("\n%20s . ", SYM_STR(caar(c)));
print(cadr(c));
c = cdr(c);
}
catf(")");
return buf;
}
int memq(SCM key, SCM list) {
SCM l = list;
while (!IS_NULL(l)) {
if (!(IS_PAIR(l) || IS_NULL(l))) wta_error ("memq", 2);
if EQ(key, CAR(l)) return 1;
l = CDR(l);
}
return 0;
}
//
// CT_Pair: C
//
REBINT CT_Pair(REBVAL *a, REBVAL *b, REBINT mode)
{
if (mode >= 0) return Cmp_Pair(a, b) == 0; // works for INTEGER=0 too (spans x y)
if (IS_PAIR(b) && 0 == VAL_INT64(b)) { // for negative? and positive?
if (mode == -1)
return (VAL_PAIR_X(a) >= 0 || VAL_PAIR_Y(a) >= 0); // not LT
return (VAL_PAIR_X(a) > 0 && VAL_PAIR_Y(a) > 0); // NOT LTE
}
return -1;
}
SCM map1(SCM (*f)(SCM), SCM list) {
SCM l = list;
if (IS_PAIR(l)) {
SCM h, p;
p = CONS(f(CAR(l)), NIL);
h = p;
l = CDR(l);
while (!IS_NULL(l)) {
SCM n = CONS(f(CAR(l)), NIL);
CDR(p) = n;
p = n;
}
return h;
}
else
return NIL;
}
*/ static REBFLG Set_Pair(REBXYF *pair, REBVAL *val)
/*
***********************************************************************/
{
if (IS_PAIR(val)) {
pair->x = VAL_PAIR_X(val);
pair->y = VAL_PAIR_Y(val);
}
else if (IS_INTEGER(val)) {
pair->x = pair->y = (REBD32)VAL_INT64(val);
}
else if (IS_DECIMAL(val)) {
pair->x = pair->y = (REBD32)VAL_DECIMAL(val);
}
else
return FALSE;
return TRUE;
}
*/ REBINT PD_Gob(REBPVS *pvs)
/*
***********************************************************************/
{
REBGOB *gob = VAL_GOB(pvs->value);
REBCNT index;
REBCNT tail;
if (IS_WORD(pvs->select)) {
if (pvs->setval == 0 || NOT_END(pvs->path+1)) {
if (!Get_GOB_Var(gob, pvs->select, pvs->store)) return PE_BAD_SELECT;
// Check for SIZE/X: types of cases:
if (pvs->setval && IS_PAIR(pvs->store)) {
REBVAL *sel = pvs->select;
pvs->value = pvs->store;
Next_Path(pvs); // sets value in pvs->store
Set_GOB_Var(gob, sel, pvs->store); // write it back to gob
}
return PE_USE;
} else {
if (!Set_GOB_Var(gob, pvs->select, pvs->setval)) return PE_BAD_SET;
return PE_OK;
}
}
if (IS_INTEGER(pvs->select)) {
if (!GOB_PANE(gob)) return PE_NONE;
tail = GOB_PANE(gob) ? GOB_TAIL(gob) : 0;
index = VAL_GOB_INDEX(pvs->value);
index += Int32(pvs->select) - 1;
if (index >= tail) return PE_NONE;
gob = *GOB_SKIP(gob, index);
index = 0;
VAL_SET(pvs->store, REB_GOB);
VAL_GOB(pvs->store) = gob;
VAL_GOB_INDEX(pvs->store) = 0;
return PE_USE;
}
return PE_BAD_SELECT;
}
//
// MAKE_Pair: C
//
void MAKE_Pair(REBVAL *out, enum Reb_Kind type, const REBVAL *arg)
{
if (IS_PAIR(arg)) {
*out = *arg;
return;
}
if (IS_STRING(arg)) {
//
// -1234567890x-1234567890
//
REBCNT len;
REBYTE *bp
= Temp_Byte_Chars_May_Fail(arg, VAL_LEN_AT(arg), &len, FALSE);
if (!Scan_Pair(bp, len, out)) goto bad_make;
return;
}
REBDEC x;
REBDEC y;
if (IS_INTEGER(arg)) {
x = VAL_INT32(arg);
y = VAL_INT32(arg);
}
else if (IS_DECIMAL(arg)) {
x = VAL_DECIMAL(arg);
y = VAL_DECIMAL(arg);
}
else if (IS_BLOCK(arg) && VAL_LEN_AT(arg) == 2) {
RELVAL *item = VAL_ARRAY_AT(arg);
if (IS_INTEGER(item))
x = cast(REBDEC, VAL_INT64(item));
else if (IS_DECIMAL(item))
x = cast(REBDEC, VAL_DECIMAL(item));
else
goto bad_make;
++item;
if (IS_END(item))
goto bad_make;
if (IS_INTEGER(item))
y = cast(REBDEC, VAL_INT64(item));
else if (IS_DECIMAL(item))
y = cast(REBDEC, VAL_DECIMAL(item));
else
goto bad_make;
}
else
goto bad_make;
SET_PAIR(out, x, y);
return;
bad_make:
fail (Error_Bad_Make(REB_PAIR, arg));
}
*/ REBINT Text_Gob(void *richtext, REBSER *block)
/*
** Handles all commands for the TEXT dialect as specified
** in the system/dialects/text object.
**
** This function calls the REBOL_Dialect interpreter to
** parse the dialect and build and return the command number
** (the index offset in the text 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.
**
***********************************************************************/
{
REBCNT index = 0;
REBINT cmd;
REBSER *args = 0;
REBVAL *arg;
REBCNT nargs;
//font object conversion related values
REBFNT* font;
REBVAL* val;
REBPAR offset;
REBPAR space;
//para object conversion related values
REBPRA* para;
REBPAR origin;
REBPAR margin;
REBPAR indent;
REBPAR scroll;
do {
cmd = Reb_Dialect(DIALECTS_TEXT, 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("TEXT: 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 TW_TYPE_SPEC:
if (IS_STRING(arg)) {
rt_text(richtext, ARG_STRING(0), index);
} else if (IS_TUPLE(arg)) {
rt_color(richtext, ARG_TUPLE(0));
}
break;
case TW_ANTI_ALIAS:
rt_anti_alias(richtext, ARG_OPT_LOGIC(0));
break;
case TW_SCROLL:
rt_scroll(richtext, ARG_PAIR(0));
break;
case TW_BOLD:
case TW_B:
rt_bold(richtext, ARG_OPT_LOGIC(0));
break;
case TW_ITALIC:
case TW_I:
rt_italic(richtext, ARG_OPT_LOGIC(0));
break;
case TW_UNDERLINE:
case TW_U:
rt_underline(richtext, ARG_OPT_LOGIC(0));
break;
case TW_CENTER:
rt_center(richtext);
break;
case TW_LEFT:
rt_left(richtext);
break;
case TW_RIGHT:
rt_right(richtext);
break;
case TW_FONT:
if (!IS_OBJECT(arg)) break;
font = (REBFNT*)rt_get_font(richtext);
val = BLK_HEAD(ARG_OBJECT(0))+1;
if (IS_STRING(val)) {
font->name = VAL_STRING(val);
}
// Reb_Print("font/name: %s", font->name);
val++;
if (IS_BLOCK(val)) {
REBSER* styles = VAL_SERIES(val);
REBVAL* slot = BLK_HEAD(styles);
REBCNT len = SERIES_TAIL(styles) ,i;
for (i = 0;i<len;i++){
if (IS_WORD(slot+i)){
set_font_styles(font, slot+i);
}
}
} else if (IS_WORD(val)) {
set_font_styles(font, val);
}
val++;
if (IS_INTEGER(val)) {
font->size = VAL_INT32(val);
}
// Reb_Print("font/size: %d", font->size);
val++;
if ((IS_TUPLE(val)) || (IS_NONE(val))) {
COPY_MEM(font->color,VAL_TUPLE(val), 4);
}
// Reb_Print("font/color: %d.%d.%d.%d", font->color[0],font->color[1],font->color[2],font->color[3]);
val++;
if ((IS_PAIR(val)) || (IS_NONE(val))) {
offset = VAL_PAIR(val);
font->offset_x = offset.x;
font->offset_y = offset.y;
}
// Reb_Print("font/offset: %dx%d", offset.x,offset.y);
val++;
if ((IS_PAIR(val)) || (IS_NONE(val))) {
space = VAL_PAIR(val);
font->space_x = space.x;
font->space_y = space.y;
}
// Reb_Print("font/space: %dx%d", space.x, space.y);
val++;
font->shadow_x = 0;
font->shadow_y = 0;
if (IS_BLOCK(val)) {
REBSER* ser = VAL_SERIES(val);
REBVAL* slot = BLK_HEAD(ser);
REBCNT len = SERIES_TAIL(ser) ,i;
for (i = 0;i<len;i++){
if (IS_PAIR(slot)) {
REBPAR shadow = VAL_PAIR(slot);
font->shadow_x = shadow.x;
font->shadow_y = shadow.y;
} else if (IS_TUPLE(slot)) {
COPY_MEM(font->shadow_color,VAL_TUPLE(slot), 4);
} else if (IS_INTEGER(slot)) {
font->shadow_blur = VAL_INT32(slot);
}
slot++;
}
} else if (IS_PAIR(val)) {
REBPAR shadow = VAL_PAIR(val);
font->shadow_x = shadow.x;
font->shadow_y = shadow.y;
}
rt_font(richtext, font);
break;
case TW_PARA:
if (!IS_OBJECT(arg)) break;
para = (REBPRA*)rt_get_para(richtext);
val = BLK_HEAD(ARG_OBJECT(0))+1;
if (IS_PAIR(val)) {
origin = VAL_PAIR(val);
para->origin_x = origin.x;
para->origin_y = origin.y;
}
// Reb_Print("para/origin: %dx%d", origin.x, origin.y);
val++;
if (IS_PAIR(val)) {
margin = VAL_PAIR(val);
para->margin_x = margin.x;
para->margin_y = margin.y;
}
// Reb_Print("para/margin: %dx%d", margin.x, margin.y);
val++;
if (IS_PAIR(val)) {
indent = VAL_PAIR(val);
para->indent_x = indent.x;
para->indent_y = indent.y;
}
// Reb_Print("para/indent: %dx%d", indent.x, indent.y);
val++;
if (IS_INTEGER(val)) {
para->tabs = VAL_INT32(val);
}
// Reb_Print("para/tabs: %d", para->tabs);
val++;
if (IS_LOGIC(val)) {
para->wrap = VAL_LOGIC(val);
}
// Reb_Print("para/wrap?: %d", para->wrap);
val++;
if (IS_PAIR(val)) {
scroll = VAL_PAIR(val);
para->scroll_x = scroll.x;
para->scroll_y = scroll.y;
}
// Reb_Print("para/scroll: %dx%d", scroll.x, scroll.y);
val++;
if (IS_WORD(val)) {
REBINT result = Reb_Find_Word(VAL_WORD_SYM(val), Symbol_Ids, 0);
switch (result){
case SW_RIGHT:
case SW_LEFT:
case SW_CENTER:
para->align = result;
break;
default:
para->align = SW_LEFT;
break;
}
}
val++;
if (IS_WORD(val)) {
REBINT result = Reb_Find_Word(VAL_WORD_SYM(val), Symbol_Ids, 0);
switch (result){
case SW_TOP:
case SW_BOTTOM:
case SW_MIDDLE:
para->valign = result;
break;
default:
para->valign = SW_TOP;
break;
}
}
rt_para(richtext, para);
break;
case TW_SIZE:
rt_font_size(richtext, ARG_INTEGER(0));
break;
case TW_SHADOW:
rt_shadow(richtext, &ARG_PAIR(0), ARG_TUPLE(1), ARG_INTEGER(2));
break;
case TW_DROP:
rt_drop(richtext, ARG_OPT_INTEGER(0));
break;
case TW_NEWLINE:
case TW_NL:
rt_newline(richtext, index);
break;
case TW_CARET:
{
REBPAR caret = {0,0};
REBPAR highlightStart = {0,0};
REBPAR highlightEnd = {0,0};
REBVAL *slot;
if (!IS_OBJECT(arg)) break;
val = BLK_HEAD(ARG_OBJECT(0))+1;
if (IS_BLOCK(val)) {
slot = BLK_HEAD(VAL_SERIES(val));
if (SERIES_TAIL(VAL_SERIES(val)) == 2 && IS_BLOCK(slot) && IS_STRING(slot+1)){
caret.x = 1 + slot->data.series.index;
caret.y = 1 + (slot+1)->data.series.index;;
//Reb_Print("caret %d, %d", caret.x, caret.y);
}
}
val++;
if (IS_BLOCK(val)) {
slot = BLK_HEAD(VAL_SERIES(val));
if (SERIES_TAIL(VAL_SERIES(val)) == 2 && IS_BLOCK(slot) && IS_STRING(slot+1)){
highlightStart.x = 1 + slot->data.series.index;
highlightStart.y = 1 + (slot+1)->data.series.index;;
//Reb_Print("highlight-start %d, %d", highlightStart.x, highlightStart.y);
}
}
val++;
if (IS_BLOCK(val)) {
slot = BLK_HEAD(VAL_SERIES(val));
if (SERIES_TAIL(VAL_SERIES(val)) == 2 && IS_BLOCK(slot) && IS_STRING(slot+1)){
highlightEnd.x = 1 + slot->data.series.index;
highlightEnd.y = 1 + (slot+1)->data.series.index;;
//Reb_Print("highlight-End %d, %d", highlightEnd.x, highlightEnd.y);
}
}
rt_caret(richtext, &caret, &highlightStart,&highlightEnd);
}
break;
}
} while (TRUE);
}
cell parse(char** s) {
// Skip whitespace
while (isspace(**s))
(*s)++;
if (!**s) return NIL;
switch (**s) {
case '"': {
*(*s)++;
cell str = read_string(s);
return cons(str, parse(s));
}
case ')':
(*s)++;
return NIL;
case '(': {
(*s)++;
cell first = parse(s);
return cons(first, parse(s));
}
case '\'': {
(*s)++;
cell rest = parse(s);
// ' -> ()
if (!rest) return NIL;
// '.a -> ()
// ' -> ()
if (!IS_PAIR(rest)) return NIL;
// 'a -> (quote a)
if (!IS_PAIR(car(rest)))
return cons(LIST2(sym("quote"), car(rest)), cdr(rest));
// '(a b c) -> (quote a b c)
return cons(cons(sym("quote"), rest), cdr(rest));
}
case '.': {
(*s)++;
cell rest = parse(s);
if (!rest) return NIL;
if (TYPE(rest) != PAIR) return NIL;
return car(rest);
}
default: {
char* i = *s;
while (*i && !isspace(*i) && *i != '(' && *i != ')')
i++;
size_t token_len = i - *s;
char* token = strncpy(malloc(token_len + 1), *s, token_len);
token[token_len] = '\0';
*s = i;
cell c;
// Try to turn the token into a number
char* endptr;
long val = strtol(token, &endptr, 0);
if (endptr != token)
c = make_int(val);
else
c = sym(token);
free(token);
return cons(c, parse(s));
}
}
}