From 693a3c9f9780ef1665c1d2c7dd3d7d79c27e76d5 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Thu, 5 Mar 2026 10:28:11 +1000 Subject: [PATCH 01/29] Initial types and operations defined --- lib/lang/expr_smt.ml | 19 +++++++++++++++++++ lib/lang/ops.ml | 24 ++++++++++++++++++++++++ lib/util/types.ml | 43 ++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 85 insertions(+), 1 deletion(-) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index fa02d9a0..d691cd64 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -99,6 +99,25 @@ module SMTLib2 = struct | Bitvector i -> ( list [ atom "_"; atom "BitVec"; atom @@ Int.to_string i ], LSet.singleton BV ) + | Record fields -> + (* Each field in record has three atoms? Offset, size, type *) + let of_field ({ offset; size; t } : Types.field) = + let t_sexp, t_set = of_typ t in + (list [ atom @@ Z.to_string offset; of_int size; t_sexp ], t_set) + in + (* The fold keeps track of the set and the map makes it a sexp list *) + let lset, sexp = + List.fold_left_map + (fun set field -> + let field_sexp, field_set = of_field field in + (LSet.union set field_set, field_sexp)) + LSet.empty fields + in + (list sexp, lset) + | Pointer (l, u) -> + let l_sexp, l_set = of_typ l in + let u_sexp, u_set = of_typ u in + (list [ l_sexp; u_sexp ], LSet.union l_set u_set) | Types.Unit -> (atom "Unit", LSet.singleton DT) | Types.Top -> (atom "Any", LSet.singleton DT) | Types.Nothing -> (atom "Nothing", LSet.singleton DT) diff --git a/lib/lang/ops.ml b/lib/lang/ops.ml index 7f18a0f5..d26bea6e 100644 --- a/lib/lang/ops.ml +++ b/lib/lang/ops.ml @@ -194,6 +194,30 @@ module IntOps = struct | #binary as b -> show_binary b end +module RecordOps = struct + type unary = [ `FACCESS of Z.t ] [@@deriving eq, ord] + type binary = [ `FSET of Z.t ] [@@deriving eq, ord] + + let show_unary = function + | `FACCESS offset -> "`FACCESS " ^ Z.to_string offset + + let show_binary = function `FSET offset -> "`FSET " ^ Z.to_string offset + let eval_unary (u : unary) = failwith "boom" + let eval_unary (u : binary) = failwith "boom" + + let show = function + | #unary as u -> show_unary u + | #binary as b -> show_binary b +end + +module PointerOps = struct + type binary = [ `PTRADD | `PTRSUB ] + [@@deriving show { with_path = false }, eq, ord] + + let eval_binary (u : binary) = failwith "boom" + let show = function #binary as u -> show_binary u +end + module Spec = struct type endian = [ `Big | `Little ] [@@deriving show { with_path = false }, eq, ord] diff --git a/lib/util/types.ml b/lib/util/types.ml index 19e7d5a6..12b243c4 100644 --- a/lib/util/types.ml +++ b/lib/util/types.ml @@ -33,10 +33,14 @@ type t = | Nothing | Map of t * t | Sort of string * variant list + | Record of field list + | Pointer of t * t and variant = { variant : string; fields : field list } and field = { field : string; typ : t } [@@deriving eq, ord] +and field2 = { offset : Z.t; size : int; t : t } + let bv i = Bitvector i let int = Integer let bool = Boolean @@ -72,7 +76,7 @@ let mk_adt name (variants : (string * field list) list) = (name, variants |> List.map (fun (variant, fields) -> { variant; fields })) (* - Nothing < Unit < {boolean, integer, bitvector} < Top + Nothing < Unit < {boolean, integer, bitvector, record, pointer} < Top *) let rec compare_partial (a : t) (b : t) = match (a, b) with @@ -86,11 +90,33 @@ let rec compare_partial (a : t) (b : t) = | _, Unit -> Some 1 | Boolean, Integer -> None | Integer, Boolean -> None + | Integer, Record _ -> None + | Integer, Pointer _ -> None | Boolean, Bitvector _ -> None + | Boolean, Pointer _ -> None + | Boolean, Record _ -> None | Bitvector _, Boolean -> None | Boolean, Boolean -> None | Integer, Bitvector _ -> None | Bitvector _, Integer -> None + | Bitvector _, Record _ -> None + | Bitvector _, Pointer _ -> None + | Record _, Bitvector _ -> None + | Record _, Integer -> None + | Record _, Boolean -> None + | Record _, Pointer _ -> None + | Pointer _, Bitvector _ -> None + | Pointer _, Integer -> None + | Pointer _, Boolean -> None + | Pointer _, Record _ -> None + | Pointer (l, u), Pointer (l2, u2) -> ( + compare_partial l l2 |> function Some 0 -> compare_partial u u2 | o -> o) + | Record fields, Record fields2 -> + Some + (List.compare + (fun a b -> + match field_equal_partial a b with Some a -> a | None -> -1) + fields fields2) | Bitvector a, Bitvector b -> Some (Int.compare a b) | Sort (n1, _), Sort (n2, _) -> if String.equal n1 n2 then Some 0 else None | Integer, Integer -> Some 0 @@ -98,6 +124,12 @@ let rec compare_partial (a : t) (b : t) = compare_partial k k2 |> function Some 0 -> compare_partial v v2 | o -> o) | _, _ -> None +and field_equal_partial { offset; size; t } + { offset = offset1; size = size1; t = t1 } = + if Z.compare offset1 offset <> 0 then + if Int.compare size size1 <> 0 then compare_partial t t1 else Some 0 + else Some 0 + let leq a b = compare_partial a b |> function Some a when a <= 0 -> true | _ -> false @@ -118,6 +150,15 @@ let rec to_string = function | Unit -> "()" | Top -> "⊤" | Nothing -> "⊥" + | Pointer (l, u) -> Printf.sprintf "ptr(%s, %s)" (to_string l) (to_string u) + | Record fields -> + List.fold_left + (fun acc { offset; size; t } -> + acc + ^ Printf.sprintf "(%s, %d) : %s" (Z.to_string offset) size + (to_string t)) + "{" fields + ^ "}" | Map ((Map _ as a), (Map _ as b)) -> "(" ^ "(" ^ to_string a ^ ")" ^ "->" ^ "(" ^ to_string b ^ ")" ^ ")" | Map ((Map _ as a), b) -> From 6b08c3efb807873cde87337d266c4724c2e4c7de Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Thu, 5 Mar 2026 13:34:18 +1000 Subject: [PATCH 02/29] New operations should be done --- flake.nix | 71 ++++++++++++++++++++++++------------------ lib/fe/AbsBasilIR.ml | 21 ++++++++++++- lib/fe/BNFC_Util.ml | 2 +- lib/fe/BasilIR.cf | 27 ++++++++++------ lib/fe/LexBasilIR.mll | 9 ++++-- lib/fe/ParBasilIR.mly | 52 +++++++++++++++++++++++++++++-- lib/fe/PrintBasilIR.ml | 30 +++++++++++++++++- lib/fe/ShowBasilIR.ml | 25 ++++++++++++++- lib/fe/SkelBasilIR.ml | 28 ++++++++++++++++- lib/fe/TestBasilIR.ml | 2 +- lib/lang/expr.ml | 6 ++++ lib/lang/expr_smt.ml | 2 +- lib/lang/ops.ml | 44 +++++++++++++++++++++----- lib/loadir.ml | 13 ++++++++ lib/util/types.ml | 29 +++++------------ 15 files changed, 279 insertions(+), 82 deletions(-) diff --git a/flake.nix b/flake.nix index 3c0b03ab..d9c00c09 100644 --- a/flake.nix +++ b/flake.nix @@ -5,30 +5,41 @@ infuse-src.flake = false; }; outputs = - { self - , nixpkgs - , infuse-src + { + self, + nixpkgs, + infuse-src, }@args: let inherit (nixpkgs) lib; - inherit (import ./nix/infuse-lib.nix { - lib = lib; - infuse-src = infuse-src; - }) infuse infuse-with; + inherit + (import ./nix/infuse-lib.nix { + lib = lib; + infuse-src = infuse-src; + }) + infuse + infuse-with + ; inherit (import ./nix/flake-for-all-systems.nix { lib = lib; }) - flake-for-all-systems; + flake-for-all-systems + ; - in flake-for-all-systems args { - systems = ["x86_64-linux" "aarch64-linux" "aarch64-darwin" "x86_64-darwin"]; - outputs = { self, nixpkgs, ... }: + in + flake-for-all-systems args { + systems = [ + "x86_64-linux" + "aarch64-linux" + "aarch64-darwin" + "x86_64-darwin" + ]; + outputs = + { self, nixpkgs, ... }: let pkgs = nixpkgs.legacyPackages; - selfOcamlPackages = - pkgs.ocamlPackages.overrideScope self.overlays.addBincamlPackages; - fpOcamlPackages = - selfOcamlPackages.overrideScope self.overlays.enableOcamlFramePointer; + selfOcamlPackages = pkgs.ocamlPackages.overrideScope self.overlays.addBincamlPackages; + fpOcamlPackages = selfOcamlPackages.overrideScope self.overlays.enableOcamlFramePointer; in { defaultPackage = selfOcamlPackages.bincaml; @@ -40,17 +51,19 @@ intPQueue = ofinal.callPackage ./nix/intpqueue.nix { }; }; - enableOcamlFramePointer = ofinal: infuse-with { - # https://github.com/NixOS/nixpkgs/blob/aca4d95fce4914b3892661bcb80b8087293536c6/pkgs/development/compilers/ocaml/generic.nix#L30 - ocaml.__input.flambdaSupport.__assign = true; - ocaml.__input.framePointerSupport.__assign = true; - ocaml.__attrs.patches.__append = [ - (pkgs.fetchpatch { - url = "https://github.com/ocaml/ocaml/commit/c2eec4dd1de7d0da2d2f76e5e7f2b567901f4e2c.patch"; - hash = "sha256-qDx8saOLhFMYaK4PLsSvHnDBYKvRSMmPtdVa/IqkQSI="; - }) - ]; - }; + enableOcamlFramePointer = + ofinal: + infuse-with { + # https://github.com/NixOS/nixpkgs/blob/aca4d95fce4914b3892661bcb80b8087293536c6/pkgs/development/compilers/ocaml/generic.nix#L30 + ocaml.__input.flambdaSupport.__assign = true; + ocaml.__input.framePointerSupport.__assign = true; + ocaml.__attrs.patches.__append = [ + (pkgs.fetchpatch { + url = "https://github.com/ocaml/ocaml/commit/c2eec4dd1de7d0da2d2f76e5e7f2b567901f4e2c.patch"; + hash = "sha256-qDx8saOLhFMYaK4PLsSvHnDBYKvRSMmPtdVa/IqkQSI="; + }) + ]; + }; }; legacyPackages = { @@ -68,8 +81,6 @@ fp = fpOcamlPackages.callPackage ./nix/shell.nix { }; no-fp = selfOcamlPackages.callPackage ./nix/shell.nix { }; }; - } - ; - } - ; + }; + }; } diff --git a/lib/fe/AbsBasilIR.ml b/lib/fe/AbsBasilIR.ml index 7e6d3e06..7fa36e55 100644 --- a/lib/fe/AbsBasilIR.ml +++ b/lib/fe/AbsBasilIR.ml @@ -1,8 +1,9 @@ -(* File generated by the BNF Converter (bnfc 2.9.6.2). *) +(* File generated by the BNF Converter (bnfc 2.9.6.1). *) type bVTYPE = BVTYPE of ((int * int) * string) and iNTTYPE = INTTYPE of ((int * int) * string) and bOOLTYPE = BOOLTYPE of ((int * int) * string) +and pOINTERTYPE = POINTERTYPE of ((int * int) * string) and bIdent = BIdent of ((int * int) * string) and localIdent = LocalIdent of ((int * int) * string) and globalIdent = GlobalIdent of ((int * int) * string) @@ -48,12 +49,21 @@ and procDef = ProcDef_Empty | ProcDef_Some of beginList * block list * endList +and field = + Field1 of openParen * intVal * intVal * closeParen * typeT + and intType = IntType1 of iNTTYPE and boolType = BoolType1 of bOOLTYPE +and recordType = + RecordType1 of beginRec * field list * endRec + +and pointerType = + PointerType1 of pOINTERTYPE * openParen * typeT * typeT * closeParen + and bVType = BVType1 of bVTYPE @@ -71,6 +81,8 @@ and typeT = TypeIntType of intType | TypeBoolType of boolType | TypeBVType of bVType + | TypePointerType of pointerType + | TypeRecordType of recordType | TypeParen of openParen * typeT * closeParen | TypeSort of localIdent | TypeMapType of mapType @@ -207,6 +219,8 @@ and expr = | Expr_SignExtend of openParen * intVal * expr * closeParen | Expr_Extract of openParen * intVal * intVal * expr * closeParen | Expr_Concat of openParen * expr list * closeParen + | Expr_FSet of openParen * intVal * expr * expr * closeParen + | Expr_FAccess of openParen * intVal * expr * closeParen | Expr_Match of expr * openParen * case list * closeParen | Expr_Cases of openParen * case list * closeParen | Expr_Paren of openParen * expr * closeParen @@ -220,6 +234,7 @@ and binOp = | BinOpIntLogicalBinOp of intLogicalBinOp | BinOpIntBinOp of intBinOp | BinOpEqOp of eqOp + | BinOpPointerBinOp of pointerBinOp and unOp = UnOpBVUnOp of bVUnOp @@ -289,6 +304,10 @@ and boolBinOp = | BoolBinOp_boolor | BoolBinOp_boolimplies +and pointerBinOp = + PointerBinOp_ptradd + | PointerBinOp_ptrsub + and requireTok = RequireTok_require | RequireTok_requires diff --git a/lib/fe/BNFC_Util.ml b/lib/fe/BNFC_Util.ml index 19303111..6d3bb604 100644 --- a/lib/fe/BNFC_Util.ml +++ b/lib/fe/BNFC_Util.ml @@ -1,4 +1,4 @@ -(* File generated by the BNF Converter (bnfc 2.9.6.2). *) +(* File generated by the BNF Converter (bnfc 2.9.6.1). *) open Lexing diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index 6c375b16..fca3d637 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -7,6 +7,7 @@ terminator Decl ";"; position token BVTYPE ('b' 'v' digit+) ; position token INTTYPE {"int"} ; position token BOOLTYPE {"bool"} ; +position token POINTERTYPE {"ptr"} ; {- position token UserIdent '`' ((upper | letter | '_' | '#')(upper | letter | digit | ["_.$#"])*) '`'; -} position token BIdent '.'((upper | letter | '_')(upper | letter | digit | ["_.$#~"])*) ; @@ -71,8 +72,13 @@ Decl_Type . Decl ::= "type" LocalIdent ; ProcDef_Empty . ProcDef ::= ; ProcDef_Some . ProcDef ::= BeginList [Block] EndList ; +separator Field "," ; +Field1 . Field ::= OpenParen IntVal "," IntVal CloseParen ":" Type "," ; + IntType1 . IntType ::= INTTYPE ; BoolType1. BoolType ::= BOOLTYPE ; +RecordType1 . RecordType ::= BeginRec [Field] EndRec ; +PointerType1 . PointerType ::= POINTERTYPE OpenParen Type "," Type CloseParen ; BVType1 . BVType ::= BVTYPE ; -- map types are right associative. left of -> cannot be another MapType. MapType1 . MapType ::= Type1 "->" Type ; @@ -86,13 +92,14 @@ VariantCase . SumCase ::= LocalIdent "of" BeginRec [RecordField] EndRec; separator nonempty SumCase "|"; -TypeIntType . Type1 ::= IntType ; -TypeBoolType . Type1 ::= BoolType ; -TypeBVType . Type1 ::= BVType ; -TypeParen . Type1 ::= OpenParen Type CloseParen; -TypeSort . Type1 ::= LocalIdent; - -TypeMapType . Type ::= MapType; +TypeIntType . Type1 ::= IntType ; +TypeBoolType . Type1 ::= BoolType ; +TypeBVType . Type1 ::= BVType ; +TypePointerType . Type1 ::= PointerType ; +TypeRecordType . Type1 ::= RecordType ; +TypeParen . Type1 ::= OpenParen Type CloseParen; +TypeSort . Type1 ::= LocalIdent; +TypeMapType . Type ::= MapType; _ . Type ::= Type1; IntVal_Hex . IntVal ::= IntegerHex ; @@ -246,7 +253,7 @@ Expr_FunctionOp . Expr1 ::= Expr1 OpenParen [Expr] CloseParen; -- binary expr -rules BinOp ::= BVBinOp | BVLogicalBinOp | IntLogicalBinOp | IntBinOp | EqOp ; +rules BinOp ::= BVBinOp | BVLogicalBinOp | IntLogicalBinOp | IntBinOp | EqOp | PointerBinOp ; Expr_Binary . Expr2 ::= BinOp OpenParen Expr "," Expr CloseParen ; Expr_Assoc . Expr2 ::= BoolBinOp OpenParen [Expr] CloseParen ; @@ -260,6 +267,8 @@ Expr_ZeroExtend . Expr2 ::= "zero_extend" OpenParen IntVal "," Expr CloseParen ; Expr_SignExtend . Expr2 ::= "sign_extend" OpenParen IntVal "," Expr CloseParen ; Expr_Extract . Expr2 ::= "extract" OpenParen IntVal "," IntVal "," Expr CloseParen ; Expr_Concat . Expr2 ::= "bvconcat" OpenParen [Expr] CloseParen ; +Expr_FSet . Expr ::= "fset" OpenParen IntVal "," Expr "," Expr CloseParen ; +Expr_FAccess . Expr ::= "facces" OpenParen IntVal "," Expr CloseParen ; CaseCase . Case ::= Expr "->" Expr ; CaseDefault . Case ::= "_" "->" Expr ; @@ -280,7 +289,7 @@ rules BVLogicalBinOp ::= "bvule" | "bvugt" | "bvuge" | "bvult" | "bvslt" | "b rules IntBinOp ::= "intadd" | "intmul" | "intsub" | "intdiv" | "intmod" ; rules IntLogicalBinOp ::= "intlt" | "intle" | "intgt" | "intge" ; rules BoolBinOp ::= "booland" | "boolor" | "boolimplies" ; - +rules PointerBinOp ::= "ptradd" | "ptrsub" ; {- SPECIFICATION -} diff --git a/lib/fe/LexBasilIR.mll b/lib/fe/LexBasilIR.mll index d4f39668..20259755 100644 --- a/lib/fe/LexBasilIR.mll +++ b/lib/fe/LexBasilIR.mll @@ -1,4 +1,4 @@ -(* File generated by the BNF Converter (bnfc 2.9.6.2). *) +(* File generated by the BNF Converter (bnfc 2.9.6.1). *) (* Lexer definition for ocamllex. *) @@ -11,9 +11,9 @@ let symbol_table = Hashtbl.create 10 let _ = List.iter (fun (kwd, tok) -> Hashtbl.add symbol_table kwd tok) [(";", SYMB1);(",", SYMB2);("->", SYMB3);("::", SYMB4);(":", SYMB5);("=", SYMB6);("|", SYMB7);(":=", SYMB8);("mem:=", SYMB9);("_", SYMB10)] -let resword_table = Hashtbl.create 101 +let resword_table = Hashtbl.create 105 let _ = List.iter (fun (kwd, tok) -> Hashtbl.add resword_table kwd tok) - [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("of", KW_of);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("old", KW_old);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("bvconcat", KW_bvconcat);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvmul", KW_bvmul);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxor", KW_bvxor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("boolimplies", KW_boolimplies);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] + [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("of", KW_of);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("old", KW_old);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("bvconcat", KW_bvconcat);("fset", KW_fset);("facces", KW_facces);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvmul", KW_bvmul);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxor", KW_bvxor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("boolimplies", KW_boolimplies);("ptradd", KW_ptradd);("ptrsub", KW_ptrsub);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] let unescapeInitTail (s:string) : string = let rec unesc s = match s with @@ -59,6 +59,7 @@ let rsyms = ";" | "," | "->" | "::" | ":" | "=" | "|" | ":=" | "mem:=" | "_" let bVTYPE = "bv" _digit + let iNTTYPE = "int" let bOOLTYPE = "bool" +let pOINTERTYPE = "ptr" let bIdent = '.' ('_' | _letter)('#' | '$' | '.' | '_' | '~' | (_digit | _letter)) * let localIdent = ('#' | '_' | _letter)('#' | '$' | '.' | '_' | (_digit | _letter)) * let globalIdent = '$' ('#' | '$' | '.' | '_' | (_digit | _letter)) + @@ -85,6 +86,8 @@ rule token = | iNTTYPE { let l = lexeme lexbuf in try Hashtbl.find resword_table l with Not_found -> TOK_INTTYPE ((lexeme_start lexbuf, lexeme_end lexbuf), l) } | bOOLTYPE { let l = lexeme lexbuf in try Hashtbl.find resword_table l with Not_found -> TOK_BOOLTYPE ((lexeme_start lexbuf, lexeme_end lexbuf), l) } + | pOINTERTYPE + { let l = lexeme lexbuf in try Hashtbl.find resword_table l with Not_found -> TOK_POINTERTYPE ((lexeme_start lexbuf, lexeme_end lexbuf), l) } | bIdent { let l = lexeme lexbuf in try Hashtbl.find resword_table l with Not_found -> TOK_BIdent ((lexeme_start lexbuf, lexeme_end lexbuf), l) } | localIdent { let l = lexeme lexbuf in try Hashtbl.find resword_table l with Not_found -> TOK_LocalIdent ((lexeme_start lexbuf, lexeme_end lexbuf), l) } diff --git a/lib/fe/ParBasilIR.mly b/lib/fe/ParBasilIR.mly index 976469cf..bbf47ab7 100644 --- a/lib/fe/ParBasilIR.mly +++ b/lib/fe/ParBasilIR.mly @@ -1,4 +1,4 @@ -/* File generated by the BNF Converter (bnfc 2.9.6.2). */ +/* File generated by the BNF Converter (bnfc 2.9.6.1). */ /* Parser definition for use with menhir */ @@ -7,7 +7,7 @@ open AbsBasilIR open Lexing %} -%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_of KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_true KW_false KW_forall KW_exists KW_fun KW_old KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_bvconcat KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvand KW_bvor KW_bvadd KW_bvmul KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_boolimplies KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant +%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_of KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_true KW_false KW_forall KW_exists KW_fun KW_old KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_bvconcat KW_fset KW_facces KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvand KW_bvor KW_bvadd KW_bvmul KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_boolimplies KW_ptradd KW_ptrsub KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant %token SYMB1 /* ; */ %token SYMB2 /* , */ @@ -29,6 +29,7 @@ open Lexing %token <(int * int) * string> TOK_BVTYPE %token <(int * int) * string> TOK_INTTYPE %token <(int * int) * string> TOK_BOOLTYPE +%token <(int * int) * string> TOK_POINTERTYPE %token <(int * int) * string> TOK_BIdent %token <(int * int) * string> TOK_LocalIdent %token <(int * int) * string> TOK_GlobalIdent @@ -44,7 +45,7 @@ open Lexing %token <(int * int) * string> TOK_IntegerHex %token <(int * int) * string> TOK_IntegerDec -%start pModuleT pDecl_list pBlockIdent_list pLambdaSep pVarModifiers pVarModifiers_list pDecl pTypeT_list pTypeAssign pTypeAssign_list pProcDef pIntType pBoolType pBVType pMapType pRecordField pRecordField_list pSumCase pSumCase_list pType1 pTypeT pIntVal pBVVal pEndian pAssignment pStmt pAssignment_list pLocalVar pLocalVar_list pGlobalVar pGlobalVar_list pVar pLocalVarParen pGlobalVarParen pLocalVarParen_list pNamedCallReturn pNamedCallReturn_list pLVars pNamedCallArg pNamedCallArg_list pCallParams pJump pLVar pLVar_list pBlock_list pStmtWithAttrib pStmtWithAttrib_list pJumpWithAttrib pPhiExpr pPhiExpr_list pPhiAssign pPhiAssign_list pBlock pAttrKeyValue pAttrKeyValue_list pAttribSet pAttr_list pAttr pParams pParams_list pValue pExpr_list pExpr pExpr1 pExpr2 pLambdaDef pBinOp pUnOp pCase pCase_list pEqOp pBVUnOp pBVBinOp pBVLogicalBinOp pIntBinOp pIntLogicalBinOp pBoolBinOp pRequireTok pEnsureTok pRelyTok pGuarTok pFunSpec pVarSpec pProgSpec pFunSpec_list pProgSpec_list +%start pModuleT pDecl_list pBlockIdent_list pLambdaSep pVarModifiers pVarModifiers_list pDecl pTypeT_list pTypeAssign pTypeAssign_list pProcDef pField_list pField pIntType pBoolType pRecordType pPointerType pBVType pMapType pRecordField pRecordField_list pSumCase pSumCase_list pType1 pTypeT pIntVal pBVVal pEndian pAssignment pStmt pAssignment_list pLocalVar pLocalVar_list pGlobalVar pGlobalVar_list pVar pLocalVarParen pGlobalVarParen pLocalVarParen_list pNamedCallReturn pNamedCallReturn_list pLVars pNamedCallArg pNamedCallArg_list pCallParams pJump pLVar pLVar_list pBlock_list pStmtWithAttrib pStmtWithAttrib_list pJumpWithAttrib pPhiExpr pPhiExpr_list pPhiAssign pPhiAssign_list pBlock pAttrKeyValue pAttrKeyValue_list pAttribSet pAttr_list pAttr pParams pParams_list pValue pExpr_list pExpr pExpr1 pExpr2 pLambdaDef pBinOp pUnOp pCase pCase_list pEqOp pBVUnOp pBVBinOp pBVLogicalBinOp pIntBinOp pIntLogicalBinOp pBoolBinOp pPointerBinOp pRequireTok pEnsureTok pRelyTok pGuarTok pFunSpec pVarSpec pProgSpec pFunSpec_list pProgSpec_list %type pModuleT %type pDecl_list %type pBlockIdent_list @@ -56,8 +57,12 @@ open Lexing %type pTypeAssign %type pTypeAssign_list %type pProcDef +%type pField_list +%type pField %type pIntType %type pBoolType +%type pRecordType +%type pPointerType %type pBVType %type pMapType %type pRecordField @@ -122,6 +127,7 @@ open Lexing %type pIntBinOp %type pIntLogicalBinOp %type pBoolBinOp +%type pPointerBinOp %type pRequireTok %type pEnsureTok %type pRelyTok @@ -143,8 +149,12 @@ open Lexing %type typeAssign %type typeAssign_list %type procDef +%type field_list +%type field %type intType %type boolType +%type recordType +%type pointerType %type bVType %type mapType %type recordField @@ -209,6 +219,7 @@ open Lexing %type intBinOp %type intLogicalBinOp %type boolBinOp +%type pointerBinOp %type requireTok %type ensureTok %type relyTok @@ -222,6 +233,7 @@ open Lexing %type bVTYPE %type iNTTYPE %type bOOLTYPE +%type pOINTERTYPE %type bIdent %type localIdent %type globalIdent @@ -261,10 +273,18 @@ pTypeAssign_list : typeAssign_list TOK_EOF { $1 }; pProcDef : procDef TOK_EOF { $1 }; +pField_list : field_list TOK_EOF { $1 }; + +pField : field TOK_EOF { $1 }; + pIntType : intType TOK_EOF { $1 }; pBoolType : boolType TOK_EOF { $1 }; +pRecordType : recordType TOK_EOF { $1 }; + +pPointerType : pointerType TOK_EOF { $1 }; + pBVType : bVType TOK_EOF { $1 }; pMapType : mapType TOK_EOF { $1 }; @@ -393,6 +413,8 @@ pIntLogicalBinOp : intLogicalBinOp TOK_EOF { $1 }; pBoolBinOp : boolBinOp TOK_EOF { $1 }; +pPointerBinOp : pointerBinOp TOK_EOF { $1 }; + pRequireTok : requireTok TOK_EOF { $1 }; pEnsureTok : ensureTok TOK_EOF { $1 }; @@ -464,12 +486,26 @@ procDef : /* empty */ { ProcDef_Empty } | beginList block_list endList { ProcDef_Some ($1, $2, $3) } ; +field_list : /* empty */ { [] } + | field { (fun x -> [x]) $1 } + | field SYMB2 field_list { (fun (x,xs) -> x::xs) ($1, $3) } + ; + +field : openParen intVal SYMB2 intVal closeParen SYMB5 typeT SYMB2 { Field1 ($1, $2, $4, $5, $7) } + ; + intType : iNTTYPE { IntType1 $1 } ; boolType : bOOLTYPE { BoolType1 $1 } ; +recordType : beginRec field_list endRec { RecordType1 ($1, $2, $3) } + ; + +pointerType : pOINTERTYPE openParen typeT SYMB2 typeT closeParen { PointerType1 ($1, $2, $3, $5, $6) } + ; + bVType : bVTYPE { BVType1 $1 } ; @@ -494,6 +530,8 @@ sumCase_list : sumCase { (fun x -> [x]) $1 } type1 : intType { TypeIntType $1 } | boolType { TypeBoolType $1 } | bVType { TypeBVType $1 } + | pointerType { TypePointerType $1 } + | recordType { TypeRecordType $1 } | openParen typeT closeParen { TypeParen ($1, $2, $3) } | localIdent { TypeSort $1 } ; @@ -690,6 +728,8 @@ expr : expr1 { $1 } | KW_forall attribSet lambdaDef { Expr_Forall ($2, $3) } | KW_exists attribSet lambdaDef { Expr_Exists ($2, $3) } | KW_fun attribSet lambdaDef { Expr_Lambda ($2, $3) } + | KW_fset openParen intVal SYMB2 expr SYMB2 expr closeParen { Expr_FSet ($2, $3, $5, $7, $8) } + | KW_facces openParen intVal SYMB2 expr closeParen { Expr_FAccess ($2, $3, $5, $6) } ; expr1 : expr2 { $1 } @@ -722,6 +762,7 @@ binOp : bVBinOp { BinOpBVBinOp $1 } | intLogicalBinOp { BinOpIntLogicalBinOp $1 } | intBinOp { BinOpIntBinOp $1 } | eqOp { BinOpEqOp $1 } + | pointerBinOp { BinOpPointerBinOp $1 } ; unOp : bVUnOp { UnOpBVUnOp $1 } @@ -797,6 +838,10 @@ boolBinOp : KW_booland { BoolBinOp_booland } | KW_boolimplies { BoolBinOp_boolimplies } ; +pointerBinOp : KW_ptradd { PointerBinOp_ptradd } + | KW_ptrsub { PointerBinOp_ptrsub } + ; + requireTok : KW_require { RequireTok_require } | KW_requires { RequireTok_requires } ; @@ -841,6 +886,7 @@ progSpec_list : progSpec { (fun x -> [x]) $1 } bVTYPE : TOK_BVTYPE { BVTYPE ($1)}; iNTTYPE : TOK_INTTYPE { INTTYPE ($1)}; bOOLTYPE : TOK_BOOLTYPE { BOOLTYPE ($1)}; +pOINTERTYPE : TOK_POINTERTYPE { POINTERTYPE ($1)}; bIdent : TOK_BIdent { BIdent ($1)}; localIdent : TOK_LocalIdent { LocalIdent ($1)}; globalIdent : TOK_GlobalIdent { GlobalIdent ($1)}; diff --git a/lib/fe/PrintBasilIR.ml b/lib/fe/PrintBasilIR.ml index 25ba97ea..0675ee47 100644 --- a/lib/fe/PrintBasilIR.ml +++ b/lib/fe/PrintBasilIR.ml @@ -1,4 +1,4 @@ -(* File generated by the BNF Converter (bnfc 2.9.6.2). *) +(* File generated by the BNF Converter (bnfc 2.9.6.1). *) (* pretty-printer *) @@ -90,6 +90,9 @@ let prtINTTYPE _ (AbsBasilIR.INTTYPE (_,i)) : doc = render i let prtBOOLTYPE _ (AbsBasilIR.BOOLTYPE (_,i)) : doc = render i +let prtPOINTERTYPE _ (AbsBasilIR.POINTERTYPE (_,i)) : doc = render i + + let prtBIdent _ (AbsBasilIR.BIdent (_,i)) : doc = render i @@ -180,6 +183,13 @@ and prtProcDef (i:int) (e : AbsBasilIR.procDef) : doc = match e with | AbsBasilIR.ProcDef_Some (beginlist, blocks, endlist) -> prPrec i 0 (concatD [prtBeginList 0 beginlist ; prtBlockListBNFC 0 blocks ; prtEndList 0 endlist]) +and prtField (i:int) (e : AbsBasilIR.field) : doc = match e with + AbsBasilIR.Field1 (openparen, intval1, intval2, closeparen, type_) -> prPrec i 0 (concatD [prtOpenParen 0 openparen ; prtIntVal 0 intval1 ; render "," ; prtIntVal 0 intval2 ; prtCloseParen 0 closeparen ; render ":" ; prtTypeT 0 type_ ; render ","]) + +and prtFieldListBNFC i es : doc = match (i, es) with + (_,[]) -> (concatD []) + | (_,[x]) -> (concatD [prtField 0 x]) + | (_,x::xs) -> (concatD [prtField 0 x ; render "," ; prtFieldListBNFC 0 xs]) and prtIntType (i:int) (e : AbsBasilIR.intType) : doc = match e with AbsBasilIR.IntType1 inttype -> prPrec i 0 (concatD [prtINTTYPE 0 inttype]) @@ -188,6 +198,14 @@ and prtBoolType (i:int) (e : AbsBasilIR.boolType) : doc = match e with AbsBasilIR.BoolType1 booltype -> prPrec i 0 (concatD [prtBOOLTYPE 0 booltype]) +and prtRecordType (i:int) (e : AbsBasilIR.recordType) : doc = match e with + AbsBasilIR.RecordType1 (beginrec, fields, endrec) -> prPrec i 0 (concatD [prtBeginRec 0 beginrec ; prtFieldListBNFC 0 fields ; prtEndRec 0 endrec]) + + +and prtPointerType (i:int) (e : AbsBasilIR.pointerType) : doc = match e with + AbsBasilIR.PointerType1 (pointertype, openparen, type_1, type_2, closeparen) -> prPrec i 0 (concatD [prtPOINTERTYPE 0 pointertype ; prtOpenParen 0 openparen ; prtTypeT 0 type_1 ; render "," ; prtTypeT 0 type_2 ; prtCloseParen 0 closeparen]) + + and prtBVType (i:int) (e : AbsBasilIR.bVType) : doc = match e with AbsBasilIR.BVType1 bvtype -> prPrec i 0 (concatD [prtBVTYPE 0 bvtype]) @@ -215,6 +233,8 @@ and prtTypeT (i:int) (e : AbsBasilIR.typeT) : doc = match e with AbsBasilIR.TypeIntType inttype -> prPrec i 1 (concatD [prtIntType 0 inttype]) | AbsBasilIR.TypeBoolType booltype -> prPrec i 1 (concatD [prtBoolType 0 booltype]) | AbsBasilIR.TypeBVType bvtype -> prPrec i 1 (concatD [prtBVType 0 bvtype]) + | AbsBasilIR.TypePointerType pointertype -> prPrec i 1 (concatD [prtPointerType 0 pointertype]) + | AbsBasilIR.TypeRecordType recordtype -> prPrec i 1 (concatD [prtRecordType 0 recordtype]) | AbsBasilIR.TypeParen (openparen, type_, closeparen) -> prPrec i 1 (concatD [prtOpenParen 0 openparen ; prtTypeT 0 type_ ; prtCloseParen 0 closeparen]) | AbsBasilIR.TypeSort localident -> prPrec i 1 (concatD [prtLocalIdent 0 localident]) | AbsBasilIR.TypeMapType maptype -> prPrec i 0 (concatD [prtMapType 0 maptype]) @@ -422,6 +442,8 @@ and prtExpr (i:int) (e : AbsBasilIR.expr) : doc = match e with | AbsBasilIR.Expr_SignExtend (openparen, intval, expr, closeparen) -> prPrec i 2 (concatD [render "sign_extend" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Extract (openparen, intval1, intval2, expr, closeparen) -> prPrec i 2 (concatD [render "extract" ; prtOpenParen 0 openparen ; prtIntVal 0 intval1 ; render "," ; prtIntVal 0 intval2 ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Concat (openparen, exprs, closeparen) -> prPrec i 2 (concatD [render "bvconcat" ; prtOpenParen 0 openparen ; prtExprListBNFC 0 exprs ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_FSet (openparen, intval, expr1, expr2, closeparen) -> prPrec i 0 (concatD [render "fset" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr1 ; render "," ; prtExpr 0 expr2 ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_FAccess (openparen, intval, expr, closeparen) -> prPrec i 0 (concatD [render "facces" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Match (expr, openparen, cases, closeparen) -> prPrec i 2 (concatD [render "match" ; prtExpr 0 expr ; render "with" ; prtOpenParen 0 openparen ; prtCaseListBNFC 0 cases ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Cases (openparen, cases, closeparen) -> prPrec i 2 (concatD [render "cases" ; prtOpenParen 0 openparen ; prtCaseListBNFC 0 cases ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Paren (openparen, expr, closeparen) -> prPrec i 2 (concatD [prtOpenParen 0 openparen ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) @@ -440,6 +462,7 @@ and prtBinOp (i:int) (e : AbsBasilIR.binOp) : doc = match e with | AbsBasilIR.BinOpIntLogicalBinOp intlogicalbinop -> prPrec i 0 (concatD [prtIntLogicalBinOp 0 intlogicalbinop]) | AbsBasilIR.BinOpIntBinOp intbinop -> prPrec i 0 (concatD [prtIntBinOp 0 intbinop]) | AbsBasilIR.BinOpEqOp eqop -> prPrec i 0 (concatD [prtEqOp 0 eqop]) + | AbsBasilIR.BinOpPointerBinOp pointerbinop -> prPrec i 0 (concatD [prtPointerBinOp 0 pointerbinop]) and prtUnOp (i:int) (e : AbsBasilIR.unOp) : doc = match e with @@ -522,6 +545,11 @@ and prtBoolBinOp (i:int) (e : AbsBasilIR.boolBinOp) : doc = match e with | AbsBasilIR.BoolBinOp_boolimplies -> prPrec i 0 (concatD [render "boolimplies"]) +and prtPointerBinOp (i:int) (e : AbsBasilIR.pointerBinOp) : doc = match e with + AbsBasilIR.PointerBinOp_ptradd -> prPrec i 0 (concatD [render "ptradd"]) + | AbsBasilIR.PointerBinOp_ptrsub -> prPrec i 0 (concatD [render "ptrsub"]) + + and prtRequireTok (i:int) (e : AbsBasilIR.requireTok) : doc = match e with AbsBasilIR.RequireTok_require -> prPrec i 0 (concatD [render "require"]) | AbsBasilIR.RequireTok_requires -> prPrec i 0 (concatD [render "requires"]) diff --git a/lib/fe/ShowBasilIR.ml b/lib/fe/ShowBasilIR.ml index d3d0cc0e..106d3af8 100644 --- a/lib/fe/ShowBasilIR.ml +++ b/lib/fe/ShowBasilIR.ml @@ -1,4 +1,4 @@ -(* File generated by the BNF Converter (bnfc 2.9.6.2). *) +(* File generated by the BNF Converter (bnfc 2.9.6.1). *) (* show functions *) @@ -41,6 +41,7 @@ let showFloat (f:float) : showable = s2s (string_of_float f) let rec showBVTYPE (AbsBasilIR.BVTYPE (_,i)) : showable = s2s "BVTYPE " >> showString i let rec showINTTYPE (AbsBasilIR.INTTYPE (_,i)) : showable = s2s "INTTYPE " >> showString i let rec showBOOLTYPE (AbsBasilIR.BOOLTYPE (_,i)) : showable = s2s "BOOLTYPE " >> showString i +let rec showPOINTERTYPE (AbsBasilIR.POINTERTYPE (_,i)) : showable = s2s "POINTERTYPE " >> showString i let rec showBIdent (AbsBasilIR.BIdent (_,i)) : showable = s2s "BIdent " >> showString i let rec showLocalIdent (AbsBasilIR.LocalIdent (_,i)) : showable = s2s "LocalIdent " >> showString i let rec showGlobalIdent (AbsBasilIR.GlobalIdent (_,i)) : showable = s2s "GlobalIdent " >> showString i @@ -93,6 +94,10 @@ and showProcDef (e : AbsBasilIR.procDef) : showable = match e with | AbsBasilIR.ProcDef_Some (beginlist, blocks, endlist) -> s2s "ProcDef_Some" >> c2s ' ' >> c2s '(' >> showBeginList beginlist >> s2s ", " >> showList showBlock blocks >> s2s ", " >> showEndList endlist >> c2s ')' +and showField (e : AbsBasilIR.field) : showable = match e with + AbsBasilIR.Field1 (openparen, intval0, intval, closeparen, type') -> s2s "Field1" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval0 >> s2s ", " >> showIntVal intval >> s2s ", " >> showCloseParen closeparen >> s2s ", " >> showTypeT type' >> c2s ')' + + and showIntType (e : AbsBasilIR.intType) : showable = match e with AbsBasilIR.IntType1 inttype -> s2s "IntType1" >> c2s ' ' >> c2s '(' >> showINTTYPE inttype >> c2s ')' @@ -101,6 +106,14 @@ and showBoolType (e : AbsBasilIR.boolType) : showable = match e with AbsBasilIR.BoolType1 booltype -> s2s "BoolType1" >> c2s ' ' >> c2s '(' >> showBOOLTYPE booltype >> c2s ')' +and showRecordType (e : AbsBasilIR.recordType) : showable = match e with + AbsBasilIR.RecordType1 (beginrec, fields, endrec) -> s2s "RecordType1" >> c2s ' ' >> c2s '(' >> showBeginRec beginrec >> s2s ", " >> showList showField fields >> s2s ", " >> showEndRec endrec >> c2s ')' + + +and showPointerType (e : AbsBasilIR.pointerType) : showable = match e with + AbsBasilIR.PointerType1 (pointertype, openparen, type'0, type', closeparen) -> s2s "PointerType1" >> c2s ' ' >> c2s '(' >> showPOINTERTYPE pointertype >> s2s ", " >> showOpenParen openparen >> s2s ", " >> showTypeT type'0 >> s2s ", " >> showTypeT type' >> s2s ", " >> showCloseParen closeparen >> c2s ')' + + and showBVType (e : AbsBasilIR.bVType) : showable = match e with AbsBasilIR.BVType1 bvtype -> s2s "BVType1" >> c2s ' ' >> c2s '(' >> showBVTYPE bvtype >> c2s ')' @@ -122,6 +135,8 @@ and showTypeT (e : AbsBasilIR.typeT) : showable = match e with AbsBasilIR.TypeIntType inttype -> s2s "TypeIntType" >> c2s ' ' >> c2s '(' >> showIntType inttype >> c2s ')' | AbsBasilIR.TypeBoolType booltype -> s2s "TypeBoolType" >> c2s ' ' >> c2s '(' >> showBoolType booltype >> c2s ')' | AbsBasilIR.TypeBVType bvtype -> s2s "TypeBVType" >> c2s ' ' >> c2s '(' >> showBVType bvtype >> c2s ')' + | AbsBasilIR.TypePointerType pointertype -> s2s "TypePointerType" >> c2s ' ' >> c2s '(' >> showPointerType pointertype >> c2s ')' + | AbsBasilIR.TypeRecordType recordtype -> s2s "TypeRecordType" >> c2s ' ' >> c2s '(' >> showRecordType recordtype >> c2s ')' | AbsBasilIR.TypeParen (openparen, type', closeparen) -> s2s "TypeParen" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showTypeT type' >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.TypeSort localident -> s2s "TypeSort" >> c2s ' ' >> c2s '(' >> showLocalIdent localident >> c2s ')' | AbsBasilIR.TypeMapType maptype -> s2s "TypeMapType" >> c2s ' ' >> c2s '(' >> showMapType maptype >> c2s ')' @@ -285,6 +300,8 @@ and showExpr (e : AbsBasilIR.expr) : showable = match e with | AbsBasilIR.Expr_SignExtend (openparen, intval, expr, closeparen) -> s2s "Expr_SignExtend" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval >> s2s ", " >> showExpr expr >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.Expr_Extract (openparen, intval0, intval, expr, closeparen) -> s2s "Expr_Extract" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval0 >> s2s ", " >> showIntVal intval >> s2s ", " >> showExpr expr >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.Expr_Concat (openparen, exprs, closeparen) -> s2s "Expr_Concat" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showList showExpr exprs >> s2s ", " >> showCloseParen closeparen >> c2s ')' + | AbsBasilIR.Expr_FSet (openparen, intval, expr0, expr, closeparen) -> s2s "Expr_FSet" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval >> s2s ", " >> showExpr expr0 >> s2s ", " >> showExpr expr >> s2s ", " >> showCloseParen closeparen >> c2s ')' + | AbsBasilIR.Expr_FAccess (openparen, intval, expr, closeparen) -> s2s "Expr_FAccess" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval >> s2s ", " >> showExpr expr >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.Expr_Match (expr, openparen, cases, closeparen) -> s2s "Expr_Match" >> c2s ' ' >> c2s '(' >> showExpr expr >> s2s ", " >> showOpenParen openparen >> s2s ", " >> showList showCase cases >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.Expr_Cases (openparen, cases, closeparen) -> s2s "Expr_Cases" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showList showCase cases >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.Expr_Paren (openparen, expr, closeparen) -> s2s "Expr_Paren" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showExpr expr >> s2s ", " >> showCloseParen closeparen >> c2s ')' @@ -300,6 +317,7 @@ and showBinOp (e : AbsBasilIR.binOp) : showable = match e with | AbsBasilIR.BinOpIntLogicalBinOp intlogicalbinop -> s2s "BinOpIntLogicalBinOp" >> c2s ' ' >> c2s '(' >> showIntLogicalBinOp intlogicalbinop >> c2s ')' | AbsBasilIR.BinOpIntBinOp intbinop -> s2s "BinOpIntBinOp" >> c2s ' ' >> c2s '(' >> showIntBinOp intbinop >> c2s ')' | AbsBasilIR.BinOpEqOp eqop -> s2s "BinOpEqOp" >> c2s ' ' >> c2s '(' >> showEqOp eqop >> c2s ')' + | AbsBasilIR.BinOpPointerBinOp pointerbinop -> s2s "BinOpPointerBinOp" >> c2s ' ' >> c2s '(' >> showPointerBinOp pointerbinop >> c2s ')' and showUnOp (e : AbsBasilIR.unOp) : showable = match e with @@ -379,6 +397,11 @@ and showBoolBinOp (e : AbsBasilIR.boolBinOp) : showable = match e with | AbsBasilIR.BoolBinOp_boolimplies -> s2s "BoolBinOp_boolimplies" +and showPointerBinOp (e : AbsBasilIR.pointerBinOp) : showable = match e with + AbsBasilIR.PointerBinOp_ptradd -> s2s "PointerBinOp_ptradd" + | AbsBasilIR.PointerBinOp_ptrsub -> s2s "PointerBinOp_ptrsub" + + and showRequireTok (e : AbsBasilIR.requireTok) : showable = match e with AbsBasilIR.RequireTok_require -> s2s "RequireTok_require" | AbsBasilIR.RequireTok_requires -> s2s "RequireTok_requires" diff --git a/lib/fe/SkelBasilIR.ml b/lib/fe/SkelBasilIR.ml index ddc2b377..3a6af581 100644 --- a/lib/fe/SkelBasilIR.ml +++ b/lib/fe/SkelBasilIR.ml @@ -1,4 +1,4 @@ -(* File generated by the BNF Converter (bnfc 2.9.6.2). *) +(* File generated by the BNF Converter (bnfc 2.9.6.1). *) module SkelBasilIR = struct @@ -20,6 +20,10 @@ and transBOOLTYPE (x : bOOLTYPE) : result = match x with BOOLTYPE string -> failure x +and transPOINTERTYPE (x : pOINTERTYPE) : result = match x with + POINTERTYPE string -> failure x + + and transBIdent (x : bIdent) : result = match x with BIdent string -> failure x @@ -113,6 +117,10 @@ and transProcDef (x : procDef) : result = match x with | ProcDef_Some (beginlist, blocks, endlist) -> failure x +and transField (x : field) : result = match x with + Field1 (openparen, intval0, intval, closeparen, type') -> failure x + + and transIntType (x : intType) : result = match x with IntType1 inttype -> failure x @@ -121,6 +129,14 @@ and transBoolType (x : boolType) : result = match x with BoolType1 booltype -> failure x +and transRecordType (x : recordType) : result = match x with + RecordType1 (beginrec, fields, endrec) -> failure x + + +and transPointerType (x : pointerType) : result = match x with + PointerType1 (pointertype, openparen, type'0, type', closeparen) -> failure x + + and transBVType (x : bVType) : result = match x with BVType1 bvtype -> failure x @@ -142,6 +158,8 @@ and transType (x : typeT) : result = match x with TypeIntType inttype -> failure x | TypeBoolType booltype -> failure x | TypeBVType bvtype -> failure x + | TypePointerType pointertype -> failure x + | TypeRecordType recordtype -> failure x | TypeParen (openparen, type', closeparen) -> failure x | TypeSort localident -> failure x | TypeMapType maptype -> failure x @@ -305,6 +323,8 @@ and transExpr (x : expr) : result = match x with | Expr_SignExtend (openparen, intval, expr, closeparen) -> failure x | Expr_Extract (openparen, intval0, intval, expr, closeparen) -> failure x | Expr_Concat (openparen, exprs, closeparen) -> failure x + | Expr_FSet (openparen, intval, expr0, expr, closeparen) -> failure x + | Expr_FAccess (openparen, intval, expr, closeparen) -> failure x | Expr_Match (expr, openparen, cases, closeparen) -> failure x | Expr_Cases (openparen, cases, closeparen) -> failure x | Expr_Paren (openparen, expr, closeparen) -> failure x @@ -320,6 +340,7 @@ and transBinOp (x : binOp) : result = match x with | BinOpIntLogicalBinOp intlogicalbinop -> failure x | BinOpIntBinOp intbinop -> failure x | BinOpEqOp eqop -> failure x + | BinOpPointerBinOp pointerbinop -> failure x and transUnOp (x : unOp) : result = match x with @@ -399,6 +420,11 @@ and transBoolBinOp (x : boolBinOp) : result = match x with | BoolBinOp_boolimplies -> failure x +and transPointerBinOp (x : pointerBinOp) : result = match x with + PointerBinOp_ptradd -> failure x + | PointerBinOp_ptrsub -> failure x + + and transRequireTok (x : requireTok) : result = match x with RequireTok_require -> failure x | RequireTok_requires -> failure x diff --git a/lib/fe/TestBasilIR.ml b/lib/fe/TestBasilIR.ml index e3da9490..db9dbc6e 100644 --- a/lib/fe/TestBasilIR.ml +++ b/lib/fe/TestBasilIR.ml @@ -1,4 +1,4 @@ -(* File generated by the BNF Converter (bnfc 2.9.6.2). *) +(* File generated by the BNF Converter (bnfc 2.9.6.1). *) open Lexing diff --git a/lib/lang/expr.ml b/lib/lang/expr.ml index 3ba9b12c..7db644e1 100644 --- a/lib/lang/expr.ml +++ b/lib/lang/expr.ml @@ -544,6 +544,12 @@ module BasilExpr = struct let zero_extend ?attrib ~n_prefix_bits (e : t) : t = unexp ?attrib ~op:(`ZeroExtend n_prefix_bits) e + let fset ?attrib ~(offset : Z.t) (record : t) (e : t) : t = + binexp ?attrib ~op:(`FSET offset) record e + + let faccess ?attrib ~(offset : Z.t) (record : t) : t = + unexp ?attrib ~op:(`FACCESS offset) record + let sign_extend ?attrib ~n_prefix_bits (e : t) : t = unexp ?attrib ~op:(`SignExtend n_prefix_bits) e diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index d691cd64..ac81c002 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -101,7 +101,7 @@ module SMTLib2 = struct LSet.singleton BV ) | Record fields -> (* Each field in record has three atoms? Offset, size, type *) - let of_field ({ offset; size; t } : Types.field) = + let of_field ({ offset; size; t } : Types.field2) = let t_sexp, t_set = of_typ t in (list [ atom @@ Z.to_string offset; of_int size; t_sexp ], t_set) in diff --git a/lib/lang/ops.ml b/lib/lang/ops.ml index d26bea6e..d1e49f6e 100644 --- a/lib/lang/ops.ml +++ b/lib/lang/ops.ml @@ -195,15 +195,23 @@ module IntOps = struct end module RecordOps = struct - type unary = [ `FACCESS of Z.t ] [@@deriving eq, ord] - type binary = [ `FSET of Z.t ] [@@deriving eq, ord] + type unary = + ([ `FACCESS of Z.t ] + [@printer + fun fmt m -> match m with `FACCESS offset -> Z.pp_print fmt offset]) + [@@deriving show { with_path = false }, eq, ord] + + type binary = + ([ `FSET of Z.t ] + [@printer fun fmt m -> match m with `FSET offset -> Z.pp_print fmt offset]) + [@@deriving show { with_path = false }, eq, ord] - let show_unary = function + let to_string_unary = function | `FACCESS offset -> "`FACCESS " ^ Z.to_string offset let show_binary = function `FSET offset -> "`FSET " ^ Z.to_string offset - let eval_unary (u : unary) = failwith "boom" - let eval_unary (u : binary) = failwith "boom" + let eval_unary (u : unary) = failwith "TODO" + let eval_unary (u : binary) = failwith "TODO" let show = function | #unary as u -> show_unary u @@ -214,7 +222,7 @@ module PointerOps = struct type binary = [ `PTRADD | `PTRSUB ] [@@deriving show { with_path = false }, eq, ord] - let eval_binary (u : binary) = failwith "boom" + let eval_binary (u : binary) = failwith "TODO" let show = function #binary as u -> show_binary u end @@ -244,11 +252,21 @@ module AllOps = struct type const = [ IntOps.const | BVOps.const | LogicalOps.const ] [@@deriving show { with_path = false }, eq, ord] - type unary = [ IntOps.unary | BVOps.unary | Spec.unary | LogicalOps.unary ] + type unary = + [ IntOps.unary + | BVOps.unary + | Spec.unary + | LogicalOps.unary + | RecordOps.unary ] [@@deriving show { with_path = false }, eq, ord] type binary = - [ IntOps.binary | BVOps.binary | LogicalOps.binary | Spec.binary ] + [ IntOps.binary + | BVOps.binary + | LogicalOps.binary + | Spec.binary + | RecordOps.binary + | PointerOps.binary ] [@@deriving show { with_path = false }, eq, ord] type intrin = [ BVOps.intrin | LogicalOps.intrin | Spec.intrin ] @@ -280,6 +298,10 @@ module AllOps = struct match a with | Bitvector s -> return @@ Bitvector (sz + s) | o -> Conflict [ (o, " ( + match get_field offset a with + | None -> failwith @@ "No field at offset: " ^ Z.to_string offset + | Some ({ t; _ } : field2) -> return t) | `Forall -> return Boolean | `BVNEG -> return a | `INTNEG -> return Integer @@ -312,6 +334,8 @@ module AllOps = struct | `BVAND | `BVOR | `BVADD | `BVMUL | `BVUDIV | `BVUREM | `BVSHL | `BVLSHR | `BVNAND | `BVXOR | `BVSUB | `BVSDIV | `BVSREM | `BVSMOD | `BVASHR -> return l + | `FSET _ -> return r + | `PTRADD | `PTRSUB -> return l | `MapAccess -> let m, r = Types.uncurry l in return r @@ -370,6 +394,10 @@ module AllOps = struct | `Exists -> "exists" | `SignExtend n -> Printf.sprintf "sign_extend_%d" n | `ZeroExtend n -> Printf.sprintf "zero_extend_%d" n + | `FSET offset -> Printf.sprintf "fset_%s" @@ Z.to_string offset + | `FACCESS offset -> Printf.sprintf "faccess_%s" @@ Z.to_string offset + | `PTRADD -> "ptradd" + | `PTRSUB -> "ptrsub" | `EQ -> "eq" | `INTADD -> "intadd" | `BVNAND -> "bvnand" diff --git a/lib/loadir.ml b/lib/loadir.ml index 438c18bb..48d468a6 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -436,6 +436,8 @@ module BasilASTLoader = struct match field with | RecordField1 (id, ty) -> Types.mk_field (unsafe_unsigil (`Local id)) (trans_type ty) + and transRECORDTYPE (fields : field list) = failwith "TODO" + and transPOINTERTYPE (l : typeT) (u : typeT) = failwith "TODO" and trans_type (x : typeT) : Types.t = match x with @@ -445,6 +447,8 @@ module BasilASTLoader = struct | TypeBVType (BVType1 bvtype) -> transBVTYPE bvtype | TypeParen (_, typeT, _) -> trans_type typeT | TypeSort t -> Types.Sort (unsafe_unsigil (`Local t), []) + | TypeRecordType (RecordType1 (_, fields, _)) -> transRECORDTYPE fields + | TypePointerType (PointerType1 (_, _, l, u, _)) -> transPOINTERTYPE l u and transIntVal (x : intVal) : PrimInt.t = match x with @@ -965,6 +969,12 @@ module BasilASTLoader = struct ~hi_excl:(transIntVal ival0 |> Z.to_int) ~lo_incl:(transIntVal intval |> Z.to_int) (trans_expr expr) + | Expr_FAccess (o, offset, record, c) -> + BasilExpr.faccess ~attrib:(expr_range_attr o c) + ~offset:(transIntVal offset) (trans_expr record) + | Expr_FSet (o, offset, record, expr, c) -> + BasilExpr.fset ~attrib:(expr_range_attr o c) + ~offset:(transIntVal offset) (trans_expr record) (trans_expr expr) | Expr_LoadLe (o, intval, a1, a2, c) -> BasilExpr.load ~attrib:(expr_range_attr o c) ~bits:(Z.to_int @@ transIntVal intval) @@ -1014,6 +1024,7 @@ module BasilASTLoader = struct transIntLogicalBinOp intlogicalbinop | BinOpIntBinOp intbinop -> transIntBinOp intbinop | BinOpEqOp equop -> transEqOp equop + | BinOpPointerBinOp pointerBinOp -> transPointerBinOp pointerBinOp and transUnOp (x : BasilIR.AbsBasilIR.unOp) = match x with @@ -1069,6 +1080,8 @@ module BasilASTLoader = struct | IntBinOp_intdiv -> `INTDIV | IntBinOp_intmod -> `INTMOD + and transPointerBinOp (x : pointerBinOp) = failwith "TODO" + and transIntLogicalBinOp (x : intLogicalBinOp) = match x with | IntLogicalBinOp_intlt -> `INTLT diff --git a/lib/util/types.ml b/lib/util/types.ml index 12b243c4..1736a0d8 100644 --- a/lib/util/types.ml +++ b/lib/util/types.ml @@ -33,7 +33,7 @@ type t = | Nothing | Map of t * t | Sort of string * variant list - | Record of field list + | Record of field2 list | Pointer of t * t and variant = { variant : string; fields : field list } @@ -75,6 +75,12 @@ let mk_adt name (variants : (string * field list) list) = Sort (name, variants |> List.map (fun (variant, fields) -> { variant; fields })) +let get_field offset1 record : field2 option = + match record with + | Record fields -> + List.find_opt (fun { offset; _ } -> Z.equal offset offset1) fields + | _ -> failwith "Not record type" + (* Nothing < Unit < {boolean, integer, bitvector, record, pointer} < Top *) @@ -88,27 +94,6 @@ let rec compare_partial (a : t) (b : t) = | _, Nothing -> Some 1 | Unit, _ -> Some (-1) | _, Unit -> Some 1 - | Boolean, Integer -> None - | Integer, Boolean -> None - | Integer, Record _ -> None - | Integer, Pointer _ -> None - | Boolean, Bitvector _ -> None - | Boolean, Pointer _ -> None - | Boolean, Record _ -> None - | Bitvector _, Boolean -> None - | Boolean, Boolean -> None - | Integer, Bitvector _ -> None - | Bitvector _, Integer -> None - | Bitvector _, Record _ -> None - | Bitvector _, Pointer _ -> None - | Record _, Bitvector _ -> None - | Record _, Integer -> None - | Record _, Boolean -> None - | Record _, Pointer _ -> None - | Pointer _, Bitvector _ -> None - | Pointer _, Integer -> None - | Pointer _, Boolean -> None - | Pointer _, Record _ -> None | Pointer (l, u), Pointer (l2, u2) -> ( compare_partial l l2 |> function Some 0 -> compare_partial u u2 | o -> o) | Record fields, Record fields2 -> From 2f15e79fcd69a2fb98fcbb7ce1d31ee3ee7a3317 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Thu, 5 Mar 2026 13:51:44 +1000 Subject: [PATCH 03/29] remove size field from records --- lib/fe/AbsBasilIR.ml | 2 +- lib/fe/BasilIR.cf | 2 +- lib/fe/ParBasilIR.mly | 2 +- lib/fe/PrintBasilIR.ml | 2 +- lib/fe/ShowBasilIR.ml | 2 +- lib/fe/SkelBasilIR.ml | 2 +- lib/lang/expr_smt.ml | 4 ++-- lib/loadir.ml | 12 ++++++++++-- lib/util/types.ml | 15 +++++---------- 9 files changed, 23 insertions(+), 20 deletions(-) diff --git a/lib/fe/AbsBasilIR.ml b/lib/fe/AbsBasilIR.ml index 7fa36e55..a649d2f4 100644 --- a/lib/fe/AbsBasilIR.ml +++ b/lib/fe/AbsBasilIR.ml @@ -50,7 +50,7 @@ and procDef = | ProcDef_Some of beginList * block list * endList and field = - Field1 of openParen * intVal * intVal * closeParen * typeT + Field1 of intVal * typeT and intType = IntType1 of iNTTYPE diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index fca3d637..7ce02b6f 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -73,7 +73,7 @@ ProcDef_Empty . ProcDef ::= ; ProcDef_Some . ProcDef ::= BeginList [Block] EndList ; separator Field "," ; -Field1 . Field ::= OpenParen IntVal "," IntVal CloseParen ":" Type "," ; +Field1 . Field ::= IntVal ":" Type ; IntType1 . IntType ::= INTTYPE ; BoolType1. BoolType ::= BOOLTYPE ; diff --git a/lib/fe/ParBasilIR.mly b/lib/fe/ParBasilIR.mly index bbf47ab7..dbd76824 100644 --- a/lib/fe/ParBasilIR.mly +++ b/lib/fe/ParBasilIR.mly @@ -491,7 +491,7 @@ field_list : /* empty */ { [] } | field SYMB2 field_list { (fun (x,xs) -> x::xs) ($1, $3) } ; -field : openParen intVal SYMB2 intVal closeParen SYMB5 typeT SYMB2 { Field1 ($1, $2, $4, $5, $7) } +field : intVal SYMB5 typeT { Field1 ($1, $3) } ; intType : iNTTYPE { IntType1 $1 } diff --git a/lib/fe/PrintBasilIR.ml b/lib/fe/PrintBasilIR.ml index 0675ee47..cd2d5069 100644 --- a/lib/fe/PrintBasilIR.ml +++ b/lib/fe/PrintBasilIR.ml @@ -184,7 +184,7 @@ and prtProcDef (i:int) (e : AbsBasilIR.procDef) : doc = match e with and prtField (i:int) (e : AbsBasilIR.field) : doc = match e with - AbsBasilIR.Field1 (openparen, intval1, intval2, closeparen, type_) -> prPrec i 0 (concatD [prtOpenParen 0 openparen ; prtIntVal 0 intval1 ; render "," ; prtIntVal 0 intval2 ; prtCloseParen 0 closeparen ; render ":" ; prtTypeT 0 type_ ; render ","]) + AbsBasilIR.Field1 (intval, type_) -> prPrec i 0 (concatD [prtIntVal 0 intval ; render ":" ; prtTypeT 0 type_]) and prtFieldListBNFC i es : doc = match (i, es) with (_,[]) -> (concatD []) diff --git a/lib/fe/ShowBasilIR.ml b/lib/fe/ShowBasilIR.ml index 106d3af8..21741809 100644 --- a/lib/fe/ShowBasilIR.ml +++ b/lib/fe/ShowBasilIR.ml @@ -95,7 +95,7 @@ and showProcDef (e : AbsBasilIR.procDef) : showable = match e with and showField (e : AbsBasilIR.field) : showable = match e with - AbsBasilIR.Field1 (openparen, intval0, intval, closeparen, type') -> s2s "Field1" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval0 >> s2s ", " >> showIntVal intval >> s2s ", " >> showCloseParen closeparen >> s2s ", " >> showTypeT type' >> c2s ')' + AbsBasilIR.Field1 (intval, type') -> s2s "Field1" >> c2s ' ' >> c2s '(' >> showIntVal intval >> s2s ", " >> showTypeT type' >> c2s ')' and showIntType (e : AbsBasilIR.intType) : showable = match e with diff --git a/lib/fe/SkelBasilIR.ml b/lib/fe/SkelBasilIR.ml index 3a6af581..106b6c56 100644 --- a/lib/fe/SkelBasilIR.ml +++ b/lib/fe/SkelBasilIR.ml @@ -118,7 +118,7 @@ and transProcDef (x : procDef) : result = match x with and transField (x : field) : result = match x with - Field1 (openparen, intval0, intval, closeparen, type') -> failure x + Field1 (intval, type') -> failure x and transIntType (x : intType) : result = match x with diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index ac81c002..0a8282f4 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -101,9 +101,9 @@ module SMTLib2 = struct LSet.singleton BV ) | Record fields -> (* Each field in record has three atoms? Offset, size, type *) - let of_field ({ offset; size; t } : Types.field2) = + let of_field ({ offset; t } : Types.field2) = let t_sexp, t_set = of_typ t in - (list [ atom @@ Z.to_string offset; of_int size; t_sexp ], t_set) + (list [ atom @@ Z.to_string offset; t_sexp ], t_set) in (* The fold keeps track of the set and the map makes it a sexp list *) let lset, sexp = diff --git a/lib/loadir.ml b/lib/loadir.ml index 48d468a6..952a2806 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -436,8 +436,16 @@ module BasilASTLoader = struct match field with | RecordField1 (id, ty) -> Types.mk_field (unsafe_unsigil (`Local id)) (trans_type ty) - and transRECORDTYPE (fields : field list) = failwith "TODO" - and transPOINTERTYPE (l : typeT) (u : typeT) = failwith "TODO" + and transRECORDTYPE (fields : field list) = + Types.Record + (List.map + (function + | Field1 (offset, t) -> + ({ offset = transIntVal offset; t = trans_type t } : Types.field2)) + fields) + + and transPOINTERTYPE (l : typeT) (u : typeT) = + Types.Pointer (trans_type l, trans_type u) and trans_type (x : typeT) : Types.t = match x with diff --git a/lib/util/types.ml b/lib/util/types.ml index 1736a0d8..97d2b364 100644 --- a/lib/util/types.ml +++ b/lib/util/types.ml @@ -39,7 +39,7 @@ type t = and variant = { variant : string; fields : field list } and field = { field : string; typ : t } [@@deriving eq, ord] -and field2 = { offset : Z.t; size : int; t : t } +and field2 = { offset : Z.t; t : t } let bv i = Bitvector i let int = Integer @@ -109,11 +109,8 @@ let rec compare_partial (a : t) (b : t) = compare_partial k k2 |> function Some 0 -> compare_partial v v2 | o -> o) | _, _ -> None -and field_equal_partial { offset; size; t } - { offset = offset1; size = size1; t = t1 } = - if Z.compare offset1 offset <> 0 then - if Int.compare size size1 <> 0 then compare_partial t t1 else Some 0 - else Some 0 +and field_equal_partial { offset; t } { offset = offset1; t = t1 } = + if Z.compare offset1 offset <> 0 then compare_partial t t1 else Some 0 let leq a b = compare_partial a b |> function Some a when a <= 0 -> true | _ -> false @@ -138,10 +135,8 @@ let rec to_string = function | Pointer (l, u) -> Printf.sprintf "ptr(%s, %s)" (to_string l) (to_string u) | Record fields -> List.fold_left - (fun acc { offset; size; t } -> - acc - ^ Printf.sprintf "(%s, %d) : %s" (Z.to_string offset) size - (to_string t)) + (fun acc { offset; t } -> + acc ^ Printf.sprintf "%s : %s," (Z.to_string offset) (to_string t)) "{" fields ^ "}" | Map ((Map _ as a), (Map _ as b)) -> From 09cb033702ce9c1cf4eed5b16545603b1ca6d919 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Thu, 5 Mar 2026 15:59:39 +1000 Subject: [PATCH 04/29] types added and analysis fixed --- lib/analysis/defuse_bool.ml | 19 ++++++++++++++++- lib/analysis/wrapped_intervals.ml | 8 ++++--- lib/fe/AbsBasilIR.ml | 5 +++++ lib/fe/BasilIR.cf | 5 +++++ lib/fe/LexBasilIR.mll | 4 ++-- lib/fe/ParBasilIR.mly | 22 +++++++++++++++++-- lib/fe/PrintBasilIR.ml | 9 ++++++++ lib/fe/ShowBasilIR.ml | 6 ++++++ lib/fe/SkelBasilIR.ml | 6 ++++++ lib/lang/attrib.ml | 4 ++++ lib/lang/expr_eval.ml | 17 +++++++++++++++ lib/lang/expr_smt.ml | 5 ++++- lib/lang/interp.ml | 7 +++++++ lib/lang/ops.ml | 20 +++++++++++++----- lib/loadir.ml | 9 ++++++++ lib/transforms/type_check.ml | 35 +++++++++++++++++++++++++++++-- lib/util/common.ml | 1 + lib/util/dune | 1 + lib/util/record.ml | 11 ++++++++++ lib/util/types.ml | 10 ++++++--- 20 files changed, 185 insertions(+), 19 deletions(-) create mode 100644 lib/util/record.ml diff --git a/lib/analysis/defuse_bool.ml b/lib/analysis/defuse_bool.ml index 3f9cc038..83394985 100644 --- a/lib/analysis/defuse_bool.ml +++ b/lib/analysis/defuse_bool.ml @@ -40,10 +40,17 @@ module IsZeroValueAbstraction = struct | `Bool true -> NonZero | `Bool false -> Zero | `Integer i -> if Z.equal Z.zero i then Zero else NonZero - | `Bitvector i -> + | `Bitvector i | `Pointer i -> if Bitvec.size i = 0 then Top else if Z.equal Z.zero (Bitvec.value i) then Zero else NonZero + | `Record fields -> + List.fold_left + (fun acc ({ value = i; _ } : Record.field) -> + if Bitvec.size i = 0 then Top + else if Z.equal Z.zero (Bitvec.value i) then join acc Zero + else join acc NonZero) + Zero fields let eval_unop (op : Lang.Ops.AllOps.unary) a = match op with @@ -58,13 +65,19 @@ module IsZeroValueAbstraction = struct | `Old -> Top | `Exists -> Top | `Forall | `Lambda | `Gamma | `Classification -> Top + (* NOTE: More effort would be needed to be able to say is this one field zero or not *) + | `FACCESS offset -> ( match a with Zero -> Zero | _ -> Top) let eval_binop (op : Lang.Ops.AllOps.binary) a b = match (op, a, b) with | `BVSREM, _, _ -> Top | `BVSDIV, _, _ -> Top | `BVADD, Zero, Zero -> Zero + | `PTRADD, Zero, Zero -> Zero + | `PTRSUB, Zero, Zero -> Zero | `BVADD, _, _ -> Top + | `PTRADD, _, _ -> Top + | `PTRSUB, _, _ -> Top | `NEQ, Zero, Zero -> Zero | `NEQ, _, _ -> Top | `BVASHR, _, _ -> Top @@ -101,6 +114,10 @@ module IsZeroValueAbstraction = struct | `INTSUB, _, _ -> Top | `BVSLT, Zero, Zero -> Zero | `BVSLT, _, _ -> Top + | `FSET _, Zero, Zero -> Zero + | `FSET _, NonZero, NonZero -> NonZero + (* Larger refactor would be needed to reason about individual fields *) + | `FSET _, _, _ -> Top | #Lang.Ops.Spec.binary, _, _ -> Top let eval_intrin (op : Lang.Ops.AllOps.intrin) (args : t list) = diff --git a/lib/analysis/wrapped_intervals.ml b/lib/analysis/wrapped_intervals.ml index f35a72f6..6d6d18c1 100644 --- a/lib/analysis/wrapped_intervals.ml +++ b/lib/analysis/wrapped_intervals.ml @@ -697,7 +697,9 @@ module WrappedIntervalsValueAbstraction = struct match op with | `Bool _ -> top | `Integer _ -> top - | `Bitvector bv -> if size bv = 0 then top else interval bv bv + | `Bitvector bv | `Pointer bv -> if size bv = 0 then top else interval bv bv + (* NOTE: This kind of thing happens frequently, should I go through all of the fields and make a intervals out of those bvs?*) + | `Record fields -> top let eval_unop (op : Lang.Ops.AllOps.unary) (a, t) rt = match t with @@ -715,8 +717,8 @@ module WrappedIntervalsValueAbstraction = struct match (ta, ta) with | Types.Bitvector width, Types.Bitvector w2 when width = w2 -> ( match op with - | `BVADD -> add ~width a b - | `BVSUB -> sub ~width a b + | `BVADD | `PTRADD -> add ~width a b + | `BVSUB | `PTRSUB -> sub ~width a b | `BVMUL -> mul ~width a b | `BVUDIV -> udiv ~width a b | `BVSDIV -> sdiv ~width a b diff --git a/lib/fe/AbsBasilIR.ml b/lib/fe/AbsBasilIR.ml index a649d2f4..229a0bfc 100644 --- a/lib/fe/AbsBasilIR.ml +++ b/lib/fe/AbsBasilIR.ml @@ -94,6 +94,9 @@ and intVal = and bVVal = BVVal1 of intVal * bVType +and fieldVal = + FieldVal1 of intVal * bVVal + and endian = Endian_Little | Endian_Big @@ -198,6 +201,8 @@ and params = and value = Value_BV of bVVal | Value_Int of intVal + | Value_Record of openParen * fieldVal list * closeParen + | Value_Pointer of bVVal | Value_True | Value_False diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index 7ce02b6f..8bfccf8e 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -107,6 +107,9 @@ IntVal_Dec . IntVal ::= IntegerDec ; rules BVVal ::= IntVal ":" BVType ; +separator FieldVal "f" ; +rules FieldVal ::= IntVal ":" BVVal ; + Endian_Little . Endian ::= "le" ; Endian_Big . Endian ::= "be" ; @@ -222,6 +225,8 @@ separator Params "," ; Value_BV . Value ::= BVVal; Value_Int . Value ::= IntVal; +Value_Record . Value ::= OpenParen [FieldVal] CloseParen; +Value_Pointer . Value ::= "ptr" BVVal ; Value_True . Value ::= "true" ; Value_False . Value ::= "false" ; diff --git a/lib/fe/LexBasilIR.mll b/lib/fe/LexBasilIR.mll index 20259755..2ae387ff 100644 --- a/lib/fe/LexBasilIR.mll +++ b/lib/fe/LexBasilIR.mll @@ -11,9 +11,9 @@ let symbol_table = Hashtbl.create 10 let _ = List.iter (fun (kwd, tok) -> Hashtbl.add symbol_table kwd tok) [(";", SYMB1);(",", SYMB2);("->", SYMB3);("::", SYMB4);(":", SYMB5);("=", SYMB6);("|", SYMB7);(":=", SYMB8);("mem:=", SYMB9);("_", SYMB10)] -let resword_table = Hashtbl.create 105 +let resword_table = Hashtbl.create 107 let _ = List.iter (fun (kwd, tok) -> Hashtbl.add resword_table kwd tok) - [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("of", KW_of);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("old", KW_old);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("bvconcat", KW_bvconcat);("fset", KW_fset);("facces", KW_facces);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvmul", KW_bvmul);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxor", KW_bvxor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("boolimplies", KW_boolimplies);("ptradd", KW_ptradd);("ptrsub", KW_ptrsub);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] + [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("of", KW_of);("f", KW_f);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("ptr", KW_ptr);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("old", KW_old);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("bvconcat", KW_bvconcat);("fset", KW_fset);("facces", KW_facces);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvmul", KW_bvmul);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxor", KW_bvxor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("boolimplies", KW_boolimplies);("ptradd", KW_ptradd);("ptrsub", KW_ptrsub);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] let unescapeInitTail (s:string) : string = let rec unesc s = match s with diff --git a/lib/fe/ParBasilIR.mly b/lib/fe/ParBasilIR.mly index dbd76824..e034eaa2 100644 --- a/lib/fe/ParBasilIR.mly +++ b/lib/fe/ParBasilIR.mly @@ -7,7 +7,7 @@ open AbsBasilIR open Lexing %} -%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_of KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_true KW_false KW_forall KW_exists KW_fun KW_old KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_bvconcat KW_fset KW_facces KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvand KW_bvor KW_bvadd KW_bvmul KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_boolimplies KW_ptradd KW_ptrsub KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant +%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_of KW_f KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_ptr KW_true KW_false KW_forall KW_exists KW_fun KW_old KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_bvconcat KW_fset KW_facces KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvand KW_bvor KW_bvadd KW_bvmul KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_boolimplies KW_ptradd KW_ptrsub KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant %token SYMB1 /* ; */ %token SYMB2 /* , */ @@ -45,7 +45,7 @@ open Lexing %token <(int * int) * string> TOK_IntegerHex %token <(int * int) * string> TOK_IntegerDec -%start pModuleT pDecl_list pBlockIdent_list pLambdaSep pVarModifiers pVarModifiers_list pDecl pTypeT_list pTypeAssign pTypeAssign_list pProcDef pField_list pField pIntType pBoolType pRecordType pPointerType pBVType pMapType pRecordField pRecordField_list pSumCase pSumCase_list pType1 pTypeT pIntVal pBVVal pEndian pAssignment pStmt pAssignment_list pLocalVar pLocalVar_list pGlobalVar pGlobalVar_list pVar pLocalVarParen pGlobalVarParen pLocalVarParen_list pNamedCallReturn pNamedCallReturn_list pLVars pNamedCallArg pNamedCallArg_list pCallParams pJump pLVar pLVar_list pBlock_list pStmtWithAttrib pStmtWithAttrib_list pJumpWithAttrib pPhiExpr pPhiExpr_list pPhiAssign pPhiAssign_list pBlock pAttrKeyValue pAttrKeyValue_list pAttribSet pAttr_list pAttr pParams pParams_list pValue pExpr_list pExpr pExpr1 pExpr2 pLambdaDef pBinOp pUnOp pCase pCase_list pEqOp pBVUnOp pBVBinOp pBVLogicalBinOp pIntBinOp pIntLogicalBinOp pBoolBinOp pPointerBinOp pRequireTok pEnsureTok pRelyTok pGuarTok pFunSpec pVarSpec pProgSpec pFunSpec_list pProgSpec_list +%start pModuleT pDecl_list pBlockIdent_list pLambdaSep pVarModifiers pVarModifiers_list pDecl pTypeT_list pTypeAssign pTypeAssign_list pProcDef pField_list pField pIntType pBoolType pRecordType pPointerType pBVType pMapType pRecordField pRecordField_list pSumCase pSumCase_list pType1 pTypeT pIntVal pBVVal pFieldVal_list pFieldVal pEndian pAssignment pStmt pAssignment_list pLocalVar pLocalVar_list pGlobalVar pGlobalVar_list pVar pLocalVarParen pGlobalVarParen pLocalVarParen_list pNamedCallReturn pNamedCallReturn_list pLVars pNamedCallArg pNamedCallArg_list pCallParams pJump pLVar pLVar_list pBlock_list pStmtWithAttrib pStmtWithAttrib_list pJumpWithAttrib pPhiExpr pPhiExpr_list pPhiAssign pPhiAssign_list pBlock pAttrKeyValue pAttrKeyValue_list pAttribSet pAttr_list pAttr pParams pParams_list pValue pExpr_list pExpr pExpr1 pExpr2 pLambdaDef pBinOp pUnOp pCase pCase_list pEqOp pBVUnOp pBVBinOp pBVLogicalBinOp pIntBinOp pIntLogicalBinOp pBoolBinOp pPointerBinOp pRequireTok pEnsureTok pRelyTok pGuarTok pFunSpec pVarSpec pProgSpec pFunSpec_list pProgSpec_list %type pModuleT %type pDecl_list %type pBlockIdent_list @@ -73,6 +73,8 @@ open Lexing %type pTypeT %type pIntVal %type pBVVal +%type pFieldVal_list +%type pFieldVal %type pEndian %type pAssignment %type pStmt @@ -165,6 +167,8 @@ open Lexing %type typeT %type intVal %type bVVal +%type fieldVal_list +%type fieldVal %type endian %type assignment %type stmt @@ -305,6 +309,10 @@ pIntVal : intVal TOK_EOF { $1 }; pBVVal : bVVal TOK_EOF { $1 }; +pFieldVal_list : fieldVal_list TOK_EOF { $1 }; + +pFieldVal : fieldVal TOK_EOF { $1 }; + pEndian : endian TOK_EOF { $1 }; pAssignment : assignment TOK_EOF { $1 }; @@ -547,6 +555,14 @@ intVal : integerHex { IntVal_Hex $1 } bVVal : intVal SYMB5 bVType { BVVal1 ($1, $3) } ; +fieldVal_list : /* empty */ { [] } + | fieldVal { (fun x -> [x]) $1 } + | fieldVal KW_f fieldVal_list { (fun (x,xs) -> x::xs) ($1, $3) } + ; + +fieldVal : intVal SYMB5 bVVal { FieldVal1 ($1, $3) } + ; + endian : KW_le { Endian_Little } | KW_be { Endian_Big } ; @@ -715,6 +731,8 @@ params_list : /* empty */ { [] } value : bVVal { Value_BV $1 } | intVal { Value_Int $1 } + | openParen fieldVal_list closeParen { Value_Record ($1, $2, $3) } + | KW_ptr bVVal { Value_Pointer $2 } | KW_true { Value_True } | KW_false { Value_False } ; diff --git a/lib/fe/PrintBasilIR.ml b/lib/fe/PrintBasilIR.ml index cd2d5069..0aecc383 100644 --- a/lib/fe/PrintBasilIR.ml +++ b/lib/fe/PrintBasilIR.ml @@ -252,6 +252,13 @@ and prtBVVal (i:int) (e : AbsBasilIR.bVVal) : doc = match e with AbsBasilIR.BVVal1 (intval, bvtype) -> prPrec i 0 (concatD [prtIntVal 0 intval ; render ":" ; prtBVType 0 bvtype]) +and prtFieldVal (i:int) (e : AbsBasilIR.fieldVal) : doc = match e with + AbsBasilIR.FieldVal1 (intval, bvval) -> prPrec i 0 (concatD [prtIntVal 0 intval ; render ":" ; prtBVVal 0 bvval]) + +and prtFieldValListBNFC i es : doc = match (i, es) with + (_,[]) -> (concatD []) + | (_,[x]) -> (concatD [prtFieldVal 0 x]) + | (_,x::xs) -> (concatD [prtFieldVal 0 x ; render "f" ; prtFieldValListBNFC 0 xs]) and prtEndian (i:int) (e : AbsBasilIR.endian) : doc = match e with AbsBasilIR.Endian_Little -> prPrec i 0 (concatD [render "le"]) | AbsBasilIR.Endian_Big -> prPrec i 0 (concatD [render "be"]) @@ -420,6 +427,8 @@ and prtParamsListBNFC i es : doc = match (i, es) with and prtValue (i:int) (e : AbsBasilIR.value) : doc = match e with AbsBasilIR.Value_BV bvval -> prPrec i 0 (concatD [prtBVVal 0 bvval]) | AbsBasilIR.Value_Int intval -> prPrec i 0 (concatD [prtIntVal 0 intval]) + | AbsBasilIR.Value_Record (openparen, fieldvals, closeparen) -> prPrec i 0 (concatD [prtOpenParen 0 openparen ; prtFieldValListBNFC 0 fieldvals ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Value_Pointer bvval -> prPrec i 0 (concatD [render "ptr" ; prtBVVal 0 bvval]) | AbsBasilIR.Value_True -> prPrec i 0 (concatD [render "true"]) | AbsBasilIR.Value_False -> prPrec i 0 (concatD [render "false"]) diff --git a/lib/fe/ShowBasilIR.ml b/lib/fe/ShowBasilIR.ml index 21741809..41729001 100644 --- a/lib/fe/ShowBasilIR.ml +++ b/lib/fe/ShowBasilIR.ml @@ -151,6 +151,10 @@ and showBVVal (e : AbsBasilIR.bVVal) : showable = match e with AbsBasilIR.BVVal1 (intval, bvtype) -> s2s "BVVal1" >> c2s ' ' >> c2s '(' >> showIntVal intval >> s2s ", " >> showBVType bvtype >> c2s ')' +and showFieldVal (e : AbsBasilIR.fieldVal) : showable = match e with + AbsBasilIR.FieldVal1 (intval, bvval) -> s2s "FieldVal1" >> c2s ' ' >> c2s '(' >> showIntVal intval >> s2s ", " >> showBVVal bvval >> c2s ')' + + and showEndian (e : AbsBasilIR.endian) : showable = match e with AbsBasilIR.Endian_Little -> s2s "Endian_Little" | AbsBasilIR.Endian_Big -> s2s "Endian_Big" @@ -278,6 +282,8 @@ and showParams (e : AbsBasilIR.params) : showable = match e with and showValue (e : AbsBasilIR.value) : showable = match e with AbsBasilIR.Value_BV bvval -> s2s "Value_BV" >> c2s ' ' >> c2s '(' >> showBVVal bvval >> c2s ')' | AbsBasilIR.Value_Int intval -> s2s "Value_Int" >> c2s ' ' >> c2s '(' >> showIntVal intval >> c2s ')' + | AbsBasilIR.Value_Record (openparen, fieldvals, closeparen) -> s2s "Value_Record" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showList showFieldVal fieldvals >> s2s ", " >> showCloseParen closeparen >> c2s ')' + | AbsBasilIR.Value_Pointer bvval -> s2s "Value_Pointer" >> c2s ' ' >> c2s '(' >> showBVVal bvval >> c2s ')' | AbsBasilIR.Value_True -> s2s "Value_True" | AbsBasilIR.Value_False -> s2s "Value_False" diff --git a/lib/fe/SkelBasilIR.ml b/lib/fe/SkelBasilIR.ml index 106b6c56..5780268a 100644 --- a/lib/fe/SkelBasilIR.ml +++ b/lib/fe/SkelBasilIR.ml @@ -174,6 +174,10 @@ and transBVVal (x : bVVal) : result = match x with BVVal1 (intval, bvtype) -> failure x +and transFieldVal (x : fieldVal) : result = match x with + FieldVal1 (intval, bvval) -> failure x + + and transEndian (x : endian) : result = match x with Endian_Little -> failure x | Endian_Big -> failure x @@ -301,6 +305,8 @@ and transParams (x : params) : result = match x with and transValue (x : value) : result = match x with Value_BV bvval -> failure x | Value_Int intval -> failure x + | Value_Record (openparen, fieldvals, closeparen) -> failure x + | Value_Pointer bvval -> failure x | Value_True -> failure x | Value_False -> failure x diff --git a/lib/lang/attrib.ml b/lib/lang/attrib.ml index 196d30de..bee1957e 100644 --- a/lib/lang/attrib.ml +++ b/lib/lang/attrib.ml @@ -10,6 +10,8 @@ type 'e t = | `Integer of Z.t | `CamlInt of int | `Bitvector of Bitvec.t + | `Record of Record.t + | `Pointer of Bitvec.t | `List of 'e t list ] [@@deriving eq, ord] @@ -25,6 +27,8 @@ let rec attrib_pretty ?(internal = [ location_key ]) pretty_expr (e : 'e t) : | `Bool b -> bool b | `Expr e -> pretty_expr e | `Bitvector bv -> text @@ Bitvec.to_string bv + | `Pointer bv -> text @@ Bitvec.to_string bv + | `Record record -> text @@ Record.to_string record | `Integer bv -> text @@ Z.to_string bv | `List s -> nest 2 diff --git a/lib/lang/expr_eval.ml b/lib/lang/expr_eval.ml index 9867eceb..623d21d2 100644 --- a/lib/lang/expr_eval.ml +++ b/lib/lang/expr_eval.ml @@ -7,8 +7,12 @@ let eval_expr_alg (e : Ops.AllOps.const option BasilExpr.abstract_expr) = let bool e = Some (`Bool e) in let bv e = `Bitvector e in let z e = Some (`Integer e) in + let record e = Some (`Record e) in + let pointer e = Some (`Pointer e) in let get_bv = function Some (`Bitvector b) -> Some b | _ -> None in + let get_record = function Some (`Record b) -> Some b | _ -> None in + let get_pointer = function Some (`Pointer b) -> Some b | _ -> None in let get_bool = function Some (`Bool b) -> Some b | _ -> None in let get_int = function Some (`Integer b) -> Some b | _ -> None in @@ -33,6 +37,19 @@ let eval_expr_alg (e : Ops.AllOps.const option BasilExpr.abstract_expr) = get_bv b >|= BVOps.eval_unary_unif op >|= bv | UnaryExpr { op = #BVOps.unary_bool as op; arg = b } -> get_bool b >|= BVOps.eval_unary_bool op >|= bv + | BinaryExpr { op = `FSET offset; arg1 = a; arg2 = b } -> + let* a = get_record a in + let* b = get_bv b in + record a + | UnaryExpr { op = `FACCESS offset; arg = a } -> failwith "TODO" + | BinaryExpr { op = `PTRADD; arg1 = a; arg2 = b } -> + let* a = get_pointer a in + let* b = get_bv b in + pointer a + | BinaryExpr { op = `PTRSUB; arg1 = a; arg2 = b } -> + let* a = get_pointer a in + let* b = get_bv b in + pointer a | BinaryExpr { op = #BVOps.binary_unif as op; arg1 = a; arg2 = b } -> let* a = get_bv a in let* b = get_bv b in diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 0a8282f4..51300469 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -3,7 +3,7 @@ open Expr open CCSexp module SMTLib2 = struct - type logic = UF | Int | Prop | BV | Array | DT [@@deriving ord] + type logic = UF | Int | Prop | BV | Record |Array | DT [@@deriving ord] module LSet = Set.Make (struct type t = logic @@ -144,6 +144,9 @@ module SMTLib2 = struct | `Bitvector _ -> add_logic BV | `Integer _ -> add_logic Int | `Bool _ -> return () + (* NOTE: Will need some help here *) + | `Record _ -> add_logic Record + | `Pointer _ -> add_logic BV in return v diff --git a/lib/lang/interp.ml b/lib/lang/interp.ml index dd732895..c0da070e 100644 --- a/lib/lang/interp.ml +++ b/lib/lang/interp.ml @@ -34,6 +34,11 @@ module IValue = struct | `Integer v -> Bitvec.create ~size:int_size v | `Bool true -> Bitvec.create ~size:8 Z.one | `Bool false -> Bitvec.create ~size:8 Z.zero + | `Pointer bv -> bv + | `Record fields -> + List.fold_left + (fun acc ({ value; _ } : Record.field) -> Bitvec.concat acc value) + Bitvec.empty fields let of_constant (v : Ops.AllOps.const) = let open Expr.BasilExpr in @@ -42,6 +47,8 @@ module IValue = struct | `Bitvector bv -> bv_value bv | `Integer v -> int_value v | `Bool b -> if b then true_value else false_value + | `Pointer bv -> bv_value bv + | `Record fields -> bv_value @@ bv_of_constant v (** conversion to basil values *) diff --git a/lib/lang/ops.ml b/lib/lang/ops.ml index d1e49f6e..99e34552 100644 --- a/lib/lang/ops.ml +++ b/lib/lang/ops.ml @@ -195,6 +195,9 @@ module IntOps = struct end module RecordOps = struct + type const = [ `Record of Record.t ] + [@@deriving show { with_path = false }, eq, ord] + type unary = ([ `FACCESS of Z.t ] [@printer @@ -219,6 +222,9 @@ module RecordOps = struct end module PointerOps = struct + type const = [ `Pointer of Bitvec.t ] + [@@deriving show { with_path = false }, eq, ord] + type binary = [ `PTRADD | `PTRSUB ] [@@deriving show { with_path = false }, eq, ord] @@ -249,7 +255,12 @@ module Spec = struct end module AllOps = struct - type const = [ IntOps.const | BVOps.const | LogicalOps.const ] + type const = + [ IntOps.const + | BVOps.const + | LogicalOps.const + | RecordOps.const + | PointerOps.const ] [@@deriving show { with_path = false }, eq, ord] type unary = @@ -298,10 +309,7 @@ module AllOps = struct match a with | Bitvector s -> return @@ Bitvector (sz + s) | o -> Conflict [ (o, " ( - match get_field offset a with - | None -> failwith @@ "No field at offset: " ^ Z.to_string offset - | Some ({ t; _ } : field2) -> return t) + | `FACCESS offset -> return @@ get_field offset a | `Forall -> return Boolean | `BVNEG -> return a | `INTNEG -> return Integer @@ -415,6 +423,8 @@ module AllOps = struct | `BVAND -> "bvand" | `INTMUL -> "intmul" | `Bitvector z -> Bitvec.to_string z + | `Pointer z -> "ptr:" ^ Bitvec.to_string z + | `Record fields -> Record.to_string fields | `BVSMOD -> "bvsmod" | `INTLT -> "intlt" | `IMPLIES -> "implies" diff --git a/lib/loadir.ml b/lib/loadir.ml index 952a2806..3a85edbf 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -869,6 +869,15 @@ module BasilASTLoader = struct | Value_Int intval -> `Integer (transIntVal intval) | Value_True -> `Bool true | Value_False -> `Bool false + | Value_Pointer v -> `Pointer (trans_bv_val v) + | Value_Record (_, fields, _) -> + `Record + (List.map + (function + | FieldVal1 (offset, value) -> + ({ offset = transIntVal offset; value = trans_bv_val value } + : Record.field)) + fields) and unsafe_unsigil g : string = match g with diff --git a/lib/transforms/type_check.ml b/lib/transforms/type_check.ml index 86ea006c..ce34e548 100644 --- a/lib/transforms/type_check.ml +++ b/lib/transforms/type_check.ml @@ -27,6 +27,12 @@ let type_check stmt_id block_id expr = match op with | `Classification -> [] | `Gamma -> [] + | `Old -> [] + | `Forall | `Exists | `Lambda -> [] + | `FACCESS _ -> ( + match arg with + | Record _ -> [] + | _ -> [ type_err "FACCESS body is not a record type" ]) | `BoolNOT | `BOOLTOBV1 -> if Types.equal arg Types.Boolean then [] else [ type_err "%s body is not a boolean" @@ AllOps.to_string op ] @@ -49,8 +55,6 @@ let type_check stmt_id block_id expr = @@ AllOps.to_string op; ]) | _ -> [ type_err "%s body is not a bitvector" @@ AllOps.to_string op ]) - | `Old -> [] - | `Forall | `Exists | `Lambda -> [] in let check_binary (op : Ops.AllOps.binary) (arg1 : Types.t) (arg2 : Types.t) : @@ -86,6 +90,33 @@ let type_check stmt_id block_id expr = let binary_bool_types = binary_same_types Types.Boolean in let open Ops in match op with + | `PTRADD | `PTRSUB -> ( + let err = + match arg2 with + | Bitvector _ -> [] + | _ -> + [ type_err "%s is not of bitvector type" @@ Types.to_string arg1 ] + in + match arg1 with + | Pointer _ -> err + | _ -> + err + @ [ type_err "%s is not of pointer type" @@ Types.to_string arg2 ]) + | `FSET offset -> + let err = + match arg1 with + | Record _ -> [] + | _ -> [ type_err "%s is not of record type" @@ Types.to_string arg1 ] + in + if + List.length err = 1 + || (Types.equal arg2 @@ Types.get_field offset arg1) + then err + else + [ + type_err "%s is not of %s type" (Types.to_string arg1) + (Types.to_string @@ Types.get_field offset arg1); + ] | `INTADD | `INTMUL | `INTSUB | `INTDIV | `INTMOD | `INTLT | `INTLE -> binary_int_types arg1 arg2 | (`EQ | `NEQ) as op -> diff --git a/lib/util/common.ml b/lib/util/common.ml index 822d5d62..bcf34315 100644 --- a/lib/util/common.ml +++ b/lib/util/common.ml @@ -43,6 +43,7 @@ module VarSet = Set.Make (Var) module Bitvec = Bitvec module PrimInt = Zint +module Record = Record let disable_backtrace_in f = let old = Printexc.backtrace_status () in diff --git a/lib/util/dune b/lib/util/dune index 0b987b7c..b82d4f73 100644 --- a/lib/util/dune +++ b/lib/util/dune @@ -10,6 +10,7 @@ ID types bitvec + record zint smt reverse_graph diff --git a/lib/util/record.ml b/lib/util/record.ml new file mode 100644 index 00000000..a586eff5 --- /dev/null +++ b/lib/util/record.ml @@ -0,0 +1,11 @@ +type t = field list [@@deriving eq, ord] +and field = { offset : Z.t; value : Bitvec.t } + +let show_field { offset; value } = + Z.to_string offset ^ " : " ^ Bitvec.to_string value + +let show (record : t) = + List.fold_left (fun acc field -> acc ^ show_field field ^ ", ") "" record + +let to_string v = show v +let pp fmt b = Format.pp_print_string fmt (show b) diff --git a/lib/util/types.ml b/lib/util/types.ml index 97d2b364..cb07cb74 100644 --- a/lib/util/types.ml +++ b/lib/util/types.ml @@ -75,10 +75,14 @@ let mk_adt name (variants : (string * field list) list) = Sort (name, variants |> List.map (fun (variant, fields) -> { variant; fields })) -let get_field offset1 record : field2 option = +let get_field offset1 record : t = match record with - | Record fields -> - List.find_opt (fun { offset; _ } -> Z.equal offset offset1) fields + | Record fields -> ( + match + List.find_opt (fun { offset; _ } -> Z.equal offset offset1) fields + with + | None -> failwith @@ "No field at offset " ^ Z.to_string offset1 + | Some { t; _ } -> t) | _ -> failwith "Not record type" (* From 82acfd6272aaf8a092fd989c44c090684e427c2b Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Thu, 5 Mar 2026 16:10:45 +1000 Subject: [PATCH 05/29] fmt --- lib/lang/expr_smt.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 51300469..aaf14cc7 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -3,7 +3,7 @@ open Expr open CCSexp module SMTLib2 = struct - type logic = UF | Int | Prop | BV | Record |Array | DT [@@deriving ord] + type logic = UF | Int | Prop | BV | Record | Array | DT [@@deriving ord] module LSet = Set.Make (struct type t = logic From c517ba3c1f809cc9c28becb0ac8b75c237c7cd2c Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Thu, 5 Mar 2026 16:16:57 +1000 Subject: [PATCH 06/29] Change sep from f -> , --- lib/fe/BasilIR.cf | 2 +- lib/fe/LexBasilIR.mll | 4 ++-- lib/fe/ParBasilIR.mly | 4 ++-- lib/fe/PrintBasilIR.ml | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index 8bfccf8e..f7582a31 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -107,7 +107,7 @@ IntVal_Dec . IntVal ::= IntegerDec ; rules BVVal ::= IntVal ":" BVType ; -separator FieldVal "f" ; +separator FieldVal "," ; rules FieldVal ::= IntVal ":" BVVal ; Endian_Little . Endian ::= "le" ; diff --git a/lib/fe/LexBasilIR.mll b/lib/fe/LexBasilIR.mll index 2ae387ff..2256e888 100644 --- a/lib/fe/LexBasilIR.mll +++ b/lib/fe/LexBasilIR.mll @@ -11,9 +11,9 @@ let symbol_table = Hashtbl.create 10 let _ = List.iter (fun (kwd, tok) -> Hashtbl.add symbol_table kwd tok) [(";", SYMB1);(",", SYMB2);("->", SYMB3);("::", SYMB4);(":", SYMB5);("=", SYMB6);("|", SYMB7);(":=", SYMB8);("mem:=", SYMB9);("_", SYMB10)] -let resword_table = Hashtbl.create 107 +let resword_table = Hashtbl.create 106 let _ = List.iter (fun (kwd, tok) -> Hashtbl.add resword_table kwd tok) - [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("of", KW_of);("f", KW_f);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("ptr", KW_ptr);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("old", KW_old);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("bvconcat", KW_bvconcat);("fset", KW_fset);("facces", KW_facces);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvmul", KW_bvmul);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxor", KW_bvxor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("boolimplies", KW_boolimplies);("ptradd", KW_ptradd);("ptrsub", KW_ptrsub);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] + [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("of", KW_of);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("ptr", KW_ptr);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("old", KW_old);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("bvconcat", KW_bvconcat);("fset", KW_fset);("facces", KW_facces);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvmul", KW_bvmul);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxor", KW_bvxor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("boolimplies", KW_boolimplies);("ptradd", KW_ptradd);("ptrsub", KW_ptrsub);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] let unescapeInitTail (s:string) : string = let rec unesc s = match s with diff --git a/lib/fe/ParBasilIR.mly b/lib/fe/ParBasilIR.mly index e034eaa2..6940b950 100644 --- a/lib/fe/ParBasilIR.mly +++ b/lib/fe/ParBasilIR.mly @@ -7,7 +7,7 @@ open AbsBasilIR open Lexing %} -%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_of KW_f KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_ptr KW_true KW_false KW_forall KW_exists KW_fun KW_old KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_bvconcat KW_fset KW_facces KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvand KW_bvor KW_bvadd KW_bvmul KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_boolimplies KW_ptradd KW_ptrsub KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant +%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_of KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_ptr KW_true KW_false KW_forall KW_exists KW_fun KW_old KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_bvconcat KW_fset KW_facces KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvand KW_bvor KW_bvadd KW_bvmul KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_boolimplies KW_ptradd KW_ptrsub KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant %token SYMB1 /* ; */ %token SYMB2 /* , */ @@ -557,7 +557,7 @@ bVVal : intVal SYMB5 bVType { BVVal1 ($1, $3) } fieldVal_list : /* empty */ { [] } | fieldVal { (fun x -> [x]) $1 } - | fieldVal KW_f fieldVal_list { (fun (x,xs) -> x::xs) ($1, $3) } + | fieldVal SYMB2 fieldVal_list { (fun (x,xs) -> x::xs) ($1, $3) } ; fieldVal : intVal SYMB5 bVVal { FieldVal1 ($1, $3) } diff --git a/lib/fe/PrintBasilIR.ml b/lib/fe/PrintBasilIR.ml index 0aecc383..c3e69ccd 100644 --- a/lib/fe/PrintBasilIR.ml +++ b/lib/fe/PrintBasilIR.ml @@ -258,7 +258,7 @@ and prtFieldVal (i:int) (e : AbsBasilIR.fieldVal) : doc = match e with and prtFieldValListBNFC i es : doc = match (i, es) with (_,[]) -> (concatD []) | (_,[x]) -> (concatD [prtFieldVal 0 x]) - | (_,x::xs) -> (concatD [prtFieldVal 0 x ; render "f" ; prtFieldValListBNFC 0 xs]) + | (_,x::xs) -> (concatD [prtFieldVal 0 x ; render "," ; prtFieldValListBNFC 0 xs]) and prtEndian (i:int) (e : AbsBasilIR.endian) : doc = match e with AbsBasilIR.Endian_Little -> prPrec i 0 (concatD [render "le"]) | AbsBasilIR.Endian_Big -> prPrec i 0 (concatD [render "be"]) From 90998258f698970a6cb0e05a065092fb833433cd Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Thu, 5 Mar 2026 16:57:21 +1000 Subject: [PATCH 07/29] Fux eval_expr_alg and some parsing issues --- lib/fe/AbsBasilIR.ml | 2 +- lib/fe/BasilIR.cf | 2 +- lib/fe/LexBasilIR.mll | 2 +- lib/fe/ParBasilIR.mly | 4 ++-- lib/fe/PrintBasilIR.ml | 2 +- lib/fe/ShowBasilIR.ml | 2 +- lib/fe/SkelBasilIR.ml | 2 +- lib/lang/expr_eval.ml | 10 ++++++---- lib/loadir.ml | 5 ++++- lib/util/record.ml | 12 ++++++++++++ 10 files changed, 30 insertions(+), 13 deletions(-) diff --git a/lib/fe/AbsBasilIR.ml b/lib/fe/AbsBasilIR.ml index 229a0bfc..32ddf4ed 100644 --- a/lib/fe/AbsBasilIR.ml +++ b/lib/fe/AbsBasilIR.ml @@ -62,7 +62,7 @@ and recordType = RecordType1 of beginRec * field list * endRec and pointerType = - PointerType1 of pOINTERTYPE * openParen * typeT * typeT * closeParen + PointerType1 of openParen * typeT * typeT * closeParen and bVType = BVType1 of bVTYPE diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index f7582a31..b28a5f0a 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -78,7 +78,7 @@ Field1 . Field ::= IntVal ":" Type ; IntType1 . IntType ::= INTTYPE ; BoolType1. BoolType ::= BOOLTYPE ; RecordType1 . RecordType ::= BeginRec [Field] EndRec ; -PointerType1 . PointerType ::= POINTERTYPE OpenParen Type "," Type CloseParen ; +PointerType1 . PointerType ::= "ptr" OpenParen Type "," Type CloseParen ; BVType1 . BVType ::= BVTYPE ; -- map types are right associative. left of -> cannot be another MapType. MapType1 . MapType ::= Type1 "->" Type ; diff --git a/lib/fe/LexBasilIR.mll b/lib/fe/LexBasilIR.mll index 2256e888..55359052 100644 --- a/lib/fe/LexBasilIR.mll +++ b/lib/fe/LexBasilIR.mll @@ -13,7 +13,7 @@ let _ = List.iter (fun (kwd, tok) -> Hashtbl.add symbol_table kwd tok) let resword_table = Hashtbl.create 106 let _ = List.iter (fun (kwd, tok) -> Hashtbl.add resword_table kwd tok) - [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("of", KW_of);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("ptr", KW_ptr);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("old", KW_old);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("bvconcat", KW_bvconcat);("fset", KW_fset);("facces", KW_facces);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvmul", KW_bvmul);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxor", KW_bvxor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("boolimplies", KW_boolimplies);("ptradd", KW_ptradd);("ptrsub", KW_ptrsub);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] + [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("ptr", KW_ptr);("of", KW_of);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("old", KW_old);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("bvconcat", KW_bvconcat);("fset", KW_fset);("facces", KW_facces);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvmul", KW_bvmul);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxor", KW_bvxor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("boolimplies", KW_boolimplies);("ptradd", KW_ptradd);("ptrsub", KW_ptrsub);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] let unescapeInitTail (s:string) : string = let rec unesc s = match s with diff --git a/lib/fe/ParBasilIR.mly b/lib/fe/ParBasilIR.mly index 6940b950..697f98b2 100644 --- a/lib/fe/ParBasilIR.mly +++ b/lib/fe/ParBasilIR.mly @@ -7,7 +7,7 @@ open AbsBasilIR open Lexing %} -%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_of KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_ptr KW_true KW_false KW_forall KW_exists KW_fun KW_old KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_bvconcat KW_fset KW_facces KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvand KW_bvor KW_bvadd KW_bvmul KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_boolimplies KW_ptradd KW_ptrsub KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant +%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_ptr KW_of KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_true KW_false KW_forall KW_exists KW_fun KW_old KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_bvconcat KW_fset KW_facces KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvand KW_bvor KW_bvadd KW_bvmul KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_boolimplies KW_ptradd KW_ptrsub KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant %token SYMB1 /* ; */ %token SYMB2 /* , */ @@ -511,7 +511,7 @@ boolType : bOOLTYPE { BoolType1 $1 } recordType : beginRec field_list endRec { RecordType1 ($1, $2, $3) } ; -pointerType : pOINTERTYPE openParen typeT SYMB2 typeT closeParen { PointerType1 ($1, $2, $3, $5, $6) } +pointerType : KW_ptr openParen typeT SYMB2 typeT closeParen { PointerType1 ($2, $3, $5, $6) } ; bVType : bVTYPE { BVType1 $1 } diff --git a/lib/fe/PrintBasilIR.ml b/lib/fe/PrintBasilIR.ml index c3e69ccd..bcb30968 100644 --- a/lib/fe/PrintBasilIR.ml +++ b/lib/fe/PrintBasilIR.ml @@ -203,7 +203,7 @@ and prtRecordType (i:int) (e : AbsBasilIR.recordType) : doc = match e with and prtPointerType (i:int) (e : AbsBasilIR.pointerType) : doc = match e with - AbsBasilIR.PointerType1 (pointertype, openparen, type_1, type_2, closeparen) -> prPrec i 0 (concatD [prtPOINTERTYPE 0 pointertype ; prtOpenParen 0 openparen ; prtTypeT 0 type_1 ; render "," ; prtTypeT 0 type_2 ; prtCloseParen 0 closeparen]) + AbsBasilIR.PointerType1 (openparen, type_1, type_2, closeparen) -> prPrec i 0 (concatD [render "ptr" ; prtOpenParen 0 openparen ; prtTypeT 0 type_1 ; render "," ; prtTypeT 0 type_2 ; prtCloseParen 0 closeparen]) and prtBVType (i:int) (e : AbsBasilIR.bVType) : doc = match e with diff --git a/lib/fe/ShowBasilIR.ml b/lib/fe/ShowBasilIR.ml index 41729001..cd143241 100644 --- a/lib/fe/ShowBasilIR.ml +++ b/lib/fe/ShowBasilIR.ml @@ -111,7 +111,7 @@ and showRecordType (e : AbsBasilIR.recordType) : showable = match e with and showPointerType (e : AbsBasilIR.pointerType) : showable = match e with - AbsBasilIR.PointerType1 (pointertype, openparen, type'0, type', closeparen) -> s2s "PointerType1" >> c2s ' ' >> c2s '(' >> showPOINTERTYPE pointertype >> s2s ", " >> showOpenParen openparen >> s2s ", " >> showTypeT type'0 >> s2s ", " >> showTypeT type' >> s2s ", " >> showCloseParen closeparen >> c2s ')' + AbsBasilIR.PointerType1 (openparen, type'0, type', closeparen) -> s2s "PointerType1" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showTypeT type'0 >> s2s ", " >> showTypeT type' >> s2s ", " >> showCloseParen closeparen >> c2s ')' and showBVType (e : AbsBasilIR.bVType) : showable = match e with diff --git a/lib/fe/SkelBasilIR.ml b/lib/fe/SkelBasilIR.ml index 5780268a..d727cb23 100644 --- a/lib/fe/SkelBasilIR.ml +++ b/lib/fe/SkelBasilIR.ml @@ -134,7 +134,7 @@ and transRecordType (x : recordType) : result = match x with and transPointerType (x : pointerType) : result = match x with - PointerType1 (pointertype, openparen, type'0, type', closeparen) -> failure x + PointerType1 (openparen, type'0, type', closeparen) -> failure x and transBVType (x : bVType) : result = match x with diff --git a/lib/lang/expr_eval.ml b/lib/lang/expr_eval.ml index 623d21d2..2c2d9c2a 100644 --- a/lib/lang/expr_eval.ml +++ b/lib/lang/expr_eval.ml @@ -40,16 +40,18 @@ let eval_expr_alg (e : Ops.AllOps.const option BasilExpr.abstract_expr) = | BinaryExpr { op = `FSET offset; arg1 = a; arg2 = b } -> let* a = get_record a in let* b = get_bv b in - record a - | UnaryExpr { op = `FACCESS offset; arg = a } -> failwith "TODO" + record (Record.set_field offset b a) + | UnaryExpr { op = `FACCESS offset; arg = a } -> + let* a = get_record a in + Some (bv (Record.get_field offset a)) | BinaryExpr { op = `PTRADD; arg1 = a; arg2 = b } -> let* a = get_pointer a in let* b = get_bv b in - pointer a + pointer (BVOps.eval_binary_unif `BVADD a b) | BinaryExpr { op = `PTRSUB; arg1 = a; arg2 = b } -> let* a = get_pointer a in let* b = get_bv b in - pointer a + pointer (BVOps.eval_binary_unif `BVSUB a b) | BinaryExpr { op = #BVOps.binary_unif as op; arg1 = a; arg2 = b } -> let* a = get_bv a in let* b = get_bv b in diff --git a/lib/loadir.ml b/lib/loadir.ml index 3a85edbf..f7c7f933 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -1097,7 +1097,10 @@ module BasilASTLoader = struct | IntBinOp_intdiv -> `INTDIV | IntBinOp_intmod -> `INTMOD - and transPointerBinOp (x : pointerBinOp) = failwith "TODO" + and transPointerBinOp (x : pointerBinOp) = + match x with + | PointerBinOp_ptradd -> `PTRADD + | PointerBinOp_ptrsub -> `PTRSUB and transIntLogicalBinOp (x : intLogicalBinOp) = match x with diff --git a/lib/util/record.ml b/lib/util/record.ml index a586eff5..7f030600 100644 --- a/lib/util/record.ml +++ b/lib/util/record.ml @@ -1,6 +1,18 @@ type t = field list [@@deriving eq, ord] and field = { offset : Z.t; value : Bitvec.t } +let get_field offset1 fields : Bitvec.t = + match List.find_opt (fun { offset; _ } -> Z.equal offset offset1) fields with + | None -> failwith @@ "No field at offset " ^ Z.to_string offset1 + | Some { value; _ } -> value + +let set_field offset1 (value1 : Bitvec.t) fields : t = + List.map + (fun { offset; value } -> + if Z.equal offset offset1 then { offset; value = value1 } + else { offset; value }) + fields + let show_field { offset; value } = Z.to_string offset ^ " : " ^ Bitvec.to_string value From 42324329141f9ce64420d3d905a97a149f57cd2f Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Fri, 6 Mar 2026 13:49:10 +1000 Subject: [PATCH 08/29] Change record to be map, and record and pointer contain there type --- lib/analysis/defuse_bool.ml | 8 ++--- lib/analysis/wrapped_intervals.ml | 3 +- lib/fe/AbsBasilIR.ml | 4 +-- lib/fe/BasilIR.cf | 4 +-- lib/fe/ParBasilIR.mly | 4 +-- lib/fe/PrintBasilIR.ml | 4 +-- lib/fe/ShowBasilIR.ml | 4 +-- lib/fe/SkelBasilIR.ml | 4 +-- lib/lang/attrib.ml | 5 ++-- lib/lang/expr_eval.ml | 11 +++---- lib/lang/expr_smt.ml | 23 +++++++------- lib/lang/interp.ml | 10 +++---- lib/lang/ops.ml | 10 +++++-- lib/loadir.ml | 28 +++++++++-------- lib/util/common.ml | 1 + lib/util/record.ml | 32 ++++++++++---------- lib/util/types.ml | 50 +++++++++++++++++++------------ 17 files changed, 115 insertions(+), 90 deletions(-) diff --git a/lib/analysis/defuse_bool.ml b/lib/analysis/defuse_bool.ml index 83394985..8aa8f03d 100644 --- a/lib/analysis/defuse_bool.ml +++ b/lib/analysis/defuse_bool.ml @@ -40,17 +40,17 @@ module IsZeroValueAbstraction = struct | `Bool true -> NonZero | `Bool false -> Zero | `Integer i -> if Z.equal Z.zero i then Zero else NonZero - | `Bitvector i | `Pointer i -> + | `Bitvector i | `Pointer (i, _) -> if Bitvec.size i = 0 then Top else if Z.equal Z.zero (Bitvec.value i) then Zero else NonZero | `Record fields -> - List.fold_left - (fun acc ({ value = i; _ } : Record.field) -> + ZMap.fold + (fun _ ({ value = i; _ } : Record.field) acc -> if Bitvec.size i = 0 then Top else if Z.equal Z.zero (Bitvec.value i) then join acc Zero else join acc NonZero) - Zero fields + fields Zero let eval_unop (op : Lang.Ops.AllOps.unary) a = match op with diff --git a/lib/analysis/wrapped_intervals.ml b/lib/analysis/wrapped_intervals.ml index 6d6d18c1..bb339cb4 100644 --- a/lib/analysis/wrapped_intervals.ml +++ b/lib/analysis/wrapped_intervals.ml @@ -697,7 +697,8 @@ module WrappedIntervalsValueAbstraction = struct match op with | `Bool _ -> top | `Integer _ -> top - | `Bitvector bv | `Pointer bv -> if size bv = 0 then top else interval bv bv + | `Bitvector bv | `Pointer (bv, _) -> + if size bv = 0 then top else interval bv bv (* NOTE: This kind of thing happens frequently, should I go through all of the fields and make a intervals out of those bvs?*) | `Record fields -> top diff --git a/lib/fe/AbsBasilIR.ml b/lib/fe/AbsBasilIR.ml index 32ddf4ed..d869706a 100644 --- a/lib/fe/AbsBasilIR.ml +++ b/lib/fe/AbsBasilIR.ml @@ -95,7 +95,7 @@ and bVVal = BVVal1 of intVal * bVType and fieldVal = - FieldVal1 of intVal * bVVal + FieldVal1 of openParen * intVal * bVVal * typeT * closeParen and endian = Endian_Little @@ -202,7 +202,7 @@ and value = Value_BV of bVVal | Value_Int of intVal | Value_Record of openParen * fieldVal list * closeParen - | Value_Pointer of bVVal + | Value_Pointer of openParen * bVVal * pointerType * closeParen | Value_True | Value_False diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index b28a5f0a..5efcf816 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -108,7 +108,7 @@ IntVal_Dec . IntVal ::= IntegerDec ; rules BVVal ::= IntVal ":" BVType ; separator FieldVal "," ; -rules FieldVal ::= IntVal ":" BVVal ; +rules FieldVal ::= OpenParen IntVal ":" BVVal "," Type CloseParen; Endian_Little . Endian ::= "le" ; Endian_Big . Endian ::= "be" ; @@ -226,7 +226,7 @@ separator Params "," ; Value_BV . Value ::= BVVal; Value_Int . Value ::= IntVal; Value_Record . Value ::= OpenParen [FieldVal] CloseParen; -Value_Pointer . Value ::= "ptr" BVVal ; +Value_Pointer . Value ::= "ptr" OpenParen BVVal "," PointerType CloseParen; Value_True . Value ::= "true" ; Value_False . Value ::= "false" ; diff --git a/lib/fe/ParBasilIR.mly b/lib/fe/ParBasilIR.mly index 697f98b2..b36b1095 100644 --- a/lib/fe/ParBasilIR.mly +++ b/lib/fe/ParBasilIR.mly @@ -560,7 +560,7 @@ fieldVal_list : /* empty */ { [] } | fieldVal SYMB2 fieldVal_list { (fun (x,xs) -> x::xs) ($1, $3) } ; -fieldVal : intVal SYMB5 bVVal { FieldVal1 ($1, $3) } +fieldVal : openParen intVal SYMB5 bVVal SYMB2 typeT closeParen { FieldVal1 ($1, $2, $4, $6, $7) } ; endian : KW_le { Endian_Little } @@ -732,7 +732,7 @@ params_list : /* empty */ { [] } value : bVVal { Value_BV $1 } | intVal { Value_Int $1 } | openParen fieldVal_list closeParen { Value_Record ($1, $2, $3) } - | KW_ptr bVVal { Value_Pointer $2 } + | KW_ptr openParen bVVal SYMB2 pointerType closeParen { Value_Pointer ($2, $3, $5, $6) } | KW_true { Value_True } | KW_false { Value_False } ; diff --git a/lib/fe/PrintBasilIR.ml b/lib/fe/PrintBasilIR.ml index bcb30968..22f27729 100644 --- a/lib/fe/PrintBasilIR.ml +++ b/lib/fe/PrintBasilIR.ml @@ -253,7 +253,7 @@ and prtBVVal (i:int) (e : AbsBasilIR.bVVal) : doc = match e with and prtFieldVal (i:int) (e : AbsBasilIR.fieldVal) : doc = match e with - AbsBasilIR.FieldVal1 (intval, bvval) -> prPrec i 0 (concatD [prtIntVal 0 intval ; render ":" ; prtBVVal 0 bvval]) + AbsBasilIR.FieldVal1 (openparen, intval, bvval, type_, closeparen) -> prPrec i 0 (concatD [prtOpenParen 0 openparen ; prtIntVal 0 intval ; render ":" ; prtBVVal 0 bvval ; render "," ; prtTypeT 0 type_ ; prtCloseParen 0 closeparen]) and prtFieldValListBNFC i es : doc = match (i, es) with (_,[]) -> (concatD []) @@ -428,7 +428,7 @@ and prtValue (i:int) (e : AbsBasilIR.value) : doc = match e with AbsBasilIR.Value_BV bvval -> prPrec i 0 (concatD [prtBVVal 0 bvval]) | AbsBasilIR.Value_Int intval -> prPrec i 0 (concatD [prtIntVal 0 intval]) | AbsBasilIR.Value_Record (openparen, fieldvals, closeparen) -> prPrec i 0 (concatD [prtOpenParen 0 openparen ; prtFieldValListBNFC 0 fieldvals ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Value_Pointer bvval -> prPrec i 0 (concatD [render "ptr" ; prtBVVal 0 bvval]) + | AbsBasilIR.Value_Pointer (openparen, bvval, pointertype, closeparen) -> prPrec i 0 (concatD [render "ptr" ; prtOpenParen 0 openparen ; prtBVVal 0 bvval ; render "," ; prtPointerType 0 pointertype ; prtCloseParen 0 closeparen]) | AbsBasilIR.Value_True -> prPrec i 0 (concatD [render "true"]) | AbsBasilIR.Value_False -> prPrec i 0 (concatD [render "false"]) diff --git a/lib/fe/ShowBasilIR.ml b/lib/fe/ShowBasilIR.ml index cd143241..80bd2a9f 100644 --- a/lib/fe/ShowBasilIR.ml +++ b/lib/fe/ShowBasilIR.ml @@ -152,7 +152,7 @@ and showBVVal (e : AbsBasilIR.bVVal) : showable = match e with and showFieldVal (e : AbsBasilIR.fieldVal) : showable = match e with - AbsBasilIR.FieldVal1 (intval, bvval) -> s2s "FieldVal1" >> c2s ' ' >> c2s '(' >> showIntVal intval >> s2s ", " >> showBVVal bvval >> c2s ')' + AbsBasilIR.FieldVal1 (openparen, intval, bvval, type', closeparen) -> s2s "FieldVal1" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval >> s2s ", " >> showBVVal bvval >> s2s ", " >> showTypeT type' >> s2s ", " >> showCloseParen closeparen >> c2s ')' and showEndian (e : AbsBasilIR.endian) : showable = match e with @@ -283,7 +283,7 @@ and showValue (e : AbsBasilIR.value) : showable = match e with AbsBasilIR.Value_BV bvval -> s2s "Value_BV" >> c2s ' ' >> c2s '(' >> showBVVal bvval >> c2s ')' | AbsBasilIR.Value_Int intval -> s2s "Value_Int" >> c2s ' ' >> c2s '(' >> showIntVal intval >> c2s ')' | AbsBasilIR.Value_Record (openparen, fieldvals, closeparen) -> s2s "Value_Record" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showList showFieldVal fieldvals >> s2s ", " >> showCloseParen closeparen >> c2s ')' - | AbsBasilIR.Value_Pointer bvval -> s2s "Value_Pointer" >> c2s ' ' >> c2s '(' >> showBVVal bvval >> c2s ')' + | AbsBasilIR.Value_Pointer (openparen, bvval, pointertype, closeparen) -> s2s "Value_Pointer" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showBVVal bvval >> s2s ", " >> showPointerType pointertype >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.Value_True -> s2s "Value_True" | AbsBasilIR.Value_False -> s2s "Value_False" diff --git a/lib/fe/SkelBasilIR.ml b/lib/fe/SkelBasilIR.ml index d727cb23..f3ebaf88 100644 --- a/lib/fe/SkelBasilIR.ml +++ b/lib/fe/SkelBasilIR.ml @@ -175,7 +175,7 @@ and transBVVal (x : bVVal) : result = match x with and transFieldVal (x : fieldVal) : result = match x with - FieldVal1 (intval, bvval) -> failure x + FieldVal1 (openparen, intval, bvval, type', closeparen) -> failure x and transEndian (x : endian) : result = match x with @@ -306,7 +306,7 @@ and transValue (x : value) : result = match x with Value_BV bvval -> failure x | Value_Int intval -> failure x | Value_Record (openparen, fieldvals, closeparen) -> failure x - | Value_Pointer bvval -> failure x + | Value_Pointer (openparen, bvval, pointertype, closeparen) -> failure x | Value_True -> failure x | Value_False -> failure x diff --git a/lib/lang/attrib.ml b/lib/lang/attrib.ml index bee1957e..0acda433 100644 --- a/lib/lang/attrib.ml +++ b/lib/lang/attrib.ml @@ -11,7 +11,7 @@ type 'e t = | `CamlInt of int | `Bitvector of Bitvec.t | `Record of Record.t - | `Pointer of Bitvec.t + | `Pointer of Bitvec.t * Types.pointer | `List of 'e t list ] [@@deriving eq, ord] @@ -27,7 +27,8 @@ let rec attrib_pretty ?(internal = [ location_key ]) pretty_expr (e : 'e t) : | `Bool b -> bool b | `Expr e -> pretty_expr e | `Bitvector bv -> text @@ Bitvec.to_string bv - | `Pointer bv -> text @@ Bitvec.to_string bv + | `Pointer (bv, typ) -> + text (String.cat (Bitvec.to_string bv) @@ Types.show_pointer typ) | `Record record -> text @@ Record.to_string record | `Integer bv -> text @@ Z.to_string bv | `List s -> diff --git a/lib/lang/expr_eval.ml b/lib/lang/expr_eval.ml index 2c2d9c2a..fd1fc0b0 100644 --- a/lib/lang/expr_eval.ml +++ b/lib/lang/expr_eval.ml @@ -43,15 +43,16 @@ let eval_expr_alg (e : Ops.AllOps.const option BasilExpr.abstract_expr) = record (Record.set_field offset b a) | UnaryExpr { op = `FACCESS offset; arg = a } -> let* a = get_record a in - Some (bv (Record.get_field offset a)) + let { value; _ } : Record.field = Record.get_field offset a in + Some (bv value) | BinaryExpr { op = `PTRADD; arg1 = a; arg2 = b } -> - let* a = get_pointer a in + let* a, typ = get_pointer a in let* b = get_bv b in - pointer (BVOps.eval_binary_unif `BVADD a b) + pointer (BVOps.eval_binary_unif `BVADD a b, typ) | BinaryExpr { op = `PTRSUB; arg1 = a; arg2 = b } -> - let* a = get_pointer a in + let* a, typ = get_pointer a in let* b = get_bv b in - pointer (BVOps.eval_binary_unif `BVSUB a b) + pointer (BVOps.eval_binary_unif `BVSUB a b, typ) | BinaryExpr { op = #BVOps.binary_unif as op; arg1 = a; arg2 = b } -> let* a = get_bv a in let* b = get_bv b in diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index aaf14cc7..17481822 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -100,23 +100,22 @@ module SMTLib2 = struct ( list [ atom "_"; atom "BitVec"; atom @@ Int.to_string i ], LSet.singleton BV ) | Record fields -> - (* Each field in record has three atoms? Offset, size, type *) - let of_field ({ offset; t } : Types.field2) = + (* Each field in record has two atoms? Offset, type *) + let of_field offset t = let t_sexp, t_set = of_typ t in - (list [ atom @@ Z.to_string offset; t_sexp ], t_set) + ([ atom @@ Z.to_string offset; t_sexp ], t_set) in - (* The fold keeps track of the set and the map makes it a sexp list *) let lset, sexp = - List.fold_left_map - (fun set field -> - let field_sexp, field_set = of_field field in - (LSet.union set field_set, field_sexp)) - LSet.empty fields + ZMap.fold + (fun offset t (set, sexp_list) -> + let field_sexp, field_set = of_field offset t in + (LSet.union set field_set, sexp_list @ field_sexp)) + fields (LSet.empty, []) in (list sexp, lset) - | Pointer (l, u) -> - let l_sexp, l_set = of_typ l in - let u_sexp, u_set = of_typ u in + | Pointer { lower; upper } -> + let l_sexp, l_set = of_typ lower in + let u_sexp, u_set = of_typ upper in (list [ l_sexp; u_sexp ], LSet.union l_set u_set) | Types.Unit -> (atom "Unit", LSet.singleton DT) | Types.Top -> (atom "Any", LSet.singleton DT) diff --git a/lib/lang/interp.ml b/lib/lang/interp.ml index c0da070e..29d6c170 100644 --- a/lib/lang/interp.ml +++ b/lib/lang/interp.ml @@ -34,11 +34,11 @@ module IValue = struct | `Integer v -> Bitvec.create ~size:int_size v | `Bool true -> Bitvec.create ~size:8 Z.one | `Bool false -> Bitvec.create ~size:8 Z.zero - | `Pointer bv -> bv + | `Pointer (bv, _) -> bv | `Record fields -> - List.fold_left - (fun acc ({ value; _ } : Record.field) -> Bitvec.concat acc value) - Bitvec.empty fields + ZMap.fold + (fun _ ({ value; _ } : Record.field) acc -> Bitvec.concat acc value) + fields Bitvec.empty let of_constant (v : Ops.AllOps.const) = let open Expr.BasilExpr in @@ -47,7 +47,7 @@ module IValue = struct | `Bitvector bv -> bv_value bv | `Integer v -> int_value v | `Bool b -> if b then true_value else false_value - | `Pointer bv -> bv_value bv + | `Pointer (bv, _) -> bv_value bv | `Record fields -> bv_value @@ bv_of_constant v (** conversion to basil values *) diff --git a/lib/lang/ops.ml b/lib/lang/ops.ml index 99e34552..2ddd1af3 100644 --- a/lib/lang/ops.ml +++ b/lib/lang/ops.ml @@ -222,7 +222,7 @@ module RecordOps = struct end module PointerOps = struct - type const = [ `Pointer of Bitvec.t ] + type const = [ `Pointer of Bitvec.t * Types.pointer ] [@@deriving show { with_path = false }, eq, ord] type binary = [ `PTRADD | `PTRSUB ] @@ -296,6 +296,10 @@ module AllOps = struct | `Bool _ -> return Boolean | `Integer _ -> return Integer | `Bitvector v -> return (Bitvector (Bitvec.size v)) + | `Pointer (v, ty) -> return (Pointer ty) + | `Record fields -> + return + @@ Record (ZMap.map (fun ({ value; typ } : Record.field) -> typ) fields) let ret_type_unary (o : [< unary ]) a = let open Types in @@ -423,7 +427,9 @@ module AllOps = struct | `BVAND -> "bvand" | `INTMUL -> "intmul" | `Bitvector z -> Bitvec.to_string z - | `Pointer z -> "ptr:" ^ Bitvec.to_string z + | `Pointer (value, typ) -> + Printf.sprintf "ptr(%s, %s)" (Bitvec.show value) + (Types.show_pointer typ) | `Record fields -> Record.to_string fields | `BVSMOD -> "bvsmod" | `INTLT -> "intlt" diff --git a/lib/loadir.ml b/lib/loadir.ml index f7c7f933..34619465 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -438,14 +438,13 @@ module BasilASTLoader = struct Types.mk_field (unsafe_unsigil (`Local id)) (trans_type ty) and transRECORDTYPE (fields : field list) = Types.Record - (List.map - (function - | Field1 (offset, t) -> - ({ offset = transIntVal offset; t = trans_type t } : Types.field2)) - fields) + (ZMap.of_list + ((List.map (function Field1 (offset, t) -> + (transIntVal offset, trans_type t))) + fields)) and transPOINTERTYPE (l : typeT) (u : typeT) = - Types.Pointer (trans_type l, trans_type u) + Types.Pointer { lower = trans_type l; upper = trans_type u } and trans_type (x : typeT) : Types.t = match x with @@ -869,15 +868,18 @@ module BasilASTLoader = struct | Value_Int intval -> `Integer (transIntVal intval) | Value_True -> `Bool true | Value_False -> `Bool false - | Value_Pointer v -> `Pointer (trans_bv_val v) + | Value_Pointer (_, v, PointerType1 (_, l, u, _), _) -> + `Pointer (trans_bv_val v, { lower = trans_type l; upper = trans_type u }) | Value_Record (_, fields, _) -> `Record - (List.map - (function - | FieldVal1 (offset, value) -> - ({ offset = transIntVal offset; value = trans_bv_val value } - : Record.field)) - fields) + (ZMap.of_list + (List.map + (function + | FieldVal1 (_, offset, value, typ, _) -> + ( transIntVal offset, + ({ value = trans_bv_val value; typ = trans_type typ } + : Record.field) )) + fields)) and unsafe_unsigil g : string = match g with diff --git a/lib/util/common.ml b/lib/util/common.ml index bcf34315..bec97272 100644 --- a/lib/util/common.ml +++ b/lib/util/common.ml @@ -36,6 +36,7 @@ module Var = Var module ID = ID module IDMap = Map.Make (ID) module VarMap = Map.Make (Var) +module ZMap = Map.Make (Z) module IDSet = Set.Make (ID) module VarSet = Set.Make (Var) diff --git a/lib/util/record.ml b/lib/util/record.ml index 7f030600..9f95fb23 100644 --- a/lib/util/record.ml +++ b/lib/util/record.ml @@ -1,23 +1,25 @@ -type t = field list [@@deriving eq, ord] -and field = { offset : Z.t; value : Bitvec.t } +module ZMap = Map.Make (Z) -let get_field offset1 fields : Bitvec.t = - match List.find_opt (fun { offset; _ } -> Z.equal offset offset1) fields with - | None -> failwith @@ "No field at offset " ^ Z.to_string offset1 - | Some { value; _ } -> value +type t = field ZMap.t [@@deriving eq, ord] +and field = { value : Bitvec.t; typ : Types.t } -let set_field offset1 (value1 : Bitvec.t) fields : t = - List.map - (fun { offset; value } -> - if Z.equal offset offset1 then { offset; value = value1 } - else { offset; value }) - fields +let get_field offset record : field = + match ZMap.find_opt offset record with + | None -> failwith @@ "No field at offset " ^ Z.to_string offset + | Some f -> f -let show_field { offset; value } = - Z.to_string offset ^ " : " ^ Bitvec.to_string value +let set_field offset value record = + let { typ; _ } = get_field offset record in + ZMap.add offset { typ; value } record + +let show_field { value; typ } = + Bitvec.to_string value ^ " , " ^ Types.to_string typ let show (record : t) = - List.fold_left (fun acc field -> acc ^ show_field field ^ ", ") "" record + ZMap.fold + (fun offset field acc -> + acc ^ Z.to_string offset ^ " : " ^ show_field field ^ ", ") + record "" let to_string v = show v let pp fmt b = Format.pp_print_string fmt (show b) diff --git a/lib/util/types.ml b/lib/util/types.ml index cb07cb74..7cefeca1 100644 --- a/lib/util/types.ml +++ b/lib/util/types.ml @@ -1,4 +1,5 @@ open Containers +module ZMap = Map.Make (Z) (** This represents type right expressions (i.e. not declarations), we expand this in the future to allow declarations to be polymorphic. @@ -33,14 +34,19 @@ type t = | Nothing | Map of t * t | Sort of string * variant list - | Record of field2 list - | Pointer of t * t + | Record of t ZMap.t + | Pointer of pointer and variant = { variant : string; fields : field list } and field = { field : string; typ : t } [@@deriving eq, ord] - and field2 = { offset : Z.t; t : t } +(* + Lower type represents types the pointer could load + Upper type represents types the pointer could store +*) +and pointer = { lower : t; upper : t } [@@deriving eq, ord] + let bv i = Bitvector i let int = Integer let bool = Boolean @@ -78,11 +84,9 @@ let mk_adt name (variants : (string * field list) list) = let get_field offset1 record : t = match record with | Record fields -> ( - match - List.find_opt (fun { offset; _ } -> Z.equal offset offset1) fields - with + match ZMap.find_opt offset1 fields with | None -> failwith @@ "No field at offset " ^ Z.to_string offset1 - | Some { t; _ } -> t) + | Some t -> t) | _ -> failwith "Not record type" (* @@ -98,13 +102,15 @@ let rec compare_partial (a : t) (b : t) = | _, Nothing -> Some 1 | Unit, _ -> Some (-1) | _, Unit -> Some 1 - | Pointer (l, u), Pointer (l2, u2) -> ( - compare_partial l l2 |> function Some 0 -> compare_partial u u2 | o -> o) + | Pointer { lower; upper }, Pointer { lower = lower1; upper = upper1 } -> ( + compare_partial lower lower1 |> function + | Some 0 -> compare_partial upper upper1 + | o -> o) | Record fields, Record fields2 -> Some - (List.compare + (ZMap.compare (fun a b -> - match field_equal_partial a b with Some a -> a | None -> -1) + match compare_partial a b with Some a -> a | None -> -1) fields fields2) | Bitvector a, Bitvector b -> Some (Int.compare a b) | Sort (n1, _), Sort (n2, _) -> if String.equal n1 n2 then Some 0 else None @@ -113,9 +119,6 @@ let rec compare_partial (a : t) (b : t) = compare_partial k k2 |> function Some 0 -> compare_partial v v2 | o -> o) | _, _ -> None -and field_equal_partial { offset; t } { offset = offset1; t = t1 } = - if Z.compare offset1 offset <> 0 then compare_partial t t1 else Some 0 - let leq a b = compare_partial a b |> function Some a when a <= 0 -> true | _ -> false @@ -136,12 +139,13 @@ let rec to_string = function | Unit -> "()" | Top -> "⊤" | Nothing -> "⊥" - | Pointer (l, u) -> Printf.sprintf "ptr(%s, %s)" (to_string l) (to_string u) + | Pointer { lower; upper } -> + Printf.sprintf "ptr(%s, %s)" (to_string lower) (to_string upper) | Record fields -> - List.fold_left - (fun acc { offset; t } -> + ZMap.fold + (fun offset t acc -> acc ^ Printf.sprintf "%s : %s," (Z.to_string offset) (to_string t)) - "{" fields + fields "{" ^ "}" | Map ((Map _ as a), (Map _ as b)) -> "(" ^ "(" ^ to_string a ^ ")" ^ "->" ^ "(" ^ to_string b ^ ")" ^ ")" @@ -187,10 +191,18 @@ let%expect_test "dtp" = in print_endline @@ to_string lst; print_endline @@ to_string rc; - [%expect {| + [%expect + {| list = cons of {head: E; tail: list} | nil recs = Recordrecs of {a: bv12; b: bool} |}] let show (b : t) = to_string b + +let show_pointer { lower; upper } = + Printf.sprintf "{ lower = %s; upper = %s }" (show lower) (show upper) + let pp fmt b = Format.pp_print_string fmt (show b) + +let pp_pointer fmt { lower; upper } = + Format.fprintf fmt "{ lower = %s; upper = %s }" (show lower) (show upper) From d94a2d3106e7ecf44d1917a6d10c5bf405ac538a Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Fri, 6 Mar 2026 14:00:04 +1000 Subject: [PATCH 09/29] Finishes of eval functions --- lib/lang/expr_eval.ml | 2 +- lib/lang/ops.ml | 15 ++++++++++++--- lib/util/record.ml | 2 +- 3 files changed, 14 insertions(+), 5 deletions(-) diff --git a/lib/lang/expr_eval.ml b/lib/lang/expr_eval.ml index fd1fc0b0..63aa7d3b 100644 --- a/lib/lang/expr_eval.ml +++ b/lib/lang/expr_eval.ml @@ -40,7 +40,7 @@ let eval_expr_alg (e : Ops.AllOps.const option BasilExpr.abstract_expr) = | BinaryExpr { op = `FSET offset; arg1 = a; arg2 = b } -> let* a = get_record a in let* b = get_bv b in - record (Record.set_field offset b a) + record (Record.set_field offset a b) | UnaryExpr { op = `FACCESS offset; arg = a } -> let* a = get_record a in let { value; _ } : Record.field = Record.get_field offset a in diff --git a/lib/lang/ops.ml b/lib/lang/ops.ml index 2ddd1af3..2025fbb1 100644 --- a/lib/lang/ops.ml +++ b/lib/lang/ops.ml @@ -213,8 +213,15 @@ module RecordOps = struct | `FACCESS offset -> "`FACCESS " ^ Z.to_string offset let show_binary = function `FSET offset -> "`FSET " ^ Z.to_string offset - let eval_unary (u : unary) = failwith "TODO" - let eval_unary (u : binary) = failwith "TODO" + + let eval_unary (u : unary) record = + match u with + | `FACCESS offset -> + let { value; _ } : Record.field = Record.get_field offset record in + value + + let eval_binary (u : binary) = + match u with `FSET offset -> Record.set_field offset let show = function | #unary as u -> show_unary u @@ -228,7 +235,9 @@ module PointerOps = struct type binary = [ `PTRADD | `PTRSUB ] [@@deriving show { with_path = false }, eq, ord] - let eval_binary (u : binary) = failwith "TODO" + let eval_binary (u : binary) (bv, _) = + match u with `PTRADD -> Bitvec.add bv | `PTRSUB -> Bitvec.sub bv + let show = function #binary as u -> show_binary u end diff --git a/lib/util/record.ml b/lib/util/record.ml index 9f95fb23..2350799e 100644 --- a/lib/util/record.ml +++ b/lib/util/record.ml @@ -8,7 +8,7 @@ let get_field offset record : field = | None -> failwith @@ "No field at offset " ^ Z.to_string offset | Some f -> f -let set_field offset value record = +let set_field offset record value = let { typ; _ } = get_field offset record in ZMap.add offset { typ; value } record From d5d4dfec31709df0b597b116487e8a0e3acd0220 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Fri, 6 Mar 2026 14:51:14 +1000 Subject: [PATCH 10/29] test code and correct prints --- lib/fe/AbsBasilIR.ml | 2 +- lib/fe/BasilIR.cf | 4 ++-- lib/fe/LexBasilIR.mll | 2 +- lib/fe/ParBasilIR.mly | 6 +++--- lib/fe/PrintBasilIR.ml | 4 ++-- lib/fe/ShowBasilIR.ml | 2 +- lib/fe/SkelBasilIR.ml | 2 +- lib/lang/expr.ml | 14 ++++++++++++++ lib/lang/ops.ml | 7 +------ lib/loadir.ml | 2 +- lib/util/record.ml | 2 +- lib/util/types.ml | 2 +- test/cram/dune | 1 + test/cram/roundtrip.sexp | 5 +++++ test/cram/roundtrip.t | 5 +++++ 15 files changed, 40 insertions(+), 20 deletions(-) diff --git a/lib/fe/AbsBasilIR.ml b/lib/fe/AbsBasilIR.ml index d869706a..6652cef4 100644 --- a/lib/fe/AbsBasilIR.ml +++ b/lib/fe/AbsBasilIR.ml @@ -50,7 +50,7 @@ and procDef = | ProcDef_Some of beginList * block list * endList and field = - Field1 of intVal * typeT + Field1 of openParen * intVal * typeT * closeParen and intType = IntType1 of iNTTYPE diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index 5efcf816..bc88abe9 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -73,7 +73,7 @@ ProcDef_Empty . ProcDef ::= ; ProcDef_Some . ProcDef ::= BeginList [Block] EndList ; separator Field "," ; -Field1 . Field ::= IntVal ":" Type ; +Field1 . Field ::= OpenParen IntVal ":" Type CloseParen ; IntType1 . IntType ::= INTTYPE ; BoolType1. BoolType ::= BOOLTYPE ; @@ -273,7 +273,7 @@ Expr_SignExtend . Expr2 ::= "sign_extend" OpenParen IntVal "," Expr CloseParen ; Expr_Extract . Expr2 ::= "extract" OpenParen IntVal "," IntVal "," Expr CloseParen ; Expr_Concat . Expr2 ::= "bvconcat" OpenParen [Expr] CloseParen ; Expr_FSet . Expr ::= "fset" OpenParen IntVal "," Expr "," Expr CloseParen ; -Expr_FAccess . Expr ::= "facces" OpenParen IntVal "," Expr CloseParen ; +Expr_FAccess . Expr ::= "faccess" OpenParen IntVal "," Expr CloseParen ; CaseCase . Case ::= Expr "->" Expr ; CaseDefault . Case ::= "_" "->" Expr ; diff --git a/lib/fe/LexBasilIR.mll b/lib/fe/LexBasilIR.mll index 55359052..bd5112aa 100644 --- a/lib/fe/LexBasilIR.mll +++ b/lib/fe/LexBasilIR.mll @@ -13,7 +13,7 @@ let _ = List.iter (fun (kwd, tok) -> Hashtbl.add symbol_table kwd tok) let resword_table = Hashtbl.create 106 let _ = List.iter (fun (kwd, tok) -> Hashtbl.add resword_table kwd tok) - [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("ptr", KW_ptr);("of", KW_of);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("old", KW_old);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("bvconcat", KW_bvconcat);("fset", KW_fset);("facces", KW_facces);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvmul", KW_bvmul);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxor", KW_bvxor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("boolimplies", KW_boolimplies);("ptradd", KW_ptradd);("ptrsub", KW_ptrsub);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] + [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("ptr", KW_ptr);("of", KW_of);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("old", KW_old);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("bvconcat", KW_bvconcat);("fset", KW_fset);("faccess", KW_faccess);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvmul", KW_bvmul);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxor", KW_bvxor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("boolimplies", KW_boolimplies);("ptradd", KW_ptradd);("ptrsub", KW_ptrsub);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] let unescapeInitTail (s:string) : string = let rec unesc s = match s with diff --git a/lib/fe/ParBasilIR.mly b/lib/fe/ParBasilIR.mly index b36b1095..83f1525e 100644 --- a/lib/fe/ParBasilIR.mly +++ b/lib/fe/ParBasilIR.mly @@ -7,7 +7,7 @@ open AbsBasilIR open Lexing %} -%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_ptr KW_of KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_true KW_false KW_forall KW_exists KW_fun KW_old KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_bvconcat KW_fset KW_facces KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvand KW_bvor KW_bvadd KW_bvmul KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_boolimplies KW_ptradd KW_ptrsub KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant +%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_ptr KW_of KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_true KW_false KW_forall KW_exists KW_fun KW_old KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_bvconcat KW_fset KW_faccess KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvand KW_bvor KW_bvadd KW_bvmul KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_boolimplies KW_ptradd KW_ptrsub KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant %token SYMB1 /* ; */ %token SYMB2 /* , */ @@ -499,7 +499,7 @@ field_list : /* empty */ { [] } | field SYMB2 field_list { (fun (x,xs) -> x::xs) ($1, $3) } ; -field : intVal SYMB5 typeT { Field1 ($1, $3) } +field : openParen intVal SYMB5 typeT closeParen { Field1 ($1, $2, $4, $5) } ; intType : iNTTYPE { IntType1 $1 } @@ -747,7 +747,7 @@ expr : expr1 { $1 } | KW_exists attribSet lambdaDef { Expr_Exists ($2, $3) } | KW_fun attribSet lambdaDef { Expr_Lambda ($2, $3) } | KW_fset openParen intVal SYMB2 expr SYMB2 expr closeParen { Expr_FSet ($2, $3, $5, $7, $8) } - | KW_facces openParen intVal SYMB2 expr closeParen { Expr_FAccess ($2, $3, $5, $6) } + | KW_faccess openParen intVal SYMB2 expr closeParen { Expr_FAccess ($2, $3, $5, $6) } ; expr1 : expr2 { $1 } diff --git a/lib/fe/PrintBasilIR.ml b/lib/fe/PrintBasilIR.ml index 22f27729..9403c193 100644 --- a/lib/fe/PrintBasilIR.ml +++ b/lib/fe/PrintBasilIR.ml @@ -184,7 +184,7 @@ and prtProcDef (i:int) (e : AbsBasilIR.procDef) : doc = match e with and prtField (i:int) (e : AbsBasilIR.field) : doc = match e with - AbsBasilIR.Field1 (intval, type_) -> prPrec i 0 (concatD [prtIntVal 0 intval ; render ":" ; prtTypeT 0 type_]) + AbsBasilIR.Field1 (openparen, intval, type_, closeparen) -> prPrec i 0 (concatD [prtOpenParen 0 openparen ; prtIntVal 0 intval ; render ":" ; prtTypeT 0 type_ ; prtCloseParen 0 closeparen]) and prtFieldListBNFC i es : doc = match (i, es) with (_,[]) -> (concatD []) @@ -452,7 +452,7 @@ and prtExpr (i:int) (e : AbsBasilIR.expr) : doc = match e with | AbsBasilIR.Expr_Extract (openparen, intval1, intval2, expr, closeparen) -> prPrec i 2 (concatD [render "extract" ; prtOpenParen 0 openparen ; prtIntVal 0 intval1 ; render "," ; prtIntVal 0 intval2 ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Concat (openparen, exprs, closeparen) -> prPrec i 2 (concatD [render "bvconcat" ; prtOpenParen 0 openparen ; prtExprListBNFC 0 exprs ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_FSet (openparen, intval, expr1, expr2, closeparen) -> prPrec i 0 (concatD [render "fset" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr1 ; render "," ; prtExpr 0 expr2 ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_FAccess (openparen, intval, expr, closeparen) -> prPrec i 0 (concatD [render "facces" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_FAccess (openparen, intval, expr, closeparen) -> prPrec i 0 (concatD [render "faccess" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Match (expr, openparen, cases, closeparen) -> prPrec i 2 (concatD [render "match" ; prtExpr 0 expr ; render "with" ; prtOpenParen 0 openparen ; prtCaseListBNFC 0 cases ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Cases (openparen, cases, closeparen) -> prPrec i 2 (concatD [render "cases" ; prtOpenParen 0 openparen ; prtCaseListBNFC 0 cases ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Paren (openparen, expr, closeparen) -> prPrec i 2 (concatD [prtOpenParen 0 openparen ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) diff --git a/lib/fe/ShowBasilIR.ml b/lib/fe/ShowBasilIR.ml index 80bd2a9f..0439838d 100644 --- a/lib/fe/ShowBasilIR.ml +++ b/lib/fe/ShowBasilIR.ml @@ -95,7 +95,7 @@ and showProcDef (e : AbsBasilIR.procDef) : showable = match e with and showField (e : AbsBasilIR.field) : showable = match e with - AbsBasilIR.Field1 (intval, type') -> s2s "Field1" >> c2s ' ' >> c2s '(' >> showIntVal intval >> s2s ", " >> showTypeT type' >> c2s ')' + AbsBasilIR.Field1 (openparen, intval, type', closeparen) -> s2s "Field1" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval >> s2s ", " >> showTypeT type' >> s2s ", " >> showCloseParen closeparen >> c2s ')' and showIntType (e : AbsBasilIR.intType) : showable = match e with diff --git a/lib/fe/SkelBasilIR.ml b/lib/fe/SkelBasilIR.ml index f3ebaf88..06b59c86 100644 --- a/lib/fe/SkelBasilIR.ml +++ b/lib/fe/SkelBasilIR.ml @@ -118,7 +118,7 @@ and transProcDef (x : procDef) : result = match x with and transField (x : field) : result = match x with - Field1 (intval, type') -> failure x + Field1 (openparen, intval, type', closeparen) -> failure x and transIntType (x : intType) : result = match x with diff --git a/lib/lang/expr.ml b/lib/lang/expr.ml index 7db644e1..c3f93ad0 100644 --- a/lib/lang/expr.ml +++ b/lib/lang/expr.ml @@ -358,6 +358,20 @@ module BasilExpr = struct [ text "sign_extend" ^ a ^ (textpf "(%d") bits; arg ^ text ")" ] | UnaryExpr { op = `Extract (hi, lo); arg = e } -> fill nil [ text "extract" ^ a ^ textpf "(%d,%d, " hi lo ^ e ^ text ")" ] + | UnaryExpr { op = `FACCESS offset; arg } -> + fill + (text "," ^ newline) + [ + text "faccess" ^ a ^ (textpf "(%s") (Z.to_string offset); + arg ^ text ")"; + ] + | BinaryExpr { op = `FSET offset; arg1; arg2 } -> + fill + (text "," ^ newline) + [ + text "fset" ^ a ^ (textpf "(%s") (Z.to_string offset); + arg1 ^ arg2 ^ text ")"; + ] | UnaryExpr { op; arg = e } -> text (AllOps.to_string op) ^ a ^ bracket "(" e ")" | BinaryExpr { op = `Load (endian, bits); arg1; arg2 } -> diff --git a/lib/lang/ops.ml b/lib/lang/ops.ml index 2025fbb1..ff722274 100644 --- a/lib/lang/ops.ml +++ b/lib/lang/ops.ml @@ -209,11 +209,6 @@ module RecordOps = struct [@printer fun fmt m -> match m with `FSET offset -> Z.pp_print fmt offset]) [@@deriving show { with_path = false }, eq, ord] - let to_string_unary = function - | `FACCESS offset -> "`FACCESS " ^ Z.to_string offset - - let show_binary = function `FSET offset -> "`FSET " ^ Z.to_string offset - let eval_unary (u : unary) record = match u with | `FACCESS offset -> @@ -416,7 +411,7 @@ module AllOps = struct | `SignExtend n -> Printf.sprintf "sign_extend_%d" n | `ZeroExtend n -> Printf.sprintf "zero_extend_%d" n | `FSET offset -> Printf.sprintf "fset_%s" @@ Z.to_string offset - | `FACCESS offset -> Printf.sprintf "faccess_%s" @@ Z.to_string offset + | `FACCESS offset -> Printf.sprintf "asdfaccess_%s" @@ Z.to_string offset | `PTRADD -> "ptradd" | `PTRSUB -> "ptrsub" | `EQ -> "eq" diff --git a/lib/loadir.ml b/lib/loadir.ml index 34619465..c9093621 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -439,7 +439,7 @@ module BasilASTLoader = struct and transRECORDTYPE (fields : field list) = Types.Record (ZMap.of_list - ((List.map (function Field1 (offset, t) -> + ((List.map (function Field1 (_, offset, t, _) -> (transIntVal offset, trans_type t))) fields)) diff --git a/lib/util/record.ml b/lib/util/record.ml index 2350799e..18de04ff 100644 --- a/lib/util/record.ml +++ b/lib/util/record.ml @@ -13,7 +13,7 @@ let set_field offset record value = ZMap.add offset { typ; value } record let show_field { value; typ } = - Bitvec.to_string value ^ " , " ^ Types.to_string typ + Printf.sprintf "(%s, %s)" (Bitvec.to_string value) @@ Types.to_string typ let show (record : t) = ZMap.fold diff --git a/lib/util/types.ml b/lib/util/types.ml index 7cefeca1..9202106a 100644 --- a/lib/util/types.ml +++ b/lib/util/types.ml @@ -144,7 +144,7 @@ let rec to_string = function | Record fields -> ZMap.fold (fun offset t acc -> - acc ^ Printf.sprintf "%s : %s," (Z.to_string offset) (to_string t)) + acc ^ Printf.sprintf "(%s : %s)," (Z.to_string offset) (to_string t)) fields "{" ^ "}" | Map ((Map _ as a), (Map _ as b)) -> diff --git a/test/cram/dune b/test/cram/dune index 0ce781a2..09509e42 100644 --- a/test/cram/dune +++ b/test/cram/dune @@ -15,6 +15,7 @@ %{bin:bincaml} ssa-multi-deps.il memassign.il + ptrrec1.il ../../examples/irreducible_loop_1.il ../../examples/cat.il ../../examples/cntlm-output.il diff --git a/test/cram/roundtrip.sexp b/test/cram/roundtrip.sexp index 8ae5bb5a..545d40b3 100644 --- a/test/cram/roundtrip.sexp +++ b/test/cram/roundtrip.sexp @@ -11,3 +11,8 @@ (dump-il "beforemem.il") (load-il "beforemem.il") (dump-il "aftermem.il") + +(load-il "ptrrec1.il") +(dump-il "ptrrec2.il") +(load-il "ptrrec2.il") +(dump-il "ptrrec3.il") diff --git a/test/cram/roundtrip.t b/test/cram/roundtrip.t index dc4a8888..e95d4ea1 100644 --- a/test/cram/roundtrip.t +++ b/test/cram/roundtrip.t @@ -32,4 +32,9 @@ The serialise -> parse serialise loop should be idempotent Memassign repr $ diff beforemem.il aftermem.il + +Record and Pointer + + $ diff ptrrec1.il ptrrec2.il + $ diff ptrrec2.il ptrrec3.il From 4f680338cc67fc0e8326d4c6cf5c5c2235b635c1 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Fri, 6 Mar 2026 14:52:19 +1000 Subject: [PATCH 11/29] add test file --- test/cram/ptrrec1.il | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 test/cram/ptrrec1.il diff --git a/test/cram/ptrrec1.il b/test/cram/ptrrec1.il new file mode 100644 index 00000000..4f422e55 --- /dev/null +++ b/test/cram/ptrrec1.il @@ -0,0 +1,22 @@ +var $rec:{(0 : bv32),}; +prog entry @main_4196164; +proc @main_4196164(R0_in:bv64, R10_in:bv64, R11_in:bv64, R12_in:bv64, R13_in:bv64, + R14_in:bv64, R15_in:bv64, R16_in:bv64, R17_in:bv64, R18_in:bv64, R1_in:bv64, + R29_in:bv64, R2_in:bv64, R30_in:bv64, R31_in:bv64, R3_in:bv64, R4_in:bv64, + R5_in:bv64, R6_in:bv64, R7_in:bv64, R8_in:bv64, R9_in:bv64, _PC_in:bv64) + -> (R0_out:bv64, R1_out:bv64) { .address = 4196164; .name = "main"; + .returnBlock = "main_return" } + captures $rec:{(0 : bv32),}; + +[ + block %main_entry [ + var as:ptr(bv64, bv64) := ptradd(R31_in:bv64, R0_in:bv64); + var ad:ptr(bv64, bv64) := ptrsub(R31_in:bv64, R0_in:bv64); + var af:bv32 := faccess(0, $rec:{(0 : bv32),}); + goto (%main_return); + ]; + block %main_return [ + (var R0_out:bv64 := 0x0:bv64, var R1_out:bv64 := 0x2a:bv64); + return; + ] +]; \ No newline at end of file From ba4fd6f4614be6e9e7bb5db7f32ef3d32cdc00dd Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Fri, 6 Mar 2026 14:55:34 +1000 Subject: [PATCH 12/29] fix fset printer and add final test --- lib/lang/expr.ml | 2 +- test/cram/ptrrec1.il | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/lang/expr.ml b/lib/lang/expr.ml index c3f93ad0..0708c71f 100644 --- a/lib/lang/expr.ml +++ b/lib/lang/expr.ml @@ -370,7 +370,7 @@ module BasilExpr = struct (text "," ^ newline) [ text "fset" ^ a ^ (textpf "(%s") (Z.to_string offset); - arg1 ^ arg2 ^ text ")"; + arg1 ^ text ", " ^ arg2 ^ text ")"; ] | UnaryExpr { op; arg = e } -> text (AllOps.to_string op) ^ a ^ bracket "(" e ")" diff --git a/test/cram/ptrrec1.il b/test/cram/ptrrec1.il index 4f422e55..20867314 100644 --- a/test/cram/ptrrec1.il +++ b/test/cram/ptrrec1.il @@ -6,6 +6,7 @@ proc @main_4196164(R0_in:bv64, R10_in:bv64, R11_in:bv64, R12_in:bv64, R13_in:bv6 R5_in:bv64, R6_in:bv64, R7_in:bv64, R8_in:bv64, R9_in:bv64, _PC_in:bv64) -> (R0_out:bv64, R1_out:bv64) { .address = 4196164; .name = "main"; .returnBlock = "main_return" } + modifies $rec:{(0 : bv32),}; captures $rec:{(0 : bv32),}; [ @@ -13,6 +14,7 @@ proc @main_4196164(R0_in:bv64, R10_in:bv64, R11_in:bv64, R12_in:bv64, R13_in:bv6 var as:ptr(bv64, bv64) := ptradd(R31_in:bv64, R0_in:bv64); var ad:ptr(bv64, bv64) := ptrsub(R31_in:bv64, R0_in:bv64); var af:bv32 := faccess(0, $rec:{(0 : bv32),}); + $rec:{(0 : bv32),} := fset(0, $rec:{(0 : bv32),}, af:bv32); goto (%main_return); ]; block %main_return [ From 88b94bc1280db434b6b8e6c8cbaa8ed9c00d31e8 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Fri, 6 Mar 2026 15:48:26 +1000 Subject: [PATCH 13/29] move record and remove smt --- lib/analysis/defuse_bool.ml | 2 +- lib/lang/dune | 3 ++- lib/lang/expr_smt.ml | 23 +---------------------- lib/{util => lang}/record.ml | 9 ++++----- lib/util/common.ml | 1 - lib/util/dune | 1 - 6 files changed, 8 insertions(+), 31 deletions(-) rename lib/{util => lang}/record.ml (80%) diff --git a/lib/analysis/defuse_bool.ml b/lib/analysis/defuse_bool.ml index 8aa8f03d..55dbc7bd 100644 --- a/lib/analysis/defuse_bool.ml +++ b/lib/analysis/defuse_bool.ml @@ -46,7 +46,7 @@ module IsZeroValueAbstraction = struct else NonZero | `Record fields -> ZMap.fold - (fun _ ({ value = i; _ } : Record.field) acc -> + (fun _ ({ value = i; _ } : Lang.Record.field) acc -> if Bitvec.size i = 0 then Top else if Z.equal Z.zero (Bitvec.value i) then join acc Zero else join acc NonZero) diff --git a/lib/lang/dune b/lib/lang/dune index 9f22039b..f48c5f4c 100644 --- a/lib/lang/dune +++ b/lib/lang/dune @@ -14,7 +14,8 @@ block procedure interp - program) + program + record) (flags -w -27) ; unused var (libraries zarith diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 17481822..fa02d9a0 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -3,7 +3,7 @@ open Expr open CCSexp module SMTLib2 = struct - type logic = UF | Int | Prop | BV | Record | Array | DT [@@deriving ord] + type logic = UF | Int | Prop | BV | Array | DT [@@deriving ord] module LSet = Set.Make (struct type t = logic @@ -99,24 +99,6 @@ module SMTLib2 = struct | Bitvector i -> ( list [ atom "_"; atom "BitVec"; atom @@ Int.to_string i ], LSet.singleton BV ) - | Record fields -> - (* Each field in record has two atoms? Offset, type *) - let of_field offset t = - let t_sexp, t_set = of_typ t in - ([ atom @@ Z.to_string offset; t_sexp ], t_set) - in - let lset, sexp = - ZMap.fold - (fun offset t (set, sexp_list) -> - let field_sexp, field_set = of_field offset t in - (LSet.union set field_set, sexp_list @ field_sexp)) - fields (LSet.empty, []) - in - (list sexp, lset) - | Pointer { lower; upper } -> - let l_sexp, l_set = of_typ lower in - let u_sexp, u_set = of_typ upper in - (list [ l_sexp; u_sexp ], LSet.union l_set u_set) | Types.Unit -> (atom "Unit", LSet.singleton DT) | Types.Top -> (atom "Any", LSet.singleton DT) | Types.Nothing -> (atom "Nothing", LSet.singleton DT) @@ -143,9 +125,6 @@ module SMTLib2 = struct | `Bitvector _ -> add_logic BV | `Integer _ -> add_logic Int | `Bool _ -> return () - (* NOTE: Will need some help here *) - | `Record _ -> add_logic Record - | `Pointer _ -> add_logic BV in return v diff --git a/lib/util/record.ml b/lib/lang/record.ml similarity index 80% rename from lib/util/record.ml rename to lib/lang/record.ml index 18de04ff..bce9c72d 100644 --- a/lib/util/record.ml +++ b/lib/lang/record.ml @@ -1,4 +1,4 @@ -module ZMap = Map.Make (Z) +open Bincaml_util.Common type t = field ZMap.t [@@deriving eq, ord] and field = { value : Bitvec.t; typ : Types.t } @@ -16,10 +16,9 @@ let show_field { value; typ } = Printf.sprintf "(%s, %s)" (Bitvec.to_string value) @@ Types.to_string typ let show (record : t) = - ZMap.fold - (fun offset field acc -> - acc ^ Z.to_string offset ^ " : " ^ show_field field ^ ", ") - record "" + record |> ZMap.bindings + |> List.map (fun (k, v) -> Z.to_string k ^ ": " ^ show_field v) + |> String.concat ", " let to_string v = show v let pp fmt b = Format.pp_print_string fmt (show b) diff --git a/lib/util/common.ml b/lib/util/common.ml index bec97272..d688f3cb 100644 --- a/lib/util/common.ml +++ b/lib/util/common.ml @@ -44,7 +44,6 @@ module VarSet = Set.Make (Var) module Bitvec = Bitvec module PrimInt = Zint -module Record = Record let disable_backtrace_in f = let old = Printexc.backtrace_status () in diff --git a/lib/util/dune b/lib/util/dune index b82d4f73..0b987b7c 100644 --- a/lib/util/dune +++ b/lib/util/dune @@ -10,7 +10,6 @@ ID types bitvec - record zint smt reverse_graph From a8cdd0e696a100e01d9fa988f3ee1c117ab9bdd0 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Fri, 6 Mar 2026 15:49:56 +1000 Subject: [PATCH 14/29] fix failing test --- test/cram/roundtrip.t | 1 - 1 file changed, 1 deletion(-) diff --git a/test/cram/roundtrip.t b/test/cram/roundtrip.t index e95d4ea1..f8eb95bc 100644 --- a/test/cram/roundtrip.t +++ b/test/cram/roundtrip.t @@ -32,7 +32,6 @@ The serialise -> parse serialise loop should be idempotent Memassign repr $ diff beforemem.il aftermem.il - Record and Pointer $ diff ptrrec1.il ptrrec2.il From 1aaec04623d328b7919313fd6159be6585a89269 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Fri, 6 Mar 2026 16:13:15 +1000 Subject: [PATCH 15/29] change both prints --- lib/analysis/defuse_bool.ml | 2 +- lib/lang/attrib.ml | 4 ++-- lib/lang/interp.ml | 3 ++- lib/lang/ops.ml | 30 +++++++++++++++++++++++++++++- lib/lang/record.ml | 24 ------------------------ lib/loadir.ml | 2 +- lib/util/types.ml | 11 ++++++----- test/cram/ptrrec1.il | 4 ++-- 8 files changed, 43 insertions(+), 37 deletions(-) delete mode 100644 lib/lang/record.ml diff --git a/lib/analysis/defuse_bool.ml b/lib/analysis/defuse_bool.ml index 55dbc7bd..f2b78221 100644 --- a/lib/analysis/defuse_bool.ml +++ b/lib/analysis/defuse_bool.ml @@ -46,7 +46,7 @@ module IsZeroValueAbstraction = struct else NonZero | `Record fields -> ZMap.fold - (fun _ ({ value = i; _ } : Lang.Record.field) acc -> + (fun _ ({ value = i; _ } : Lang.Ops.Record.field) acc -> if Bitvec.size i = 0 then Top else if Z.equal Z.zero (Bitvec.value i) then join acc Zero else join acc NonZero) diff --git a/lib/lang/attrib.ml b/lib/lang/attrib.ml index 0acda433..60c67410 100644 --- a/lib/lang/attrib.ml +++ b/lib/lang/attrib.ml @@ -10,7 +10,7 @@ type 'e t = | `Integer of Z.t | `CamlInt of int | `Bitvector of Bitvec.t - | `Record of Record.t + | `Record of Ops.Record.t | `Pointer of Bitvec.t * Types.pointer | `List of 'e t list ] [@@deriving eq, ord] @@ -29,7 +29,7 @@ let rec attrib_pretty ?(internal = [ location_key ]) pretty_expr (e : 'e t) : | `Bitvector bv -> text @@ Bitvec.to_string bv | `Pointer (bv, typ) -> text (String.cat (Bitvec.to_string bv) @@ Types.show_pointer typ) - | `Record record -> text @@ Record.to_string record + | `Record record -> text @@ Ops.Record.to_string record | `Integer bv -> text @@ Z.to_string bv | `List s -> nest 2 diff --git a/lib/lang/interp.ml b/lib/lang/interp.ml index 29d6c170..61540e19 100644 --- a/lib/lang/interp.ml +++ b/lib/lang/interp.ml @@ -37,7 +37,8 @@ module IValue = struct | `Pointer (bv, _) -> bv | `Record fields -> ZMap.fold - (fun _ ({ value; _ } : Record.field) acc -> Bitvec.concat acc value) + (fun _ ({ value; _ } : Ops.Record.field) acc -> + Bitvec.concat acc value) fields Bitvec.empty let of_constant (v : Ops.AllOps.const) = diff --git a/lib/lang/ops.ml b/lib/lang/ops.ml index ff722274..1563b2e9 100644 --- a/lib/lang/ops.ml +++ b/lib/lang/ops.ml @@ -1,6 +1,34 @@ open Common open Containers +module Record = struct + type t = field ZMap.t [@@deriving eq, ord] + and field = { value : Bitvec.t; typ : Types.t } + + let get_field offset record : field = + match ZMap.find_opt offset record with + | None -> failwith @@ "No field at offset " ^ Z.to_string offset + | Some f -> f + + let set_field offset record value = + let { typ; _ } = get_field offset record in + ZMap.add offset { typ; value } record + + let show_field { value; typ } = + Printf.sprintf "(%s, %s)" (Bitvec.to_string value) @@ Types.to_string typ + + let show (record : t) = + "{" + ^ (ZMap.bindings record + |> List.map (fun (k, v) -> + "(" ^ Z.to_string k ^ ": " ^ show_field v ^ ")") + |> String.concat ", ") + ^ "}" + + let to_string v = show v + let pp fmt b = Format.pp_print_string fmt (show b) +end + module Maps = struct (* map, value -> result *) @@ -434,7 +462,7 @@ module AllOps = struct | `Pointer (value, typ) -> Printf.sprintf "ptr(%s, %s)" (Bitvec.show value) (Types.show_pointer typ) - | `Record fields -> Record.to_string fields + | `Record record -> Record.to_string record | `BVSMOD -> "bvsmod" | `INTLT -> "intlt" | `IMPLIES -> "implies" diff --git a/lib/lang/record.ml b/lib/lang/record.ml deleted file mode 100644 index bce9c72d..00000000 --- a/lib/lang/record.ml +++ /dev/null @@ -1,24 +0,0 @@ -open Bincaml_util.Common - -type t = field ZMap.t [@@deriving eq, ord] -and field = { value : Bitvec.t; typ : Types.t } - -let get_field offset record : field = - match ZMap.find_opt offset record with - | None -> failwith @@ "No field at offset " ^ Z.to_string offset - | Some f -> f - -let set_field offset record value = - let { typ; _ } = get_field offset record in - ZMap.add offset { typ; value } record - -let show_field { value; typ } = - Printf.sprintf "(%s, %s)" (Bitvec.to_string value) @@ Types.to_string typ - -let show (record : t) = - record |> ZMap.bindings - |> List.map (fun (k, v) -> Z.to_string k ^ ": " ^ show_field v) - |> String.concat ", " - -let to_string v = show v -let pp fmt b = Format.pp_print_string fmt (show b) diff --git a/lib/loadir.ml b/lib/loadir.ml index c9093621..17110154 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -878,7 +878,7 @@ module BasilASTLoader = struct | FieldVal1 (_, offset, value, typ, _) -> ( transIntVal offset, ({ value = trans_bv_val value; typ = trans_type typ } - : Record.field) )) + : Ops.Record.field) )) fields)) and unsafe_unsigil g : string = diff --git a/lib/util/types.ml b/lib/util/types.ml index 9202106a..54a5e26a 100644 --- a/lib/util/types.ml +++ b/lib/util/types.ml @@ -141,11 +141,12 @@ let rec to_string = function | Nothing -> "⊥" | Pointer { lower; upper } -> Printf.sprintf "ptr(%s, %s)" (to_string lower) (to_string upper) - | Record fields -> - ZMap.fold - (fun offset t acc -> - acc ^ Printf.sprintf "(%s : %s)," (Z.to_string offset) (to_string t)) - fields "{" + | Record record -> + "{" + ^ (ZMap.bindings record + |> List.map (fun (k, v) -> + "(" ^ Z.to_string k ^ ": " ^ to_string v ^ ")") + |> String.concat ", ") ^ "}" | Map ((Map _ as a), (Map _ as b)) -> "(" ^ "(" ^ to_string a ^ ")" ^ "->" ^ "(" ^ to_string b ^ ")" ^ ")" diff --git a/test/cram/ptrrec1.il b/test/cram/ptrrec1.il index 20867314..a680d098 100644 --- a/test/cram/ptrrec1.il +++ b/test/cram/ptrrec1.il @@ -1,4 +1,4 @@ -var $rec:{(0 : bv32),}; +var $rec:{(0 : bv32)}; prog entry @main_4196164; proc @main_4196164(R0_in:bv64, R10_in:bv64, R11_in:bv64, R12_in:bv64, R13_in:bv64, R14_in:bv64, R15_in:bv64, R16_in:bv64, R17_in:bv64, R18_in:bv64, R1_in:bv64, @@ -21,4 +21,4 @@ proc @main_4196164(R0_in:bv64, R10_in:bv64, R11_in:bv64, R12_in:bv64, R13_in:bv6 (var R0_out:bv64 := 0x0:bv64, var R1_out:bv64 := 0x2a:bv64); return; ] -]; \ No newline at end of file +]; From 9d367fd3a72df164161a435ba4b94a12ddff335e Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Mon, 9 Mar 2026 09:59:51 +1000 Subject: [PATCH 16/29] forgor --- lib/lang/dune | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lib/lang/dune b/lib/lang/dune index f48c5f4c..9f22039b 100644 --- a/lib/lang/dune +++ b/lib/lang/dune @@ -14,8 +14,7 @@ block procedure interp - program - record) + program) (flags -w -27) ; unused var (libraries zarith From 000fd00ceadb4daa6d266d008a5368e07a5bab9f Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Mon, 9 Mar 2026 10:15:47 +1000 Subject: [PATCH 17/29] remove ptrsub --- lib/analysis/defuse_bool.ml | 2 -- lib/analysis/wrapped_intervals.ml | 2 +- lib/fe/AbsBasilIR.ml | 1 - lib/fe/BasilIR.cf | 2 +- lib/fe/LexBasilIR.mll | 4 ++-- lib/fe/ParBasilIR.mly | 3 +-- lib/fe/PrintBasilIR.ml | 1 - lib/fe/ShowBasilIR.ml | 1 - lib/fe/SkelBasilIR.ml | 1 - lib/lang/expr_eval.ml | 4 ---- lib/lang/ops.ml | 9 +++------ lib/loadir.ml | 1 - lib/transforms/type_check.ml | 2 +- 13 files changed, 9 insertions(+), 24 deletions(-) diff --git a/lib/analysis/defuse_bool.ml b/lib/analysis/defuse_bool.ml index f2b78221..7709f9f0 100644 --- a/lib/analysis/defuse_bool.ml +++ b/lib/analysis/defuse_bool.ml @@ -74,10 +74,8 @@ module IsZeroValueAbstraction = struct | `BVSDIV, _, _ -> Top | `BVADD, Zero, Zero -> Zero | `PTRADD, Zero, Zero -> Zero - | `PTRSUB, Zero, Zero -> Zero | `BVADD, _, _ -> Top | `PTRADD, _, _ -> Top - | `PTRSUB, _, _ -> Top | `NEQ, Zero, Zero -> Zero | `NEQ, _, _ -> Top | `BVASHR, _, _ -> Top diff --git a/lib/analysis/wrapped_intervals.ml b/lib/analysis/wrapped_intervals.ml index bb339cb4..ae4f8e0b 100644 --- a/lib/analysis/wrapped_intervals.ml +++ b/lib/analysis/wrapped_intervals.ml @@ -719,7 +719,7 @@ module WrappedIntervalsValueAbstraction = struct | Types.Bitvector width, Types.Bitvector w2 when width = w2 -> ( match op with | `BVADD | `PTRADD -> add ~width a b - | `BVSUB | `PTRSUB -> sub ~width a b + | `BVSUB -> sub ~width a b | `BVMUL -> mul ~width a b | `BVUDIV -> udiv ~width a b | `BVSDIV -> sdiv ~width a b diff --git a/lib/fe/AbsBasilIR.ml b/lib/fe/AbsBasilIR.ml index 6652cef4..0acf04af 100644 --- a/lib/fe/AbsBasilIR.ml +++ b/lib/fe/AbsBasilIR.ml @@ -311,7 +311,6 @@ and boolBinOp = and pointerBinOp = PointerBinOp_ptradd - | PointerBinOp_ptrsub and requireTok = RequireTok_require diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index bc88abe9..de657662 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -294,7 +294,7 @@ rules BVLogicalBinOp ::= "bvule" | "bvugt" | "bvuge" | "bvult" | "bvslt" | "b rules IntBinOp ::= "intadd" | "intmul" | "intsub" | "intdiv" | "intmod" ; rules IntLogicalBinOp ::= "intlt" | "intle" | "intgt" | "intge" ; rules BoolBinOp ::= "booland" | "boolor" | "boolimplies" ; -rules PointerBinOp ::= "ptradd" | "ptrsub" ; +rules PointerBinOp ::= "ptradd" ; {- SPECIFICATION -} diff --git a/lib/fe/LexBasilIR.mll b/lib/fe/LexBasilIR.mll index bd5112aa..0b86baa4 100644 --- a/lib/fe/LexBasilIR.mll +++ b/lib/fe/LexBasilIR.mll @@ -11,9 +11,9 @@ let symbol_table = Hashtbl.create 10 let _ = List.iter (fun (kwd, tok) -> Hashtbl.add symbol_table kwd tok) [(";", SYMB1);(",", SYMB2);("->", SYMB3);("::", SYMB4);(":", SYMB5);("=", SYMB6);("|", SYMB7);(":=", SYMB8);("mem:=", SYMB9);("_", SYMB10)] -let resword_table = Hashtbl.create 106 +let resword_table = Hashtbl.create 105 let _ = List.iter (fun (kwd, tok) -> Hashtbl.add resword_table kwd tok) - [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("ptr", KW_ptr);("of", KW_of);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("old", KW_old);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("bvconcat", KW_bvconcat);("fset", KW_fset);("faccess", KW_faccess);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvmul", KW_bvmul);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxor", KW_bvxor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("boolimplies", KW_boolimplies);("ptradd", KW_ptradd);("ptrsub", KW_ptrsub);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] + [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("ptr", KW_ptr);("of", KW_of);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("old", KW_old);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("bvconcat", KW_bvconcat);("fset", KW_fset);("faccess", KW_faccess);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvmul", KW_bvmul);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxor", KW_bvxor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("boolimplies", KW_boolimplies);("ptradd", KW_ptradd);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] let unescapeInitTail (s:string) : string = let rec unesc s = match s with diff --git a/lib/fe/ParBasilIR.mly b/lib/fe/ParBasilIR.mly index 83f1525e..dc1d917f 100644 --- a/lib/fe/ParBasilIR.mly +++ b/lib/fe/ParBasilIR.mly @@ -7,7 +7,7 @@ open AbsBasilIR open Lexing %} -%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_ptr KW_of KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_true KW_false KW_forall KW_exists KW_fun KW_old KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_bvconcat KW_fset KW_faccess KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvand KW_bvor KW_bvadd KW_bvmul KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_boolimplies KW_ptradd KW_ptrsub KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant +%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_ptr KW_of KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_true KW_false KW_forall KW_exists KW_fun KW_old KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_bvconcat KW_fset KW_faccess KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvand KW_bvor KW_bvadd KW_bvmul KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_boolimplies KW_ptradd KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant %token SYMB1 /* ; */ %token SYMB2 /* , */ @@ -857,7 +857,6 @@ boolBinOp : KW_booland { BoolBinOp_booland } ; pointerBinOp : KW_ptradd { PointerBinOp_ptradd } - | KW_ptrsub { PointerBinOp_ptrsub } ; requireTok : KW_require { RequireTok_require } diff --git a/lib/fe/PrintBasilIR.ml b/lib/fe/PrintBasilIR.ml index 9403c193..413893e5 100644 --- a/lib/fe/PrintBasilIR.ml +++ b/lib/fe/PrintBasilIR.ml @@ -556,7 +556,6 @@ and prtBoolBinOp (i:int) (e : AbsBasilIR.boolBinOp) : doc = match e with and prtPointerBinOp (i:int) (e : AbsBasilIR.pointerBinOp) : doc = match e with AbsBasilIR.PointerBinOp_ptradd -> prPrec i 0 (concatD [render "ptradd"]) - | AbsBasilIR.PointerBinOp_ptrsub -> prPrec i 0 (concatD [render "ptrsub"]) and prtRequireTok (i:int) (e : AbsBasilIR.requireTok) : doc = match e with diff --git a/lib/fe/ShowBasilIR.ml b/lib/fe/ShowBasilIR.ml index 0439838d..512c0caf 100644 --- a/lib/fe/ShowBasilIR.ml +++ b/lib/fe/ShowBasilIR.ml @@ -405,7 +405,6 @@ and showBoolBinOp (e : AbsBasilIR.boolBinOp) : showable = match e with and showPointerBinOp (e : AbsBasilIR.pointerBinOp) : showable = match e with AbsBasilIR.PointerBinOp_ptradd -> s2s "PointerBinOp_ptradd" - | AbsBasilIR.PointerBinOp_ptrsub -> s2s "PointerBinOp_ptrsub" and showRequireTok (e : AbsBasilIR.requireTok) : showable = match e with diff --git a/lib/fe/SkelBasilIR.ml b/lib/fe/SkelBasilIR.ml index 06b59c86..dc4f300b 100644 --- a/lib/fe/SkelBasilIR.ml +++ b/lib/fe/SkelBasilIR.ml @@ -428,7 +428,6 @@ and transBoolBinOp (x : boolBinOp) : result = match x with and transPointerBinOp (x : pointerBinOp) : result = match x with PointerBinOp_ptradd -> failure x - | PointerBinOp_ptrsub -> failure x and transRequireTok (x : requireTok) : result = match x with diff --git a/lib/lang/expr_eval.ml b/lib/lang/expr_eval.ml index 63aa7d3b..7eb45b14 100644 --- a/lib/lang/expr_eval.ml +++ b/lib/lang/expr_eval.ml @@ -49,10 +49,6 @@ let eval_expr_alg (e : Ops.AllOps.const option BasilExpr.abstract_expr) = let* a, typ = get_pointer a in let* b = get_bv b in pointer (BVOps.eval_binary_unif `BVADD a b, typ) - | BinaryExpr { op = `PTRSUB; arg1 = a; arg2 = b } -> - let* a, typ = get_pointer a in - let* b = get_bv b in - pointer (BVOps.eval_binary_unif `BVSUB a b, typ) | BinaryExpr { op = #BVOps.binary_unif as op; arg1 = a; arg2 = b } -> let* a = get_bv a in let* b = get_bv b in diff --git a/lib/lang/ops.ml b/lib/lang/ops.ml index 1563b2e9..572770c5 100644 --- a/lib/lang/ops.ml +++ b/lib/lang/ops.ml @@ -255,12 +255,9 @@ module PointerOps = struct type const = [ `Pointer of Bitvec.t * Types.pointer ] [@@deriving show { with_path = false }, eq, ord] - type binary = [ `PTRADD | `PTRSUB ] - [@@deriving show { with_path = false }, eq, ord] - - let eval_binary (u : binary) (bv, _) = - match u with `PTRADD -> Bitvec.add bv | `PTRSUB -> Bitvec.sub bv + type binary = [ `PTRADD ] [@@deriving show { with_path = false }, eq, ord] + let eval_binary (u : binary) (bv, _) = match u with `PTRADD -> Bitvec.add bv let show = function #binary as u -> show_binary u end @@ -379,7 +376,7 @@ module AllOps = struct | `BVNAND | `BVXOR | `BVSUB | `BVSDIV | `BVSREM | `BVSMOD | `BVASHR -> return l | `FSET _ -> return r - | `PTRADD | `PTRSUB -> return l + | `PTRADD -> return l | `MapAccess -> let m, r = Types.uncurry l in return r diff --git a/lib/loadir.ml b/lib/loadir.ml index 17110154..c4191b8d 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -1102,7 +1102,6 @@ module BasilASTLoader = struct and transPointerBinOp (x : pointerBinOp) = match x with | PointerBinOp_ptradd -> `PTRADD - | PointerBinOp_ptrsub -> `PTRSUB and transIntLogicalBinOp (x : intLogicalBinOp) = match x with diff --git a/lib/transforms/type_check.ml b/lib/transforms/type_check.ml index ce34e548..224cec71 100644 --- a/lib/transforms/type_check.ml +++ b/lib/transforms/type_check.ml @@ -90,7 +90,7 @@ let type_check stmt_id block_id expr = let binary_bool_types = binary_same_types Types.Boolean in let open Ops in match op with - | `PTRADD | `PTRSUB -> ( + | `PTRADD -> ( let err = match arg2 with | Bitvector _ -> [] From 9be32dc2f0a98d23a4fc78d6978eebbc2655902c Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Mon, 9 Mar 2026 10:15:56 +1000 Subject: [PATCH 18/29] fmt --- lib/loadir.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lib/loadir.ml b/lib/loadir.ml index c4191b8d..2370ef79 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -1100,8 +1100,7 @@ module BasilASTLoader = struct | IntBinOp_intmod -> `INTMOD and transPointerBinOp (x : pointerBinOp) = - match x with - | PointerBinOp_ptradd -> `PTRADD + match x with PointerBinOp_ptradd -> `PTRADD and transIntLogicalBinOp (x : intLogicalBinOp) = match x with From ab578c451f3dc433d36d8d4e90b15dc5240825c4 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Mon, 9 Mar 2026 10:33:32 +1000 Subject: [PATCH 19/29] remove ptrsub --- test/cram/ptrrec1.il | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/test/cram/ptrrec1.il b/test/cram/ptrrec1.il index a680d098..bd783023 100644 --- a/test/cram/ptrrec1.il +++ b/test/cram/ptrrec1.il @@ -1,4 +1,4 @@ -var $rec:{(0 : bv32)}; +var $rec:{(0: bv32)}; prog entry @main_4196164; proc @main_4196164(R0_in:bv64, R10_in:bv64, R11_in:bv64, R12_in:bv64, R13_in:bv64, R14_in:bv64, R15_in:bv64, R16_in:bv64, R17_in:bv64, R18_in:bv64, R1_in:bv64, @@ -6,19 +6,18 @@ proc @main_4196164(R0_in:bv64, R10_in:bv64, R11_in:bv64, R12_in:bv64, R13_in:bv6 R5_in:bv64, R6_in:bv64, R7_in:bv64, R8_in:bv64, R9_in:bv64, _PC_in:bv64) -> (R0_out:bv64, R1_out:bv64) { .address = 4196164; .name = "main"; .returnBlock = "main_return" } - modifies $rec:{(0 : bv32),}; - captures $rec:{(0 : bv32),}; + modifies $rec:{(0: bv32)}; + captures $rec:{(0: bv32)}; [ block %main_entry [ var as:ptr(bv64, bv64) := ptradd(R31_in:bv64, R0_in:bv64); - var ad:ptr(bv64, bv64) := ptrsub(R31_in:bv64, R0_in:bv64); - var af:bv32 := faccess(0, $rec:{(0 : bv32),}); - $rec:{(0 : bv32),} := fset(0, $rec:{(0 : bv32),}, af:bv32); + var af:bv32 := faccess(0, $rec:{(0: bv32)}); + $rec:{(0: bv32)} := fset(0, $rec:{(0: bv32)}, af:bv32); goto (%main_return); ]; block %main_return [ (var R0_out:bv64 := 0x0:bv64, var R1_out:bv64 := 0x2a:bv64); return; ] -]; +]; \ No newline at end of file From b61e2d800adb8cf5065ee6acfb228eef3e4b6f5d Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Mon, 9 Mar 2026 13:49:36 +1000 Subject: [PATCH 20/29] change ZMap to be StringMap --- lib/analysis/defuse_bool.ml | 2 +- lib/fe/AbsBasilIR.ml | 8 ++++---- lib/fe/BasilIR.cf | 16 ++++++++-------- lib/fe/ParBasilIR.mly | 16 ++++++++-------- lib/fe/PrintBasilIR.ml | 16 ++++++++-------- lib/fe/ShowBasilIR.ml | 8 ++++---- lib/fe/SkelBasilIR.ml | 8 ++++---- lib/lang/expr.ml | 11 ++++------- lib/lang/interp.ml | 2 +- lib/lang/ops.ml | 30 ++++++++++++------------------ lib/loadir.ml | 16 ++++++++-------- lib/util/common.ml | 1 - lib/util/types.ml | 19 +++++++++---------- 13 files changed, 71 insertions(+), 82 deletions(-) diff --git a/lib/analysis/defuse_bool.ml b/lib/analysis/defuse_bool.ml index 7709f9f0..9e63053c 100644 --- a/lib/analysis/defuse_bool.ml +++ b/lib/analysis/defuse_bool.ml @@ -45,7 +45,7 @@ module IsZeroValueAbstraction = struct else if Z.equal Z.zero (Bitvec.value i) then Zero else NonZero | `Record fields -> - ZMap.fold + StringMap.fold (fun _ ({ value = i; _ } : Lang.Ops.Record.field) acc -> if Bitvec.size i = 0 then Top else if Z.equal Z.zero (Bitvec.value i) then join acc Zero diff --git a/lib/fe/AbsBasilIR.ml b/lib/fe/AbsBasilIR.ml index 0acf04af..d287a30b 100644 --- a/lib/fe/AbsBasilIR.ml +++ b/lib/fe/AbsBasilIR.ml @@ -50,7 +50,7 @@ and procDef = | ProcDef_Some of beginList * block list * endList and field = - Field1 of openParen * intVal * typeT * closeParen + Field1 of openParen * str * typeT * closeParen and intType = IntType1 of iNTTYPE @@ -95,7 +95,7 @@ and bVVal = BVVal1 of intVal * bVType and fieldVal = - FieldVal1 of openParen * intVal * bVVal * typeT * closeParen + FieldVal1 of openParen * str * bVVal * typeT * closeParen and endian = Endian_Little @@ -224,8 +224,8 @@ and expr = | Expr_SignExtend of openParen * intVal * expr * closeParen | Expr_Extract of openParen * intVal * intVal * expr * closeParen | Expr_Concat of openParen * expr list * closeParen - | Expr_FSet of openParen * intVal * expr * expr * closeParen - | Expr_FAccess of openParen * intVal * expr * closeParen + | Expr_FSet of openParen * str * expr * expr * closeParen + | Expr_FAccess of openParen * str * expr * closeParen | Expr_Match of expr * openParen * case list * closeParen | Expr_Cases of openParen * case list * closeParen | Expr_Paren of openParen * expr * closeParen diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index de657662..d33b8c3e 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -73,7 +73,7 @@ ProcDef_Empty . ProcDef ::= ; ProcDef_Some . ProcDef ::= BeginList [Block] EndList ; separator Field "," ; -Field1 . Field ::= OpenParen IntVal ":" Type CloseParen ; +Field1 . Field ::= OpenParen Str ":" Type CloseParen ; IntType1 . IntType ::= INTTYPE ; BoolType1. BoolType ::= BOOLTYPE ; @@ -108,7 +108,7 @@ IntVal_Dec . IntVal ::= IntegerDec ; rules BVVal ::= IntVal ":" BVType ; separator FieldVal "," ; -rules FieldVal ::= OpenParen IntVal ":" BVVal "," Type CloseParen; +rules FieldVal ::= OpenParen Str ":" BVVal "," Type CloseParen; Endian_Little . Endian ::= "le" ; Endian_Big . Endian ::= "be" ; @@ -268,12 +268,12 @@ Expr_Unary . Expr2 ::= UnOp OpenParen Expr CloseParen ; Expr_LoadBe . Expr2 ::= "load_be" OpenParen IntVal "," Expr "," Expr CloseParen ; Expr_LoadLe . Expr2 ::= "load_le" OpenParen IntVal "," Expr "," Expr CloseParen ; -Expr_ZeroExtend . Expr2 ::= "zero_extend" OpenParen IntVal "," Expr CloseParen ; -Expr_SignExtend . Expr2 ::= "sign_extend" OpenParen IntVal "," Expr CloseParen ; -Expr_Extract . Expr2 ::= "extract" OpenParen IntVal "," IntVal "," Expr CloseParen ; -Expr_Concat . Expr2 ::= "bvconcat" OpenParen [Expr] CloseParen ; -Expr_FSet . Expr ::= "fset" OpenParen IntVal "," Expr "," Expr CloseParen ; -Expr_FAccess . Expr ::= "faccess" OpenParen IntVal "," Expr CloseParen ; +Expr_ZeroExtend . Expr ::= "zero_extend" OpenParen IntVal "," Expr CloseParen ; +Expr_SignExtend . Expr ::= "sign_extend" OpenParen IntVal "," Expr CloseParen ; +Expr_Extract . Expr ::= "extract" OpenParen IntVal "," IntVal "," Expr CloseParen ; +Expr_Concat . Expr ::= "bvconcat" OpenParen [Expr] CloseParen ; +Expr_FSet . Expr ::= "fset" OpenParen Str "," Expr "," Expr CloseParen ; +Expr_FAccess . Expr ::= "faccess" OpenParen Str "," Expr CloseParen ; CaseCase . Case ::= Expr "->" Expr ; CaseDefault . Case ::= "_" "->" Expr ; diff --git a/lib/fe/ParBasilIR.mly b/lib/fe/ParBasilIR.mly index dc1d917f..9db388b5 100644 --- a/lib/fe/ParBasilIR.mly +++ b/lib/fe/ParBasilIR.mly @@ -499,7 +499,7 @@ field_list : /* empty */ { [] } | field SYMB2 field_list { (fun (x,xs) -> x::xs) ($1, $3) } ; -field : openParen intVal SYMB5 typeT closeParen { Field1 ($1, $2, $4, $5) } +field : openParen str SYMB5 typeT closeParen { Field1 ($1, $2, $4, $5) } ; intType : iNTTYPE { IntType1 $1 } @@ -560,7 +560,7 @@ fieldVal_list : /* empty */ { [] } | fieldVal SYMB2 fieldVal_list { (fun (x,xs) -> x::xs) ($1, $3) } ; -fieldVal : openParen intVal SYMB5 bVVal SYMB2 typeT closeParen { FieldVal1 ($1, $2, $4, $6, $7) } +fieldVal : openParen str SYMB5 bVVal SYMB2 typeT closeParen { FieldVal1 ($1, $2, $4, $6, $7) } ; endian : KW_le { Endian_Little } @@ -746,8 +746,12 @@ expr : expr1 { $1 } | KW_forall attribSet lambdaDef { Expr_Forall ($2, $3) } | KW_exists attribSet lambdaDef { Expr_Exists ($2, $3) } | KW_fun attribSet lambdaDef { Expr_Lambda ($2, $3) } - | KW_fset openParen intVal SYMB2 expr SYMB2 expr closeParen { Expr_FSet ($2, $3, $5, $7, $8) } - | KW_faccess openParen intVal SYMB2 expr closeParen { Expr_FAccess ($2, $3, $5, $6) } + | KW_zero_extend openParen intVal SYMB2 expr closeParen { Expr_ZeroExtend ($2, $3, $5, $6) } + | KW_sign_extend openParen intVal SYMB2 expr closeParen { Expr_SignExtend ($2, $3, $5, $6) } + | KW_extract openParen intVal SYMB2 intVal SYMB2 expr closeParen { Expr_Extract ($2, $3, $5, $7, $8) } + | KW_bvconcat openParen expr_list closeParen { Expr_Concat ($2, $3, $4) } + | KW_fset openParen str SYMB2 expr SYMB2 expr closeParen { Expr_FSet ($2, $3, $5, $7, $8) } + | KW_faccess openParen str SYMB2 expr closeParen { Expr_FAccess ($2, $3, $5, $6) } ; expr1 : expr2 { $1 } @@ -763,10 +767,6 @@ expr2 : value { Expr_Literal $1 } | unOp openParen expr closeParen { Expr_Unary ($1, $2, $3, $4) } | KW_load_be openParen intVal SYMB2 expr SYMB2 expr closeParen { Expr_LoadBe ($2, $3, $5, $7, $8) } | KW_load_le openParen intVal SYMB2 expr SYMB2 expr closeParen { Expr_LoadLe ($2, $3, $5, $7, $8) } - | KW_zero_extend openParen intVal SYMB2 expr closeParen { Expr_ZeroExtend ($2, $3, $5, $6) } - | KW_sign_extend openParen intVal SYMB2 expr closeParen { Expr_SignExtend ($2, $3, $5, $6) } - | KW_extract openParen intVal SYMB2 intVal SYMB2 expr closeParen { Expr_Extract ($2, $3, $5, $7, $8) } - | KW_bvconcat openParen expr_list closeParen { Expr_Concat ($2, $3, $4) } | KW_match expr KW_with openParen case_list closeParen { Expr_Match ($2, $4, $5, $6) } | KW_cases openParen case_list closeParen { Expr_Cases ($2, $3, $4) } | openParen expr closeParen { Expr_Paren ($1, $2, $3) } diff --git a/lib/fe/PrintBasilIR.ml b/lib/fe/PrintBasilIR.ml index 413893e5..5a5b27d3 100644 --- a/lib/fe/PrintBasilIR.ml +++ b/lib/fe/PrintBasilIR.ml @@ -184,7 +184,7 @@ and prtProcDef (i:int) (e : AbsBasilIR.procDef) : doc = match e with and prtField (i:int) (e : AbsBasilIR.field) : doc = match e with - AbsBasilIR.Field1 (openparen, intval, type_, closeparen) -> prPrec i 0 (concatD [prtOpenParen 0 openparen ; prtIntVal 0 intval ; render ":" ; prtTypeT 0 type_ ; prtCloseParen 0 closeparen]) + AbsBasilIR.Field1 (openparen, str, type_, closeparen) -> prPrec i 0 (concatD [prtOpenParen 0 openparen ; prtStr 0 str ; render ":" ; prtTypeT 0 type_ ; prtCloseParen 0 closeparen]) and prtFieldListBNFC i es : doc = match (i, es) with (_,[]) -> (concatD []) @@ -253,7 +253,7 @@ and prtBVVal (i:int) (e : AbsBasilIR.bVVal) : doc = match e with and prtFieldVal (i:int) (e : AbsBasilIR.fieldVal) : doc = match e with - AbsBasilIR.FieldVal1 (openparen, intval, bvval, type_, closeparen) -> prPrec i 0 (concatD [prtOpenParen 0 openparen ; prtIntVal 0 intval ; render ":" ; prtBVVal 0 bvval ; render "," ; prtTypeT 0 type_ ; prtCloseParen 0 closeparen]) + AbsBasilIR.FieldVal1 (openparen, str, bvval, type_, closeparen) -> prPrec i 0 (concatD [prtOpenParen 0 openparen ; prtStr 0 str ; render ":" ; prtBVVal 0 bvval ; render "," ; prtTypeT 0 type_ ; prtCloseParen 0 closeparen]) and prtFieldValListBNFC i es : doc = match (i, es) with (_,[]) -> (concatD []) @@ -447,12 +447,12 @@ and prtExpr (i:int) (e : AbsBasilIR.expr) : doc = match e with | AbsBasilIR.Expr_Unary (unop, openparen, expr, closeparen) -> prPrec i 2 (concatD [prtUnOp 0 unop ; prtOpenParen 0 openparen ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_LoadBe (openparen, intval, expr1, expr2, closeparen) -> prPrec i 2 (concatD [render "load_be" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr1 ; render "," ; prtExpr 0 expr2 ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_LoadLe (openparen, intval, expr1, expr2, closeparen) -> prPrec i 2 (concatD [render "load_le" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr1 ; render "," ; prtExpr 0 expr2 ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_ZeroExtend (openparen, intval, expr, closeparen) -> prPrec i 2 (concatD [render "zero_extend" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_SignExtend (openparen, intval, expr, closeparen) -> prPrec i 2 (concatD [render "sign_extend" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_Extract (openparen, intval1, intval2, expr, closeparen) -> prPrec i 2 (concatD [render "extract" ; prtOpenParen 0 openparen ; prtIntVal 0 intval1 ; render "," ; prtIntVal 0 intval2 ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_Concat (openparen, exprs, closeparen) -> prPrec i 2 (concatD [render "bvconcat" ; prtOpenParen 0 openparen ; prtExprListBNFC 0 exprs ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_FSet (openparen, intval, expr1, expr2, closeparen) -> prPrec i 0 (concatD [render "fset" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr1 ; render "," ; prtExpr 0 expr2 ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_FAccess (openparen, intval, expr, closeparen) -> prPrec i 0 (concatD [render "faccess" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_ZeroExtend (openparen, intval, expr, closeparen) -> prPrec i 0 (concatD [render "zero_extend" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_SignExtend (openparen, intval, expr, closeparen) -> prPrec i 0 (concatD [render "sign_extend" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_Extract (openparen, intval1, intval2, expr, closeparen) -> prPrec i 0 (concatD [render "extract" ; prtOpenParen 0 openparen ; prtIntVal 0 intval1 ; render "," ; prtIntVal 0 intval2 ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_Concat (openparen, exprs, closeparen) -> prPrec i 0 (concatD [render "bvconcat" ; prtOpenParen 0 openparen ; prtExprListBNFC 0 exprs ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_FSet (openparen, str, expr1, expr2, closeparen) -> prPrec i 0 (concatD [render "fset" ; prtOpenParen 0 openparen ; prtStr 0 str ; render "," ; prtExpr 0 expr1 ; render "," ; prtExpr 0 expr2 ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_FAccess (openparen, str, expr, closeparen) -> prPrec i 0 (concatD [render "faccess" ; prtOpenParen 0 openparen ; prtStr 0 str ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Match (expr, openparen, cases, closeparen) -> prPrec i 2 (concatD [render "match" ; prtExpr 0 expr ; render "with" ; prtOpenParen 0 openparen ; prtCaseListBNFC 0 cases ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Cases (openparen, cases, closeparen) -> prPrec i 2 (concatD [render "cases" ; prtOpenParen 0 openparen ; prtCaseListBNFC 0 cases ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Paren (openparen, expr, closeparen) -> prPrec i 2 (concatD [prtOpenParen 0 openparen ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) diff --git a/lib/fe/ShowBasilIR.ml b/lib/fe/ShowBasilIR.ml index 512c0caf..2b2e4398 100644 --- a/lib/fe/ShowBasilIR.ml +++ b/lib/fe/ShowBasilIR.ml @@ -95,7 +95,7 @@ and showProcDef (e : AbsBasilIR.procDef) : showable = match e with and showField (e : AbsBasilIR.field) : showable = match e with - AbsBasilIR.Field1 (openparen, intval, type', closeparen) -> s2s "Field1" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval >> s2s ", " >> showTypeT type' >> s2s ", " >> showCloseParen closeparen >> c2s ')' + AbsBasilIR.Field1 (openparen, str, type', closeparen) -> s2s "Field1" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showStr str >> s2s ", " >> showTypeT type' >> s2s ", " >> showCloseParen closeparen >> c2s ')' and showIntType (e : AbsBasilIR.intType) : showable = match e with @@ -152,7 +152,7 @@ and showBVVal (e : AbsBasilIR.bVVal) : showable = match e with and showFieldVal (e : AbsBasilIR.fieldVal) : showable = match e with - AbsBasilIR.FieldVal1 (openparen, intval, bvval, type', closeparen) -> s2s "FieldVal1" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval >> s2s ", " >> showBVVal bvval >> s2s ", " >> showTypeT type' >> s2s ", " >> showCloseParen closeparen >> c2s ')' + AbsBasilIR.FieldVal1 (openparen, str, bvval, type', closeparen) -> s2s "FieldVal1" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showStr str >> s2s ", " >> showBVVal bvval >> s2s ", " >> showTypeT type' >> s2s ", " >> showCloseParen closeparen >> c2s ')' and showEndian (e : AbsBasilIR.endian) : showable = match e with @@ -306,8 +306,8 @@ and showExpr (e : AbsBasilIR.expr) : showable = match e with | AbsBasilIR.Expr_SignExtend (openparen, intval, expr, closeparen) -> s2s "Expr_SignExtend" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval >> s2s ", " >> showExpr expr >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.Expr_Extract (openparen, intval0, intval, expr, closeparen) -> s2s "Expr_Extract" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval0 >> s2s ", " >> showIntVal intval >> s2s ", " >> showExpr expr >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.Expr_Concat (openparen, exprs, closeparen) -> s2s "Expr_Concat" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showList showExpr exprs >> s2s ", " >> showCloseParen closeparen >> c2s ')' - | AbsBasilIR.Expr_FSet (openparen, intval, expr0, expr, closeparen) -> s2s "Expr_FSet" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval >> s2s ", " >> showExpr expr0 >> s2s ", " >> showExpr expr >> s2s ", " >> showCloseParen closeparen >> c2s ')' - | AbsBasilIR.Expr_FAccess (openparen, intval, expr, closeparen) -> s2s "Expr_FAccess" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showIntVal intval >> s2s ", " >> showExpr expr >> s2s ", " >> showCloseParen closeparen >> c2s ')' + | AbsBasilIR.Expr_FSet (openparen, str, expr0, expr, closeparen) -> s2s "Expr_FSet" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showStr str >> s2s ", " >> showExpr expr0 >> s2s ", " >> showExpr expr >> s2s ", " >> showCloseParen closeparen >> c2s ')' + | AbsBasilIR.Expr_FAccess (openparen, str, expr, closeparen) -> s2s "Expr_FAccess" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showStr str >> s2s ", " >> showExpr expr >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.Expr_Match (expr, openparen, cases, closeparen) -> s2s "Expr_Match" >> c2s ' ' >> c2s '(' >> showExpr expr >> s2s ", " >> showOpenParen openparen >> s2s ", " >> showList showCase cases >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.Expr_Cases (openparen, cases, closeparen) -> s2s "Expr_Cases" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showList showCase cases >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.Expr_Paren (openparen, expr, closeparen) -> s2s "Expr_Paren" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showExpr expr >> s2s ", " >> showCloseParen closeparen >> c2s ')' diff --git a/lib/fe/SkelBasilIR.ml b/lib/fe/SkelBasilIR.ml index dc4f300b..a71dc1d5 100644 --- a/lib/fe/SkelBasilIR.ml +++ b/lib/fe/SkelBasilIR.ml @@ -118,7 +118,7 @@ and transProcDef (x : procDef) : result = match x with and transField (x : field) : result = match x with - Field1 (openparen, intval, type', closeparen) -> failure x + Field1 (openparen, str, type', closeparen) -> failure x and transIntType (x : intType) : result = match x with @@ -175,7 +175,7 @@ and transBVVal (x : bVVal) : result = match x with and transFieldVal (x : fieldVal) : result = match x with - FieldVal1 (openparen, intval, bvval, type', closeparen) -> failure x + FieldVal1 (openparen, str, bvval, type', closeparen) -> failure x and transEndian (x : endian) : result = match x with @@ -329,8 +329,8 @@ and transExpr (x : expr) : result = match x with | Expr_SignExtend (openparen, intval, expr, closeparen) -> failure x | Expr_Extract (openparen, intval0, intval, expr, closeparen) -> failure x | Expr_Concat (openparen, exprs, closeparen) -> failure x - | Expr_FSet (openparen, intval, expr0, expr, closeparen) -> failure x - | Expr_FAccess (openparen, intval, expr, closeparen) -> failure x + | Expr_FSet (openparen, str, expr0, expr, closeparen) -> failure x + | Expr_FAccess (openparen, str, expr, closeparen) -> failure x | Expr_Match (expr, openparen, cases, closeparen) -> failure x | Expr_Cases (openparen, cases, closeparen) -> failure x | Expr_Paren (openparen, expr, closeparen) -> failure x diff --git a/lib/lang/expr.ml b/lib/lang/expr.ml index 0708c71f..639973f3 100644 --- a/lib/lang/expr.ml +++ b/lib/lang/expr.ml @@ -361,15 +361,12 @@ module BasilExpr = struct | UnaryExpr { op = `FACCESS offset; arg } -> fill (text "," ^ newline) - [ - text "faccess" ^ a ^ (textpf "(%s") (Z.to_string offset); - arg ^ text ")"; - ] + [ text "faccess" ^ a ^ (textpf "(\"%s\"") offset; arg ^ text ")" ] | BinaryExpr { op = `FSET offset; arg1; arg2 } -> fill (text "," ^ newline) [ - text "fset" ^ a ^ (textpf "(%s") (Z.to_string offset); + text "fset" ^ a ^ (textpf "(\"%s\"") offset; arg1 ^ text ", " ^ arg2 ^ text ")"; ] | UnaryExpr { op; arg = e } -> @@ -558,10 +555,10 @@ module BasilExpr = struct let zero_extend ?attrib ~n_prefix_bits (e : t) : t = unexp ?attrib ~op:(`ZeroExtend n_prefix_bits) e - let fset ?attrib ~(offset : Z.t) (record : t) (e : t) : t = + let fset ?attrib ~(offset : string) (record : t) (e : t) : t = binexp ?attrib ~op:(`FSET offset) record e - let faccess ?attrib ~(offset : Z.t) (record : t) : t = + let faccess ?attrib ~(offset : string) (record : t) : t = unexp ?attrib ~op:(`FACCESS offset) record let sign_extend ?attrib ~n_prefix_bits (e : t) : t = diff --git a/lib/lang/interp.ml b/lib/lang/interp.ml index 61540e19..73b44193 100644 --- a/lib/lang/interp.ml +++ b/lib/lang/interp.ml @@ -36,7 +36,7 @@ module IValue = struct | `Bool false -> Bitvec.create ~size:8 Z.zero | `Pointer (bv, _) -> bv | `Record fields -> - ZMap.fold + StringMap.fold (fun _ ({ value; _ } : Ops.Record.field) acc -> Bitvec.concat acc value) fields Bitvec.empty diff --git a/lib/lang/ops.ml b/lib/lang/ops.ml index 572770c5..de25d802 100644 --- a/lib/lang/ops.ml +++ b/lib/lang/ops.ml @@ -2,26 +2,25 @@ open Common open Containers module Record = struct - type t = field ZMap.t [@@deriving eq, ord] + type t = field StringMap.t [@@deriving eq, ord] and field = { value : Bitvec.t; typ : Types.t } let get_field offset record : field = - match ZMap.find_opt offset record with - | None -> failwith @@ "No field at offset " ^ Z.to_string offset + match StringMap.find_opt offset record with + | None -> failwith @@ "No field at offset " ^ offset | Some f -> f let set_field offset record value = let { typ; _ } = get_field offset record in - ZMap.add offset { typ; value } record + StringMap.add offset { typ; value } record let show_field { value; typ } = Printf.sprintf "(%s, %s)" (Bitvec.to_string value) @@ Types.to_string typ let show (record : t) = "{" - ^ (ZMap.bindings record - |> List.map (fun (k, v) -> - "(" ^ Z.to_string k ^ ": " ^ show_field v ^ ")") + ^ (StringMap.bindings record + |> List.map (fun (k, v) -> "(\"" ^ k ^ "\": " ^ show_field v ^ ")") |> String.concat ", ") ^ "}" @@ -226,15 +225,10 @@ module RecordOps = struct type const = [ `Record of Record.t ] [@@deriving show { with_path = false }, eq, ord] - type unary = - ([ `FACCESS of Z.t ] - [@printer - fun fmt m -> match m with `FACCESS offset -> Z.pp_print fmt offset]) + type unary = [ `FACCESS of string ] [@@deriving show { with_path = false }, eq, ord] - type binary = - ([ `FSET of Z.t ] - [@printer fun fmt m -> match m with `FSET offset -> Z.pp_print fmt offset]) + type binary = [ `FSET of string ] [@@deriving show { with_path = false }, eq, ord] let eval_unary (u : unary) record = @@ -328,7 +322,8 @@ module AllOps = struct | `Pointer (v, ty) -> return (Pointer ty) | `Record fields -> return - @@ Record (ZMap.map (fun ({ value; typ } : Record.field) -> typ) fields) + @@ Record + (StringMap.map (fun ({ value; typ } : Record.field) -> typ) fields) let ret_type_unary (o : [< unary ]) a = let open Types in @@ -435,10 +430,9 @@ module AllOps = struct | `Exists -> "exists" | `SignExtend n -> Printf.sprintf "sign_extend_%d" n | `ZeroExtend n -> Printf.sprintf "zero_extend_%d" n - | `FSET offset -> Printf.sprintf "fset_%s" @@ Z.to_string offset - | `FACCESS offset -> Printf.sprintf "asdfaccess_%s" @@ Z.to_string offset + | `FSET offset -> Printf.sprintf "fset_%s" offset + | `FACCESS offset -> Printf.sprintf "asdfaccess_%s" offset | `PTRADD -> "ptradd" - | `PTRSUB -> "ptrsub" | `EQ -> "eq" | `INTADD -> "intadd" | `BVNAND -> "bvnand" diff --git a/lib/loadir.ml b/lib/loadir.ml index 2370ef79..1280d0f4 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -438,9 +438,9 @@ module BasilASTLoader = struct Types.mk_field (unsafe_unsigil (`Local id)) (trans_type ty) and transRECORDTYPE (fields : field list) = Types.Record - (ZMap.of_list + (StringMap.of_list ((List.map (function Field1 (_, offset, t, _) -> - (transIntVal offset, trans_type t))) + (transStr offset, trans_type t))) fields)) and transPOINTERTYPE (l : typeT) (u : typeT) = @@ -455,7 +455,7 @@ module BasilASTLoader = struct | TypeParen (_, typeT, _) -> trans_type typeT | TypeSort t -> Types.Sort (unsafe_unsigil (`Local t), []) | TypeRecordType (RecordType1 (_, fields, _)) -> transRECORDTYPE fields - | TypePointerType (PointerType1 (_, _, l, u, _)) -> transPOINTERTYPE l u + | TypePointerType (PointerType1 (_, l, u, _)) -> transPOINTERTYPE l u and transIntVal (x : intVal) : PrimInt.t = match x with @@ -872,11 +872,11 @@ module BasilASTLoader = struct `Pointer (trans_bv_val v, { lower = trans_type l; upper = trans_type u }) | Value_Record (_, fields, _) -> `Record - (ZMap.of_list + (StringMap.of_list (List.map (function | FieldVal1 (_, offset, value, typ, _) -> - ( transIntVal offset, + ( transStr offset, ({ value = trans_bv_val value; typ = trans_type typ } : Ops.Record.field) )) fields)) @@ -990,10 +990,10 @@ module BasilASTLoader = struct (trans_expr expr) | Expr_FAccess (o, offset, record, c) -> BasilExpr.faccess ~attrib:(expr_range_attr o c) - ~offset:(transIntVal offset) (trans_expr record) + ~offset:(transStr offset) (trans_expr record) | Expr_FSet (o, offset, record, expr, c) -> - BasilExpr.fset ~attrib:(expr_range_attr o c) - ~offset:(transIntVal offset) (trans_expr record) (trans_expr expr) + BasilExpr.fset ~attrib:(expr_range_attr o c) ~offset:(transStr offset) + (trans_expr record) (trans_expr expr) | Expr_LoadLe (o, intval, a1, a2, c) -> BasilExpr.load ~attrib:(expr_range_attr o c) ~bits:(Z.to_int @@ transIntVal intval) diff --git a/lib/util/common.ml b/lib/util/common.ml index d688f3cb..822d5d62 100644 --- a/lib/util/common.ml +++ b/lib/util/common.ml @@ -36,7 +36,6 @@ module Var = Var module ID = ID module IDMap = Map.Make (ID) module VarMap = Map.Make (Var) -module ZMap = Map.Make (Z) module IDSet = Set.Make (ID) module VarSet = Set.Make (Var) diff --git a/lib/util/types.ml b/lib/util/types.ml index 54a5e26a..6afe37cd 100644 --- a/lib/util/types.ml +++ b/lib/util/types.ml @@ -1,5 +1,5 @@ open Containers -module ZMap = Map.Make (Z) +module StringMap = Map.Make (String) (** This represents type right expressions (i.e. not declarations), we expand this in the future to allow declarations to be polymorphic. @@ -34,12 +34,12 @@ type t = | Nothing | Map of t * t | Sort of string * variant list - | Record of t ZMap.t + | Record of t StringMap.t | Pointer of pointer and variant = { variant : string; fields : field list } and field = { field : string; typ : t } [@@deriving eq, ord] -and field2 = { offset : Z.t; t : t } +and field2 = { offset : Z.t; t : t; size : int } (* Lower type represents types the pointer could load @@ -81,11 +81,11 @@ let mk_adt name (variants : (string * field list) list) = Sort (name, variants |> List.map (fun (variant, fields) -> { variant; fields })) -let get_field offset1 record : t = +let get_field field_name record : t = match record with | Record fields -> ( - match ZMap.find_opt offset1 fields with - | None -> failwith @@ "No field at offset " ^ Z.to_string offset1 + match StringMap.find_opt field_name fields with + | None -> failwith @@ "No field at offset " ^ field_name | Some t -> t) | _ -> failwith "Not record type" @@ -108,7 +108,7 @@ let rec compare_partial (a : t) (b : t) = | o -> o) | Record fields, Record fields2 -> Some - (ZMap.compare + (StringMap.compare (fun a b -> match compare_partial a b with Some a -> a | None -> -1) fields fields2) @@ -143,9 +143,8 @@ let rec to_string = function Printf.sprintf "ptr(%s, %s)" (to_string lower) (to_string upper) | Record record -> "{" - ^ (ZMap.bindings record - |> List.map (fun (k, v) -> - "(" ^ Z.to_string k ^ ": " ^ to_string v ^ ")") + ^ (StringMap.bindings record + |> List.map (fun (k, v) -> "(\"" ^ k ^ "\": " ^ to_string v ^ ")") |> String.concat ", ") ^ "}" | Map ((Map _ as a), (Map _ as b)) -> From 2e73b85de99f2513f2557b8f8cb5a01395a3b833 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Mon, 9 Mar 2026 13:53:12 +1000 Subject: [PATCH 21/29] fix test --- test/cram/ptrrec1.il | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/test/cram/ptrrec1.il b/test/cram/ptrrec1.il index bd783023..9146bb38 100644 --- a/test/cram/ptrrec1.il +++ b/test/cram/ptrrec1.il @@ -1,4 +1,4 @@ -var $rec:{(0: bv32)}; +var $rec:{("0": bv32)}; prog entry @main_4196164; proc @main_4196164(R0_in:bv64, R10_in:bv64, R11_in:bv64, R12_in:bv64, R13_in:bv64, R14_in:bv64, R15_in:bv64, R16_in:bv64, R17_in:bv64, R18_in:bv64, R1_in:bv64, @@ -6,14 +6,14 @@ proc @main_4196164(R0_in:bv64, R10_in:bv64, R11_in:bv64, R12_in:bv64, R13_in:bv6 R5_in:bv64, R6_in:bv64, R7_in:bv64, R8_in:bv64, R9_in:bv64, _PC_in:bv64) -> (R0_out:bv64, R1_out:bv64) { .address = 4196164; .name = "main"; .returnBlock = "main_return" } - modifies $rec:{(0: bv32)}; - captures $rec:{(0: bv32)}; + modifies $rec:{("0": bv32)}; + captures $rec:{("0": bv32)}; [ block %main_entry [ var as:ptr(bv64, bv64) := ptradd(R31_in:bv64, R0_in:bv64); - var af:bv32 := faccess(0, $rec:{(0: bv32)}); - $rec:{(0: bv32)} := fset(0, $rec:{(0: bv32)}, af:bv32); + var af:bv32 := faccess("0", $rec:{("0": bv32)}); + $rec:{("0": bv32)} := fset("0", $rec:{("0": bv32)}, af:bv32); goto (%main_return); ]; block %main_return [ From 9d3e763b1617eb5a00a54b11923117ab8619339a Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Mon, 9 Mar 2026 14:37:35 +1000 Subject: [PATCH 22/29] fix from rebase --- test/cram/ptrrec1.il | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/test/cram/ptrrec1.il b/test/cram/ptrrec1.il index 9146bb38..4ff0fb67 100644 --- a/test/cram/ptrrec1.il +++ b/test/cram/ptrrec1.il @@ -6,18 +6,18 @@ proc @main_4196164(R0_in:bv64, R10_in:bv64, R11_in:bv64, R12_in:bv64, R13_in:bv6 R5_in:bv64, R6_in:bv64, R7_in:bv64, R8_in:bv64, R9_in:bv64, _PC_in:bv64) -> (R0_out:bv64, R1_out:bv64) { .address = 4196164; .name = "main"; .returnBlock = "main_return" } - modifies $rec:{("0": bv32)}; - captures $rec:{("0": bv32)}; + modifies $rec:{("0": bv32)} + captures $rec:{("0": bv32)} [ block %main_entry [ - var as:ptr(bv64, bv64) := ptradd(R31_in:bv64, R0_in:bv64); - var af:bv32 := faccess("0", $rec:{("0": bv32)}); - $rec:{("0": bv32)} := fset("0", $rec:{("0": bv32)}, af:bv32); - goto (%main_return); + var as:ptr(bv64, bv64) := ptradd(R31_in:bv64, R0_in:bv64); + var af:bv32 := faccess("0", $rec:{("0": bv32)}); + $rec:{("0": bv32)} := fset("0", $rec:{("0": bv32)}, af:bv32); + goto (%main_return); ]; block %main_return [ - (var R0_out:bv64 := 0x0:bv64, var R1_out:bv64 := 0x2a:bv64); - return; + (var R0_out:bv64 := 0x0:bv64, var R1_out:bv64 := 0x2a:bv64); + return; ] ]; \ No newline at end of file From 0fd122c53f8c02fe93597991d9e7b8bd3c83febf Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Mon, 9 Mar 2026 14:59:00 +1000 Subject: [PATCH 23/29] remove field2 --- lib/util/types.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/util/types.ml b/lib/util/types.ml index 6afe37cd..3f18d119 100644 --- a/lib/util/types.ml +++ b/lib/util/types.ml @@ -39,7 +39,6 @@ type t = and variant = { variant : string; fields : field list } and field = { field : string; typ : t } [@@deriving eq, ord] -and field2 = { offset : Z.t; t : t; size : int } (* Lower type represents types the pointer could load From e471ac0d5e55205475572d3da02f8b72957d8111 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Mon, 9 Mar 2026 15:00:36 +1000 Subject: [PATCH 24/29] expr -> expr2 --- lib/fe/BasilIR.cf | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index d33b8c3e..aeb5865a 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -268,12 +268,12 @@ Expr_Unary . Expr2 ::= UnOp OpenParen Expr CloseParen ; Expr_LoadBe . Expr2 ::= "load_be" OpenParen IntVal "," Expr "," Expr CloseParen ; Expr_LoadLe . Expr2 ::= "load_le" OpenParen IntVal "," Expr "," Expr CloseParen ; -Expr_ZeroExtend . Expr ::= "zero_extend" OpenParen IntVal "," Expr CloseParen ; -Expr_SignExtend . Expr ::= "sign_extend" OpenParen IntVal "," Expr CloseParen ; -Expr_Extract . Expr ::= "extract" OpenParen IntVal "," IntVal "," Expr CloseParen ; -Expr_Concat . Expr ::= "bvconcat" OpenParen [Expr] CloseParen ; -Expr_FSet . Expr ::= "fset" OpenParen Str "," Expr "," Expr CloseParen ; -Expr_FAccess . Expr ::= "faccess" OpenParen Str "," Expr CloseParen ; +Expr_ZeroExtend . Expr2 ::= "zero_extend" OpenParen IntVal "," Expr CloseParen ; +Expr_SignExtend . Expr2 ::= "sign_extend" OpenParen IntVal "," Expr CloseParen ; +Expr_Extract . Expr2 ::= "extract" OpenParen IntVal "," IntVal "," Expr CloseParen ; +Expr_Concat . Expr2 ::= "bvconcat" OpenParen [Expr] CloseParen ; +Expr_FSet . Expr2 ::= "fset" OpenParen Str "," Expr "," Expr CloseParen ; +Expr_FAccess . Expr2 ::= "faccess" OpenParen Str "," Expr CloseParen ; CaseCase . Case ::= Expr "->" Expr ; CaseDefault . Case ::= "_" "->" Expr ; From 19c2d7c3ade2915bee1ce3a20c86e36d69d1f99e Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Mon, 9 Mar 2026 15:20:14 +1000 Subject: [PATCH 25/29] adds some comments for adt record functions --- lib/util/types.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lib/util/types.ml b/lib/util/types.ml index 3f18d119..9efe7f91 100644 --- a/lib/util/types.ml +++ b/lib/util/types.ml @@ -57,15 +57,18 @@ let bit_width = function Boolean -> Some 1 | Bitvector n -> Some n | _ -> None (** Get the type for an opaque sort *) let mk_sort name = Sort (name, []) +(* ADT not Record type *) let mk_field field typ = { field; typ } let mk_variant name fields = { variant = name; fields } let mk_enum name (cases : string list) = Sort (name, List.map (fun variant -> { variant; fields = [] }) cases) +(* ADT not Record type *) let mk_record name (fields : field list) = Sort (name, [ mk_variant ("Record" ^ name) fields ]) +(* ADT not Record type *) let record_field name t = match t with | Sort (sort_name, [ { variant; fields } ]) From 09a242b2267dd4067b9ff5d8a2d9b94da087ea53 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Thu, 12 Mar 2026 10:20:41 +1000 Subject: [PATCH 26/29] fix defuse_bool analysis to be correct --- lib/analysis/defuse_bool.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/analysis/defuse_bool.ml b/lib/analysis/defuse_bool.ml index 9e63053c..7625901c 100644 --- a/lib/analysis/defuse_bool.ml +++ b/lib/analysis/defuse_bool.ml @@ -113,7 +113,7 @@ module IsZeroValueAbstraction = struct | `BVSLT, Zero, Zero -> Zero | `BVSLT, _, _ -> Top | `FSET _, Zero, Zero -> Zero - | `FSET _, NonZero, NonZero -> NonZero + | `FSET _, _, NonZero -> NonZero (* Larger refactor would be needed to reason about individual fields *) | `FSET _, _, _ -> Top | #Lang.Ops.Spec.binary, _, _ -> Top From 1993a73b95b973ed71c5d5827a5ecd07fa146afb Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Thu, 12 Mar 2026 12:41:13 +1000 Subject: [PATCH 27/29] base var type --- lib/fe/BasilIR.cf | 1 + lib/util/types.ml | 2 ++ 2 files changed, 3 insertions(+) diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index aeb5865a..83ff7ed4 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -80,6 +80,7 @@ BoolType1. BoolType ::= BOOLTYPE ; RecordType1 . RecordType ::= BeginRec [Field] EndRec ; PointerType1 . PointerType ::= "ptr" OpenParen Type "," Type CloseParen ; BVType1 . BVType ::= BVTYPE ; +VarType1 . VarType :: = Str ; -- map types are right associative. left of -> cannot be another MapType. MapType1 . MapType ::= Type1 "->" Type ; diff --git a/lib/util/types.ml b/lib/util/types.ml index 9efe7f91..4b3f9f67 100644 --- a/lib/util/types.ml +++ b/lib/util/types.ml @@ -36,6 +36,7 @@ type t = | Sort of string * variant list | Record of t StringMap.t | Pointer of pointer + | Variable of string (* Possibly a name of a type declartion *) and variant = { variant : string; fields : field list } and field = { field : string; typ : t } [@@deriving eq, ord] @@ -141,6 +142,7 @@ let rec to_string = function | Unit -> "()" | Top -> "⊤" | Nothing -> "⊥" + | Variable name -> name | Pointer { lower; upper } -> Printf.sprintf "ptr(%s, %s)" (to_string lower) (to_string upper) | Record record -> From 045bdaf8b6368c3b01693057117b146aea909148 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Thu, 12 Mar 2026 13:42:30 +1000 Subject: [PATCH 28/29] parse type variables --- lib/fe/AbsBasilIR.ml | 4 ++++ lib/fe/BasilIR.cf | 3 ++- lib/fe/ParBasilIR.mly | 22 +++++++++++++++------- lib/fe/PrintBasilIR.ml | 17 +++++++++++------ lib/fe/ShowBasilIR.ml | 5 +++++ lib/fe/SkelBasilIR.ml | 5 +++++ lib/loadir.ml | 2 ++ 7 files changed, 44 insertions(+), 14 deletions(-) diff --git a/lib/fe/AbsBasilIR.ml b/lib/fe/AbsBasilIR.ml index d287a30b..7dd1dcc2 100644 --- a/lib/fe/AbsBasilIR.ml +++ b/lib/fe/AbsBasilIR.ml @@ -67,6 +67,9 @@ and pointerType = and bVType = BVType1 of bVTYPE +and varType = + VarType1 of str + and mapType = MapType1 of typeT * typeT @@ -83,6 +86,7 @@ and typeT = | TypeBVType of bVType | TypePointerType of pointerType | TypeRecordType of recordType + | TypeVarType of varType | TypeParen of openParen * typeT * closeParen | TypeSort of localIdent | TypeMapType of mapType diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index 83ff7ed4..dd8e6dc2 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -80,7 +80,7 @@ BoolType1. BoolType ::= BOOLTYPE ; RecordType1 . RecordType ::= BeginRec [Field] EndRec ; PointerType1 . PointerType ::= "ptr" OpenParen Type "," Type CloseParen ; BVType1 . BVType ::= BVTYPE ; -VarType1 . VarType :: = Str ; +VarType1 . VarType ::= Str ; -- map types are right associative. left of -> cannot be another MapType. MapType1 . MapType ::= Type1 "->" Type ; @@ -98,6 +98,7 @@ TypeBoolType . Type1 ::= BoolType ; TypeBVType . Type1 ::= BVType ; TypePointerType . Type1 ::= PointerType ; TypeRecordType . Type1 ::= RecordType ; +TypeVarType . Type1 ::= VarType ; TypeParen . Type1 ::= OpenParen Type CloseParen; TypeSort . Type1 ::= LocalIdent; TypeMapType . Type ::= MapType; diff --git a/lib/fe/ParBasilIR.mly b/lib/fe/ParBasilIR.mly index 9db388b5..e5758d3d 100644 --- a/lib/fe/ParBasilIR.mly +++ b/lib/fe/ParBasilIR.mly @@ -45,7 +45,7 @@ open Lexing %token <(int * int) * string> TOK_IntegerHex %token <(int * int) * string> TOK_IntegerDec -%start pModuleT pDecl_list pBlockIdent_list pLambdaSep pVarModifiers pVarModifiers_list pDecl pTypeT_list pTypeAssign pTypeAssign_list pProcDef pField_list pField pIntType pBoolType pRecordType pPointerType pBVType pMapType pRecordField pRecordField_list pSumCase pSumCase_list pType1 pTypeT pIntVal pBVVal pFieldVal_list pFieldVal pEndian pAssignment pStmt pAssignment_list pLocalVar pLocalVar_list pGlobalVar pGlobalVar_list pVar pLocalVarParen pGlobalVarParen pLocalVarParen_list pNamedCallReturn pNamedCallReturn_list pLVars pNamedCallArg pNamedCallArg_list pCallParams pJump pLVar pLVar_list pBlock_list pStmtWithAttrib pStmtWithAttrib_list pJumpWithAttrib pPhiExpr pPhiExpr_list pPhiAssign pPhiAssign_list pBlock pAttrKeyValue pAttrKeyValue_list pAttribSet pAttr_list pAttr pParams pParams_list pValue pExpr_list pExpr pExpr1 pExpr2 pLambdaDef pBinOp pUnOp pCase pCase_list pEqOp pBVUnOp pBVBinOp pBVLogicalBinOp pIntBinOp pIntLogicalBinOp pBoolBinOp pPointerBinOp pRequireTok pEnsureTok pRelyTok pGuarTok pFunSpec pVarSpec pProgSpec pFunSpec_list pProgSpec_list +%start pModuleT pDecl_list pBlockIdent_list pLambdaSep pVarModifiers pVarModifiers_list pDecl pTypeT_list pTypeAssign pTypeAssign_list pProcDef pField_list pField pIntType pBoolType pRecordType pPointerType pBVType pVarType pMapType pRecordField pRecordField_list pSumCase pSumCase_list pType1 pTypeT pIntVal pBVVal pFieldVal_list pFieldVal pEndian pAssignment pStmt pAssignment_list pLocalVar pLocalVar_list pGlobalVar pGlobalVar_list pVar pLocalVarParen pGlobalVarParen pLocalVarParen_list pNamedCallReturn pNamedCallReturn_list pLVars pNamedCallArg pNamedCallArg_list pCallParams pJump pLVar pLVar_list pBlock_list pStmtWithAttrib pStmtWithAttrib_list pJumpWithAttrib pPhiExpr pPhiExpr_list pPhiAssign pPhiAssign_list pBlock pAttrKeyValue pAttrKeyValue_list pAttribSet pAttr_list pAttr pParams pParams_list pValue pExpr_list pExpr pExpr1 pExpr2 pLambdaDef pBinOp pUnOp pCase pCase_list pEqOp pBVUnOp pBVBinOp pBVLogicalBinOp pIntBinOp pIntLogicalBinOp pBoolBinOp pPointerBinOp pRequireTok pEnsureTok pRelyTok pGuarTok pFunSpec pVarSpec pProgSpec pFunSpec_list pProgSpec_list %type pModuleT %type pDecl_list %type pBlockIdent_list @@ -64,6 +64,7 @@ open Lexing %type pRecordType %type pPointerType %type pBVType +%type pVarType %type pMapType %type pRecordField %type pRecordField_list @@ -158,6 +159,7 @@ open Lexing %type recordType %type pointerType %type bVType +%type varType %type mapType %type recordField %type recordField_list @@ -291,6 +293,8 @@ pPointerType : pointerType TOK_EOF { $1 }; pBVType : bVType TOK_EOF { $1 }; +pVarType : varType TOK_EOF { $1 }; + pMapType : mapType TOK_EOF { $1 }; pRecordField : recordField TOK_EOF { $1 }; @@ -517,6 +521,9 @@ pointerType : KW_ptr openParen typeT SYMB2 typeT closeParen { PointerType1 ($2, bVType : bVTYPE { BVType1 $1 } ; +varType : str { VarType1 $1 } + ; + mapType : type1 SYMB3 typeT { MapType1 ($1, $3) } ; @@ -540,6 +547,7 @@ type1 : intType { TypeIntType $1 } | bVType { TypeBVType $1 } | pointerType { TypePointerType $1 } | recordType { TypeRecordType $1 } + | varType { TypeVarType $1 } | openParen typeT closeParen { TypeParen ($1, $2, $3) } | localIdent { TypeSort $1 } ; @@ -746,12 +754,6 @@ expr : expr1 { $1 } | KW_forall attribSet lambdaDef { Expr_Forall ($2, $3) } | KW_exists attribSet lambdaDef { Expr_Exists ($2, $3) } | KW_fun attribSet lambdaDef { Expr_Lambda ($2, $3) } - | KW_zero_extend openParen intVal SYMB2 expr closeParen { Expr_ZeroExtend ($2, $3, $5, $6) } - | KW_sign_extend openParen intVal SYMB2 expr closeParen { Expr_SignExtend ($2, $3, $5, $6) } - | KW_extract openParen intVal SYMB2 intVal SYMB2 expr closeParen { Expr_Extract ($2, $3, $5, $7, $8) } - | KW_bvconcat openParen expr_list closeParen { Expr_Concat ($2, $3, $4) } - | KW_fset openParen str SYMB2 expr SYMB2 expr closeParen { Expr_FSet ($2, $3, $5, $7, $8) } - | KW_faccess openParen str SYMB2 expr closeParen { Expr_FAccess ($2, $3, $5, $6) } ; expr1 : expr2 { $1 } @@ -767,6 +769,12 @@ expr2 : value { Expr_Literal $1 } | unOp openParen expr closeParen { Expr_Unary ($1, $2, $3, $4) } | KW_load_be openParen intVal SYMB2 expr SYMB2 expr closeParen { Expr_LoadBe ($2, $3, $5, $7, $8) } | KW_load_le openParen intVal SYMB2 expr SYMB2 expr closeParen { Expr_LoadLe ($2, $3, $5, $7, $8) } + | KW_zero_extend openParen intVal SYMB2 expr closeParen { Expr_ZeroExtend ($2, $3, $5, $6) } + | KW_sign_extend openParen intVal SYMB2 expr closeParen { Expr_SignExtend ($2, $3, $5, $6) } + | KW_extract openParen intVal SYMB2 intVal SYMB2 expr closeParen { Expr_Extract ($2, $3, $5, $7, $8) } + | KW_bvconcat openParen expr_list closeParen { Expr_Concat ($2, $3, $4) } + | KW_fset openParen str SYMB2 expr SYMB2 expr closeParen { Expr_FSet ($2, $3, $5, $7, $8) } + | KW_faccess openParen str SYMB2 expr closeParen { Expr_FAccess ($2, $3, $5, $6) } | KW_match expr KW_with openParen case_list closeParen { Expr_Match ($2, $4, $5, $6) } | KW_cases openParen case_list closeParen { Expr_Cases ($2, $3, $4) } | openParen expr closeParen { Expr_Paren ($1, $2, $3) } diff --git a/lib/fe/PrintBasilIR.ml b/lib/fe/PrintBasilIR.ml index 5a5b27d3..c55bc65f 100644 --- a/lib/fe/PrintBasilIR.ml +++ b/lib/fe/PrintBasilIR.ml @@ -210,6 +210,10 @@ and prtBVType (i:int) (e : AbsBasilIR.bVType) : doc = match e with AbsBasilIR.BVType1 bvtype -> prPrec i 0 (concatD [prtBVTYPE 0 bvtype]) +and prtVarType (i:int) (e : AbsBasilIR.varType) : doc = match e with + AbsBasilIR.VarType1 str -> prPrec i 0 (concatD [prtStr 0 str]) + + and prtMapType (i:int) (e : AbsBasilIR.mapType) : doc = match e with AbsBasilIR.MapType1 (type_1, type_2) -> prPrec i 0 (concatD [prtTypeT 1 type_1 ; render "->" ; prtTypeT 0 type_2]) @@ -235,6 +239,7 @@ and prtTypeT (i:int) (e : AbsBasilIR.typeT) : doc = match e with | AbsBasilIR.TypeBVType bvtype -> prPrec i 1 (concatD [prtBVType 0 bvtype]) | AbsBasilIR.TypePointerType pointertype -> prPrec i 1 (concatD [prtPointerType 0 pointertype]) | AbsBasilIR.TypeRecordType recordtype -> prPrec i 1 (concatD [prtRecordType 0 recordtype]) + | AbsBasilIR.TypeVarType vartype -> prPrec i 1 (concatD [prtVarType 0 vartype]) | AbsBasilIR.TypeParen (openparen, type_, closeparen) -> prPrec i 1 (concatD [prtOpenParen 0 openparen ; prtTypeT 0 type_ ; prtCloseParen 0 closeparen]) | AbsBasilIR.TypeSort localident -> prPrec i 1 (concatD [prtLocalIdent 0 localident]) | AbsBasilIR.TypeMapType maptype -> prPrec i 0 (concatD [prtMapType 0 maptype]) @@ -447,12 +452,12 @@ and prtExpr (i:int) (e : AbsBasilIR.expr) : doc = match e with | AbsBasilIR.Expr_Unary (unop, openparen, expr, closeparen) -> prPrec i 2 (concatD [prtUnOp 0 unop ; prtOpenParen 0 openparen ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_LoadBe (openparen, intval, expr1, expr2, closeparen) -> prPrec i 2 (concatD [render "load_be" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr1 ; render "," ; prtExpr 0 expr2 ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_LoadLe (openparen, intval, expr1, expr2, closeparen) -> prPrec i 2 (concatD [render "load_le" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr1 ; render "," ; prtExpr 0 expr2 ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_ZeroExtend (openparen, intval, expr, closeparen) -> prPrec i 0 (concatD [render "zero_extend" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_SignExtend (openparen, intval, expr, closeparen) -> prPrec i 0 (concatD [render "sign_extend" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_Extract (openparen, intval1, intval2, expr, closeparen) -> prPrec i 0 (concatD [render "extract" ; prtOpenParen 0 openparen ; prtIntVal 0 intval1 ; render "," ; prtIntVal 0 intval2 ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_Concat (openparen, exprs, closeparen) -> prPrec i 0 (concatD [render "bvconcat" ; prtOpenParen 0 openparen ; prtExprListBNFC 0 exprs ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_FSet (openparen, str, expr1, expr2, closeparen) -> prPrec i 0 (concatD [render "fset" ; prtOpenParen 0 openparen ; prtStr 0 str ; render "," ; prtExpr 0 expr1 ; render "," ; prtExpr 0 expr2 ; prtCloseParen 0 closeparen]) - | AbsBasilIR.Expr_FAccess (openparen, str, expr, closeparen) -> prPrec i 0 (concatD [render "faccess" ; prtOpenParen 0 openparen ; prtStr 0 str ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_ZeroExtend (openparen, intval, expr, closeparen) -> prPrec i 2 (concatD [render "zero_extend" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_SignExtend (openparen, intval, expr, closeparen) -> prPrec i 2 (concatD [render "sign_extend" ; prtOpenParen 0 openparen ; prtIntVal 0 intval ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_Extract (openparen, intval1, intval2, expr, closeparen) -> prPrec i 2 (concatD [render "extract" ; prtOpenParen 0 openparen ; prtIntVal 0 intval1 ; render "," ; prtIntVal 0 intval2 ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_Concat (openparen, exprs, closeparen) -> prPrec i 2 (concatD [render "bvconcat" ; prtOpenParen 0 openparen ; prtExprListBNFC 0 exprs ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_FSet (openparen, str, expr1, expr2, closeparen) -> prPrec i 2 (concatD [render "fset" ; prtOpenParen 0 openparen ; prtStr 0 str ; render "," ; prtExpr 0 expr1 ; render "," ; prtExpr 0 expr2 ; prtCloseParen 0 closeparen]) + | AbsBasilIR.Expr_FAccess (openparen, str, expr, closeparen) -> prPrec i 2 (concatD [render "faccess" ; prtOpenParen 0 openparen ; prtStr 0 str ; render "," ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Match (expr, openparen, cases, closeparen) -> prPrec i 2 (concatD [render "match" ; prtExpr 0 expr ; render "with" ; prtOpenParen 0 openparen ; prtCaseListBNFC 0 cases ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Cases (openparen, cases, closeparen) -> prPrec i 2 (concatD [render "cases" ; prtOpenParen 0 openparen ; prtCaseListBNFC 0 cases ; prtCloseParen 0 closeparen]) | AbsBasilIR.Expr_Paren (openparen, expr, closeparen) -> prPrec i 2 (concatD [prtOpenParen 0 openparen ; prtExpr 0 expr ; prtCloseParen 0 closeparen]) diff --git a/lib/fe/ShowBasilIR.ml b/lib/fe/ShowBasilIR.ml index 2b2e4398..010a5317 100644 --- a/lib/fe/ShowBasilIR.ml +++ b/lib/fe/ShowBasilIR.ml @@ -118,6 +118,10 @@ and showBVType (e : AbsBasilIR.bVType) : showable = match e with AbsBasilIR.BVType1 bvtype -> s2s "BVType1" >> c2s ' ' >> c2s '(' >> showBVTYPE bvtype >> c2s ')' +and showVarType (e : AbsBasilIR.varType) : showable = match e with + AbsBasilIR.VarType1 str -> s2s "VarType1" >> c2s ' ' >> c2s '(' >> showStr str >> c2s ')' + + and showMapType (e : AbsBasilIR.mapType) : showable = match e with AbsBasilIR.MapType1 (type'0, type') -> s2s "MapType1" >> c2s ' ' >> c2s '(' >> showTypeT type'0 >> s2s ", " >> showTypeT type' >> c2s ')' @@ -137,6 +141,7 @@ and showTypeT (e : AbsBasilIR.typeT) : showable = match e with | AbsBasilIR.TypeBVType bvtype -> s2s "TypeBVType" >> c2s ' ' >> c2s '(' >> showBVType bvtype >> c2s ')' | AbsBasilIR.TypePointerType pointertype -> s2s "TypePointerType" >> c2s ' ' >> c2s '(' >> showPointerType pointertype >> c2s ')' | AbsBasilIR.TypeRecordType recordtype -> s2s "TypeRecordType" >> c2s ' ' >> c2s '(' >> showRecordType recordtype >> c2s ')' + | AbsBasilIR.TypeVarType vartype -> s2s "TypeVarType" >> c2s ' ' >> c2s '(' >> showVarType vartype >> c2s ')' | AbsBasilIR.TypeParen (openparen, type', closeparen) -> s2s "TypeParen" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showTypeT type' >> s2s ", " >> showCloseParen closeparen >> c2s ')' | AbsBasilIR.TypeSort localident -> s2s "TypeSort" >> c2s ' ' >> c2s '(' >> showLocalIdent localident >> c2s ')' | AbsBasilIR.TypeMapType maptype -> s2s "TypeMapType" >> c2s ' ' >> c2s '(' >> showMapType maptype >> c2s ')' diff --git a/lib/fe/SkelBasilIR.ml b/lib/fe/SkelBasilIR.ml index a71dc1d5..20d29ade 100644 --- a/lib/fe/SkelBasilIR.ml +++ b/lib/fe/SkelBasilIR.ml @@ -141,6 +141,10 @@ and transBVType (x : bVType) : result = match x with BVType1 bvtype -> failure x +and transVarType (x : varType) : result = match x with + VarType1 str -> failure x + + and transMapType (x : mapType) : result = match x with MapType1 (type'0, type') -> failure x @@ -160,6 +164,7 @@ and transType (x : typeT) : result = match x with | TypeBVType bvtype -> failure x | TypePointerType pointertype -> failure x | TypeRecordType recordtype -> failure x + | TypeVarType vartype -> failure x | TypeParen (openparen, type', closeparen) -> failure x | TypeSort localident -> failure x | TypeMapType maptype -> failure x diff --git a/lib/loadir.ml b/lib/loadir.ml index 1280d0f4..9290499d 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -436,6 +436,7 @@ module BasilASTLoader = struct match field with | RecordField1 (id, ty) -> Types.mk_field (unsafe_unsigil (`Local id)) (trans_type ty) + and transRECORDTYPE (fields : field list) = Types.Record (StringMap.of_list @@ -456,6 +457,7 @@ module BasilASTLoader = struct | TypeSort t -> Types.Sort (unsafe_unsigil (`Local t), []) | TypeRecordType (RecordType1 (_, fields, _)) -> transRECORDTYPE fields | TypePointerType (PointerType1 (_, l, u, _)) -> transPOINTERTYPE l u + | TypeVarType (VarType1 name) -> Types.Variable (transStr name) and transIntVal (x : intVal) : PrimInt.t = match x with From bbcab9f4d5f431e582feb9562ad7f0ad13fc1f68 Mon Sep 17 00:00:00 2001 From: JTrenerry <105094182+JTrenerry@users.noreply.github.com> Date: Thu, 12 Mar 2026 13:50:05 +1000 Subject: [PATCH 29/29] changes str -> localIdent --- lib/fe/AbsBasilIR.ml | 6 +----- lib/fe/BasilIR.cf | 4 +--- lib/fe/ParBasilIR.mly | 12 ++---------- lib/fe/PrintBasilIR.ml | 7 +------ lib/fe/ShowBasilIR.ml | 7 +------ lib/fe/SkelBasilIR.ml | 7 +------ lib/loadir.ml | 3 +-- 7 files changed, 8 insertions(+), 38 deletions(-) diff --git a/lib/fe/AbsBasilIR.ml b/lib/fe/AbsBasilIR.ml index 7dd1dcc2..6851b539 100644 --- a/lib/fe/AbsBasilIR.ml +++ b/lib/fe/AbsBasilIR.ml @@ -67,9 +67,6 @@ and pointerType = and bVType = BVType1 of bVTYPE -and varType = - VarType1 of str - and mapType = MapType1 of typeT * typeT @@ -86,9 +83,8 @@ and typeT = | TypeBVType of bVType | TypePointerType of pointerType | TypeRecordType of recordType - | TypeVarType of varType + | TypeVarType of localIdent | TypeParen of openParen * typeT * closeParen - | TypeSort of localIdent | TypeMapType of mapType and intVal = diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index dd8e6dc2..799d1a25 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -80,7 +80,6 @@ BoolType1. BoolType ::= BOOLTYPE ; RecordType1 . RecordType ::= BeginRec [Field] EndRec ; PointerType1 . PointerType ::= "ptr" OpenParen Type "," Type CloseParen ; BVType1 . BVType ::= BVTYPE ; -VarType1 . VarType ::= Str ; -- map types are right associative. left of -> cannot be another MapType. MapType1 . MapType ::= Type1 "->" Type ; @@ -98,9 +97,8 @@ TypeBoolType . Type1 ::= BoolType ; TypeBVType . Type1 ::= BVType ; TypePointerType . Type1 ::= PointerType ; TypeRecordType . Type1 ::= RecordType ; -TypeVarType . Type1 ::= VarType ; +TypeVarType . Type1 ::= LocalIdent ; TypeParen . Type1 ::= OpenParen Type CloseParen; -TypeSort . Type1 ::= LocalIdent; TypeMapType . Type ::= MapType; _ . Type ::= Type1; diff --git a/lib/fe/ParBasilIR.mly b/lib/fe/ParBasilIR.mly index e5758d3d..85c60cab 100644 --- a/lib/fe/ParBasilIR.mly +++ b/lib/fe/ParBasilIR.mly @@ -45,7 +45,7 @@ open Lexing %token <(int * int) * string> TOK_IntegerHex %token <(int * int) * string> TOK_IntegerDec -%start pModuleT pDecl_list pBlockIdent_list pLambdaSep pVarModifiers pVarModifiers_list pDecl pTypeT_list pTypeAssign pTypeAssign_list pProcDef pField_list pField pIntType pBoolType pRecordType pPointerType pBVType pVarType pMapType pRecordField pRecordField_list pSumCase pSumCase_list pType1 pTypeT pIntVal pBVVal pFieldVal_list pFieldVal pEndian pAssignment pStmt pAssignment_list pLocalVar pLocalVar_list pGlobalVar pGlobalVar_list pVar pLocalVarParen pGlobalVarParen pLocalVarParen_list pNamedCallReturn pNamedCallReturn_list pLVars pNamedCallArg pNamedCallArg_list pCallParams pJump pLVar pLVar_list pBlock_list pStmtWithAttrib pStmtWithAttrib_list pJumpWithAttrib pPhiExpr pPhiExpr_list pPhiAssign pPhiAssign_list pBlock pAttrKeyValue pAttrKeyValue_list pAttribSet pAttr_list pAttr pParams pParams_list pValue pExpr_list pExpr pExpr1 pExpr2 pLambdaDef pBinOp pUnOp pCase pCase_list pEqOp pBVUnOp pBVBinOp pBVLogicalBinOp pIntBinOp pIntLogicalBinOp pBoolBinOp pPointerBinOp pRequireTok pEnsureTok pRelyTok pGuarTok pFunSpec pVarSpec pProgSpec pFunSpec_list pProgSpec_list +%start pModuleT pDecl_list pBlockIdent_list pLambdaSep pVarModifiers pVarModifiers_list pDecl pTypeT_list pTypeAssign pTypeAssign_list pProcDef pField_list pField pIntType pBoolType pRecordType pPointerType pBVType pMapType pRecordField pRecordField_list pSumCase pSumCase_list pType1 pTypeT pIntVal pBVVal pFieldVal_list pFieldVal pEndian pAssignment pStmt pAssignment_list pLocalVar pLocalVar_list pGlobalVar pGlobalVar_list pVar pLocalVarParen pGlobalVarParen pLocalVarParen_list pNamedCallReturn pNamedCallReturn_list pLVars pNamedCallArg pNamedCallArg_list pCallParams pJump pLVar pLVar_list pBlock_list pStmtWithAttrib pStmtWithAttrib_list pJumpWithAttrib pPhiExpr pPhiExpr_list pPhiAssign pPhiAssign_list pBlock pAttrKeyValue pAttrKeyValue_list pAttribSet pAttr_list pAttr pParams pParams_list pValue pExpr_list pExpr pExpr1 pExpr2 pLambdaDef pBinOp pUnOp pCase pCase_list pEqOp pBVUnOp pBVBinOp pBVLogicalBinOp pIntBinOp pIntLogicalBinOp pBoolBinOp pPointerBinOp pRequireTok pEnsureTok pRelyTok pGuarTok pFunSpec pVarSpec pProgSpec pFunSpec_list pProgSpec_list %type pModuleT %type pDecl_list %type pBlockIdent_list @@ -64,7 +64,6 @@ open Lexing %type pRecordType %type pPointerType %type pBVType -%type pVarType %type pMapType %type pRecordField %type pRecordField_list @@ -159,7 +158,6 @@ open Lexing %type recordType %type pointerType %type bVType -%type varType %type mapType %type recordField %type recordField_list @@ -293,8 +291,6 @@ pPointerType : pointerType TOK_EOF { $1 }; pBVType : bVType TOK_EOF { $1 }; -pVarType : varType TOK_EOF { $1 }; - pMapType : mapType TOK_EOF { $1 }; pRecordField : recordField TOK_EOF { $1 }; @@ -521,9 +517,6 @@ pointerType : KW_ptr openParen typeT SYMB2 typeT closeParen { PointerType1 ($2, bVType : bVTYPE { BVType1 $1 } ; -varType : str { VarType1 $1 } - ; - mapType : type1 SYMB3 typeT { MapType1 ($1, $3) } ; @@ -547,9 +540,8 @@ type1 : intType { TypeIntType $1 } | bVType { TypeBVType $1 } | pointerType { TypePointerType $1 } | recordType { TypeRecordType $1 } - | varType { TypeVarType $1 } + | localIdent { TypeVarType $1 } | openParen typeT closeParen { TypeParen ($1, $2, $3) } - | localIdent { TypeSort $1 } ; typeT : mapType { TypeMapType $1 } diff --git a/lib/fe/PrintBasilIR.ml b/lib/fe/PrintBasilIR.ml index c55bc65f..5a4ad15c 100644 --- a/lib/fe/PrintBasilIR.ml +++ b/lib/fe/PrintBasilIR.ml @@ -210,10 +210,6 @@ and prtBVType (i:int) (e : AbsBasilIR.bVType) : doc = match e with AbsBasilIR.BVType1 bvtype -> prPrec i 0 (concatD [prtBVTYPE 0 bvtype]) -and prtVarType (i:int) (e : AbsBasilIR.varType) : doc = match e with - AbsBasilIR.VarType1 str -> prPrec i 0 (concatD [prtStr 0 str]) - - and prtMapType (i:int) (e : AbsBasilIR.mapType) : doc = match e with AbsBasilIR.MapType1 (type_1, type_2) -> prPrec i 0 (concatD [prtTypeT 1 type_1 ; render "->" ; prtTypeT 0 type_2]) @@ -239,9 +235,8 @@ and prtTypeT (i:int) (e : AbsBasilIR.typeT) : doc = match e with | AbsBasilIR.TypeBVType bvtype -> prPrec i 1 (concatD [prtBVType 0 bvtype]) | AbsBasilIR.TypePointerType pointertype -> prPrec i 1 (concatD [prtPointerType 0 pointertype]) | AbsBasilIR.TypeRecordType recordtype -> prPrec i 1 (concatD [prtRecordType 0 recordtype]) - | AbsBasilIR.TypeVarType vartype -> prPrec i 1 (concatD [prtVarType 0 vartype]) + | AbsBasilIR.TypeVarType localident -> prPrec i 1 (concatD [prtLocalIdent 0 localident]) | AbsBasilIR.TypeParen (openparen, type_, closeparen) -> prPrec i 1 (concatD [prtOpenParen 0 openparen ; prtTypeT 0 type_ ; prtCloseParen 0 closeparen]) - | AbsBasilIR.TypeSort localident -> prPrec i 1 (concatD [prtLocalIdent 0 localident]) | AbsBasilIR.TypeMapType maptype -> prPrec i 0 (concatD [prtMapType 0 maptype]) and prtTypeTListBNFC i es : doc = match (i, es) with diff --git a/lib/fe/ShowBasilIR.ml b/lib/fe/ShowBasilIR.ml index 010a5317..cd9e5579 100644 --- a/lib/fe/ShowBasilIR.ml +++ b/lib/fe/ShowBasilIR.ml @@ -118,10 +118,6 @@ and showBVType (e : AbsBasilIR.bVType) : showable = match e with AbsBasilIR.BVType1 bvtype -> s2s "BVType1" >> c2s ' ' >> c2s '(' >> showBVTYPE bvtype >> c2s ')' -and showVarType (e : AbsBasilIR.varType) : showable = match e with - AbsBasilIR.VarType1 str -> s2s "VarType1" >> c2s ' ' >> c2s '(' >> showStr str >> c2s ')' - - and showMapType (e : AbsBasilIR.mapType) : showable = match e with AbsBasilIR.MapType1 (type'0, type') -> s2s "MapType1" >> c2s ' ' >> c2s '(' >> showTypeT type'0 >> s2s ", " >> showTypeT type' >> c2s ')' @@ -141,9 +137,8 @@ and showTypeT (e : AbsBasilIR.typeT) : showable = match e with | AbsBasilIR.TypeBVType bvtype -> s2s "TypeBVType" >> c2s ' ' >> c2s '(' >> showBVType bvtype >> c2s ')' | AbsBasilIR.TypePointerType pointertype -> s2s "TypePointerType" >> c2s ' ' >> c2s '(' >> showPointerType pointertype >> c2s ')' | AbsBasilIR.TypeRecordType recordtype -> s2s "TypeRecordType" >> c2s ' ' >> c2s '(' >> showRecordType recordtype >> c2s ')' - | AbsBasilIR.TypeVarType vartype -> s2s "TypeVarType" >> c2s ' ' >> c2s '(' >> showVarType vartype >> c2s ')' + | AbsBasilIR.TypeVarType localident -> s2s "TypeVarType" >> c2s ' ' >> c2s '(' >> showLocalIdent localident >> c2s ')' | AbsBasilIR.TypeParen (openparen, type', closeparen) -> s2s "TypeParen" >> c2s ' ' >> c2s '(' >> showOpenParen openparen >> s2s ", " >> showTypeT type' >> s2s ", " >> showCloseParen closeparen >> c2s ')' - | AbsBasilIR.TypeSort localident -> s2s "TypeSort" >> c2s ' ' >> c2s '(' >> showLocalIdent localident >> c2s ')' | AbsBasilIR.TypeMapType maptype -> s2s "TypeMapType" >> c2s ' ' >> c2s '(' >> showMapType maptype >> c2s ')' diff --git a/lib/fe/SkelBasilIR.ml b/lib/fe/SkelBasilIR.ml index 20d29ade..06a8175f 100644 --- a/lib/fe/SkelBasilIR.ml +++ b/lib/fe/SkelBasilIR.ml @@ -141,10 +141,6 @@ and transBVType (x : bVType) : result = match x with BVType1 bvtype -> failure x -and transVarType (x : varType) : result = match x with - VarType1 str -> failure x - - and transMapType (x : mapType) : result = match x with MapType1 (type'0, type') -> failure x @@ -164,9 +160,8 @@ and transType (x : typeT) : result = match x with | TypeBVType bvtype -> failure x | TypePointerType pointertype -> failure x | TypeRecordType recordtype -> failure x - | TypeVarType vartype -> failure x + | TypeVarType localident -> failure x | TypeParen (openparen, type', closeparen) -> failure x - | TypeSort localident -> failure x | TypeMapType maptype -> failure x diff --git a/lib/loadir.ml b/lib/loadir.ml index 9290499d..5dc8999a 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -454,10 +454,9 @@ module BasilASTLoader = struct | TypeMapType maptype -> transMapType maptype | TypeBVType (BVType1 bvtype) -> transBVTYPE bvtype | TypeParen (_, typeT, _) -> trans_type typeT - | TypeSort t -> Types.Sort (unsafe_unsigil (`Local t), []) + | TypeVarType name -> Types.Variable (unsafe_unsigil (`Local name)) | TypeRecordType (RecordType1 (_, fields, _)) -> transRECORDTYPE fields | TypePointerType (PointerType1 (_, l, u, _)) -> transPOINTERTYPE l u - | TypeVarType (VarType1 name) -> Types.Variable (transStr name) and transIntVal (x : intVal) : PrimInt.t = match x with