int function_decl(ParserState* ps) {
Ast *func = ps->curr, *t0 = 0;
if (stepifis(ps, RFunction)) {
if (stepifis(ps, TkId)) {
ast_swap(func, func->next);
t0 = func;
func = func->next;
}
if (parameter_list(ps)) {
if (statement_block(ps)) {
ast_next_to_last_child(func);
ast_next_to_last_child(func);
if (t0 != 0) {
Ast* t2 = ast_insert_after(t0);
t2->t = OpAsgn;
Ast* t1 = ast_insert_after(t0);
t1->t = RVar;
ast_swap(t0, t1);
ast_swap(t1, t2);
ast_next_to_last_child(t1);
ast_next_to_last_child(t1);
ast_next_to_last_child(t0);
}
}
else parerr(ps, "expecting '{'");
}
else parerr(ps, "expecting '('");
return 1;
}
else return 0;
}
ast_t* reify_method_def(ast_t* ast, ast_t* typeparams, ast_t* typeargs,
pass_opt_t* opt)
{
(void)opt;
switch(ast_id(ast))
{
case TK_FUN:
case TK_BE:
case TK_NEW:
break;
default:
pony_assert(false);
}
// Remove the body AST to avoid duplicating it.
ast_t* body = ast_childidx(ast, 6);
ast_t* temp_body = ast_blank(TK_NONE);
ast_swap(body, temp_body);
ast_t* r_ast = reify(ast, typeparams, typeargs, opt, true);
ast_swap(temp_body, body);
ast_free_unattached(temp_body);
return r_ast;
}
int statement(ParserState* ps) {
Ast *start = ps->curr, *expr = 0;
if (stepifis(ps, PSemi)) { parwrn(ps, "empty statement"); }
else if (stepifis(ps, RBreak)) {
if (stepifis(ps, PSemi)) {}
else { parerr(ps, "expecting ';' after break"); }
}
else if (stepifis(ps, RReturn)) {
if (expression(ps, &expr)) {
ast_next_to_first_child(start);
}
if (stepifis(ps, PSemi)) {}
else { parerr(ps, "expecting ';'"); }
}
else if (if_statement(ps)) {}
else if (while_statement(ps)) {}
else if (variable_decl(ps)) {}
else if (statement_block(ps)) {}
else if (expression(ps, &expr)) {
Ast* lhs = expr;
Ast* op = ps->curr;
if (curris(ps, OpAsgn)) {
step(ps);
if (expression(ps, &expr)) {
if (lhs->t == AstGetIdx || lhs->t == AstGetKey) {
lhs->t++;
free(ast_rmnext(lhs));
ast_next_to_last_child(lhs);
}
else {
ast_swap(lhs, op);
ast_next_to_first_child(lhs);
ast_next_to_last_child(lhs);
}
}
else {
parerr(ps, "invalid assignment");
}
}
else if (stepifis(ps, OpInc) || stepifis(ps, OpDec)) {
ast_swap(lhs, op);
ast_next_to_first_child(lhs);
}
if (stepifis(ps, PSemi)) {}
else {
parerr(ps, "invalid syntax, missing ';'?");
}
}
else return 0;
return 1;
}
static int binary_expr(ParserState* ps, int p, Ast** expr) {
Ast *left, *right;
if (unary_expr(ps, &left)) {
*expr = left;
int r = 0xffff;
while (ps->curr != 0 &&
ps->curr->t < TkOpEnd &&
OpPrec[ps->curr->t] >= p &&
OpPrec[ps->curr->t] <= r)
{
Ast* op = ps->curr;
step(ps);
if (binary_expr(ps, OpPrec[op->t] + 1, &right)) {
r = OpPrec[op->t];
ast_swap(left, op);
ast_next_to_first_child(left);
ast_next_to_last_child(left);
*expr = left;
}
else {
parerr(ps, "invalid syntax");
}
}
return 1;
}
else return 0;
}
int if_statement(ParserState* ps) {
Ast* rif = ps->curr, *expr, *relse;
if (stepifis(ps, RIf)) {
if (expression(ps, &expr)) {
if (statement_block(ps)) {
ast_next_to_first_child(rif);
ast_next_to_last_child(rif);
}
else { parerr(ps, "expecting '{'"); }
}
else { parerr(ps, "expecting test expression"); }
relse = ps->curr;
if (stepifis(ps, RElse)) {
if (if_statement(ps) || statement_block(ps)) {
ast_swap(relse, relse->next);
ast_rmnext(relse);
ast_next_to_last_child(rif);
}
else { parerr(ps, "expecting '{' or 'if' after 'else'"); }
}
return 1;
}
else return 0;
}
int parameter_list(ParserState* ps) {
if (curris(ps, PLParen)) {
enterblk();
while (ps->curr != 0) {
VVar id;
if (!declarator(ps, &id))
parerr(ps, "invalid parameter syntax");
if (curris(ps, PComma)) {
Ast* comma = ps->curr;
if (comma->next != 0) {
ast_swap(comma, comma->next);
ast_rmnext(comma);
}
}
else if (ps->curr != 0) {
parerr(ps, "expecting \',\' in parameter list");
}
}
exitblk();
return 1;
}
else return 0;
}
static int primary_expr(ParserState* ps, Ast** expr) {
Ast* base = ps->curr;
if (literal_expr(ps, &base)) { *expr = base; }
else if (curris(ps, PLParen)) {
enterblk();
if (expression(ps, expr) && ps->curr == 0) {
exitblk();
ast_swap(base, *expr);
free(*expr);
*expr = base;
return 1;
}
else {
exitblk();
parerr(ps, "invlaid syntax");
}
}
else if (obj_literal_expr(ps, expr)) {}
else if (array_literal_expr(ps, expr)) {}
else if (curris(ps, TkId)) { *expr = base; step(ps); }
// else if (stepifis(ps, RNew)) {}
else return 0;
while (indexing(ps, expr, base)
|| dot_id(ps, expr, base)
|| arg_list(ps, base)) {
}
return 1;
}
static int dot_id(ParserState* ps, Ast** expr, Ast* obj) {
Ast* op = ps->curr;
if (stepifis(ps, OpDot) && stepifis(ps, TkId)) {
ast_swap(obj, op);
ast_next_to_first_child(obj);
ast_next_to_last_child(obj);
obj->t = AstGetKey;
*expr = obj;
return 1;
}
return 0;
}
void ast_replace(ast_t** prev, ast_t* next)
{
if(*prev == next)
return;
if(hasparent(next))
next = ast_dup(next);
if(hasparent(*prev))
ast_swap(*prev, next);
ast_free(*prev);
*prev = next;
}
static bool insert_apply(pass_opt_t* opt, ast_t** astp)
{
// Sugar .apply()
ast_t* ast = *astp;
AST_GET_CHILDREN(ast, positional, namedargs, lhs);
ast_t* dot = ast_from(ast, TK_DOT);
ast_add(dot, ast_from_string(ast, "apply"));
ast_swap(lhs, dot);
ast_add(dot, lhs);
if(!expr_dot(opt, &dot))
return false;
return expr_call(opt, astp);
}
static int obj_literal_expr(ParserState* ps, Ast** expr) {
if (curris(ps, PLBrace)) {
*expr = ps->curr;
enterblk();
Ast* start = ps->curr, *value;
while (ps->curr != 0) {
Ast *key, *op;
if (curris(ps, TkId) || curris(ps, TkVar) && ps->curr->v.type == T_VString) {
key = ps->curr;
step(ps);
op = ps->curr;
if (stepifis(ps, PColon)) {
if (expression(ps, &value)) {
ast_swap(key, op);
ast_next_to_last_child(key);
ast_next_to_last_child(key);
}
else {
parerr(ps, "invalid initialization in object literal"); break;
}
}
else {
parerr(ps, "expecting ':'"); break;
}
}
else {
parerr(ps, "invalid key in object literal"); break;
}
if (ps->curr != 0 && !stepifis(ps, PComma)) {
parerr(ps, "expecting ','"); break;
}
}
while (start != 0 && start->next != 0) {
if (start->next->t == PComma)
ast_rmnext(start);
else
start = start->next;
}
exitblk();
(*expr)->t = AstObjLiteral;
return 1;
}
else return 0;
}
static int indexing(ParserState* ps, Ast** expr, Ast* obj) {
if (curris(ps, PLBracket) && ps->curr->child != 0) {
Ast* idx = ps->curr;
enterblk();
if (!expression(ps, expr))
parerr(ps, "invalid index");
exitblk();
ast_swap(obj, idx);
ast_next_to_first_child(obj);
obj->t = AstGetIdx;
*expr = obj;
return 1;
}
else return 0;
}
static int declarator(ParserState* ps, VVar* id) {
Ast* start = ps->curr;
if (curris(ps, TkId)) {
*id = ps->curr->v;
step(ps);
Ast* op = ps->curr;
if (stepifis(ps, OpAsgn)) {
Ast* expr;
if (expression(ps, &expr)) {
ast_swap(start, op);
ast_next_to_first_child(start);
ast_next_to_last_child(start);
}
else { parerr(ps, "invalid initialization syntax"); }
}
return 1;
}
else return 0;
}
static int arg_list(ParserState* ps, Ast* base) {
Ast* args = ps->curr;
if (curris(ps, PLParen)) {
enterblk();
while (ps->curr != 0) {
Ast* expr;
if (!expression(ps, &expr))
parerr(ps, "invalid argument");
if (stepifis(ps, PComma))
free(ast_rmnext(expr));
else if (ps->curr != 0)
parerr(ps, "expecting \',\' in parameter list");
}
exitblk();
ast_swap(base, args);
ast_next_to_first_child(base);
base->t = AstInvoke;
return 1;
}
else return 0;
}
bool expr_typeref(pass_opt_t* opt, ast_t** astp)
{
ast_t* ast = *astp;
assert(ast_id(ast) == TK_TYPEREF);
ast_t* type = ast_type(ast);
if(is_typecheck_error(type))
return false;
switch(ast_id(ast_parent(ast)))
{
case TK_QUALIFY:
// Doesn't have to be valid yet.
break;
case TK_DOT:
// Has to be valid.
if(!expr_nominal(opt, &type))
{
ast_settype(ast, ast_from(type, TK_ERRORTYPE));
ast_free_unattached(type);
return false;
}
break;
case TK_CALL:
{
// Has to be valid.
if(!expr_nominal(opt, &type))
{
ast_settype(ast, ast_from(type, TK_ERRORTYPE));
ast_free_unattached(type);
return false;
}
// Transform to a default constructor.
ast_t* dot = ast_from(ast, TK_DOT);
ast_add(dot, ast_from_string(ast, "create"));
ast_swap(ast, dot);
*astp = dot;
ast_add(dot, ast);
if(!expr_dot(opt, astp))
{
ast_settype(ast, ast_from(type, TK_ERRORTYPE));
ast_free_unattached(type);
return false;
}
ast_t* ast = *astp;
// If the default constructor has no parameters, transform to an apply
// call.
if((ast_id(ast) == TK_NEWREF) || (ast_id(ast) == TK_NEWBEREF))
{
type = ast_type(ast);
if(is_typecheck_error(type))
return false;
assert(ast_id(type) == TK_FUNTYPE);
AST_GET_CHILDREN(type, cap, typeparams, params, result);
if(ast_id(params) == TK_NONE)
{
// Add a call node.
ast_t* call = ast_from(ast, TK_CALL);
ast_add(call, ast_from(call, TK_NONE)); // Named
ast_add(call, ast_from(call, TK_NONE)); // Positional
ast_swap(ast, call);
ast_append(call, ast);
if(!expr_call(opt, &call))
{
ast_settype(ast, ast_from(type, TK_ERRORTYPE));
ast_free_unattached(type);
return false;
}
// Add a dot node.
ast_t* apply = ast_from(call, TK_DOT);
ast_add(apply, ast_from_string(call, "apply"));
ast_swap(call, apply);
ast_add(apply, call);
if(!expr_dot(opt, &apply))
{
ast_settype(ast, ast_from(type, TK_ERRORTYPE));
ast_free_unattached(type);
return false;
}
}
}
return true;
}
default:
{
// Has to be valid.
if(!expr_nominal(opt, &type))
{
ast_settype(ast, ast_from(type, TK_ERRORTYPE));
ast_free_unattached(type);
return false;
}
// Transform to a default constructor.
ast_t* dot = ast_from(ast, TK_DOT);
ast_add(dot, ast_from_string(ast, "create"));
ast_swap(ast, dot);
ast_add(dot, ast);
// Call the default constructor with no arguments.
ast_t* call = ast_from(ast, TK_CALL);
ast_swap(dot, call);
ast_add(call, dot); // Receiver comes last.
ast_add(call, ast_from(ast, TK_NONE)); // Named args.
ast_add(call, ast_from(ast, TK_NONE)); // Positional args.
*astp = call;
if(!expr_dot(opt, &dot))
{
ast_settype(ast, ast_from(type, TK_ERRORTYPE));
ast_free_unattached(type);
return false;
}
if(!expr_call(opt, astp))
{
ast_settype(ast, ast_from(type, TK_ERRORTYPE));
ast_free_unattached(type);
return false;
}
break;
}
}
return true;
}
static void trace_dynamic_tuple(compile_t* c, LLVMValueRef ctx,
LLVMValueRef ptr, LLVMValueRef desc, ast_t* type, ast_t* orig, ast_t* tuple)
{
// Build a "don't care" type of our cardinality.
size_t cardinality = ast_childcount(type);
ast_t* dontcare = ast_from(type, TK_TUPLETYPE);
for(size_t i = 0; i < cardinality; i++)
ast_append(dontcare, ast_from(type, TK_DONTCARE));
// Replace our type in the tuple type with the "don't care" type.
bool in_tuple = (tuple != NULL);
if(in_tuple)
ast_swap(type, dontcare);
else
tuple = dontcare;
// If the original type is a subtype of the test type, then we are always
// the correct cardinality. Otherwise, we need to dynamically check
// cardinality.
LLVMBasicBlockRef is_true = codegen_block(c, "");
LLVMBasicBlockRef is_false = codegen_block(c, "");
if(!is_subtype(orig, tuple, NULL))
{
LLVMValueRef dynamic_count = gendesc_fieldcount(c, desc);
LLVMValueRef static_count = LLVMConstInt(c->i32, cardinality, false);
LLVMValueRef test = LLVMBuildICmp(c->builder, LLVMIntEQ, static_count,
dynamic_count, "");
// Skip if not the right cardinality.
LLVMBuildCondBr(c->builder, test, is_true, is_false);
} else {
LLVMBuildBr(c->builder, is_true);
}
LLVMPositionBuilderAtEnd(c->builder, is_true);
size_t index = 0;
ast_t* child = ast_child(type);
ast_t* dc_child = ast_child(dontcare);
while(child != NULL)
{
switch(trace_type(child))
{
case TRACE_PRIMITIVE:
// Skip this element.
break;
case TRACE_ACTOR:
case TRACE_KNOWN:
case TRACE_UNKNOWN:
case TRACE_KNOWN_VAL:
case TRACE_UNKNOWN_VAL:
case TRACE_TAG:
case TRACE_TAG_OR_ACTOR:
case TRACE_DYNAMIC:
{
// If we are (A, B), turn (_, _) into (A, _).
ast_t* swap = ast_dup(child);
ast_swap(dc_child, swap);
// Create a next block.
LLVMBasicBlockRef next_block = codegen_block(c, "");
// Load the object from the tuple field.
LLVMValueRef field_info = gendesc_fieldinfo(c, desc, index);
LLVMValueRef object = gendesc_fieldload(c, ptr, field_info);
// Trace dynamic, even if the tuple thinks the field isn't dynamic.
trace_dynamic(c, ctx, object, swap, orig, tuple, next_block);
// Continue into the next block.
LLVMBuildBr(c->builder, next_block);
LLVMPositionBuilderAtEnd(c->builder, next_block);
// Restore (A, _) to (_, _).
ast_swap(swap, dc_child);
ast_free_unattached(swap);
break;
}
case TRACE_TUPLE:
{
// If we are (A, B), turn (_, _) into (A, _).
ast_t* swap = ast_dup(child);
ast_swap(dc_child, swap);
// Get a pointer to the unboxed tuple and it's descriptor.
LLVMValueRef field_info = gendesc_fieldinfo(c, desc, index);
LLVMValueRef field_ptr = gendesc_fieldptr(c, ptr, field_info);
LLVMValueRef field_desc = gendesc_fielddesc(c, field_info);
// Trace the tuple dynamically.
trace_dynamic_tuple(c, ctx, field_ptr, field_desc, swap, orig, tuple);
// Restore (A, _) to (_, _).
ast_swap(swap, dc_child);
ast_free_unattached(swap);
break;
}
default: {}
}
index++;
child = ast_sibling(child);
dc_child = ast_sibling(dc_child);
}
// Restore the tuple type.
if(in_tuple)
ast_swap(dontcare, type);
ast_free_unattached(dontcare);
// Continue with other possible tracings.
LLVMBuildBr(c->builder, is_false);
LLVMPositionBuilderAtEnd(c->builder, is_false);
}
// Add the given case method into the given match method wrapper and check the
// are compatible.
// Returns: match case for worker method or NULL on error.
static ast_t* add_case_method(ast_t* match_method, ast_t* case_method)
{
assert(match_method != NULL);
assert(case_method != NULL);
// We need default capabality and return value if not provided explicitly.
if(ast_id(case_method) == TK_FUN)
fun_defaults(case_method);
AST_GET_CHILDREN(match_method, match_cap, match_id, match_t_params,
match_params, match_ret_type, match_question);
AST_GET_CHILDREN(case_method, case_cap, case_id, case_t_params, case_params,
case_ret_type, case_question, case_body, case_docstring, case_guard);
bool ok = true;
if(ast_id(case_method) != ast_id(match_method))
{
ast_error(case_method,
"cannot mix fun and be cases in a single match method");
ast_error(match_method, "clashing method here");
ok = false;
}
if(ast_id(case_method) == TK_FUN)
{
if(ast_id(case_cap) != ast_id(match_cap))
{
ast_error(case_cap, "differing receiver capabilities on case methods");
ast_error(match_cap, "clashing capability here");
ok = false;
}
if(ast_id(match_ret_type) == TK_NONE)
{
// Use case method return type.
ast_replace(&match_ret_type, case_ret_type);
}
else
{
// Union this case method's return type with the existing match one.
REPLACE(&match_ret_type,
NODE(TK_UNIONTYPE,
TREE(match_ret_type)
TREE(case_ret_type)));
}
}
if(ast_id(case_question) == TK_QUESTION)
// If any case throws the match does too.
ast_setid(match_question, TK_QUESTION);
if(!process_t_params(match_t_params, case_t_params))
ok = false;
ast_t* pattern = process_params(match_params, case_params);
if(!ok || pattern == NULL)
{
ast_free(pattern);
return NULL;
}
// Extract case body and guard condition (if any) to avoid copying.
ast_t* body = ast_from(case_body, TK_NONE);
ast_swap(case_body, body);
ast_t* guard = ast_from(case_guard, TK_NONE);
ast_swap(case_guard, guard);
// Make match case.
BUILD(match_case, pattern,
NODE(TK_CASE, AST_SCOPE
TREE(pattern)
TREE(case_guard)
TREE(case_body)));
return match_case;
}
static bool type_access(pass_opt_t* opt, ast_t** astp)
{
ast_t* ast = *astp;
// Left is a typeref, right is an id.
ast_t* left = ast_child(ast);
ast_t* right = ast_sibling(left);
ast_t* type = ast_type(left);
if(is_typecheck_error(type))
return false;
assert(ast_id(left) == TK_TYPEREF);
assert(ast_id(right) == TK_ID);
ast_t* find = lookup(opt, ast, type, ast_name(right));
if(find == NULL)
return false;
bool ret = true;
switch(ast_id(find))
{
case TK_TYPEPARAM:
ast_error(opt->check.errors, right,
"can't look up a typeparam on a type");
ret = false;
break;
case TK_NEW:
ret = method_access(opt, ast, find);
break;
case TK_FVAR:
case TK_FLET:
case TK_EMBED:
case TK_BE:
case TK_FUN:
{
// Make this a lookup on a default constructed object.
ast_free_unattached(find);
if(!strcmp(ast_name(right), "create"))
{
ast_error(opt->check.errors, right,
"create is not a constructor on this type");
return false;
}
ast_t* dot = ast_from(ast, TK_DOT);
ast_add(dot, ast_from_string(ast, "create"));
ast_swap(left, dot);
ast_add(dot, left);
ast_t* call = ast_from(ast, TK_CALL);
ast_swap(dot, call);
ast_add(call, dot); // the LHS goes at the end, not the beginning
ast_add(call, ast_from(ast, TK_NONE)); // named
ast_add(call, ast_from(ast, TK_NONE)); // positional
if(!expr_dot(opt, &dot))
return false;
if(!expr_call(opt, &call))
return false;
return expr_dot(opt, astp);
}
default:
assert(0);
ret = false;
break;
}
ast_free_unattached(find);
return ret;
}
bool expr_qualify(pass_opt_t* opt, ast_t** astp)
{
// Left is a postfix expression, right is a typeargs.
ast_t* ast = *astp;
AST_GET_CHILDREN(ast, left, right);
ast_t* type = ast_type(left);
assert(ast_id(right) == TK_TYPEARGS);
if(is_typecheck_error(type))
return false;
switch(ast_id(left))
{
case TK_TYPEREF:
{
// Qualify the type.
assert(ast_id(type) == TK_NOMINAL);
// If the type isn't polymorphic or the type is already qualified,
// sugar .apply().
ast_t* def = names_def(opt, type);
ast_t* typeparams = ast_childidx(def, 1);
if((ast_id(typeparams) == TK_NONE) ||
(ast_id(ast_childidx(type, 2)) != TK_NONE))
{
if(!expr_nominal(opt, &type))
return false;
break;
}
type = ast_dup(type);
ast_t* typeargs = ast_childidx(type, 2);
ast_replace(&typeargs, right);
ast_settype(ast, type);
ast_setid(ast, TK_TYPEREF);
return expr_typeref(opt, astp);
}
case TK_NEWREF:
case TK_NEWBEREF:
case TK_BEREF:
case TK_FUNREF:
case TK_NEWAPP:
case TK_BEAPP:
case TK_FUNAPP:
{
// Qualify the function.
assert(ast_id(type) == TK_FUNTYPE);
ast_t* typeparams = ast_childidx(type, 1);
if(!reify_defaults(typeparams, right, true, opt))
return false;
if(!check_constraints(left, typeparams, right, true, opt))
return false;
type = reify(type, typeparams, right, opt);
typeparams = ast_childidx(type, 1);
ast_replace(&typeparams, ast_from(typeparams, TK_NONE));
ast_settype(ast, type);
ast_setid(ast, ast_id(left));
ast_inheritflags(ast);
return true;
}
default: {}
}
// Sugar .apply()
ast_t* dot = ast_from(left, TK_DOT);
ast_add(dot, ast_from_string(left, "apply"));
ast_swap(left, dot);
ast_add(dot, left);
if(!expr_dot(opt, &dot))
return false;
return expr_qualify(opt, astp);
}
static ast_result_t sugar_entity(typecheck_t* t, ast_t* ast, bool add_create,
token_id def_def_cap)
{
AST_GET_CHILDREN(ast, id, typeparams, defcap, traits, members);
if(add_create)
add_default_constructor(ast);
if(ast_id(defcap) == TK_NONE)
ast_setid(defcap, def_def_cap);
// Build a reverse sequence of all field initialisers.
BUILD(init_seq, members, NODE(TK_SEQ));
ast_t* member = ast_child(members);
while(member != NULL)
{
switch(ast_id(member))
{
case TK_FLET:
case TK_FVAR:
case TK_EMBED:
{
AST_GET_CHILDREN(member, f_id, f_type, f_init);
if(ast_id(f_init) != TK_NONE)
{
// Replace the initialiser with TK_NONE.
ast_swap(f_init, ast_from(f_init, TK_NONE));
// id = init
BUILD(init, member,
NODE(TK_ASSIGN,
TREE(f_init)
NODE(TK_REFERENCE, TREE(f_id))));
ast_add(init_seq, init);
}
break;
}
default: {}
}
member = ast_sibling(member);
}
// Add field initialisers to all constructors.
if(ast_child(init_seq) != NULL)
{
member = ast_child(members);
while(member != NULL)
{
switch(ast_id(member))
{
case TK_NEW:
{
AST_GET_CHILDREN(member, n_cap, n_id, n_typeparam, n_params,
n_result, n_partial, n_body);
assert(ast_id(n_body) == TK_SEQ);
ast_t* init = ast_child(init_seq);
while(init != NULL)
{
ast_add(n_body, init);
init = ast_sibling(init);
}
break;
}
default: {}
}
member = ast_sibling(member);
}
}
ast_free_unattached(init_seq);
return sugar_case_methods(t, ast);
}
