Source file asl_ast.ml

(* generated by Ott 0.30 from: asl.ott *)

type id = string
type typeid = string
type intLit = string
type bitsLit = string
type maskLit = string
type realLit = string
type hexLit = string
type i = int

(** Location tracking *)
type l =
    | Unknown
    | Int of string * l option
    | Generated of l
    | Range of Lexing.position * Lexing.position

type 'a annot = l * 'a

let pp_lexing_position (p: Lexing.position): string =
    Printf.sprintf  "file \"%s\" line %d char %d"
        p.Lexing.pos_fname p.Lexing.pos_lnum (p.Lexing.pos_cnum - p.Lexing.pos_bol)

let rec pp_loc (l: l): string =  match l with
    | Unknown -> "no location information available"
    | Generated l -> Printf.sprintf "Generated: %s"  (pp_loc l)
    | Range(p1, p2) ->
        if String.equal p1.Lexing.pos_fname p2.Lexing.pos_fname then begin
            if p1.Lexing.pos_lnum = p2.Lexing.pos_lnum then
                Printf.sprintf "file \"%s\" line %d char %d - %d"
                    p1.Lexing.pos_fname
                    p1.Lexing.pos_lnum
                    (p1.Lexing.pos_cnum - p1.Lexing.pos_bol)
                    (p2.Lexing.pos_cnum - p2.Lexing.pos_bol)
            else
                Printf.sprintf "file \"%s\" line %d char %d - line %d char %d"
                    p1.Lexing.pos_fname
                    p1.Lexing.pos_lnum
                    (p1.Lexing.pos_cnum - p1.Lexing.pos_bol)
                    p2.Lexing.pos_lnum
                    (p2.Lexing.pos_cnum - p2.Lexing.pos_bol)
        end else begin
            Printf.sprintf "file \"%s\" line %d char %d - file \"%s\" line %d char %d"
                p1.Lexing.pos_fname
                p1.Lexing.pos_lnum
                (p1.Lexing.pos_cnum - p1.Lexing.pos_bol)
                p2.Lexing.pos_fname
                p2.Lexing.pos_lnum
                (p2.Lexing.pos_cnum - p2.Lexing.pos_bol)
        end
    | Int(s,lo) -> Printf.sprintf "%s %s" s (match lo with Some l -> pp_loc l | None -> "none")

(** Parsing exceptions (1/2) *)
exception Parse_error_locn of l * string

(** Identifiers used for variable names, function names, etc.

    There are two kinds of identifier:
    - Ident is generated by the parser - it is just a string
    - FIdent is generated by the disambiguation part of the typechecker and
      includes a unique label to distinguish different entities with
      the same name in the source syntax.
 *)
type ident =
    | Ident of string
    | FIdent of string * int

let pprint_ident (x: ident): string =
    (match x with
    | Ident(s)    -> s
    | FIdent(s,t) -> s ^"."^ string_of_int t
    )

let addTag (x: ident) (tag: int): ident =
    (match x with
    | Ident(s)    -> FIdent (s, tag)
    | FIdent(_,_) -> failwith "addTag"
    )

let stripTag (x: ident): ident =
    (match x with
    | Ident(s)
    | FIdent(s,_) -> Ident (s)
    )

let name_of_FIdent (x: ident): string =
    (match x with
    | Ident(_)    -> failwith "name_of_FIdent"
    | FIdent(s,_) -> s
    )


let addQualifier (p: string) (x: ident): ident =
    (match x with
    | Ident(s)    -> Ident (p ^ "." ^ s)
    | FIdent(_,_) -> failwith "addQualifier"
    )

let addPrefix (p: string) (x: ident): ident =
    (match x with
    | Ident(q)    -> Ident (p ^ "." ^ q)
    | FIdent(_,_) -> failwith "addQualifier"
    )

let addSuffix (x: ident) (s: string): ident =
    (match x with
    | Ident(p)    -> Ident (p ^ "." ^ s)
    | FIdent(_,_) -> failwith "addQualifier"
    )

let genericTyvar (i: int): ident =
    let v = "$" ^ string_of_int i in
    Ident v

let isGenericTyvar (x: ident): bool =
    (match x with
    | Ident(s)    -> s.[0] = '$'
    | FIdent(_,_) -> failwith "addQualifier"
    )

module Id = struct
    type t = ident
    let compare (x: ident) (y: ident): int =
        (match (x, y) with
        | (Ident x, Ident y) ->
            String.compare x y
        | (FIdent (x,i), FIdent (y,j)) ->
            let cx = String.compare x y in
            if cx <> 0 then cx else compare i j
        | (Ident _, FIdent (_, _)) -> -1
        | (FIdent (_, _), Ident _) -> 1
        )
end

(** Type Identifiers *)

module StringSet = Set.Make(String)

let typeIdents = ref StringSet.empty

let addTypeIdent (x: ident): unit = begin
    (* ignore (Printf.printf "New type identifier %s\n" (pprint_ident x)); *)
    typeIdents := StringSet.add (pprint_ident x) !typeIdents
end

let isTypeIdent (x: string): bool = StringSet.mem x !typeIdents



type 
binop = 
   Binop_Eq
 | Binop_NtEq
 | Binop_Gt
 | Binop_GtEq
 | Binop_Lt
 | Binop_LtEq
 | Binop_Plus
 | Binop_Minus
 | Binop_Multiply
 | Binop_Divide
 | Binop_Power
 | Binop_Quot
 | Binop_Rem
 | Binop_Div
 | Binop_Mod
 | Binop_ShiftL
 | Binop_ShiftR
 | Binop_BoolAnd
 | Binop_BoolOr
 | Binop_BoolIff
 | Binop_BoolImplies
 | Binop_BitOr
 | Binop_BitEor
 | Binop_BitAnd
 | Binop_Append
 | Binop_Concat
 | Binop_DUMMY


type 
unop = 
   Unop_Negate
 | Unop_BoolNot
 | Unop_BitsNot


type 
ixtype = 
   Index_Enum of ident
 | Index_Range of expr * expr

and ty = 
   Type_Constructor of ident
 | Type_Bits of expr
 | Type_App of ident * (expr) list
 | Type_OfExpr of expr
 | Type_Register of intLit * (slice list * ident) list
 | Type_Array of ixtype * ty
 | Type_Tuple of (ty) list

and pattern = 
   Pat_LitInt of intLit
 | Pat_LitHex of hexLit
 | Pat_LitBits of bitsLit
 | Pat_LitMask of maskLit
 | Pat_Const of ident
 | Pat_Wildcard
 | Pat_Tuple of (pattern) list
 | Pat_Set of (pattern) list
 | Pat_Range of expr * expr
 | Pat_Single of expr

and expr = 
   Expr_If of expr * expr * (e_elsif) list * expr
 | Expr_Binop of expr * binop * expr
 | Expr_Unop of unop * expr (* unary operator *)
 | Expr_Field of expr * ident (* field selection *)
 | Expr_Fields of expr * (ident) list (* multiple field selection *)
 | Expr_Slices of expr * (slice) list (* bitslice *)
 | Expr_In of expr * pattern (* pattern match *)
 | Expr_Var of ident
 | Expr_Parens of expr
 | Expr_Tuple of (expr) list (* tuple *)
 | Expr_Unknown of ty
 | Expr_ImpDef of ty * string option
 | Expr_TApply of ident * (expr) list * (expr) list (* spice for desugaring function call with explicit type parameters *)
 | Expr_Array of expr * expr (* spice for desugaring array accesses *)
 | Expr_LitInt of intLit (* literal decimal integer *)
 | Expr_LitHex of hexLit (* literal hexadecimal integer *)
 | Expr_LitReal of realLit (* literal real *)
 | Expr_LitBits of bitsLit (* literal bitvector *)
 | Expr_LitMask of maskLit (* literal bitmask *)
 | Expr_LitString of string (* literal string *)

and e_elsif = 
   E_Elsif_Cond of expr * expr

and slice = 
   Slice_Single of expr
 | Slice_HiLo of expr * expr
 | Slice_LoWd of expr * expr


type 
direction = 
   Direction_Up
 | Direction_Down


type 
lexpr = 
   LExpr_Wildcard
 | LExpr_Var of ident
 | LExpr_Field of lexpr * ident
 | LExpr_Fields of lexpr * (ident) list
 | LExpr_Slices of lexpr * (slice) list
 | LExpr_BitTuple of (lexpr) list
 | LExpr_Tuple of (lexpr) list
 | LExpr_Array of lexpr * expr (* spice for desugaring array assignment *)
 | LExpr_Write of ident * (expr) list * (expr) list (* spice for desugaring setter procedure call *)
 | LExpr_ReadWrite of ident * ident * (expr) list * (expr) list (* spice for desugaring read-modify-write function+procedure call *)


type 
stmt = 
   Stmt_VarDeclsNoInit of ty * (ident) list * l
 | Stmt_VarDecl of ty * ident * expr * l
 | Stmt_ConstDecl of ty * ident * expr * l
 | Stmt_Assign of lexpr * expr * l
 | Stmt_FunReturn of expr * l (* function return *)
 | Stmt_ProcReturn of l (* procedure return *)
 | Stmt_Assert of expr * l (* assertion *)
 | Stmt_Unpred of l (* underspecified behaviour *)
 | Stmt_ConstrainedUnpred of l
 | Stmt_ImpDef of ident * l (* underspecified behaviour *)
 | Stmt_Undefined of l
 | Stmt_ExceptionTaken of l
 | Stmt_Dep_Unpred of l (* DEPRECATED *)
 | Stmt_Dep_ImpDef of string * l (* DEPRECATED *)
 | Stmt_Dep_Undefined of l (* DEPRECATED *)
 | Stmt_See of expr * l
 | Stmt_Throw of ident * l
 | Stmt_DecodeExecute of ident * expr * l (* decode and execute instruction *)
 | Stmt_TCall of ident * (expr) list * (expr) list * l (* spice for procedure call with explicit type parameters *)
 | Stmt_If of expr * stmt list * (s_elsif) list * stmt list * l
 | Stmt_Case of expr * (alt) list * (stmt list) option * l
 | Stmt_For of ident * expr * direction * expr * stmt list * l
 | Stmt_While of expr * stmt list * l
 | Stmt_Repeat of stmt list * expr * l
 | Stmt_Try of stmt list * ident * (catcher) list * (stmt list) option * l

and s_elsif = 
   S_Elsif_Cond of expr * stmt list

and alt = 
   Alt_Alt of (pattern) list * expr option * stmt list

and catcher = 
   Catcher_Guarded of expr * stmt list


type 
instr_field = 
   IField_Field of ident * int * int


type 
opcode_value = 
   Opcode_Bits of bitsLit
 | Opcode_Mask of maskLit


type 
decode_pattern = 
   DecoderPattern_Bits of bitsLit
 | DecoderPattern_Mask of maskLit
 | DecoderPattern_Wildcard of ident (* todo: wildcard should be underscore *)
 | DecoderPattern_Not of decode_pattern


type 
decode_slice = 
   DecoderSlice_Slice of int * int
 | DecoderSlice_FieldName of ident
 | DecoderSlice_Concat of (ident) list


type 
sformal = 
   Formal_In of ty * ident
 | Formal_InOut of ty * ident


type 
encoding = 
   Encoding_Block of ident * ident * (instr_field) list * opcode_value * expr * ((int * bitsLit)) list * stmt list * l


type 
decode_case = 
   DecoderCase_Case of (decode_slice) list * (decode_alt) list * l

and decode_alt = 
   DecoderAlt_Alt of (decode_pattern) list * decode_body

and decode_body = 
   DecoderBody_UNPRED of l
 | DecoderBody_UNALLOC of l
 | DecoderBody_NOP of l
 | DecoderBody_Encoding of ident * l
 | DecoderBody_Decoder of (instr_field) list * decode_case * l


type 
mapfield = 
   MapField_Field of ident * pattern


type 
declaration = 
   Decl_BuiltinType of ident * l
 | Decl_Forward of ident * l
 | Decl_Record of ident * (ty * ident) list * l
 | Decl_Typedef of ident * ty * l
 | Decl_Enum of ident * (ident) list * l
 | Decl_Var of ty * ident * l
 | Decl_Const of ty * ident * expr * l
 | Decl_BuiltinFunction of ty * ident * (ty * ident) list * l
 | Decl_FunType of ty * ident * (ty * ident) list * l
 | Decl_FunDefn of ty * ident * (ty * ident) list * stmt list * l
 | Decl_ProcType of ident * (ty * ident) list * l
 | Decl_ProcDefn of ident * (ty * ident) list * stmt list * l
 | Decl_VarGetterType of ty * ident * l
 | Decl_VarGetterDefn of ty * ident * stmt list * l
 | Decl_ArrayGetterType of ty * ident * (ty * ident) list * l
 | Decl_ArrayGetterDefn of ty * ident * (ty * ident) list * stmt list * l
 | Decl_VarSetterType of ident * ty * ident * l
 | Decl_VarSetterDefn of ident * ty * ident * stmt list * l
 | Decl_ArraySetterType of ident * (sformal) list * ty * ident * l
 | Decl_ArraySetterDefn of ident * (sformal) list * ty * ident * stmt list * l
 | Decl_InstructionDefn of ident * (encoding) list * (stmt list) option * bool * stmt list * l
 | Decl_DecoderDefn of ident * decode_case * l
 | Decl_Operator1 of unop * (ident) list * l
 | Decl_Operator2 of binop * (ident) list * l
 | Decl_NewEventDefn of ident * (ty * ident) list * l
 | Decl_EventClause of ident * stmt list * l
 | Decl_NewMapDefn of ty * ident * (ty * ident) list * stmt list * l
 | Decl_MapClause of ident * (mapfield) list * expr option * stmt list * l
 | Decl_Config of ty * ident * expr * l


type 
leadingblank = 
   LeadingBlank
 | LeadingNothing


type 
factor = 
   Factor_BinOp of binop * expr


type 
impdef_command = 
   CLI_Impdef of string * expr


let associativeOperators: binop list =
    [ Binop_Plus
    ; Binop_Multiply
    ; Binop_BoolAnd
    ; Binop_BoolOr
    ; Binop_BitOr
    ; Binop_BitEor
    ; Binop_BitAnd
    ; Binop_Concat
    ; Binop_Append
    ]

(* boolean operators bind least tightly *)
let booleanOperators: binop list =
    [ Binop_BoolAnd
    ; Binop_BoolOr
    ; Binop_BoolIff
    ; Binop_BoolImplies
    ]

(* comparision operators bind less tightly than arithmetic, etc. *)
let comparisionOperators: binop list =
    [ Binop_Eq
    ; Binop_NtEq
    ; Binop_Gt
    ; Binop_GtEq
    ; Binop_Lt
    ; Binop_LtEq
    ]

(* arithmetic and similar operations bind more tightly than comparisions and &&/|| *)
let miscOperators: binop list =
    [ Binop_Plus
    ; Binop_Minus
    ; Binop_Multiply
    ; Binop_Divide
    ; Binop_Power
    ; Binop_Quot
    ; Binop_Rem
    ; Binop_Div
    ; Binop_Mod
    ; Binop_ShiftL
    ; Binop_ShiftR
    ; Binop_BitOr
    ; Binop_BitEor
    ; Binop_BitAnd
    ; Binop_Concat
    ]

let isAssociative (x: binop): bool = List.mem x associativeOperators
let isBoolean     (x: binop): bool = List.mem x booleanOperators
let isComparision (x: binop): bool = List.mem x comparisionOperators
let isMisc        (x: binop): bool = List.mem x miscOperators

(* Is operator x higher priority than y
 * (Binop_DUMMY acts as the lowest priority operation - see below)
 *)
let higherPriorityThan (x: binop) (y: binop): bool option =
    if                             y = Binop_DUMMY    then Some(true)
    else if x = Binop_Power    && y = Binop_Multiply then Some(true)
    else if x = Binop_Power    && y = Binop_Divide   then Some(true)
    else if x = Binop_Power    && y = Binop_Plus     then Some(true)
    else if x = Binop_Power    && y = Binop_Minus    then Some(true)
    else if x = Binop_Multiply && y = Binop_Plus     then Some(true)
    else if x = Binop_Multiply && y = Binop_Minus    then Some(true)
    else if x = Binop_Plus     && y = Binop_Minus    then Some(true)
    else if isMisc x           && isBoolean y        then Some(true)
    else if isMisc x           && isComparision y    then Some(true)
    else if isComparision x    && isBoolean y        then Some(true)

    else if                       x = Binop_DUMMY    then Some(false)
    else if y = Binop_Power    && x = Binop_Multiply then Some(false)
    else if y = Binop_Power    && x = Binop_Divide   then Some(false)
    else if y = Binop_Power    && x = Binop_Plus     then Some(false)
    else if y = Binop_Power    && x = Binop_Minus    then Some(false)
    else if y = Binop_Multiply && x = Binop_Plus     then Some(false)
    else if y = Binop_Multiply && x = Binop_Minus    then Some(false)
    else if isMisc y           && isBoolean x        then Some(false)
    else if isMisc y           && isComparision x    then Some(false)
    else if isComparision y    && isBoolean x        then Some(false)

    (* The following rules might be a mistake - though they do seem
     * to match common usage.
     *)
    else if x = Binop_Minus    && y = Binop_Plus     then Some(true)
    else if x = Binop_Minus    && y = Binop_Minus    then Some(true)

    else None

(** Parsing exceptions (2/2) *)
exception PrecedenceError of l * binop * binop

(* Support function for parsing expression trees of the form
 *
 *     ... op x op_1 y_1 op_2 y_2 ... op_n y_n
 *
 * Consumes input until it finds an operator y_i of lower precedence
 * than op returning
 *
 * 1) an expression representing "x op_1 ... y_i-1"
 * 2) the remainder if the input "op_i y_i ... op_n y_n"
 *
 * As in Dijkstra's "Shunting Yard" algorithm, we work left to right across
 * the expression comparing the next two operators:
 * - op1 > op2 => (x op1 y1) op2 ...
 * - op1 < op2 => x op1 (y1 op2 ...) ...
 * - op1 = op2 => (x op1 y1) op2 ...     if op1 is associative
 * - _         => error
 *)
let rec buildExpr (op: binop) (x: expr) (ys: factor list) (loc: l): (expr * factor list) =
    ( match ys with
    | [] ->
        (x, [])
    | (Factor_BinOp(op1, y1) :: ys1) ->
        ( match higherPriorityThan op op1 with
        | Some(false) ->
            ( match ys1 with
            | (Factor_BinOp(op2, _) :: _) ->
                ( match higherPriorityThan op1 op2 with
                | Some(true) ->
                    buildExpr op (Expr_Binop(x, op1, y1)) ys1 loc
                | Some(false) ->
                    let (r, rs) = buildExpr op1 y1 ys1 loc in
                    buildExpr op (Expr_Binop(x, op1, r)) rs loc
                | None ->
                    if op1 = op2 && isAssociative(op1) then
                        buildExpr op (Expr_Binop(x, op1, y1)) ys1 loc
                    else
                        raise (PrecedenceError(loc, op1, op2))
                )
            | [] ->
                (Expr_Binop(x, op1, y1), [])
            )
        | _ -> (x, ys)
        )
    )

(* Construct an expression tree based on precedence rules
 *
 * Given parser output of the form  x op_1 y_1 op_2 y_2 ...op_n y_n,
 * construct a tree based on the relative priorities of op1, ... opn.
 * If any adjacent operators op_i, op_i+1 are unordered, report
 * a parsing ambiguity.
 *
 * We use a recursive variant on Dijkstra's Shunting Yard algorithm to
 * parse a list of operator-expression pairs into an expression tree
 * based on operator precedences
 * All operators are treated as left-associative
 *)

let buildExpression (x: expr) (fs: factor list) (loc: l): expr =
    ( match buildExpr Binop_DUMMY x fs loc with
    | (e, []) -> e
    | (_, _) -> raise (Parse_error_locn(loc, "Impossible: unable to resolve precedence"))
    )