civicaml/parser.mly

%{
    (**
     * Parser for the CiviC language.
     *
     * Note that some shift/reduce conflicts exist, but these need not be solved
     * since menhir can automatically resolve them
     *)

    open Lexing
    open Types

    let loc start stop = [Loc (Util.loc_from_lexpos start stop)]

    let rec make_dims dimloc = function
        | [] -> []
        | dim :: tail -> Dim (dim, dimloc) :: (make_dims dimloc tail)

    let rec make_args = function
        | [] -> []
        | h::t -> Arg h :: (make_args t)
%}

(* Tokens *)
%token LPAREN RPAREN LBRACK RBRACK LBRACE RBRACE SEMICOL COMMA
%token NOT ADD SUB MUL DIV MOD
%token EQ NE LT LE GT GE
%token AND OR
%token ASSIGN IF ELSE WHILE DO FOR RETURN EXTERN EXPORT
%token INT BOOL FLOAT VOID
%token EOF

%token <bool> BOOL_CONST
%token <float> FLOAT_CONST
%token <int> INT_CONST
%token <string> ID

(* Precedence *)
(*%right ASSIGN*)
%left OR
%left AND
%left EQ NE
%left LT LE GT GE
%left ADD SUB
%left MUL DIV MOD
%right NOT NEG CAST

%nonassoc IF
%nonassoc ELSE

(* Start symbol *)
%type <Types.node> program
%start program

%%

(* Left-recursive list (use List.rev to obtain original list)  *)
lreclist(x):
    |               { [] }
    | lreclist(x) x { $2 :: $1 }

(* Shorthand for comma-separated list *)
%inline clist(x):
    lst=separated_list(COMMA, x)
    { lst }

basic_type:
    | FLOAT { Float }
    | INT   { Int }
    | BOOL  { Bool }

program:
    decl* EOF
    { Program ($1, loc $startpos $endpos) }

decl:
    (* function: use location of function name *)
    | EXTERN hdr=fun_header SEMICOL
    { let (t, n, p, nameloc) = hdr in
      FunDec(t, n, p, nameloc) }

    | export=boption(EXPORT) hdr=fun_header LBRACE body=fun_body RBRACE
    { let (t, n, p, nameloc) = hdr in
      FunDef (export, t, n, p, Block body, nameloc) }

    (* global variable declaration: use location of variable name *)
    | EXTERN ctype=basic_type name=ID SEMICOL
    { GlobalDec (ctype, name, loc $startpos $endpos) }

    | EXTERN ctype=basic_type LBRACK dims=dimlist RBRACK name=ID SEMICOL
    { let loc = loc $startpos(name) $endpos(name) in
      GlobalDec (ArrayDims (ctype, List.rev dims), name, loc) }

    | export=boption(EXPORT) ctype=basic_type name=ID SEMICOL
    { let loc = loc $startpos(name) $endpos(name) in
      GlobalDef (export, ctype, name, None, loc) }

    | export=boption(EXPORT) ctype=basic_type name=ID ASSIGN init=expr SEMICOL
    { let loc = loc $startpos(name) $endpos(name) in
      GlobalDef (export, ctype, name, Some init, loc) }

    | export=boption(EXPORT) ctype=basic_type LBRACK dims=clist(expr) RBRACK
      name=ID SEMICOL
    { let loc = loc $startpos(name) $endpos(name) in
      GlobalDef (export, ArrayDims (ctype, dims), name, None, loc) }

fun_header:
    (* function header: use location of function name *)
    | ret=basic_type name=ID LPAREN params=clist(param) RPAREN
    { (ret, name, params, loc $startpos(name) $endpos(name)) }

    | VOID name=ID LPAREN params=clist(param) RPAREN
    { (Void, name, params, loc $startpos(name) $endpos(name)) }

param:
    (* parameter: use location of parameter name *)
    | ctype=basic_type name=ID
    { Param (ctype, name, loc $startpos(name) $endpos(name)) }

    | ctype=basic_type LBRACK dims=dimlist RBRACK name=ID
    { let loc = loc $startpos(name) $endpos(name) in
      Param (ArrayDims (ctype, List.rev dims), name, loc) }

dimlist:
    | name=ID
    { [Dim (name, loc $startpos(name) $endpos(name))] }
    | head=dimlist COMMA name=ID
    { Dim (name, loc $startpos(name) $endpos(name)) :: head }

fun_body:
    | lreclist(var_dec) local_fun_dec* statement* loption(return_statement)
    { VarDecs (List.rev $1) :: (LocalFuns $2) :: $3 @ $4 }

return_statement:
    (* return statement: use location of return value *)
    | RETURN value=expr SEMICOL
    { [Return (value, loc $startpos(value) $endpos(value))] }

(* function: use location of function name *)
local_fun_dec:
    | hdr=fun_header LBRACE body=fun_body RBRACE
    { let (t, n, p, nameloc) = hdr in
      FunDef (false, t, n, p, Block body, nameloc) }

var_dec:
    (* variable declaration: use location of variable name *)
    | ctype=basic_type name=ID SEMICOL
    { VarDec (ctype, name, None, loc $startpos(name) $endpos(name)) }

    | ctype=basic_type name=ID ASSIGN init=expr SEMICOL
    { VarDec (ctype, name, Some init, loc $startpos(name) $endpos(name)) }

    | ctype=basic_type LBRACK dims=clist(expr) RBRACK name=ID SEMICOL
    { let loc = loc $startpos(name) $endpos(name) in
      VarDec (ArrayDims (ctype, dims), name, None, loc) }

    | ctype=basic_type LBRACK dims=clist(expr) RBRACK name=ID ASSIGN
      init=expr SEMICOL
    { let loc = loc $startpos(name) $endpos(name) in
      VarDec (ArrayDims (ctype, dims), name, Some init, loc) }

statement:
    (* assignment: use location of assigned variable name *)
    | name=ID ASSIGN value=expr SEMICOL
    { Assign (name, None, value, loc $startpos(name) $endpos(name)) }

    | name=ID LBRACK dims=clist(expr) brk=RBRACK ASSIGN value=expr SEMICOL
    { Assign (name, Some dims, value, loc $startpos(name) $endpos(brk)) }

    | name=ID LPAREN args=clist(expr) RPAREN SEMICOL
    { Expr (FunCall (name, make_args args, loc $startpos(name) $endpos(name))) }

    (* if-statements and (do-)while-loops: use location of condition *)
    | IF LPAREN cond=expr RPAREN body=block
    { If (cond, Block body, loc $startpos $endpos) }                %prec IF

    | IF LPAREN c=expr RPAREN t=block ELSE f=block
    { IfElse (c, Block t, Block f, loc $startpos(c) $endpos(c)) }   %prec ELSE

    | WHILE LPAREN cond=expr RPAREN body=block
    { While (cond, Block body, loc $startpos(cond) $endpos(cond)) }

    | DO body=block WHILE LPAREN cond=expr RPAREN SEMICOL
    { DoWhile (cond, Block body, loc $startpos(cond) $endpos(cond)) }

    (* for-loop: use location of counter id *)
    | FOR LPAREN INT cnt=ID ASSIGN start=expr COMMA stop=expr RPAREN body=block
    { let loc = loc $startpos(cnt) $endpos(cnt) in
        For (cnt, start, stop, Const (IntVal 1, []), Block body, loc) }

    | FOR LPAREN INT cnt=ID ASSIGN start=expr COMMA stop=expr COMMA step=expr
      RPAREN body=block
    { let loc = loc $startpos(cnt) $endpos(cnt) in
      For (cnt, start, stop, step, Block body, loc) }

block:
    | LBRACE stats=statement* RBRACE  { stats }
    | stat=statement                  { [stat] }

expr:
    | name=ID LPAREN args=clist(expr) RPAREN
    { FunCall (name, make_args args, loc $startpos $endpos) }

    | LPAREN expr RPAREN              { $2 }
    | ID                              { Var ($1, None, loc $startpos $endpos) }
    | l=expr op=binop r=expr          { Binop (op, l, r, loc $startpos $endpos) }
    | SUB expr                        { Monop (Neg, $2, loc $startpos $endpos) }    %prec NEG
    | NOT expr                        { Monop (Not, $2, loc $startpos $endpos) }
    | LPAREN basic_type RPAREN expr   { TypeCast ($2, $4, loc $startpos $endpos) }  %prec CAST
    | FLOAT_CONST                     { Const (FloatVal $1, loc $startpos $endpos) }
    | INT_CONST                       { Const (IntVal $1, loc $startpos $endpos) }
    | BOOL_CONST                      { Const (BoolVal $1, loc $startpos $endpos) }
    | ID array_const                  { Var ($1, Some $2, loc $startpos $endpos) }
    | array_const                     { ArrayConst ($1, loc $startpos $endpos) }

%inline binop:
    | ADD  { Add }
    | SUB  { Sub }
    | MUL  { Mul }
    | DIV  { Div }
    | MOD  { Mod }
    | EQ   { Eq  }
    | NE   { Ne  }
    | LT   { Lt  }
    | LE   { Le  }
    | GT   { Gt  }
    | GE   { Ge  }
    | AND  { And }
    | OR   { Or  }

array_const:
    LBRACK values=clist(expr) RBRACK
    { values }

%%