/*
array = '[' _ (value _ (',' _ value _)*)? ']'
*/
static OOP
array_grammar_new(OOP scope)
{
OOP g_ws = object_call(scope, s_lookup, s_ws); // already bound
OOP g_value = named_pattern_new(s_value, scope); // defered lookup
OOP g_array = and_pattern_new(
eq_pattern_new(integer_new('[')),
and_pattern_new(
g_ws,
and_pattern_new(
opt_pattern_new(
and_pattern_new(
g_value,
and_pattern_new(
g_ws,
star_pattern_new(
and_pattern_new(
eq_pattern_new(integer_new(',')),
and_pattern_new(
g_ws,
and_pattern_new(
g_value,
g_ws))))))),
eq_pattern_new(integer_new(']')))));
object_call(scope, s_bind, s_array, g_array);
return g_array;
}
/*
object = '{' _ (property _ (',' _ property _)*)? '}'
property = string _ ':' _ value
*/
static OOP
object_grammar_new(OOP scope)
{
OOP g_ws = object_call(scope, s_lookup, s_ws); // already bound
OOP g_property = and_pattern_new(
named_pattern_new(s_string, scope),
and_pattern_new(
g_ws,
and_pattern_new(
eq_pattern_new(integer_new(':')),
and_pattern_new(
g_ws,
named_pattern_new(s_value, scope)))));
OOP g_object = and_pattern_new(
eq_pattern_new(integer_new('{')),
and_pattern_new(
g_ws,
and_pattern_new(
opt_pattern_new(
and_pattern_new(
g_property,
and_pattern_new(
g_ws,
star_pattern_new(
and_pattern_new(
eq_pattern_new(integer_new(',')),
and_pattern_new(
g_ws,
and_pattern_new(
g_property,
g_ws))))))),
eq_pattern_new(integer_new('}')))));
object_call(scope, s_bind, s_object, g_object);
return g_object;
}
/*
string = '"' character* '"'
character = ('\\' escape) | [^"\\]
escape = 'u' [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F]
| [\\/tnrbf"]
*/
static OOP
string_grammar_new(OOP scope)
{
OOP g_hexdigit = if_pattern_new(charset_p_new("0123456789ABCDEFabcdef"));
OOP g_escape = or_pattern_new(
and_pattern_new(
eq_pattern_new(integer_new('u')),
and_pattern_new(
g_hexdigit,
and_pattern_new(
g_hexdigit,
and_pattern_new(
g_hexdigit,
g_hexdigit)))),
if_pattern_new(charset_p_new("\\/tnrbf\"")));
OOP g_character = or_pattern_new(
and_pattern_new(
eq_pattern_new(integer_new('\\')),
g_escape),
if_pattern_new(exclset_p_new("\"\\")));
OOP g_string = and_pattern_new(
eq_pattern_new(integer_new('"')),
and_pattern_new(
star_pattern_new(g_character),
eq_pattern_new(integer_new('"'))));
object_call(scope, s_bind, s_string, g_string);
return g_string;
}
void kitten_eq(Boxed stack, Boxed definitions) {
assert(stack);
assert(is_quotation(stack));
Boxed b = pop(stack);
Boxed a = pop(stack);
push(stack, integer_new(boxed_compare(a, b) == 0));
}
void kitten_isw(Boxed stack, Boxed definitions) {
assert(stack);
assert(is_quotation(stack));
Boxed a = pop(stack);
push(stack, integer_new(is_word(a)));
boxed_free(a);
}
/*
number = integer fraction? exponent?
integer = '-'? ('0' | [1-9] [0-9]*)
fraction = '.' [0-9]+
exponent = [eE] [-+]? [0-9]+
*/
static OOP
number_grammar_new(OOP scope)
{
OOP g_digit = if_pattern_new(charset_p_new("0123456789"));
OOP g_integer = and_pattern_new(
opt_pattern_new(
eq_pattern_new(integer_new('-'))),
or_pattern_new(
eq_pattern_new(integer_new('0')),
and_pattern_new(
if_pattern_new(charset_p_new("123456789")),
star_pattern_new(g_digit))));
OOP g_fraction = and_pattern_new(
eq_pattern_new(integer_new('.')),
plus_pattern_new(g_digit));
OOP g_exponent = and_pattern_new(
or_pattern_new(
eq_pattern_new(integer_new('e')),
eq_pattern_new(integer_new('E'))),
and_pattern_new(
opt_pattern_new(
or_pattern_new(
eq_pattern_new(integer_new('+')),
eq_pattern_new(integer_new('-')))),
plus_pattern_new(g_digit)));
OOP g_number = and_pattern_new(
g_integer,
and_pattern_new(
opt_pattern_new(g_fraction),
opt_pattern_new(g_exponent)));
object_call(scope, s_bind, s_number, g_number);
return g_number;
}
inline Actor
pstring_new(Config cfg, char * p, int n)
{
if (n <= 0) { return a_empty_string; }
String s = (String)config_create(cfg, sizeof(STRING), beh_string);
s->_act.eqv = string_eqv_method; // override eqv procedure
s->p = p; // may, or may not, have '\0' terminator
s->n = integer_new(cfg, n); // pre-defined length
return (Actor)s;
}
/* Unfortunate specialization for floating-point modulus. */
void kitten_mod(Boxed stack, Boxed definitions) {
Boxed unpromoted_b = pop(stack);
Boxed unpromoted_a = pop(stack);
Boxed a;
Boxed b;
int compatible_types = boxed_promote(unpromoted_a, unpromoted_b, &a, &b);
assert(compatible_types);
assert(is_numeric(a) && is_numeric(b));
switch (boxed_type(a)) {
case FLOAT:
push(stack, float_new(fmod(float_unbox(a), float_unbox(b))));
break;
case INTEGER:
push(stack, integer_new(integer_unbox(a) % integer_unbox(b)));
break;
default:
break;
}
}
/* 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;
}
/*
name = 'n' 'u' 'l' 'l'
| 't' 'r' 'u' 'e'
| 'f' 'a' 'l' 's' 'e'
*/
static OOP
name_grammar_new(OOP scope)
{
OOP g_null = and_pattern_new(
eq_pattern_new(integer_new('n')),
and_pattern_new(
eq_pattern_new(integer_new('u')),
and_pattern_new(
eq_pattern_new(integer_new('l')),
eq_pattern_new(integer_new('l')))));
OOP g_true = and_pattern_new(
eq_pattern_new(integer_new('t')),
and_pattern_new(
eq_pattern_new(integer_new('r')),
and_pattern_new(
eq_pattern_new(integer_new('u')),
eq_pattern_new(integer_new('e')))));
OOP g_false = and_pattern_new(
eq_pattern_new(integer_new('f')),
and_pattern_new(
eq_pattern_new(integer_new('a')),
and_pattern_new(
eq_pattern_new(integer_new('l')),
and_pattern_new(
eq_pattern_new(integer_new('s')),
eq_pattern_new(integer_new('e'))))));
OOP g_name = or_pattern_new(g_null, or_pattern_new(g_true, g_false));
object_call(scope, s_bind, s_name, g_name);
return g_name;
}
VALUE
float_to_i(VALUE recv)
{
return integer_new((int)FLOAT(recv)->num);
}
bool test_integer()
{
char *endptr, buf[64];
struct integer_t *val, *tmp;
unsigned int rem;
printf("testing integer... ");
val = integer_zero();
integer_delete(val);
val = integer_zero();
integer_add_uint(&val, 58);
if((val->len != 1) || (val->arr[0] != 58))
return printf("failed\n"), false;
integer_add_uint(&val, UINT_MAX);
if((val->len != 2) || (val->arr[0] != 57) || (val->arr[1] != 1))
return printf("failed\n"), false;
integer_delete(val);
val = integer_new(14);
integer_mul_ushort(&val, 11);
if((val->len != 1) || (val->arr[0] != 154))
return printf("failed\n"), false;
integer_mul_ushort(&val, 9261);
if((val->len != 1) || (val->arr[0] != 1426194))
return printf("failed\n"), false;
integer_delete(val);
val = integer_new(4194314);
rem = integer_div_ushort(&val, 20460);
if((rem != 14) || (val->len != 1) || (val->arr[0] != 205))
return printf("failed\n"), false;
rem = integer_div_ushort(&val, 3);
if((rem != 1) || (val->len != 1) || (val->arr[0] != 68))
return printf("failed\n"), false;
integer_delete(val);
val = integer_parse("123", &endptr);
if((val->len != 1) || val->neg || (val->arr[0] != 123))
return printf("failed\n"), false;
integer_delete(val);
val = integer_parse("-0x123", &endptr);
if((val->len != 1) || !val->neg || (val->arr[0] != 0x123))
return printf("failed\n"), false;
integer_delete(val);
val = integer_new(78910);
str_printf(buf, "%C", integer_chunk(val));
integer_delete(val);
if(!str_isequal(buf, "78910"))
return printf("failed\n"), false;
val = integer_parse("4052555153018976267", NULL);
tmp = integer_parse("4656612873077392578125", NULL);
integer_add(&val, tmp);
str_printf(buf, "%C", integer_chunk(val));
integer_delete(tmp);
integer_delete(val);
if(!str_isequal(buf, "4660665428230411554392"))
return printf("failed\n"), false;
val = integer_parse("13", NULL);
tmp = integer_parse("28", NULL);
integer_add(&val, tmp);
str_printf(buf, "%C", integer_chunk(val));
integer_delete(tmp);
integer_delete(val);
if(!str_isequal(buf, "41"))
return printf("failed\n"), false;
val = integer_parse("28", NULL);
tmp = integer_parse("13", NULL);
integer_sub(&val, tmp);
str_printf(buf, "%C", integer_chunk(val));
integer_delete(tmp);
integer_delete(val);
if(!str_isequal(buf, "15"))
return printf("failed\n"), false;
val = integer_parse("4656612873077392578125", NULL);
tmp = integer_parse("4052555153018976267", NULL);
integer_sub(&val, tmp);
str_printf(buf, "%C", integer_chunk(val));
integer_delete(tmp);
integer_delete(val);
if(!str_isequal(buf, "4652560317924373601858"))
return printf("failed\n"), false;
val = integer_parse("483306625", NULL);
tmp = integer_parse("-3916345896", NULL);
integer_add(&val, tmp);
str_printf(buf, "%C", integer_chunk(val));
integer_delete(tmp);
integer_delete(val);
if(!str_isequal(buf, "-3433039271"))
return printf("failed\n"), false;
val = integer_parse("483306625", NULL);
tmp = integer_parse("-13582478396", NULL);
integer_add(&val, tmp);
str_printf(buf, "%C", integer_chunk(val));
integer_delete(tmp);
integer_delete(val);
if(!str_isequal(buf, "-13099171771"))
return printf("failed\n"), false;
val = integer_new(78910);
if(!integer_uint32chk(val))
return printf("failed\n"), false;
else if(integer_uint16chk(val))
return printf("failed\n"), false;
else if(integer_uint8chk(val))
return printf("failed\n"), false;
else if(integer_uint32(val) != 78910)
return printf("failed\n"), false;
else if(integer_uint16(val) != 13374)
return printf("failed\n"), false;
else if(integer_uint8(val) != 62)
return printf("failed\n"), false;
integer_delete(val);
val = integer_new(-281);
if(!integer_uint16chk(val))
return printf("failed\n"), false;
else if(!integer_uint8chk(val))
return printf("failed\n"), false;
else if(integer_uint32(val) != 4294967015)
return printf("failed\n"), false;
else if(integer_uint16(val) != 65255)
return printf("failed\n"), false;
else if(integer_uint8(val) != 231)
return printf("failed %u\n", integer_uint8(val)), false;
integer_delete(val);
printf("okay\n");
return true;
}
