cell pp_curs_move(cell x) {
char name[] = "curs:move";
if (!Running) return UNSPECIFIC;
move(integer_value(name, car(x)), integer_value(name, cadr(x)));
return UNSPECIFIC;
}
cell pp_curs_mvinch(cell x) {
char name[] = "curs:mvinch";
if (!Running) return UNSPECIFIC;
return make_char((int) mvinch(integer_value(name, car(x)),
integer_value(name, cadr(x))));
}
cell pp_curs_mvinsch(cell x) {
char name[] = "curs:mvinsch";
if (!Running) return UNSPECIFIC;
mvinsch(integer_value(name, car(x)),
integer_value(name, cadr(x)),
char_value(caddr(x)));
return UNSPECIFIC;
}
cell pp_curs_mvaddstr(cell x) {
char name[] = "curs:mvaddstr";
if (!Running) return UNSPECIFIC;
mvaddstr(integer_value(name, car(x)),
integer_value(name, cadr(x)),
string(caddr(x)));
return UNSPECIFIC;
}
cell pp_curs_color_set(cell x) {
int f, b;
char name[] = "curs:color-set";
f = integer_value(name, car(x));
b = integer_value(name, cadr(x));
color_set(b<<3|f, NULL);
return UNSPECIFIC;
}
/* Perform type promotion of boxed values according to the following rules:
First Second First Second
float float -> float float
float integer -> float float
integer float -> float float
integer integer -> integer integer
quotation quotation -> quotation quotation
quotation * ->
word word -> word
word * ->
* quotation ->
* word ->
Supplies promoted values as out parameters, either as new values or as boxed
copies. Returns whether the given values are of compatible type. */
int boxed_promote(Boxed unpromoted_a, Boxed unpromoted_b, Boxed *promoted_a,
Boxed *promoted_b) {
assert(unpromoted_a);
assert(unpromoted_b);
assert(promoted_a);
assert(promoted_b);
switch (boxed_type(unpromoted_a)) {
case FLOAT:
switch (boxed_type(unpromoted_b)) {
case FLOAT:
*promoted_a = boxed_copy(unpromoted_a);
*promoted_b = boxed_copy(unpromoted_b);
return 1;
case INTEGER:
*promoted_a = boxed_copy(unpromoted_a);
*promoted_b = float_new(integer_value(unpromoted_b));
return 1;
case QUOTATION:
case WORD:
return 0;
}
case INTEGER:
switch (boxed_type(unpromoted_b)) {
case FLOAT:
*promoted_a = float_new(integer_value(unpromoted_a));
*promoted_b = boxed_copy(unpromoted_b);
return 1;
case INTEGER:
*promoted_a = boxed_copy(unpromoted_a);
*promoted_b = boxed_copy(unpromoted_b);
return 1;
case QUOTATION:
case WORD:
return 0;
}
case QUOTATION:
switch (boxed_type(unpromoted_b)) {
case QUOTATION:
*promoted_a = boxed_copy(unpromoted_a);
*promoted_b = boxed_copy(unpromoted_b);
return 1;
default:
return 0;
}
case WORD:
switch (boxed_type(unpromoted_b)) {
case WORD:
*promoted_a = boxed_copy(unpromoted_a);
*promoted_b = boxed_copy(unpromoted_b);
return 1;
default:
return 0;
}
}
return 0;
}
cell pp_curs_mvgetch(cell x) {
char name[] = "curs:mvgetch";
int c;
if (!Running) return UNSPECIFIC;
c = mvgetch(integer_value(name, car(x)),
integer_value(name, cadr(x)));
if (c == ERR)
return S9_FALSE;
return make_integer(c);
}
cell pp_curs_mvcur(cell x) {
char name[] = "curs:mvcur";
if (!Running) return UNSPECIFIC;
if (!integer_p(cadddr(x)))
return error("curs:mvcur: expected integer, got",
caddr(cdr(x)));
mvcur(integer_value(name, car(x)),
integer_value(name, cadr(x)),
integer_value(name, caddr(x)),
integer_value(name, cadddr(x)));
return UNSPECIFIC;
}
/* Unbox an integer. */
Integer integer_unbox(Boxed reference) {
assert(reference);
assert(is_integer(reference));
Integer value = integer_value(reference);
boxed_free(reference);
return value;
}
void kitten_trace(Boxed stack, Boxed definitions) {
assert(stack);
assert(is_quotation(stack));
printf("[ ");
int i;
for (i = 0; i < quotation_size(stack); ++i) {
Boxed current = quotation_data(stack)[i];
switch (boxed_type(current)) {
case FLOAT:
printf("%p:%fF ", current, float_value(current));
break;
case INTEGER:
printf("%p:%ldI ", current, integer_value(current));
break;
case WORD:
printf("%p:%dW ", current, word_value(current));
break;
case QUOTATION:
printf("%p:", current);
kitten_trace(current, definitions);
break;
}
}
printf("] ");
}
cell pp_curs_unctrl(cell x) {
char *s;
if (!Running) return UNSPECIFIC;
s = (char *) unctrl(integer_value("curs:unctrl", car(x)));
return make_string(s, strlen(s));
}
/* Make a deeper copy of a boxed reference. References within quotations are
cloned using boxed_copy() rather than boxed_clone(). */
Boxed boxed_clone(Boxed reference) {
trace("boxed_clone(%p)\n", reference);
if (!reference)
return NULL;
switch (boxed_type(reference)) {
case FLOAT:
return float_new(float_value(reference));
case INTEGER:
return integer_new(integer_value(reference));
case QUOTATION:
{
Boxed result = quotation_new(0);
quotation_append(result, reference);
return result;
}
case WORD:
return word_new(word_value(reference));
}
return NULL;
}
static long long integer_range (long long min, long long max)
{
extern long long integer_value (void);
long long n = integer_value ();
return n < min || max < n ? min : n;
}
// Initialize the value from the integer n.
//
// This allows initialization of the form value(0). Lookup would be ambiguous
// without this constructor.
inline
value::value(int n)
: kind_(integer_value_kind), data_(integer_value(n))
{ }
cell pp_curs_ungetch(cell x) {
if (!Running) return UNSPECIFIC;
ungetch(integer_value("curs:ungetch", car(x)));
return UNSPECIFIC;
}
cell pp_curs_attrset(cell x) {
if (!Running) return UNSPECIFIC;
attrset(integer_value("curs:attrset", car(x)));
return UNSPECIFIC;
}
cell pp_curs_scroll(cell x) {
if (!Running) return UNSPECIFIC;
scrl(integer_value("curs:scroll", car(x)));
return UNSPECIFIC;
}
