* working snapshot

* working snapshot

(%
 % rowl - generation 1
 % Copyright (C) 2010 nineties
 %
 % $Id: typing.rl 2010-04-29 22:46:33 nineties $
 %);

include(stddef, code);

export(init_typing, typing, unit_type, char_type, int_type, float_type, double_type, void_type);
export(get_variable);

scopeid: 0;
scopeid_stack: NULL;

varmap: NULL; (% variable table. name -> (tyscheme, id, is_global) %);

(% p0: (scopeid-id, name) %);
ident_hash: (p0) {
    return strhash(p0[1]) * 3+ p0[0];
};

ident_equal: (p0, p1) {
    if (p0[0] != p1[0]) { return FALSE; };
    return streq(p0[1], p1[1]);
};

scope_push: () {
    scopeid = scopeid + 1;
    vec_pushback(scopeid_stack, scopeid);
};

scope_pop: () {
    vec_popback(scopeid_stack);
};

(% p0: name, p1: value %);
varmap_add: (p0, p1) {
    allocate(1);
    x0 = vec_at(scopeid_stack, vec_size(scopeid_stack)-1);
    map_add(varmap, mktup2(x0, p0), p1);
};

(% p0: name %);
varmap_find: (p0) {
    allocate(3);
    x0 = vec_size(scopeid_stack)-1;
    while (x0 >= 0) {
        x1 = vec_at(scopeid_stack, x0); (% scopeid-id %);
        x2 = map_find(varmap, mktup2(x1, p0));
        if (x2 != NULL) { return x2; };
        x0 = x0 - 1;
    };
    return NULL;
};

funtable: NULL; (% function table. name -> list of tyscheme %);

(% p0: name, p1: value %);
function_add: (p0, p1) {
    allocate(1);
    x0 = vec_at(scopeid_stack, vec_size(scopeid_stack)-1);
    map_add(funtable, mktup2(x0, p0), p1);
};

(% p0: name %);
function_find: (p0) {
    allocate(3);
    x0 = vec_size(scopeid_stack)-1;
    while (x0 >= 0) {
        x1 = vec_at(scopeid_stack, x0); (% scopeid-id %);
        x2 = map_find(funtable, mktup2(x1, p0));
        if (x2 != NULL) { return x2; };
        x0 = x0 - 1;
    };
    return NULL;
};

(% p0: name %);
get_variable: (p0) {
    allocate(1);
    x0 = varmap_find(p0); (% tyscheme, id, is_global %);
    if (x0 == NULL) {
        fputs(stderr, "ERROR: variable '");
        fputs(stderr, p0);
        fputs(stderr, "' is not declared\n");
        exit(1);
    };
    return mktup6(NODE_IDENTIFIER, x0[0][1], p0, x0[1], x0[0], x0[2]);
};

in_global_namespace: () {
    return vec_size(scopeid_stack) == 1;
};

tyvarmap: NULL;

tyvarid_hash: (p0) {
    return p0;
};

tyvarid_equal: (p0, p1) {
    return p0 == p1;
};

init_tyvarmap: () {
    tyvarmap = mkmap(&tyvarid_hash, &tyvarid_equal, 10);
};

(% constructor name -> (variant type, corresponding row) %);
variant_map: NULL;

not_reachable: (p0) {
    fputs(stderr, "ERROR: not reachable here\n");
    exit(1);
};

not_implemented: (p0) {
    fputs(stderr, "ERROR: not implemented\n");
    exit(1);
};

infer_funcs: [not_reachable, infer_integer, infer_string, not_implemented,
    infer_identifier, infer_array, infer_tuple, infer_block, infer_decl,
    infer_call, infer_subscript, infer_lambda, infer_unexpr, infer_binexpr,
    infer_assign, infer_export, infer_import, infer_external, infer_ret, infer_retval,
    infer_syscall, infer_field, infer_fieldref, infer_typedecl, infer_variant, infer_unit,
    infer_typedexpr, infer_if, infer_ifelse, infer_static_array, infer_cast, infer_new,
    infer_while, infer_for, infer_newarray, infer_rewrite
];

unit_type   : NULL;
char_type   : NULL;
int_type    : NULL;
float_type  : NULL;
double_type : NULL;
void_type   : NULL;

init_typing: () {
    unit_type   = mktup1(NODE_UNIT_T);
    char_type   = mktup1(NODE_CHAR_T);
    int_type    = mktup1(NODE_INT_T);
    float_type  = mktup1(NODE_FLOAT_T);
    double_type = mktup1(NODE_DOUBLE_T);
    void_type   = mktup1(NODE_VOID_T);
};

infer_integer: (p0) {
    if (p0[2] == 8)  { p0[1] = char_type; return char_type; };
    if (p0[2] == 32) { p0[1] = int_type;  return int_type; };
    not_reachable();
};

infer_string: (p0) {
    p0[1] = mktup3(NODE_NAMED_T, "string", NULL);
    return p0[1];
};

infer_identifier: (p0) {
    allocate(3);
    x0 = varmap_find(p0[2]); (% (tyscheme, id, is_global) %);
    if (x0 == NULL) {
        fputs(stderr, "ERROR: undefined symbol '");
        fputs(stderr, p0[2]);
        fputs(stderr, "'\n");
        exit(1);
    };

    x1 = rename_tyscheme(x0[0]);
    p0[1] = x1[1];
    p0[3] = x0[1];
    p0[4] = x1;
    p0[5] = x0[2];

    deref(p0);

    return p0[1];
};

infer_array: (p0) {
    allocate(5);
    x0 = mktyvar();
    x1 = p0[2]; (% length %);
    x2 = 0;
    x3 = p0[3]; (% pointer to the array %);
    while (x2 < x1) {
        x4 = x3[x2];
        x4[1] = infer_item(x3[x2]);
        unify(x0, x4[1], TRUE);
        x2 = x2 + 1;
    };
    not_implemented();
    p0[1] = mktup4(NODE_ARRAY_T, x0, x1, FALSE);
    deref(p0);
    return p0[1];
};

infer_tuple: (p0) {
    allocate(5);
    x1 = p0[2]; (% length %);
    x2 = p0[3];
    x3 = memalloc(4*x1);
    x0 = 0;
    while (x0 < x1) {
        x4 = x2[x0];
        x4[1] = infer_item((p0[3])[x0]);
        x3[x0] = x4[1];
        x0 = x0 + 1;
    };
    p0[1] = mktup3(NODE_TUPLE_T, x1, x3);
    deref(p0);
    return p0[1];
};

do_exit: (p0) {
    if (p0[0] == NODE_RETVAL) { return TRUE; };
    if (p0[0] == NODE_RET)    { return TRUE; };
    if (p0[1][0] == NODE_VOID_T) { return TRUE; };
    return FALSE;
};

(% p0: instruction %);
block_type: (p0) {
    if (p0[0] == NODE_RET) { return void_type; };
    if (p0[0] == NODE_RETVAL) { return void_type; };
    if (p0[1][0] == NODE_VOID_T) {
        return void_type;
    };
    return unit_type;
};

return_stack: NULL;

infer_block: (p0) {
    allocate(3);
    x0 = p0[BLOCK_STATEMENTS];

    if (x0 != NULL) {
        while (x0 != NULL) {
            x1 = ls_value(x0);
            x2 = infer_item(x1);
            if (ls_next(x0) != NULL) {
                if (do_exit(ls_value(x0))) {
                    fputs(stderr, "ERROR: unreachable code '");
                    put_item(stderr, ls_value(ls_next(x0)));
                    fputs(stderr, "'\n");
                    exit(1);
                };
            } else {
                p0[1] = block_type(x1);
            };
            x0 = ls_next(x0);
        };
    } else {
        (% empty function body %);
        p0[1] = unit_type;
    };

    deref(p0);
    return p0[1];
};

(% p0: dontcare pattern, p1: expr %);
infer_decl_dontcare: (p0, p1) {
    p0[1] = infer_item(p1);
    return p0[1];
};

(% p0: var, p1: expr %);
infer_decl_var: (p0, p1) {
    allocate(5);
    x0 = mktyvar();
    x1 = set_varid(p0);
    x2 = in_global_namespace();
    varmap_add(p0[2], mktup3(mktyscheme(x0), x1, x2));
    x3 = infer_item(p1);
    unify(x0, x3, TRUE);
    x4 = closure(x3);
    varmap_add(p0[2], mktup3(x4, x1, x2));
    p0[1] = x3; (% type %);
    p0[3] = x1; (% variable id %);
    p0[4] = x4; (% type scheme %);
    p0[5] = x2;
    deref_pattern(p0);
    deref(p1);
    return p0[1];
};

(% p0: tuple pattern, p1: expr %);
infer_decl_tuple: (p0, p1) {
    allocate(1);
    x0 = infer_pattern(p0);
    unify(x0, infer_item(p1), TRUE);
    deref_pattern(p0);
    deref(p1);
    return p0[1];
};

infer_pattern: (p0) {
    allocate(5);
    if (p0[0] == NODE_UNIT) {
        p0[1] = unit_type;
        return unit_type;
    };
    if (p0[0] == NODE_DONTCARE) {
        x0 = mktyvar();
        p0[1] = x0;
        return x0;
    };
    if (p0[0] == NODE_IDENTIFIER) {
        (% variable pattern %);
        x0 = mktyvar(); (% type of variable %);
        x1 = set_varid(p0);
        x2 = mktup3(mktyscheme(x0), x1, in_global_namespace());
        varmap_add(p0[2], x2);
        p0[1] = x0;
        p0[3] = x1;
        p0[4] = x2;
        deref(p0);
        return p0[1];
    };
    if (p0[0] == NODE_TUPLE) {
        (% tuple pattern %);
        x0 = p0[TUPLE_LENGTH];
        x1 = p0[TUPLE_ELEMENTS];
        x2 = memalloc(4*x0); (% element types %);
        x3 = 0;
        while (x3 < x0) {
            x4 = infer_pattern(x1[x3]);
            x2[x3] = x4;
            x3 = x3 + 1;
        };
        p0[1] = mktup3(NODE_TUPLE_T, x0, x2);
        return p0[1];
    };
    if (p0[0] == NODE_TYPEDEXPR) {
        (% typed pattern %);
        x0 = infer_pattern(p0[2]);
        unify(x0, p0[1], TRUE);
        deref(p0);
        return p0[1];
    };
    fputs(stderr, "ERROR: invalid pattern expression\n");
    exit(1);
};

(% p0: lhs, p1: rhs %);
infer_decl_impl: (p0, p1) {
    if (p0[0] == NODE_DONTCARE) {
        return infer_decl_dontcare(p0, p1);
    };
    if (p0[0] == NODE_IDENTIFIER) {
        return infer_decl_var(p0, p1);
    };
    if (p0[0] == NODE_TUPLE) {
        return infer_decl_tuple(p0, p1);
    };
    not_implemented();
};

infer_decl: (p0) {
    allocate(1);
    x0 = infer_decl_impl(p0[2], p0[3]);
    p0[1] = x0;
    deref(p0);
    return p0[1];
};

(% p0: expr %);
infer_call: (p0) {
    allocate(3);
    x0 = infer_item(p0[2]); (% function type %);
    x1 = infer_item(p0[3]); (% argument type %);
    x2 = mktyvar(); (% return type %);
    unify(x0, mktup3(NODE_LAMBDA_T, x1, x2), TRUE);

    p0[1] = x2;
    deref(p0);
    return p0[1];
};

infer_subscript: (p0) {
    allocate(2);
    x0 = infer_item(p0[2]);
    x1 = infer_item(p0[3]);
    unify(int_type, x1, TRUE);
    if (x0[0] == NODE_SARRAY_T) {
	p0[1] = x0[1];
	deref(p0);
	return p0[1];
    };
    if (x0[0] == NODE_ARRAY_T) {
        p0[1] = x0[1];
        deref(p0);
        return p0[1];
    };
    not_implemented();
};

insert_missing_ret: (p0) {
    allocate(1);
    if (p0 == NULL) {
        return ls_singleton(mktup2(NODE_RET, unit_type));
    };
    x0 = ls_value(p0);
    if (x0[0] == NODE_RET)    { return p0; };
    if (x0[0] == NODE_RETVAL) { return p0; };
    if (x0[1] == void_type)   { return p0; };
    return ls_cons(x0, insert_missing_ret(ls_next(p0)));
};

infer_lambda: (p0) {
    allocate(3);

    (% lambda opens new namespace %);
    scope_push();
    x0 = infer_pattern(p0[LAMBDA_ARG]);

    vec_pushback(return_stack, NULL);
    x1 = infer_item(p0[LAMBDA_BODY]);
    x2 = vec_at(return_stack, vec_size(return_stack)-1);
    if (x2 != NULL) {
        x1 = x2;
    };
    vec_popback(return_stack);
    scope_pop();

    p0[1] = mktup3(NODE_LAMBDA_T, x0, x1);

    if (p0[1] != void_type) {
        x2 = p0[LAMBDA_BODY];
        x2[2] = insert_missing_ret(x2[2]);
    };

    deref(p0);
    return p0[1];
};

unexpr_funcs: [
    infer_unarith, infer_unarith, infer_unarith, infer_unarith, not_implemented,
    infer_indirect, infer_unarith, infer_unarith, infer_unarith, infer_unarith
];

infer_unarith: (p0) {
    allocate(1);
    x0 = infer_item(p0[3]);
    unify(int_type, x0, TRUE);
    p0[1] = int_type;
    return int_type;
};

infer_indirect: (p0) {
    allocate(2);
    x0 = infer_item(p0[3]);
    x1 = mktyvar();
    unify(mktup2(NODE_POINTER_T, x1), x0, TRUE);
    p0[1] = x1;
    deref(p0);
    return p0[1];
};

infer_unexpr: (p0) {
    allocate(1);
    x0 = unexpr_funcs[p0[2]];
    return x0(p0);
};

binexpr_funcs: [
    not_reachable, infer_binarith, infer_binarith, infer_binarith, infer_binarith,
    infer_binarith, infer_binarith, infer_binarith, infer_binarith, infer_binarith,
    infer_binarith, infer_equality, infer_equality, infer_binarith, infer_binarith,
    infer_binarith, infer_binarith, not_implemented, not_implemented
];

infer_binarith: (p0) {
    allocate(2);
    x0 = infer_item(p0[3]);
    x1 = infer_item(p0[4]);
    unify(int_type, x0, TRUE);
    unify(int_type, x1, TRUE);
    p0[1] = int_type;
    deref(p0);
    return p0[1];
};

infer_equality: (p0) {
    allocate(2);
    x0 = infer_item(p0[3]);
    x1 = infer_item(p0[4]);
    unify(x0, x1, TRUE);
    p0[1] = int_type;
    deref(p0);
    return int_type;
};

infer_binexpr: (p0) {
    allocate(1);
    x0 = binexpr_funcs[p0[2]];
    return x0(p0);
};

infer_assign: (p0) {
    allocate(2);
    x0 = infer_item(p0[3]); (% lhs type %);
    x1 = infer_item(p0[4]); (% rhs type %);
    unify(x0, x1, TRUE);
    p0[1] = x0;
    return x0;
};

infer_export: (p0) {
    infer_item(p0[1]);
    deref(p0);
    return unit_type;
};

infer_import: (p0) {
    (% do nothing %);
};

infer_external: (p0) {
    allocate(5);
    x0 = p0[1]; (% ident %);
    x1 = p0[2]; (% type %);
    x2 = closure(x1);
    x3 = set_varid(x0);
    varmap_add(get_ident_name(x0), mktup3(x2, x3, TRUE));
    x0[1] = x1;
    x0[3] = x3;
    x0[4] = x2;
    x0[5] = TRUE;
    return unit_type;
};

infer_ret: (p0) {
    allocate(1);
    x0 = vec_back(return_stack);
    if (x0 != NULL) {
        unify(x0, unit_type, TRUE);
    };
    vec_put(return_stack, vec_size(return_stack)-1, unit_type);
    p0[1] = unit_type;
    deref(p0);
    return unit_type;
};

(% return e; is treated as .pseudo_retvar = e; %);
infer_retval: (p0) {
    allocate(1);
    p0[1] = infer_item(p0[RETVAL_VALUE]);
    x0 = vec_back(return_stack);
    if (x0 != NULL) {
        unify(p0[1], x0, TRUE);
    };
    deref(p0);
    vec_put(return_stack, vec_size(return_stack)-1, p0[1]);
    return p0[1];
};

infer_syscall: (p0) {
    infer_item(p0[2]);
    p0[1] = mktyvar();
    deref(p0);
    return p0[1];
};

(% fieldname : expression %);
infer_field: (p0) {
    allocate(3);
    x0 = p0[2]; (% lhs %);
    if (x0[0] != NODE_IDENTIFIER) {
        fputs(stderr, "ERROR: invalid field name\n");
        exit(1);
    };
    x1 = infer_item(p0[3]);
    x2 = mktup3(NODE_FIELD_T, get_ident_name(x0), x1);
    p0[1] = x2;
    deref(p0);
    return p0[1];
};

(% p0: type, p1: field name %);
get_fieldtype: (p0, p1) {
    allocate(4);
    if (p0[0] == NODE_TUPLE_T) {
        x0 = p0[TUPLE_T_LENGTH];
        x1 = p0[TUPLE_T_ELEMENTS];
        x2 = 0;
        while (x2 < x0) {
            x3 = x1[x2];
            if (has_name(x3, p1)) {
                return x3[2];
            };
            x2 = x2 + 1;
        };
        return NULL;
    };
    if (p0[0] == NODE_VARIANT_T) {
        x0 = p0[2]; (% rows %);
        if (ls_length(x0) != 1) {
            return NULL;
        };
        x1 = (ls_value(x0))[2]; (% argument type %);
        return get_fieldtype(x1, p1);
    };
    if (p0[0] == NODE_NAMED_T) {
        if (p0[2] != NULL) {
            return get_fieldtype(p0[2], p1);
        };
        return NULL;
    };
    return NULL;
};

infer_fieldref: (p0) {
    allocate(3);
    x0 = infer_item(p0[2]); (% lhs %);
    x1 = p0[3]; (% field name %);
    x2 = get_fieldtype(x0, x1);
    if (x2 == NULL) {
        fputs(stderr, "ERROR: field '");
        fputs(stderr, x1);
        fputs(stderr, "' not found\n");
        exit(1);
    };
    p0[1] = x2;
    deref(p0);
    return p0[1];
};

infer_typedecl: (p0) {
    allocate(5);
    x0 = p0[1]; (% identifier %);
    x1 = p0[2][2]; (% type %);
    if (x1 == NULL) {
	return unit_type;
    };
    if (x1[0] == NODE_VARIANT_T) {
        x1[1] = x0;
        x2 = x1[2]; (% rows %);
        x3 = 0; (% constructor id %);

        (% set constructor-id and register to variant_map %);
        while (x2 != NULL) {
            x4 = ls_value(x2); (% constructor name, id, arg %);
            x4[1] = x3;
            map_add(variant_map, x4[0], mktup2(x1, x4));
            x2 = ls_next(x2);
            x3 = x3 + 1;
        };
        return unit_type;
    };
    return unit_type;
};

infer_variant: (p0) {
    allocate(3);
    x0 = p0[2]; (% constructor name %);
    x1 = map_find(variant_map, x0); (% (type, (constructor name, id, arg type)) %);
    assert(x1 != NULL);
    p0[1] = x1[0];
    p0[3] = x1[1][1]; (% id %);
    if (p0[4] != NULL) {
        x2 = infer_item(p0[4]); (% infer argument %);
        unify(x2, x1[1][2], TRUE);
    };
    deref(p0);
    return p0[1];
};

infer_unit: (p0) {
    p0[1] = unit_type;
    return unit_type;
};

infer_typedexpr: (p0) {
    allocate(1);
    x0 = infer_item(p0[2]); (% expression %);
    unify(x0, p0[1], TRUE);
    deref(p0);
    return p0[1];
};

infer_if: (p0) {
    allocate(1);
    x0 = infer_item(p0[2]); (% condition %);
    unify(x0, int_type, TRUE);
    infer_item(p0[3]);
    p0[1] = unit_type;
    deref(p0);
    return p0[1];
};

infer_ifelse: (p0) {
    allocate(3);
    x0 = infer_item(p0[2]); (% condition %);
    unify(int_type, x0, TRUE);
    x1 = infer_item(p0[3]); (% ifthen block %);
    x2 = infer_item(p0[4]); (% ifelse block %);
    p0[1] = unify_join(x1, x2, TRUE);
    deref(p0);
    return p0[1];
};

infer_static_array: (p0) {
    allocate(4);
    x0 = infer_item(p0[2]); (% initializer %);
    x1 = infer_item(p0[3]); (% length %);
    unify(x1, int_type, TRUE);
    p0[1] = mktup2(NODE_SARRAY_T, x0);
    deref(p0);
    return p0[1];
};

infer_cast: (p0) {
    infer_item(p0[2]);
    deref(p0);
    return p0[1];
};

infer_new: (p0) {
    allocate(1);
    x0 = infer_item(p0[2]);
    p0[1] = mktup2(NODE_POINTER_T, x0);
    deref(p0);
    return p0[1];
};

infer_while: (p0) {
    allocate(1);
    x0 = infer_item(p0[2]); (% condition %);
    unify(int_type, x0, TRUE);
    infer_item(p0[3]);
    p0[1] = unit_type;
    deref(p0);
    return p0[1];
};

infer_for: (p0) {
    allocate(1);
    infer_item(p0[2]);
    x0 = infer_item(p0[3]); (% condition %);
    unify(int_type, x0, TRUE);
    infer_item(p0[4]);
    infer_item(p0[5]);
    p0[1] = unit_type;
    deref(p0);
    return p0[1];
};

infer_newarray: (p0) {
    allocate(2);
    x0 = infer_item(p0[2]); (% length %);
    unify(int_type, x0, TRUE);
    x1 = infer_item(p0[3]);
    p0[1] = mktup2(NODE_ARRAY_T, x1);
    deref(p0);
    return p0[1];
};

infer_rewrite: (p0) {
    return unit_type;
};

(% p0: item %);
infer_item: (p0) {
    allocate(1);
    x0 = infer_funcs[p0[0]];
    return x0(p0);
};

remove_freevar: (p0) {
    allocate(1);
    if (p0 == NULL) { return NULL; };
    x0 = map_find(tyvarmap, ls_value(p0));
    if (x0 != NULL) {
        p0[1] = remove_freevar(ls_next(p0));
        return p0;
    };
    return remove_freevar(ls_next(p0));
};

(% p0: type %);
closure: (p0) {
    allocate(1);
    x0 = freevar(p0);
    x0 = remove_freevar(x0);
    return mktup2(x0, p0);
};

(% p0, p1: type, p2: do update tyvarmap %);
unify: (p0, p1, p2) {
    if (p0[0] == NODE_TYVAR) { return unify_tyvar(p0, p1, p2); };
    if (p1[0] == NODE_TYVAR) { return unify_tyvar(p1, p0, p2); };
    if (p0[0] == p1[0]) {
        if (p0[0] == NODE_UNIT_T)     { return TRUE; };
        if (p0[0] == NODE_CHAR_T)     { return TRUE; };
        if (p0[0] == NODE_INT_T)      { return TRUE; };
        if (p0[0] == NODE_FLOAT_T)    { return TRUE; };
        if (p0[0] == NODE_DOUBLE_T)   { return TRUE; };
        if (p0[0] == NODE_POINTER_T)  { return unify(p0[POINTER_T_BASE], p1[POINTER_T_BASE], p2); };
        if (p0[0] == NODE_TUPLE_T)    { return unify_tuple_t(p0, p1, p2); };
        if (p0[0] == NODE_ARRAY_T)    {
            unify(p0[ARRAY_T_ELEMENT], p1[ARRAY_T_ELEMENT], p2);
            return TRUE;
        };
        if (p0[0] == NODE_LAMBDA_T) { return unify_lambda_t(p0, p1, p2); };
        if (p0[0] == NODE_VARIANT_T) {
            if (streq(p0[1], p1[1])) { return TRUE; };
        };
	if (p0[0] == NODE_NAMED_T) {
	    if (streq(p0[1], p1[1])) { return TRUE; };
	};
    };
    if (p0[0] == NODE_NAMED_T) {
	if (p0[2] != NULL) {
	    return unify(p0[2], p1, p2);
	};
    };
    if (p1[0] == NODE_NAMED_T) {
	if (p1[2] != NULL) {
	    return unify(p0, p1[2], p2);
	};
    };
    if (p0[0] == NODE_FIELD_T) {
        return unify(p0[2], p1, p2);
    };
    if (p1[0] == NODE_FIELD_T) {
        return unify(p0, p1[2], p2);
    };
    if (p2) {
        type_mismatch(p0, p1);
    };
    return FALSE;
};

unify_tuple_t: (p0, p1, p2) {
    allocate(2);
    if (p0[1] != p1[1]) {
        if (p2) {
            type_mismatch(p0, p1);
        };
        return FALSE;
    };
    x1 = p0[1]; (% length %);
    x0 = 0;
    while (x0 < x1) {
        if (unify((p0[2])[x0], (p1[2])[x0], p2) == FALSE) {
            return FALSE;
        };
        x0 = x0 + 1;
    };
    return TRUE;
};

unify_lambda_t: (p0, p1, p2) {
    if(unify(p0[1], p1[1], p2) == FALSE) {
        return FALSE;
    };
    return unify(p0[2], p1[2], p2);
};

(% p0: tyvar, p1, type %);
unify_tyvar: (p0, p1, p2) {
    allocate(1);
    if (p1[0] == NODE_TYVAR) {
        if (p0[1] == p1[1]) { return TRUE; };
    };
    x0 = map_find(tyvarmap, p0[1]);
    if (x0 != NULL) {
        return unify(x0[1], p1, p2);
    };
    if (p1[0] == NODE_TYVAR) {
        x0 = map_find(tyvarmap, p1[1]);
        if (x0 != NULL) {
            return unify(p0, x0[1], p2);
        };
    };
    occur_check(p0[1], p1);
    if (p2) {
        x0 = closure(p1);
        map_add(tyvarmap, p0[1], x0);
    };
};

(% p0: type of ifthen block, p1: type of ifelse block %);
unify_join: (p0, p1) {
    if (p0 == void_type) { return p1; };
    if (p1 == void_type) { return p0; };
    return unit_type;
};

(% p0: id, p1, type %);
occur_check: (p0, p1) {
    allocate(1);
    if (p1[0] == NODE_TUPLE_T)  { return occur_check_tuple_t(p0, p1); };
    if (p1[0] == NODE_ARRAY_T)  { return occur_check(p0, p1[1]); };
    if (p1[0] == NODE_LAMBDA_T) { return occur_check_lambda_t(p0, p1); };
    if (p1[0] == NODE_TYVAR) {
        if (p0 == p1[1]) {
            fputs(stderr, "ERROR: infinite type\n");
            exit(1);
        };
        x0 = map_find(tyvarmap, p1[1]);
        if (x0 == NULL) { return; };
        x0 = rename_tyscheme(x0);
        occur_check(p0, x0[1]);
        return;
    };
};

occur_check_tuple_t: (p0, p1) {
    allocate(2);
    x1 = p1[1]; (% length %);
    x0 = 0;
    while (x0 < x1) {
        occur_check(p0, (p1[2])[x0]);
        x0 = x0 + 1;
    };
};

occur_check_lambda_t: (p0, p1) {
    occur_check(p0, p1[1]);
    occur_check(p0, p1[2]);
};

(% p0, p1: type %);
type_mismatch: (p0, p1) {
    fputs(stderr, "ERROR: type mismatch ");
    put_type(stderr, p0);
    fputs(stderr, " <-> ");
    put_type(stderr, p1);
    fputc(stderr, '\n');
    exit(1);
};

deref_funcs: [not_reachable, deref_integer, deref_string, deref_dontcare,
    deref_identifier, deref_array, deref_tuple, deref_block, deref_decl,
    deref_call, deref_subscript, deref_lambda, deref_unexpr, deref_binexpr,
    deref_assign, deref_export, deref_import, deref_external, deref_ret, deref_retval,
    deref_syscall, deref_field, deref_fieldref, deref_typedecl, deref_variant, deref_unit,
    deref_typedexpr, deref_if, deref_ifelse, deref_static_array, deref_cast, deref_new,
    deref_while, deref_for, deref_newarray, deref_rewrite
];

(% p0: item %);
deref: (p0) {
    allocate(1);
    x0 = deref_funcs[p0[0]];
    x0(p0);
};

deref_identifier: (p0) {
    p0[1] = deref_type(p0[1]);
    p0[4] = closure(p0[1]);
};

deref_dontcare: (p0) {
    p0[1] = deref_type(p0[1]);
};

deref_integer: (p0) {
    p0[1] = deref_type(p0[1]);
};

deref_string: (p0) {
    p0[1] = deref_type(p0[1]);
};

deref_array: (p0) {
    allocate(3);
    x0 = p0[2]; (% length %);
    x1 = 0;
    while (x1 < x0) {
        x2 = p0[3];
        deref(x2[x1]);
        x1 = x1 + 1;
    };
    p0[1] = deref_type(p0[1]);
};

deref_tuple: (p0) {
    allocate(3);
    x0 = p0[2]; (% length %);
    x1 = 0;
    while (x1 < x0) {
        x2 = p0[3];
        deref(x2[x1]);
        x1 = x1 + 1;
    };
    p0[1] = deref_type(p0[1]);
};

deref_block: (p0) {
    allocate(1);
    x0 = p0[BLOCK_STATEMENTS];
    while (x0 != NULL) {
        deref(ls_value(x0));
        x0 = ls_next(x0);
    };
    p0[1] = deref_type(p0[1]);
};

deref_decl: (p0) {
    deref(p0[2]); (% lhs %);
    deref(p0[3]); (% rhs %);
    p0[1] = deref_type(p0[1]);
};

deref_call: (p0) {
    deref(p0[2]); (% function %);
    deref(p0[3]); (% argument %);
    p0[1] = deref_type(p0[1]);
};

deref_subscript: (p0) {
    deref(p0[2]);
    deref(p0[3]);
    p0[1] = deref_type(p0[1]);
};

deref_lambda: (p0) {
    deref(p0[LAMBDA_ARG]);
    deref(p0[LAMBDA_BODY]);
    p0[1] = deref_type(p0[1]);
};

deref_unexpr: (p0) {
    deref(p0[3]);
    p0[1] = deref_type(p0[1]);
};

deref_binexpr: (p0) {
    deref(p0[3]);
    deref(p0[4]);
    p0[1] = deref_type(p0[1]);
};

deref_assign: (p0) {
    deref(p0[3]);
    deref(p0[4]);
    p0[1] = deref_type(p0[1]);
};

deref_export: (p0) {
    deref(p0[1]);
};

deref_import: (p0) {
    (% do nothing %);
};

deref_external: (p0) {
    (% do nothing %);
};

deref_ret: (p0) {
    p0[1] = deref_type(p0[1]);
};

deref_retval: (p0) {
    deref(p0[RETVAL_VALUE]);
    p0[1] = deref_type(p0[1]);
};

deref_syscall: (p0) {
    deref(p0[2]);
    p0[1] = deref_type(p0[1]);
};

deref_field: (p0) {
    deref(p0[3]);
    p0[1] = deref_type(p0[1]);
};

deref_fieldref: (p0) {
    deref(p0[2]); (% lhs %);
    p0[1] = deref_type(p0[1]);
};

deref_typedecl: (p0) {
    (% do nothing %);
};

deref_variant: (p0) {
    if (p0[4] != NULL) {
        deref(p0[4]);
    };
    p0[1] = deref_type(p0[1]);
};

deref_unit: (p0) {
    (% do nothing %);
};

deref_typedexpr: (p0) {
    deref(p0[2]);
    p0[1] = deref_type(p0[1]);
};

deref_if: (p0) {
    deref(p0[2]);
    deref(p0[3]);
    p0[1] = deref_type(p0[1]);
};

deref_ifelse: (p0) {
    deref(p0[2]);
    deref(p0[3]);
    deref(p0[4]);
    p0[1] = deref_type(p0[1]);
};

deref_static_array: (p0) {
    deref(p0[2]);
    deref(p0[3]);
    p0[1] = deref_type(p0[1]);
};

deref_cast: (p0) {
    deref(p0[2]);
    p0[1] = deref_type(p0[1]);
};

deref_new: (p0) {
    deref(p0[2]);
    p0[1] = deref_type(p0[1]);
};

deref_while: (p0) {
    deref(p0[2]);
    deref(p0[3]);
};

deref_for: (p0) {
    deref(p0[2]);
    deref(p0[3]);
    deref(p0[4]);
    deref(p0[5]);
};

deref_newarray: (p0) {
    deref(p0[2]);
    deref(p0[3]);
    p0[1] = deref_type(p0[1]);
};

deref_rewrite: (p0) {
    (% do nothing %);
    return;
};

(% p0: type %);
deref_type: (p0) {
    allocate(3);
    if (p0[0] == NODE_TUPLE_T) {
        x0 = p0[1]; (% length %);
        x1 = 0;
        while (x1 < x0) {
            x2 = p0[2];
            x2[x1] = deref_type(x2[x1]);
            x1 = x1 + 1;
        };
        return p0;
    };
    if (p0[0] == NODE_ARRAY_T)   { p0[1] = deref_type(p0[1]); return p0; };
    if (p0[0] == NODE_LAMBDA_T) {
        p0[1] = deref_type(p0[1]);
        p0[2] = deref_type(p0[2]);
        return p0;
    };
    if (p0[0] == NODE_TYVAR) {
        x0 = map_find(tyvarmap, p0[1]); (% x0: type scheme %);
        if (x0 == NULL) { return p0; };
        x1 = x0[1];
        x1 = deref_type(x1);
        x2 = closure(x1);
        map_add(tyvarmap, p0[1], x2);
        return x1
    };
    if (p0[0] == NODE_FIELD_T) {
        p0[2] = deref_type(p0[2]);
        return p0;
    };
    if (p0[0] == NODE_NAMED_T) {
	if (p0[2] != NULL) {
	    p0[2] = deref_type(p0[2]);
	};
	return p0;
    };
    return p0;
};

(% p0: pattern %);
deref_pattern: (p0) {
    allocate(3);
    if (p0[0] == NODE_DONTCARE) {
        p0[1] = deref_type(p0[1]);
        return;
    };
    if (p0[0] == NODE_IDENTIFIER) {
        p0[1] = deref_type(p0[1]);
        p0[4] = closure(p0[1]);
        return;
    };
    if (p0[0] == NODE_TUPLE) {
        x0 = p0[TUPLE_LENGTH];
        x1 = p0[TUPLE_ELEMENTS];
        x2 = 0;
        while (x2 < x0) {
            deref_pattern(x1[x2]);
            x2 = x2 + 1;
        };
        p0[1] = deref_type(p0[1]);
        return;
    };
    not_reachable();
};

(% p0: program (item list) %);
typing: (p0) {
    allocate(1);

    varmap = mkmap(&ident_hash, &ident_equal, 10);
    funtable = mkmap(&ident_hash, &ident_equal, 10);
    scopeid_stack = mkvec(0);
    scope_push(); (% global scopeid %);
    init_tyvarmap();

    variant_map  = mkmap(&strhash, &streq, 10);
    return_stack = mkvec(0);

    x0 = p0[1];
    while (x0 != NULL) {
        infer_item(ls_value(x0));
        x0 = ls_next(x0);
    };
    return p0;
};

(%
 % rowl - generation 1
 % Copyright (C) 2010 nineties
 %
 % $Id: typing.rl 2010-04-23 16:56:50 nineties $
 %);

include(stddef, code);

export(init_typing, typing, unit_type, char_type, int_type, float_type, double_type, void_type);
export(get_variable);

scopeid: 0;
scopeid_stack: NULL;

varmap: NULL; (% variable table. name -> list of (tyscheme, id) %);

(% p0: (scopeid-id, name) %);
varmap_hash: (p0) {
    return strhash(p0[1]) * 3+ p0[0];
};

varmap_keyequal: (p0, p1) {
    if (p0[0] != p1[0]) { return FALSE; };
    return streq(p0[1], p1[1]);
};

varmap_push: () {
    scopeid = scopeid + 1;
    vec_pushback(scopeid_stack, scopeid);
};

varmap_pop: () {
    vec_popback(scopeid_stack);
};

(% p0: name, p1: value %);
varmap_add: (p0, p1) {
    allocate(1);
    x0 = vec_at(scopeid_stack, vec_size(scopeid_stack)-1);
    map_add(varmap, mktup2(x0, p0), p1);
};

(% p0: name %);
varmap_find: (p0) {
    allocate(3);
    x0 = vec_size(scopeid_stack)-1;
    while (x0 >= 0) {
        x1 = vec_at(scopeid_stack, x0); (% scopeid-id %);
        x2 = map_find(varmap, mktup2(x1, p0));
        if (x2 != NULL) { return x2; };
        x0 = x0 - 1;
    };
    return NULL;
};

init_varmap: () {
    varmap = mkmap(&varmap_hash, &varmap_keyequal, 10);
    scopeid_stack = mkvec(0);
    varmap_push(); (% global scopeid %);
};

(% p0: name %);
get_variable: (p0) {
    allocate(1);
    x0 = varmap_find(p0); (% tyscheme, id, is_global %);
    if (x0 == NULL) {
        fputs(stderr, "ERROR: variable '");
        fputs(stderr, p0);
        fputs(stderr, "' is not declared\n");
        exit(1);
    };
    return mktup6(NODE_IDENTIFIER, x0[0][1], p0, x0[1], x0[0], x0[2]);
};

in_global_namespace: () {
    return vec_size(scopeid_stack) == 1;
};

tyvarmap: NULL;

tyvarid_hash: (p0) {
    return p0;
};

tyvarid_equal: (p0, p1) {
    return p0 == p1;
};

init_tyvarmap: () {
    tyvarmap = mkmap(&tyvarid_hash, &tyvarid_equal, 10);
};

(% constructor name -> (variant type, corresponding row) %);
variant_map: NULL;

not_reachable: (p0) {
    fputs(stderr, "ERROR: not reachable here\n");
    exit(1);
};

not_implemented: (p0) {
    fputs(stderr, "ERROR: not implemented\n");
    exit(1);
};

infer_funcs: [not_reachable, infer_integer, infer_string, not_implemented,
    infer_identifier, infer_array, infer_tuple, infer_block, infer_decl,
    infer_call, infer_subscript, infer_lambda, infer_unexpr, infer_binexpr,
    infer_assign, infer_export, infer_import, infer_external, infer_ret, infer_retval,
    infer_syscall, infer_field, infer_fieldref, infer_typedecl, infer_variant, infer_unit,
    infer_typedexpr, infer_if, infer_ifelse, infer_static_array, infer_cast, infer_new,
    infer_while, infer_for, infer_newarray, infer_rewrite
];

unit_type   : NULL;
char_type   : NULL;
int_type    : NULL;
float_type  : NULL;
double_type : NULL;
void_type   : NULL;

init_typing: () {
    unit_type   = mktup1(NODE_UNIT_T);
    char_type   = mktup1(NODE_CHAR_T);
    int_type    = mktup1(NODE_INT_T);
    float_type  = mktup1(NODE_FLOAT_T);
    double_type = mktup1(NODE_DOUBLE_T);
    void_type   = mktup1(NODE_VOID_T);
};

infer_integer: (p0) {
    if (p0[2] == 8)  { p0[1] = char_type; return char_type; };
    if (p0[2] == 32) { p0[1] = int_type;  return int_type; };
    not_reachable();
};

infer_string: (p0) {
    p0[1] = mktup3(NODE_NAMED_T, "string", NULL);
    return p0[1];
};

infer_identifier: (p0) {
    allocate(3);
    x0 = varmap_find(p0[2]); (% (tyscheme, id, is_global) %);
    if (x0 == NULL) {
        fputs(stderr, "ERROR: undefined symbol '");
        fputs(stderr, p0[2]);
        fputs(stderr, "'\n");
        exit(1);
    };

    x1 = rename_tyscheme(x0[0]);
    p0[1] = x1[1];
    p0[3] = x0[1];
    p0[4] = x1;
    p0[5] = x0[2];

    deref(p0);

    return p0[1];
};

infer_array: (p0) {
    allocate(5);
    x0 = mktyvar();
    x1 = p0[2]; (% length %);
    x2 = 0;
    x3 = p0[3]; (% pointer to the array %);
    while (x2 < x1) {
        x4 = x3[x2];
        x4[1] = infer_item(x3[x2]);
        unify(x0, x4[1], TRUE);
        x2 = x2 + 1;
    };
    not_implemented();
    p0[1] = mktup4(NODE_ARRAY_T, x0, x1, FALSE);
    deref(p0);
    return p0[1];
};

infer_tuple: (p0) {
    allocate(5);
    x1 = p0[2]; (% length %);
    x2 = p0[3];
    x3 = memalloc(4*x1);
    x0 = 0;
    while (x0 < x1) {
        x4 = x2[x0];
        x4[1] = infer_item((p0[3])[x0]);
        x3[x0] = x4[1];
        x0 = x0 + 1;
    };
    p0[1] = mktup3(NODE_TUPLE_T, x1, x3);
    deref(p0);
    return p0[1];
};

do_exit: (p0) {
    if (p0[0] == NODE_RETVAL) { return TRUE; };
    if (p0[0] == NODE_RET)    { return TRUE; };
    if (p0[1][0] == NODE_VOID_T) { return TRUE; };
    return FALSE;
};

(% p0: instruction %);
block_type: (p0) {
    if (p0[0] == NODE_RET) { return void_type; };
    if (p0[0] == NODE_RETVAL) { return void_type; };
    if (p0[1][0] == NODE_VOID_T) {
        return void_type;
    };
    return unit_type;
};

return_stack: NULL;

infer_block: (p0) {
    allocate(3);
    x0 = p0[BLOCK_STATEMENTS];

    if (x0 != NULL) {
        while (x0 != NULL) {
            x1 = ls_value(x0);
            x2 = infer_item(x1);
            if (ls_next(x0) != NULL) {
                if (do_exit(ls_value(x0))) {
                    fputs(stderr, "ERROR: unreachable code '");
                    put_item(stderr, ls_value(ls_next(x0)));
                    fputs(stderr, "'\n");
                    exit(1);
                };
            } else {
                p0[1] = block_type(x1);
            };
            x0 = ls_next(x0);
        };
    } else {
        (% empty function body %);
        p0[1] = unit_type;
    };

    deref(p0);
    return p0[1];
};

(% p0: dontcare pattern, p1: expr %);
infer_decl_dontcare: (p0, p1) {
    p0[1] = infer_item(p1);
    return p0[1];
};

(% p0: var, p1: expr %);
infer_decl_var: (p0, p1) {
    allocate(5);
    x0 = mktyvar();
    x1 = set_varid(p0);
    x2 = in_global_namespace();
    varmap_add(p0[2], mktup3(mktyscheme(x0), x1, x2));
    x3 = infer_item(p1);
    unify(x0, x3, TRUE);
    x4 = closure(x3);
    varmap_add(p0[2], mktup3(x4, x1, x2));
    p0[1] = x3; (% type %);
    p0[3] = x1; (% variable id %);
    p0[4] = x4; (% type scheme %);
    p0[5] = x2;
    deref_pattern(p0);
    deref(p1);
    return p0[1];
};

(% p0: tuple pattern, p1: expr %);
infer_decl_tuple: (p0, p1) {
    allocate(1);
    x0 = infer_pattern(p0);
    unify(x0, infer_item(p1), TRUE);
    deref_pattern(p0);
    deref(p1);
    return p0[1];
};

infer_pattern: (p0) {
    allocate(5);
    if (p0[0] == NODE_UNIT) {
        p0[1] = unit_type;
        return unit_type;
    };
    if (p0[0] == NODE_DONTCARE) {
        x0 = mktyvar();
        p0[1] = x0;
        return x0;
    };
    if (p0[0] == NODE_IDENTIFIER) {
        (% variable pattern %);
        x0 = mktyvar(); (% type of variable %);
        x1 = set_varid(p0);
        x2 = mktup3(mktyscheme(x0), x1, in_global_namespace());
        varmap_add(p0[2], x2);
        p0[1] = x0;
        p0[3] = x1;
        p0[4] = x2;
        deref(p0);
        return p0[1];
    };
    if (p0[0] == NODE_TUPLE) {
        (% tuple pattern %);
        x0 = p0[TUPLE_LENGTH];
        x1 = p0[TUPLE_ELEMENTS];
        x2 = memalloc(4*x0); (% element types %);
        x3 = 0;
        while (x3 < x0) {
            x4 = infer_pattern(x1[x3]);
            x2[x3] = x4;
            x3 = x3 + 1;
        };
        p0[1] = mktup3(NODE_TUPLE_T, x0, x2);
        return p0[1];
    };
    if (p0[0] == NODE_TYPEDEXPR) {
        (% typed pattern %);
        x0 = infer_pattern(p0[2]);
        unify(x0, p0[1], TRUE);
        deref(p0);
        return p0[1];
    };
    fputs(stderr, "ERROR: invalid pattern expression\n");
    exit(1);
};

(% p0: lhs, p1: rhs %);
infer_decl_impl: (p0, p1) {
    if (p0[0] == NODE_DONTCARE) {
        return infer_decl_dontcare(p0, p1);
    };
    if (p0[0] == NODE_IDENTIFIER) {
        return infer_decl_var(p0, p1);
    };
    if (p0[0] == NODE_TUPLE) {
        return infer_decl_tuple(p0, p1);
    };
    not_implemented();
};

infer_decl: (p0) {
    allocate(1);
    x0 = infer_decl_impl(p0[2], p0[3]);
    p0[1] = x0;
    deref(p0);
    return p0[1];
};

(% p0: expr %);
infer_call: (p0) {
    allocate(3);
    x0 = infer_item(p0[2]); (% function type %);
    x1 = infer_item(p0[3]); (% argument type %);
    x2 = mktyvar(); (% return type %);
    unify(x0, mktup3(NODE_LAMBDA_T, x1, x2), TRUE);

    p0[1] = x2;
    deref(p0);
    return p0[1];
};

infer_subscript: (p0) {
    allocate(2);
    x0 = infer_item(p0[2]);
    x1 = infer_item(p0[3]);
    unify(int_type, x1, TRUE);
    if (x0[0] == NODE_SARRAY_T) {
	p0[1] = x0[1];
	deref(p0);
	return p0[1];
    };
    if (x0[0] == NODE_ARRAY_T) {
        p0[1] = x0[1];
        deref(p0);
        return p0[1];
    };
    not_implemented();
};

insert_missing_ret: (p0) {
    allocate(1);
    if (p0 == NULL) {
        return ls_singleton(mktup2(NODE_RET, unit_type));
    };
    x0 = ls_value(p0);
    if (x0[0] == NODE_RET)    { return p0; };
    if (x0[0] == NODE_RETVAL) { return p0; };
    if (x0[1] == void_type)   { return p0; };
    return ls_cons(x0, insert_missing_ret(ls_next(p0)));
};

infer_lambda: (p0) {
    allocate(3);

    (% lambda opens new namespace %);
    varmap_push();
    x0 = infer_pattern(p0[LAMBDA_ARG]);

    vec_pushback(return_stack, NULL);
    x1 = infer_item(p0[LAMBDA_BODY]);
    x2 = vec_at(return_stack, vec_size(return_stack)-1);
    if (x2 != NULL) {
        x1 = x2;
    };
    vec_popback(return_stack);
    varmap_pop();

    p0[1] = mktup3(NODE_LAMBDA_T, x0, x1);

    if (p0[1] != void_type) {
        x2 = p0[LAMBDA_BODY];
        x2[2] = insert_missing_ret(x2[2]);
    };

    deref(p0);
    return p0[1];
};

unexpr_funcs: [
    infer_unarith, infer_unarith, infer_unarith, infer_unarith, not_implemented,
    infer_indirect, infer_unarith, infer_unarith, infer_unarith, infer_unarith
];

infer_unarith: (p0) {
    allocate(1);
    x0 = infer_item(p0[3]);
    unify(int_type, x0, TRUE);
    p0[1] = int_type;
    return int_type;
};

infer_indirect: (p0) {
    allocate(2);
    x0 = infer_item(p0[3]);
    x1 = mktyvar();
    unify(mktup2(NODE_POINTER_T, x1), x0, TRUE);
    p0[1] = x1;
    deref(p0);
    return p0[1];
};

infer_unexpr: (p0) {
    allocate(1);
    x0 = unexpr_funcs[p0[2]];
    return x0(p0);
};

binexpr_funcs: [
    not_reachable, infer_binarith, infer_binarith, infer_binarith, infer_binarith,
    infer_binarith, infer_binarith, infer_binarith, infer_binarith, infer_binarith,
    infer_binarith, infer_equality, infer_equality, infer_binarith, infer_binarith,
    infer_binarith, infer_binarith, not_implemented, not_implemented
];

infer_binarith: (p0) {
    allocate(2);
    x0 = infer_item(p0[3]);
    x1 = infer_item(p0[4]);
    unify(int_type, x0, TRUE);
    unify(int_type, x1, TRUE);
    p0[1] = int_type;
    deref(p0);
    return p0[1];
};

infer_equality: (p0) {
    allocate(2);
    x0 = infer_item(p0[3]);
    x1 = infer_item(p0[4]);
    unify(x0, x1, TRUE);
    p0[1] = int_type;
    deref(p0);
    return int_type;
};

infer_binexpr: (p0) {
    allocate(1);
    x0 = binexpr_funcs[p0[2]];
    return x0(p0);
};

infer_assign: (p0) {
    allocate(2);
    x0 = infer_item(p0[3]); (% lhs type %);
    x1 = infer_item(p0[4]); (% rhs type %);
    unify(x0, x1, TRUE);
    p0[1] = x0;
    return x0;
};

infer_export: (p0) {
    infer_item(p0[1]);
    deref(p0);
    return unit_type;
};

infer_import: (p0) {
    (% do nothing %);
};

infer_external: (p0) {
    allocate(5);
    x0 = p0[1]; (% ident %);
    x1 = p0[2]; (% type %);
    x2 = closure(x1);
    x3 = set_varid(x0);
    varmap_add(get_ident_name(x0), mktup3(x2, x3, TRUE));
    x0[1] = x1;
    x0[3] = x3;
    x0[4] = x2;
    x0[5] = TRUE;
    return unit_type;
};

infer_ret: (p0) {
    allocate(1);
    x0 = vec_back(return_stack);
    if (x0 != NULL) {
        unify(x0, unit_type, TRUE);
    };
    vec_put(return_stack, vec_size(return_stack)-1, unit_type);
    p0[1] = unit_type;
    deref(p0);
    return unit_type;
};

(% return e; is treated as .pseudo_retvar = e; %);
infer_retval: (p0) {
    allocate(1);
    p0[1] = infer_item(p0[RETVAL_VALUE]);
    x0 = vec_back(return_stack);
    if (x0 != NULL) {
        unify(p0[1], x0, TRUE);
    };
    deref(p0);
    vec_put(return_stack, vec_size(return_stack)-1, p0[1]);
    return p0[1];
};

infer_syscall: (p0) {
    infer_item(p0[2]);
    p0[1] = mktyvar();
    deref(p0);
    return p0[1];
};

(% fieldname : expression %);
infer_field: (p0) {
    allocate(3);
    x0 = p0[2]; (% lhs %);
    if (x0[0] != NODE_IDENTIFIER) {
        fputs(stderr, "ERROR: invalid field name\n");
        exit(1);
    };
    x1 = infer_item(p0[3]);
    x2 = mktup3(NODE_FIELD_T, get_ident_name(x0), x1);
    p0[1] = x2;
    deref(p0);
    return p0[1];
};

(% p0: type, p1: field name %);
get_fieldtype: (p0, p1) {
    allocate(4);
    if (p0[0] == NODE_TUPLE_T) {
        x0 = p0[TUPLE_T_LENGTH];
        x1 = p0[TUPLE_T_ELEMENTS];
        x2 = 0;
        while (x2 < x0) {
            x3 = x1[x2];
            if (has_name(x3, p1)) {
                return x3[2];
            };
            x2 = x2 + 1;
        };
        return NULL;
    };
    if (p0[0] == NODE_VARIANT_T) {
        x0 = p0[2]; (% rows %);
        if (ls_length(x0) != 1) {
            return NULL;
        };
        x1 = (ls_value(x0))[2]; (% argument type %);
        return get_fieldtype(x1, p1);
    };
    if (p0[0] == NODE_NAMED_T) {
        if (p0[2] != NULL) {
            return get_fieldtype(p0[2], p1);
        };
        return NULL;
    };
    return NULL;
};

infer_fieldref: (p0) {
    allocate(3);
    x0 = infer_item(p0[2]); (% lhs %);
    x1 = p0[3]; (% field name %);
    x2 = get_fieldtype(x0, x1);
    if (x2 == NULL) {
        fputs(stderr, "ERROR: field '");
        fputs(stderr, x1);
        fputs(stderr, "' not found\n");
        exit(1);
    };
    p0[1] = x2;
    deref(p0);
    return p0[1];
};

infer_typedecl: (p0) {
    allocate(5);
    x0 = p0[1]; (% identifier %);
    x1 = p0[2][2]; (% type %);
    if (x1 == NULL) {
	return unit_type;
    };
    if (x1[0] == NODE_VARIANT_T) {
        x1[1] = x0;
        x2 = x1[2]; (% rows %);
        x3 = 0; (% constructor id %);

        (% set constructor-id and register to variant_map %);
        while (x2 != NULL) {
            x4 = ls_value(x2); (% constructor name, id, arg %);
            x4[1] = x3;
            map_add(variant_map, x4[0], mktup2(x1, x4));
            x2 = ls_next(x2);
            x3 = x3 + 1;
        };
        return unit_type;
    };
    return unit_type;
};

infer_variant: (p0) {
    allocate(3);
    x0 = p0[2]; (% constructor name %);
    x1 = map_find(variant_map, x0); (% (type, (constructor name, id, arg type)) %);
    assert(x1 != NULL);
    p0[1] = x1[0];
    p0[3] = x1[1][1]; (% id %);
    if (p0[4] != NULL) {
        x2 = infer_item(p0[4]); (% infer argument %);
        unify(x2, x1[1][2], TRUE);
    };
    deref(p0);
    return p0[1];
};

infer_unit: (p0) {
    p0[1] = unit_type;
    return unit_type;
};

infer_typedexpr: (p0) {
    allocate(1);
    x0 = infer_item(p0[2]); (% expression %);
    unify(x0, p0[1], TRUE);
    deref(p0);
    return p0[1];
};

infer_if: (p0) {
    allocate(1);
    x0 = infer_item(p0[2]); (% condition %);
    unify(x0, int_type, TRUE);
    infer_item(p0[3]);
    p0[1] = unit_type;
    deref(p0);
    return p0[1];
};

infer_ifelse: (p0) {
    allocate(3);
    x0 = infer_item(p0[2]); (% condition %);
    unify(int_type, x0, TRUE);
    x1 = infer_item(p0[3]); (% ifthen block %);
    x2 = infer_item(p0[4]); (% ifelse block %);
    p0[1] = unify_join(x1, x2, TRUE);
    deref(p0);
    return p0[1];
};

infer_static_array: (p0) {
    allocate(4);
    x0 = infer_item(p0[2]); (% initializer %);
    x1 = infer_item(p0[3]); (% length %);
    unify(x1, int_type, TRUE);
    p0[1] = mktup2(NODE_SARRAY_T, x0);
    deref(p0);
    return p0[1];
};

infer_cast: (p0) {
    infer_item(p0[2]);
    deref(p0);
    return p0[1];
};

infer_new: (p0) {
    allocate(1);
    x0 = infer_item(p0[2]);
    p0[1] = mktup2(NODE_POINTER_T, x0);
    deref(p0);
    return p0[1];
};

infer_while: (p0) {
    allocate(1);
    x0 = infer_item(p0[2]); (% condition %);
    unify(int_type, x0, TRUE);
    infer_item(p0[3]);
    p0[1] = unit_type;
    deref(p0);
    return p0[1];
};

infer_for: (p0) {
    allocate(1);
    infer_item(p0[2]);
    x0 = infer_item(p0[3]); (% condition %);
    unify(int_type, x0, TRUE);
    infer_item(p0[4]);
    infer_item(p0[5]);
    p0[1] = unit_type;
    deref(p0);
    return p0[1];
};

infer_newarray: (p0) {
    allocate(2);
    x0 = infer_item(p0[2]); (% length %);
    unify(int_type, x0, TRUE);
    x1 = infer_item(p0[3]);
    p0[1] = mktup2(NODE_ARRAY_T, x1);
    deref(p0);
    return p0[1];
};

infer_rewrite: (p0) {
    return unit_type;
};

(% p0: item %);
infer_item: (p0) {
    allocate(1);
    x0 = infer_funcs[p0[0]];
    return x0(p0);
};

remove_freevar: (p0) {
    allocate(1);
    if (p0 == NULL) { return NULL; };
    x0 = map_find(tyvarmap, ls_value(p0));
    if (x0 != NULL) {
        p0[1] = remove_freevar(ls_next(p0));
        return p0;
    };
    return remove_freevar(ls_next(p0));
};

(% p0: type %);
closure: (p0) {
    allocate(1);
    x0 = freevar(p0);
    x0 = remove_freevar(x0);
    return mktup2(x0, p0);
};

(% p0, p1: type, p2: do update tyvarmap %);
unify: (p0, p1, p2) {
    if (p0[0] == NODE_TYVAR) { return unify_tyvar(p0, p1, p2); };
    if (p1[0] == NODE_TYVAR) { return unify_tyvar(p1, p0, p2); };
    if (p0[0] == p1[0]) {
        if (p0[0] == NODE_UNIT_T)     { return TRUE; };
        if (p0[0] == NODE_CHAR_T)     { return TRUE; };
        if (p0[0] == NODE_INT_T)      { return TRUE; };
        if (p0[0] == NODE_FLOAT_T)    { return TRUE; };
        if (p0[0] == NODE_DOUBLE_T)   { return TRUE; };
        if (p0[0] == NODE_POINTER_T)  { return unify(p0[POINTER_T_BASE], p1[POINTER_T_BASE], p2); };
        if (p0[0] == NODE_TUPLE_T)    { return unify_tuple_t(p0, p1, p2); };
        if (p0[0] == NODE_ARRAY_T)    {
            unify(p0[ARRAY_T_ELEMENT], p1[ARRAY_T_ELEMENT], p2);
            return TRUE;
        };
        if (p0[0] == NODE_LAMBDA_T) { return unify_lambda_t(p0, p1, p2); };
        if (p0[0] == NODE_VARIANT_T) {
            if (streq(p0[1], p1[1])) { return TRUE; };
        };
	if (p0[0] == NODE_NAMED_T) {
	    if (streq(p0[1], p1[1])) { return TRUE; };
	};
    };
    if (p0[0] == NODE_NAMED_T) {
	if (p0[2] != NULL) {
	    return unify(p0[2], p1, p2);
	};
    };
    if (p1[0] == NODE_NAMED_T) {
	if (p1[2] != NULL) {
	    return unify(p0, p1[2], p2);
	};
    };
    if (p0[0] == NODE_FIELD_T) {
        return unify(p0[2], p1, p2);
    };
    if (p1[0] == NODE_FIELD_T) {
        return unify(p0, p1[2], p2);
    };
    if (p2) {
        type_mismatch(p0, p1);
    };
    return FALSE;
};

unify_tuple_t: (p0, p1, p2) {
    allocate(2);
    if (p0[1] != p1[1]) {
        if (p2) {
            type_mismatch(p0, p1);
        };
        return FALSE;
    };
    x1 = p0[1]; (% length %);
    x0 = 0;
    while (x0 < x1) {
        if (unify((p0[2])[x0], (p1[2])[x0], p2) == FALSE) {
            return FALSE;
        };
        x0 = x0 + 1;
    };
    return TRUE;
};

unify_lambda_t: (p0, p1, p2) {
    if(unify(p0[1], p1[1], p2) == FALSE) {
        return FALSE;
    };
    return unify(p0[2], p1[2], p2);
};

(% p0: tyvar, p1, type %);
unify_tyvar: (p0, p1, p2) {
    allocate(1);
    if (p1[0] == NODE_TYVAR) {
        if (p0[1] == p1[1]) { return TRUE; };
    };
    x0 = map_find(tyvarmap, p0[1]);
    if (x0 != NULL) {
        return unify(x0[1], p1, p2);
    };
    if (p1[0] == NODE_TYVAR) {
        x0 = map_find(tyvarmap, p1[1]);
        if (x0 != NULL) {
            return unify(p0, x0[1], p2);
        };
    };
    occur_check(p0[1], p1);
    if (p2) {
        x0 = closure(p1);
        map_add(tyvarmap, p0[1], x0);
    };
};

(% p0: type of ifthen block, p1: type of ifelse block %);
unify_join: (p0, p1) {
    if (p0 == void_type) { return p1; };
    if (p1 == void_type) { return p0; };
    return unit_type;
};

(% p0: id, p1, type %);
occur_check: (p0, p1) {
    allocate(1);
    if (p1[0] == NODE_TUPLE_T)  { return occur_check_tuple_t(p0, p1); };
    if (p1[0] == NODE_ARRAY_T)  { return occur_check(p0, p1[1]); };
    if (p1[0] == NODE_LAMBDA_T) { return occur_check_lambda_t(p0, p1); };
    if (p1[0] == NODE_TYVAR) {
        if (p0 == p1[1]) {
            fputs(stderr, "ERROR: infinite type\n");
            exit(1);
        };
        x0 = map_find(tyvarmap, p1[1]);
        if (x0 == NULL) { return; };
        x0 = rename_tyscheme(x0);
        occur_check(p0, x0[1]);
        return;
    };
};

occur_check_tuple_t: (p0, p1) {
    allocate(2);
    x1 = p1[1]; (% length %);
    x0 = 0;
    while (x0 < x1) {
        occur_check(p0, (p1[2])[x0]);
        x0 = x0 + 1;
    };
};

occur_check_lambda_t: (p0, p1) {
    occur_check(p0, p1[1]);
    occur_check(p0, p1[2]);
};

(% p0, p1: type %);
type_mismatch: (p0, p1) {
    fputs(stderr, "ERROR: type mismatch ");
    put_type(stderr, p0);
    fputs(stderr, " <-> ");
    put_type(stderr, p1);
    fputc(stderr, '\n');
    exit(1);
};

deref_funcs: [not_reachable, deref_integer, deref_string, deref_dontcare,
    deref_identifier, deref_array, deref_tuple, deref_block, deref_decl,
    deref_call, deref_subscript, deref_lambda, deref_unexpr, deref_binexpr,
    deref_assign, deref_export, deref_import, deref_external, deref_ret, deref_retval,
    deref_syscall, deref_field, deref_fieldref, deref_typedecl, deref_variant, deref_unit,
    deref_typedexpr, deref_if, deref_ifelse, deref_static_array, deref_cast, deref_new,
    deref_while, deref_for, deref_newarray, deref_rewrite
];

(% p0: item %);
deref: (p0) {
    allocate(1);
    x0 = deref_funcs[p0[0]];
    x0(p0);
};

deref_identifier: (p0) {
    p0[1] = deref_type(p0[1]);
    p0[4] = closure(p0[1]);
};

deref_dontcare: (p0) {
    p0[1] = deref_type(p0[1]);
};

deref_integer: (p0) {
    p0[1] = deref_type(p0[1]);
};

deref_string: (p0) {
    p0[1] = deref_type(p0[1]);
};

deref_array: (p0) {
    allocate(3);
    x0 = p0[2]; (% length %);
    x1 = 0;
    while (x1 < x0) {
        x2 = p0[3];
        deref(x2[x1]);
        x1 = x1 + 1;
    };
    p0[1] = deref_type(p0[1]);
};

deref_tuple: (p0) {
    allocate(3);
    x0 = p0[2]; (% length %);
    x1 = 0;
    while (x1 < x0) {
        x2 = p0[3];
        deref(x2[x1]);
        x1 = x1 + 1;
    };
    p0[1] = deref_type(p0[1]);
};

deref_block: (p0) {
    allocate(1);
    x0 = p0[BLOCK_STATEMENTS];
    while (x0 != NULL) {
        deref(ls_value(x0));
        x0 = ls_next(x0);
    };
    p0[1] = deref_type(p0[1]);
};

deref_decl: (p0) {
    deref(p0[2]); (% lhs %);
    deref(p0[3]); (% rhs %);
    p0[1] = deref_type(p0[1]);
};

deref_call: (p0) {
    deref(p0[2]); (% function %);
    deref(p0[3]); (% argument %);
    p0[1] = deref_type(p0[1]);
};

deref_subscript: (p0) {
    deref(p0[2]);
    deref(p0[3]);
    p0[1] = deref_type(p0[1]);
};

deref_lambda: (p0) {
    deref(p0[LAMBDA_ARG]);
    deref(p0[LAMBDA_BODY]);
    p0[1] = deref_type(p0[1]);
};

deref_unexpr: (p0) {
    deref(p0[3]);
    p0[1] = deref_type(p0[1]);
};

deref_binexpr: (p0) {
    deref(p0[3]);
    deref(p0[4]);
    p0[1] = deref_type(p0[1]);
};

deref_assign: (p0) {
    deref(p0[3]);
    deref(p0[4]);
    p0[1] = deref_type(p0[1]);
};

deref_export: (p0) {
    deref(p0[1]);
};

deref_import: (p0) {
    (% do nothing %);
};

deref_external: (p0) {
    (% do nothing %);
};

deref_ret: (p0) {
    p0[1] = deref_type(p0[1]);
};

deref_retval: (p0) {
    deref(p0[RETVAL_VALUE]);
    p0[1] = deref_type(p0[1]);
};

deref_syscall: (p0) {
    deref(p0[2]);
    p0[1] = deref_type(p0[1]);
};

deref_field: (p0) {
    deref(p0[3]);
    p0[1] = deref_type(p0[1]);
};

deref_fieldref: (p0) {
    deref(p0[2]); (% lhs %);
    p0[1] = deref_type(p0[1]);
};

deref_typedecl: (p0) {
    (% do nothing %);
};

deref_variant: (p0) {
    if (p0[4] != NULL) {
        deref(p0[4]);
    };
    p0[1] = deref_type(p0[1]);
};

deref_unit: (p0) {
    (% do nothing %);
};

deref_typedexpr: (p0) {
    deref(p0[2]);
    p0[1] = deref_type(p0[1]);
};

deref_if: (p0) {
    deref(p0[2]);
    deref(p0[3]);
    p0[1] = deref_type(p0[1]);
};

deref_ifelse: (p0) {
    deref(p0[2]);
    deref(p0[3]);
    deref(p0[4]);
    p0[1] = deref_type(p0[1]);
};

deref_static_array: (p0) {
    deref(p0[2]);
    deref(p0[3]);
    p0[1] = deref_type(p0[1]);
};

deref_cast: (p0) {
    deref(p0[2]);
    p0[1] = deref_type(p0[1]);
};

deref_new: (p0) {
    deref(p0[2]);
    p0[1] = deref_type(p0[1]);
};

deref_while: (p0) {
    deref(p0[2]);
    deref(p0[3]);
};

deref_for: (p0) {
    deref(p0[2]);
    deref(p0[3]);
    deref(p0[4]);
    deref(p0[5]);
};

deref_newarray: (p0) {
    deref(p0[2]);
    deref(p0[3]);
    p0[1] = deref_type(p0[1]);
};

deref_rewrite: (p0) {
    (% do nothing %);
    return;
};

(% p0: type %);
deref_type: (p0) {
    allocate(3);
    if (p0[0] == NODE_TUPLE_T) {
        x0 = p0[1]; (% length %);
        x1 = 0;
        while (x1 < x0) {
            x2 = p0[2];
            x2[x1] = deref_type(x2[x1]);
            x1 = x1 + 1;
        };
        return p0;
    };
    if (p0[0] == NODE_ARRAY_T)   { p0[1] = deref_type(p0[1]); return p0; };
    if (p0[0] == NODE_LAMBDA_T) {
        p0[1] = deref_type(p0[1]);
        p0[2] = deref_type(p0[2]);
        return p0;
    };
    if (p0[0] == NODE_TYVAR) {
        x0 = map_find(tyvarmap, p0[1]); (% x0: type scheme %);
        if (x0 == NULL) { return p0; };
        x1 = x0[1];
        x1 = deref_type(x1);
        x2 = closure(x1);
        map_add(tyvarmap, p0[1], x2);
        return x1
    };
    if (p0[0] == NODE_FIELD_T) {
        p0[2] = deref_type(p0[2]);
        return p0;
    };
    if (p0[0] == NODE_NAMED_T) {
	if (p0[2] != NULL) {
	    p0[2] = deref_type(p0[2]);
	};
	return p0;
    };
    return p0;
};

(% p0: pattern %);
deref_pattern: (p0) {
    allocate(3);
    if (p0[0] == NODE_DONTCARE) {
        p0[1] = deref_type(p0[1]);
        return;
    };
    if (p0[0] == NODE_IDENTIFIER) {
        p0[1] = deref_type(p0[1]);
        p0[4] = closure(p0[1]);
        return;
    };
    if (p0[0] == NODE_TUPLE) {
        x0 = p0[TUPLE_LENGTH];
        x1 = p0[TUPLE_ELEMENTS];
        x2 = 0;
        while (x2 < x0) {
            deref_pattern(x1[x2]);
            x2 = x2 + 1;
        };
        p0[1] = deref_type(p0[1]);
        return;
    };
    not_reachable();
};

(% p0: program (item list) %);
typing: (p0) {
    allocate(1);

    init_varmap();
    init_tyvarmap();
    variant_map  = mkmap(&strhash, &streq, 10);
    return_stack = mkvec(0);

    x0 = p0[1];
    while (x0 != NULL) {
        infer_item(ls_value(x0));
        x0 = ls_next(x0);
    };
    return p0;
};


http: capture request content for POST requests

HTTP parser code used to capture HTTP headers only, ignoring
the content altogether, while it's allowed for POST requests
to have contents. This commit adds parsing the content and makes
it available through req->content string.

Message-Id: <5fd68ef57425289d55d49bc09f4d33fecd7c6509@scylladb.com>

/*
 * This file is open source software, licensed to you under the terms
 * of the Apache License, Version 2.0 (the "License").  See the NOTICE file
 * distributed with this work for additional information regarding copyright
 * ownership.  You may not use this file except in compliance with the License.
 *
 * You may obtain a copy of the License at
 *
 *   http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing,
 * software distributed under the License is distributed on an
 * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
 * KIND, either express or implied.  See the License for the
 * specific language governing permissions and limitations
 * under the License.
 */
/*
 * Copyright (C) 2014 Cloudius Systems, Ltd.
 */

#pragma once

#include <seastar/core/ragel.hh>
#include <memory>
#include <unordered_map>
#include <seastar/http/request.hh>

namespace seastar {

using namespace httpd;

%% machine request;

%%{

access _fsm_;

action mark {
    g.mark_start(p);
}

action store_method {
    _req->_method = str();
}

action store_uri {
    _req->_url = str();
}

action store_version {
    _req->_version = str();
}

action store_field_name {
    _field_name = str();
}

action store_value {
    _value = str();
}

action assign_field {
    _req->_headers[_field_name] = std::move(_value);
}

action extend_field  {
    _req->_headers[_field_name] += sstring(" ") + std::move(_value);
}

action done {
    g.mark_start(p);
    g.mark_end(pe);
    _req->content = get_str();
    _req->content_length = _req->content.size();
    done = true;
    fbreak;
}

crlf = '\r\n';
tchar = alpha | digit | '-' | '!' | '#' | '$' | '%' | '&' | '\'' | '*'
        | '+' | '.' | '^' | '_' | '`' | '|' | '~';

sp = ' ';
ht = '\t';

sp_ht = sp | ht;

op_char = upper;

operation = op_char+ >mark %store_method;
uri = (any - sp)+ >mark %store_uri;
http_version = 'HTTP/' (digit '.' digit) >mark %store_version;

field = tchar+ >mark %store_field_name;
value = any* >mark %store_value;
start_line = ((operation sp uri sp http_version) -- crlf) crlf;
header_1st = (field sp_ht* ':' sp_ht* value :> crlf) %assign_field;
header_cont = (sp_ht+ value sp_ht* crlf) %extend_field;
header = header_1st header_cont*;
main := start_line header* :> (crlf @done);

}%%

class http_request_parser : public ragel_parser_base<http_request_parser> {
    %% write data nofinal noprefix;
public:
    enum class state {
        error,
        eof,
        done,
    };
    std::unique_ptr<httpd::request> _req;
    sstring _field_name;
    sstring _value;
    state _state;
public:
    void init() {
        init_base();
        _req.reset(new httpd::request());
        _state = state::eof;
        %% write init;
    }
    char* parse(char* p, char* pe, char* eof) {
        sstring_builder::guard g(_builder, p, pe);
        auto str = [this, &g, &p] { g.mark_end(p); return get_str(); };
        bool done = false;
        if (p != pe) {
            _state = state::error;
        }
        %% write exec;
        if (!done) {
            p = nullptr;
        } else {
            _state = state::done;
        }
        return p;
    }
    auto get_parsed_request() {
        return std::move(_req);
    }
    bool eof() const {
        return _state == state::eof;
    }
};

}

/*
 * This file is open source software, licensed to you under the terms
 * of the Apache License, Version 2.0 (the "License").  See the NOTICE file
 * distributed with this work for additional information regarding copyright
 * ownership.  You may not use this file except in compliance with the License.
 *
 * You may obtain a copy of the License at
 *
 *   http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing,
 * software distributed under the License is distributed on an
 * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
 * KIND, either express or implied.  See the License for the
 * specific language governing permissions and limitations
 * under the License.
 */
/*
 * Copyright (C) 2014 Cloudius Systems, Ltd.
 */

#pragma once

#include <seastar/core/ragel.hh>
#include <memory>
#include <unordered_map>
#include <seastar/http/request.hh>

namespace seastar {

using namespace httpd;

%% machine request;

%%{

access _fsm_;

action mark {
    g.mark_start(p);
}

action store_method {
    _req->_method = str();
}

action store_uri {
    _req->_url = str();
}

action store_version {
    _req->_version = str();
}

action store_field_name {
    _field_name = str();
}

action store_value {
    _value = str();
}

action assign_field {
    _req->_headers[_field_name] = std::move(_value);
}

action extend_field  {
    _req->_headers[_field_name] += sstring(" ") + std::move(_value);
}

action done {
    done = true;
    fbreak;
}

crlf = '\r\n';
tchar = alpha | digit | '-' | '!' | '#' | '$' | '%' | '&' | '\'' | '*'
        | '+' | '.' | '^' | '_' | '`' | '|' | '~';

sp = ' ';
ht = '\t';

sp_ht = sp | ht;

op_char = upper;

operation = op_char+ >mark %store_method;
uri = (any - sp)+ >mark %store_uri;
http_version = 'HTTP/' (digit '.' digit) >mark %store_version;

field = tchar+ >mark %store_field_name;
value = any* >mark %store_value;
start_line = ((operation sp uri sp http_version) -- crlf) crlf;
header_1st = (field sp_ht* ':' sp_ht* value :> crlf) %assign_field;
header_cont = (sp_ht+ value sp_ht* crlf) %extend_field;
header = header_1st header_cont*;
main := start_line header* :> (crlf @done);

}%%

class http_request_parser : public ragel_parser_base<http_request_parser> {
    %% write data nofinal noprefix;
public:
    enum class state {
        error,
        eof,
        done,
    };
    std::unique_ptr<httpd::request> _req;
    sstring _field_name;
    sstring _value;
    state _state;
public:
    void init() {
        init_base();
        _req.reset(new httpd::request());
        _state = state::eof;
        %% write init;
    }
    char* parse(char* p, char* pe, char* eof) {
        sstring_builder::guard g(_builder, p, pe);
        auto str = [this, &g, &p] { g.mark_end(p); return get_str(); };
        bool done = false;
        if (p != pe) {
            _state = state::error;
        }
        %% write exec;
        if (!done) {
            p = nullptr;
        } else {
            _state = state::done;
        }
        return p;
    }
    auto get_parsed_request() {
        return std::move(_req);
    }
    bool eof() const {
        return _state == state::eof;
    }
};

}


Don't consume the last carriage return in the single line mutli-consume

This is probably the least efficient way to do this, because I must be reparsing
the line 5 times. At some future point I have to come up with a single pass.

package handbrake

import (
	"fmt"
)

%%{
	machine handbrake;
	write data;
}%%

func parseOutput(data string) (HandBrakeMeta) {
	cs, p, pe, eof := 0, 0, len(data), 0
	top, ts, te, act := 0,0,0,0
	_,_,_,_ = top, ts, te, act
	stack := []int{0}
	_ = eof
	line := 1
	capture := false
	csp := 0
	meta := HandBrakeMeta{}
	fmt.Printf("%02d: ", line)
	_ = capture
	_ = csp
	%%{
		action newline { line +=1; fmt.Printf("\n%02d: ", line) }
		newline = any* '\n' @ newline;
		title := |*
			(alnum|space)+[.]*alnum* => { fmt.Printf("%s", data[ts:te]); fret;};
			"\n" => { fret; };
		*|;
		duration := |*
			space*;
			digit{2}[:]digit{2}[:]digit{2} => { fmt.Printf("%s", data[ts:te]); fret;};
			"\n" => { fret; };
		*|;
		picture := |*
			space*;
			digit{3,4} "x" digit{3,4} => { fmt.Printf("%s", data[ts:te]); fret;};
		*|;
		paspect := |*
			space*;
			digit{1,4} "/" digit{1,4} => { fmt.Printf("%s", data[ts:te]); fret; };
		*|;
		daspect := |*
			space*;
			digit{1} . "." . digit{1,3} => { fmt.Printf("%s", data[ts:te]); fret; };
		*|;
		fps := |*
			"\n" => { ts -= 10; fmt.Printf("%s", data[ts:te-5]); p -= 1; fret; };
		*|;
		crop := |*
			space*;
			digit{1,3} "/" digit{1,3} "/" digit{1,3} "/" digit{1,3} => { fmt.Printf("%s", data[ts:te]); fret; };
		*|;
		main := (
			newline |
			space+ "+" space+ "stream:" space* @{ fcall title; } |
			space+ "+" space+ "duration:" @{ fcall duration; } |
			space+ "+" space+ "size:" @{ fcall picture; } |
			space+ "+" any+ "pixel" space+ "aspect:" @{ fcall paspect; } |
			space+ "+" any+ "display" space+ "aspect:" @{ fcall daspect; } |
			space+ "+" any+ "fps" @{ fcall fps; } |
			space+ "+" space+ "autocrop:" @{ fcall crop; }
		)*;
		write init;
		write exec;
	}%%
	return meta
}

package handbrake

import (
	"fmt"
)

%%{
	machine handbrake;
	write data;
}%%

func parseOutput(data string) (HandBrakeMeta) {
	cs, p, pe, eof := 0, 0, len(data), 0
	top, ts, te, act := 0,0,0,0
	_,_,_,_ = top, ts, te, act
	stack := []int{0}
	_ = eof
	line := 1
	capture := false
	csp := 0
	meta := HandBrakeMeta{}
	fmt.Printf("%02d: ", line)
	_ = capture
	_ = csp
	%%{
		action newline { line +=1; fmt.Printf("\n%02d: ", line) }
		newline = any* '\n' @ newline;
		title := |*
			(alnum|space)+[.]*alnum* => { fmt.Printf("%s", data[ts:te]); fret;};
			"\n" => { fret; };
		*|;
		duration := |*
			space*;
			digit{2}[:]digit{2}[:]digit{2} => { fmt.Printf("%s", data[ts:te]); fret;};
			"\n" => { fret; };
		*|;
		picture := |*
			space*;
			digit{3,4} "x" digit{3,4} => { fmt.Printf("%s", data[ts:te]); fret;};
		*|;
		paspect := |*
			space*;
			digit{1,4} "/" digit{1,4} => { fmt.Printf("%s", data[ts:te]); fret; };
		*|;
		daspect := |*
			space*;
			digit{1} . "." . digit{1,3} => { fmt.Printf("%s", data[ts:te]); fret; };
		*|;
		fps := |*
			"\n" => { ts=ts-12; fmt.Printf("%s\n", data[ts:te-4]); fret; };
		*|;
		crop := |*
			space*;
			digit{1,3} "/" digit{1,3} "/" digit{1,3} "/" digit{1,3} => { fmt.Printf("%s", data[ts:te]); fret; };
		*|;
		main := (
			newline |
			space+ "+" space+ "stream:" space* @{ fcall title; } |
			space+ "+" space+ "duration:" @{ fcall duration; } |
			space+ "+" space+ "size:" @{ fcall picture; } |
			space+ "+" any+ "pixel" space+ "aspect:" @{ fcall paspect; } |
			space+ "+" any+ "display" space+ "aspect:" @{ fcall daspect; } |
			space+ "+" any+ "fps" @{ fcall fps; } |
			space+ "+" space+ "autocrop:" @{ fcall crop; }
		)*;
		write init;
		write exec;
	}%%
	return meta
}


Fix CParser for Rubinius and Ruby 2.0.0 (and slightly speed it up!)

#include <ruby.h>

#if DEBUG_H
#  define DEBUG(fmt, ...) do { fprintf(stderr, fmt "\n", ##__VA_ARGS__); } while(0)
#else
#  define DEBUG(...)
#endif

#define UNUSED(x) (void)(x)
#define MARK_LEN (p - mark)
#define MARK_STR_NEW() rb_str_new(mark, MARK_LEN)

#define true 1
#define false 0

typedef struct {
  VALUE error;
  long max_frame_size;

  VALUE chunk;
  const char *p;
  int cs;
  const char *mark;
  VALUE mark_key;
  VALUE mark_frame;
  long mark_frame_size;
  long mark_content_length;
} parser_state_t;

VALUE mStompParser = Qnil;
VALUE cFrame = Qnil;
VALUE eFrameSizeExceeded = Qnil;
ID g_write_command;
ID g_write_header;
ID g_write_body;
ID g_content_length;
ID g_build_parse_error;
ID g_max_frame_size;

%%{
  machine frame;

  action mark {
    mark = p;
  }

  action mark_frame {
    mark_frame = rb_class_new_instance(0, NULL, cFrame);
    mark_frame_size = 0;
  }

  action write_command {
    VALUE command = MARK_STR_NEW();
    rb_funcall2(mark_frame, g_write_command, 1, &command);
    mark = NULL;
  }

  action mark_key {
    mark_key = MARK_STR_NEW();
    mark = NULL;
  }

  action write_header {
    VALUE args[2] = { mark_key, MARK_STR_NEW() };
    rb_funcall2(mark_frame, g_write_header, 2, args);
    mark_key = Qnil;
    mark = NULL;
  }

  action finish_headers {
    VALUE length = rb_funcall2(mark_frame, g_content_length, 0, NULL);
    if ( ! NIL_P(length)) {
      mark_content_length = NUM2LONG(length);
    } else {
      mark_content_length = -1;
    }
  }

  action write_body {
    VALUE body = MARK_STR_NEW();
    rb_funcall2(mark_frame, g_write_body, 1, &body);
    mark = NULL;
  }

  action consume_null {
    ((mark_content_length != -1) && (MARK_LEN < mark_content_length))
  }

  action consume_octet {
    ((mark_content_length == -1) || (MARK_LEN < mark_content_length))
  }

  action check_frame_size {
    mark_frame_size += 1;
    if (mark_frame_size > max_frame_size) {
      rb_raise(eFrameSizeExceeded, "");
    }
  }

  action finish_frame {
    rb_yield(mark_frame);
    mark_frame = Qnil;
  }

  include frame_common "parser_common.rl";

  write data noprefix;
}%%

static void parser_free(parser_state_t *state) {
  xfree(state);
}

static void parser_mark(parser_state_t *state) {
  rb_gc_mark(state->error);
  rb_gc_mark(state->mark_key);
  rb_gc_mark(state->mark_frame);
  rb_gc_mark(state->chunk);
}

static VALUE parser_alloc(VALUE klass) {
  parser_state_t *state = ALLOC(parser_state_t);
  return Data_Wrap_Struct(klass, parser_mark, parser_free, state);
}

static VALUE parser_initialize(int argc, VALUE *argv, VALUE self) {
  parser_state_t *state;
  Data_Get_Struct(self, parser_state_t, state);

  VALUE max_frame_size;
  rb_scan_args(argc, argv, "01", &max_frame_size);

  if (max_frame_size == Qnil) {
    max_frame_size = rb_funcall(mStompParser, g_max_frame_size, 0);
  }

  state->error = Qnil;
  state->max_frame_size = FIX2LONG(max_frame_size);
  state->chunk = Qnil;
  state->cs = start;
  state->mark = NULL;
  state->mark_key = Qnil;
  state->mark_frame = Qnil;
  state->mark_frame_size = 0;
  state->mark_content_length = 0;

  return self;
}

static VALUE parser_parse(VALUE self, VALUE new_chunk) {
  parser_state_t *state;
  Data_Get_Struct(self, parser_state_t, state);

  if (NIL_P(state->error)) {
    VALUE chunk = Qnil;
    const char *p = NULL;
    const char *mark = NULL;

    if ( ! NIL_P(state->chunk)) {
      long offset = RSTRING_LEN(state->chunk);
      long mark_offset = state->mark - RSTRING_PTR(state->chunk);

      chunk = rb_str_append(state->chunk, new_chunk);
      p = RSTRING_PTR(chunk) + offset;
      mark = RSTRING_PTR(chunk) + mark_offset;
    } else {
      chunk = new_chunk;
      p = RSTRING_PTR(chunk);
    }

    const char *pe = RSTRING_END(chunk);
    long max_frame_size = state->max_frame_size;

    int cs = state->cs;
    VALUE mark_key = state->mark_key;
    VALUE mark_frame = state->mark_frame;
    long mark_frame_size = state->mark_frame_size;
    long mark_content_length = state->mark_content_length;

    %% write exec;

    if (mark != NULL) {
      state->chunk = chunk;
    } else {
      state->chunk = Qnil;
    }

    state->cs = cs;
    state->mark = mark;
    state->mark_key = mark_key;
    state->mark_frame = mark_frame;
    state->mark_frame_size = mark_frame_size;
    state->mark_content_length = mark_content_length;

    if (cs == error) {
      long index = p - RSTRING_PTR(chunk);
      state->error = rb_funcall(mStompParser, g_build_parse_error, 2, chunk, LONG2NUM(index));
    }
  }

  if ( ! NIL_P(state->error)) {
    rb_exc_raise(state->error);
  }

  return Qnil;
}

void Init_c_parser(void) {
  mStompParser = rb_const_get(rb_cObject, rb_intern("StompParser"));
  cFrame = rb_const_get(mStompParser, rb_intern("Frame"));
  eFrameSizeExceeded = rb_const_get(mStompParser, rb_intern("FrameSizeExceeded"));

  g_write_command = rb_intern("write_command");
  g_write_header = rb_intern("write_header");
  g_write_body = rb_intern("write_body");
  g_content_length = rb_intern("content_length");
  g_build_parse_error = rb_intern("build_parse_error");
  g_max_frame_size = rb_intern("max_frame_size");

  VALUE cParser = rb_define_class_under(mStompParser, "CParser", rb_cObject);
  rb_define_alloc_func(cParser, parser_alloc);

  rb_define_method(cParser, "initialize", parser_initialize, -1);
  rb_define_method(cParser, "parse", parser_parse, 1);
}

#include <ruby.h>

#if DEBUG_H
#  define DEBUG(fmt, ...) do { fprintf(stderr, fmt "\n", ##__VA_ARGS__); } while(0)
#else
#  define DEBUG(...)
#endif

#define UNUSED(x) (void)(x)
#define MARK_LEN (p - mark)
#define MARK_STR_NEW() rb_str_new(mark, MARK_LEN)

#define true 1
#define false 0

typedef struct {
  VALUE error;
  long max_frame_size;

  VALUE chunk;
  const char *p;
  int cs;
  const char *mark;
  VALUE mark_key;
  VALUE mark_frame;
  long mark_frame_size;
  long mark_content_length;
} parser_state_t;

VALUE mStompParser = Qnil;
VALUE cFrame = Qnil;
VALUE eFrameSizeExceeded = Qnil;
ID g_new;
ID g_write_command;
ID g_write_header;
ID g_write_body;
ID g_content_length;
ID g_build_parse_error;
ID g_max_frame_size;

%%{
  machine frame;

  action mark {
    mark = p;
  }

  action mark_frame {
    mark_frame = rb_funcallv(cFrame, g_new, 0, NULL);
    mark_frame_size = 0;
  }

  action write_command {
    VALUE command = MARK_STR_NEW();
    rb_funcallv(mark_frame, g_write_command, 1, &command);
    mark = NULL;
  }

  action mark_key {
    mark_key = MARK_STR_NEW();
    mark = NULL;
  }

  action write_header {
    VALUE args[2] = { mark_key, MARK_STR_NEW() };
    rb_funcallv(mark_frame, g_write_header, 2, args);
    mark_key = Qnil;
    mark = NULL;
  }

  action finish_headers {
    VALUE length = rb_funcallv(mark_frame, g_content_length, 0, NULL);
    if ( ! NIL_P(length)) {
      mark_content_length = NUM2LONG(length);
    } else {
      mark_content_length = -1;
    }
  }

  action write_body {
    VALUE body = MARK_STR_NEW();
    rb_funcallv(mark_frame, g_write_body, 1, &body);
    mark = NULL;
  }

  action consume_null {
    ((mark_content_length != -1) && (MARK_LEN < mark_content_length))
  }

  action consume_octet {
    ((mark_content_length == -1) || (MARK_LEN < mark_content_length))
  }

  action check_frame_size {
    mark_frame_size += 1;
    if (mark_frame_size > max_frame_size) {
      rb_raise(eFrameSizeExceeded, "");
    }
  }

  action finish_frame {
    rb_yield(mark_frame);
    mark_frame = Qnil;
  }

  include frame_common "parser_common.rl";

  write data noprefix;
}%%

static void parser_free(parser_state_t *state) {
  xfree(state);
}

static void parser_mark(parser_state_t *state) {
  rb_gc_mark(state->error);
  rb_gc_mark(state->mark_key);
  rb_gc_mark(state->mark_frame);
  rb_gc_mark(state->chunk);
}

static VALUE parser_alloc(VALUE klass) {
  parser_state_t *state = ALLOC(parser_state_t);
  return Data_Wrap_Struct(klass, parser_mark, parser_free, state);
}

static VALUE parser_initialize(int argc, VALUE *argv, VALUE self) {
  parser_state_t *state;
  Data_Get_Struct(self, parser_state_t, state);

  VALUE max_frame_size;
  rb_scan_args(argc, argv, "01", &max_frame_size);

  if (max_frame_size == Qnil) {
    max_frame_size = rb_funcall(mStompParser, g_max_frame_size, 0);
  }

  state->error = Qnil;
  state->max_frame_size = FIX2LONG(max_frame_size);
  state->chunk = Qnil;
  state->cs = start;
  state->mark = NULL;
  state->mark_key = Qnil;
  state->mark_frame = Qnil;
  state->mark_frame_size = 0;
  state->mark_content_length = 0;

  return self;
}

static VALUE parser_parse(VALUE self, VALUE new_chunk) {
  parser_state_t *state;
  Data_Get_Struct(self, parser_state_t, state);

  if (NIL_P(state->error)) {
    VALUE chunk = Qnil;
    const char *p = NULL;
    const char *mark = NULL;

    if ( ! NIL_P(state->chunk)) {
      long offset = RSTRING_LEN(state->chunk);
      long mark_offset = state->mark - RSTRING_PTR(state->chunk);

      chunk = rb_str_append(state->chunk, new_chunk);
      p = RSTRING_PTR(chunk) + offset;
      mark = RSTRING_PTR(chunk) + mark_offset;
    } else {
      chunk = new_chunk;
      p = RSTRING_PTR(chunk);
    }

    const char *pe = RSTRING_END(chunk);
    long max_frame_size = state->max_frame_size;

    int cs = state->cs;
    VALUE mark_key = state->mark_key;
    VALUE mark_frame = state->mark_frame;
    long mark_frame_size = state->mark_frame_size;
    long mark_content_length = state->mark_content_length;

    %% write exec;

    if (mark != NULL) {
      state->chunk = chunk;
    } else {
      state->chunk = Qnil;
    }

    state->cs = cs;
    state->mark = mark;
    state->mark_key = mark_key;
    state->mark_frame = mark_frame;
    state->mark_frame_size = mark_frame_size;
    state->mark_content_length = mark_content_length;

    if (cs == error) {
      long index = p - RSTRING_PTR(chunk);
      state->error = rb_funcall(mStompParser, g_build_parse_error, 2, chunk, LONG2NUM(index));
    }
  }

  if ( ! NIL_P(state->error)) {
    rb_exc_raise(state->error);
  }

  return Qnil;
}

void Init_c_parser(void) {
  mStompParser = rb_const_get(rb_cObject, rb_intern("StompParser"));
  cFrame = rb_const_get(mStompParser, rb_intern("Frame"));
  eFrameSizeExceeded = rb_const_get(mStompParser, rb_intern("FrameSizeExceeded"));

  g_new = rb_intern("new");
  g_write_command = rb_intern("write_command");
  g_write_header = rb_intern("write_header");
  g_write_body = rb_intern("write_body");
  g_content_length = rb_intern("content_length");
  g_build_parse_error = rb_intern("build_parse_error");
  g_max_frame_size = rb_intern("max_frame_size");

  VALUE cParser = rb_define_class_under(mStompParser, "CParser", rb_cObject);
  rb_define_alloc_func(cParser, parser_alloc);

  rb_define_method(cParser, "initialize", parser_initialize, -1);
  rb_define_method(cParser, "parse", parser_parse, 1);
}


cleanup

cleanup

%%{
  machine params_parser;
  action H { @head = p }
  action T { @tail = p }
  action inject_key { @hash[key] = {} }
  action push { @hash_stack.push @hash; @hash = @hash[key] }
  action pop { @hash = @hash_stack.pop }

  DELIMITER = ([, ])+                               >H@T @{ log(:delimiter) };
  LEVEL = ('(')+                                    >H@T @{ log(:level) };
  END_LEVEL = (')')+                                >H@T @{ log(:end_level); p + 1 == pe and inject_key; };
  INPUT = (any - LEVEL - END_LEVEL - DELIMITER)+    >H@T @{ log(:input); memo_key; };

  main := (
    INPUT
    (
      DELIMITER @inject_key @{ fnext main; } |
      END_LEVEL DELIMITER @inject_key @pop @{ fret; } |
      LEVEL @inject_key @push @{ fcall main; }
    )
  )*;
}%%

module ParamsTree
  class Parser
    attr_accessor :data

    def initialize
      %% write data;
    end

    def process(input)
      @data = input.unpack('c*')
      stack = []

      @log = []
      @hash = {}
      @hash_stack = []
      @key = nil

      %% write init;
      %% write exec;

      puts @hash_stack.inspect
    end

    def char
      @data[@head..@tail]
    end

    def strokes
      char.pack('c*')
    end

    def log(token)
      @log << { token => strokes }
    end

    def memo_key
      @key = char
    end

    def key
      @key.pack('c*')
    end
  end
end

ParamsTree::Parser.new.process "default(all,usadasdid(zczxc(pio),cvb)),isdsdd(wow,er),sed(rew,tre,yrt(dfg,gfd))"

%%{
  machine params_parser;
  action H { @head = p }
  action T { @tail = p }
  action inject_key { @hash[key] = {} }
  action push { @hash_stack.push @hash; @hash = @hash[key] }
  action pop { @hash = @hash_stack.pop }

  DELIMITER = ([, ])+                               >H@T @{ log(:delimiter) };
  LEVEL = ('(')+                                    >H@T @{ log(:level) };
  END_LEVEL = (')')+                                >H@T @{ log(:end_level); p + 1 == pe and @hash[key] = {}; };
  INPUT = (any - LEVEL - END_LEVEL - DELIMITER)+    >H@T @{ log(:input); memo_key; };

  main := (
    INPUT
    (
      DELIMITER @inject_key @{ fnext main; } |
      END_LEVEL DELIMITER @inject_key @pop @{ fret; } |
      LEVEL @inject_key @push @{ fcall main; }
    )
  )*;
}%%

module ParamsTree
  class Parser
    attr_accessor :data

    def initialize
      %% write data;
    end

    def process(input)
      @data = input.unpack('c*')
      stack = []

      @log = []
      @hash = {}
      @hash_stack = []
      @key = nil

      %% write init;
      %% write exec;

      puts @hash_stack.inspect
    end

    def char
      @data[@head..@tail]
    end

    def strokes
      char.pack('c*')
    end

    def log(token)
      @log << { token => strokes }
    end

    def memo_key
      @key = char
    end

    def key
      @key.pack('c*')
    end
  end
end

ParamsTree::Parser.new.process "default(all,usadasdid(zczxc(pio),cvb)),isdsdd(wow,er),sed(rew,tre,yrt(dfg,gfd))"


add ability to escape slashes in cap_regex and match_regex

%%{
  machine hext;

  action error {
    throw_error();
  }

  nth_child = ( [1-9][0-9]** );
  attr_name = ( alpha (alnum | '-' | '_')** );
  cap_var       = ( [^/{}][^/{}]** );
  match_literal = ( [^/{}"][^/{}"]** );
  cap_regex   = ( ( [^/] | '\\/' )** );
  match_regex = ( ( [^/] | '\\/' )** );

  comment = (
    ' '*
    '#'
    (any - '\n')*
    (
      '\n' >{ LX_TK_START(TK_NEWLINE); }
           %{ LX_TK_STOP; }
    )
  );

  attributes =
    (
      space+
      (
        (
          '@' >{ LX_TK_START(TK_BUILTIN); }
              %{ LX_TK_STOP; }
        )?
        (
          attr_name >{ LX_TK_START(TK_ATTR_NAME); }
                    %{ LX_TK_STOP; }
        )
        <:
        (
          '='
          (
            (
              (
                '{' >{ LX_TK_START(TK_CAP_BEGIN); }
                    %{ LX_TK_STOP; }
              )
              (
                cap_var >{ LX_TK_START(TK_CAP_VAR); }
                        %{ LX_TK_STOP; }
              )
              (
                '/'
                (
                  cap_regex >{ LX_TK_START(TK_CAP_REGEX); }
                            %{ LX_TK_STOP; }
                )
                '/'
              )?
              (
                '}' >{ LX_TK_START(TK_CAP_END); }
                    %{ LX_TK_STOP; }
              )
            )
            |
            (
              (
                '/'
                (
                  match_regex >{ LX_TK_START(TK_MATCH_REGEX); }
                              %{ LX_TK_STOP; }
                )
                '/'
              )
              |
              (
                '"'
                (
                  match_literal >{ LX_TK_START(TK_MATCH_LITERAL); }
                                %{ LX_TK_STOP; }
                )
                '"'
              )
            )
          )
        )?
      )
    )+;

  main :=
    (
      comment
      |
      (
        (
          '  ' >{ LX_TK_START(TK_INDENT); }
               %{ LX_TK_STOP; }
        )*
        (
          '<' >{ LX_TK_START(TK_RULE_BEGIN); }
              %{ LX_TK_STOP; }
        )
        (
          '!' >{ LX_TK_START(TK_DIRECT_DESC); }
              %{ LX_TK_STOP; }
        )?
        (
          nth_child >{ LX_TK_START(TK_NTH_CHILD); }
                    %{ LX_TK_STOP; }
        )?
        (
          attr_name >{ LX_TK_START(TK_TAG_NAME); }
                    %{ LX_TK_STOP; }
        )?
        attributes?
        (
          '>' >{ LX_TK_START(TK_RULE_END); }
              %{ LX_TK_STOP; }
        )?
      ):>
      (
        '\n' >{ LX_TK_START(TK_NEWLINE); }
             %{ LX_TK_STOP; }
      )
    )**
    $err(error) $/{ LX_TK_START(TK_EOF); fbreak; };
}%%

%%{
  machine hext;

  action error {
    throw_error();
  }

  nth_child = ( [1-9][0-9]** );
  attr_name = ( alpha (alnum | '-' | '_')** );
  cap_var       = ( [^/{}][^/{}]** );
  match_literal = ( [^/{}"][^/{}"]** );
  cap_regex   = ( [^/][^/]** );
  match_regex = ( [^/][^/]** );

  comment = (
    ' '*
    '#'
    (any - '\n')*
    (
      '\n' >{ LX_TK_START(TK_NEWLINE); }
           %{ LX_TK_STOP; }
    )
  );

  attributes =
    (
      space+
      (
        (
          '@' >{ LX_TK_START(TK_BUILTIN); }
              %{ LX_TK_STOP; }
        )?
        (
          attr_name >{ LX_TK_START(TK_ATTR_NAME); }
                    %{ LX_TK_STOP; }
        )
        <:
        (
          '='
          (
            (
              (
                '{' >{ LX_TK_START(TK_CAP_BEGIN); }
                    %{ LX_TK_STOP; }
              )
              (
                cap_var >{ LX_TK_START(TK_CAP_VAR); }
                        %{ LX_TK_STOP; }
              )
              (
                '/'
                (
                  cap_regex >{ LX_TK_START(TK_CAP_REGEX); }
                            %{ LX_TK_STOP; }
                )
                '/'
              )?
              (
                '}' >{ LX_TK_START(TK_CAP_END); }
                    %{ LX_TK_STOP; }
              )
            )
            |
            (
              (
                '/'
                (
                  match_regex >{ LX_TK_START(TK_MATCH_REGEX); }
                              %{ LX_TK_STOP; }
                )
                '/'
              )
              |
              (
                '"'
                (
                  match_literal >{ LX_TK_START(TK_MATCH_LITERAL); }
                                %{ LX_TK_STOP; }
                )
                '"'
              )
            )
          )
        )?
      )
    )+;

  main :=
    (
      comment
      |
      (
        (
          '  ' >{ LX_TK_START(TK_INDENT); }
               %{ LX_TK_STOP; }
        )*
        (
          '<' >{ LX_TK_START(TK_RULE_BEGIN); }
              %{ LX_TK_STOP; }
        )
        (
          '!' >{ LX_TK_START(TK_DIRECT_DESC); }
              %{ LX_TK_STOP; }
        )?
        (
          nth_child >{ LX_TK_START(TK_NTH_CHILD); }
                    %{ LX_TK_STOP; }
        )?
        (
          attr_name >{ LX_TK_START(TK_TAG_NAME); }
                    %{ LX_TK_STOP; }
        )?
        attributes?
        (
          '>' >{ LX_TK_START(TK_RULE_END); }
              %{ LX_TK_STOP; }
        )?
      ):>
      (
        '\n' >{ LX_TK_START(TK_NEWLINE); }
             %{ LX_TK_STOP; }
      )
    )**
    $err(error) $/{ LX_TK_START(TK_EOF); fbreak; };
}%%


Interpret /serviceValidate responses as UTF-8 codepoints.

require 'castanet'

%%{
  machine service_validate;

  action buffer { buffer << fc }
  action save_username { r.username = buffer; buffer = '' }
  action save_failure_code { r.failure_code = buffer; buffer = '' }
  action save_failure_reason { r.failure_reason = buffer.strip; buffer = '' }
  action save_pgt_iou { r.pgt_iou = buffer; buffer = '' }
  action set_authenticated { r.valid = true; eof = -1 }

  include common "common.rl";

  # Leaf tags
  # ---------

  code    = ( ( upper | '_' ) @buffer )+ %save_failure_code;
  reason  = ( xml_content @buffer )+ %save_failure_reason;
  pgt_iou = "<cas:proxyGrantingTicket>"
            ( ticket_character @buffer ){,256}
            "</cas:proxyGrantingTicket>" %save_pgt_iou;
  user    = "<cas:user>" ( xml_content @buffer )+ "</cas:user>" %save_username;

  # Non-leaf tags
  # -------------

  service_response_start          = "<cas:serviceResponse xmlns:cas="
                                     quote
                                     "http://www.yale.edu/tp/cas"
                                     quote
                                     ">";
  service_response_end            = "</cas:serviceResponse>";

  authentication_failure_start    = "<cas:authenticationFailure code="
                                     quote
                                     code
                                     quote
                                     ">";
  authentication_failure_end      = "</cas:authenticationFailure>";

  authentication_success_start    = "<cas:authenticationSuccess>";
  authentication_success_end      = "</cas:authenticationSuccess>";

  # Top-level elements
  # ------------------

  ok_cas_st         = ( service_response_start
                        space*
                        authentication_success_start
                        space*
                        user
                        space*
                        pgt_iou?
                        space*
                        authentication_success_end
                        space*
                        service_response_end ) @set_authenticated;

  failed_cas_st     = ( service_response_start
                        space*
                        authentication_failure_start
                        reason
                        authentication_failure_end
                        space*
                        service_response_end );

  main := ok_cas_st | failed_cas_st;
}%%

module Castanet::Responses
  class ServiceValidate
    ##
    # Whether or not this response passed CAS authentication.
    #
    # @return [Boolean]
    attr_accessor :valid

    alias_method :valid?, :valid

    ##
    # The failure code returned on authentication failure.
    #
    # @return [String, nil]
    attr_accessor :failure_code

    ##
    # The reason given by the CAS server for authentication failure.
    #
    # @return [String, nil]
    attr_accessor :failure_reason

    ##
    # The PGT IOU returned by an authentication success message.
    #
    # @return [String, nil]
    attr_accessor :pgt_iou

    ##
    # The name of the owner of the validated service or proxy ticket.
    #
    # This information is only present on authentication success.
    #
    # @return [String, nil]
    attr_accessor :username

    ##
    # Generates a {ServiceValidate} object from a CAS response.
    #
    # @param [String] response the CAS response
    # @return [ServiceValidate}
    def self.from_cas(response)
      data = response.strip.unpack('U*')
      buffer = ''
      eof = nil

      %% write init;

      new.tap do |r|
        %% write exec;
      end
    end

    def initialize
      self.valid = false
    end

    %% write data;
  end
end

require 'castanet'

%%{
  machine service_validate;

  action buffer { buffer << fc }
  action save_username { r.username = buffer; buffer = '' }
  action save_failure_code { r.failure_code = buffer; buffer = '' }
  action save_failure_reason { r.failure_reason = buffer.strip; buffer = '' }
  action save_pgt_iou { r.pgt_iou = buffer; buffer = '' }
  action set_authenticated { r.valid = true; eof = -1 }

  include common "common.rl";

  # Leaf tags
  # ---------

  code    = ( ( upper | '_' ) @buffer )+ %save_failure_code;
  reason  = ( xml_content @buffer )+ %save_failure_reason;
  pgt_iou = "<cas:proxyGrantingTicket>"
            ( ticket_character @buffer ){,256}
            "</cas:proxyGrantingTicket>" %save_pgt_iou;
  user    = "<cas:user>" ( xml_content @buffer )+ "</cas:user>" %save_username;

  # Non-leaf tags
  # -------------

  service_response_start          = "<cas:serviceResponse xmlns:cas="
                                     quote
                                     "http://www.yale.edu/tp/cas"
                                     quote
                                     ">";
  service_response_end            = "</cas:serviceResponse>";

  authentication_failure_start    = "<cas:authenticationFailure code="
                                     quote
                                     code
                                     quote
                                     ">";
  authentication_failure_end      = "</cas:authenticationFailure>";

  authentication_success_start    = "<cas:authenticationSuccess>";
  authentication_success_end      = "</cas:authenticationSuccess>";

  # Top-level elements
  # ------------------

  ok_cas_st         = ( service_response_start
                        space*
                        authentication_success_start
                        space*
                        user
                        space*
                        pgt_iou?
                        space*
                        authentication_success_end
                        space*
                        service_response_end ) @set_authenticated;

  failed_cas_st     = ( service_response_start
                        space*
                        authentication_failure_start
                        reason
                        authentication_failure_end
                        space*
                        service_response_end );

  main := ok_cas_st | failed_cas_st;
}%%

module Castanet::Responses
  class ServiceValidate
    ##
    # Whether or not this response passed CAS authentication.
    #
    # @return [Boolean]
    attr_accessor :valid

    alias_method :valid?, :valid

    ##
    # The failure code returned on authentication failure.
    #
    # @return [String, nil]
    attr_accessor :failure_code

    ##
    # The reason given by the CAS server for authentication failure.
    #
    # @return [String, nil]
    attr_accessor :failure_reason

    ##
    # The PGT IOU returned by an authentication success message.
    #
    # @return [String, nil]
    attr_accessor :pgt_iou

    ##
    # The name of the owner of the validated service or proxy ticket.
    #
    # This information is only present on authentication success.
    #
    # @return [String, nil]
    attr_accessor :username

    ##
    # Generates a {ServiceValidate} object from a CAS response.
    #
    # @param [String] response the CAS response
    # @return [ServiceValidate}
    def self.from_cas(response)
      data = response.strip.unpack('c*')
      buffer = ''
      eof = nil

      %% write init;

      new.tap do |r|
        %% write exec;
      end
    end

    def initialize
      self.valid = false
    end

    %% write data;
  end
end