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 <int32> 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)  *)
llist(x):
  |            { [] }
  | llist(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
  { let nameloc = loc $startpos(name) $endpos(name) in
    GlobalDec (ctype, name, nameloc) }

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

  | 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) }

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

%inline ret_type:
    | t=basic_type  { t }
    | VOID          { Void }

fun_header:
  (* function header: use location of function name *)
  | ret=ret_type name=ID LPAREN params=clist(param) RPAREN
  { (ret, 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:
  | llist(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 1l, []), 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 }

%%