/* 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; }