Complete 1.04.p: add semantic actions to parser

[tiger.ml.git] / tiger / src / lib / tiger / tiger_parser.mly

%{
  module Ast = Tiger_absyn
  module Sym = Tiger_symbol

  let pos () =
    Tiger_position.of_lexing_positions
      ~pos_start:(Parsing.symbol_start_pos ())
      ~pos_end:(Parsing.symbol_end_pos ())
%}

/* Declarations */
%token AND
%token ARRAY
%token ASSIGN
%token BREAK
%token COLON
%token COMMA
%token DIVIDE
%token DO
%token DOT
%token ELSE
%token END
%token EOF
%token EQ
%token FOR
%token FUNCTION
%token GE
%token GT
%token <string> ID
%token IF
%token IN
%token <int> INT
%token LBRACE
%token LBRACK
%token LE
%token LET
%token LPAREN
%token LT
%token MINUS
%token NEQ
%token NIL
%token OF
%token OR
%token PLUS
%token RBRACE
%token RBRACK
%token RPAREN
%token SEMICOLON
%token <string> STRING
%token THEN
%token TIMES
%token TO
%token TYPE
%token VAR
%token WHILE

/* from lowest precedence */
%nonassoc LOWEST
%nonassoc THEN
%nonassoc ELSE
%nonassoc ASSIGN
%nonassoc OF DO
%left OR
%left AND
%nonassoc EQ NEQ GT LT GE LE
%left PLUS MINUS
%left TIMES DIVIDE
%nonassoc HIGHEST
/* to highest precedence */

%type <Tiger_absyn.t> program

%start program

%%

program: exp EOF { $1 };

exp:
  | NIL
    { Ast.NilExp }
  | INT
    { Ast.IntExp $1 }
  | MINUS exp %prec HIGHEST
    {
      Ast.OpExp
        { left  = Ast.IntExp 0
        ; oper  = Ast.MinusOp
        ; right = $2
        ; pos   = pos ()
        }
    }
  | lvalue LBRACK exp RBRACK OF exp
    {
      match $1 with
      | Ast.SimpleVar {symbol=typ; _} ->
          Ast.ArrayExp
            { typ
            ; size = $3
            ; init = $6
            ; pos  = pos ()
            }
      | Ast.SubscriptVar _ | Ast.FieldVar _ ->
          raise Parse_error
    }
  | ID LBRACE rec_fields_bind RBRACE
    {
      let type_id = $1 in
      let fields  = $3 in
      let typ     = Sym.of_string type_id in
      let pos     = pos () in
      Ast.RecordExp {fields; typ; pos}
    }
  | lvalue
    { Ast.VarExp $1 }
  | lvalue ASSIGN exp
    {
      let var = $1 in
      let exp = $3 in
      let pos = pos () in
      Ast.AssignExp {var; exp; pos}
    }
  | STRING
    { Ast.StringExp {string = $1; pos = pos ()} }
  | ID LPAREN fun_args RPAREN
    {
      Ast.CallExp
        { func = Sym.of_string $1
        ; args = $3
        ; pos  = pos ()
        }
    }
  | exp PLUS exp
    {
      Ast.OpExp
        { left  = $1
        ; oper  = Ast.PlusOp
        ; right = $3
        ; pos   = pos ()
        }
    }
  | exp MINUS exp
    {
      Ast.OpExp
        { left  = $1
        ; oper  = Ast.MinusOp
        ; right = $3
        ; pos   = pos ()
        }
    }
  | exp TIMES exp
    {
      Ast.OpExp
        { left  = $1
        ; oper  = Ast.TimesOp
        ; right = $3
        ; pos   = pos ()
        }
    }
  | exp DIVIDE exp
    {
      Ast.OpExp
        { left  = $1
        ; oper  = Ast.DivideOp
        ; right = $3
        ; pos   = pos ()
        }
    }
  | exp EQ exp
    {
      Ast.OpExp
        { left  = $1
        ; oper  = Ast.EqOp
        ; right = $3
        ; pos   = pos ()
        }
    }
  | exp NEQ exp
    {
      Ast.OpExp
        { left  = $1
        ; oper  = Ast.NeqOp
        ; right = $3
        ; pos   = pos ()
        }
    }
  | exp GT exp
    {
      Ast.OpExp
        { left  = $1
        ; oper  = Ast.GtOp
        ; right = $3
        ; pos   = pos ()
        }
    }
  | exp LT exp
    {
      Ast.OpExp
        { left  = $1
        ; oper  = Ast.LtOp
        ; right = $3
        ; pos   = pos ()
        }
    }
  | exp GE exp
    {
      Ast.OpExp
        { left  = $1
        ; oper  = Ast.GeOp
        ; right = $3
        ; pos   = pos ()
        }
    }
  | exp LE exp
    {
      Ast.OpExp
        { left  = $1
        ; oper  = Ast.LeOp
        ; right = $3
        ; pos   = pos ()
        }
    }
  | exp AND exp
    {
      let e1 = $1 in
      let e2 = $3 in
      Ast.IfExp
        { test  = e1
        ; then' = e2
        ; else' = Some (Ast.IntExp 0)
        ; pos   = pos ()
        }
    }
  | exp OR exp
    {
      let e1 = $1 in
      let e2 = $3 in
      Ast.IfExp
        { test  = e1
        ; then' = Ast.IntExp 1
        ; else' = Some e2
        ; pos   = pos ()
        }
    }
  | IF exp THEN exp ELSE exp
    {
      let e1 = $2 in
      let e2 = $4 in
      let e3 = $6 in
      Ast.IfExp
        { test  = e1
        ; then' = e2
        ; else' = Some e3
        ; pos   = pos ()
        }
    }
  | IF exp THEN exp
    {
      let e1 = $2 in
      let e2 = $4 in
      Ast.IfExp
        { test  = e1
        ; then' = e2
        ; else' = None
        ; pos   = pos ()
        }
    }
  | WHILE exp DO exp
    {
      let e1 = $2 in
      let e2 = $4 in
      Ast.WhileExp
        { test = e1
        ; body = e2
        ; pos  = pos ()
        }
    }
  | FOR ID ASSIGN exp TO exp DO exp
    {
      let var = $2 in
      let e1  = $4 in
      let e2  = $6 in
      let e3  = $8 in
      Ast.ForExp
        { var    = Sym.of_string var
        ; escape = ref true
        ; lo     = e1
        ; hi     = e2
        ; body   = e3
        ; pos    = pos ()
        }
    }
  | BREAK
    { Ast.BreakExp (pos ()) }
  | LPAREN exps RPAREN
    { Ast.SeqExp $2 }
  | LET decs IN exps END
    {
      let decs = $2 in
      let exps = $4 in
      Ast.LetExp {decs; body = Ast.SeqExp exps; pos = pos ()}
    }
  ;

exps:
  |                    {                 [] }
  | exp                { ($1, pos ()) :: [] }
  | exp SEMICOLON exps { ($1, pos ()) :: $3 }
  ;

rec_fields_bind:
  | ID EQ exp                       { (Sym.of_string $1, $3, pos ()) :: [] }
  | ID EQ exp COMMA rec_fields_bind { (Sym.of_string $1, $3, pos ()) :: $5 }
  ;

decs:
  | dec      { $1 :: [] }
  | dec decs { $1 :: $2 }
  ;

dec:
  | var_dec                { $1 }
  | typ_decs  %prec LOWEST { Ast.TypeDecs $1 }
  | fun_decs  %prec LOWEST { Ast.FunDecs $1 }
  ;

typ_decs:
  | typ_dec                        { $1 :: [] }
  | typ_dec typ_decs %prec LOWEST  { $1 :: $2 }
  ;

typ_dec:
  | TYPE ID EQ ID
    {
      let type_id_left = $2 in
      let type_id_right = $4 in
      let pos = pos () in  (* FIXME: rhs id should have its own pos, no? *)
      Ast.TypeDec
        { name = Sym.of_string type_id_left
        ; ty   = Ast.NameTy {symbol = Sym.of_string type_id_right; pos}
        ; pos
        }
    }
  | TYPE ID EQ LBRACE type_fields RBRACE
    {
      let type_id = $2 in
      let type_fields = $5 in
      Ast.TypeDec
        { name = Sym.of_string type_id
        ; ty   = Ast.RecordTy type_fields
        ; pos  = pos ()
        }
    }
  | TYPE ID EQ ARRAY OF ID
    {
      let type_id         = Sym.of_string $2 in
      let element_type_id = Sym.of_string $6 in
      let pos = pos () in
      Ast.TypeDec
        { name = type_id
        ; ty   = Ast.ArrayTy {symbol = element_type_id; pos}
        ; pos
        }
    }
  ;

var_dec:
  | VAR ID maybe_type_sig ASSIGN exp
    {
      let var_id = Sym.of_string $2 in
      let maybe_type_sig = $3 in
      let exp = $5 in
      let pos = pos () in
      Ast.VarDec
        { name   = var_id
        ; escape = ref true
        ; typ    = maybe_type_sig
        ; init   = exp
        ; pos
        }
    }
  ;

fun_decs:
  | fun_dec                       { $1 :: [] }
  | fun_dec fun_decs %prec LOWEST { $1 :: $2 }
  ;

fun_dec:
  | FUNCTION ID LPAREN type_fields RPAREN maybe_type_sig EQ exp
    {
      let name   = Sym.of_string $2 in
      let params = $4 in
      let result = $6 in
      let body   = $8 in
      let pos    = pos () in
      Ast.FunDec {name; params; result; body; pos}
    }
  ;

maybe_type_sig:
  |          { None }
  | COLON ID { Some (Sym.of_string $2, pos ()) }
  ;

type_fields:
  |
    { [] }
  | ID COLON ID
    {
      let field =
        Ast.Field
          { name   = Sym.of_string $1
          ; escape = ref true
          ; typ    = Sym.of_string $3
          ; pos    = pos ()
          }
      in
      field :: []
    }
  | ID COLON ID COMMA type_fields
    {
      let field =
        Ast.Field
          { name   = Sym.of_string $1
          ; escape = ref true
          ; typ    = Sym.of_string $3
          ; pos    = pos ()
          }
      in
      field :: $5
    }
  ;

fun_args:
  |                    {       [] }
  | exp                { $1 :: [] }
  | exp COMMA fun_args { $1 :: $3 }
  ;

lvalue:
  | ID
    {
      Ast.SimpleVar
        { symbol = Sym.of_string $1
        ; pos    = pos ()
        }
    }
  | lvalue LBRACK exp RBRACK
    {
      Ast.SubscriptVar
        { var = $1
        ; exp = $3
        ; pos = pos ()
        }
    }
  | lvalue DOT ID
    {
      Ast.FieldVar
        { var    = $1
        ; symbol = Sym.of_string $3
        ; pos    = pos ()
        }
    }
  ;

%%