diff --git a/.github/actions/setup-isabelle-action/action.yml b/.github/actions/setup-isabelle-action/action.yml index 8bb90c4c..8031ac65 100644 --- a/.github/actions/setup-isabelle-action/action.yml +++ b/.github/actions/setup-isabelle-action/action.yml @@ -11,6 +11,16 @@ runs: repository: isabelle-prover/mirror-afp-2025-1 path: afp + - name: Patch AFP Isabelle/C parser + shell: bash + run: | + TARGET=afp/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Language.thy + sed -i \ + '/| (CDecl0 (\[CTypeSpec0 (CIntType0 _)\], \[\], _)) => ("int",decl)/{ + n + c\ | (CDecl0 (_, [((Some (CDeclr0 (nameIdent,_,_,_,_)),_),_)], _)) =>\n (getVarName nameIdent, decl)\n | (CDecl0 (_, [], _)) => ("unknown", decl)\n | dd => ("unknown", dd) + }' "$TARGET" + - name: Set AFP component base shell: bash run: | diff --git a/.github/patches/isabelle_c_parser_language.patch b/.github/patches/isabelle_c_parser_language.patch new file mode 100644 index 00000000..5220d551 --- /dev/null +++ b/.github/patches/isabelle_c_parser_language.patch @@ -0,0 +1,16 @@ +--- a/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Language.thy ++++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Parser_Language.thy +@@ -344,8 +344,11 @@ + | (CDecl0 ([CTypeSpec0 (CSignedType0 _)], [], _)) => ("signed",decl) + | (CDecl0 ([CTypeSpec0 (CUnsigType0 _)], [], _)) => ("unsigned",decl) + | (CDecl0 ([CTypeSpec0 (CBoolType0 _)], [], _)) => ("bool",decl) +- | (CDecl0 ([CTypeSpec0 (CIntType0 _)], [], _)) => ("int",decl) +- | dd => error ("unknown declaration format : "^ @{make_string} dd) ++ | (CDecl0 ([CTypeSpec0 (CIntType0 _)], [], _)) => ("int",decl) ++ | (CDecl0 (_, [((Some (CDeclr0 (nameIdent,_,_,_,_)),_),_)], _)) => ++ (getVarName nameIdent, decl) ++ | (CDecl0 (_, [], _)) => ("unknown", decl) ++ | dd => ("unknown", dd) + in + case ident of [CFunDeclr0 (Right (declarations,_),_,_)] => Some (map transformDeclaration declarations) + | _ => None diff --git a/AutoCorrode.thy b/AutoCorrode.thy index e9004874..14dc494b 100644 --- a/AutoCorrode.thy +++ b/AutoCorrode.thy @@ -18,11 +18,14 @@ theory AutoCorrode "Micro_C_Parsing_Frontend.C_To_Core_Translation" "Micro_C_Parsing_Frontend.C_File_Load_Smoke" "Micro_C_Parsing_Frontend.C_Parser_Smoke" + "Micro_C_Parsing_Frontend.C_Translation_Smoke_Advanced" "Micro_C_Parsing_Frontend.C_Translation_Smoke_Control" "Micro_C_Parsing_Frontend.C_Translation_Smoke_Core" "Micro_C_Parsing_Frontend.C_Translation_Smoke_Memory" "Micro_C_Parsing_Frontend.C_Translation_Smoke_Options" "Micro_C_Parsing_Frontend.C_Translation_Smoke_Types" + "Micro_C_Parsing_Frontend.C_Translation_Smoke_ILP32" + "Micro_C_Parsing_Frontend.C_Translation_Smoke_Compiler" "Shallow_Micro_C.C_Arithmetic_Rules" "Shallow_Micro_C.C_Abort" "Shallow_Micro_C.C_Abort_Rules" @@ -40,6 +43,7 @@ theory AutoCorrode "Micro_C_Examples.C_Void_Pointer_Examples" "Micro_C_Examples.C_Union_Examples" "Micro_C_Examples.C_Byte_Refinement" + "Micro_C_Examples.C_Misc_Examples" "Misc.Misc" "Lenses_And_Other_Optics.Lenses_And_Other_Optics" "Separation_Lenses.Separation_Lenses" diff --git a/Micro_C_Examples/C_ABI_Examples.thy b/Micro_C_Examples/C_ABI_Examples.thy index 3a3e34ea..d051c026 100644 --- a/Micro_C_Examples/C_ABI_Examples.thy +++ b/Micro_C_Examples/C_ABI_Examples.thy @@ -14,10 +14,21 @@ text \ \ locale c_char_uint_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + reference reference_types + ref_c_char: reference_allocatable reference_types _ _ _ _ _ _ _ c_char_prism + ref_c_uint: reference_allocatable reference_types _ _ _ _ _ _ _ c_uint_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ 'o prompt_output \ unit\ and c_char_prism :: \('gv, c_char) prism\ and c_uint_prism :: \('gv, c_uint) prism\ @@ -26,8 +37,15 @@ begin adhoc_overloading store_reference_const \ ref_c_char.new adhoc_overloading store_reference_const \ ref_c_uint.new adhoc_overloading store_update_const \ update_fun +adhoc_overloading c_void_cast_prism_for \ c_char_prism adhoc_overloading c_void_cast_prism_for \ c_uint_prism +definition c_char_ref_at :: \('addr, 'gv, c_char) Global_Store.ref \ nat \ ('addr, 'gv, c_char) Global_Store.ref\ where + \c_char_ref_at buf i \ + make_focused + (c_ptr_add (unwrap_focused buf) i (c_sizeof TYPE(c_char))) + (get_focus buf)\ + definition be32_from_bytes4 :: \c_char list \ c_uint\ where \be32_from_bytes4 vs \ (push_bit 24 (ucast (vs ! 0) :: c_uint)) @@ -81,18 +99,29 @@ lemma wire_le_abi_profile_values: by (simp_all add: wire_le_abi_pointer_bits_def wire_le_abi_long_bits_def wire_le_abi_big_endian_def) definition wire_le_load_be32_portable_contract :: - \('addr, 'gv, c_char list) Global_Store.ref \ 'gv \ c_char list \ + \('addr, 'gv, c_char) Global_Store.ref \ c_char \ c_char \ c_char \ c_char \ ('s::{sepalg}, c_uint, 'b) function_contract\ where - [crush_contracts]: \wire_le_load_be32_portable_contract buf bg vs \ - let pre = buf \\\\ bg\vs \ \3 < size buf\ \ \length vs \ 4\; - post = \r. buf \\\\ bg\vs \ \r = be32_from_bytes4 vs\ + [crush_contracts]: \wire_le_load_be32_portable_contract buf b0 b1 b2 b3 \ + let r0 = c_char_ref_at buf 0; + r1 = c_char_ref_at buf 1; + r2 = c_char_ref_at buf 2; + r3 = c_char_ref_at buf 3; + pre = (\g0. r0 \\\\ g0\b0) + \ (\g1. r1 \\\\ g1\b1) + \ (\g2. r2 \\\\ g2\b2) + \ (\g3. r3 \\\\ g3\b3); + post = \r. (\g0. r0 \\\\ g0\b0) + \ (\g1. r1 \\\\ g1\b1) + \ (\g2. r2 \\\\ g2\b2) + \ (\g3. r3 \\\\ g3\b3) + \ \r = be32_from_bytes4 [b0, b1, b2, b3]\ in make_function_contract pre post\ ucincl_auto wire_le_load_be32_portable_contract lemma wire_le_load_be32_portable_spec [crush_specs]: - shows \\; wire_le_load_be32_portable buf \\<^sub>F wire_le_load_be32_portable_contract buf bg vs\ + shows \\; wire_le_load_be32_portable buf \\<^sub>F wire_le_load_be32_portable_contract buf b0 b1 b2 b3\ apply (crush_boot f: wire_le_load_be32_portable_def contract: wire_le_load_be32_portable_contract_def) - apply (crush_base simp add: be32_from_bytes4_def c_unsigned_or_def c_unsigned_shl_def c_ucast_def) + apply (crush_base simp add: c_char_ref_at_def be32_from_bytes4_def c_unsigned_or_def c_unsigned_shl_def c_ucast_def) apply (simp add: ac_simps) done @@ -143,18 +172,29 @@ lemma wire_be_abi_profile_values: by (simp_all add: wire_be_abi_pointer_bits_def wire_be_abi_long_bits_def wire_be_abi_big_endian_def) definition wire_be_load_be32_portable_contract :: - \('addr, 'gv, c_char list) Global_Store.ref \ 'gv \ c_char list \ + \('addr, 'gv, c_char) Global_Store.ref \ c_char \ c_char \ c_char \ c_char \ ('s::{sepalg}, c_uint, 'b) function_contract\ where - [crush_contracts]: \wire_be_load_be32_portable_contract buf bg vs \ - let pre = buf \\\\ bg\vs \ \3 < size buf\ \ \length vs \ 4\; - post = \r. buf \\\\ bg\vs \ \r = be32_from_bytes4 vs\ + [crush_contracts]: \wire_be_load_be32_portable_contract buf b0 b1 b2 b3 \ + let r0 = c_char_ref_at buf 0; + r1 = c_char_ref_at buf 1; + r2 = c_char_ref_at buf 2; + r3 = c_char_ref_at buf 3; + pre = (\g0. r0 \\\\ g0\b0) + \ (\g1. r1 \\\\ g1\b1) + \ (\g2. r2 \\\\ g2\b2) + \ (\g3. r3 \\\\ g3\b3); + post = \r. (\g0. r0 \\\\ g0\b0) + \ (\g1. r1 \\\\ g1\b1) + \ (\g2. r2 \\\\ g2\b2) + \ (\g3. r3 \\\\ g3\b3) + \ \r = be32_from_bytes4 [b0, b1, b2, b3]\ in make_function_contract pre post\ ucincl_auto wire_be_load_be32_portable_contract lemma wire_be_load_be32_portable_spec [crush_specs]: - shows \\; wire_be_load_be32_portable buf \\<^sub>F wire_be_load_be32_portable_contract buf bg vs\ + shows \\; wire_be_load_be32_portable buf \\<^sub>F wire_be_load_be32_portable_contract buf b0 b1 b2 b3\ apply (crush_boot f: wire_be_load_be32_portable_def contract: wire_be_load_be32_portable_contract_def) - apply (crush_base simp add: be32_from_bytes4_def c_unsigned_or_def c_unsigned_shl_def c_ucast_def) + apply (crush_base simp add: c_char_ref_at_def be32_from_bytes4_def c_unsigned_or_def c_unsigned_shl_def c_ucast_def) apply (simp add: ac_simps) done @@ -182,6 +222,39 @@ lemma wire_be_u32_prism_is_be: shows \wire_be_u32_prism = c_uint_byte_prism_be\ by (simp add: wire_be_u32_prism_def c_endianness_of_bool_def c_uint_byte_prism_of_def wire_be_abi_big_endian_def) +section \Raw Struct Field Address Regression\ + +text \ + Regression for raw @{verbatim "void *"} cast to struct pointer followed by + address-of field extraction and a helper that immediately reinterprets the + resulting field pointer as bytes. +\ + +micro_c_translate prefix: raw_struct_ abi: ilp32-le \ + typedef unsigned char uint8_t; + typedef unsigned int uint32_t; + + struct pair { + uint32_t x; + uint32_t y; + }; + + static uint32_t load_be32(const uint32_t *p) { + const uint8_t *bp = (const uint8_t *)p; + return ((uint32_t)bp[0] << 24) + | ((uint32_t)bp[1] << 16) + | ((uint32_t)bp[2] << 8) + | (uint32_t)bp[3]; + } + + uint32_t read_pair_y_be(const void *p) { + return load_be32(&((const struct pair *)p)->y); + } +\ + +thm raw_struct_load_be32_def +thm raw_struct_read_pair_y_be_def + end end diff --git a/Micro_C_Examples/C_Array_Examples.thy b/Micro_C_Examples/C_Array_Examples.thy index 716e05e7..47eda34b 100644 --- a/Micro_C_Examples/C_Array_Examples.thy +++ b/Micro_C_Examples/C_Array_Examples.thy @@ -6,9 +6,9 @@ begin section \C array verification\ text \ - This theory demonstrates verification of C array indexing operations. - Arrays are modeled as references to @{typ \c_int list\}. - Array indexing uses @{const focus_nth} (focus-based access). + This theory demonstrates verification of pointer-indexed C array operations. + Pointer parameters are modeled as references to the current element, and + indexing is expressed via @{const c_ptr_add} over the underlying pointer model. \ subsection \Helper Definitions for Array Loop Proofs\ @@ -78,6 +78,12 @@ lemma sint_word_of_nat_Suc_ge_zero: context c_verification_ctx begin +definition c_int_ref_at :: \('addr, 'gv, c_int) Global_Store.ref \ c_int \ ('addr, 'gv, c_int) Global_Store.ref\ where + \c_int_ref_at arr idx \ + make_focused + (c_ptr_shift_signed (unwrap_focused arr) (sint idx) (c_sizeof TYPE(c_int))) + (get_focus arr)\ + subsection \C Array Functions\ micro_c_translate \ @@ -99,22 +105,39 @@ thm c_write_at_def subsection \Read-at Contract and Proof\ text \ - The contract for @{text read_at}: given a reference to a @{typ \c_int list\} - and a valid index, the function returns the element at that index. - The @{const c_idx_to_nat} function converts the C integer index to a natural number. + The contract for @{text read_at}: given a reference to the current element of an + integer array and an index, the function reads the element at that shifted location. \ -definition c_read_at_contract :: \('addr, 'gv, c_int list) Global_Store.ref \ c_int \ - 'gv \ c_int list \ ('s, c_int, 'b) function_contract\ where - [crush_contracts]: \c_read_at_contract arr idx g vs \ - let pre = arr \\\\ g\vs \ \\ (sint idx < 0)\ \ \c_idx_to_nat idx < length vs\; - post = \r. arr \\\\ g\vs \ \r = vs ! (c_idx_to_nat idx)\ +definition c_read_at_contract :: \('addr, 'gv, c_int) Global_Store.ref \ c_int \ + 'gv \ c_int \ ('s, c_int, 'b) function_contract\ where + [crush_contracts]: \c_read_at_contract arr idx g v \ + let elem_ref = c_int_ref_at arr idx; + pre = elem_ref \\\\ g\v; + post = \r. elem_ref \\\\ g\v \ \r = v\ in make_function_contract pre post\ ucincl_auto c_read_at_contract lemma c_read_at_spec: - shows \\; c_read_at arr idx \\<^sub>F c_read_at_contract arr idx g vs\ -by (crush_boot f: c_read_at_def contract: c_read_at_contract_def) crush_base + shows \\; c_read_at arr idx \\<^sub>F c_read_at_contract arr idx g v\ +by (crush_boot f: c_read_at_def contract: c_read_at_contract_def) + (crush_base simp add: c_int_ref_at_def) + +subsection \Write-at Contract and Proof\ + +definition c_write_at_contract :: \('addr, 'gv, c_int) Global_Store.ref \ c_int \ + 'gv \ c_int \ c_int \ ('s, unit, 'b) function_contract\ where + [crush_contracts]: \c_write_at_contract arr idx g old_v new_v \ + let elem_ref = c_int_ref_at arr idx; + pre = elem_ref \\\\ g\old_v; + post = \_. elem_ref \\\\ (\_. new_v) \ (g\old_v) + in make_function_contract pre post\ +ucincl_auto c_write_at_contract + +lemma c_write_at_spec: + shows \\; c_write_at arr idx val \\<^sub>F c_write_at_contract arr idx g old_v val\ +by (crush_boot f: c_write_at_def contract: c_write_at_contract_def) + (crush_base simp add: c_int_ref_at_def) subsection \Array Fill (memset-style)\ @@ -133,33 +156,11 @@ micro_c_translate \ thm c_array_fill_def -definition c_array_fill_contract :: \('addr, 'gv, c_int list) Global_Store.ref \ c_int \ c_uint \ - 'gv \ c_int list \ ('s, 'a, 'b) function_contract\ where - \c_array_fill_contract arr val n g vs \ - let pre = arr \\\\ g\vs \ - \c_idx_to_nat n \ size arr\ \ - \c_idx_to_nat n \ length vs\ \ - \c_idx_to_nat n < 2147483648\ \ - can_alloc_reference; - post = \_. (\g'. arr \\\\ g'\(list_fill_prefix (c_idx_to_nat n) val vs)) \ - can_alloc_reference - in make_function_contract pre post\ -ucincl_auto c_array_fill_contract - -lemma c_array_fill_spec: - shows \\; c_array_fill arr val n \\<^sub>F c_array_fill_contract arr val n g vs\ - apply (crush_boot f: c_array_fill_def contract: c_array_fill_contract_def) - apply crush_base - apply (ucincl_discharge\ - rule_tac - INV=\\_ i. (\ g. arr \\\\ g\(list_fill_prefix i val vs)) - \ \\ sint (word_of_nat i :: c_int) < 0\\ - and \=\\_. \False\\ - and \=\\_. \False\\ - in wp_raw_for_loop_framedI'\) - using unat_lt2p[of n] apply (crush_base simp add: list_fill_prefix_step unat_of_nat_eq More_Word.sint_of_nat_ge_zero) - apply (metis sint_word_of_nat_Suc_ge_zero not_le) - done +text \ + @{term c_array_fill_def} is kept as a translation regression for pointer-indexed loop writes. + A full whole-array contract now requires a contiguous raw-pointer region predicate, rather than + the old list-backed pointer model this theory previously assumed. +\ subsection \Array Copy (memcpy-style)\ @@ -178,37 +179,11 @@ micro_c_translate \ thm c_array_copy_def -definition c_array_copy_contract :: \('addr, 'gv, c_int list) Global_Store.ref \ - ('addr, 'gv, c_int list) Global_Store.ref \ c_uint \ 'gv \ c_int list \ 'gv \ - c_int list \ ('s, 'a, 'b) function_contract\ where - \c_array_copy_contract dst src n gd vd gs vs \ - let pre = dst \\\\ gd\vd \ src \\\\ gs\vs \ - \c_idx_to_nat n \ size dst\ \ - \c_idx_to_nat n \ size src\ \ - \c_idx_to_nat n \ length vd\ \ - \c_idx_to_nat n \ length vs\ \ - \c_idx_to_nat n < 2147483648\ \ - can_alloc_reference; - post = \_. (\ g'. dst \\\\ g'\(list_copy_prefix (c_idx_to_nat n) vs vd)) \ - src \\\\ gs\vs \ - can_alloc_reference - in make_function_contract pre post\ -ucincl_auto c_array_copy_contract - -lemma c_array_copy_spec: - shows \\; c_array_copy dst src n \\<^sub>F c_array_copy_contract dst src n gd vd gs vs\ - apply (crush_boot f: c_array_copy_def contract: c_array_copy_contract_def) - apply crush_base - apply (ucincl_discharge\ - rule_tac - INV=\\_ i. ((\ g. dst \\\\ g\(list_copy_prefix i vs vd)) \ src \\\\ gs\vs) - \ \\ sint (word_of_nat i :: c_int) < 0\\ - and \=\\_. \False\\ - and \=\\_. \False\\ - in wp_raw_for_loop_framedI'\) - using unat_lt2p[of n] apply (crush_base simp add: list_copy_prefix_step unat_of_nat_eq More_Word.sint_of_nat_ge_zero) - apply (metis sint_word_of_nat_Suc_ge_zero not_le) - done +text \ + @{term c_array_copy_def} is kept as a translation regression for pointer-indexed read/write loops. + Proving a semantic copy contract over raw pointers needs the same contiguous-region predicate as + @{term c_array_fill_def}. +\ end diff --git a/Micro_C_Examples/C_Bitwise_Examples.thy b/Micro_C_Examples/C_Bitwise_Examples.thy index 969b516c..46ec6819 100644 --- a/Micro_C_Examples/C_Bitwise_Examples.thy +++ b/Micro_C_Examples/C_Bitwise_Examples.thy @@ -73,6 +73,25 @@ lemma c_u_shl_spec [crush_specs]: by (crush_boot f: c_u_shl_def contract: c_u_shl_contract_def) (crush_base simp add: c_unsigned_shl_def) +text \Shift out of range: when the shift amount exceeds the bit width, + the operation correctly aborts with @{const ShiftOutOfRange}.\ + +definition c_u_shl_oor_contract :: + \c_uint \ c_uint \ ('s::{sepalg}, c_uint, c_abort) function_contract\ where + [crush_contracts]: \c_u_shl_oor_contract x n \ + let pre = \\ unat n < 32\; + post = \_. \True\; + abort_post = \ab. \ab = CustomAbort ShiftOutOfRange\ + in make_function_contract_with_abort pre post abort_post\ +ucincl_auto c_u_shl_oor_contract + +lemma c_u_shl_oor_spec: + shows \\; c_u_shl x n \\<^sub>F c_u_shl_oor_contract x n\ + apply (crush_boot f: c_u_shl_def contract: c_u_shl_oor_contract_def) + apply (simp only: c_unsigned_shl_def) + apply (crush_base simp add: c_shift_out_of_range_def c_abort_def) + done + subsection \Interesting semantic examples\ text \Mask low byte: result fits in a byte.\ diff --git a/Micro_C_Examples/C_Misc_Examples.thy b/Micro_C_Examples/C_Misc_Examples.thy new file mode 100644 index 00000000..9dd5f632 --- /dev/null +++ b/Micro_C_Examples/C_Misc_Examples.thy @@ -0,0 +1,266 @@ +theory C_Misc_Examples + imports + "Micro_C_Parsing_Frontend.C_To_Core_Translation" + "Shallow_Micro_C.C_Arithmetic_Rules" + "Micro_Rust_Std_Lib.StdLib_All" +begin + +section \Miscellaneous C Feature Tests\ + +text \ + Smoke tests for minor C frontend features: @{text "_Static_assert"}, + range case labels, @{text "_Alignas"}, @{text "__builtin_types_compatible_p"}, + and character constants. +\ + +locale c_misc_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + + reference reference_types + + ref_c_uint: reference_allocatable reference_types _ _ _ _ _ _ _ c_uint_prism + + ref_c_uint_ptr: reference_allocatable reference_types _ _ _ _ _ _ _ c_uint_ptr_prism + + ref_c_int: reference_allocatable reference_types _ _ _ _ _ _ _ c_int_prism + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ + 'o prompt_output \ unit\ + and c_uint_prism :: \('gv, c_uint) prism\ + and c_uint_ptr_prism :: \('gv, ('addr, 'gv, c_uint) Global_Store.ref) prism\ + and c_int_prism :: \('gv, c_int) prism\ +begin + +adhoc_overloading store_reference_const \ ref_c_uint.new +adhoc_overloading store_reference_const \ ref_c_uint_ptr.new +adhoc_overloading store_reference_const \ ref_c_int.new +adhoc_overloading store_update_const \ update_fun + +subsection \Static Assert\ + +micro_c_translate \ + _Static_assert(sizeof(int) == 4, "int must be 32 bits"); + + unsigned int static_assert_test(unsigned int x) { + _Static_assert(1, "trivially true"); + return x + 1; + } +\ + +definition c_static_assert_test_contract :: \c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_static_assert_test_contract x \ + let pre = \True\; + post = \r. \r = x + 1\ + in make_function_contract pre post\ +ucincl_auto c_static_assert_test_contract + +lemma c_static_assert_test_spec [crush_specs]: + shows \\; c_static_assert_test x \\<^sub>F c_static_assert_test_contract x\ +by (crush_boot f: c_static_assert_test_def contract: c_static_assert_test_contract_def) + (crush_base simp add: c_unsigned_add_def) + +subsection \Range Case Labels\ + +micro_c_translate \ + unsigned int range_case(unsigned int x) { + unsigned int result; + switch (x) { + case 1 ... 5: + result = 1; + break; + case 10 ... 20: + result = 2; + break; + default: + result = 0; + break; + } + return result; + } +\ + +definition c_range_case_contract :: \c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_range_case_contract x \ + let pre = can_alloc_reference; + post = \r. can_alloc_reference \ + \r = (if 1 \ x \ x \ 5 then 1 + else if 10 \ x \ x \ 20 then 2 + else 0)\ + in make_function_contract pre post\ +ucincl_auto c_range_case_contract + +lemma c_range_case_spec [crush_specs]: + shows \\; c_range_case x \\<^sub>F c_range_case_contract x\ +by (crush_boot f: c_range_case_def contract: c_range_case_contract_def) + crush_base + +subsection \Alignas Specifier\ + +micro_c_translate \ + unsigned int alignas_test(unsigned int x) { + _Alignas(16) unsigned int y = x + 1; + return y; + } +\ + +definition c_alignas_test_contract :: \c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_alignas_test_contract x \ + let pre = can_alloc_reference; + post = \r. can_alloc_reference \ \r = x + 1\ + in make_function_contract pre post\ +ucincl_auto c_alignas_test_contract + +lemma c_alignas_test_spec [crush_specs]: + shows \\; c_alignas_test x \\<^sub>F c_alignas_test_contract x\ +by (crush_boot f: c_alignas_test_def contract: c_alignas_test_contract_def) + (crush_base simp add: c_unsigned_add_def) + +subsection \Builtin Types Compatible\ + +micro_c_translate \ + unsigned int types_compat_test(unsigned int x) { + if (__builtin_types_compatible_p(unsigned int, unsigned int)) + return x; + else + return 0; + } +\ + +definition c_types_compat_test_contract :: \c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_types_compat_test_contract x \ + let pre = \True\; + post = \r. \r = x\ + in make_function_contract pre post\ +ucincl_auto c_types_compat_test_contract + +lemma c_types_compat_test_spec [crush_specs]: + shows \\; c_types_compat_test x \\<^sub>F c_types_compat_test_contract x\ +by (crush_boot f: c_types_compat_test_def contract: c_types_compat_test_contract_def) + crush_base + +subsection \Character Constants\ + +micro_c_translate \ + int char_val(void) { + return 'A'; + } +\ + +definition c_char_val_contract :: \('s::{sepalg}, c_int, 'b) function_contract\ where + [crush_contracts]: \c_char_val_contract \ + let pre = \True\; + post = \r. \r = 65\ + in make_function_contract pre post\ +ucincl_auto c_char_val_contract + +lemma c_char_val_spec [crush_specs]: + shows \\; c_char_val \\<^sub>F c_char_val_contract\ +by (crush_boot f: c_char_val_def contract: c_char_val_contract_def) + crush_base + +subsection \Register Storage Class\ + +micro_c_translate \ + unsigned int register_add(register unsigned int x) { + register unsigned int y = x + 1; + return y; + } +\ + +definition c_register_add_contract :: \c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_register_add_contract x \ + let pre = can_alloc_reference; + post = \r. can_alloc_reference \ \r = x + 1\ + in make_function_contract pre post\ +ucincl_auto c_register_add_contract + +lemma c_register_add_spec [crush_specs]: + shows \\; c_register_add x \\<^sub>F c_register_add_contract x\ +by (crush_boot f: c_register_add_def contract: c_register_add_contract_def) + (crush_base simp add: c_unsigned_add_def) + +subsection \Builtin Offsetof\ + +micro_c_translate \ + struct offset_test { int a; int b; }; + typedef unsigned long offset_size_t; + offset_size_t offset_of_b(void) { + return __builtin_offsetof(struct offset_test, b); + } +\ + +definition c_offset_of_b_contract :: \('s::{sepalg}, c_ulong, 'b) function_contract\ where + [crush_contracts]: \c_offset_of_b_contract \ + let pre = \True\; + post = \r. \r = 4\ + in make_function_contract pre post\ +ucincl_auto c_offset_of_b_contract + +lemma c_offset_of_b_spec [crush_specs]: + shows \\; c_offset_of_b \\<^sub>F c_offset_of_b_contract\ +by (crush_boot f: c_offset_of_b_def contract: c_offset_of_b_contract_def) + crush_base + +subsection \Range Designators\ + +micro_c_translate \ + static unsigned int range_arr[4] = { [0 ... 1] = 10, [2 ... 3] = 20 }; + unsigned int range_test(unsigned int i) { + return range_arr[i]; + } +\ + +definition c_range_test_contract :: \c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_range_test_contract i \ + let pre = \i = 0\; + post = \r. \r = 10\ + in make_function_contract pre post\ +ucincl_auto c_range_test_contract + +lemma c_range_test_spec [crush_specs]: + shows \\; c_range_test i \\<^sub>F c_range_test_contract i\ +by (crush_boot f: c_range_test_def contract: c_range_test_contract_def) + crush_base + +subsection \Struct Compound Literal\ + +micro_c_translate addr: nat \ + struct compound_lit_pair { int x; int y; }; + void compound_lit_write(struct compound_lit_pair *out) { + *out = (struct compound_lit_pair){3, 7}; + } +\ + +thm c_compound_lit_write_def + +subsection \Statement Expression\ + +micro_c_translate \ + unsigned int stmt_expr_add(unsigned int x) { + return ({ + unsigned int r = x + 1; + r; + }); + } +\ + +definition c_stmt_expr_add_contract :: \c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_stmt_expr_add_contract x \ + let pre = can_alloc_reference; + post = \r. can_alloc_reference \ \r = x + 1\ + in make_function_contract pre post\ +ucincl_auto c_stmt_expr_add_contract + +lemma c_stmt_expr_add_spec [crush_specs]: + shows \\; c_stmt_expr_add x \\<^sub>F c_stmt_expr_add_contract x\ +by (crush_boot f: c_stmt_expr_add_def contract: c_stmt_expr_add_contract_def) + (crush_base simp add: c_unsigned_add_def) + +end + +end diff --git a/Micro_C_Examples/C_Struct_Examples.thy b/Micro_C_Examples/C_Struct_Examples.thy index 902a6a29..e3425d2a 100644 --- a/Micro_C_Examples/C_Struct_Examples.thy +++ b/Micro_C_Examples/C_Struct_Examples.thy @@ -26,7 +26,7 @@ locale c_struct_verification_ctx = reference reference_types + ref_c_int: reference_allocatable reference_types _ _ _ _ _ _ _ c_int_prism + ref_c_point: reference_allocatable reference_types _ _ _ _ _ _ _ c_point_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ 'abort \ 'i prompt \ + for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ 'o prompt_output \ unit\ and c_int_prism :: \('gv, c_int) prism\ and c_point_prism :: \('gv, c_point) prism\ @@ -67,9 +67,144 @@ definition c_swap_coords_contract :: \('addr, 'gv, c_point) Global_Store.r in make_function_contract pre post\ ucincl_auto c_swap_coords_contract +lemma c_point_x_focus_view [simp]: + shows \focus_view (Abs_focus (make_focus_raw (\s. Some (c_point_x s)) (\y. update_c_point_x (\_. y)))) pval = Some (c_point_x pval)\ +proof - + have valid_via_modify: \is_valid_focus (make_focus_raw_via_view_modify (\s. Some (c_point_x s)) update_c_point_x)\ + proof (rule is_valid_focus_via_modifyI') + show \is_valid_view_modify (\s. Some (c_point_x s)) update_c_point_x\ + unfolding is_valid_view_modify_def + proof (intro conjI allI impI) + fix f s + show \Some (c_point_x (update_c_point_x f s)) = map_option f (Some (c_point_x s))\ + by (cases s) simp + next + fix f s + assume eq: \map_option f (Some (c_point_x s)) = Some (c_point_x s)\ + then have fx: \f (c_point_x s) = c_point_x s\ + by simp + show \update_c_point_x f s = s\ + proof (cases s) + case (make_c_point x1 x2) + from fx make_c_point have \f x1 = x1\ + by simp + then show ?thesis + using make_c_point by (simp add: c_point.record_simps c_point.expand) + qed + next + fix f g s + show \update_c_point_x f (update_c_point_x g s) = update_c_point_x (\x. f (g x)) s\ + by (cases s) simp + qed + qed + then have valid: \is_valid_focus (make_focus_raw (\s. Some (c_point_x s)) (\y. update_c_point_x (\_. y)))\ + by (simp add: make_focus_raw_via_view_modify_def) + then show ?thesis + by (auto simp add: eq_onp_same_args focus_view.abs_eq Abs_focus_inverse) +qed + +lemma c_point_y_focus_view [simp]: + shows \focus_view (Abs_focus (make_focus_raw (\s. Some (c_point_y s)) (\y. update_c_point_y (\_. y)))) pval = Some (c_point_y pval)\ +proof - + have valid_via_modify: \is_valid_focus (make_focus_raw_via_view_modify (\s. Some (c_point_y s)) update_c_point_y)\ + proof (rule is_valid_focus_via_modifyI') + show \is_valid_view_modify (\s. Some (c_point_y s)) update_c_point_y\ + unfolding is_valid_view_modify_def + proof (intro conjI allI impI) + fix f s + show \Some (c_point_y (update_c_point_y f s)) = map_option f (Some (c_point_y s))\ + by (cases s) simp + next + fix f s + assume eq: \map_option f (Some (c_point_y s)) = Some (c_point_y s)\ + then have fy: \f (c_point_y s) = c_point_y s\ + by simp + show \update_c_point_y f s = s\ + proof (cases s) + case (make_c_point x1 x2) + from fy make_c_point have \f x2 = x2\ + by simp + then show ?thesis + using make_c_point by (simp add: c_point.record_simps c_point.expand) + qed + next + fix f g s + show \update_c_point_y f (update_c_point_y g s) = update_c_point_y (\x. f (g x)) s\ + by (cases s) simp + qed + qed + then have valid: \is_valid_focus (make_focus_raw (\s. Some (c_point_y s)) (\y. update_c_point_y (\_. y)))\ + by (simp add: make_focus_raw_via_view_modify_def) + then show ?thesis + by (auto simp add: eq_onp_same_args focus_view.abs_eq Abs_focus_inverse) +qed + +lemma c_point_x_lens_focus_view [simp]: + shows \focus_view (Abs_focus (lens_to_focus_raw (make_lens_via_view_modify c_point_x update_c_point_x))) pval = Some (c_point_x pval)\ +proof - + have valid_vm: \is_valid_lens_view_modify c_point_x update_c_point_x\ + unfolding is_valid_lens_view_modify_def + proof (intro conjI allI impI) + fix f s + show \c_point_x (update_c_point_x f s) = f (c_point_x s)\ + by (cases s) simp + next + fix f s + assume eq: \f (c_point_x s) = c_point_x s\ + show \update_c_point_x f s = s\ + proof (cases s) + case (make_c_point x1 x2) + from eq make_c_point have \f x1 = x1\ + by simp + then show ?thesis + using make_c_point by (simp add: c_point.record_simps c_point.expand) + qed + next + fix f g s + show \update_c_point_x f (update_c_point_x g s) = update_c_point_x (\x. f (g x)) s\ + by (cases s) simp + qed + have valid: \is_valid_lens (make_lens_via_view_modify c_point_x update_c_point_x)\ + by (rule is_valid_lens_via_modifyI'[OF valid_vm]) + from lens_to_focus_raw_components'[OF valid] show ?thesis + by (simp add: make_lens_via_view_modify_components) +qed + +lemma c_point_y_lens_focus_view [simp]: + shows \focus_view (Abs_focus (lens_to_focus_raw (make_lens_via_view_modify c_point_y update_c_point_y))) pval = Some (c_point_y pval)\ +proof - + have valid_vm: \is_valid_lens_view_modify c_point_y update_c_point_y\ + unfolding is_valid_lens_view_modify_def + proof (intro conjI allI impI) + fix f s + show \c_point_y (update_c_point_y f s) = f (c_point_y s)\ + by (cases s) simp + next + fix f s + assume eq: \f (c_point_y s) = c_point_y s\ + show \update_c_point_y f s = s\ + proof (cases s) + case (make_c_point x1 x2) + from eq make_c_point have \f x2 = x2\ + by simp + then show ?thesis + using make_c_point by (simp add: c_point.record_simps c_point.expand) + qed + next + fix f g s + show \update_c_point_y f (update_c_point_y g s) = update_c_point_y (\x. f (g x)) s\ + by (cases s) simp + qed + have valid: \is_valid_lens (make_lens_via_view_modify c_point_y update_c_point_y)\ + by (rule is_valid_lens_via_modifyI'[OF valid_vm]) + from lens_to_focus_raw_components'[OF valid] show ?thesis + by (simp add: make_lens_via_view_modify_components) +qed + lemma c_swap_coords_spec: shows \\; c_swap_coords pref \\<^sub>F c_swap_coords_contract pref pg pval\ -by (crush_boot f: c_swap_coords_def contract: c_swap_coords_contract_def) crush_base +by (crush_boot f: c_swap_coords_def contract: c_swap_coords_contract_def) + (crush_base simp add: c_point.record_simps) end diff --git a/Micro_C_Examples/C_Union_Examples.thy b/Micro_C_Examples/C_Union_Examples.thy index cf5e5423..12a40cae 100644 --- a/Micro_C_Examples/C_Union_Examples.thy +++ b/Micro_C_Examples/C_Union_Examples.thy @@ -129,7 +129,7 @@ using c_uint_byte_prism_valid[unfolded c_uint_byte_prism_def] by (simp add: c_in } Key union use case: writing through one field and reading through another. *) -micro_c_translate \ +micro_c_translate gv: \byte list\ \ union U { int i; unsigned int u; diff --git a/Micro_C_Examples/C_Void_Pointer_Examples.thy b/Micro_C_Examples/C_Void_Pointer_Examples.thy index b98e9c76..a5907d4e 100644 --- a/Micro_C_Examples/C_Void_Pointer_Examples.thy +++ b/Micro_C_Examples/C_Void_Pointer_Examples.thy @@ -18,7 +18,7 @@ locale c_void_verification_ctx = reference reference_types + ref_c_int: reference_allocatable reference_types _ _ _ _ _ _ _ c_int_prism + ref_c_uint: reference_allocatable reference_types _ _ _ _ _ _ _ c_uint_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ 'abort \ 'i prompt \ + for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ 'o prompt_output \ unit\ and c_int_prism :: \('gv, c_int) prism\ and c_uint_prism :: \('gv, c_uint) prism\ @@ -41,14 +41,14 @@ text \ definition c_read_via_void :: \('addr, 'gv) gref \ - ('s, c_int, 'abort, 'i prompt, 'o prompt_output) function_body\ where + ('s, c_int, c_abort, 'i prompt, 'o prompt_output) function_body\ where \c_read_via_void p \ FunctionBody (bind (literal (c_cast_from_void c_int_prism p)) (deep_compose1 call dereference_fun))\ definition c_read_via_void_contract :: \('addr, 'gv) gref \ 'gv \ c_int \ - ('s, c_int, 'abort) function_contract\ where + ('s, c_int, c_abort) function_contract\ where \c_read_via_void_contract p g v \ let typed_p = c_cast_from_void c_int_prism p; pre = typed_p \\\\ g\v; @@ -70,14 +70,14 @@ text \ definition c_write_via_void :: \('addr, 'gv) gref \ c_uint \ - ('s, unit, 'abort, 'i prompt, 'o prompt_output) function_body\ where + ('s, unit, c_abort, 'i prompt, 'o prompt_output) function_body\ where \c_write_via_void p v \ FunctionBody (bind (literal (c_cast_from_void c_uint_prism p)) (\up. call (update_fun up v)))\ definition c_write_via_void_contract :: \('addr, 'gv) gref \ 'gv \ c_uint \ c_uint \ - ('s, unit, 'abort) function_contract\ where + ('s, unit, c_abort) function_contract\ where \c_write_via_void_contract p g old_v new_v \ let typed_p = c_cast_from_void c_uint_prism p; pre = typed_p \\\\ g\old_v; @@ -108,7 +108,7 @@ micro_c_translate \ definition c_read_via_void_e2e_contract :: \('addr, 'gv) gref \ 'gv \ c_int \ - ('s, c_int, 'abort) function_contract\ where + ('s, c_int, c_abort) function_contract\ where \c_read_via_void_e2e_contract p g v \ let typed_p = c_cast_from_void c_int_prism p; pre = typed_p \\\\ g\v; diff --git a/Micro_C_Examples/ROOT b/Micro_C_Examples/ROOT index d421d575..fb405728 100644 --- a/Micro_C_Examples/ROOT +++ b/Micro_C_Examples/ROOT @@ -17,3 +17,4 @@ session Micro_C_Examples = HOL + C_Void_Pointer_Examples C_Union_Examples C_Byte_Refinement + C_Misc_Examples diff --git a/Micro_C_Examples/Simple_C_Functions.thy b/Micro_C_Examples/Simple_C_Functions.thy index 630137ba..33ae9b61 100644 --- a/Micro_C_Examples/Simple_C_Functions.thy +++ b/Micro_C_Examples/Simple_C_Functions.thy @@ -23,10 +23,50 @@ text \ This is the same boilerplate as the Rust examples. \ +locale c_translation_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + +locale c_base_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + + reference reference_types + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ + 'o prompt_output \ unit\ + locale c_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + reference reference_types + ref_c_int: reference_allocatable reference_types _ _ _ _ _ _ _ c_int_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ 'abort \ 'i prompt \ + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ 'o prompt_output \ unit\ and c_int_prism :: \('gv, c_int) prism\ begin @@ -131,6 +171,56 @@ lemma c_abs_val_spec [crush_specs]: by (crush_boot f: c_abs_val_def contract: c_abs_val_contract_def) (crush_base simp add: c_signed_less_def c_signed_sub_def c_signed_overflow_def Let_def) +subsection \Signed Addition (with Overflow Precondition)\ + +text \ + A function exercising signed addition directly. + The precondition establishes no-overflow using @{const c_signed_in_range}, + and the postcondition shows the result equals @{term "word_of_int (sint a + sint b)"}. +\ +micro_c_translate \ + int signed_add(int a, int b) { + return a + b; + } +\ + +definition c_signed_add_contract :: + \c_int \ c_int \ ('s::{sepalg}, c_int, 'b) function_contract\ where + [crush_contracts]: \c_signed_add_contract a b \ + let pre = \c_signed_in_range (sint a + sint b) LENGTH(32)\; + post = \r. \r = word_of_int (sint a + sint b)\ + in make_function_contract pre post\ +ucincl_auto c_signed_add_contract + +lemma c_signed_add_spec [crush_specs]: + shows \\; c_signed_add a b \\<^sub>F c_signed_add_contract a b\ +by (crush_boot f: c_signed_add_def contract: c_signed_add_contract_def) + (crush_base simp add: c_signed_add_def c_signed_overflow_def Let_def) + +subsection \Signed Overflow UB Detection\ + +text \ + When the precondition specifies that overflow \emph{does} occur, the function + correctly aborts with @{const SignedOverflow}. This demonstrates the core value + of the C frontend: UB is detected and turned into a verifiable abort. +\ + +definition c_signed_add_overflow_contract :: + \c_int \ c_int \ ('s::{sepalg}, c_int, c_abort) function_contract\ where + [crush_contracts]: \c_signed_add_overflow_contract a b \ + let pre = \\ c_signed_in_range (sint a + sint b) LENGTH(32)\; + post = \_. \; + abort_post = \ab. \ab = CustomAbort SignedOverflow\ + in make_function_contract_with_abort pre post abort_post\ +ucincl_auto c_signed_add_overflow_contract + +lemma c_signed_add_overflow_spec: + shows \\; c_signed_add a b \\<^sub>F c_signed_add_overflow_contract a b\ + apply (crush_boot f: c_signed_add_def contract: c_signed_add_overflow_contract_def) + apply (simp only: C_Numeric_Types.c_signed_add_def Let_def) + apply (crush_base simp add: c_signed_overflow_def c_abort_def) + done + end section \C Unsigned Arithmetic Verification\ @@ -142,11 +232,22 @@ text \ \ locale c_uint_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + reference reference_types + ref_c_uint: reference_allocatable reference_types _ _ _ _ _ _ _ c_uint_prism + ref_c_uint_ptr: reference_allocatable reference_types _ _ _ _ _ _ _ c_uint_ptr_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ 'abort \ 'i prompt \ - 'o prompt_output \ unit\ + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ + 'o prompt_output \ unit\ and c_uint_prism :: \('gv, c_uint) prism\ and c_uint_ptr_prism :: \('gv, ('addr, 'gv, c_uint) Global_Store.ref) prism\ begin @@ -163,6 +264,47 @@ micro_c_translate \ thm c_u_add_def +micro_c_translate \ + unsigned int u_call_helper(unsigned int x) { + return x; + } + + unsigned int u_call_caller(unsigned int a, unsigned int b) { + return u_call_helper(a) + u_call_helper(b); + } +\ + +thm c_u_call_helper_def c_u_call_caller_def + +text \ + Multi-function contract composition: verify the helper first, tag its spec + with @{text "[crush_specs]"}, then the caller's proof automatically uses it. +\ +definition c_u_call_helper_contract :: + \c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_u_call_helper_contract x \ + let pre = \True\; + post = \r. \r = x\ + in make_function_contract pre post\ +ucincl_auto c_u_call_helper_contract + +lemma c_u_call_helper_spec [crush_specs]: + shows \\; c_u_call_helper x \\<^sub>F c_u_call_helper_contract x\ +by (crush_boot f: c_u_call_helper_def contract: c_u_call_helper_contract_def) crush_base + +definition c_u_call_caller_contract :: + \c_uint \ c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_u_call_caller_contract a b \ + let pre = \True\; + post = \r. \r = a + b\ + in make_function_contract pre post\ +ucincl_auto c_u_call_caller_contract + +lemma c_u_call_caller_spec [crush_specs]: + shows \\; c_u_call_caller a b \\<^sub>F c_u_call_caller_contract a b\ +by (crush_boot f: c_u_call_caller_def contract: c_u_call_caller_contract_def) + (crush_base simp add: c_unsigned_add_def) + text \ The contract for @{text u_add}: unsigned addition wraps, so the result is always @{term \a + b\} (Isabelle word addition already wraps). @@ -490,6 +632,59 @@ lemma c_double_val_spec [crush_specs]: by (crush_boot f: c_double_val_def contract: c_double_val_contract_def) (crush_base simp add: c_unsigned_add_def) +subsection \Mutable parameter: compound assignment and increment\ + +text \ + Test that compound assignment and pre/post increment on parameters are + correctly detected by \<^text>\find_assigned_vars\ and promoted to locals. +\ + +micro_c_translate \ + unsigned int param_compound(unsigned int x, unsigned int y) { + x += y; + return x; + } +\ + +thm c_param_compound_def + +definition c_param_compound_contract :: \c_uint \ c_uint \ + ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_param_compound_contract x y \ + let pre = can_alloc_reference; + post = \r. can_alloc_reference \ + \r = x + y\ + in make_function_contract pre post\ +ucincl_auto c_param_compound_contract + +lemma c_param_compound_spec [crush_specs]: + shows \\; c_param_compound x y \\<^sub>F c_param_compound_contract x y\ +by (crush_boot f: c_param_compound_def contract: c_param_compound_contract_def) + (crush_base simp add: c_unsigned_add_def) + +micro_c_translate \ + unsigned int param_inc(unsigned int x) { + x++; + return x; + } +\ + +thm c_param_inc_def + +definition c_param_inc_contract :: \c_uint \ + ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_param_inc_contract x \ + let pre = can_alloc_reference; + post = \r. can_alloc_reference \ + \r = x + 1\ + in make_function_contract pre post\ +ucincl_auto c_param_inc_contract + +lemma c_param_inc_spec [crush_specs]: + shows \\; c_param_inc x \\<^sub>F c_param_inc_contract x\ +by (crush_boot f: c_param_inc_def contract: c_param_inc_contract_def) + (crush_base simp add: c_unsigned_add_def) + subsection \Compound pointer dereference\ micro_c_translate \ @@ -592,8 +787,8 @@ by (crush_boot f: c_inc_via_addr_def contract: c_inc_via_addr_contract_def) subsection \Pointer arithmetic\ text \ - Test pointer arithmetic: @{text "*(arr + idx)"} reads the element at offset @{text idx} - via @{const focus_focused} and @{const nth_focus}. + Test pointer arithmetic: @{text "*(arr + idx)"} reads through the + pointer model by shifting the base reference and dereferencing the result. \ micro_c_translate \ @@ -604,17 +799,19 @@ micro_c_translate \ thm c_ptr_add_read_def -definition c_ptr_add_read_contract :: \('addr, 'gv, c_uint list) Global_Store.ref \ 'gv \ - c_uint list \ c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where - [crush_contracts]: \c_ptr_add_read_contract arr ag vs idx \ - let pre = arr \\\\ ag\vs \ \c_idx_to_nat idx < size arr\ \ - \c_idx_to_nat idx < length vs\; - post = \r. arr \\\\ ag\vs \ \r = vs ! c_idx_to_nat idx\ +definition c_ptr_add_read_contract :: \('addr, 'gv, c_uint) Global_Store.ref \ 'gv \ + c_uint \ c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_ptr_add_read_contract arr ag v idx \ + let elem_ref = make_focused + (c_ptr_add (unwrap_focused arr) (c_idx_to_nat idx) (c_sizeof TYPE(c_uint))) + (get_focus arr); + pre = elem_ref \\\\ ag\v; + post = \r. elem_ref \\\\ ag\v \ \r = v\ in make_function_contract pre post\ ucincl_auto c_ptr_add_read_contract lemma c_ptr_add_read_spec [crush_specs]: - shows \\; c_ptr_add_read arr idx \\<^sub>F c_ptr_add_read_contract arr ag vs idx\ + shows \\; c_ptr_add_read arr idx \\<^sub>F c_ptr_add_read_contract arr ag v idx\ by (crush_boot f: c_ptr_add_read_def contract: c_ptr_add_read_contract_def) crush_base subsection \Forward-only goto\ @@ -650,15 +847,201 @@ lemma c_skip_add_spec [crush_specs]: by (crush_boot f: c_skip_add_def contract: c_skip_add_contract_def) (crush_base simp add: c_unsigned_eq_def c_unsigned_add_def) +subsection \Unsigned Division (with Division-by-Zero Precondition)\ + +text \ + Exercises unsigned division end-to-end. The precondition ensures + the divisor is non-zero (division by zero aborts with @{const DivisionByZero}). + Unsigned division has no overflow — the result is always representable. +\ +micro_c_translate \ + unsigned int u_div(unsigned int a, unsigned int b) { + return a / b; + } +\ + +definition c_u_div_contract :: + \c_uint \ c_uint \ ('s::{sepalg}, c_uint, c_abort) function_contract\ where + [crush_contracts]: \c_u_div_contract a b \ + let pre = \b \ 0\; + post = \r. \r = a div b\ + in make_function_contract pre post\ +ucincl_auto c_u_div_contract + +lemma c_u_div_spec [crush_specs]: + shows \\; c_u_div a b \\<^sub>F c_u_div_contract a b\ +by (crush_boot f: c_u_div_def contract: c_u_div_contract_def) + (crush_base simp add: c_unsigned_div_def c_division_by_zero_def c_abort_def) + +subsection \Division by Zero UB Detection\ + +text \ + When the divisor is zero, unsigned division correctly aborts with + @{const DivisionByZero}. The function never returns normally. +\ + +definition c_u_div_zero_contract :: + \c_uint \ c_uint \ ('s::{sepalg}, c_uint, c_abort) function_contract\ where + [crush_contracts]: \c_u_div_zero_contract a b \ + let pre = \b = 0\; + post = \_. \; + abort_post = \ab. \ab = CustomAbort DivisionByZero\ + in make_function_contract_with_abort pre post abort_post\ +ucincl_auto c_u_div_zero_contract + +lemma c_u_div_zero_spec: + shows \\; c_u_div a b \\<^sub>F c_u_div_zero_contract a b\ +by (crush_boot f: c_u_div_def contract: c_u_div_zero_contract_def) + (crush_base simp add: c_unsigned_div_def c_division_by_zero_def c_abort_def) + +subsection \NULL pointer literal\ + +text \ + Test null pointer comparison: @{text "p == (void*)0"} checks whether a + pointer is null via @{text "gref_address"}. +\ + +micro_c_translate \ + unsigned int is_null(unsigned int *p) { + if (p == (void*)0) + return 1; + return 0; + } +\ + +thm c_is_null_def + +definition c_is_null_contract :: \('addr, 'gv, c_uint) Global_Store.ref \ + 'gv \ c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_is_null_contract p pg val \ + let pre = p \\\\ pg\val \ \c_ptr_to_uintptr (\ p) \ 0\; + post = \r. p \\\\ pg\val \ \r = 0\ + in make_function_contract pre post\ +ucincl_auto c_is_null_contract + +lemma c_is_null_spec [crush_specs]: + shows \\; c_is_null p \\<^sub>F c_is_null_contract p pg val\ +by (crush_boot f: c_is_null_def contract: c_is_null_contract_def) + crush_base + +micro_c_translate \ + unsigned int ptr_eq(unsigned int *p, unsigned int *q) { + if (p != q) + return 0; + return 1; + } +\ + +thm c_ptr_eq_def + +subsection \Arbitrary loop bound\ + +text \ + Test that for-loop bounds can be arbitrary unsigned expressions, + not just literals or parameters. The bound @{text "n + 1"} is evaluated + monadically and its @{text "unat"} value used as the loop range. +\ + +micro_c_translate \ + unsigned int noop_loop(unsigned int n) { + for (unsigned int i = 0; i < n + 1; i++) { + } + return 0; + } +\ + +thm c_noop_loop_def + +definition c_noop_loop_contract :: \c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_noop_loop_contract n \ + let pre = \True\; + post = \r. \r = 0\ + in make_function_contract pre post\ +ucincl_auto c_noop_loop_contract + +lemma c_noop_loop_spec [crush_specs]: + shows \\; c_noop_loop n \\<^sub>F c_noop_loop_contract n\ + apply (crush_boot f: c_noop_loop_def contract: c_noop_loop_contract_def) + apply crush_base + apply (rule wp_raw_for_loop_framedI'[where INV=\\_ _. \True\\ and \=\\_. \\]) + apply crush_base + done + +subsection \Backward goto\ + +text \ + Test backward goto: a label-based retry loop. The label @{text "start"} + is a backward goto target, wrapped in @{text "bounded_while"} with + fuel. The goto sets the flag, guards skip remaining code, and the + while re-enters. +\ + +micro_c_translate \ + unsigned int count_down(unsigned int n) { + unsigned int i = n; + start: + if (i == 0) goto done; + i = i - 1; + goto start; + done: + return i; + } +\ + +thm c_count_down_def + +definition c_count_down_contract :: \c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_count_down_contract n \ + let pre = can_alloc_reference; + post = \r. can_alloc_reference \ \r = 0\ + in make_function_contract pre post\ +ucincl_auto c_count_down_contract + +lemma c_count_down_spec: + assumes \while_fuel = unat n\ + shows \\; c_count_down while_fuel n \\<^sub>F c_count_down_contract n\ + apply (crush_boot f: c_count_down_def contract: c_count_down_contract_def) + apply crush_base + apply (ucincl_discharge\ + rule_tac + INV=\\k. (\g. x \\\\ g\(1 :: c_uint)) \ + (\g. xa \\\\ g\(0 :: c_uint)) \ + (\g. xb \\\\ g\(of_nat k :: c_uint))\ + and INV'=\\k. (\g. x \\\\ g\(1 :: c_uint)) \ + (\g. xa \\\\ g\(0 :: c_uint)) \ + (\g. xb \\\\ g\(of_nat (Suc k) :: c_uint))\ + and \=\\_. \False\\ + and \=\\_. \False\\ + in wp_bounded_while_framedI\) + apply (crush_base simp add: c_unsigned_eq_def c_unsigned_sub_def + unat_of_nat_eq word_of_nat_eq_0_iff of_nat_diff linorder_not_less + unat_gt_0 word_of_nat_less)+ + apply (metis add.commute assms less_is_non_zero_p1 word_of_nat_less) + apply (metis add.commute assms less_is_non_zero_p1 word_of_nat_less) + apply (metis add.commute assms less_is_non_zero_p1 word_of_nat_less) + apply (simp add: assms unat_of_nat_eq) + done + end section \Fixed-width integer type verification (\<^verbatim>\uint16_t\)\ locale c_ushort_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + reference reference_types + ref_c_ushort: reference_allocatable reference_types _ _ _ _ _ _ _ c_ushort_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ 'abort \ 'i prompt \ - 'o prompt_output \ unit\ + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ + 'o prompt_output \ unit\ and c_ushort_prism :: \('gv, c_ushort) prism\ begin @@ -737,10 +1120,21 @@ micro_c_translate \ thm c_poly.record_simps locale c_poly_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + reference reference_types + ref_c_poly: reference_allocatable reference_types _ _ _ _ _ _ _ c_poly_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ 'abort \ 'i prompt \ - 'o prompt_output \ unit\ + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ + 'o prompt_output \ unit\ and c_poly_prism :: \('gv, c_poly) prism\ begin @@ -841,17 +1235,31 @@ end section \Non-constant local array initializers\ locale c_uint_arr_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + reference reference_types + ref_c_uint: reference_allocatable reference_types _ _ _ _ _ _ _ c_uint_prism + - ref_c_uint_list: reference_allocatable reference_types _ _ _ _ _ _ _ c_uint_list_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ 'abort \ 'i prompt \ - 'o prompt_output \ unit\ + ref_c_uint_list: reference_allocatable reference_types _ _ _ _ _ _ _ c_uint_list_prism + + ref_c_uint_list_list: reference_allocatable reference_types _ _ _ _ _ _ _ c_uint_list_list_prism + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ + 'o prompt_output \ unit\ and c_uint_prism :: \('gv, c_uint) prism\ and c_uint_list_prism :: \('gv, c_uint list) prism\ + and c_uint_list_list_prism :: \('gv, c_uint list list) prism\ begin adhoc_overloading store_reference_const \ ref_c_uint.new adhoc_overloading store_reference_const \ ref_c_uint_list.new +adhoc_overloading store_reference_const \ ref_c_uint_list_list.new adhoc_overloading store_update_const \ update_fun micro_c_translate \ @@ -882,22 +1290,33 @@ begin micro_c_translate \ typedef unsigned int uint32_t; - long ptr_diff(uint32_t *p, uint32_t *q) { + long ptr_diff_test(uint32_t *p, uint32_t *q) { return p - q; } \ -thm c_ptr_diff_def +thm c_ptr_diff_test_def end section \Byte buffer pointer arithmetic verification\ locale c_char_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + reference reference_types + ref_c_char: reference_allocatable reference_types _ _ _ _ _ _ _ c_char_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ 'abort \ 'i prompt \ - 'o prompt_output \ unit\ + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ + 'o prompt_output \ unit\ and c_char_prism :: \('gv, c_char) prism\ begin @@ -914,17 +1333,19 @@ micro_c_translate \ thm c_read_byte_def -definition c_read_byte_contract :: \('addr, 'gv, c_char list) Global_Store.ref \ 'gv \ - c_char list \ c_uint \ ('s::{sepalg}, c_char, 'b) function_contract\ where - [crush_contracts]: \c_read_byte_contract buf bg vs idx \ - let pre = buf \\\\ bg\vs \ \c_idx_to_nat idx < size buf\ \ - \c_idx_to_nat idx < length vs\; - post = \r. buf \\\\ bg\vs \ \r = vs ! c_idx_to_nat idx\ +definition c_read_byte_contract :: \('addr, 'gv, c_char) Global_Store.ref \ 'gv \ + c_char \ c_uint \ ('s::{sepalg}, c_char, 'b) function_contract\ where + [crush_contracts]: \c_read_byte_contract buf bg v idx \ + let elem_ref = make_focused + (c_ptr_add (unwrap_focused buf) (c_idx_to_nat idx) (c_sizeof TYPE(c_char))) + (get_focus buf); + pre = elem_ref \\\\ bg\v; + post = \r. elem_ref \\\\ bg\v \ \r = v\ in make_function_contract pre post\ ucincl_auto c_read_byte_contract lemma c_read_byte_spec [crush_specs]: - shows \\; c_read_byte buf idx \\<^sub>F c_read_byte_contract buf bg vs idx\ + shows \\; c_read_byte buf idx \\<^sub>F c_read_byte_contract buf bg v idx\ by (crush_boot f: c_read_byte_def contract: c_read_byte_contract_def) crush_base end @@ -932,10 +1353,21 @@ end section \Long long type verification\ locale c_ulong_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + reference reference_types + ref_c_ulong: reference_allocatable reference_types _ _ _ _ _ _ _ c_ulong_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ 'abort \ 'i prompt \ - 'o prompt_output \ unit\ + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ + 'o prompt_output \ unit\ and c_ulong_prism :: \('gv, c_ulong) prism\ begin @@ -970,10 +1402,21 @@ end section \128-bit integer type verification\ locale c_uint128_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + reference reference_types + ref_c_uint128: reference_allocatable reference_types _ _ _ _ _ _ _ c_uint128_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ 'abort \ 'i prompt \ - 'o prompt_output \ unit\ + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ + 'o prompt_output \ unit\ and c_uint128_prism :: \('gv, c_uint128) prism\ begin @@ -1012,10 +1455,21 @@ micro_c_translate \ \ locale c_point_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + reference reference_types + ref_c_point: reference_allocatable reference_types _ _ _ _ _ _ _ c_point_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ 'abort \ 'i prompt \ - 'o prompt_output \ unit\ + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ + 'o prompt_output \ unit\ and c_point_prism :: \('gv, c_point) prism\ begin @@ -1180,6 +1634,27 @@ micro_c_translate \ thm c_inc_arr_elem_def +micro_c_translate \ + unsigned int mat_read(void) { + unsigned int mat[2][3] = {{1,2,3},{4,5,6}}; + return mat[1][2]; + } +\ + +thm c_mat_read_def + +definition c_mat_read_contract :: \('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_mat_read_contract \ + let pre = can_alloc_reference; + post = \r. can_alloc_reference \ \r = 6\ + in make_function_contract pre post\ +ucincl_auto c_mat_read_contract + +lemma c_mat_read_spec [crush_specs]: + shows \\; c_mat_read \\<^sub>F c_mat_read_contract\ +by (crush_boot f: c_mat_read_def contract: c_mat_read_contract_def) + crush_base + end section \Scalar compound literal\ @@ -1224,21 +1699,43 @@ micro_c_translate \ thm c_ptr_to_int_def +micro_c_translate \ + typedef unsigned long long uintptr_t; + + unsigned int *int_to_ptr(uintptr_t p) { + return (unsigned int *)p; + } +\ + +thm c_int_to_ptr_def + end section \String literal as array initializer\ locale c_char_arr_verification_ctx = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + reference reference_types + ref_c_char: reference_allocatable reference_types _ _ _ _ _ _ _ c_char_prism + ref_c_char_list: reference_allocatable reference_types _ _ _ _ _ _ _ c_char_list_prism - for reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ 'abort \ 'i prompt \ - 'o prompt_output \ unit\ + for c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and reference_types :: \'s::{sepalg} \ 'addr \ 'gv \ c_abort \ 'i prompt \ + 'o prompt_output \ unit\ and c_char_prism :: \('gv, c_char) prism\ and c_char_list_prism :: \('gv, c_char list) prism\ begin -adhoc_overloading store_reference_const \ ref_c_char.new ref_c_char_list.new +adhoc_overloading store_reference_const \ ref_c_char.new +adhoc_overloading store_reference_const \ ref_c_char_list.new adhoc_overloading store_update_const \ update_fun micro_c_translate \ diff --git a/Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy b/Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy new file mode 100644 index 00000000..1b36fbe0 --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy @@ -0,0 +1,174 @@ +theory C_ABI_And_Compiler + imports + "Isabelle_C.C_Main" +begin + +section \C-to-Core Monad Translation Infrastructure\ + +text \ + This theory defines ML infrastructure for translating Isabelle/C's parsed C11 AST + into AutoCorrode's core monad terms. The pipeline is: + \begin{enumerate} + \item Parse C source via Isabelle/C (reusing the existing @{command "C"} parser) + \item Walk the \C_Ast.cTranslationUnit\ AST + \item Generate Isabelle @{command definition} commands for each C function + \end{enumerate} + + The translation is invoked via the \micro_c_translate\ command, + which takes a C source string and produces definitions in the local theory. +\ + +subsection \Implementation-Defined Behavior\ + +text \ + AutoCorrode's C translation depends on several implementation-defined behaviors + from the C11 standard. These are either controlled by the compiler/ABI profile + or hardcoded to match universal practice. + + \<^bold>\Controlled by compiler profile\ (@{text C_Compiler}): + \<^item> \<^bold>\Plain char signedness\ (\
6.2.5p15): whether @{text char} is signed or + unsigned. Controlled by @{text "char_is_signed"} in the compiler profile. + GCC/Clang on x86\_64: signed; GCC/Clang on aarch64: unsigned. + \<^item> \<^bold>\Signed right shift\ (\
6.5.7p5): result of right-shifting a negative + signed value. Controlled by @{text "signed_shr"}: @{text "ArithmeticShift"} + (sign-extending, matching GCC/Clang) or @{text "ConservativeShift"} (abort + on negative operand). + \<^item> \<^bold>\Signed narrowing cast\ (\
6.3.1.3p3): result of converting a signed + value to a narrower signed type when the value is out of range. + Controlled by @{text "signed_narrowing"}: @{text "Truncating"} (modular + reduction, matching GCC/Clang) or @{text "Checked"} (abort on overflow). + + \<^bold>\Controlled by ABI profile\ (@{text C_ABI}): + \<^item> \<^bold>\@{text long} bit width\: 64 bits (LP64, LP64-BE) or 32 bits (ILP32, LLP64). + \<^item> \<^bold>\Pointer bit width\: 64 bits (LP64, LLP64, LP64-BE) or 32 bits (ILP32). + \<^item> \<^bold>\Endianness\: little-endian (default) or big-endian (LP64-BE, ILP32-BE). + + \<^bold>\Hardcoded assumptions\: + \<^item> \<^bold>\Two's complement\ (\
6.2.6.2): assumed for all signed types. This was + implementation-defined in C11/C17 but mandated by C23 (\
6.2.6.2p2). + All modern compilers and ABIs use two's complement. + \<^item> \<^bold>\Integer type widths\ (\
5.2.4.2.1): @{text "char"}=8, @{text "short"}=16, + @{text "int"}=32, @{text "long long"}=64, @{text "__int128"}=128 bits. + These match all standard ABIs (LP64, ILP32, LLP64). + \<^item> \<^bold>\@{text "sizeof"} result type\ (\
6.5.3.4p5): @{text "size_t"} is + the pointer-width unsigned type from the ABI profile. +\ + +subsection \ABI Profiles\ + +text \ + Translation currently supports named ABI profiles (rather than arbitrary ABI formulas), + so that type inference and overloaded constants remain stable. The default profile is + @{text "lp64-le"}. + + The ABI option affects translation-time C typing (e.g. long/pointer widths and plain + char signedness). Byte-level endianness in machine models is selected separately via + prism overloading (for example, @{text "c_uint_byte_prism"} vs @{text "c_uint_byte_prism_be"}). +\ + +ML \ +structure C_ABI : sig + datatype profile = LP64_LE | ILP32_LE | LP64_BE | LLP64_LE | ILP32_BE + val profile_name : profile -> string + val parse_profile : string -> profile + val long_bits : profile -> int + val pointer_bits : profile -> int + val char_is_signed : profile -> bool + val big_endian : profile -> bool +end = +struct + datatype profile = LP64_LE | ILP32_LE | LP64_BE | LLP64_LE | ILP32_BE + + fun profile_name LP64_LE = "lp64-le" + | profile_name ILP32_LE = "ilp32-le" + | profile_name LP64_BE = "lp64-be" + | profile_name LLP64_LE = "llp64-le" + | profile_name ILP32_BE = "ilp32-be" + + fun parse_profile s = + let + val normalized = + String.map (fn c => if c = #"_" then #"-" else Char.toLower c) s + in + (case normalized of + "lp64-le" => LP64_LE + | "ilp32-le" => ILP32_LE + | "lp64-be" => LP64_BE + | "llp64-le" => LLP64_LE + | "ilp32-be" => ILP32_BE + | _ => error ("micro_c_translate: unsupported ABI profile: " ^ s ^ + " (supported: lp64-le, ilp32-le, lp64-be, llp64-le, ilp32-be)")) + end + + fun long_bits LP64_LE = 64 + | long_bits ILP32_LE = 32 + | long_bits LP64_BE = 64 + | long_bits LLP64_LE = 32 + | long_bits ILP32_BE = 32 + + fun pointer_bits LP64_LE = 64 + | pointer_bits ILP32_LE = 32 + | pointer_bits LP64_BE = 64 + | pointer_bits LLP64_LE = 64 + | pointer_bits ILP32_BE = 32 + + fun big_endian LP64_BE = true + | big_endian ILP32_BE = true + | big_endian _ = false + + (* NOTE: This function is NOT used by the translation pipeline. + Plain-char signedness is controlled by C_Compiler.get_compiler_profile, + which is set via the compiler: option (see resolve_c_type). + This ABI-level function is retained only for the abi_char_is_signed + metadata constant; it always returns false. *) + fun char_is_signed _ = false +end +\ + +ML \ +structure C_Compiler : sig + datatype signed_shr_behavior = ArithmeticShift | ConservativeShift + datatype signed_narrowing_behavior = Truncating | Checked + + type profile = { + char_is_signed: bool, + signed_shr: signed_shr_behavior, + signed_narrowing: signed_narrowing_behavior + } + + val parse_compiler : string -> profile + val default_profile : profile + val set_compiler_profile : profile -> unit + val get_compiler_profile : unit -> profile +end = struct + datatype signed_shr_behavior = ArithmeticShift | ConservativeShift + datatype signed_narrowing_behavior = Truncating | Checked + + type profile = { + char_is_signed: bool, + signed_shr: signed_shr_behavior, + signed_narrowing: signed_narrowing_behavior + } + + (* Default: current behavior (unsigned char, arithmetic shr, truncating narrowing) *) + val default_profile : profile = { + char_is_signed = false, + signed_shr = ArithmeticShift, + signed_narrowing = Truncating + } + + fun parse_compiler "gcc-x86_64" = {char_is_signed = true, signed_shr = ArithmeticShift, signed_narrowing = Truncating} + | parse_compiler "clang-x86_64" = {char_is_signed = true, signed_shr = ArithmeticShift, signed_narrowing = Truncating} + | parse_compiler "gcc-aarch64" = {char_is_signed = false, signed_shr = ArithmeticShift, signed_narrowing = Truncating} + | parse_compiler "clang-aarch64" = {char_is_signed = false, signed_shr = ArithmeticShift, signed_narrowing = Truncating} + | parse_compiler "conservative" = {char_is_signed = false, signed_shr = ConservativeShift, signed_narrowing = Checked} + | parse_compiler name = error ("micro_c_translate: unknown compiler profile: " ^ name ^ + ". Known profiles: gcc-x86_64, clang-x86_64, gcc-aarch64, clang-aarch64, conservative") + + val current_compiler_profile : profile Unsynchronized.ref = Unsynchronized.ref default_profile + fun set_compiler_profile p = (current_compiler_profile := p) + fun get_compiler_profile () = !current_compiler_profile +end +\ + +end diff --git a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy new file mode 100644 index 00000000..36f32755 --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy @@ -0,0 +1,1445 @@ +theory C_Ast_Utilities + imports + C_ABI_And_Compiler + "Shallow_Micro_C.C_Numeric_Types" + "Shallow_Micro_C.C_Sizeof" + "Shallow_Micro_C.C_Memory_Operations" + "Shallow_Micro_C.C_Void_Pointer" +begin + +subsection \AST Utilities\ + +text \ + C11 standard sections implemented in this module: + + \<^item> \<^bold>\\
6.2.5\ (Types): @{text is_signed}, @{text is_unsigned_int}, @{text is_bool}, @{text is_ptr} + classify C numeric types by signedness, boolean, and pointer status. + \<^item> \<^bold>\\
5.2.4.2.1\ (Sizes of integer types): @{text bit_width_of} returns the bit width + of each integer type, parameterized by the ABI profile for @{text long}/@{text pointer}. + \<^item> \<^bold>\\
6.3.1.1p1\ (Integer conversion rank): @{text type_rank} assigns conversion ranks. + \<^item> \<^bold>\\
6.3.1.1p2\ (Integer promotion): @{text integer_promote} promotes sub-int types to int. + \<^item> \<^bold>\\
6.3.1.8\ (Usual arithmetic conversions): @{text usual_arith_conv} determines the + common type for binary arithmetic operations. + \<^item> \<^bold>\\
6.4.4.1p5\ (Integer constant types): @{text int_literal_type} determines the C type + of an integer constant from its suffix flags. + \<^item> \<^bold>\\
6.7.2\ (Type specifiers): @{text resolve_c_type} resolves a list of C declaration + specifiers into a @{text c_numeric_type}. + \<^item> \<^bold>\\
7.20\ (Integer types \\), \<^bold>\\
7.19\ (\\): + @{text builtin_typedefs} maps fixed-width type names to their @{text c_numeric_type}. +\ + +text \Helper functions for extracting information from Isabelle/C's AST nodes.\ + +ML \ +structure C_Ast_Utils : sig + datatype c_numeric_type = CInt | CUInt | CChar | CSChar + | CShort | CUShort | CLong | CULong + | CLongLong | CULongLong + | CInt128 | CUInt128 | CBool + | CPtr of c_numeric_type | CVoid + | CStruct of string + | CUnion of string + + val is_signed : c_numeric_type -> bool + val is_bool : c_numeric_type -> bool + val is_ptr : c_numeric_type -> bool + val is_unsigned_int : c_numeric_type -> bool + val set_abi_profile : C_ABI.profile -> unit + val set_ref_universe_types : typ -> typ -> unit + val set_parametric_struct_names : string list -> unit + val set_pure_function_names : string list -> unit + val get_abi_profile : unit -> C_ABI.profile + val current_abi_name : unit -> string + val pointer_uint_cty : unit -> c_numeric_type + val pointer_int_cty : unit -> c_numeric_type + val bit_width_of : c_numeric_type -> int option + val sizeof_c_type : c_numeric_type -> int + val alignof_c_type : c_numeric_type -> int + val intinf_to_int_checked : string -> IntInf.int -> int + val struct_name_of_cty : c_numeric_type -> string option + val builtin_typedefs : unit -> (string * c_numeric_type) list + val hol_type_of : c_numeric_type -> typ + val cty_to_record_typ : string -> c_numeric_type -> typ option + val type_name_of : c_numeric_type -> string + val resolve_c_type : C_Ast.nodeInfo C_Ast.cDeclarationSpecifier list -> c_numeric_type option + val decl_type : C_Ast.nodeInfo C_Ast.cDeclaration -> c_numeric_type option + val param_type : C_Ast.nodeInfo C_Ast.cDeclaration -> c_numeric_type option + val is_pointer_param : C_Ast.nodeInfo C_Ast.cDeclaration -> bool + val pointer_depth_of_declr : C_Ast.nodeInfo C_Ast.cDeclarator -> int + val pointer_depth_of_decl : C_Ast.nodeInfo C_Ast.cDeclaration -> int + val apply_ptr_depth : c_numeric_type -> int -> c_numeric_type + val abr_string_to_string : C_Ast.abr_string -> string + val ident_name : C_Ast.ident -> string + val declr_name : C_Ast.nodeInfo C_Ast.cDeclarator -> string + val extract_params : C_Ast.nodeInfo C_Ast.cDeclarator -> string list + val extract_param_decls : C_Ast.nodeInfo C_Ast.cDeclarator + -> C_Ast.nodeInfo C_Ast.cDeclaration list + val declr_is_variadic : C_Ast.nodeInfo C_Ast.cDeclarator -> bool + val param_name : C_Ast.nodeInfo C_Ast.cDeclaration -> string option + val extract_struct_type_from_decl : C_Ast.nodeInfo C_Ast.cDeclaration -> string option + val extract_struct_type_from_decl_full : string list + -> C_Ast.nodeInfo C_Ast.cDeclaration -> string option + val extract_struct_type_from_specs_full : string list + -> C_Ast.nodeInfo C_Ast.cDeclarationSpecifier list + -> string option + val extract_union_type_from_specs : C_Ast.nodeInfo C_Ast.cDeclarationSpecifier list + -> string option + val extract_union_type_from_specs_full : string list + -> C_Ast.nodeInfo C_Ast.cDeclarationSpecifier list + -> string option + val extract_union_type_from_decl_full : string list + -> C_Ast.nodeInfo C_Ast.cDeclaration -> string option + val extract_union_defs_with_types : c_numeric_type Symtab.table + -> C_Ast.nodeInfo C_Ast.cTranslationUnit + -> (string * (string * c_numeric_type) list) list + val extract_struct_defs : C_Ast.nodeInfo C_Ast.cTranslationUnit + -> (string * string list) list + val extract_enum_defs : C_Ast.nodeInfo C_Ast.cTranslationUnit + -> (string * int) list + val extract_typedefs : C_Ast.nodeInfo C_Ast.cTranslationUnit + -> (string * c_numeric_type) list + val resolve_c_type_full : c_numeric_type Symtab.table + -> C_Ast.nodeInfo C_Ast.cDeclarationSpecifier list + -> c_numeric_type option + val int_literal_type : 'a C_Ast.flags -> c_numeric_type + val expr_has_side_effect : C_Ast.nodeInfo C_Ast.cExpression -> bool + val expr_has_unsequenced_ub_risk : + C_Ast.nodeInfo C_Ast.cExpression -> C_Ast.nodeInfo C_Ast.cExpression -> bool + val find_assigned_vars : C_Ast.nodeInfo C_Ast.cStatement -> string list + val find_goto_targets : C_Ast.nodeInfo C_Ast.cStatement -> string list + val find_called_functions : C_Ast.nodeInfo C_Ast.cFunctionDef -> string list + val find_list_backed_aliases : (string * c_numeric_type) list Symtab.table + -> string list Symtab.table + -> C_Ast.nodeInfo C_Ast.cFunctionDef -> string list + val find_indexed_base_vars : C_Ast.nodeInfo C_Ast.cFunctionDef -> string list + val find_named_calls_with_args : + C_Ast.nodeInfo C_Ast.cFunctionDef + -> (string * C_Ast.nodeInfo C_Ast.cExpression list) list + val fundef_is_pure_with : unit Symtab.table -> C_Ast.nodeInfo C_Ast.cFunctionDef -> bool + val extract_string_literal : C_Ast.nodeInfo C_Ast.cStringLiteral -> string + val eval_const_int_expr : (C_Ast.nodeInfo C_Ast.cDeclaration -> c_numeric_type option) + -> C_Ast.nodeInfo C_Ast.cExpression -> IntInf.int + + val extract_struct_defs_with_types : c_numeric_type Symtab.table + -> C_Ast.nodeInfo C_Ast.cTranslationUnit + -> (string * (string * c_numeric_type) list) list + val derive_parametric_struct_names : (string * (string * c_numeric_type) list) list + -> string list + val extract_struct_record_defs : string -> c_numeric_type Symtab.table + -> C_Ast.nodeInfo C_Ast.cTranslationUnit + -> (string * (string * typ option) list) list + val extract_struct_array_fields : C_Ast.nodeInfo C_Ast.cTranslationUnit + -> (string * string list) list + val extract_fundefs : C_Ast.nodeInfo C_Ast.cTranslationUnit + -> C_Ast.nodeInfo C_Ast.cFunctionDef list + val type_rank : c_numeric_type -> int + val integer_promote : c_numeric_type -> c_numeric_type + val usual_arith_conv : c_numeric_type * c_numeric_type -> c_numeric_type +end = +struct + open C_Ast + + (* ----- Resolved C numeric type representation ----- *) + + datatype c_numeric_type = CInt | CUInt | CChar | CSChar + | CShort | CUShort | CLong | CULong + | CLongLong | CULongLong + | CInt128 | CUInt128 | CBool + | CPtr of c_numeric_type | CVoid + | CStruct of string + | CUnion of string + + val current_abi_profile : C_ABI.profile Unsynchronized.ref = + Unsynchronized.ref C_ABI.LP64_LE + + val current_ref_addr_ty : Term.typ Unsynchronized.ref = + Unsynchronized.ref (Term.TFree ("'addr", [])) + val current_ref_gv_ty : Term.typ Unsynchronized.ref = + Unsynchronized.ref (Term.TFree ("'gv", [])) + val current_parametric_struct_names : unit Symtab.table Unsynchronized.ref = + Unsynchronized.ref Symtab.empty + val current_pure_function_names : unit Symtab.table Unsynchronized.ref = + Unsynchronized.ref Symtab.empty + + fun set_abi_profile abi = (current_abi_profile := abi) + fun set_ref_universe_types (addr_ty: Term.typ) (gv_ty: Term.typ) = + (current_ref_addr_ty := addr_ty; current_ref_gv_ty := gv_ty) + fun set_parametric_struct_names names = + current_parametric_struct_names := + List.foldl (fn (n, tab) => Symtab.update (n, ()) tab) Symtab.empty names + fun set_pure_function_names names = + current_pure_function_names := + List.foldl (fn (n, tab) => Symtab.update (n, ()) tab) Symtab.empty names + fun get_abi_profile () = !current_abi_profile + fun current_abi_name () = C_ABI.profile_name (get_abi_profile ()) + fun pointer_uint_cty () = + if C_ABI.pointer_bits (get_abi_profile ()) = 64 then CULong else CUInt + fun pointer_int_cty () = + if C_ABI.pointer_bits (get_abi_profile ()) = 64 then CLong else CInt + + (* C11 \
6.2.5p4-6: signed integer types are signed char, short int, int, long int, + long long int, and the extended signed types (__int128). + \
6.2.5p6: unsigned types are the corresponding unsigned variants. + \
6.2.5p2: _Bool is a separate unsigned integer type. + \
6.2.5p20: pointer types are derived types, not integer types. *) + fun is_signed CInt = true + | is_signed CSChar = true + | is_signed CShort = true + | is_signed CLong = true + | is_signed CLongLong = true + | is_signed CInt128 = true + | is_signed (CPtr _) = false + | is_signed CVoid = false + | is_signed (CStruct _) = false + | is_signed (CUnion _) = false + | is_signed _ = false + + fun is_bool CBool = true + | is_bool _ = false + + fun is_ptr (CPtr _) = true + | is_ptr _ = false + + fun is_unsigned_int cty = not (is_signed cty) andalso not (is_bool cty) + andalso not (is_ptr cty) andalso cty <> CVoid + andalso (case cty of CStruct _ => false | CUnion _ => false | _ => true) + + (* C11 \
5.2.4.2.1: minimum widths from . + We use exact widths matching standard ABI conventions: + char=8, short=16, int=32, long long=64. long and pointer widths + are ABI-dependent (queried from the current ABI profile). *) + fun bit_width_of CChar = SOME 8 + | bit_width_of CSChar = SOME 8 + | bit_width_of CShort = SOME 16 + | bit_width_of CUShort = SOME 16 + | bit_width_of CInt = SOME 32 + | bit_width_of CUInt = SOME 32 + | bit_width_of CLong = SOME (C_ABI.long_bits (get_abi_profile ())) + | bit_width_of CULong = SOME (C_ABI.long_bits (get_abi_profile ())) + | bit_width_of CLongLong = SOME 64 + | bit_width_of CULongLong = SOME 64 + | bit_width_of CInt128 = SOME 128 + | bit_width_of CUInt128 = SOME 128 + | bit_width_of (CPtr _) = SOME (C_ABI.pointer_bits (get_abi_profile ())) + | bit_width_of _ = NONE + + fun sizeof_c_type cty = + (case bit_width_of cty of + SOME bits => bits div 8 + | NONE => error "micro_c_translate: sizeof: unsupported type") + + fun alignof_c_type CInt128 = 16 + | alignof_c_type CUInt128 = 16 + | alignof_c_type cty = Int.min (sizeof_c_type cty, 8) + + fun intinf_to_int_checked what n = + let + val ge_min = + (case Int.minInt of + SOME lo => n >= IntInf.fromInt lo + | NONE => true) + val le_max = + (case Int.maxInt of + SOME hi => n <= IntInf.fromInt hi + | NONE => true) + in + if ge_min andalso le_max then IntInf.toInt n + else error ("micro_c_translate: " ^ what ^ " out of ML-int range: " ^ IntInf.toString n) + end + + fun struct_name_of_cty (CStruct sname) = SOME sname + | struct_name_of_cty (CPtr (CStruct sname)) = SOME sname + | struct_name_of_cty (CUnion sname) = SOME sname + | struct_name_of_cty (CPtr (CUnion sname)) = SOME sname + | struct_name_of_cty _ = NONE + + (* C11 \
7.20 : exact-width integer types (uint8_t, int32_t, etc.) + C11 \
7.19 : size_t + C11 \
7.20.1.4: uintptr_t/intptr_t -- integer types capable of holding a pointer. + Mappings are ABI-dependent for pointer-width types (size_t, uintptr_t, intptr_t). *) + fun builtin_typedefs () = + let + val uintptr_cty = pointer_uint_cty () + val intptr_cty = pointer_int_cty () + in + [ ("uint8_t", CChar), ("int8_t", CSChar), + ("uint16_t", CUShort), ("int16_t", CShort), + ("uint32_t", CUInt), ("int32_t", CInt), + ("uint64_t", CULongLong), ("int64_t", CLongLong), + ("size_t", uintptr_cty), ("uintptr_t", uintptr_cty), ("intptr_t", intptr_cty), + ("__int128_t", CInt128), ("__uint128_t", CUInt128) ] + end + + (* Map c_numeric_type to Isabelle/HOL fixed-width word types. + Type synonyms are defined in C_Numeric_Types.thy and are always + fixed-width: c_int = 32 sword, c_long = 64 sword, etc. + ABI variation is handled here, not in the type synonyms: + - CLong/CULong map to c_int/c_uint on ILP32, c_long/c_ulong on LP64 + - CLongLong/CULongLong always map to c_long/c_ulong (= 64-bit) + - CChar is always unsigned (8 word); resolve_c_type returns CSChar + when the compiler profile has char_is_signed=true + Pointer, struct, and union types use dummyT for type inference. *) + fun hol_type_of CBool = @{typ bool} + | hol_type_of CInt = \<^typ>\c_int\ + | hol_type_of CUInt = \<^typ>\c_uint\ + | hol_type_of CChar = \<^typ>\c_char\ + | hol_type_of CSChar = \<^typ>\c_schar\ + | hol_type_of CShort = \<^typ>\c_short\ + | hol_type_of CUShort = \<^typ>\c_ushort\ + | hol_type_of CLong = + if C_ABI.long_bits (get_abi_profile ()) = 32 then \<^typ>\c_int\ else \<^typ>\c_long\ + | hol_type_of CULong = + if C_ABI.long_bits (get_abi_profile ()) = 32 then \<^typ>\c_uint\ else \<^typ>\c_ulong\ + | hol_type_of CLongLong = \<^typ>\c_long\ + | hol_type_of CULongLong = \<^typ>\c_ulong\ + | hol_type_of CInt128 = \<^typ>\c_int128\ + | hol_type_of CUInt128 = \<^typ>\c_uint128\ + | hol_type_of (CPtr _) = dummyT (* pointer types use type inference *) + | hol_type_of CVoid = @{typ unit} + | hol_type_of (CStruct _) = dummyT + | hol_type_of (CUnion _) = dummyT + + fun type_name_of CBool = "_Bool" + | type_name_of CInt = "int" + | type_name_of CUInt = "unsigned int" + | type_name_of CChar = "char" + | type_name_of CSChar = "signed char" + | type_name_of CShort = "short" + | type_name_of CUShort = "unsigned short" + | type_name_of CLong = "long" + | type_name_of CULong = "unsigned long" + | type_name_of CLongLong = "long long" + | type_name_of CULongLong = "unsigned long long" + | type_name_of CInt128 = "__int128" + | type_name_of CUInt128 = "unsigned __int128" + | type_name_of (CPtr cty) = type_name_of cty ^ " *" + | type_name_of CVoid = "void" + | type_name_of (CStruct s) = "struct " ^ s + | type_name_of (CUnion s) = "union " ^ s + + (* C11 \
6.4.4.1p5: integer constant type from suffix flags. + Flags0 of int is a bitfield: bit 0 = unsigned (U suffix), + bit 1 = long (L suffix), bit 2 = long long (LL suffix). + This simplified version returns the base type from the suffix without + considering the constant's value; see choose_int_literal_type in + C_Translation_Engine for the full Table 5 lookup. *) + fun int_literal_type (Flags0 bits) = + let val is_unsigned = IntInf.andb (bits, 1) <> 0 + val is_long = IntInf.andb (bits, 2) <> 0 + val is_long_long = IntInf.andb (bits, 4) <> 0 + in if is_long_long andalso is_unsigned then CULongLong + else if is_long_long then CLongLong + else if is_unsigned andalso is_long then CULong + else if is_long then CLong + else if is_unsigned then CUInt + else CInt + end + + (* C11 \
6.7.2 (Type specifiers): resolve a list of C declaration specifiers + into a c_numeric_type. Specifier combinations follow \
6.7.2p2. + \
6.2.5p15: plain char signedness is implementation-defined (compiler profile). + \
6.7.2.2: enum specifiers treated as int. + Returns NONE for void, struct types, and other non-numeric specifiers. *) + fun resolve_c_type specs = + (* _Bool is a distinct type in C — handle it before the accumulator. + It cannot combine with signed/unsigned/short/long specifiers. *) + if List.exists (fn CTypeSpec0 (CBoolType0 _) => true | _ => false) specs + then SOME CBool + else + let + fun accumulate (CTypeSpec0 (CSignedType0 _)) (_, us, ch, sh, it, lg, vd, st) = + (true, us, ch, sh, it, lg, vd, st) + | accumulate (CTypeSpec0 (CUnsigType0 _)) (sg, _, ch, sh, it, lg, vd, st) = + (sg, true, ch, sh, it, lg, vd, st) + | accumulate (CTypeSpec0 (CCharType0 _)) (sg, us, _, sh, it, lg, vd, st) = + (sg, us, true, sh, it, lg, vd, st) + | accumulate (CTypeSpec0 (CShortType0 _)) (sg, us, ch, _, it, lg, vd, st) = + (sg, us, ch, true, it, lg, vd, st) + | accumulate (CTypeSpec0 (CIntType0 _)) (sg, us, ch, sh, _, lg, vd, st) = + (sg, us, ch, sh, true, lg, vd, st) + | accumulate (CTypeSpec0 (CLongType0 _)) (sg, us, ch, sh, it, lc, vd, st) = + (sg, us, ch, sh, it, lc + 1, vd, st) (* count long occurrences *) + | accumulate (CTypeSpec0 (CVoidType0 _)) (sg, us, ch, sh, it, lc, _, st) = + (sg, us, ch, sh, it, lc, true, st) + | accumulate (CTypeSpec0 (CSUType0 _)) (sg, us, ch, sh, it, lc, vd, _) = + (sg, us, ch, sh, it, lc, vd, true) + | accumulate (CTypeSpec0 (CEnumType0 _)) (sg, us, ch, sh, _, lc, vd, st) = + (sg, us, ch, sh, true, lc, vd, st) (* enum treated as int *) + | accumulate (CTypeSpec0 (CFloatType0 _)) _ = + error "micro_c_translate: float type not supported" + | accumulate (CTypeSpec0 (CDoubleType0 _)) _ = + error "micro_c_translate: double type not supported" + | accumulate (CTypeSpec0 (CInt128Type0 _)) (sg, us, ch, sh, it, _, vd, st) = + (sg, us, ch, sh, it, 128, vd, st) (* __int128: use long_count=128 as sentinel *) + | accumulate (CTypeSpec0 (CComplexType0 _)) _ = + error "micro_c_translate: _Complex type not supported" + | accumulate (CTypeSpec0 (CTypeDef0 _)) flags = flags + | accumulate (CTypeSpec0 _) _ = + error "micro_c_translate: unsupported type specifier" + (* C11 \
6.7.5: _Alignas affects memory layout alignment but not computation + semantics. Our translation does not model byte-level local variable layout, + so alignment is safely irrelevant. Verified example: C_Misc_Examples.thy. *) + | accumulate (CAlignSpec0 _) flags = flags + | accumulate (CFunSpec0 _) flags = flags (* inline/_Noreturn: silently ignored *) + | accumulate (CTypeQual0 (CVolatQual0 _)) flags = flags (* volatile: ignored for now; sound yield-based modeling is a follow-up *) + | accumulate (CTypeQual0 (CAtomicQual0 _)) _ = + error "micro_c_translate: _Atomic qualifier not supported (atomic semantics not modeled)" + | accumulate (CTypeQual0 (CRestrQual0 _)) flags = flags (* C11 \
6.7.3.1: restrict is optimization hint *) + | accumulate (CTypeQual0 (CConstQual0 _)) flags = flags (* C11 \
6.7.3: const has no runtime effect *) + | accumulate (CTypeQual0 _) flags = flags + | accumulate (CStorageSpec0 (CExtern0 _)) flags = flags (* extern: linkage only, safe to ignore *) + | accumulate (CStorageSpec0 _) flags = flags (* static/register/typedef: safe to ignore *) + val (has_signed, has_unsigned, has_char, has_short, _, long_count, has_void, has_struct) = + List.foldl (fn (spec, flags) => accumulate spec flags) + (false, false, false, false, false, 0, false, false) specs + (* C11 \
6.7.2p2: resolve accumulated specifier flags to a c_numeric_type. + Pattern order follows the standard's specifier combination table. *) + fun resolve_from_flags (_, _, _, _, _, _, true, _) = SOME CVoid (* void *) + | resolve_from_flags (_, _, _, _, _, _, _, true) = NONE (* struct/union *) + | resolve_from_flags (_, true, true, _, _, _, _, _) = SOME CChar (* unsigned char *) + | resolve_from_flags (true, _, true, _, _, _, _, _) = SOME CSChar (* signed char *) + | resolve_from_flags (_, _, true, _, _, _, _, _) = (* plain char *) + if #char_is_signed (C_Compiler.get_compiler_profile ()) + then SOME CSChar else SOME CChar + | resolve_from_flags (_, true, _, true, _, _, _, _) = SOME CUShort (* unsigned short *) + | resolve_from_flags (_, _, _, true, _, _, _, _) = SOME CShort (* short *) + | resolve_from_flags (_, true, _, _, _, 128, _, _) = SOME CUInt128 (* unsigned __int128 *) + | resolve_from_flags (_, _, _, _, _, 128, _, _) = SOME CInt128 (* __int128 *) + | resolve_from_flags (_, us, _, _, _, lc, _, _) = (* int/long/long long *) + if lc >= 2 then (if us then SOME CULongLong else SOME CLongLong) (* long long *) + else if lc = 1 then (if us then SOME CULong else SOME CLong) (* long *) + else if us then SOME CUInt (* unsigned int *) + else SOME CInt (* int, signed, signed int, or bare specifiers *) + in + resolve_from_flags (has_signed, has_unsigned, has_char, has_short, false, long_count, has_void, has_struct) + end + + (* Extract numeric type from a declaration *) + fun decl_type (CDecl0 (specs, _, _)) = resolve_c_type specs + | decl_type _ = NONE + + (* Extract numeric type from a parameter declaration *) + val param_type = decl_type + + (* Check if a parameter declaration has a pointer or array declarator + (e.g. int *a, struct point *p, int arr[]) *) + fun pointer_depth_of_derived derived = + List.foldl + (fn (d, acc) => + (case d of + CPtrDeclr0 _ => acc + 1 + | CArrDeclr0 _ => acc + 1 + | _ => acc)) + 0 derived + + fun pointer_depth_of_declr (CDeclr0 (_, derived, _, _, _)) = + pointer_depth_of_derived derived + + fun pointer_depth_of_decl (CDecl0 (_, [((Some declr, _), _)], _)) = + pointer_depth_of_declr declr + | pointer_depth_of_decl _ = 0 + + fun apply_ptr_depth base 0 = base + | apply_ptr_depth base n = apply_ptr_depth (CPtr base) (n - 1) + + fun is_pointer_param decl = + pointer_depth_of_decl decl > 0 + + fun abr_string_to_string (SS_base (ST s)) = s + | abr_string_to_string (SS_base (STa codes)) = + String.implode (List.map (Char.chr o IntInf.toInt) codes) + | abr_string_to_string (String_concatWith (sep, parts)) = + let val sep_s = abr_string_to_string sep + in String.concatWith sep_s (List.map abr_string_to_string parts) end + + fun ident_name (Ident0 (s, _, _)) = abr_string_to_string s + + fun declr_name (CDeclr0 (Some ident, _, _, _, _)) = ident_name ident + | declr_name (CDeclr0 (None, _, _, _, _)) = + error "C_Ast_Utils.declr_name: anonymous declarator" + + (* Extract parameter names from a function declarator. + Handles void parameters (empty list) and named parameters. *) + fun param_name (CDecl0 (_, [((Some declr, _), _)], _)) = SOME (declr_name declr) + | param_name (CDecl0 (_, [], _)) = NONE (* void parameter *) + | param_name _ = NONE + + fun extract_params (CDeclr0 (_, derived, _, _, _)) = + (case List.find (fn CFunDeclr0 _ => true | _ => false) derived of + SOME (CFunDeclr0 (Right (params, _), _, _)) => + List.mapPartial param_name params + | _ => []) + + (* Extract the full parameter declarations (not just names) from a function declarator *) + fun extract_param_decls (CDeclr0 (_, derived, _, _, _)) = + (case List.find (fn CFunDeclr0 _ => true | _ => false) derived of + SOME (CFunDeclr0 (Right (params, _), _, _)) => params + | _ => []) + + fun declr_is_variadic (CDeclr0 (_, derived, _, _, _)) = + (case List.find (fn CFunDeclr0 _ => true | _ => false) derived of + SOME (CFunDeclr0 (Right (_, has_varargs), _, _)) => has_varargs + | SOME (CFunDeclr0 _) => true + | _ => false) + + (* Check if a declaration has a struct type specifier and return the struct name. + E.g. for "struct point *p", returns SOME "point". *) + fun extract_struct_type_from_decl (CDecl0 (specs, _, _)) = + let fun find_struct [] = NONE + | find_struct (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, + Some ident, _, _, _), _)) :: _) = SOME (ident_name ident) + | find_struct (_ :: rest) = find_struct rest + in find_struct specs end + | extract_struct_type_from_decl _ = NONE + + (* Like extract_struct_type_from_decl, but also recognizes typedef names + that refer to known aggregates. E.g. for "mlk_poly *r" where mlk_poly + was typedef'd from an anonymous struct, returns SOME "mlk_poly". + Parameterized by tag (CStructTag0 or CUnionTag0). *) + fun extract_aggregate_type_from_decl_full tag agg_names (CDecl0 (specs, _, _)) = + let fun find_agg [] = NONE + | find_agg (CTypeSpec0 (CSUType0 (CStruct0 (tag', + Some ident, _, _, _), _)) :: _) = + if tag' = tag then SOME (ident_name ident) else NONE + | find_agg (CTypeSpec0 (CTypeDef0 (ident, _)) :: _) = + let val n = ident_name ident + in if List.exists (fn s => s = n) agg_names + then SOME n else NONE end + | find_agg (_ :: rest) = find_agg rest + in find_agg specs end + | extract_aggregate_type_from_decl_full _ _ _ = NONE + + val extract_struct_type_from_decl_full = extract_aggregate_type_from_decl_full CStructTag0 + val extract_union_type_from_decl_full = extract_aggregate_type_from_decl_full CUnionTag0 + + (* Extract struct definitions (with member lists) from a top-level declaration. + Returns SOME (struct_name, [field_name, ...]) for struct definitions. *) + fun extract_struct_def_from_decl (CDecl0 (specs, _, _)) = + let fun find_struct_def [] = NONE + | find_struct_def (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, + Some ident, Some members, _, _), _)) :: _) = + let val sname = ident_name ident + val field_names = List.mapPartial + (fn CDecl0 (_, [((Some declr, _), _)], _) => + SOME (declr_name declr) + | _ => NONE) + members + in SOME (sname, field_names) end + | find_struct_def (_ :: rest) = find_struct_def rest + in find_struct_def specs end + | extract_struct_def_from_decl _ = NONE + + (* Extract all struct definitions from a translation unit *) + fun extract_struct_defs (CTranslUnit0 (ext_decls, _)) = + List.mapPartial + (fn CDeclExt0 decl => extract_struct_def_from_decl decl | _ => NONE) + ext_decls + + (* Extract enum constant definitions from a translation unit. + Returns a flat list of (name, integer_value) pairs. + Handles both explicit values and auto-incrementing. *) + fun extract_enum_defs_from_spec (CTypeSpec0 (CEnumType0 (CEnum0 (_, Some enumerators, _, _), _))) = + let + fun process [] _ = [] + | process ((ident, Some (CConst0 (CIntConst0 (CInteger0 (n, _, _), _)))) :: rest) _ = + let val v = intinf_to_int_checked "enum constant" n + in (ident_name ident, v) :: process rest (v + 1) end + | process ((ident, None) :: rest) next_val = + (ident_name ident, next_val) :: process rest (next_val + 1) + | process (_ :: rest) next_val = process rest (next_val + 1) + in process enumerators 0 end + | extract_enum_defs_from_spec _ = [] + + fun extract_enum_defs (CTranslUnit0 (ext_decls, _)) = + let fun from_decl (CDeclExt0 (CDecl0 (specs, _, _))) = + List.concat (List.map extract_enum_defs_from_spec specs) + | from_decl _ = [] + in List.concat (List.map from_decl ext_decls) end + + (* Extract typedef mappings from a translation unit. + A typedef declaration is CDecl0 with CStorageSpec0 (CTypedef0 _) in specifiers. *) + fun extract_typedefs (CTranslUnit0 (ext_decls, _)) = + let + fun is_typedef_spec (CStorageSpec0 (CTypedef0 _)) = true + | is_typedef_spec _ = false + fun non_storage_spec (CStorageSpec0 _) = false + | non_storage_spec _ = true + + fun resolve_with_typedefs typedef_tab specs = + let + val type_specs = List.filter (fn CTypeSpec0 _ => true | _ => false) specs + in + case type_specs of + [CTypeSpec0 (CTypeDef0 (ident, _))] => + Symtab.lookup typedef_tab (ident_name ident) + | _ => resolve_c_type specs + end + + fun resolve_typedef_decl typedef_tab specs declr = + let + val type_specs = List.filter non_storage_spec specs + val base_cty = + (case resolve_with_typedefs typedef_tab type_specs of + SOME cty => SOME cty + | NONE => + (case List.find (fn CTypeSpec0 (CSUType0 _) => true | _ => false) type_specs of + SOME (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, Some ident, _, _, _), _))) => + SOME (CStruct (ident_name ident)) + | _ => + (case List.find (fn CTypeSpec0 (CSUType0 _) => true | _ => false) type_specs of + SOME (CTypeSpec0 (CSUType0 (CStruct0 (CUnionTag0, Some ident, _, _, _), _))) => + SOME (CUnion (ident_name ident)) + | _ => NONE))) + val ptr_depth = pointer_depth_of_declr declr + in + Option.map (fn cty => apply_ptr_depth cty ptr_depth) base_cty + end + + fun step (decl, (typedef_tab, acc)) = + (case decl of + CDeclExt0 (CDecl0 (specs, [((Some declr, _), _)], _)) => + if List.exists is_typedef_spec specs then + let + val name = declr_name declr + in + (case resolve_typedef_decl typedef_tab specs declr of + SOME cty => + let val tab' = Symtab.update (name, cty) typedef_tab + in (tab', acc @ [(name, cty)]) end + | NONE => (typedef_tab, acc)) + end + else (typedef_tab, acc) + | _ => (typedef_tab, acc)) + + val init_tab = Symtab.make (builtin_typedefs ()) + val (_, typedefs) = List.foldl step (init_tab, []) ext_decls + in + typedefs + end + + (* resolve_c_type with typedef resolution: check for CTypeDef0 first, + then fall back to standard resolve_c_type. + We strip type qualifiers (const, volatile) and storage specifiers + (static, extern) before matching, so that e.g. "const int32_t" still + resolves the typedef correctly. *) + fun resolve_c_type_full typedef_tab specs = + let val type_specs = List.filter + (fn CTypeSpec0 _ => true | _ => false) specs + in case type_specs of + [CTypeSpec0 (CTypeDef0 (ident, _))] => + (case Symtab.lookup typedef_tab (ident_name ident) of + SOME cty => SOME cty + | NONE => NONE) + | _ => resolve_c_type specs + end + + (* Extract the string from a C string literal node *) + fun extract_string_literal (CStrLit0 (CString0 (abr_str, _), _)) = + abr_string_to_string abr_str + + (* Evaluate a constant integer expression at translation time. + Used for _Static_assert conditions and similar compile-time checks. + resolve_decl_type resolves CDecl0 to a c_numeric_type (for sizeof). *) + fun eval_const_int_expr resolve_decl_type expr = + let fun eval (CConst0 (CIntConst0 (CInteger0 (n, _, _), _))) = n + | eval (CConst0 (CCharConst0 (CChar0 (c, _), _))) = integer_of_char c + | eval (CSizeofType0 (decl, _)) = + (case resolve_decl_type decl of + SOME cty => IntInf.fromInt (sizeof_c_type cty) + | NONE => error "micro_c_translate: _Static_assert: sizeof unsupported type") + | eval (CAlignofType0 (decl, _)) = + (case resolve_decl_type decl of + SOME cty => IntInf.fromInt (alignof_c_type cty) + | NONE => error "micro_c_translate: _Static_assert: _Alignof unsupported type") + | eval (CUnary0 (CMinOp0, e, _)) = IntInf.~ (eval e) + | eval (CUnary0 (CPlusOp0, e, _)) = eval e + | eval (CUnary0 (CNegOp0, e, _)) = + if eval e = 0 then 1 else 0 + | eval (CBinary0 (op_, lhs, rhs, _)) = + let val l = eval lhs val r = eval rhs + in case op_ of + CEqOp0 => if l = r then 1 else 0 + | CNeqOp0 => if l <> r then 1 else 0 + | CLeOp0 => if l < r then 1 else 0 + | CGrOp0 => if l > r then 1 else 0 + | CLeqOp0 => if l <= r then 1 else 0 + | CGeqOp0 => if l >= r then 1 else 0 + | CAddOp0 => l + r + | CSubOp0 => l - r + | CMulOp0 => l * r + | CLndOp0 => if l <> 0 andalso r <> 0 then 1 else 0 + | CLorOp0 => if l <> 0 orelse r <> 0 then 1 else 0 + | _ => error "micro_c_translate: _Static_assert: unsupported binary operator" + end + | eval _ = error "micro_c_translate: _Static_assert: unsupported expression in condition" + in eval expr end + + (* Conservative side-effect analysis for expression-order soundness checks. + Calls and mutating operators are treated as side-effecting. *) + fun named_call_is_pure pure_tab (CVar0 (ident, _)) = + Symtab.defined pure_tab (ident_name ident) + | named_call_is_pure _ _ = false + + fun expr_has_side_effect_with _ (CAssign0 _) = true + | expr_has_side_effect_with _ (CUnary0 (CPreIncOp0, _, _)) = true + | expr_has_side_effect_with _ (CUnary0 (CPostIncOp0, _, _)) = true + | expr_has_side_effect_with _ (CUnary0 (CPreDecOp0, _, _)) = true + | expr_has_side_effect_with _ (CUnary0 (CPostDecOp0, _, _)) = true + | expr_has_side_effect_with pure_tab (CCall0 (f, args, _)) = + let + val sub_effects = + expr_has_side_effect_with pure_tab f orelse + List.exists (expr_has_side_effect_with pure_tab) args + in + if named_call_is_pure pure_tab f then sub_effects else true + end + | expr_has_side_effect_with pure_tab (CBinary0 (_, l, r, _)) = + expr_has_side_effect_with pure_tab l orelse expr_has_side_effect_with pure_tab r + | expr_has_side_effect_with pure_tab (CUnary0 (_, e, _)) = expr_has_side_effect_with pure_tab e + | expr_has_side_effect_with pure_tab (CIndex0 (a, i, _)) = + expr_has_side_effect_with pure_tab a orelse expr_has_side_effect_with pure_tab i + | expr_has_side_effect_with pure_tab (CMember0 (e, _, _, _)) = expr_has_side_effect_with pure_tab e + | expr_has_side_effect_with pure_tab (CCast0 (_, e, _)) = expr_has_side_effect_with pure_tab e + | expr_has_side_effect_with pure_tab (CComma0 (es, _)) = List.exists (expr_has_side_effect_with pure_tab) es + | expr_has_side_effect_with pure_tab (CCond0 (c, t, e, _)) = + expr_has_side_effect_with pure_tab c orelse + (case t of Some te => expr_has_side_effect_with pure_tab te | None => false) orelse + expr_has_side_effect_with pure_tab e + | expr_has_side_effect_with _ _ = false + + fun expr_has_side_effect expr = + expr_has_side_effect_with (!current_pure_function_names) expr + + fun init_has_side_effect_with pure_tab (CInitExpr0 (e, _)) = + expr_has_side_effect_with pure_tab e + | init_has_side_effect_with pure_tab (CInitList0 (inits, _)) = + List.exists (fn (_, init) => init_has_side_effect_with pure_tab init) inits + + fun decl_has_side_effect_with pure_tab (CDecl0 (_, declarators, _)) = + List.exists + (fn ((_, Some init), _) => init_has_side_effect_with pure_tab init + | _ => false) + declarators + | decl_has_side_effect_with _ _ = true + + fun stmt_has_side_effect_with pure_tab (CCompound0 (_, items, _)) = + List.exists (item_has_side_effect_with pure_tab) items + | stmt_has_side_effect_with pure_tab (CExpr0 (Some e, _)) = expr_has_side_effect_with pure_tab e + | stmt_has_side_effect_with _ (CExpr0 (None, _)) = false + | stmt_has_side_effect_with pure_tab (CReturn0 (Some e, _)) = expr_has_side_effect_with pure_tab e + | stmt_has_side_effect_with _ (CReturn0 (None, _)) = false + | stmt_has_side_effect_with pure_tab (CIf0 (c, t, e_opt, _)) = + expr_has_side_effect_with pure_tab c orelse + stmt_has_side_effect_with pure_tab t orelse + (case e_opt of Some e => stmt_has_side_effect_with pure_tab e | None => false) + | stmt_has_side_effect_with pure_tab (CWhile0 (c, b, _, _)) = + expr_has_side_effect_with pure_tab c orelse stmt_has_side_effect_with pure_tab b + | stmt_has_side_effect_with pure_tab (CFor0 (Left init_opt, cond_opt, step_opt, body, _)) = + (case init_opt of Some e => expr_has_side_effect_with pure_tab e | None => false) orelse + (case cond_opt of Some e => expr_has_side_effect_with pure_tab e | None => false) orelse + (case step_opt of Some e => expr_has_side_effect_with pure_tab e | None => false) orelse + stmt_has_side_effect_with pure_tab body + | stmt_has_side_effect_with pure_tab (CFor0 (Right decl, cond_opt, step_opt, body, _)) = + decl_has_side_effect_with pure_tab decl orelse + (case cond_opt of Some e => expr_has_side_effect_with pure_tab e | None => false) orelse + (case step_opt of Some e => expr_has_side_effect_with pure_tab e | None => false) orelse + stmt_has_side_effect_with pure_tab body + | stmt_has_side_effect_with pure_tab (CSwitch0 (e, s, _)) = + expr_has_side_effect_with pure_tab e orelse stmt_has_side_effect_with pure_tab s + | stmt_has_side_effect_with pure_tab (CCase0 (e, s, _)) = + expr_has_side_effect_with pure_tab e orelse stmt_has_side_effect_with pure_tab s + | stmt_has_side_effect_with pure_tab (CCases0 (e1, e2, s, _)) = + expr_has_side_effect_with pure_tab e1 orelse + expr_has_side_effect_with pure_tab e2 orelse + stmt_has_side_effect_with pure_tab s + | stmt_has_side_effect_with pure_tab (CDefault0 (s, _)) = stmt_has_side_effect_with pure_tab s + | stmt_has_side_effect_with pure_tab (CLabel0 (_, s, _, _)) = stmt_has_side_effect_with pure_tab s + | stmt_has_side_effect_with _ (CBreak0 _) = false + | stmt_has_side_effect_with _ (CCont0 _) = false + | stmt_has_side_effect_with _ (CGoto0 _) = true + | stmt_has_side_effect_with _ (CGotoPtr0 _) = true + | stmt_has_side_effect_with _ (CAsm0 _) = true + + and item_has_side_effect_with pure_tab (CBlockStmt0 s) = stmt_has_side_effect_with pure_tab s + | item_has_side_effect_with pure_tab (CBlockDecl0 d) = decl_has_side_effect_with pure_tab d + | item_has_side_effect_with _ (CNestedFunDef0 _) = true + + fun fundef_is_pure_with pure_tab (CFunDef0 (_, _, _, body, _)) = + not (stmt_has_side_effect_with pure_tab body) + + (* ----- Generic C AST fold ----- + Post-order fold over C expression/statement trees. + The handler f receives each node AFTER its children have been accumulated. + This eliminates the need for repetitive per-walker AST traversal code. *) + fun fold_c_expr f expr acc = + f expr (case expr of + CAssign0 (_, lhs, rhs, _) => fold_c_expr f rhs (fold_c_expr f lhs acc) + | CBinary0 (_, l, r, _) => fold_c_expr f r (fold_c_expr f l acc) + | CUnary0 (_, e, _) => fold_c_expr f e acc + | CIndex0 (a, i, _) => fold_c_expr f i (fold_c_expr f a acc) + | CMember0 (e, _, _, _) => fold_c_expr f e acc + | CCast0 (_, e, _) => fold_c_expr f e acc + | CCall0 (callee, args, _) => + List.foldl (fn (a, ac) => fold_c_expr f a ac) + (fold_c_expr f callee acc) args + | CComma0 (es, _) => + List.foldl (fn (e, ac) => fold_c_expr f e ac) acc es + | CCond0 (c, t, e, _) => + fold_c_expr f e + ((case t of Some te => fold_c_expr f te | None => I) + (fold_c_expr f c acc)) + | CCompoundLit0 (_, inits, _) => + List.foldl (fn ((_, CInitExpr0 (e, _)), ac) => fold_c_expr f e ac + | (_, ac) => ac) acc inits + | CGenericSelection0 (ctrl, assocs, _) => + List.foldl (fn ((_, e), ac) => fold_c_expr f e ac) + (fold_c_expr f ctrl acc) assocs + | _ => acc) + + fun fold_c_init fe init acc = + (case init of + CInitExpr0 (e, _) => fe e acc + | CInitList0 (inits, _) => + List.foldl (fn ((_, i), ac) => fold_c_init fe i ac) acc inits) + + fun fold_c_stmt fe fs stmt acc = + let + val oe = fn (Some e) => fe e | None => I + fun fi (CBlockStmt0 s) acc = fold_c_stmt fe fs s acc + | fi (CBlockDecl0 (CDecl0 (_, declarators, _))) acc = + List.foldl + (fn (((_, Some init), _), ac) => fold_c_init fe init ac + | (_, ac) => ac) + acc declarators + | fi _ acc = acc + in + fs stmt (case stmt of + CCompound0 (_, items, _) => + List.foldl (fn (item, ac) => fi item ac) acc items + | CExpr0 (Some e, _) => fe e acc + | CExpr0 (None, _) => acc + | CReturn0 (Some e, _) => fe e acc + | CReturn0 (None, _) => acc + | CIf0 (c, t, e_opt, _) => + (case e_opt of Some e => fold_c_stmt fe fs e | None => I) + (fold_c_stmt fe fs t (fe c acc)) + | CWhile0 (c, b, _, _) => + fold_c_stmt fe fs b (fe c acc) + | CFor0 (Left (Some i), c, s, b, _) => + fold_c_stmt fe fs b (oe s (oe c (fe i acc))) + | CFor0 (Left None, c, s, b, _) => + fold_c_stmt fe fs b (oe s (oe c acc)) + | CFor0 (Right d, c, s, b, _) => + fold_c_stmt fe fs b (oe s (oe c (fi (CBlockDecl0 d) acc))) + | CSwitch0 (e, s, _) => + fold_c_stmt fe fs s (fe e acc) + | CCase0 (e, s, _) => + fold_c_stmt fe fs s (fe e acc) + | CCases0 (e1, e2, s, _) => + fold_c_stmt fe fs s (fe e2 (fe e1 acc)) + | CDefault0 (s, _) => + fold_c_stmt fe fs s acc + | CLabel0 (_, s, _, _) => + fold_c_stmt fe fs s acc + | _ => acc) + end + + fun expr_reads_vars expr = + fold_c_expr + (fn CVar0 (ident, _) => (fn acc => ident_name ident :: acc) + | _ => I) expr [] + + fun expr_written_vars expr = + fold_c_expr + (fn CAssign0 (_, CVar0 (ident, _), _, _) => (fn acc => ident_name ident :: acc) + | CUnary0 (CPreIncOp0, CVar0 (ident, _), _) => (fn acc => ident_name ident :: acc) + | CUnary0 (CPostIncOp0, CVar0 (ident, _), _) => (fn acc => ident_name ident :: acc) + | CUnary0 (CPreDecOp0, CVar0 (ident, _), _) => (fn acc => ident_name ident :: acc) + | CUnary0 (CPostDecOp0, CVar0 (ident, _), _) => (fn acc => ident_name ident :: acc) + | _ => I) expr [] + + fun list_intersects xs ys = + List.exists (fn x => List.exists (fn y => x = y) ys) xs + + (* C11 \
6.5p2: detect unsequenced conflicting accesses to the same + scalar object between two operands. *) + fun expr_has_unsequenced_ub_risk e0 e1 = + let + val r0 = distinct (op =) (expr_reads_vars e0) + val r1 = distinct (op =) (expr_reads_vars e1) + val w0 = distinct (op =) (expr_written_vars e0) + val w1 = distinct (op =) (expr_written_vars e1) + val writes_conflict = + list_intersects w0 (r1 @ w1) orelse list_intersects w1 (r0 @ w0) + in + (* Only reject when we can identify a concrete scalar object conflict. + Opaque/unknown side effects (e.g., function calls) are not treated as UB + by themselves, to avoid rejecting common valid C expressions. *) + writes_conflict + end + + (* Walk the C AST and collect variable names that appear on the LHS of + assignments or as operands of pre/post increment/decrement or address-of. + Used to identify parameters that need promotion to local variables. *) + fun find_assigned_vars stmt = + distinct (op =) (fold_c_stmt (fold_c_expr + (fn CAssign0 (_, CVar0 (ident, _), _, _) => (fn acc => ident_name ident :: acc) + | CUnary0 (CPreIncOp0, CVar0 (ident, _), _) => (fn acc => ident_name ident :: acc) + | CUnary0 (CPostIncOp0, CVar0 (ident, _), _) => (fn acc => ident_name ident :: acc) + | CUnary0 (CPreDecOp0, CVar0 (ident, _), _) => (fn acc => ident_name ident :: acc) + | CUnary0 (CPostDecOp0, CVar0 (ident, _), _) => (fn acc => ident_name ident :: acc) + | CUnary0 (CAdrOp0, CVar0 (ident, _), _) => (fn acc => ident_name ident :: acc) + | _ => I)) (fn _ => I) stmt []) + + (* Walk the C AST and collect label names targeted by goto statements. + Used to allocate goto flag references for forward-only goto support. *) + fun find_goto_targets stmt = + distinct (op =) (fold_c_stmt (fn _ => I) + (fn CGoto0 (ident, _) => (fn acc => ident_name ident :: acc) + | _ => I) stmt []) + + (* Collect direct function-call targets used in a function body. + Only named calls (CCall0 (CVar0 ...)) are collected. *) + fun find_called_functions (CFunDef0 (_, _, _, body, _)) = + distinct (op =) (fold_c_stmt (fold_c_expr + (fn CCall0 (CVar0 (ident, _), _, _) => (fn acc => ident_name ident :: acc) + | _ => I)) (fn _ => I) body []) + + local + fun declr_has_array (CDeclr0 (_, derived, _, _, _)) = + List.exists (fn CArrDeclr0 _ => true | _ => false) derived + + fun declr_of_decl (CDecl0 (_, declarators, _)) = + (case declarators of + ((Some declr, _), _) :: _ => SOME declr + | _ => NONE) + | declr_of_decl _ = NONE + + fun struct_name_of_decl struct_names decl = + extract_struct_type_from_decl_full struct_names decl + + fun env_contains env name = Option.isSome (Symtab.lookup env name) + fun env_insert name env = Symtab.update (name, ()) env + + fun expr_struct_name struct_env (CVar0 (ident, _)) = + Symtab.lookup struct_env (ident_name ident) + | expr_struct_name struct_env (CCast0 (_, e, _)) = + expr_struct_name struct_env e + | expr_struct_name _ _ = NONE + + fun struct_field_is_array_backed array_field_tab struct_name field_name = + List.exists (fn fname => fname = field_name) + (the_default [] (Symtab.lookup array_field_tab struct_name)) + + fun expr_is_list_backed_in_env _ _ env _ (CVar0 (ident, _)) = + env_contains env (ident_name ident) + | expr_is_list_backed_in_env struct_tab array_field_tab env struct_env (CCast0 (_, e, _)) = + expr_is_list_backed_in_env struct_tab array_field_tab env struct_env e + | expr_is_list_backed_in_env _ array_field_tab _ struct_env (CMember0 (base, field_ident, _, _)) = + (case expr_struct_name struct_env base of + SOME struct_name => + struct_field_is_array_backed array_field_tab struct_name (ident_name field_ident) + | NONE => false) + | expr_is_list_backed_in_env _ _ _ _ _ = false + + fun add_decl_array_bindings decl env = + (case declr_of_decl decl of + SOME declr => + if declr_has_array declr then env_insert (declr_name declr) env else env + | NONE => env) + + fun alias_names_from_expr struct_tab array_field_tab env struct_env (CAssign0 (_, CVar0 (ident, _), rhs, _)) acc = + let + val acc' = alias_names_from_expr struct_tab array_field_tab env struct_env rhs acc + in + if expr_is_list_backed_in_env struct_tab array_field_tab env struct_env rhs then + ident_name ident :: acc' + else + acc' + end + | alias_names_from_expr struct_tab array_field_tab env struct_env (CAssign0 (_, lhs, rhs, _)) acc = + alias_names_from_expr struct_tab array_field_tab env struct_env rhs + (alias_names_from_expr struct_tab array_field_tab env struct_env lhs acc) + | alias_names_from_expr struct_tab array_field_tab env struct_env (CBinary0 (_, l, r, _)) acc = + alias_names_from_expr struct_tab array_field_tab env struct_env r + (alias_names_from_expr struct_tab array_field_tab env struct_env l acc) + | alias_names_from_expr struct_tab array_field_tab env struct_env (CUnary0 (_, e, _)) acc = + alias_names_from_expr struct_tab array_field_tab env struct_env e acc + | alias_names_from_expr struct_tab array_field_tab env struct_env (CIndex0 (a, i, _)) acc = + alias_names_from_expr struct_tab array_field_tab env struct_env i + (alias_names_from_expr struct_tab array_field_tab env struct_env a acc) + | alias_names_from_expr struct_tab array_field_tab env struct_env (CMember0 (e, _, _, _)) acc = + alias_names_from_expr struct_tab array_field_tab env struct_env e acc + | alias_names_from_expr struct_tab array_field_tab env struct_env (CCast0 (_, e, _)) acc = + alias_names_from_expr struct_tab array_field_tab env struct_env e acc + | alias_names_from_expr struct_tab array_field_tab env struct_env (CCall0 (f, args, _)) acc = + List.foldl (fn (a, ac) => alias_names_from_expr struct_tab array_field_tab env struct_env a ac) + (alias_names_from_expr struct_tab array_field_tab env struct_env f acc) args + | alias_names_from_expr struct_tab array_field_tab env struct_env (CComma0 (es, _)) acc = + List.foldl (fn (e, ac) => alias_names_from_expr struct_tab array_field_tab env struct_env e ac) acc es + | alias_names_from_expr struct_tab array_field_tab env struct_env (CCond0 (c, t, e, _)) acc = + alias_names_from_expr struct_tab array_field_tab env struct_env e + ((case t of Some te => alias_names_from_expr struct_tab array_field_tab env struct_env te | None => I) + (alias_names_from_expr struct_tab array_field_tab env struct_env c acc)) + | alias_names_from_expr _ _ _ _ _ acc = acc + + fun alias_names_from_decl struct_tab array_field_tab env struct_env (CDecl0 (_, declarators, _)) acc = + List.foldl + (fn (((Some declr, Some (CInitExpr0 (init, _))), _), ac) => + if expr_is_list_backed_in_env struct_tab array_field_tab env struct_env init then + declr_name declr :: ac + else + ac + | (_, ac) => ac) + acc declarators + | alias_names_from_decl _ _ _ _ _ acc = acc + + fun alias_names_from_item struct_tab array_field_tab env struct_env (CBlockStmt0 stmt) acc = + alias_names_from_stmt struct_tab array_field_tab env struct_env stmt acc + | alias_names_from_item struct_tab array_field_tab env struct_env (CBlockDecl0 decl) acc = + alias_names_from_decl struct_tab array_field_tab env struct_env decl acc + | alias_names_from_item _ _ _ _ _ acc = acc + + and alias_names_from_stmt struct_tab array_field_tab env struct_env (CCompound0 (_, items, _)) acc = + List.foldl (fn (item, ac) => alias_names_from_item struct_tab array_field_tab env struct_env item ac) acc items + | alias_names_from_stmt struct_tab array_field_tab env struct_env (CExpr0 (Some e, _)) acc = + alias_names_from_expr struct_tab array_field_tab env struct_env e acc + | alias_names_from_stmt _ _ _ _ (CExpr0 (None, _)) acc = acc + | alias_names_from_stmt struct_tab array_field_tab env struct_env (CReturn0 (Some e, _)) acc = + alias_names_from_expr struct_tab array_field_tab env struct_env e acc + | alias_names_from_stmt _ _ _ _ (CReturn0 (None, _)) acc = acc + | alias_names_from_stmt struct_tab array_field_tab env struct_env (CIf0 (c, t, e_opt, _)) acc = + (case e_opt of + Some e => alias_names_from_stmt struct_tab array_field_tab env struct_env e + | None => I) + (alias_names_from_stmt struct_tab array_field_tab env struct_env t + (alias_names_from_expr struct_tab array_field_tab env struct_env c acc)) + | alias_names_from_stmt struct_tab array_field_tab env struct_env (CWhile0 (c, b, _, _)) acc = + alias_names_from_stmt struct_tab array_field_tab env struct_env b + (alias_names_from_expr struct_tab array_field_tab env struct_env c acc) + | alias_names_from_stmt struct_tab array_field_tab env struct_env (CFor0 (Left (Some i), c, s, b, _)) acc = + alias_names_from_stmt struct_tab array_field_tab env struct_env b + (opt_alias_expr struct_tab array_field_tab env struct_env s + (opt_alias_expr struct_tab array_field_tab env struct_env c + (alias_names_from_expr struct_tab array_field_tab env struct_env i acc))) + | alias_names_from_stmt struct_tab array_field_tab env struct_env (CFor0 (Left None, c, s, b, _)) acc = + alias_names_from_stmt struct_tab array_field_tab env struct_env b + (opt_alias_expr struct_tab array_field_tab env struct_env s + (opt_alias_expr struct_tab array_field_tab env struct_env c acc)) + | alias_names_from_stmt struct_tab array_field_tab env struct_env (CFor0 (Right d, c, s, b, _)) acc = + alias_names_from_stmt struct_tab array_field_tab env struct_env b + (opt_alias_expr struct_tab array_field_tab env struct_env s + (opt_alias_expr struct_tab array_field_tab env struct_env c + (alias_names_from_decl struct_tab array_field_tab env struct_env d acc))) + | alias_names_from_stmt struct_tab array_field_tab env struct_env (CSwitch0 (e, s, _)) acc = + alias_names_from_stmt struct_tab array_field_tab env struct_env s + (alias_names_from_expr struct_tab array_field_tab env struct_env e acc) + | alias_names_from_stmt struct_tab array_field_tab env struct_env (CCase0 (e, s, _)) acc = + alias_names_from_stmt struct_tab array_field_tab env struct_env s + (alias_names_from_expr struct_tab array_field_tab env struct_env e acc) + | alias_names_from_stmt struct_tab array_field_tab env struct_env (CDefault0 (s, _)) acc = + alias_names_from_stmt struct_tab array_field_tab env struct_env s acc + | alias_names_from_stmt struct_tab array_field_tab env struct_env (CLabel0 (_, s, _, _)) acc = + alias_names_from_stmt struct_tab array_field_tab env struct_env s acc + | alias_names_from_stmt _ _ _ _ _ acc = acc + + and opt_alias_expr struct_tab array_field_tab env struct_env (Some e) acc = + alias_names_from_expr struct_tab array_field_tab env struct_env e acc + | opt_alias_expr _ _ _ _ None acc = acc + + in + fun find_list_backed_aliases struct_tab array_field_tab (CFunDef0 (_, declr, _, body, _)) = + let + val struct_names = Symtab.keys struct_tab + val param_decls = extract_param_decls declr + val struct_env = + List.foldl (fn (pdecl, env) => + case (declr_of_decl pdecl, struct_name_of_decl struct_names pdecl) of + (SOME pdeclr, SOME sname) => + Symtab.update (declr_name pdeclr, sname) env + | _ => env) Symtab.empty param_decls + val env0 = + List.foldl (fn (pdecl, env) => + case declr_of_decl pdecl of + SOME pdeclr => + if declr_has_array pdeclr then env_insert (declr_name pdeclr) env else env + | NONE => env) Symtab.empty param_decls + fun add_local_arrays_stmt (CCompound0 (_, items, _)) env = + List.foldl + (fn (CBlockStmt0 stmt, ea) => add_local_arrays_stmt stmt ea + | (CBlockDecl0 decl, ea) => add_decl_array_bindings decl ea + | (_, ea) => ea) + env items + | add_local_arrays_stmt (CIf0 (_, t, e_opt, _)) env = + (case e_opt of Some e => add_local_arrays_stmt e | None => I) (add_local_arrays_stmt t env) + | add_local_arrays_stmt (CWhile0 (_, b, _, _)) env = add_local_arrays_stmt b env + | add_local_arrays_stmt (CFor0 (Right d, _, _, b, _)) env = + add_local_arrays_stmt b (add_decl_array_bindings d env) + | add_local_arrays_stmt (CFor0 (_, _, _, b, _)) env = add_local_arrays_stmt b env + | add_local_arrays_stmt (CSwitch0 (_, s, _)) env = add_local_arrays_stmt s env + | add_local_arrays_stmt (CCase0 (_, s, _)) env = add_local_arrays_stmt s env + | add_local_arrays_stmt (CDefault0 (s, _)) env = add_local_arrays_stmt s env + | add_local_arrays_stmt (CLabel0 (_, s, _, _)) env = add_local_arrays_stmt s env + | add_local_arrays_stmt _ env = env + val env0 = add_local_arrays_stmt body env0 + fun iterate env = + let + val added = + distinct (op =) (alias_names_from_stmt struct_tab array_field_tab env struct_env body []) + val env' = List.foldl (fn (name, ea) => env_insert name ea) env added + in + if Symtab.dest env' = Symtab.dest env then env else iterate env' + end + in + Symtab.keys (iterate env0) + end + + end + + fun find_indexed_base_vars (CFunDef0 (_, _, _, body, _)) = + distinct (op =) (fold_c_stmt (fold_c_expr + (fn CIndex0 (CVar0 (ident, _), _, _) => (fn acc => ident_name ident :: acc) + | CUnary0 (CIndOp0, CVar0 (ident, _), _) => (fn acc => ident_name ident :: acc) + | _ => I)) (fn _ => I) body []) + + fun find_named_calls_with_args (CFunDef0 (_, _, _, body, _)) = + fold_c_stmt (fold_c_expr + (fn CCall0 (CVar0 (ident, _), args, _) => (fn acc => (ident_name ident, args) :: acc) + | _ => I)) (fn _ => I) body [] + + + (* Extract struct definitions with field types from a top-level declaration. + Returns SOME (struct_name, [(field_name, field_type)]) for struct definitions. + Falls back to CInt for fields whose type cannot be resolved. *) + (* Extract struct type name from declaration specifiers (for struct-typed fields) *) + fun extract_aggregate_type_from_specs tag specs = + case List.find (fn CTypeSpec0 (CSUType0 _) => true | _ => false) specs of + SOME (CTypeSpec0 (CSUType0 (CStruct0 (tag', Some ident, _, _, _), _))) => + if tag' = tag then SOME (ident_name ident) else NONE + | _ => NONE + + val extract_struct_type_from_specs = extract_aggregate_type_from_specs CStructTag0 + val extract_union_type_from_specs = extract_aggregate_type_from_specs CUnionTag0 + + (* The _full variants are intentionally kept separate rather than + parameterized: extract_struct_type_from_specs_full filters specs to + CTypeSpec0 only, while extract_union_type_from_specs_full excludes + CTypeQual0 and CStorageSpec0 (a broader filter needed for union + declarations that appear with qualifiers/storage specs). *) + fun extract_struct_type_from_specs_full struct_names specs = + case extract_struct_type_from_specs specs of + SOME sn => SOME sn + | NONE => + let val type_specs = List.filter + (fn CTypeSpec0 _ => true | _ => false) specs + in case type_specs of + [CTypeSpec0 (CTypeDef0 (ident, _))] => + let val n = ident_name ident + in if List.exists (fn s => s = n) struct_names + then SOME n else NONE end + | _ => NONE + end + + (* Like extract_union_type_from_specs, but also recognizes typedef names + that refer to known unions. *) + fun extract_union_type_from_specs_full union_names specs = + case extract_union_type_from_specs specs of + SOME un => SOME un + | NONE => + let val type_specs = List.filter + (fn CTypeQual0 _ => false | CStorageSpec0 _ => false | _ => true) specs + in case type_specs of + [CTypeSpec0 (CTypeDef0 (ident, _))] => + let val n = ident_name ident + in if List.exists (fn s => s = n) union_names + then SOME n else NONE end + | _ => NONE + end + + fun extract_member_field_info typedef_tab members = + List.mapPartial + (fn CDecl0 (field_specs, [((Some (CDeclr0 (Some ident_node, derived, _, _, _)), _), _)], _) => + let val fname = ident_name ident_node + (* C struct/union fields cannot have void type; if resolve_c_type + returns CVoid here, it means the specifiers were parsed as void + (e.g. from an opaque typedef). Fallback to CInt for field layout. *) + val base_fty = case resolve_c_type_full typedef_tab field_specs of + SOME CVoid => CInt + | SOME ct => ct + | NONE => + (case extract_struct_type_from_specs field_specs of + SOME sn => CStruct sn + | NONE => + (case extract_union_type_from_specs field_specs of + SOME un => CUnion un + | NONE => CInt)) + val ptr_depth = pointer_depth_of_derived derived + val fty = apply_ptr_depth base_fty ptr_depth + in SOME (fname, fty) end + | _ => NONE) + members + + fun raw_gref_typ () = + Term.Type (\<^type_name>\gref\, [!current_ref_addr_ty, !current_ref_gv_ty]) + + fun focused_ref_typ pointee_ty = + Term.Type (\<^type_name>\focused\, [raw_gref_typ (), !current_ref_gv_ty, pointee_ty]) + + fun struct_record_typ prefix sname = + if Symtab.defined (!current_parametric_struct_names) sname + then Term.Type (prefix ^ sname, [!current_ref_addr_ty, !current_ref_gv_ty]) + else Term.Type (prefix ^ sname, []) + + fun cty_to_record_typ _ CBool = SOME @{typ bool} + | cty_to_record_typ _ CInt = SOME \<^typ>\c_int\ + | cty_to_record_typ _ CUInt = SOME \<^typ>\c_uint\ + | cty_to_record_typ _ CChar = SOME \<^typ>\c_char\ + | cty_to_record_typ _ CSChar = SOME \<^typ>\c_schar\ + | cty_to_record_typ _ CShort = SOME \<^typ>\c_short\ + | cty_to_record_typ _ CUShort = SOME \<^typ>\c_ushort\ + | cty_to_record_typ _ CLong = + if C_ABI.long_bits (get_abi_profile ()) = 32 then SOME \<^typ>\c_int\ else SOME \<^typ>\c_long\ + | cty_to_record_typ _ CULong = + if C_ABI.long_bits (get_abi_profile ()) = 32 then SOME \<^typ>\c_uint\ else SOME \<^typ>\c_ulong\ + | cty_to_record_typ _ CLongLong = SOME \<^typ>\c_long\ + | cty_to_record_typ _ CULongLong = SOME \<^typ>\c_ulong\ + | cty_to_record_typ _ CInt128 = SOME \<^typ>\c_int128\ + | cty_to_record_typ _ CUInt128 = SOME \<^typ>\c_uint128\ + | cty_to_record_typ prefix (CStruct sname) = SOME (struct_record_typ prefix sname) + | cty_to_record_typ _ (CPtr CChar) = SOME (HOLogic.listT \<^typ>\c_char\) + | cty_to_record_typ _ (CPtr CVoid) = SOME (raw_gref_typ ()) + | cty_to_record_typ _ (CPtr (CUnion _)) = SOME (raw_gref_typ ()) + | cty_to_record_typ prefix (CPtr cty) = + (case cty_to_record_typ prefix cty of + SOME inner => SOME (focused_ref_typ inner) + | NONE => SOME (raw_gref_typ ())) + | cty_to_record_typ _ CVoid = NONE + | cty_to_record_typ _ (CUnion _) = NONE + + fun ptr_depth_only derived = + List.foldl + (fn (d, acc) => + (case d of + CPtrDeclr0 _ => acc + 1 + | _ => acc)) + 0 derived + + fun has_array_derived derived = + List.exists (fn CArrDeclr0 _ => true | _ => false) derived + + fun member_record_field_typ prefix base_fty derived = + if has_array_derived derived then + Option.map HOLogic.listT (cty_to_record_typ prefix base_fty) + else if ptr_depth_only derived > 0 then + cty_to_record_typ prefix (apply_ptr_depth base_fty (ptr_depth_only derived)) + else + cty_to_record_typ prefix base_fty + + fun extract_member_record_field_info prefix typedef_tab members = + List.mapPartial + (fn CDecl0 (field_specs, [((Some (CDeclr0 (Some ident_node, derived, _, _, _)), _), _)], _) => + let val fname = ident_name ident_node + (* CVoid fallback: see comment in extract_member_field_info *) + val base_fty = case resolve_c_type_full typedef_tab field_specs of + SOME CVoid => CInt + | SOME ct => ct + | NONE => + (case extract_struct_type_from_specs field_specs of + SOME sn => CStruct sn + | NONE => CInt) + in SOME (fname, member_record_field_typ prefix base_fty derived) end + | _ => NONE) + members + + (* Extract struct or union definitions with field types from a top-level + declaration. Parameterized by tag (CStructTag0 or CUnionTag0). *) + fun extract_aggregate_def_with_types_from_decl tag typedef_tab (CDecl0 (specs, declrs, _)) = + let fun find_def [] = NONE + | find_def (CTypeSpec0 (CSUType0 (CStruct0 (tag', + Some ident, Some members, _, _), _)) :: _) = + if tag' = tag + then SOME (ident_name ident, extract_member_field_info typedef_tab members) + else NONE + | find_def (CTypeSpec0 (CSUType0 (CStruct0 (tag', + None, Some members, _, _), _)) :: _) = + if tag' = tag andalso + List.exists (fn CStorageSpec0 (CTypedef0 _) => true | _ => false) specs + then (case declrs of + [((Some (CDeclr0 (Some td_ident, _, _, _, _)), _), _)] => + SOME (ident_name td_ident, + extract_member_field_info typedef_tab members) + | _ => NONE) + else NONE + | find_def (_ :: rest) = find_def rest + in find_def specs end + | extract_aggregate_def_with_types_from_decl _ _ _ = NONE + + fun extract_aggregate_defs_with_types tag typedef_tab (CTranslUnit0 (ext_decls, _)) = + List.mapPartial + (fn CDeclExt0 decl => extract_aggregate_def_with_types_from_decl tag typedef_tab decl + | _ => NONE) + ext_decls + + val extract_struct_def_with_types_from_decl = + extract_aggregate_def_with_types_from_decl CStructTag0 + val extract_struct_defs_with_types = + extract_aggregate_defs_with_types CStructTag0 + + fun cty_needs_parametric_struct _ (CPtr _) = true + | cty_needs_parametric_struct parametric_structs (CStruct sname) = + Symtab.defined parametric_structs sname + | cty_needs_parametric_struct parametric_structs (CUnion sname) = + Symtab.defined parametric_structs sname + | cty_needs_parametric_struct _ _ = false + + fun derive_parametric_struct_names struct_defs = + let + fun step acc = + List.foldl + (fn ((sname, fields), tab) => + if List.exists (fn (_, fty) => cty_needs_parametric_struct acc fty) fields + then Symtab.update (sname, ()) tab + else tab) + acc + struct_defs + fun loop acc = + let val next = step acc + in if Symtab.dest next = Symtab.dest acc then acc else loop next end + val final = loop Symtab.empty + in + List.map #1 (Symtab.dest final) + end + + val extract_union_def_with_types_from_decl = + extract_aggregate_def_with_types_from_decl CUnionTag0 + val extract_union_defs_with_types = + extract_aggregate_defs_with_types CUnionTag0 + + (* Struct-only: record defs and array-field tracking. Unions don't need + Isabelle record types (they use a single-field sum representation) and + don't participate in list-backed parameter analysis. *) + fun extract_struct_record_def_from_decl prefix typedef_tab (CDecl0 (specs, declrs, _)) = + let fun find_struct_def [] = NONE + | find_struct_def (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, + Some ident, Some members, _, _), _)) :: _) = + SOME (ident_name ident, extract_member_record_field_info prefix typedef_tab members) + | find_struct_def (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, + None, Some members, _, _), _)) :: _) = + if List.exists (fn CStorageSpec0 (CTypedef0 _) => true | _ => false) specs + then (case declrs of + [((Some (CDeclr0 (Some td_ident, _, _, _, _)), _), _)] => + SOME (ident_name td_ident, + extract_member_record_field_info prefix typedef_tab members) + | _ => NONE) + else NONE + | find_struct_def (_ :: rest) = find_struct_def rest + in find_struct_def specs end + | extract_struct_record_def_from_decl _ _ _ = NONE + + fun extract_struct_record_defs prefix typedef_tab (CTranslUnit0 (ext_decls, _)) = + List.mapPartial + (fn CDeclExt0 decl => extract_struct_record_def_from_decl prefix typedef_tab decl + | _ => NONE) + ext_decls + + fun extract_member_array_field_names members = + List.mapPartial + (fn CDecl0 (_, [((Some (CDeclr0 (Some ident_node, derived, _, _, _)), _), _)], _) => + if List.exists (fn CArrDeclr0 _ => true | _ => false) derived + then SOME (ident_name ident_node) else NONE + | _ => NONE) + members + + fun extract_struct_array_fields_from_decl (CDecl0 (specs, declrs, _)) = + let fun find_struct_def [] = NONE + | find_struct_def (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, + Some ident, Some members, _, _), _)) :: _) = + SOME (ident_name ident, extract_member_array_field_names members) + | find_struct_def (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, + None, Some members, _, _), _)) :: _) = + if List.exists (fn CStorageSpec0 (CTypedef0 _) => true | _ => false) specs + then (case declrs of + [((Some (CDeclr0 (Some td_ident, _, _, _, _)), _), _)] => + SOME (ident_name td_ident, extract_member_array_field_names members) + | _ => NONE) + else NONE + | find_struct_def (_ :: rest) = find_struct_def rest + in find_struct_def specs end + | extract_struct_array_fields_from_decl _ = NONE + + fun extract_struct_array_fields (CTranslUnit0 (ext_decls, _)) = + List.mapPartial + (fn CDeclExt0 decl => extract_struct_array_fields_from_decl decl + | _ => NONE) + ext_decls + + fun extract_fundefs (CTranslUnit0 (ext_decls, _)) = + List.mapPartial + (fn CFDefExt0 fundef => SOME fundef | _ => NONE) + ext_decls + + (* C11 \
6.3.1.1p1: every integer type has an "integer conversion rank". + Ranks determine promotion and usual arithmetic conversion behavior. + _Bool < char = signed char < short < int < long < long long < __int128. + Unsigned types have the same rank as their signed counterparts. *) + fun type_rank CBool = 0 + | type_rank CChar = 1 + | type_rank CSChar = 1 + | type_rank CShort = 2 + | type_rank CUShort = 2 + | type_rank CInt = 3 + | type_rank CUInt = 3 + | type_rank CLong = 4 + | type_rank CULong = 4 + | type_rank CLongLong = 5 + | type_rank CULongLong = 5 + | type_rank CInt128 = 6 + | type_rank CUInt128 = 6 + | type_rank (CPtr _) = error "type_rank: pointer type has no integer conversion rank" + | type_rank CVoid = error "type_rank: void type has no integer conversion rank" + | type_rank (CStruct _) = error "type_rank: struct type has no integer conversion rank" + | type_rank (CUnion _) = error "type_rank: union type has no integer conversion rank" + + (* C11 \
6.3.1.1p2: integer promotion. + If an int can represent all values of the original type, the value is + converted to int; otherwise to unsigned int. Since all sub-int types + (char, short, _Bool) fit in int on all supported ABIs, we always + promote to int. Types at int rank or above are unchanged. *) + fun integer_promote cty = + if type_rank cty < type_rank CInt then CInt else cty + + (* C11 \
6.3.1.8: usual arithmetic conversions for binary operations. + First, integer promotions are performed on both operands. Then: + 1. If both have the same type, no further conversion. + 2. If both signed or both unsigned: convert to higher rank. + 3. If unsigned rank >= signed rank: convert to unsigned type. + 4. If signed type can represent all values of the unsigned type: + convert to the signed type. + 5. Otherwise: convert both to the unsigned type corresponding to + the signed operand's type. + Note: floating-point types are not supported (error in resolve_c_type). *) + fun usual_arith_conv (lty, rty) = + let val lp = integer_promote lty + val rp = integer_promote rty + in if lp = rp then lp + else if is_signed lp = is_signed rp then + (if type_rank lp >= type_rank rp then lp else rp) + else + let val (s, u) = if is_signed lp then (lp, rp) else (rp, lp) + in if type_rank u >= type_rank s + then u (* C11 rule 1: unsigned rank >= signed rank *) + else + (* C11 rules 2+3: signed has higher rank *) + case (bit_width_of s, bit_width_of u) of + (SOME sw, SOME uw) => + if sw > uw then s (* rule 2: signed strictly wider, can represent all unsigned *) + else (* rule 3: convert to unsigned type corresponding to signed *) + (case s of CLong => CULong | CLongLong => CULongLong + | CInt => CUInt | CInt128 => CUInt128 | _ => CUInt) + | _ => error "usual_arith_conv: cannot determine bit width for conversion" + end + end +end +\ + +end diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy new file mode 100644 index 00000000..1b84c9d0 --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -0,0 +1,1283 @@ +theory C_Definition_Generation + imports + C_Translation_Engine + keywords "micro_c_translate" :: thy_decl + and "micro_c_file" :: thy_decl + and "prefix:" and "manifest:" and "addr:" and "gv:" and "abi:" and "compiler:" + and "verbose" +begin + +subsection \Definition Generation\ + +ML \ +structure C_Def_Gen : sig + type manifest = {functions: string list option, types: string list option} + val set_decl_prefix : string -> unit + val set_manifest : manifest -> unit + val set_abi_profile : C_ABI.profile -> unit + val set_ref_universe_types : typ -> typ -> unit + val set_ref_abort_type : typ option -> unit + val set_pointer_model : C_Translate.pointer_model -> unit + val set_verbose : bool -> unit + val define_c_function : string -> string -> term -> local_theory -> local_theory + val process_translation_unit : C_Ast.nodeInfo C_Ast.cTranslationUnit + -> local_theory -> local_theory +end = +struct + type manifest = {functions: string list option, types: string list option} + + val current_decl_prefix : string Unsynchronized.ref = Unsynchronized.ref "c_" + val current_manifest : manifest Unsynchronized.ref = + Unsynchronized.ref {functions = NONE, types = NONE} + val current_abi_profile : C_ABI.profile Unsynchronized.ref = + Unsynchronized.ref C_ABI.LP64_LE + val current_ref_addr_ty : typ Unsynchronized.ref = + Unsynchronized.ref (TFree ("'addr", [])) + val current_ref_gv_ty : typ Unsynchronized.ref = + Unsynchronized.ref (TFree ("'gv", [])) + val current_pointer_model : C_Translate.pointer_model Unsynchronized.ref = + Unsynchronized.ref {ptr_add = SOME "c_ptr_add", ptr_shift_signed = SOME "c_ptr_shift_signed", ptr_diff = SOME "c_ptr_diff"} + val current_verbose : bool Unsynchronized.ref = Unsynchronized.ref false + fun set_verbose v = (current_verbose := v) + + fun set_decl_prefix pfx = (current_decl_prefix := pfx) + fun set_manifest m = (current_manifest := m) + fun set_abi_profile abi = (current_abi_profile := abi) + fun set_ref_universe_types addr_ty gv_ty = + (current_ref_addr_ty := addr_ty; + current_ref_gv_ty := gv_ty; + C_Ast_Utils.set_ref_universe_types addr_ty gv_ty) + fun set_ref_abort_type expr_constraint_opt = + (C_Translate.set_ref_abort_type expr_constraint_opt) + fun set_pointer_model model = + (current_pointer_model := model; + C_Translate.set_pointer_model model) + + fun define_c_function prefix name term lthy = + let + val full_name = prefix ^ name + val binding = Binding.name full_name + val term' = term |> Syntax.check_term lthy + val ((lhs_term, (_, _)), lthy') = + Local_Theory.define + ((binding, NoSyn), + ((Thm.def_binding binding, @{attributes [micro_rust_simps]}), term')) + lthy + val morphed_lhs = Morphism.term (Local_Theory.target_morphism lthy') lhs_term + val (registered_term, head_desc) = + let + val (head, args) = Term.strip_comb morphed_lhs + (* Replace phantom TYPE args whose type variable became schematic + (TVar) with TYPE(unit). This prevents "Illegal schematic type + variable" errors in callers that reference this constant. + Only phantom TYPE args are affected — TFree TYPE args (locale + parameters) and non-TYPE args are preserved. *) + val non_type_args = + List.filter (fn Const (n, Type ("itself", _)) => + n <> \<^const_name>\Pure.type\ + | _ => true) args + val used_tfrees = + List.foldl (fn (a, acc) => Term.add_tfrees a acc) [] non_type_args + |> map fst + fun fix_type_arg (Const (n, Type ("itself", [TFree (tv, _)]))) = + if n = \<^const_name>\Pure.type\ andalso + not (member (op =) used_tfrees tv) + then Const (n, Type ("itself", [@{typ unit}])) + else Const (n, Type ("itself", [TFree (tv, @{sort type})])) + | fix_type_arg (Const (n, Type ("itself", [TVar _]))) = + if n = \<^const_name>\Pure.type\ + then Const (n, Type ("itself", [@{typ unit}])) + else Const (n, Type ("itself", [@{typ unit}])) + | fix_type_arg arg = arg + val args' = map fix_type_arg args + in + case head of + Term.Const (c, _) => + (Term.list_comb (Const (c, dummyT), args'), "const: " ^ c) + | _ => (morphed_lhs, "registered term") + end + (* Verbose tracing: report extra type variables after definition. + Note: used_tfrees is computed inside the registered_term let block + above, so we recompute it here for the verbose check. *) + (* Collect locale TFrees from the expression type constraint + morphed args *) + val verbose_used_tfrees = + let val (_, args) = Term.strip_comb morphed_lhs + val from_args = + List.foldl (fn (a, acc) => Term.add_tfrees a acc) [] args |> map fst + val from_constraint = + Term.add_tfreesT (!current_ref_addr_ty) [] + @ Term.add_tfreesT (!current_ref_gv_ty) [] + |> map fst + in distinct (op =) (from_args @ from_constraint) end + val _ = + if !current_verbose then + let + val all_tvars = Term.add_tvars term' [] + val all_tfrees = Term.add_tfrees term' [] + val extra_tfrees = List.filter + (fn (n, _) => not (member (op =) verbose_used_tfrees n)) all_tfrees + in + if null all_tvars andalso null extra_tfrees then () + else + (writeln (" [verbose] " ^ full_name ^ " type diagnostics:"); + List.app (fn ((n, idx), sort) => + writeln (" TVar: ?" ^ n ^ "." ^ Int.toString idx ^ + " :: " ^ @{make_string} sort)) all_tvars; + List.app (fn (n, sort) => + writeln (" extra TFree: " ^ n ^ + " :: " ^ @{make_string} sort)) extra_tfrees; + (* Find sub-terms that introduce each extra type variable *) + let + val extra_names = map fst extra_tfrees @ map (fst o fst) all_tvars + fun has_extra_tyvar t = + let val tvs = Term.add_tfrees t [] |> map fst + val tvars = Term.add_tvars t [] |> map (fst o fst) + in List.exists (fn n => member (op =) extra_names n) tvs orelse + List.exists (fn n => member (op =) extra_names n) tvars + end + fun trace_subterms _ (Abs (x, T, body)) = + (if Term.add_tfreesT T [] |> List.exists (fn (n, _) => member (op =) extra_names n) + then writeln (" source: lambda " ^ x ^ " :: " ^ + Syntax.string_of_typ_global @{theory} T) + else (); + trace_subterms 0 body) + | trace_subterms depth (f $ x) = + if depth < 20 then + (trace_subterms (depth + 1) f; + trace_subterms (depth + 1) x) + else () + | trace_subterms _ (Free (n, T)) = + if has_extra_tyvar (Free (n, T)) + then writeln (" source: Free " ^ n ^ " :: " ^ + Syntax.string_of_typ_global @{theory} T) + else () + | trace_subterms _ (Const (n, T)) = + if has_extra_tyvar (Const (n, T)) + then writeln (" source: Const " ^ n ^ " :: " ^ + Syntax.string_of_typ_global @{theory} T) + else () + | trace_subterms _ _ = () + in trace_subterms 0 term' end) + end + else () + val _ = + (C_Translate.defined_func_consts := + Symtab.update (full_name, registered_term) (! C_Translate.defined_func_consts); + writeln ("Defined: " ^ full_name ^ " (" ^ head_desc ^ ")")) + in lthy' end + + fun define_c_global_value prefix name term lthy = + let + val full_name = prefix ^ "global_" ^ name + val binding = Binding.name full_name + val term' = term |> Syntax.check_term lthy + val ((_, (_, _)), lthy') = + Local_Theory.define + ((binding, NoSyn), + ((Thm.def_binding binding, @{attributes [micro_rust_simps]}), term')) + lthy + val _ = writeln ("Defined: " ^ full_name) + in lthy' end + + fun define_named_value_if_absent full_name term lthy = + let + val ctxt = Local_Theory.target_of lthy + val exists_const = can (Proof_Context.read_const {proper = true, strict = true} ctxt) full_name + val exists_fixed = is_some (Variable.lookup_fixed ctxt full_name) + in + if exists_const orelse exists_fixed then lthy + else + let + val binding = Binding.name full_name + val term' = term |> Syntax.check_term lthy + val ((_, (_, _)), lthy') = + Local_Theory.define + ((binding, NoSyn), + ((Thm.def_binding binding, @{attributes [micro_rust_simps]}), term')) + lthy + val _ = writeln ("Defined: " ^ full_name) + in lthy' end + end + + val abi_is_big_endian = C_ABI.big_endian + + fun mk_bool_term true = @{term True} + | mk_bool_term false = @{term False} + + fun define_abi_metadata prefix abi_profile lthy = + let + val defs = [ + ("abi_pointer_bits", HOLogic.mk_nat (C_ABI.pointer_bits abi_profile)), + ("abi_long_bits", HOLogic.mk_nat (C_ABI.long_bits abi_profile)), + ("abi_char_is_signed", mk_bool_term (#char_is_signed (C_Compiler.get_compiler_profile ()))), + ("abi_big_endian", mk_bool_term (abi_is_big_endian abi_profile)) + ] + in + List.foldl (fn ((suffix, tm), lthy_acc) => + define_named_value_if_absent (prefix ^ suffix) tm lthy_acc) lthy defs + end + + val intinf_to_int_checked = C_Ast_Utils.intinf_to_int_checked + val struct_name_of_cty = C_Ast_Utils.struct_name_of_cty + + fun type_exists ctxt tname = + can (Proof_Context.read_type_name {proper = true, strict = true} ctxt) tname + + fun ensure_struct_record prefix (sname, fields) lthy = + let + val tname = prefix ^ sname + val ctxt = Local_Theory.target_of lthy + in + if type_exists ctxt tname then lthy + else + let + val bad_fields = + List.filter (fn (_, ty_opt) => case ty_opt of NONE => true | SOME _ => false) fields + val _ = + if null bad_fields then () + else + error ("micro_c_translate: cannot auto-declare struct " ^ tname ^ + " because field type(s) are unsupported: " ^ + String.concatWith ", " (List.map #1 bad_fields) ^ + ". Please provide an explicit datatype_record declaration.") + val record_fields = + List.map (fn (fname, SOME ty) => (Binding.name (prefix ^ sname ^ "_" ^ fname), ty) + | (_, NONE) => raise Match) fields + val tfrees = + record_fields + |> List.foldl (fn ((_, ty), acc) => Term.add_tfreesT ty acc) [] + |> distinct (op =) + val tfree_subst = + tfrees + |> map_index (fn (i, (n, sort)) => + ((n, sort), Term.TFree ("'ac" ^ Int.toString i, sort))) + fun subst_tfree (n, sort) = + case List.find (fn ((n', s'), _) => n = n' andalso sort = s') tfree_subst of + SOME (_, t) => t + | NONE => Term.TFree (n, sort) + fun subst_ty ty = Term.map_atyps (fn Term.TFree ns => subst_tfree ns | t => t) ty + val record_fields = List.map (fn (b, ty) => (b, subst_ty ty)) record_fields + val tyargs = + List.map (fn (_, t as Term.TFree (_, sort)) => (NONE, (t, sort)) + | _ => raise Fail "tfree_subst: unexpected non-TFree") tfree_subst + val lthy' = + Datatype_Records.record + (Binding.name tname) + Datatype_Records.default_ctr_options + tyargs + record_fields + lthy + val _ = writeln ("Declared datatype_record: " ^ tname) + in + lthy' + end + end + + fun extract_global_consts typedef_tab struct_tab enum_tab ctxt + (C_Ast.CTranslUnit0 (ext_decls, _)) = + let + val struct_names = Symtab.keys struct_tab + fun resolve_make_const sname = + let + val raw = + Proof_Context.read_const {proper = true, strict = false} ctxt + ("make_" ^ !current_decl_prefix ^ sname) + in + (case raw of + Const (n, _) => Const (n, dummyT) + | Free (x, _) => + (case Variable.lookup_const ctxt x of + SOME c => Const (c, dummyT) + | NONE => Free (x, dummyT)) + | _ => raw) + end + fun has_const_qual specs = + List.exists (fn C_Ast.CTypeQual0 (C_Ast.CConstQual0 _) => true | _ => false) specs + fun has_static_storage specs = + List.exists (fn C_Ast.CStorageSpec0 (C_Ast.CStatic0 _) => true | _ => false) specs + fun has_array_declr (C_Ast.CDeclr0 (_, derived, _, _, _)) = + List.exists (fn C_Ast.CArrDeclr0 _ => true | _ => false) derived + fun array_decl_size (C_Ast.CDeclr0 (_, derived, _, _, _)) = + List.mapPartial + (fn C_Ast.CArrDeclr0 (_, C_Ast.CArrSize0 (_, C_Ast.CConst0 + (C_Ast.CIntConst0 (C_Ast.CInteger0 (n, _, _), _))), _) => + if n < 0 then + error "micro_c_translate: negative array bound not supported" + else + SOME (intinf_to_int_checked "array bound" n) + | _ => NONE) derived + |> (fn n :: _ => SOME n | [] => NONE) + fun init_scalar_const_value (C_Ast.CConst0 (C_Ast.CIntConst0 (C_Ast.CInteger0 (n, _, _), _))) = n + | init_scalar_const_value (C_Ast.CConst0 (C_Ast.CCharConst0 (C_Ast.CChar0 (c, _), _))) = + C_Ast.integer_of_char c + | init_scalar_const_value (C_Ast.CConst0 (C_Ast.CCharConst0 (C_Ast.CChars0 _, _))) = + error "micro_c_translate: multi-character constant not supported in initializers" + | init_scalar_const_value (C_Ast.CVar0 (ident, _)) = + let val name = C_Ast_Utils.ident_name ident + in case Symtab.lookup enum_tab name of + SOME value => IntInf.fromInt value + | NONE => + error ("micro_c_translate: unsupported global initializer element: " ^ name) + end + | init_scalar_const_value (C_Ast.CUnary0 (C_Ast.CMinOp0, e, _)) = + IntInf.~ (init_scalar_const_value e) + | init_scalar_const_value (C_Ast.CUnary0 (C_Ast.CPlusOp0, e, _)) = + init_scalar_const_value e + | init_scalar_const_value (C_Ast.CCast0 (_, e, _)) = + init_scalar_const_value e + | init_scalar_const_value _ = + error "micro_c_translate: non-constant global initializer element" + fun default_const_term (C_Ast_Utils.CBool) = Const (\<^const_name>\False\, @{typ bool}) + | default_const_term (C_Ast_Utils.CPtr _) = + Const (\<^const_name>\c_uninitialized\, dummyT) + | default_const_term (C_Ast_Utils.CStruct sname) = + let + val fields = + (case Symtab.lookup struct_tab sname of + SOME fs => fs + | NONE => error ("micro_c_translate: unknown struct in global initializer: " ^ sname)) + val make_const = resolve_make_const sname + val field_vals = List.map (fn (_, field_cty) => default_const_term field_cty) fields + in + List.foldl (fn (v, acc) => acc $ v) make_const field_vals + end + | default_const_term cty = + HOLogic.mk_number (C_Ast_Utils.hol_type_of cty) 0 + fun init_expr_const_term (C_Ast_Utils.CPtr _) + (C_Ast.CConst0 (C_Ast.CStrConst0 (C_Ast.CString0 (abr_str, _), _))) = + let val s = C_Ast_Utils.abr_string_to_string abr_str + val char_ty = C_Ast_Utils.hol_type_of C_Ast_Utils.CChar + val bytes = List.map (fn c => HOLogic.mk_number char_ty (Char.ord c)) + (String.explode s) + val with_null = bytes @ [HOLogic.mk_number char_ty 0] + in HOLogic.mk_list char_ty with_null end + | init_expr_const_term (C_Ast_Utils.CPtr _) _ = + Const (\<^const_name>\c_uninitialized\, dummyT) + | init_expr_const_term _ (C_Ast.CConst0 (C_Ast.CStrConst0 (C_Ast.CString0 (_, _), _))) = + error "micro_c_translate: string literal initializer requires char pointer target" + | init_expr_const_term target_cty expr = + HOLogic.mk_number (C_Ast_Utils.hol_type_of target_cty) + (intinf_to_int_checked "global initializer literal" + (init_scalar_const_value expr)) + fun init_struct_const_term sname init_list = + let + val fields = + (case Symtab.lookup struct_tab sname of + SOME fs => fs + | NONE => error ("micro_c_translate: unknown struct in global initializer: " ^ sname)) + fun find_field_index _ [] _ = + error "micro_c_translate: struct field not found in global initializer" + | find_field_index fname ((n, _) :: rest) i = + if n = fname then i else find_field_index fname rest (i + 1) + fun resolve_field_desig [] pos = pos + | resolve_field_desig [C_Ast.CMemberDesig0 (ident, _)] _ = + find_field_index (C_Ast_Utils.ident_name ident) fields 0 + | resolve_field_desig _ _ = + error "micro_c_translate: complex designator in global struct initializer" + fun collect_field_items [] _ = [] + | collect_field_items ((desigs, init_item) :: rest) pos = + let val idx = resolve_field_desig desigs pos + in (idx, init_item) :: collect_field_items rest (idx + 1) end + val field_items = collect_field_items init_list 0 + val _ = List.app (fn (idx, _) => + if idx < 0 orelse idx >= List.length fields + then error "micro_c_translate: struct designator index out of bounds in global initializer" + else ()) field_items + val base_vals = List.map (fn (_, field_cty) => default_const_term field_cty) fields + val filled = + List.foldl + (fn ((idx, init_item), acc) => + let + val (_, field_cty) = List.nth (fields, idx) + val v = init_value_term field_cty init_item + in + nth_map idx (K v) acc + end) + base_vals + field_items + val make_const = resolve_make_const sname + in + List.foldl (fn (v, acc) => acc $ v) make_const filled + end + and init_value_term target_cty (C_Ast.CInitExpr0 (expr, _)) = + init_expr_const_term target_cty expr + | init_value_term (C_Ast_Utils.CStruct sname) (C_Ast.CInitList0 (init_list, _)) = + init_struct_const_term sname init_list + | init_value_term target_cty (C_Ast.CInitList0 (init_list, _)) = + (* Sub-array initializer: build a list of recursively initialized elements *) + let + val elem_hol_ty = C_Ast_Utils.hol_type_of target_cty + fun collect [] _ = [] + | collect (([], item) :: rest) pos = + (pos, item) :: collect rest (pos + 1) + | collect ((desigs, item) :: rest) _ = + let val idx = + (case desigs of + [C_Ast.CArrDesig0 (C_Ast.CConst0 (C_Ast.CIntConst0 + (C_Ast.CInteger0 (n, _, _), _)), _)] => + intinf_to_int_checked "sub-array designator" n + | _ => error "micro_c_translate: complex designator in nested array initializer") + in (idx, item) :: collect rest (idx + 1) end + val indexed = collect init_list 0 + val arr_size = + List.foldl (fn ((i, _), acc) => Int.max (acc, i + 1)) 0 indexed + val zero = default_const_term target_cty + val base = List.tabulate (arr_size, fn _ => zero) + val filled = List.foldl + (fn ((i, item), acc) => + nth_map i (K (init_value_term target_cty item)) acc) + base indexed + in HOLogic.mk_list elem_hol_ty filled end + | init_value_term _ _ = + error "micro_c_translate: unsupported non-constant global initializer shape" + fun process_decl specs declarators = + if not (has_const_qual specs orelse has_static_storage specs) then [] + else + let + val base_cty = + (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME C_Ast_Utils.CVoid => C_Ast_Utils.CInt + | SOME t => t + | NONE => + (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of + SOME sn => C_Ast_Utils.CStruct sn + | NONE => + (case C_Ast_Utils.extract_union_type_from_specs_full (!C_Translate.current_union_names) specs of + SOME un => C_Ast_Utils.CUnion un + | NONE => C_Ast_Utils.CInt))) + fun process_one ((C_Ast.Some declr, C_Ast.Some (C_Ast.CInitExpr0 (init, _))), _) = + let + val name = C_Ast_Utils.declr_name declr + val ptr_depth = C_Ast_Utils.pointer_depth_of_declr declr + val actual_cty = C_Ast_Utils.apply_ptr_depth base_cty ptr_depth + val init_term = init_expr_const_term actual_cty init + val arr_meta = + (case array_decl_size declr of + SOME n => + if ptr_depth > 0 + then SOME (C_Ast_Utils.apply_ptr_depth base_cty (ptr_depth - 1), n) + else NONE + | NONE => NONE) + in SOME (name, init_term, actual_cty, arr_meta, struct_name_of_cty actual_cty) end + | process_one ((C_Ast.Some declr, C_Ast.Some (C_Ast.CInitList0 (init_list, _))), _) = + let + val name = C_Ast_Utils.declr_name declr + val _ = + if has_array_declr declr then () + else error "micro_c_translate: initializer list for non-array global declaration" + val ptr_depth = C_Ast_Utils.pointer_depth_of_declr declr + val actual_cty = C_Ast_Utils.apply_ptr_depth base_cty ptr_depth + val elem_cty = + if ptr_depth > 0 then C_Ast_Utils.apply_ptr_depth base_cty (ptr_depth - 1) else base_cty + fun expand_desig [] pos init_item = [(pos, init_item)] + | expand_desig [C_Ast.CArrDesig0 (C_Ast.CConst0 (C_Ast.CIntConst0 (C_Ast.CInteger0 (n, _, _), _)), _)] _ init_item = + [(intinf_to_int_checked "global array designator" n, init_item)] + | expand_desig [C_Ast.CRangeDesig0 ( + C_Ast.CConst0 (C_Ast.CIntConst0 (C_Ast.CInteger0 (lo_n, _, _), _)), + C_Ast.CConst0 (C_Ast.CIntConst0 (C_Ast.CInteger0 (hi_n, _, _), _)), _)] _ init_item = + let val lo = intinf_to_int_checked "range designator lo" lo_n + val hi = intinf_to_int_checked "range designator hi" hi_n + in List.tabulate (hi - lo + 1, fn i => (lo + i, init_item)) end + | expand_desig _ _ _ = + error "micro_c_translate: complex designator in global array initializer" + fun collect_indices [] _ = [] + | collect_indices ((desigs, init_item) :: rest) pos = + let val items = expand_desig desigs pos init_item + val next_pos = #1 (List.last items) + 1 + in items @ collect_indices rest next_pos end + val indexed_items = collect_indices init_list 0 + val declared_size = array_decl_size declr + val arr_size = + case declared_size of + SOME n => n + | NONE => + List.foldl (fn ((idx, _), acc) => Int.max (acc, idx + 1)) 0 indexed_items + val _ = List.app (fn (idx, _) => + if idx < 0 orelse idx >= arr_size + then error ("micro_c_translate: designator index " ^ + Int.toString idx ^ " out of bounds for global array of size " ^ + Int.toString arr_size) + else ()) indexed_items + val zero_value = default_const_term elem_cty + val base_values = List.tabulate (arr_size, fn _ => zero_value) + val filled_values = + List.foldl + (fn ((idx, init_item), acc) => + nth_map idx (K (init_value_term elem_cty init_item)) acc) + base_values + indexed_items + val list_term = HOLogic.mk_list (C_Ast_Utils.hol_type_of elem_cty) filled_values + val arr_meta = + SOME (elem_cty, arr_size) + in SOME (name, list_term, actual_cty, arr_meta, struct_name_of_cty actual_cty) end + | process_one ((C_Ast.Some _, C_Ast.None), _) = NONE + | process_one _ = + error "micro_c_translate: unsupported global declarator" + in List.mapPartial process_one declarators end + fun resolve_decl_type_early (C_Ast.CDecl0 (specs, _, _)) = + C_Ast_Utils.resolve_c_type_full typedef_tab specs + | resolve_decl_type_early _ = NONE + fun check_static_assert expr msg_lit = + let val v = C_Ast_Utils.eval_const_int_expr resolve_decl_type_early expr + in if v = 0 then + error ("micro_c_translate: _Static_assert failed: " ^ + C_Ast_Utils.extract_string_literal msg_lit) + else () + end + fun from_ext_decl (C_Ast.CDeclExt0 (C_Ast.CDecl0 (specs, declarators, _))) = + process_decl specs declarators + | from_ext_decl (C_Ast.CDeclExt0 (C_Ast.CStaticAssert0 (expr, msg_lit, _))) = + (check_static_assert expr msg_lit; []) + | from_ext_decl _ = [] + in + List.concat (List.map from_ext_decl ext_decls) + end + + (* Phase 1: Reset mutable translation state and read configuration refs. *) + fun setup_translation_state () = + let + val _ = C_Translate.defined_func_consts := Symtab.empty + val _ = C_Translate.defined_func_fuels := Symtab.empty + val _ = C_Translate.current_list_backed_param_modes := Symtab.empty + val _ = C_Translate.current_struct_array_fields := Symtab.empty + val decl_prefix = !current_decl_prefix + val abi_profile = !current_abi_profile + val manifest = !current_manifest + val _ = C_Ast_Utils.set_abi_profile abi_profile + val _ = C_Translate.set_decl_prefix decl_prefix + val _ = C_Translate.set_ref_universe_types (!current_ref_addr_ty) (!current_ref_gv_ty) + in (decl_prefix, abi_profile, manifest) end + + (* Phase 2: Extract struct, union, enum, and typedef definitions from the + translation unit. Returns all type-level tables needed by later phases. *) + fun extract_type_definitions decl_prefix keep_type tu = + let + val builtin_typedefs = C_Ast_Utils.builtin_typedefs () + (* Use fold/update to allow user typedefs to override builtins. *) + val typedef_defs_early = + builtin_typedefs @ C_Ast_Utils.extract_typedefs tu + val typedef_tab_early = List.foldl (fn ((n, v), tab) => Symtab.update (n, v) tab) + Symtab.empty typedef_defs_early + val struct_defs = + List.filter (fn (n, _) => keep_type n) + (C_Ast_Utils.extract_struct_defs_with_types typedef_tab_early tu) + val parametric_struct_names = + C_Ast_Utils.derive_parametric_struct_names struct_defs + val _ = C_Ast_Utils.set_ref_universe_types (!current_ref_addr_ty) (!current_ref_gv_ty) + val _ = C_Ast_Utils.set_parametric_struct_names parametric_struct_names + val struct_record_defs = + List.filter (fn (n, _) => keep_type n) + (C_Ast_Utils.extract_struct_record_defs decl_prefix typedef_tab_early tu) + val struct_array_field_tab = + Symtab.make (List.filter (fn (n, _) => keep_type n) (C_Ast_Utils.extract_struct_array_fields tu)) + val _ = C_Translate.current_struct_array_fields := struct_array_field_tab + val union_defs = + List.filter (fn (n, _) => keep_type n) + (C_Ast_Utils.extract_union_defs_with_types typedef_tab_early tu) + val union_names = List.map #1 union_defs + val _ = C_Translate.set_union_names union_names + val struct_tab = List.foldl (fn ((n, v), tab) => Symtab.update (n, v) tab) + (Symtab.make struct_defs) union_defs + val _ = List.app (fn (sname, fields) => + writeln ("Registered struct: " ^ sname ^ " with fields: " ^ + String.concatWith ", " (List.map #1 fields))) struct_defs + val _ = List.app (fn (uname, fields) => + writeln ("Registered union: " ^ uname ^ " with fields: " ^ + String.concatWith ", " (List.map #1 fields))) union_defs + val enum_defs = List.filter (fn (n, _) => keep_type n) (C_Ast_Utils.extract_enum_defs tu) + val enum_tab = Symtab.make enum_defs + val _ = if null enum_defs then () else + List.app (fn (name, value) => + writeln ("Registered enum constant: " ^ name ^ " = " ^ + Int.toString value)) enum_defs + val typedef_defs = + builtin_typedefs @ C_Ast_Utils.extract_typedefs tu + val typedef_tab = List.foldl (fn ((n, v), tab) => Symtab.update (n, v) tab) + Symtab.empty typedef_defs + val _ = if null typedef_defs then () else + List.app (fn (name, _) => + writeln ("Registered typedef: " ^ name)) typedef_defs + (* Check _Static_assert declarations at top level *) + val C_Ast.CTranslUnit0 (all_ext_decls, _) = tu + fun resolve_decl_type_sa (C_Ast.CDecl0 (specs, _, _)) = + C_Ast_Utils.resolve_c_type_full typedef_tab specs + | resolve_decl_type_sa _ = NONE + val _ = List.app + (fn C_Ast.CDeclExt0 (C_Ast.CStaticAssert0 (expr, msg_lit, _)) => + let val v = C_Ast_Utils.eval_const_int_expr resolve_decl_type_sa expr + in if v = 0 then + error ("micro_c_translate: _Static_assert failed: " ^ + C_Ast_Utils.extract_string_literal msg_lit) + else () + end + | _ => ()) all_ext_decls + in + { struct_tab = struct_tab, union_names = union_names, + struct_record_defs = struct_record_defs, + struct_array_field_tab = struct_array_field_tab, + enum_tab = enum_tab, typedef_tab = typedef_tab } + end + + (* Phase 3: Extract function definitions, compute signatures, topologically + sort by call dependencies, and identify pure functions. *) + fun extract_and_order_functions keep_func typedef_tab tu = + let + val fundefs_raw = + List.filter + (fn C_Ast.CFunDef0 (_, declr, _, _, _) => keep_func (C_Ast_Utils.declr_name declr)) + (C_Ast_Utils.extract_fundefs tu) + fun param_cty_of_decl pdecl = + (case pdecl of + C_Ast.CDecl0 (specs, _, _) => + let + val base = (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME t => t + | NONE => C_Ast_Utils.CInt) + val depth = C_Ast_Utils.pointer_depth_of_decl pdecl + in C_Ast_Utils.apply_ptr_depth base depth end + | _ => C_Ast_Utils.CInt) + fun signature_of_declr specs declr = + let val fname = C_Ast_Utils.declr_name declr + val _ = + if C_Ast_Utils.declr_is_variadic declr then + error ("micro_c_translate: unsupported C construct: variadic function declaration: " ^ fname) + else () + val rty_base = (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME C_Ast_Utils.CVoid => C_Ast_Utils.CVoid + | SOME t => t | NONE => C_Ast_Utils.CInt) + val rty = C_Ast_Utils.apply_ptr_depth rty_base + (C_Ast_Utils.pointer_depth_of_declr declr) + val ptys = List.map param_cty_of_decl (C_Ast_Utils.extract_param_decls declr) + in (fname, (rty, ptys)) end + fun declr_is_function (C_Ast.CDeclr0 (_, derived, _, _, _)) = + List.exists (fn C_Ast.CFunDeclr0 _ => true | _ => false) derived + fun signatures_from_ext_decl (C_Ast.CDeclExt0 (C_Ast.CDecl0 (specs, declarators, _))) = + List.mapPartial + (fn ((C_Ast.Some declr, _), _) => + if declr_is_function declr andalso keep_func (C_Ast_Utils.declr_name declr) + then SOME (signature_of_declr specs declr) else NONE + | _ => NONE) + declarators + | signatures_from_ext_decl _ = [] + val C_Ast.CTranslUnit0 (ext_decls, _) = tu + fun fundef_signature (C_Ast.CFunDef0 (specs, declr, _, _, _)) = + signature_of_declr specs declr + val decl_signatures = List.concat (List.map signatures_from_ext_decl ext_decls) + fun fundef_name (C_Ast.CFunDef0 (_, declr, _, _, _)) = C_Ast_Utils.declr_name declr + val fun_names = List.map fundef_name fundefs_raw + val fun_name_tab = Symtab.make (List.map (fn n => (n, ())) fun_names) + val dep_tab = + List.foldl + (fn (fdef, tab) => + let + val name = fundef_name fdef + val deps = + List.filter (fn n => n <> name andalso Symtab.defined fun_name_tab n) + (C_Ast_Utils.find_called_functions fdef) + in + Symtab.update (name, deps) tab + end) + Symtab.empty fundefs_raw + val fundef_tab = Symtab.make (List.map (fn fdef => (fundef_name fdef, fdef)) fundefs_raw) + val decl_order_names = distinct (op =) (List.map #1 decl_signatures) + val preferred_names = + decl_order_names @ + List.filter (fn n => not (List.exists (fn m => m = n) decl_order_names)) fun_names + val has_cycle = Unsynchronized.ref false + fun visit stack seen order name = + if Symtab.defined seen name then (seen, order) + else if List.exists (fn n => n = name) stack then + (has_cycle := true; (seen, order)) + else + let + val deps = the_default [] (Symtab.lookup dep_tab name) + val (seen', order') = + List.foldl (fn (d, (s, ord)) => visit (name :: stack) s ord d) (seen, order) deps + val seen'' = Symtab.update (name, ()) seen' + in + (seen'', order' @ [name]) + end + val (_, topo_names) = + List.foldl (fn (n, (s, ord)) => visit [] s ord n) (Symtab.empty, []) preferred_names + val _ = + if !has_cycle then + writeln "micro_c_translate: recursion cycle detected; using deterministic SCC fallback order" + else () + val fundefs = List.mapPartial (fn n => Symtab.lookup fundef_tab n) topo_names + val _ = List.app (fn C_Ast.CFunDef0 (_, declr, _, _, _) => + let val name = C_Ast_Utils.declr_name declr + in if C_Ast_Utils.declr_is_variadic declr then + error ("micro_c_translate: unsupported C construct: variadic function definition: " ^ name) + else () + end) fundefs + fun refine_pure_functions pure_tab = + let + val pure_tab' = + List.foldl + (fn (fdef, tab) => + let val name = fundef_name fdef + in + if C_Ast_Utils.fundef_is_pure_with pure_tab fdef then + Symtab.update (name, ()) tab + else tab + end) + Symtab.empty fundefs_raw + in + if Symtab.dest pure_tab' = Symtab.dest pure_tab then pure_tab + else refine_pure_functions pure_tab' + end + val pure_fun_tab = refine_pure_functions fun_name_tab + val _ = C_Ast_Utils.set_pure_function_names (Symtab.keys pure_fun_tab) + val signatures = decl_signatures @ List.map fundef_signature fundefs + val func_ret_table = List.foldl + (fn ((n, (rty, _)), tab) => Symtab.update (n, rty) tab) + Symtab.empty signatures + val func_ret_types = Unsynchronized.ref func_ret_table + val func_param_table = List.foldl + (fn ((n, (_, ptys)), tab) => Symtab.update (n, ptys) tab) + Symtab.empty signatures + val func_param_types = Unsynchronized.ref func_param_table + in + { fundefs = fundefs, fundefs_raw = fundefs_raw, + param_cty_of_decl = param_cty_of_decl, + func_ret_types = func_ret_types, + func_param_types = func_param_types } + end + + (* Phase 4: Determine which pointer parameters are list-backed (passed as + arrays at all call sites). Updates the global list_backed_param_modes ref. *) + fun analyze_list_backed_params struct_tab struct_array_field_tab union_names + param_cty_of_decl fundefs_raw = + let + val all_struct_names = Symtab.keys struct_tab + fun has_static_storage specs = + List.exists (fn C_Ast.CStorageSpec0 (C_Ast.CStatic0 _) => true | _ => false) specs + fun param_declr_of_decl (C_Ast.CDecl0 (_, declarators, _)) = + (case declarators of + ((C_Ast.Some declr, _), _) :: _ => SOME declr + | _ => NONE) + | param_declr_of_decl _ = NONE + fun param_decl_has_array pdecl = + (case param_declr_of_decl pdecl of + SOME (C_Ast.CDeclr0 (_, derived, _, _, _)) => + List.exists (fn C_Ast.CArrDeclr0 _ => true | _ => false) derived + | NONE => false) + fun fundef_name (C_Ast.CFunDef0 (_, declr, _, _, _)) = C_Ast_Utils.declr_name declr + val list_backed_alias_envs = + List.foldl + (fn (fdef, tab) => + Symtab.update (fundef_name fdef, C_Ast_Utils.find_list_backed_aliases struct_tab struct_array_field_tab fdef) tab) + Symtab.empty fundefs_raw + val caller_struct_envs = + List.foldl + (fn (C_Ast.CFunDef0 (_, declr, _, _, _), tab) => + let + val fname = C_Ast_Utils.declr_name declr + val pdecls = C_Ast_Utils.extract_param_decls declr + val struct_env = + List.foldl + (fn (pdecl, env) => + case (param_declr_of_decl pdecl, + C_Ast_Utils.extract_struct_type_from_decl_full all_struct_names pdecl) of + (SOME pdeclr, SOME sname) => + Symtab.update (C_Ast_Utils.declr_name pdeclr, sname) env + | _ => + (case (param_declr_of_decl pdecl, + C_Ast_Utils.extract_union_type_from_decl_full union_names pdecl) of + (SOME pdeclr, SOME uname) => + Symtab.update (C_Ast_Utils.declr_name pdeclr, uname) env + | _ => env)) + Symtab.empty pdecls + in + Symtab.update (fname, struct_env) tab + end) + Symtab.empty fundefs_raw + val call_sites = + List.concat + (List.map + (fn fdef => + let + val caller = fundef_name fdef + val caller_aliases = the_default [] (Symtab.lookup list_backed_alias_envs caller) + val caller_struct_env = the_default Symtab.empty (Symtab.lookup caller_struct_envs caller) + in + List.map (fn (callee, args) => (caller_aliases, caller_struct_env, callee, args)) + (C_Ast_Utils.find_named_calls_with_args fdef) + end) + fundefs_raw) + fun arg_is_list_backed caller_aliases caller_struct_env arg = + (case arg of + C_Ast.CVar0 (ident, _) => + List.exists (fn n => n = C_Ast_Utils.ident_name ident) caller_aliases + | C_Ast.CMember0 (base, field_ident, _, _) => + let + fun expr_struct_name (C_Ast.CVar0 (ident, _)) = + Symtab.lookup caller_struct_env (C_Ast_Utils.ident_name ident) + | expr_struct_name (C_Ast.CCast0 (_, e, _)) = expr_struct_name e + | expr_struct_name _ = NONE + in + (case expr_struct_name base of + SOME struct_name => + List.exists (fn fname => fname = C_Ast_Utils.ident_name field_ident) + (the_default [] (Symtab.lookup struct_array_field_tab struct_name)) + | NONE => false) + end + | _ => false) + val list_backed_param_modes = + List.foldl + (fn (fdef as C_Ast.CFunDef0 (specs, declr, _, _, _), tab) => + let + val fname = fundef_name fdef + val indexed_names = C_Ast_Utils.find_indexed_base_vars fdef + val pdecls = C_Ast_Utils.extract_param_decls declr + fun mode_for_param (i, pdecl) = + let + val pname = the_default "" (C_Ast_Utils.param_name pdecl) + val p_cty = param_cty_of_decl pdecl + val relevant_calls = + List.filter (fn (_, _, callee, args) => callee = fname andalso i < List.length args) call_sites + in + if param_decl_has_array pdecl then true + else if not (C_Ast_Utils.is_ptr p_cty) then false + else if not (has_static_storage specs) then false + else if not (List.exists (fn n => n = pname) indexed_names) then false + else not (null relevant_calls) andalso + List.all (fn (caller_aliases, caller_struct_env, _, args) => + arg_is_list_backed caller_aliases caller_struct_env (List.nth (args, i))) relevant_calls + end + val modes = map_index mode_for_param pdecls + in + Symtab.update (fname, modes) tab + end) + Symtab.empty fundefs_raw + in + C_Translate.current_list_backed_param_modes := list_backed_param_modes + end + + (* Orchestrator: runs phases 1-4 then generates definitions. *) + fun process_translation_unit tu lthy = + let + (* Phase 1: Setup *) + val (decl_prefix, abi_profile, manifest) = setup_translation_state () + val {functions = manifest_functions, types = manifest_types} = manifest + fun mk_name_filter NONE = NONE + | mk_name_filter (SOME xs) = + SOME (List.foldl (fn (x, tab) => Symtab.update (x, ()) tab) Symtab.empty xs) + val func_filter = mk_name_filter manifest_functions + val type_filter = mk_name_filter manifest_types + fun keep_func name = + (case func_filter of NONE => true | SOME tab => Symtab.defined tab name) + fun keep_type name = + (case type_filter of NONE => true | SOME tab => Symtab.defined tab name) + + (* Phase 2: Type extraction *) + val { struct_tab, union_names, struct_record_defs, + struct_array_field_tab, enum_tab, typedef_tab } = + extract_type_definitions decl_prefix keep_type tu + + (* Phase 3: Function extraction and ordering *) + val { fundefs, fundefs_raw, param_cty_of_decl, + func_ret_types, func_param_types } = + extract_and_order_functions keep_func typedef_tab tu + + (* Phase 4: List-backed parameter analysis *) + val _ = analyze_list_backed_params struct_tab struct_array_field_tab + union_names param_cty_of_decl fundefs_raw + + (* Phase 5: Generate type and global definitions *) + val lthy = + List.foldl (fn (sdef, lthy_acc) => ensure_struct_record decl_prefix sdef lthy_acc) + lthy struct_record_defs + val global_const_inits = + extract_global_consts typedef_tab struct_tab enum_tab (Local_Theory.target_of lthy) tu + val (lthy, global_consts) = + List.foldl (fn ((gname, init_term, gcty, garr_meta, gstruct), (lthy_acc, acc)) => + let + val lthy' = define_c_global_value decl_prefix gname init_term lthy_acc + val ctxt' = Local_Theory.target_of lthy' + val (full_name, _) = + Term.dest_Const + (Proof_Context.read_const {proper = true, strict = false} ctxt' + (decl_prefix ^ "global_" ^ gname)) + val gterm = Const (full_name, dummyT) + in + (lthy', acc @ [(gname, gterm, gcty, garr_meta, gstruct)]) + end) + (lthy, []) global_const_inits + val lthy = + (* Define ABI metadata after type-generation commands (e.g. datatype_record) + so locale-target equations from these definitions cannot interfere with + datatype package obligations. *) + define_abi_metadata decl_prefix abi_profile lthy + in + (* Phase 6: Translate and define each function one at a time, so that later + functions can reference earlier ones via Syntax.check_term. *) + List.foldl (fn (fundef, lthy) => + let val (name, term) = C_Translate.translate_fundef + struct_tab enum_tab typedef_tab func_ret_types func_param_types global_consts lthy fundef + in define_c_function decl_prefix name term lthy end) lthy fundefs + end +end +\ + +text \ + Global translation lock: the ML translation pipeline uses unsynchronized + mutable refs for threading state through structures. When Isabelle processes + multiple theories that each contain @{text "micro_c_translate"} or + @{text "micro_c_file"} commands in parallel, concurrent executions can + clobber each other's global state, producing spurious failures such as + "missing struct field accessor constant". We serialize all translation + invocations through a single mutex to prevent this. +\ + +ML \ +val micro_c_translation_lock : unit Synchronized.var = + Synchronized.var "micro_c_translation_lock" () + +fun with_micro_c_lock (f : unit -> 'a) : 'a = + Synchronized.change_result micro_c_translation_lock (fn () => (f (), ())) +\ + +subsection \The \micro_c_translate\ Command\ + +text \ + The command parses inline C source via Isabelle/C's parser (reusing the + existing infrastructure including the @{text "Root_Ast_Store"}) and + generates @{command definition} commands for each function found. + + Usage: + @{text [display] "micro_c_translate \void f() { return; }\"} + @{text [display] "micro_c_translate prefix: my_ \void f() { return; }\"} + @{text [display] "micro_c_translate abi: lp64-le \void f() { return; }\"} + @{text [display] "micro_c_translate addr: 'addr gv: 'gv \void f() { return; }\"} + + Notes: + \<^item> Option keywords are exactly @{text "prefix:"}, @{text "addr:"}, @{text "gv:"}, and @{text "abi:"}. + \<^item> Currently supported @{text "abi:"} values are @{text "lp64-le"}, @{text "ilp32-le"}, and @{text "lp64-be"}. + \<^item> When omitted, declaration prefix defaults to @{text "c_"}. + \<^item> When omitted, @{text "abi:"} defaults to @{text "lp64-le"}. + \<^item> When omitted, @{text "addr:"} and @{text "gv:"} default to @{text "'addr"} and @{text "'gv"}. + \<^item> Each translation unit also defines ABI metadata constants + @{text "abi_pointer_bits"}, @{text "abi_long_bits"}, + @{text "abi_char_is_signed"}, and @{text "abi_big_endian"}. + \<^item> Struct declarations in the input are translated to corresponding + @{command "datatype_record"} declarations automatically when possible. +\ + +ML \ + datatype translate_opt = + TranslatePrefix of string + | TranslateAddrTy of string + | TranslateGvTy of string + | TranslateAbi of string + | TranslatePtrAdd of string + | TranslatePtrShiftSigned of string + | TranslatePtrDiff of string + | TranslateCompiler of string + | TranslateVerbose + val parse_abi_ident = Scan.one (Token.ident_with (K true)) >> Token.content_of + val parse_abi_dash = + Scan.one (fn tok => Token.is_kind Token.Sym_Ident tok andalso Token.content_of tok = "-") >> K () + val parse_abi_name = + parse_abi_ident -- Scan.repeat (parse_abi_dash |-- parse_abi_ident) + >> (fn (h, t) => String.concatWith "-" (h :: t)) + val parse_prefix_key = Parse.$$$ "prefix:" >> K () + val parse_addr_key = Parse.$$$ "addr:" >> K () + val parse_gv_key = Parse.$$$ "gv:" >> K () + val parse_abi_key = Parse.$$$ "abi:" >> K () + val parse_ptr_add_key = Parse.$$$ "ptr_add:" >> K () + val parse_ptr_shift_signed_key = Parse.$$$ "ptr_shift_signed:" >> K () + val parse_ptr_diff_key = Parse.$$$ "ptr_diff:" >> K () + val parse_compiler_key = Parse.$$$ "compiler:" >> K () + val parse_translate_opt = + (parse_prefix_key |-- Parse.name >> TranslatePrefix) + || (parse_addr_key |-- Parse.typ >> TranslateAddrTy) + || (parse_gv_key |-- Parse.typ >> TranslateGvTy) + || (parse_abi_key |-- parse_abi_name >> TranslateAbi) + || (parse_ptr_add_key |-- Parse.name >> TranslatePtrAdd) + || (parse_ptr_shift_signed_key |-- Parse.name >> TranslatePtrShiftSigned) + || (parse_ptr_diff_key |-- Parse.name >> TranslatePtrDiff) + || (parse_compiler_key |-- parse_abi_name >> TranslateCompiler) + || (Parse.$$$ "verbose" >> K TranslateVerbose) + + type translate_opts = { + prefix: string option, addr: string option, gv: string option, + abi: string option, + ptr_add: string option, ptr_shift_signed: string option, ptr_diff: string option, + compiler: string option, + verbose: bool + } + + val empty_opts : translate_opts = { + prefix = NONE, addr = NONE, gv = NONE, abi = NONE, + ptr_add = NONE, ptr_shift_signed = NONE, ptr_diff = NONE, compiler = NONE, + verbose = false + } + + fun set_once _ NONE v = SOME v + | set_once name (SOME _) _ = error ("micro_c_translate: duplicate " ^ name ^ " option") + + fun apply_translate_opt (TranslatePrefix v) (r : translate_opts) = + {prefix = set_once "prefix" (#prefix r) v, addr = #addr r, gv = #gv r, abi = #abi r, + ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler r, verbose = #verbose r} + | apply_translate_opt (TranslateAddrTy v) (r : translate_opts) = + {prefix = #prefix r, addr = set_once "addr" (#addr r) v, gv = #gv r, abi = #abi r, + ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler r, verbose = #verbose r} + | apply_translate_opt (TranslateGvTy v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = set_once "gv" (#gv r) v, abi = #abi r, + ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler r, verbose = #verbose r} + | apply_translate_opt (TranslateAbi v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = set_once "abi" (#abi r) v, + ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler r, verbose = #verbose r} + | apply_translate_opt (TranslatePtrAdd v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + ptr_add = set_once "ptr_add" (#ptr_add r) v, + ptr_shift_signed = #ptr_shift_signed r, ptr_diff = #ptr_diff r, + compiler = #compiler r, verbose = #verbose r} + | apply_translate_opt (TranslatePtrShiftSigned v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + ptr_add = #ptr_add r, + ptr_shift_signed = set_once "ptr_shift_signed" (#ptr_shift_signed r) v, + ptr_diff = #ptr_diff r, compiler = #compiler r, verbose = #verbose r} + | apply_translate_opt (TranslatePtrDiff v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = set_once "ptr_diff" (#ptr_diff r) v, + compiler = #compiler r, verbose = #verbose r} + | apply_translate_opt (TranslateCompiler v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = set_once "compiler" (#compiler r) v, + verbose = #verbose r} + | apply_translate_opt TranslateVerbose (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler r, verbose = true} + + fun collect_translate_opts opts = + fold apply_translate_opt opts empty_opts + + (* Shared setup: resolve options against the local theory context and + configure global translation state. Manifest is set by the caller. *) + fun setup_translation_context cmd_name (opts : translate_opts) lthy = + let + val prefix = the_default "c_" (#prefix opts) + val abi_profile = C_ABI.parse_profile (the_default "lp64-le" (#abi opts)) + val compiler_profile = + (case #compiler opts of + SOME name => C_Compiler.parse_compiler name + | NONE => C_Compiler.default_profile) + val addr_ty = Syntax.read_typ lthy (the_default "'addr" (#addr opts)) + val gv_ty = Syntax.read_typ lthy (the_default "'gv" (#gv opts)) + fun require_visible_const_name name = + (case try (Syntax.check_term lthy) (Free (name, dummyT)) of + SOME _ => name + | NONE => error (cmd_name ^ ": missing required pointer-model constant: " ^ name)) + val pointer_model = + { ptr_add = SOME (require_visible_const_name (the_default "c_ptr_add" (#ptr_add opts))) + , ptr_shift_signed = SOME (require_visible_const_name (the_default "c_ptr_shift_signed" (#ptr_shift_signed opts))) + , ptr_diff = SOME (require_visible_const_name (the_default "c_ptr_diff" (#ptr_diff opts))) + } + val expr_constraint = + let + val ref_args = + (case try (Syntax.check_term lthy) (Free ("reference_types", dummyT)) of + SOME (Free (_, ref_ty)) => + C_Translate.strip_isa_fun_type ref_ty + | _ => []) + val (state_ty, abort_ty, prompt_in_ty, prompt_out_ty) = + (case ref_args of + [s, _, _, a, pi, po] => (s, a, pi, po) + | _ => (dummyT, @{typ c_abort}, dummyT, dummyT)) + in + SOME (Type (\<^type_name>\expression\, + [state_ty, dummyT, dummyT, abort_ty, prompt_in_ty, prompt_out_ty])) + end + + val _ = C_Def_Gen.set_decl_prefix prefix + val _ = C_Def_Gen.set_abi_profile abi_profile + val _ = C_Compiler.set_compiler_profile compiler_profile + val _ = C_Def_Gen.set_ref_universe_types addr_ty gv_ty + val _ = C_Def_Gen.set_ref_abort_type expr_constraint + val _ = C_Def_Gen.set_pointer_model pointer_model + val _ = C_Def_Gen.set_verbose (#verbose opts) + in () end + +val _ = + Outer_Syntax.local_theory \<^command_keyword>\micro_c_translate\ + "parse C source and generate core monad definitions" + (Scan.repeat parse_translate_opt -- Parse.embedded_input -- Scan.repeat parse_translate_opt >> + (fn ((opts_pre, source), opts_post) => fn lthy => + with_micro_c_lock (fn () => + let + val opts = collect_translate_opts (opts_pre @ opts_post) + val _ = setup_translation_context "micro_c_translate" opts lthy + val _ = C_Def_Gen.set_manifest {functions = NONE, types = NONE} + val thy = Proof_Context.theory_of lthy + val context' = C_Module.exec_eval source (Context.Theory thy) + val thy' = Context.theory_of context' + val tu = get_CTranslUnit thy' + in + C_Def_Gen.process_translation_unit tu lthy + end))) +\ + +text \ + The @{text "micro_c_file"} command loads C source from an external file, + parses it using Isabelle/C, and generates core monad definitions. + This enables keeping verified C code in separate @{text ".c"} files, + identical to upstream sources. + + Usage: + @{text [display] "micro_c_file \path/to/file.c\"} + @{text [display] "micro_c_file prefix: my_ \path/to/file.c\"} + @{text [display] "micro_c_file prefix: my_ manifest: \path/to/manifest.txt\ \path/to/file.c\"} + @{text [display] "micro_c_file \path/to/file.c\ prefix: my_"} + @{text [display] "micro_c_file \path/to/file.c\ manifest: \path/to/manifest.txt\"} + @{text [display] "micro_c_file abi: ilp32-le \path/to/file.c\"} + @{text [display] "micro_c_file addr: 'addr gv: 'gv \path/to/file.c\"} + + Manifest format (plain text): + @{text [display] "functions:"} + @{text [display] " foo"} + @{text [display] " - bar"} + @{text [display] "types:"} + @{text [display] " my_struct"} + @{text [display] " my_enum"} + + Notes: + \<^item> Option keywords are exactly @{text "prefix:"}, @{text "addr:"}, @{text "gv:"}, @{text "abi:"}, and @{text "manifest:"}. + \<^item> Currently supported @{text "abi:"} values are @{text "lp64-le"}, @{text "ilp32-le"}, and @{text "lp64-be"}. + \<^item> Options may appear before and/or after the C file argument. + \<^item> Each option may appear at most once. + \<^item> When omitted, declaration prefix defaults to @{text "c_"}. + \<^item> When omitted, @{text "abi:"} defaults to @{text "lp64-le"}. + \<^item> When omitted, @{text "addr:"} and @{text "gv:"} default to @{text "'addr"} and @{text "'gv"}. + \<^item> Each translation unit also defines ABI metadata constants + @{text "abi_pointer_bits"}, @{text "abi_long_bits"}, + @{text "abi_char_is_signed"}, and @{text "abi_big_endian"}. + \<^item> Sections are optional; supported section headers are exactly @{text "functions:"} and @{text "types:"}. + \<^item> Lines outside a section are rejected. + \<^item> Leading/trailing whitespace is ignored. + \<^item> A leading @{text "-"} on an entry is optional and ignored. + \<^item> @{text "#"} starts a line comment. + \<^item> Struct declarations in the input are translated to corresponding + @{command "datatype_record"} declarations automatically when possible. +\ + +ML \ +local + datatype manifest_section = Manifest_None | Manifest_Functions | Manifest_Types + datatype load_opt = CommonOpt of translate_opt | ManifestOpt of (theory -> Token.file) + val parse_manifest_key = Parse.$$$ "manifest:" >> K () + val parse_load_opt = + (parse_translate_opt >> CommonOpt) || (parse_manifest_key |-- Resources.parse_file >> ManifestOpt) + val semi = Scan.option \<^keyword>\;\; + + fun trim s = Symbol.trim_blanks s + + fun drop_comment line = + (case String.fields (fn c => c = #"#") line of + [] => "" + | x :: _ => x) + + fun parse_manifest_text text = + let + fun add_name sec raw (fs, ts) = + let val name0 = trim raw + val name = if String.isPrefix "-" name0 then trim (String.extract (name0, 1, NONE)) else name0 + in + if name = "" then (fs, ts) + else + (case sec of + Manifest_Functions => (name :: fs, ts) + | Manifest_Types => (fs, name :: ts) + | Manifest_None => + error ("micro_c_file: manifest entry outside section (functions:/types:): " ^ raw)) + end + + fun step (raw, (sec, fs, ts)) = + let val line = trim (drop_comment raw) + in + if line = "" then (sec, fs, ts) + else if line = "functions:" then (Manifest_Functions, fs, ts) + else if line = "types:" then (Manifest_Types, fs, ts) + else + let val (fs', ts') = add_name sec line (fs, ts) + in (sec, fs', ts') end + end + + val (_, rev_fs, rev_ts) = + List.foldl step (Manifest_None, [], []) (String.tokens (fn c => c = #"\n" orelse c = #"\r") text) + val fs = rev rev_fs + val ts = rev rev_ts + in + { functions = if null fs then NONE else SOME fs + , types = if null ts then NONE else SOME ts } + end + + fun collect_load_opts opts = + let + fun step (CommonOpt topt) (topts, mopt) = (topt :: topts, mopt) + | step (ManifestOpt _) (_, SOME _) = error "micro_c_file: duplicate manifest option" + | step (ManifestOpt f) (topts, NONE) = (topts, SOME f) + val (rev_topts, manifest_opt) = fold step opts ([], NONE) + in (collect_translate_opts (rev rev_topts), manifest_opt) end + + (* Register a source file dependency, tolerating duplicate registrations + (e.g. the same C file loaded with different manifests). *) + fun provide_source_file (src_path, digest) lthy = + Local_Theory.background_theory + (fn thy => Resources.provide (src_path, digest) thy + handle ERROR msg => + if String.isSubstring "Duplicate use of source file" msg + then thy + else error msg) lthy +in +val _ = + Outer_Syntax.local_theory \<^command_keyword>\micro_c_file\ + "load C file and generate core monad definitions" + (Scan.repeat parse_load_opt -- Resources.parse_file -- Scan.repeat parse_load_opt --| semi >> + (fn ((opts_pre, get_file), opts_post) => fn lthy => + with_micro_c_lock (fn () => + let + val (opts, manifest_get_file) = collect_load_opts (opts_pre @ opts_post) + val _ = setup_translation_context "micro_c_file" opts lthy + val thy = Proof_Context.theory_of lthy + val {src_path, lines, digest, pos} : Token.file = get_file thy + + (* Step 1: Parse the C file using Isabelle/C's parser *) + val source = Input.source true (cat_lines lines) (pos, pos) + val context' = C_Module.exec_eval source (Context.Theory thy) + val thy' = Context.theory_of context' + + (* Step 2: Register file dependency so Isabelle rebuilds if file changes. *) + val lthy = provide_source_file (src_path, digest) lthy + + (* Optional manifest file controlling which functions/types are extracted. *) + val (manifest, lthy) = + (case manifest_get_file of + NONE => ({functions = NONE, types = NONE}, lthy) + | SOME get_manifest_file => + let + val {src_path = m_src, lines = m_lines, digest = m_digest, ...} : Token.file = + get_manifest_file thy + val lthy' = provide_source_file (m_src, m_digest) lthy + in + (parse_manifest_text (cat_lines m_lines), lthy') + end) + + (* Step 3: Retrieve parsed AST and translate *) + val tu = get_CTranslUnit thy' + val _ = C_Def_Gen.set_manifest manifest + in + C_Def_Gen.process_translation_unit tu lthy + end))) +end +\ + +end diff --git a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy index c8c4aa16..bc979fbf 100644 --- a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy +++ b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy @@ -1,6002 +1,5 @@ theory C_To_Core_Translation - imports - "Isabelle_C.C_Main" - "Shallow_Micro_Rust.Core_Expression" - "Shallow_Micro_Rust.Prompts_And_Responses" - "Shallow_Micro_Rust.Core_Syntax" - "Shallow_Micro_Rust.Bool_Type" - "Shallow_Micro_Rust.Rust_Iterator" - "Shallow_Micro_C.C_Numeric_Types" - "Shallow_Micro_C.C_Sizeof" - "Shallow_Micro_C.C_Memory_Operations" - "Shallow_Micro_C.C_Void_Pointer" - keywords "micro_c_translate" :: thy_decl - and "micro_c_file" :: thy_decl - and "prefix:" and "manifest:" and "addr:" and "gv:" and "abi:" and "abort:" + imports C_Definition_Generation begin - -section \C-to-Core Monad Translation Infrastructure\ - -text \ - This theory defines ML infrastructure for translating Isabelle/C's parsed C11 AST - into AutoCorrode's core monad terms. The pipeline is: - \begin{enumerate} - \item Parse C source via Isabelle/C (reusing the existing @{command "C"} parser) - \item Walk the \C_Ast.cTranslationUnit\ AST - \item Generate Isabelle @{command definition} commands for each C function - \end{enumerate} - - The translation is invoked via the \micro_c_translate\ command, - which takes a C source string and produces definitions in the local theory. -\ - -subsection \ABI Profiles\ - -text \ - Translation currently supports named ABI profiles (rather than arbitrary ABI formulas), - so that type inference and overloaded constants remain stable. The default profile is - @{text "lp64-le"}. - - The ABI option affects translation-time C typing (e.g. long/pointer widths and plain - char signedness). Byte-level endianness in machine models is selected separately via - prism overloading (for example, @{text "c_uint_byte_prism"} vs @{text "c_uint_byte_prism_be"}). -\ - -ML \ -structure C_ABI : sig - datatype profile = LP64_LE | ILP32_LE | LP64_BE - val profile_name : profile -> string - val parse_profile : string -> profile - val long_bits : profile -> int - val pointer_bits : profile -> int - val char_is_signed : profile -> bool -end = -struct - datatype profile = LP64_LE | ILP32_LE | LP64_BE - - fun profile_name LP64_LE = "lp64-le" - | profile_name ILP32_LE = "ilp32-le" - | profile_name LP64_BE = "lp64-be" - - fun parse_profile s = - let - val normalized = - String.map (fn c => if c = #"_" then #"-" else Char.toLower c) s - in - (case normalized of - "lp64-le" => LP64_LE - | "ilp32-le" => ILP32_LE - | "lp64-be" => LP64_BE - | _ => error ("micro_c_translate: unsupported ABI profile: " ^ s ^ - " (supported: lp64-le, ilp32-le, lp64-be)")) - end - - fun long_bits LP64_LE = 64 - | long_bits ILP32_LE = 32 - | long_bits LP64_BE = 64 - - fun pointer_bits LP64_LE = 64 - | pointer_bits ILP32_LE = 32 - | pointer_bits LP64_BE = 64 - - (* Keep current default behavior for plain char in all built-in profiles for now. - This can be split per-profile later if needed. *) - fun char_is_signed _ = false end -\ - -subsection \AST Utilities\ - -text \Helper functions for extracting information from Isabelle/C's AST nodes.\ - -ML \ -structure C_Ast_Utils : sig - datatype c_numeric_type = CInt | CUInt | CChar | CSChar - | CShort | CUShort | CLong | CULong - | CLongLong | CULongLong - | CInt128 | CUInt128 | CBool - | CPtr of c_numeric_type | CVoid - | CStruct of string - | CUnion of string - - val is_signed : c_numeric_type -> bool - val is_bool : c_numeric_type -> bool - val is_ptr : c_numeric_type -> bool - val is_unsigned_int : c_numeric_type -> bool - val set_abi_profile : C_ABI.profile -> unit - val get_abi_profile : unit -> C_ABI.profile - val current_abi_name : unit -> string - val pointer_uint_cty : unit -> c_numeric_type - val pointer_int_cty : unit -> c_numeric_type - val bit_width_of : c_numeric_type -> int option - val sizeof_c_type : c_numeric_type -> int - val alignof_c_type : c_numeric_type -> int - val builtin_typedefs : unit -> (string * c_numeric_type) list - val hol_type_of : c_numeric_type -> typ - val type_name_of : c_numeric_type -> string - val resolve_c_type : C_Ast.nodeInfo C_Ast.cDeclarationSpecifier list -> c_numeric_type option - val decl_type : C_Ast.nodeInfo C_Ast.cDeclaration -> c_numeric_type option - val param_type : C_Ast.nodeInfo C_Ast.cDeclaration -> c_numeric_type option - val is_pointer_param : C_Ast.nodeInfo C_Ast.cDeclaration -> bool - val pointer_depth_of_declr : C_Ast.nodeInfo C_Ast.cDeclarator -> int - val pointer_depth_of_decl : C_Ast.nodeInfo C_Ast.cDeclaration -> int - val apply_ptr_depth : c_numeric_type -> int -> c_numeric_type - val abr_string_to_string : C_Ast.abr_string -> string - val ident_name : C_Ast.ident -> string - val declr_name : C_Ast.nodeInfo C_Ast.cDeclarator -> string - val extract_params : C_Ast.nodeInfo C_Ast.cDeclarator -> string list - val extract_param_decls : C_Ast.nodeInfo C_Ast.cDeclarator - -> C_Ast.nodeInfo C_Ast.cDeclaration list - val declr_is_variadic : C_Ast.nodeInfo C_Ast.cDeclarator -> bool - val param_name : C_Ast.nodeInfo C_Ast.cDeclaration -> string option - val extract_struct_type_from_decl : C_Ast.nodeInfo C_Ast.cDeclaration -> string option - val extract_struct_type_from_decl_full : string list - -> C_Ast.nodeInfo C_Ast.cDeclaration -> string option - val extract_struct_type_from_specs_full : string list - -> C_Ast.nodeInfo C_Ast.cDeclarationSpecifier list - -> string option - val extract_union_type_from_specs : C_Ast.nodeInfo C_Ast.cDeclarationSpecifier list - -> string option - val extract_union_type_from_specs_full : string list - -> C_Ast.nodeInfo C_Ast.cDeclarationSpecifier list - -> string option - val extract_union_type_from_decl_full : string list - -> C_Ast.nodeInfo C_Ast.cDeclaration -> string option - val extract_union_defs_with_types : c_numeric_type Symtab.table - -> C_Ast.nodeInfo C_Ast.cTranslationUnit - -> (string * (string * c_numeric_type) list) list - val extract_struct_defs : C_Ast.nodeInfo C_Ast.cTranslationUnit - -> (string * string list) list - val extract_enum_defs : C_Ast.nodeInfo C_Ast.cTranslationUnit - -> (string * int) list - val extract_typedefs : C_Ast.nodeInfo C_Ast.cTranslationUnit - -> (string * c_numeric_type) list - val resolve_c_type_full : c_numeric_type Symtab.table - -> C_Ast.nodeInfo C_Ast.cDeclarationSpecifier list - -> c_numeric_type option - val int_literal_type : 'a C_Ast.flags -> c_numeric_type - val expr_has_side_effect : C_Ast.nodeInfo C_Ast.cExpression -> bool - val expr_has_unsequenced_ub_risk : - C_Ast.nodeInfo C_Ast.cExpression -> C_Ast.nodeInfo C_Ast.cExpression -> bool - val find_assigned_vars : C_Ast.nodeInfo C_Ast.cStatement -> string list - val find_goto_targets : C_Ast.nodeInfo C_Ast.cStatement -> string list - val find_called_functions : C_Ast.nodeInfo C_Ast.cFunctionDef -> string list - - val extract_struct_defs_with_types : c_numeric_type Symtab.table - -> C_Ast.nodeInfo C_Ast.cTranslationUnit - -> (string * (string * c_numeric_type) list) list - val extract_struct_record_defs : string -> c_numeric_type Symtab.table - -> C_Ast.nodeInfo C_Ast.cTranslationUnit - -> (string * (string * typ option) list) list - val extract_fundefs : C_Ast.nodeInfo C_Ast.cTranslationUnit - -> C_Ast.nodeInfo C_Ast.cFunctionDef list - val type_rank : c_numeric_type -> int - val integer_promote : c_numeric_type -> c_numeric_type - val usual_arith_conv : c_numeric_type * c_numeric_type -> c_numeric_type -end = -struct - open C_Ast - - (* ----- Resolved C numeric type representation ----- *) - - datatype c_numeric_type = CInt | CUInt | CChar | CSChar - | CShort | CUShort | CLong | CULong - | CLongLong | CULongLong - | CInt128 | CUInt128 | CBool - | CPtr of c_numeric_type | CVoid - | CStruct of string - | CUnion of string - - val current_abi_profile : C_ABI.profile Unsynchronized.ref = - Unsynchronized.ref C_ABI.LP64_LE - - fun set_abi_profile abi = (current_abi_profile := abi) - fun get_abi_profile () = !current_abi_profile - fun current_abi_name () = C_ABI.profile_name (get_abi_profile ()) - fun pointer_uint_cty () = - if C_ABI.pointer_bits (get_abi_profile ()) = 64 then CULong else CUInt - fun pointer_int_cty () = - if C_ABI.pointer_bits (get_abi_profile ()) = 64 then CLong else CInt - - fun is_signed CInt = true - | is_signed CSChar = true - | is_signed CShort = true - | is_signed CLong = true - | is_signed CLongLong = true - | is_signed CInt128 = true - | is_signed (CPtr _) = false - | is_signed CVoid = false - | is_signed (CStruct _) = false - | is_signed (CUnion _) = false - | is_signed _ = false - - fun is_bool CBool = true - | is_bool _ = false - - fun is_ptr (CPtr _) = true - | is_ptr _ = false - - fun is_unsigned_int cty = not (is_signed cty) andalso not (is_bool cty) - andalso not (is_ptr cty) andalso cty <> CVoid - andalso (case cty of CStruct _ => false | CUnion _ => false | _ => true) - - fun bit_width_of CChar = SOME 8 - | bit_width_of CSChar = SOME 8 - | bit_width_of CShort = SOME 16 - | bit_width_of CUShort = SOME 16 - | bit_width_of CInt = SOME 32 - | bit_width_of CUInt = SOME 32 - | bit_width_of CLong = SOME (C_ABI.long_bits (get_abi_profile ())) - | bit_width_of CULong = SOME (C_ABI.long_bits (get_abi_profile ())) - | bit_width_of CLongLong = SOME 64 - | bit_width_of CULongLong = SOME 64 - | bit_width_of CInt128 = SOME 128 - | bit_width_of CUInt128 = SOME 128 - | bit_width_of (CPtr _) = SOME (C_ABI.pointer_bits (get_abi_profile ())) - | bit_width_of _ = NONE - - fun sizeof_c_type cty = - (case bit_width_of cty of - SOME bits => bits div 8 - | NONE => error "micro_c_translate: sizeof: unsupported type") - - fun alignof_c_type cty = Int.min (sizeof_c_type cty, 8) - - fun builtin_typedefs () = - let - val uintptr_cty = pointer_uint_cty () - val intptr_cty = pointer_int_cty () - in - [ ("uint8_t", CChar), ("int8_t", CSChar), - ("uint16_t", CUShort), ("int16_t", CShort), - ("uint32_t", CUInt), ("int32_t", CInt), - ("uint64_t", CULongLong), ("int64_t", CLongLong), - ("size_t", uintptr_cty), ("uintptr_t", uintptr_cty), ("intptr_t", intptr_cty), - ("__int128_t", CInt128), ("__uint128_t", CUInt128) ] - end - - fun hol_type_of CBool = @{typ bool} - | hol_type_of CInt = \<^typ>\c_int\ - | hol_type_of CUInt = \<^typ>\c_uint\ - | hol_type_of CChar = \<^typ>\c_char\ - | hol_type_of CSChar = \<^typ>\c_schar\ - | hol_type_of CShort = \<^typ>\c_short\ - | hol_type_of CUShort = \<^typ>\c_ushort\ - | hol_type_of CLong = - if C_ABI.long_bits (get_abi_profile ()) = 32 then \<^typ>\c_int\ else \<^typ>\c_long\ - | hol_type_of CULong = - if C_ABI.long_bits (get_abi_profile ()) = 32 then \<^typ>\c_uint\ else \<^typ>\c_ulong\ - | hol_type_of CLongLong = \<^typ>\c_long\ - | hol_type_of CULongLong = \<^typ>\c_ulong\ - | hol_type_of CInt128 = \<^typ>\c_int128\ - | hol_type_of CUInt128 = \<^typ>\c_uint128\ - | hol_type_of (CPtr _) = dummyT (* pointer types use type inference *) - | hol_type_of CVoid = @{typ unit} - | hol_type_of (CStruct _) = dummyT - | hol_type_of (CUnion _) = dummyT - - fun type_name_of CBool = "_Bool" - | type_name_of CInt = "int" - | type_name_of CUInt = "unsigned int" - | type_name_of CChar = "char" - | type_name_of CSChar = "signed char" - | type_name_of CShort = "short" - | type_name_of CUShort = "unsigned short" - | type_name_of CLong = "long" - | type_name_of CULong = "unsigned long" - | type_name_of CLongLong = "long long" - | type_name_of CULongLong = "unsigned long long" - | type_name_of CInt128 = "__int128" - | type_name_of CUInt128 = "unsigned __int128" - | type_name_of (CPtr cty) = type_name_of cty ^ " *" - | type_name_of CVoid = "void" - | type_name_of (CStruct s) = "struct " ^ s - | type_name_of (CUnion s) = "union " ^ s - - (* Determine C numeric type from integer literal suffix flags. - Flags0 of int is a bitfield: bit 0 = unsigned, bit 1 = long, bit 2 = long long. *) - fun int_literal_type (Flags0 bits) = - let val is_unsigned = IntInf.andb (bits, 1) <> 0 - val is_long = IntInf.andb (bits, 2) <> 0 - val is_long_long = IntInf.andb (bits, 4) <> 0 - in if is_long_long andalso is_unsigned then CULongLong - else if is_long_long then CLongLong - else if is_unsigned andalso is_long then CULong - else if is_long then CLong - else if is_unsigned then CUInt - else CInt - end - - (* Parse a list of C declaration specifiers into a resolved numeric type. - Returns NONE for void, struct types, and other non-numeric specifiers. *) - fun resolve_c_type specs = - (* _Bool is a distinct type in C — handle it before the accumulator. - It cannot combine with signed/unsigned/short/long specifiers. *) - if List.exists (fn CTypeSpec0 (CBoolType0 _) => true | _ => false) specs - then SOME CBool - else - let - fun accumulate (CTypeSpec0 (CSignedType0 _)) (_, us, ch, sh, it, lg, vd, st) = - (true, us, ch, sh, it, lg, vd, st) - | accumulate (CTypeSpec0 (CUnsigType0 _)) (sg, _, ch, sh, it, lg, vd, st) = - (sg, true, ch, sh, it, lg, vd, st) - | accumulate (CTypeSpec0 (CCharType0 _)) (sg, us, _, sh, it, lg, vd, st) = - (sg, us, true, sh, it, lg, vd, st) - | accumulate (CTypeSpec0 (CShortType0 _)) (sg, us, ch, _, it, lg, vd, st) = - (sg, us, ch, true, it, lg, vd, st) - | accumulate (CTypeSpec0 (CIntType0 _)) (sg, us, ch, sh, _, lg, vd, st) = - (sg, us, ch, sh, true, lg, vd, st) - | accumulate (CTypeSpec0 (CLongType0 _)) (sg, us, ch, sh, it, lc, vd, st) = - (sg, us, ch, sh, it, lc + 1, vd, st) (* count long occurrences *) - | accumulate (CTypeSpec0 (CVoidType0 _)) (sg, us, ch, sh, it, lc, _, st) = - (sg, us, ch, sh, it, lc, true, st) - | accumulate (CTypeSpec0 (CSUType0 _)) (sg, us, ch, sh, it, lc, vd, _) = - (sg, us, ch, sh, it, lc, vd, true) - | accumulate (CTypeSpec0 (CEnumType0 _)) (sg, us, ch, sh, _, lc, vd, st) = - (sg, us, ch, sh, true, lc, vd, st) (* enum treated as int *) - | accumulate (CTypeSpec0 (CFloatType0 _)) _ = - error "micro_c_translate: float type not supported" - | accumulate (CTypeSpec0 (CDoubleType0 _)) _ = - error "micro_c_translate: double type not supported" - | accumulate (CTypeSpec0 (CInt128Type0 _)) (sg, us, ch, sh, it, _, vd, st) = - (sg, us, ch, sh, it, 128, vd, st) (* __int128: use long_count=128 as sentinel *) - | accumulate (CTypeSpec0 (CComplexType0 _)) _ = - error "micro_c_translate: _Complex type not supported" - | accumulate (CTypeSpec0 (CTypeDef0 _)) flags = flags - | accumulate (CTypeSpec0 _) _ = - error "micro_c_translate: unsupported type specifier" - | accumulate _ flags = flags - val (has_signed, has_unsigned, has_char, has_short, _, long_count, has_void, has_struct) = - List.foldl (fn (spec, flags) => accumulate spec flags) - (false, false, false, false, false, 0, false, false) specs - in - if has_void then SOME CVoid - else if has_struct then NONE - else if has_char then - if has_unsigned then SOME CChar (* unsigned char = c_char = 8 word *) - else if has_signed then SOME CSChar - else if C_ABI.char_is_signed (get_abi_profile ()) then SOME CSChar else SOME CChar - else if has_short then - if has_unsigned then SOME CUShort - else SOME CShort - else if long_count = 128 then (* __int128 *) - if has_unsigned then SOME CUInt128 - else SOME CInt128 - else if long_count >= 2 then (* long long *) - if has_unsigned then SOME CULongLong - else SOME CLongLong - else if long_count = 1 then - if has_unsigned then SOME CULong - else SOME CLong - else if has_unsigned then SOME CUInt - else SOME CInt (* int, signed, signed int, or bare specifiers *) - end - - (* Extract numeric type from a declaration *) - fun decl_type (CDecl0 (specs, _, _)) = resolve_c_type specs - | decl_type _ = NONE - - (* Extract numeric type from a parameter declaration *) - val param_type = decl_type - - (* Check if a parameter declaration has a pointer or array declarator - (e.g. int *a, struct point *p, int arr[]) *) - fun pointer_depth_of_derived derived = - List.foldl - (fn (d, acc) => - (case d of - CPtrDeclr0 _ => acc + 1 - | CArrDeclr0 _ => acc + 1 - | _ => acc)) - 0 derived - - fun pointer_depth_of_declr (CDeclr0 (_, derived, _, _, _)) = - pointer_depth_of_derived derived - - fun pointer_depth_of_decl (CDecl0 (_, [((Some declr, _), _)], _)) = - pointer_depth_of_declr declr - | pointer_depth_of_decl _ = 0 - - fun apply_ptr_depth base 0 = base - | apply_ptr_depth base n = apply_ptr_depth (CPtr base) (n - 1) - - fun is_pointer_param decl = - pointer_depth_of_decl decl > 0 - - fun abr_string_to_string (SS_base (ST s)) = s - | abr_string_to_string (SS_base (STa codes)) = - String.implode (List.map (Char.chr o IntInf.toInt) codes) - | abr_string_to_string (String_concatWith (sep, parts)) = - let val sep_s = abr_string_to_string sep - in String.concatWith sep_s (List.map abr_string_to_string parts) end - - fun ident_name (Ident0 (s, _, _)) = abr_string_to_string s - - fun declr_name (CDeclr0 (Some ident, _, _, _, _)) = ident_name ident - | declr_name (CDeclr0 (None, _, _, _, _)) = - error "C_Ast_Utils.declr_name: anonymous declarator" - - (* Extract parameter names from a function declarator. - Handles void parameters (empty list) and named parameters. *) - fun param_name (CDecl0 (_, [((Some declr, _), _)], _)) = SOME (declr_name declr) - | param_name (CDecl0 (_, [], _)) = NONE (* void parameter *) - | param_name _ = NONE - - fun extract_params (CDeclr0 (_, derived, _, _, _)) = - (case List.find (fn CFunDeclr0 _ => true | _ => false) derived of - SOME (CFunDeclr0 (Right (params, _), _, _)) => - List.mapPartial param_name params - | _ => []) - - (* Extract the full parameter declarations (not just names) from a function declarator *) - fun extract_param_decls (CDeclr0 (_, derived, _, _, _)) = - (case List.find (fn CFunDeclr0 _ => true | _ => false) derived of - SOME (CFunDeclr0 (Right (params, _), _, _)) => params - | _ => []) - - fun declr_is_variadic (CDeclr0 (_, derived, _, _, _)) = - (case List.find (fn CFunDeclr0 _ => true | _ => false) derived of - SOME (CFunDeclr0 (Right (_, has_varargs), _, _)) => has_varargs - | SOME (CFunDeclr0 _) => true - | _ => false) - - (* Check if a declaration has a struct type specifier and return the struct name. - E.g. for "struct point *p", returns SOME "point". *) - fun extract_struct_type_from_decl (CDecl0 (specs, _, _)) = - let fun find_struct [] = NONE - | find_struct (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, - Some ident, _, _, _), _)) :: _) = SOME (ident_name ident) - | find_struct (_ :: rest) = find_struct rest - in find_struct specs end - | extract_struct_type_from_decl _ = NONE - - (* Like extract_struct_type_from_decl, but also recognizes typedef names - that refer to structs. E.g. for "mlk_poly *r" where mlk_poly was - typedef'd from an anonymous struct, returns SOME "mlk_poly". *) - fun extract_struct_type_from_decl_full struct_names (CDecl0 (specs, _, _)) = - let fun find_struct [] = NONE - | find_struct (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, - Some ident, _, _, _), _)) :: _) = SOME (ident_name ident) - | find_struct (CTypeSpec0 (CTypeDef0 (ident, _)) :: _) = - let val n = ident_name ident - in if List.exists (fn s => s = n) struct_names - then SOME n else NONE end - | find_struct (_ :: rest) = find_struct rest - in find_struct specs end - | extract_struct_type_from_decl_full _ _ = NONE - - (* Like extract_struct_type_from_decl_full, but for unions. *) - fun extract_union_type_from_decl_full union_names (CDecl0 (specs, _, _)) = - let fun find_union [] = NONE - | find_union (CTypeSpec0 (CSUType0 (CStruct0 (CUnionTag0, - Some ident, _, _, _), _)) :: _) = SOME (ident_name ident) - | find_union (CTypeSpec0 (CTypeDef0 (ident, _)) :: _) = - let val n = ident_name ident - in if List.exists (fn s => s = n) union_names - then SOME n else NONE end - | find_union (_ :: rest) = find_union rest - in find_union specs end - | extract_union_type_from_decl_full _ _ = NONE - - (* Extract struct definitions (with member lists) from a top-level declaration. - Returns SOME (struct_name, [field_name, ...]) for struct definitions. *) - fun extract_struct_def_from_decl (CDecl0 (specs, _, _)) = - let fun find_struct_def [] = NONE - | find_struct_def (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, - Some ident, Some members, _, _), _)) :: _) = - let val sname = ident_name ident - val field_names = List.mapPartial - (fn CDecl0 (_, [((Some declr, _), _)], _) => - SOME (declr_name declr) - | _ => NONE) - members - in SOME (sname, field_names) end - | find_struct_def (_ :: rest) = find_struct_def rest - in find_struct_def specs end - | extract_struct_def_from_decl _ = NONE - - (* Extract all struct definitions from a translation unit *) - fun extract_struct_defs (CTranslUnit0 (ext_decls, _)) = - List.mapPartial - (fn CDeclExt0 decl => extract_struct_def_from_decl decl | _ => NONE) - ext_decls - - (* Extract enum constant definitions from a translation unit. - Returns a flat list of (name, integer_value) pairs. - Handles both explicit values and auto-incrementing. *) - fun extract_enum_defs_from_spec (CTypeSpec0 (CEnumType0 (CEnum0 (_, Some enumerators, _, _), _))) = - let - fun intinf_to_int_checked what n = - let - val ge_min = - (case Int.minInt of - SOME lo => n >= IntInf.fromInt lo - | NONE => true) - val le_max = - (case Int.maxInt of - SOME hi => n <= IntInf.fromInt hi - | NONE => true) - in - if ge_min andalso le_max then IntInf.toInt n - else error ("micro_c_translate: " ^ what ^ " out of ML-int range: " ^ IntInf.toString n) - end - fun process [] _ = [] - | process ((ident, Some (CConst0 (CIntConst0 (CInteger0 (n, _, _), _)))) :: rest) _ = - let val v = intinf_to_int_checked "enum constant" n - in (ident_name ident, v) :: process rest (v + 1) end - | process ((ident, None) :: rest) next_val = - (ident_name ident, next_val) :: process rest (next_val + 1) - | process (_ :: rest) next_val = process rest (next_val + 1) - in process enumerators 0 end - | extract_enum_defs_from_spec _ = [] - - fun extract_enum_defs (CTranslUnit0 (ext_decls, _)) = - let fun from_decl (CDeclExt0 (CDecl0 (specs, _, _))) = - List.concat (List.map extract_enum_defs_from_spec specs) - | from_decl _ = [] - in List.concat (List.map from_decl ext_decls) end - - (* Extract typedef mappings from a translation unit. - A typedef declaration is CDecl0 with CStorageSpec0 (CTypedef0 _) in specifiers. *) - fun extract_typedefs (CTranslUnit0 (ext_decls, _)) = - let fun is_typedef_spec (CStorageSpec0 (CTypedef0 _)) = true - | is_typedef_spec _ = false - fun non_storage_spec (CStorageSpec0 _) = false - | non_storage_spec _ = true - fun extract (CDeclExt0 (CDecl0 (specs, [((Some declr, _), _)], _))) = - if List.exists is_typedef_spec specs then - let val name = declr_name declr - val type_specs = List.filter non_storage_spec specs - val base_cty = - (case resolve_c_type type_specs of - SOME cty => SOME cty - | NONE => - (case List.find (fn CTypeSpec0 (CSUType0 _) => true | _ => false) type_specs of - SOME (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, Some ident, _, _, _), _))) => - SOME (CStruct (ident_name ident)) - | _ => NONE)) - val ptr_depth = pointer_depth_of_declr declr - in case base_cty of - SOME cty => [(name, apply_ptr_depth cty ptr_depth)] - | NONE => [] - end - else [] - | extract _ = [] - in List.concat (List.map extract ext_decls) end - - (* resolve_c_type with typedef resolution: check for CTypeDef0 first, - then fall back to standard resolve_c_type. - We strip type qualifiers (const, volatile) and storage specifiers - (static, extern) before matching, so that e.g. "const int32_t" still - resolves the typedef correctly. *) - fun resolve_c_type_full typedef_tab specs = - let val type_specs = List.filter - (fn CTypeSpec0 _ => true | _ => false) specs - in case type_specs of - [CTypeSpec0 (CTypeDef0 (ident, _))] => - (case Symtab.lookup typedef_tab (ident_name ident) of - SOME cty => SOME cty - | NONE => NONE) - | _ => resolve_c_type specs - end - - (* Conservative side-effect analysis for expression-order soundness checks. - Calls and mutating operators are treated as side-effecting. *) - fun expr_has_side_effect (CAssign0 _) = true - | expr_has_side_effect (CUnary0 (CPreIncOp0, _, _)) = true - | expr_has_side_effect (CUnary0 (CPostIncOp0, _, _)) = true - | expr_has_side_effect (CUnary0 (CPreDecOp0, _, _)) = true - | expr_has_side_effect (CUnary0 (CPostDecOp0, _, _)) = true - | expr_has_side_effect (CCall0 _) = true - | expr_has_side_effect (CBinary0 (_, l, r, _)) = - expr_has_side_effect l orelse expr_has_side_effect r - | expr_has_side_effect (CUnary0 (_, e, _)) = expr_has_side_effect e - | expr_has_side_effect (CIndex0 (a, i, _)) = - expr_has_side_effect a orelse expr_has_side_effect i - | expr_has_side_effect (CMember0 (e, _, _, _)) = expr_has_side_effect e - | expr_has_side_effect (CCast0 (_, e, _)) = expr_has_side_effect e - | expr_has_side_effect (CComma0 (es, _)) = List.exists expr_has_side_effect es - | expr_has_side_effect (CCond0 (c, t, e, _)) = - expr_has_side_effect c orelse - (case t of Some te => expr_has_side_effect te | None => false) orelse - expr_has_side_effect e - | expr_has_side_effect _ = false - - fun expr_reads_vars (CVar0 (ident, _)) = [ident_name ident] - | expr_reads_vars (CAssign0 (_, lhs, rhs, _)) = - expr_reads_vars lhs @ expr_reads_vars rhs - | expr_reads_vars (CBinary0 (_, l, r, _)) = - expr_reads_vars l @ expr_reads_vars r - | expr_reads_vars (CUnary0 (_, e, _)) = expr_reads_vars e - | expr_reads_vars (CIndex0 (a, i, _)) = - expr_reads_vars a @ expr_reads_vars i - | expr_reads_vars (CMember0 (e, _, _, _)) = expr_reads_vars e - | expr_reads_vars (CCast0 (_, e, _)) = expr_reads_vars e - | expr_reads_vars (CCall0 (f, args, _)) = - expr_reads_vars f @ List.concat (List.map expr_reads_vars args) - | expr_reads_vars (CComma0 (es, _)) = List.concat (List.map expr_reads_vars es) - | expr_reads_vars (CCond0 (c, t, e, _)) = - expr_reads_vars c @ - (case t of Some te => expr_reads_vars te | None => []) @ - expr_reads_vars e - | expr_reads_vars _ = [] - - fun expr_written_vars (CAssign0 (_, CVar0 (ident, _), rhs, _)) = - ident_name ident :: expr_written_vars rhs - | expr_written_vars (CAssign0 (_, lhs, rhs, _)) = - expr_written_vars lhs @ expr_written_vars rhs - | expr_written_vars (CUnary0 (CPreIncOp0, CVar0 (ident, _), _)) = [ident_name ident] - | expr_written_vars (CUnary0 (CPostIncOp0, CVar0 (ident, _), _)) = [ident_name ident] - | expr_written_vars (CUnary0 (CPreDecOp0, CVar0 (ident, _), _)) = [ident_name ident] - | expr_written_vars (CUnary0 (CPostDecOp0, CVar0 (ident, _), _)) = [ident_name ident] - | expr_written_vars (CBinary0 (_, l, r, _)) = - expr_written_vars l @ expr_written_vars r - | expr_written_vars (CUnary0 (_, e, _)) = expr_written_vars e - | expr_written_vars (CIndex0 (a, i, _)) = - expr_written_vars a @ expr_written_vars i - | expr_written_vars (CMember0 (e, _, _, _)) = expr_written_vars e - | expr_written_vars (CCast0 (_, e, _)) = expr_written_vars e - | expr_written_vars (CCall0 (f, args, _)) = - expr_written_vars f @ List.concat (List.map expr_written_vars args) - | expr_written_vars (CComma0 (es, _)) = List.concat (List.map expr_written_vars es) - | expr_written_vars (CCond0 (c, t, e, _)) = - expr_written_vars c @ - (case t of Some te => expr_written_vars te | None => []) @ - expr_written_vars e - | expr_written_vars _ = [] - - fun list_intersects xs ys = - List.exists (fn x => List.exists (fn y => x = y) ys) xs - - fun expr_has_unsequenced_ub_risk e0 e1 = - let - val r0 = distinct (op =) (expr_reads_vars e0) - val r1 = distinct (op =) (expr_reads_vars e1) - val w0 = distinct (op =) (expr_written_vars e0) - val w1 = distinct (op =) (expr_written_vars e1) - val writes_conflict = - list_intersects w0 (r1 @ w1) orelse list_intersects w1 (r0 @ w0) - in - (* Only reject when we can identify a concrete scalar object conflict. - Opaque/unknown side effects (e.g., function calls) are not treated as UB - by themselves, to avoid rejecting common valid C expressions. *) - writes_conflict - end - - (* Walk the C AST and collect variable names that appear on the LHS of - assignments or as operands of pre/post increment/decrement. - Used to identify parameters that need promotion to local variables. *) - local - fun fae (CAssign0 (_, CVar0 (ident, _), rhs, _)) acc = - fae rhs (ident_name ident :: acc) - | fae (CAssign0 (_, lhs, rhs, _)) acc = fae rhs (fae lhs acc) - | fae (CUnary0 (CPreIncOp0, CVar0 (ident, _), _)) acc = ident_name ident :: acc - | fae (CUnary0 (CPostIncOp0, CVar0 (ident, _), _)) acc = ident_name ident :: acc - | fae (CUnary0 (CPreDecOp0, CVar0 (ident, _), _)) acc = ident_name ident :: acc - | fae (CUnary0 (CPostDecOp0, CVar0 (ident, _), _)) acc = ident_name ident :: acc - | fae (CBinary0 (_, l, r, _)) acc = fae r (fae l acc) - | fae (CUnary0 (CAdrOp0, CVar0 (ident, _), _)) acc = ident_name ident :: acc - | fae (CUnary0 (_, e, _)) acc = fae e acc - | fae (CCall0 (f, args, _)) acc = - List.foldl (fn (a, ac) => fae a ac) (fae f acc) args - | fae (CIndex0 (a, i, _)) acc = fae i (fae a acc) - | fae (CMember0 (e, _, _, _)) acc = fae e acc - | fae (CCast0 (_, e, _)) acc = fae e acc - | fae (CComma0 (es, _)) acc = List.foldl (fn (e, ac) => fae e ac) acc es - | fae (CCond0 (c, t, e, _)) acc = - fae e ((case t of Some te => fae te | None => I) (fae c acc)) - | fae _ acc = acc - and fas (CCompound0 (_, items, _)) acc = - List.foldl (fn (CBlockStmt0 s, ac) => fas s ac | (_, ac) => ac) acc items - | fas (CExpr0 (Some e, _)) acc = fae e acc - | fas (CIf0 (c, t, e_opt, _)) acc = - (case e_opt of Some e => fas e | None => I) (fas t (fae c acc)) - | fas (CWhile0 (c, b, _, _)) acc = fas b (fae c acc) - | fas (CFor0 (Left (Some i), c, s, b, _)) acc = - fas b (opt s (opt c (fae i acc))) - | fas (CFor0 (_, c, s, b, _)) acc = - fas b (opt s (opt c acc)) - | fas (CReturn0 (Some e, _)) acc = fae e acc - | fas (CLabel0 (_, s, _, _)) acc = fas s acc - | fas (CSwitch0 (e, s, _)) acc = fas s (fae e acc) - | fas _ acc = acc - and opt (Some e) acc = fae e acc - | opt None acc = acc - in - fun find_assigned_vars stmt = distinct (op =) (fas stmt []) - end - - (* Walk the C AST and collect label names targeted by goto statements. - Used to allocate goto flag references for forward-only goto support. *) - local - fun fgt (CGoto0 (ident, _)) acc = ident_name ident :: acc - | fgt (CCompound0 (_, items, _)) acc = - List.foldl (fn (CBlockStmt0 s, ac) => fgt s ac | (_, ac) => ac) acc items - | fgt (CIf0 (_, t, e_opt, _)) acc = - (case e_opt of Some e => fgt e | None => I) (fgt t acc) - | fgt (CWhile0 (_, b, _, _)) acc = fgt b acc - | fgt (CFor0 (_, _, _, b, _)) acc = fgt b acc - | fgt (CSwitch0 (_, s, _)) acc = fgt s acc - | fgt (CLabel0 (_, s, _, _)) acc = fgt s acc - | fgt _ acc = acc - in - fun find_goto_targets stmt = distinct (op =) (fgt stmt []) - end - - (* Collect direct function-call targets used in a function body. - Only named calls (CCall0 (CVar0 ...)) are collected. *) - local - fun fc_expr (CCall0 (CVar0 (ident, _), args, _)) acc = - List.foldl (fn (a, ac) => fc_expr a ac) (ident_name ident :: acc) args - | fc_expr (CCall0 (f, args, _)) acc = - List.foldl (fn (a, ac) => fc_expr a ac) (fc_expr f acc) args - | fc_expr (CAssign0 (_, lhs, rhs, _)) acc = fc_expr rhs (fc_expr lhs acc) - | fc_expr (CBinary0 (_, l, r, _)) acc = fc_expr r (fc_expr l acc) - | fc_expr (CUnary0 (_, e, _)) acc = fc_expr e acc - | fc_expr (CIndex0 (a, i, _)) acc = fc_expr i (fc_expr a acc) - | fc_expr (CMember0 (e, _, _, _)) acc = fc_expr e acc - | fc_expr (CCast0 (_, e, _)) acc = fc_expr e acc - | fc_expr (CComma0 (es, _)) acc = - List.foldl (fn (e, ac) => fc_expr e ac) acc es - | fc_expr (CCond0 (c, t, e, _)) acc = - fc_expr e ((case t of Some te => fc_expr te | None => I) (fc_expr c acc)) - | fc_expr _ acc = acc - - fun fc_init (CInitExpr0 (e, _)) acc = fc_expr e acc - | fc_init (CInitList0 (inits, _)) acc = - List.foldl (fn ((_, init), ac) => fc_init init ac) acc inits - - fun fc_decl (CDecl0 (_, declarators, _)) acc = - List.foldl - (fn (((_, Some init), _), ac) => fc_init init ac - | (_, ac) => ac) - acc declarators - | fc_decl _ acc = acc - - fun fc_item (CBlockStmt0 s) acc = fc_stmt s acc - | fc_item (CBlockDecl0 d) acc = fc_decl d acc - | fc_item _ acc = acc - - and fc_stmt (CCompound0 (_, items, _)) acc = - List.foldl (fn (it, ac) => fc_item it ac) acc items - | fc_stmt (CExpr0 (Some e, _)) acc = fc_expr e acc - | fc_stmt (CExpr0 (None, _)) acc = acc - | fc_stmt (CReturn0 (Some e, _)) acc = fc_expr e acc - | fc_stmt (CReturn0 (None, _)) acc = acc - | fc_stmt (CIf0 (c, t, e_opt, _)) acc = - (case e_opt of Some e => fc_stmt e | None => I) (fc_stmt t (fc_expr c acc)) - | fc_stmt (CWhile0 (c, b, _, _)) acc = fc_stmt b (fc_expr c acc) - | fc_stmt (CFor0 (Left (Some i), c, s, b, _)) acc = - fc_stmt b (opt_expr s (opt_expr c (fc_expr i acc))) - | fc_stmt (CFor0 (Left None, c, s, b, _)) acc = - fc_stmt b (opt_expr s (opt_expr c acc)) - | fc_stmt (CFor0 (Right d, c, s, b, _)) acc = - fc_stmt b (opt_expr s (opt_expr c (fc_decl d acc))) - | fc_stmt (CSwitch0 (e, s, _)) acc = fc_stmt s (fc_expr e acc) - | fc_stmt (CCase0 (e, s, _)) acc = fc_stmt s (fc_expr e acc) - | fc_stmt (CDefault0 (s, _)) acc = fc_stmt s acc - | fc_stmt (CLabel0 (_, s, _, _)) acc = fc_stmt s acc - | fc_stmt _ acc = acc - - and opt_expr (Some e) acc = fc_expr e acc - | opt_expr None acc = acc - in - fun find_called_functions (CFunDef0 (_, _, _, body, _)) = - distinct (op =) (rev (fc_stmt body [])) - end - - - (* Extract struct definitions with field types from a top-level declaration. - Returns SOME (struct_name, [(field_name, field_type)]) for struct definitions. - Falls back to CInt for fields whose type cannot be resolved. *) - (* Extract struct type name from declaration specifiers (for struct-typed fields) *) - fun extract_struct_type_from_specs specs = - case List.find (fn CTypeSpec0 (CSUType0 _) => true | _ => false) specs of - SOME (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, Some ident, _, _, _), _))) => - SOME (ident_name ident) - | _ => NONE - - (* Extract union type name from declaration specifiers *) - fun extract_union_type_from_specs specs = - case List.find (fn CTypeSpec0 (CSUType0 _) => true | _ => false) specs of - SOME (CTypeSpec0 (CSUType0 (CStruct0 (CUnionTag0, Some ident, _, _, _), _))) => - SOME (ident_name ident) - | _ => NONE - - (* Like extract_struct_type_from_specs, but also recognizes typedef names - that refer to known structs. *) - fun extract_struct_type_from_specs_full struct_names specs = - case extract_struct_type_from_specs specs of - SOME sn => SOME sn - | NONE => - let val type_specs = List.filter - (fn CTypeSpec0 _ => true | _ => false) specs - in case type_specs of - [CTypeSpec0 (CTypeDef0 (ident, _))] => - let val n = ident_name ident - in if List.exists (fn s => s = n) struct_names - then SOME n else NONE end - | _ => NONE - end - - (* Like extract_union_type_from_specs, but also recognizes typedef names - that refer to known unions. *) - fun extract_union_type_from_specs_full union_names specs = - case extract_union_type_from_specs specs of - SOME un => SOME un - | NONE => - let val type_specs = List.filter - (fn CTypeQual0 _ => false | CStorageSpec0 _ => false | _ => true) specs - in case type_specs of - [CTypeSpec0 (CTypeDef0 (ident, _))] => - let val n = ident_name ident - in if List.exists (fn s => s = n) union_names - then SOME n else NONE end - | _ => NONE - end - - fun extract_member_field_info typedef_tab members = - List.mapPartial - (fn CDecl0 (field_specs, [((Some (CDeclr0 (Some ident_node, derived, _, _, _)), _), _)], _) => - let val fname = ident_name ident_node - val base_fty = case resolve_c_type_full typedef_tab field_specs of - SOME CVoid => CInt - | SOME ct => ct - | NONE => - (case extract_struct_type_from_specs field_specs of - SOME sn => CStruct sn - | NONE => - (case extract_union_type_from_specs field_specs of - SOME un => CUnion un - | NONE => CInt)) - val ptr_depth = pointer_depth_of_derived derived - val fty = apply_ptr_depth base_fty ptr_depth - in SOME (fname, fty) end - | _ => NONE) - members - - fun cty_to_record_typ _ CBool = SOME @{typ bool} - | cty_to_record_typ _ CInt = SOME \<^typ>\c_int\ - | cty_to_record_typ _ CUInt = SOME \<^typ>\c_uint\ - | cty_to_record_typ _ CChar = SOME \<^typ>\c_char\ - | cty_to_record_typ _ CSChar = SOME \<^typ>\c_schar\ - | cty_to_record_typ _ CShort = SOME \<^typ>\c_short\ - | cty_to_record_typ _ CUShort = SOME \<^typ>\c_ushort\ - | cty_to_record_typ _ CLong = - if C_ABI.long_bits (get_abi_profile ()) = 32 then SOME \<^typ>\c_int\ else SOME \<^typ>\c_long\ - | cty_to_record_typ _ CULong = - if C_ABI.long_bits (get_abi_profile ()) = 32 then SOME \<^typ>\c_uint\ else SOME \<^typ>\c_ulong\ - | cty_to_record_typ _ CLongLong = SOME \<^typ>\c_long\ - | cty_to_record_typ _ CULongLong = SOME \<^typ>\c_ulong\ - | cty_to_record_typ _ CInt128 = SOME \<^typ>\c_int128\ - | cty_to_record_typ _ CUInt128 = SOME \<^typ>\c_uint128\ - | cty_to_record_typ prefix (CStruct sname) = SOME (Term.Type (prefix ^ sname, [])) - | cty_to_record_typ _ (CPtr _) = NONE - | cty_to_record_typ _ CVoid = NONE - | cty_to_record_typ _ (CUnion _) = NONE - - fun ptr_depth_only derived = - List.foldl - (fn (d, acc) => - (case d of - CPtrDeclr0 _ => acc + 1 - | _ => acc)) - 0 derived - - fun has_array_derived derived = - List.exists (fn CArrDeclr0 _ => true | _ => false) derived - - fun member_record_field_typ prefix base_fty derived = - if has_array_derived derived then - Option.map HOLogic.listT (cty_to_record_typ prefix base_fty) - else if ptr_depth_only derived > 0 then - NONE - else - cty_to_record_typ prefix base_fty - - fun extract_member_record_field_info prefix typedef_tab members = - List.mapPartial - (fn CDecl0 (field_specs, [((Some (CDeclr0 (Some ident_node, derived, _, _, _)), _), _)], _) => - let val fname = ident_name ident_node - val base_fty = case resolve_c_type_full typedef_tab field_specs of - SOME CVoid => CInt - | SOME ct => ct - | NONE => - (case extract_struct_type_from_specs field_specs of - SOME sn => CStruct sn - | NONE => CInt) - in SOME (fname, member_record_field_typ prefix base_fty derived) end - | _ => NONE) - members - - fun extract_struct_def_with_types_from_decl typedef_tab (CDecl0 (specs, declrs, _)) = - let fun find_struct_def [] = NONE - | find_struct_def (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, - Some ident, Some members, _, _), _)) :: _) = - SOME (ident_name ident, extract_member_field_info typedef_tab members) - | find_struct_def (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, - None, Some members, _, _), _)) :: _) = - (* Anonymous struct in typedef: get name from declarator *) - if List.exists (fn CStorageSpec0 (CTypedef0 _) => true | _ => false) specs - then (case declrs of - [((Some (CDeclr0 (Some td_ident, _, _, _, _)), _), _)] => - SOME (ident_name td_ident, - extract_member_field_info typedef_tab members) - | _ => NONE) - else NONE - | find_struct_def (_ :: rest) = find_struct_def rest - in find_struct_def specs end - | extract_struct_def_with_types_from_decl _ _ = NONE - - fun extract_struct_defs_with_types typedef_tab (CTranslUnit0 (ext_decls, _)) = - List.mapPartial - (fn CDeclExt0 decl => extract_struct_def_with_types_from_decl typedef_tab decl - | _ => NONE) - ext_decls - - (* Extract union definitions with field types. Mirrors extract_struct_defs_with_types - but matches CUnionTag0 instead of CStructTag0. *) - fun extract_union_def_with_types_from_decl typedef_tab (CDecl0 (specs, declrs, _)) = - let fun find_union_def [] = NONE - | find_union_def (CTypeSpec0 (CSUType0 (CStruct0 (CUnionTag0, - Some ident, Some members, _, _), _)) :: _) = - SOME (ident_name ident, extract_member_field_info typedef_tab members) - | find_union_def (CTypeSpec0 (CSUType0 (CStruct0 (CUnionTag0, - None, Some members, _, _), _)) :: _) = - if List.exists (fn CStorageSpec0 (CTypedef0 _) => true | _ => false) specs - then (case declrs of - [((Some (CDeclr0 (Some td_ident, _, _, _, _)), _), _)] => - SOME (ident_name td_ident, - extract_member_field_info typedef_tab members) - | _ => NONE) - else NONE - | find_union_def (_ :: rest) = find_union_def rest - in find_union_def specs end - | extract_union_def_with_types_from_decl _ _ = NONE - - fun extract_union_defs_with_types typedef_tab (CTranslUnit0 (ext_decls, _)) = - List.mapPartial - (fn CDeclExt0 decl => extract_union_def_with_types_from_decl typedef_tab decl - | _ => NONE) - ext_decls - - fun extract_struct_record_def_from_decl prefix typedef_tab (CDecl0 (specs, declrs, _)) = - let fun find_struct_def [] = NONE - | find_struct_def (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, - Some ident, Some members, _, _), _)) :: _) = - SOME (ident_name ident, extract_member_record_field_info prefix typedef_tab members) - | find_struct_def (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, - None, Some members, _, _), _)) :: _) = - if List.exists (fn CStorageSpec0 (CTypedef0 _) => true | _ => false) specs - then (case declrs of - [((Some (CDeclr0 (Some td_ident, _, _, _, _)), _), _)] => - SOME (ident_name td_ident, - extract_member_record_field_info prefix typedef_tab members) - | _ => NONE) - else NONE - | find_struct_def (_ :: rest) = find_struct_def rest - in find_struct_def specs end - | extract_struct_record_def_from_decl _ _ _ = NONE - - fun extract_struct_record_defs prefix typedef_tab (CTranslUnit0 (ext_decls, _)) = - List.mapPartial - (fn CDeclExt0 decl => extract_struct_record_def_from_decl prefix typedef_tab decl - | _ => NONE) - ext_decls - - fun extract_fundefs (CTranslUnit0 (ext_decls, _)) = - List.mapPartial - (fn CFDefExt0 fundef => SOME fundef | _ => NONE) - ext_decls - - (* C11 integer conversion rank (\
6.3.1.1) *) - fun type_rank CBool = 0 - | type_rank CChar = 1 - | type_rank CSChar = 1 - | type_rank CShort = 2 - | type_rank CUShort = 2 - | type_rank CInt = 3 - | type_rank CUInt = 3 - | type_rank CLong = 4 - | type_rank CULong = 4 - | type_rank CLongLong = 4 - | type_rank CULongLong = 4 - | type_rank CInt128 = 5 - | type_rank CUInt128 = 5 - | type_rank _ = 3 (* default: int rank *) - - (* C11 \
6.3.1.1: integer promotion — sub-int types promote to int *) - fun integer_promote cty = - if type_rank cty < type_rank CInt then CInt else cty - - (* C11 \
6.3.1.8: usual arithmetic conversions for binary ops *) - fun usual_arith_conv (lty, rty) = - let val lp = integer_promote lty - val rp = integer_promote rty - in if lp = rp then lp - else if is_signed lp = is_signed rp then - (if type_rank lp >= type_rank rp then lp else rp) - else - let val (_, u) = if is_signed lp then (lp, rp) else (rp, lp) - in if type_rank u >= type_rank lp andalso type_rank u >= type_rank rp - then u (* unsigned wins when rank >= signed *) - else if is_signed lp then lp else rp (* signed can represent all unsigned values *) - end - end -end -\ - -subsection \Translation Context\ - -text \ - The translation context tracks information accumulated during AST traversal: - variable bindings (mapping C variable names to Isabelle free variables), - function signatures, and diagnostics. -\ - -ML \ -structure C_Trans_Ctxt : sig - datatype var_kind = Param | Local (* Param = by-value, Local = mutable reference *) - type t - val make : Proof.context -> (string * C_Ast_Utils.c_numeric_type) list Symtab.table - -> int Symtab.table -> C_Ast_Utils.c_numeric_type Symtab.table - -> C_Ast_Utils.c_numeric_type Symtab.table Unsynchronized.ref - -> C_Ast_Utils.c_numeric_type list Symtab.table Unsynchronized.ref - -> typ -> typ -> t - val get_ctxt : t -> Proof.context - val get_ref_addr_ty : t -> typ - val get_ref_gv_ty : t -> typ - val add_var : string -> var_kind -> term -> C_Ast_Utils.c_numeric_type -> t -> t - val lookup_var : t -> string -> (var_kind * term * C_Ast_Utils.c_numeric_type) option - val add_global_const : string -> term -> C_Ast_Utils.c_numeric_type -> t -> t - val lookup_global_const : t -> string -> (term * C_Ast_Utils.c_numeric_type) option - val get_struct_names : t -> string list - val set_struct_type : string -> string -> t -> t - val get_struct_type : t -> string -> string option - val get_struct_fields : t -> string -> (string * C_Ast_Utils.c_numeric_type) list option - val lookup_struct_field_type : t -> string -> string -> C_Ast_Utils.c_numeric_type option - val set_array_decl : string -> C_Ast_Utils.c_numeric_type -> int -> t -> t - val lookup_array_decl : t -> string -> (C_Ast_Utils.c_numeric_type * int) option - val lookup_enum_const : t -> string -> int option - val add_enum_consts : (string * int) list -> t -> t - val get_typedef_tab : t -> C_Ast_Utils.c_numeric_type Symtab.table - val register_func_return_type : string -> C_Ast_Utils.c_numeric_type -> t -> unit - val lookup_func_return_type : t -> string -> C_Ast_Utils.c_numeric_type option - val register_func_param_types : string -> C_Ast_Utils.c_numeric_type list -> t -> unit - val lookup_func_param_types : t -> string -> C_Ast_Utils.c_numeric_type list option - val get_break_ref : t -> term option - val get_continue_ref : t -> term option - val set_break_ref : term -> t -> t - val set_continue_ref : term -> t -> t - val clear_break_ref : t -> t - val get_goto_refs : t -> (string * term) list - val set_goto_refs : (string * term) list -> t -> t - val lookup_goto_ref : t -> string -> term option - val get_active_goto_labels : t -> string list - val set_active_goto_labels : string list -> t -> t -end = -struct - datatype var_kind = Param | Local - type t = { - ctxt : Proof.context, - vars : (var_kind * term * C_Ast_Utils.c_numeric_type) Symtab.table, - global_consts : (term * C_Ast_Utils.c_numeric_type) Symtab.table, - struct_types : string Symtab.table, (* var_name -> c_struct_name *) - struct_fields : (string * C_Ast_Utils.c_numeric_type) list Symtab.table, - array_decls : (C_Ast_Utils.c_numeric_type * int) Symtab.table, (* var_name -> (elem_cty, size) *) - enum_consts : int Symtab.table, (* enum_name -> int_value *) - typedef_tab : C_Ast_Utils.c_numeric_type Symtab.table, - func_ret_types : C_Ast_Utils.c_numeric_type Symtab.table Unsynchronized.ref, - func_param_types : C_Ast_Utils.c_numeric_type list Symtab.table Unsynchronized.ref, - ref_addr_ty : typ, - ref_gv_ty : typ, - break_ref : term option, - continue_ref : term option, - goto_refs : (string * term) list, (* label_name -> flag ref variable *) - active_goto_labels : string list (* labels that are valid forward goto targets from here *) - } - - fun make ctxt struct_fields enum_consts typedef_tab func_ret_types func_param_types - ref_addr_ty ref_gv_ty : t = - { ctxt = ctxt, vars = Symtab.empty, global_consts = Symtab.empty, struct_types = Symtab.empty, - struct_fields = struct_fields, array_decls = Symtab.empty, - enum_consts = enum_consts, - typedef_tab = typedef_tab, func_ret_types = func_ret_types, - func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, - break_ref = NONE, continue_ref = NONE, - goto_refs = [], active_goto_labels = [] } - - fun get_ctxt ({ ctxt, ... } : t) = ctxt - fun get_ref_addr_ty ({ ref_addr_ty, ... } : t) = ref_addr_ty - fun get_ref_gv_ty ({ ref_gv_ty, ... } : t) = ref_gv_ty - - fun add_var name kind tm cty ({ ctxt, vars, global_consts, struct_types, struct_fields, - array_decls, enum_consts, typedef_tab, func_ret_types, - func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, goto_refs, - active_goto_labels } : t) : t = - { ctxt = ctxt, vars = Symtab.update (name, (kind, tm, cty)) vars, - global_consts = global_consts, - struct_types = struct_types, struct_fields = struct_fields, - array_decls = array_decls, - enum_consts = enum_consts, typedef_tab = typedef_tab, - func_ret_types = func_ret_types, - func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, - break_ref = break_ref, continue_ref = continue_ref, - goto_refs = goto_refs, active_goto_labels = active_goto_labels } - - fun lookup_var ({ vars, ... } : t) name = - Symtab.lookup vars name - - fun add_global_const name tm cty - ({ ctxt, vars, global_consts, struct_types, struct_fields, array_decls, enum_consts, - typedef_tab, func_ret_types, func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, goto_refs, - active_goto_labels } : t) : t = - { ctxt = ctxt, vars = vars, - global_consts = Symtab.update (name, (tm, cty)) global_consts, - struct_types = struct_types, struct_fields = struct_fields, - array_decls = array_decls, enum_consts = enum_consts, typedef_tab = typedef_tab, - func_ret_types = func_ret_types, func_param_types = func_param_types, - ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, - break_ref = break_ref, continue_ref = continue_ref, - goto_refs = goto_refs, active_goto_labels = active_goto_labels } - - fun lookup_global_const ({ global_consts, ... } : t) name = - Symtab.lookup global_consts name - - fun get_struct_names ({ struct_fields, ... } : t) = - Symtab.keys struct_fields - - fun set_struct_type var_name struct_name - ({ ctxt, vars, global_consts, struct_types, struct_fields, array_decls, enum_consts, typedef_tab, - func_ret_types, func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, goto_refs, - active_goto_labels } : t) : t = - { ctxt = ctxt, vars = vars, global_consts = global_consts, - struct_types = Symtab.update (var_name, struct_name) struct_types, - struct_fields = struct_fields, array_decls = array_decls, - enum_consts = enum_consts, - typedef_tab = typedef_tab, func_ret_types = func_ret_types, - func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, - break_ref = break_ref, continue_ref = continue_ref, - goto_refs = goto_refs, active_goto_labels = active_goto_labels } - - fun get_struct_type ({ struct_types, ... } : t) name = - Symtab.lookup struct_types name - - fun get_struct_fields ({ struct_fields, ... } : t) name = - Symtab.lookup struct_fields name - - fun lookup_struct_field_type tctx struct_name field_name = - case get_struct_fields tctx struct_name of - SOME fields => (case List.find (fn (n, _) => n = field_name) fields of - SOME (_, cty) => SOME cty | NONE => NONE) - | NONE => NONE - - fun set_array_decl var_name elem_cty size - ({ ctxt, vars, global_consts, struct_types, struct_fields, array_decls, enum_consts, - typedef_tab, func_ret_types, func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, - goto_refs, active_goto_labels } : t) : t = - { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, - struct_fields = struct_fields, - array_decls = Symtab.update (var_name, (elem_cty, size)) array_decls, - enum_consts = enum_consts, typedef_tab = typedef_tab, - func_ret_types = func_ret_types, func_param_types = func_param_types, - ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, - break_ref = break_ref, continue_ref = continue_ref, goto_refs = goto_refs, - active_goto_labels = active_goto_labels } - - fun lookup_array_decl ({ array_decls, ... } : t) name = - Symtab.lookup array_decls name - - fun lookup_enum_const ({ enum_consts, ... } : t) name = - Symtab.lookup enum_consts name - - fun add_enum_consts entries ({ ctxt, vars, struct_types, struct_fields, - global_consts, array_decls, enum_consts, typedef_tab, func_ret_types, - func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, goto_refs, - active_goto_labels } : t) : t = - { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, - struct_fields = struct_fields, - array_decls = array_decls, - enum_consts = List.foldl (fn ((n, v), tab) => Symtab.update (n, v) tab) - enum_consts entries, - typedef_tab = typedef_tab, func_ret_types = func_ret_types, - func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, - break_ref = break_ref, continue_ref = continue_ref, - goto_refs = goto_refs, active_goto_labels = active_goto_labels } - - fun get_typedef_tab ({ typedef_tab, ... } : t) = typedef_tab - - fun register_func_return_type name cty ({ func_ret_types, ... } : t) = - func_ret_types := Symtab.update (name, cty) (! func_ret_types) - - fun lookup_func_return_type ({ func_ret_types, ... } : t) name = - Symtab.lookup (! func_ret_types) name - - fun register_func_param_types name ctys ({ func_param_types, ... } : t) = - func_param_types := Symtab.update (name, ctys) (! func_param_types) - - fun lookup_func_param_types ({ func_param_types, ... } : t) name = - Symtab.lookup (! func_param_types) name - - fun get_break_ref ({ break_ref, ... } : t) = break_ref - fun get_continue_ref ({ continue_ref, ... } : t) = continue_ref - - fun set_break_ref ref_term ({ ctxt, vars, struct_types, struct_fields, - global_consts, array_decls, enum_consts, typedef_tab, func_ret_types, - func_param_types, ref_addr_ty, ref_gv_ty, break_ref = _, continue_ref, - goto_refs, active_goto_labels } : t) : t = - { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, - struct_fields = struct_fields, array_decls = array_decls, - enum_consts = enum_consts, - typedef_tab = typedef_tab, func_ret_types = func_ret_types, - func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, - break_ref = SOME ref_term, - continue_ref = continue_ref, goto_refs = goto_refs, - active_goto_labels = active_goto_labels } - - fun set_continue_ref ref_term ({ ctxt, vars, struct_types, struct_fields, - global_consts, array_decls, enum_consts, typedef_tab, func_ret_types, - func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref = _, - goto_refs, active_goto_labels } : t) : t = - { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, - struct_fields = struct_fields, array_decls = array_decls, - enum_consts = enum_consts, - typedef_tab = typedef_tab, func_ret_types = func_ret_types, - func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, - break_ref = break_ref, - continue_ref = SOME ref_term, goto_refs = goto_refs, - active_goto_labels = active_goto_labels } - - fun clear_break_ref ({ ctxt, vars, struct_types, struct_fields, - global_consts, array_decls, enum_consts, typedef_tab, func_ret_types, - func_param_types, ref_addr_ty, ref_gv_ty, break_ref = _, continue_ref, goto_refs, - active_goto_labels } : t) : t = - { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, - struct_fields = struct_fields, array_decls = array_decls, - enum_consts = enum_consts, - typedef_tab = typedef_tab, func_ret_types = func_ret_types, - func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, - break_ref = NONE, continue_ref = continue_ref, - goto_refs = goto_refs, active_goto_labels = active_goto_labels } - - fun get_goto_refs ({ goto_refs, ... } : t) = goto_refs - - fun set_goto_refs refs ({ ctxt, vars, struct_types, struct_fields, - global_consts, array_decls, enum_consts, typedef_tab, func_ret_types, - func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, goto_refs = _, - active_goto_labels } : t) : t = - { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, - struct_fields = struct_fields, array_decls = array_decls, - enum_consts = enum_consts, - typedef_tab = typedef_tab, func_ret_types = func_ret_types, - func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, - break_ref = break_ref, - continue_ref = continue_ref, goto_refs = refs, - active_goto_labels = active_goto_labels } - - fun lookup_goto_ref ({ goto_refs, ... } : t) name = - case List.find (fn (n, _) => n = name) goto_refs of - SOME (_, ref_term) => SOME ref_term - | NONE => NONE - - fun get_active_goto_labels ({ active_goto_labels, ... } : t) = - active_goto_labels - - fun set_active_goto_labels labels ({ ctxt, vars, struct_types, struct_fields, - global_consts, array_decls, enum_consts, typedef_tab, func_ret_types, - func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, goto_refs, - active_goto_labels = _ } : t) : t = - { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, - struct_fields = struct_fields, array_decls = array_decls, - enum_consts = enum_consts, typedef_tab = typedef_tab, - func_ret_types = func_ret_types, func_param_types = func_param_types, - ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, - break_ref = break_ref, continue_ref = continue_ref, - goto_refs = goto_refs, active_goto_labels = distinct (op =) labels } -end -\ - -subsection \Array Indexing Helper\ - -text \ - The @{text unat} function from the Word library is an abbreviation, not a logical - constant, so it cannot be referenced via @{text "\<^const_name>"} in ML. - We define a proper constant that wraps it. -\ - -definition c_idx_to_nat :: \'a::len word \ nat\ where - [simp]: \c_idx_to_nat w = unat w\ - -subsection \Stub Constants for Unsupported C Constructs\ - -text \ - Opaque constants for C constructs that cannot be translated. - They have no WP rules, so symbolic execution silently gets stuck - when encountering these. The translation succeeds, and the user - can see from the constant names which constructs need attention. -\ - -consts c_while_stub :: "('s, 'v, 'r, 'abort, 'i, 'o) expression" -consts c_goto_stub :: "('s, 'v, 'r, 'abort, 'i, 'o) expression" -consts c_unsupported :: "('s, 'v, 'r, 'abort, 'i, 'o) expression" -consts c_uninitialized :: "'a" - -definition c_bounds_abort :: "('s, 'v, 'r, 'abort, 'i, 'o) expression" where [simp]: - "c_bounds_abort \ abort undefined" - -subsection \Term Construction\ - -text \ - Functions for building well-formed core monad terms. Each function - constructs a term using the actual constants from @{theory "Shallow_Micro_Rust.Core_Expression"}. -\ - -ML \ -structure C_Term_Build : sig - val mk_literal_unit : term - val mk_literal : term -> term - val mk_function_body : term -> term - val mk_sequence : term -> term -> term - val mk_literal_num : C_Ast_Utils.c_numeric_type -> int -> term - val mk_literal_int : int -> term - val mk_return_func : term -> term - val mk_bind : term -> term -> term - val mk_var_alloc : term -> term - val mk_var_alloc_typed : typ -> term -> term - val mk_var_read : term -> term - val mk_var_write : term -> term -> term - val mk_bindlift2 : term -> term -> term -> term - val mk_bind2 : term -> term -> term -> term - val mk_bind2_unseq : term -> term -> term -> term - val mk_two_armed_cond : term -> term -> term -> term - val mk_one_armed_cond : term -> term -> term - val mk_funcall : term -> term list -> term - val mk_raw_for_loop : term -> term -> term - val mk_upt_int_range : term -> term -> term - val mk_deref : term -> term - val mk_ptr_write : term -> term -> term - val mk_struct_field_read : term -> term -> term - val mk_struct_field_write : term -> term -> term -> term - val mk_unat : term -> term - val mk_focus_nth : term -> term -> term - val mk_focus_field : term -> term -> term - val mk_bounded_while : term -> term -> term -> term - val mk_goto_stub : term - val mk_unsupported_stub : term -end = -struct - (* literal v *) - fun mk_literal v = - Const (\<^const_name>\literal\, dummyT --> dummyT) $ v - - (* literal () : the "skip" operation *) - val mk_literal_unit = - Const (\<^const_name>\literal\, \<^typ>\unit\ --> dummyT) $ HOLogic.unit - - (* FunctionBody e *) - fun mk_function_body body = - Const (\<^const_name>\FunctionBody\, dummyT --> dummyT) $ body - - (* sequence e1 e2 *) - fun mk_sequence e1 e2 = - Const (\<^const_name>\sequence\, dummyT --> dummyT --> dummyT) $ e1 $ e2 - - (* literal n, typed according to the given c_numeric_type *) - fun mk_literal_num cty n = - let val T = C_Ast_Utils.hol_type_of cty - in Const (\<^const_name>\literal\, T --> dummyT) $ HOLogic.mk_number T n end - - (* literal n, where n is a C integer constant. - Uses dummyT so Isabelle infers the correct word type from context - (e.g. 32 sword in signed expressions, 32 word in unsigned). *) - fun mk_literal_int n = - Const (\<^const_name>\literal\, dummyT --> dummyT) $ HOLogic.mk_number dummyT n - - (* return_func e : for C return statements *) - fun mk_return_func body = - Const (\<^const_name>\return_func\, dummyT --> dummyT) $ body - - (* bind e f : monadic bind *) - fun mk_bind e f = - Const (\<^const_name>\bind\, dummyT --> dummyT --> dummyT) $ e $ f - - (* Allocate a new mutable variable: funcall1 store_reference_const init_expr *) - fun mk_var_alloc init_expr = - Const (\<^const_name>\funcall1\, dummyT --> dummyT --> dummyT) - $ Const (\<^const_name>\store_reference_const\, dummyT) - $ init_expr - - (* Type-annotated variant: constrains the value type of store_reference_const - so adhoc overloading can resolve when multiple word-type prisms exist. *) - fun mk_var_alloc_typed val_hol_type init_expr = - if val_hol_type = dummyT then mk_var_alloc init_expr - else - Const (\<^const_name>\funcall1\, dummyT --> dummyT --> dummyT) - $ Const (\<^const_name>\store_reference_const\, val_hol_type --> dummyT) - $ init_expr - (* Read a mutable variable: bind (literal ref) (deep_compose1 call store_dereference_const) *) - fun mk_var_read ref_var = - Const (\<^const_name>\bind\, dummyT --> dummyT --> dummyT) - $ mk_literal ref_var - $ (Const (\<^const_name>\deep_compose1\, dummyT --> dummyT --> dummyT) - $ Const (\<^const_name>\call\, dummyT --> dummyT) - $ Const (\<^const_name>\store_dereference_const\, dummyT)) - - (* Write a mutable variable: bind2 (deep_compose2 call store_update_const) (literal ref) val_expr *) - fun mk_var_write ref_var val_expr = - Const (\<^const_name>\bind2\, dummyT --> dummyT --> dummyT --> dummyT) - $ (Const (\<^const_name>\deep_compose2\, dummyT --> dummyT --> dummyT) - $ Const (\<^const_name>\call\, dummyT --> dummyT) - $ Const (\<^const_name>\store_update_const\, dummyT)) - $ mk_literal ref_var - $ val_expr - fun mk_bindlift2 f e1 e2 = - Const (\<^const_name>\bindlift2\, dummyT --> dummyT --> dummyT --> dummyT) - $ f $ e1 $ e2 - - (* bind2 f e1 e2 : evaluate e1 and e2, then apply monadic f *) - fun mk_bind2 f e1 e2 = - Const (\<^const_name>\bind2\, dummyT --> dummyT --> dummyT --> dummyT) - $ f $ e1 $ e2 - - (* bind2_unseq f e1 e2 : evaluate e1/e2 in unspecified order, then apply monadic f *) - fun mk_bind2_unseq f e1 e2 = - Const (\<^const_name>\bind2_unseq\, dummyT --> dummyT --> dummyT --> dummyT) - $ f $ e1 $ e2 - - (* two_armed_conditional test then_br else_br *) - fun mk_two_armed_cond test then_br else_br = - Const (\<^const_name>\two_armed_conditional\, dummyT --> dummyT --> dummyT --> dummyT) - $ test $ then_br $ else_br - - (* one_armed_conditional test then_br *) - fun mk_one_armed_cond test then_br = - Const (\<^const_name>\two_armed_conditional\, dummyT --> dummyT --> dummyT --> dummyT) - $ test $ then_br $ mk_literal_unit - - (* funcallN f arg0 ... argN : call a function with N arguments *) - local - val funcall_names = Vector.fromList [ - \<^const_name>\funcall0\, \<^const_name>\funcall1\, \<^const_name>\funcall2\, - \<^const_name>\funcall3\, \<^const_name>\funcall4\, \<^const_name>\funcall5\, - \<^const_name>\funcall6\, \<^const_name>\funcall7\, \<^const_name>\funcall8\, - \<^const_name>\funcall9\, \<^const_name>\funcall10\, - \<^const_name>\funcall11\, \<^const_name>\funcall12\, \<^const_name>\funcall13\, - \<^const_name>\funcall14\, \<^const_name>\funcall15\, \<^const_name>\funcall16\ - ] - in - fun mk_funcall f args = - let val n = length args - in if n > 16 then error "mk_funcall: more than 16 arguments not supported" - else let val cname = Vector.sub (funcall_names, n) - val ty = Library.foldr (fn (_, t) => dummyT --> t) (args, dummyT) - in Library.foldl (op $) (Const (cname, dummyT --> ty), f :: args) end - end - end - - (* raw_for_loop range_list body_fn *) - fun mk_raw_for_loop range body = - Const (\<^const_name>\raw_for_loop\, dummyT --> dummyT --> dummyT) $ range $ body - - (* Build [start..\List.map\, dummyT --> dummyT --> dummyT) - $ Const (\<^const_name>\of_nat\, dummyT) - $ (Const (\<^const_name>\upt\, dummyT --> dummyT --> dummyT) $ start_nat $ bound_nat) - - (* Dereference a pointer expression: bind ptr_expr (deep_compose1 call store_dereference_const) - This generalizes mk_var_read from literal variables to arbitrary expressions. *) - fun mk_deref ptr_expr = - Const (\<^const_name>\bind\, dummyT --> dummyT --> dummyT) - $ ptr_expr - $ (Const (\<^const_name>\deep_compose1\, dummyT --> dummyT --> dummyT) - $ Const (\<^const_name>\call\, dummyT --> dummyT) - $ Const (\<^const_name>\store_dereference_const\, dummyT)) - - (* Write through a pointer expression: bind2 (deep_compose2 call store_update_const) ptr_expr val_expr - This generalizes mk_var_write from literal variables to arbitrary expressions. *) - fun mk_ptr_write ptr_expr val_expr = - Const (\<^const_name>\bind2\, dummyT --> dummyT --> dummyT --> dummyT) - $ (Const (\<^const_name>\deep_compose2\, dummyT --> dummyT --> dummyT) - $ Const (\<^const_name>\call\, dummyT --> dummyT) - $ Const (\<^const_name>\store_update_const\, dummyT)) - $ ptr_expr - $ val_expr - - (* Struct field read: dereference pointer, then extract field via accessor. - Generates: bind (deref ptr_expr) (\v. literal (accessor v)) *) - fun mk_struct_field_read accessor_const ptr_expr = - let val v = Free ("v__struct", dummyT) - in mk_bind (mk_deref ptr_expr) - (Term.lambda v (mk_literal (accessor_const $ v))) - end - - (* Struct field write: evaluate rhs, dereference pointer, update field, write back. - Generates: bind val_expr (\rhs. bind (deref ptr) (\v. ptr_write ptr (updater (\_. rhs) v))) *) - fun mk_struct_field_write updater_const ptr_expr val_expr = - let val rhs_var = Free ("v__rhs", dummyT) - val struct_var = Free ("v__struct", dummyT) - val dummy_var = Free ("_uu__", dummyT) - val updated = updater_const $ (Term.lambda dummy_var rhs_var) $ struct_var - in mk_bind val_expr (Term.lambda rhs_var - (mk_bind (mk_deref ptr_expr) (Term.lambda struct_var - (mk_ptr_write ptr_expr (mk_literal updated))))) - end - - (* c_idx_to_nat idx : convert word to nat for array indexing (wraps unat) *) - fun mk_unat idx_term = - Const (\<^const_name>\c_idx_to_nat\, dummyT --> dummyT) $ idx_term - - (* focus_focused (nth_focus idx_nat) ref_term : focus reference to nth element *) - fun mk_focus_nth idx_nat ref_term = - Const (\<^const_name>\focus_focused\, dummyT --> dummyT --> dummyT) - $ (Const (\<^const_name>\nth_focus\, dummyT --> dummyT) $ idx_nat) - $ ref_term - - fun mk_focus_field focus_const ref_term = - Const (\<^const_name>\focus_focused\, dummyT --> dummyT --> dummyT) - $ focus_const - $ ref_term - - (* bounded_while fuel cond body *) - fun mk_bounded_while fuel cond body = - Const (\<^const_name>\bounded_while\, dummyT --> dummyT --> dummyT --> dummyT) - $ fuel $ cond $ body - - (* Stub constants for unsupported C constructs *) - val mk_goto_stub = Const (\<^const_name>\c_goto_stub\, dummyT) - val mk_unsupported_stub = Const (\<^const_name>\c_unsupported\, dummyT) -end -\ - -subsection \Statement and Expression Translation\ - -text \ - The core translation: C AST nodes are mapped to core monad expressions. - Unsupported constructs produce explicit errors identifying the construct - that could not be translated. -\ - -ML \ -structure C_Translate : sig - val translate_stmt : C_Trans_Ctxt.t -> C_Ast.nodeInfo C_Ast.cStatement -> term - val set_decl_prefix : string -> unit - val set_union_names : string list -> unit - val current_union_names : string list Unsynchronized.ref - val set_ref_universe_types : typ -> typ -> unit - val set_ref_abort_type : typ option -> unit - val strip_isa_fun_type : typ -> typ list - val defined_func_consts : string Symtab.table Unsynchronized.ref - val defined_func_fuels : int Symtab.table Unsynchronized.ref - val translate_fundef : (string * C_Ast_Utils.c_numeric_type) list Symtab.table - -> int Symtab.table - -> C_Ast_Utils.c_numeric_type Symtab.table - -> C_Ast_Utils.c_numeric_type Symtab.table Unsynchronized.ref - -> C_Ast_Utils.c_numeric_type list Symtab.table Unsynchronized.ref - -> (string * term * C_Ast_Utils.c_numeric_type * - (C_Ast_Utils.c_numeric_type * int) option * string option) list - -> Proof.context - -> C_Ast.nodeInfo C_Ast.cFunctionDef -> string * term -end = -struct - (* Save Isabelle term constructors before C_Ast shadows them *) - val Isa_Const = Const - val Isa_Free = Free - val isa_dummyT = dummyT - val Isa_add_frees = Term.add_frees - val Isa_Type = Type - - (* Table mapping fixed-variable names to qualified const names. - Populated by C_Def_Gen.define_c_function using target_morphism - (the standard Isabelle mechanism from specification.ML:269). *) - val defined_func_consts : string Symtab.table Unsynchronized.ref = - Unsynchronized.ref Symtab.empty - - (* Table mapping function names to their fuel parameter count. - Populated by translate_fundef after abstracting while_fuel variables. *) - val defined_func_fuels : int Symtab.table Unsynchronized.ref = - Unsynchronized.ref Symtab.empty - - (* Generate a fresh variable name not occurring free in the given terms *) - fun fresh_var terms stem typ = - let val used = List.foldl (fn (t, acc) => Isa_add_frees t acc) [] terms - |> List.map fst - val (name, _) = Name.variant stem (Name.make_context used) - in Isa_Free (name, typ) end - - fun expr_value_type tm = - (case fastype_of tm of - Type (_, _ :: vty :: _) => vty - | _ => isa_dummyT) - - fun cty_of_hol_type T = - if T = @{typ bool} then SOME C_Ast_Utils.CBool - else if T = \<^typ>\c_int\ then SOME C_Ast_Utils.CInt - else if T = \<^typ>\c_uint\ then SOME C_Ast_Utils.CUInt - else if T = \<^typ>\c_char\ then SOME C_Ast_Utils.CChar - else if T = \<^typ>\c_schar\ then SOME C_Ast_Utils.CSChar - else if T = \<^typ>\c_short\ then SOME C_Ast_Utils.CShort - else if T = \<^typ>\c_ushort\ then SOME C_Ast_Utils.CUShort - else if T = \<^typ>\c_long\ then SOME C_Ast_Utils.CLong - else if T = \<^typ>\c_ulong\ then SOME C_Ast_Utils.CULong - else NONE - - (* Binary operator classification: arithmetic/comparison/bitwise operators are - monadic and compose via bind2. - NB: Must be defined before 'open C_Ast' which shadows the term type. *) - datatype binop_kind = Monadic of term - - (* void* cast helper: generate c_cast_from_void with type-annotated prism. - The prism constant c_void_cast_prism_for is adhoc-overloaded; the type annotation - on the prism (constraining 'v to the target type) lets Isabelle resolve it. - Must be defined before 'open C_Ast' to use Const/Free/dummyT/Type. *) - fun mk_cast_from_void target_cty void_ptr_term = - let val target_ty = C_Ast_Utils.hol_type_of target_cty - val prism_ty = Type (\<^type_name>\prism\, [dummyT, target_ty]) - val prism_const = Const (\<^const_name>\c_void_cast_prism_for\, prism_ty) - val cast_const = Const (\<^const_name>\c_cast_from_void\, dummyT) - val v = Free ("v__void_cast", dummyT) - in C_Term_Build.mk_bind void_ptr_term - (Term.lambda v (C_Term_Build.mk_literal (cast_const $ prism_const $ v))) - end - - (* C11 implicit integer promotion cast. - Inserts c_scast or c_ucast when from_cty <> to_cty. - Cast direction: signed source \ c_scast (sign-extend), unsigned \ c_ucast (zero-extend). - Both c_scast/c_ucast are fully polymorphic: 'a word \ ('s, 'b word, ...) expression. - Must be defined before 'open C_Ast' to use Const/Free/dummyT. *) - fun mk_implicit_cast (tm, from_cty, to_cty) = - let - val tm_ty = expr_value_type tm - val to_ty = C_Ast_Utils.hol_type_of to_cty - in - if from_cty = to_cty then - if tm_ty <> isa_dummyT andalso tm_ty = to_ty then tm - else - let - val v = Isa_Free ("v__idcast", to_ty) - in - C_Term_Build.mk_bind tm (Term.lambda v (C_Term_Build.mk_literal v)) - end - else if tm_ty <> isa_dummyT andalso tm_ty = to_ty then tm - else if C_Ast_Utils.is_bool to_cty then - (* scalar -> _Bool : compare against zero *) - if C_Ast_Utils.is_ptr from_cty then - let val v = Isa_Free ("v__promo", isa_dummyT) - val addr_term = - Isa_Const (\<^const_name>\address\, isa_dummyT --> isa_dummyT) $ v - val neq_zero = - Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) - $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT --> isa_dummyT --> @{typ bool}) - $ addr_term - $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) - in C_Term_Build.mk_bind tm (Term.lambda v (C_Term_Build.mk_literal neq_zero)) end - else - let val from_ty = if C_Ast_Utils.is_bool from_cty - then @{typ bool} - else C_Ast_Utils.hol_type_of from_cty - val v = Isa_Free ("v__promo", from_ty) - val truthy_expr = - if C_Ast_Utils.is_bool from_cty then - C_Term_Build.mk_literal v - else if C_Ast_Utils.is_signed from_cty then - Const (\<^const_name>\c_signed_truthy\, isa_dummyT) $ v - else - Const (\<^const_name>\c_unsigned_truthy\, isa_dummyT) $ v - in C_Term_Build.mk_bind tm (Term.lambda v truthy_expr) end - else if C_Ast_Utils.is_bool from_cty then - (* Bool \ integer: if b then 1 else 0 *) - let val v = Isa_Free ("v__promo", @{typ bool}) - val one = C_Term_Build.mk_literal_num to_cty 1 - val zero = C_Term_Build.mk_literal_num to_cty 0 - in C_Term_Build.mk_bind tm - (Term.lambda v (C_Term_Build.mk_two_armed_cond - (C_Term_Build.mk_literal v) one zero)) end - else if to_cty = C_Ast_Utils.CVoid then - (* (void)expr is a no-op: just evaluate and discard the result *) - tm - else if C_Ast_Utils.is_ptr from_cty andalso C_Ast_Utils.is_ptr to_cty then - let fun is_void_like C_Ast_Utils.CVoid = true - | is_void_like (C_Ast_Utils.CUnion _) = true - | is_void_like _ = false - in case (from_cty, to_cty) of - (C_Ast_Utils.CPtr from_inner, C_Ast_Utils.CPtr to_inner) => - if is_void_like from_inner andalso is_void_like to_inner then tm - (* untyped -> T* : attach prism focus *) - else if is_void_like from_inner then mk_cast_from_void to_inner tm - (* T* -> untyped : strip focus *) - else if is_void_like to_inner then - let val v = Free ("v__cast", dummyT) - val cast = Const (\<^const_name>\c_cast_to_void\, dummyT) - in C_Term_Build.mk_bind tm (Term.lambda v (C_Term_Build.mk_literal (cast $ v))) - end - (* T* -> U* where neither is void/union: no-op *) - else tm - | _ => tm - end - else if C_Ast_Utils.is_ptr from_cty then - (* pointer -> integer cast via ABI uintptr type, then convert as needed *) - let val v = Free ("v__ptrint", dummyT) - val ptr_uint_cty = C_Ast_Utils.pointer_uint_cty () - val conv = Const (\<^const_name>\c_ptr_to_uintptr\, dummyT) - val as_ulong = C_Term_Build.mk_bind tm - (Term.lambda v (C_Term_Build.mk_literal (conv $ v))) - in if to_cty = ptr_uint_cty then as_ulong - else mk_implicit_cast (as_ulong, ptr_uint_cty, to_cty) - end - else if C_Ast_Utils.is_ptr to_cty then - (* integer -> pointer cast: widen/narrow to ABI uintptr then convert *) - let val ptr_uint_cty = C_Ast_Utils.pointer_uint_cty () - val as_ulong = if from_cty = ptr_uint_cty then tm - else mk_implicit_cast (tm, from_cty, ptr_uint_cty) - val v = Free ("v__intptr", dummyT) - val conv = Const (\<^const_name>\c_uintptr_to_ptr\, dummyT) - in C_Term_Build.mk_bind as_ulong - (Term.lambda v (C_Term_Build.mk_literal (conv $ v))) - end - else let val cast_const = - if C_Ast_Utils.is_signed from_cty - then Const (\<^const_name>\c_scast\, isa_dummyT) - else Const (\<^const_name>\c_ucast\, isa_dummyT) - (* Type-annotate the lambda variable with the source HOL type - so c_scast/c_ucast input type is fully determined. *) - val from_ty = - let val explicit = C_Ast_Utils.hol_type_of from_cty - in if tm_ty <> isa_dummyT then tm_ty else explicit end - val v = Isa_Free ("v__promo", from_ty) - in C_Term_Build.mk_bind tm (Term.lambda v (cast_const $ v)) end - end - - (* Current function's return type, set by translate_fundef before translating - the function body. Used by CReturn0 to insert narrowing casts. *) - val current_ret_cty : C_Ast_Utils.c_numeric_type option Unsynchronized.ref = - Unsynchronized.ref NONE - val current_decl_prefix : string Unsynchronized.ref = - Unsynchronized.ref "c_" - val current_union_names : string list Unsynchronized.ref = - Unsynchronized.ref [] - val current_ref_addr_ty : typ Unsynchronized.ref = - Unsynchronized.ref (TFree ("'addr", [])) - val current_ref_gv_ty : typ Unsynchronized.ref = - Unsynchronized.ref (TFree ("'gv", [])) - (* Full expression type constraint: constrains state/abort/prompt positions - so type inference doesn't leave them as unconstrained TFrees. - Built by micro_c_file handler from locale's reference_types parameter. *) - val current_ref_expr_constraint : typ option Unsynchronized.ref = - Unsynchronized.ref NONE - - fun strip_isa_fun_type (Type ("fun", [A, B])) = A :: strip_isa_fun_type B - | strip_isa_fun_type _ = [] - - fun set_decl_prefix pfx = (current_decl_prefix := pfx) - fun set_union_names names = current_union_names := names - fun set_ref_universe_types addr_ty gv_ty = - (current_ref_addr_ty := addr_ty; current_ref_gv_ty := gv_ty) - fun set_ref_abort_type abort_opt = (current_ref_expr_constraint := abort_opt) - - - open C_Ast - - fun unsupported construct = - error ("micro_c_translate: unsupported C construct: " ^ construct) - - fun normalize_ref_universe_type tctx ty = - let - val addr_ty = C_Trans_Ctxt.get_ref_addr_ty tctx - val gv_ty = C_Trans_Ctxt.get_ref_gv_ty tctx - fun go (Term.Type (name, args)) = - let - val args' = List.map go args - in - (case args' of - [Term.Type (gname, [_ , _]), _, vty] => - if Long_Name.base_name name = "focused" - andalso Long_Name.base_name gname = "gref" - then Isa_Type (name, [Isa_Type (gname, [addr_ty, gv_ty]), gv_ty, vty]) - else Isa_Type (name, args') - | _ => Isa_Type (name, args')) - end - | go t = t - in go ty end - - fun mk_typed_ref_var tctx name alloc_expr = - Isa_Free (name, normalize_ref_universe_type tctx (expr_value_type alloc_expr)) - - fun resolve_visible_const_term ctxt short_name = - let - val direct = - SOME (Proof_Context.read_const {proper = true, strict = false} ctxt short_name) - handle ERROR _ => NONE - val result = - case direct of - SOME (Term.Const (n, _)) => SOME (Isa_Const (n, isa_dummyT)) - | SOME (Term.Free (x, _)) => - (* In locale context, read_const returns Free for locally-fixed - variables. Look up the qualified const name — first from our - table (populated via target_morphism after each define), then - via Variable.lookup_const (for locale parameters). Use - Consts.type_scheme to get the polymorphic type with TVars. *) - let - val c_opt = - (case Symtab.lookup (!defined_func_consts) x of - SOME c => SOME c - | NONE => Variable.lookup_const ctxt x) - in - (case c_opt of - SOME c => - ((let val _ = Consts.type_scheme (Proof_Context.consts_of ctxt) c - in SOME (Isa_Const (c, isa_dummyT)) end) - handle TYPE _ => NONE) - | NONE => NONE) - end - | _ => - let - val full_name = Proof_Context.intern_const ctxt short_name - val thy = Proof_Context.theory_of ctxt - in - if can (Sign.the_const_type thy) full_name - then SOME (Isa_Const (full_name, isa_dummyT)) - else NONE - end - in result end - - fun mk_flag_ref_type tctx = - let - val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 - val alloc_expr = - C_Term_Build.mk_var_alloc_typed - (C_Ast_Utils.hol_type_of C_Ast_Utils.CUInt) false_lit - in - normalize_ref_universe_type tctx (expr_value_type alloc_expr) - end - - (* Translate a C binary operator to a HOL function constant, dispatching - signed vs unsigned based on the operand type. - Arithmetic, comparison and bitwise operations use the overflow-checked - C operations from C_Numeric_Types which are monadic (they can abort). *) - fun translate_binop cty CAddOp0 = - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_add\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_add\, isa_dummyT)) - | translate_binop cty CSubOp0 = - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_sub\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_sub\, isa_dummyT)) - | translate_binop cty CMulOp0 = - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_mul\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_mul\, isa_dummyT)) - | translate_binop cty CDivOp0 = - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_div\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_div\, isa_dummyT)) - | translate_binop cty CRmdOp0 = - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_mod\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_mod\, isa_dummyT)) - | translate_binop cty CLeOp0 = - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_less\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_less\, isa_dummyT)) - | translate_binop cty CLeqOp0 = - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_le\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_le\, isa_dummyT)) - | translate_binop cty CGrOp0 = (* reversed operands *) - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_less\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_less\, isa_dummyT)) - | translate_binop cty CGeqOp0 = (* reversed operands *) - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_le\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_le\, isa_dummyT)) - | translate_binop cty CEqOp0 = - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_eq\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_eq\, isa_dummyT)) - | translate_binop cty CNeqOp0 = - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_neq\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_neq\, isa_dummyT)) - | translate_binop cty CAndOp0 = (* bitwise AND *) - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_and\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_and\, isa_dummyT)) - | translate_binop cty CXorOp0 = (* bitwise XOR *) - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_xor\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_xor\, isa_dummyT)) - | translate_binop cty COrOp0 = (* bitwise OR *) - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_or\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_or\, isa_dummyT)) - | translate_binop cty CShlOp0 = (* left shift *) - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_shl\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_shl\, isa_dummyT)) - | translate_binop cty CShrOp0 = (* right shift *) - if C_Ast_Utils.is_signed cty - then Monadic (Isa_Const (\<^const_name>\c_signed_shr\, isa_dummyT)) - else Monadic (Isa_Const (\<^const_name>\c_unsigned_shr\, isa_dummyT)) - | translate_binop _ _ = unsupported "unsupported binary operator" - - (* Check if a given aggregate name refers to a union (not a struct). *) - fun is_union_aggregate name = - List.exists (fn n => n = name) (!current_union_names) - - (* Determine the C struct type of a variable expression. - Handles simple variable references and chained member access (p->vec[i].coeffs). *) - fun determine_struct_type tctx (CVar0 (ident, _)) = - let val name = C_Ast_Utils.ident_name ident - in case C_Trans_Ctxt.get_struct_type tctx name of - SOME sname => sname - | NONE => error ("micro_c_translate: cannot determine struct type for: " ^ name) - end - | determine_struct_type tctx (CMember0 (inner_expr, field_ident, _, _)) = - let val inner_struct = determine_struct_type tctx inner_expr - val field_name = C_Ast_Utils.ident_name field_ident - in case C_Trans_Ctxt.lookup_struct_field_type tctx inner_struct field_name of - SOME (C_Ast_Utils.CStruct sname) => sname - | SOME (C_Ast_Utils.CPtr (C_Ast_Utils.CStruct sname)) => sname - | SOME (C_Ast_Utils.CUnion sname) => sname - | SOME (C_Ast_Utils.CPtr (C_Ast_Utils.CUnion sname)) => sname - | _ => error ("micro_c_translate: field " ^ field_name ^ " of " ^ - inner_struct ^ " is not a struct/union type") - end - | determine_struct_type tctx (CUnary0 (CIndOp0, inner_expr, _)) = - (* *p where p points to a struct — recurse to determine struct type *) - determine_struct_type tctx inner_expr - | determine_struct_type tctx (CIndex0 (inner_expr, _, _)) = - (* arr[i] where arr is a struct field — the struct type comes from the array expression *) - determine_struct_type tctx inner_expr - | determine_struct_type _ _ = - error "micro_c_translate: struct member access on complex expression not yet supported" - - (* Resolve a struct field accessor/updater constant by naming convention. - Prefix defaults to "c_" and can be overridden via command options. *) - fun struct_accessor_name struct_name field_name = - !current_decl_prefix ^ struct_name ^ "_" ^ field_name - - fun struct_updater_name struct_name field_name = - "update_" ^ struct_accessor_name struct_name field_name - - fun struct_focus_name struct_name field_name = - struct_accessor_name struct_name field_name ^ "_focus" - - fun resolve_const ctxt name = - let val (full_name, _) = Term.dest_Const - (Proof_Context.read_const {proper = true, strict = true} ctxt name) - in Isa_Const (full_name, isa_dummyT) end - - fun try_resolve_const ctxt name = - SOME (resolve_const ctxt name) handle ERROR _ => NONE - - fun pick_preferred_const_by_base ctxt pred = - let - val consts_info = Consts.dest (Proof_Context.consts_of ctxt) - val names = map #1 (#constants consts_info) - val matches = List.filter pred names - fun base n = Long_Name.base_name n - fun pref_rank n = - let val b = base n in - if String.isPrefix (!current_decl_prefix) b then 0 - else if String.isPrefix "c_" b then 1 - else 2 - end - fun best [] = NONE - | best (n :: ns) = - SOME (List.foldl (fn (m, acc) => if pref_rank m < pref_rank acc then m else acc) n ns) - in - best matches - end - - fun resolve_struct_accessor_const ctxt struct_name field_name = - let - val suffix = struct_name ^ "_" ^ field_name - val explicit = - [ struct_accessor_name struct_name field_name - , (!current_decl_prefix ^ struct_name) ^ "." ^ struct_accessor_name struct_name field_name - , struct_name ^ "." ^ struct_accessor_name struct_name field_name - ] - fun try_explicit [] = NONE - | try_explicit (n :: ns) = - (case try_resolve_const ctxt n of SOME c => SOME c | NONE => try_explicit ns) - in - case try_explicit explicit of - SOME c => c - | NONE => - (case pick_preferred_const_by_base ctxt - (fn full => - let val b = Long_Name.base_name full in - String.isSuffix suffix b andalso - not (String.isPrefix "update_" b) andalso - not (String.isSuffix "_focus" b) - end) of - SOME full => Isa_Const (full, isa_dummyT) - | NONE => - error ("micro_c_translate: missing struct field accessor constant: " ^ - struct_accessor_name struct_name field_name)) - end - - fun resolve_struct_updater_const ctxt struct_name field_name = - let - val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name - val (accessor_full, _) = Term.dest_Const accessor_const - val qualifier = Long_Name.qualifier accessor_full - val accessor_base = Long_Name.base_name accessor_full - val updater_base = "update_" ^ accessor_base - val qualified = if qualifier = "" then updater_base else qualifier ^ "." ^ updater_base - val suffix = "update_" ^ struct_name ^ "_" ^ field_name - in - case try_resolve_const ctxt qualified of - SOME c => c - | NONE => - (case try_resolve_const ctxt updater_base of - SOME c => c - | NONE => - (case pick_preferred_const_by_base ctxt - (fn full => String.isSuffix suffix (Long_Name.base_name full)) of - SOME full => Isa_Const (full, isa_dummyT) - | NONE => - error ("micro_c_translate: missing struct field updater constant: " ^ - struct_updater_name struct_name field_name))) - end - - fun resolve_struct_focus_const ctxt struct_name field_name = - let - val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name - val updater_const = resolve_struct_updater_const ctxt struct_name field_name - val (accessor_full, _) = Term.dest_Const accessor_const - val qualifier = Long_Name.qualifier accessor_full - val accessor_base = Long_Name.base_name accessor_full - val focus_base = accessor_base ^ "_focus" - val record_name = !current_decl_prefix ^ struct_name - val candidates = - [ if qualifier = "" then focus_base else qualifier ^ "." ^ focus_base - , focus_base - , struct_focus_name struct_name field_name - , record_name ^ "." ^ struct_focus_name struct_name field_name - , struct_name ^ "." ^ struct_focus_name struct_name field_name - ] - fun mk_focus_from_lens () = - let - val make_lens_const = resolve_const ctxt "make_lens_via_view_modify" - val lens_to_focus_raw_const = resolve_const ctxt "lens_to_focus_raw" - val abs_focus_const = resolve_const ctxt "Abs_focus" - val lens = - make_lens_const $ accessor_const $ updater_const - val focus_raw = lens_to_focus_raw_const $ lens - in - abs_focus_const $ focus_raw - end - fun try_names [] = mk_focus_from_lens () - | try_names (n :: ns) = - (resolve_const ctxt n handle ERROR _ => try_names ns) - in - try_names candidates - end - - fun resolve_dereference_const ctxt = - (let - val (full_name, _) = - Term.dest_Const - (Proof_Context.read_const {proper = true, strict = false} ctxt "dereference_fun") - in - Isa_Const (full_name, isa_dummyT) - end - handle ERROR _ => - Isa_Const (\<^const_name>\store_dereference_const\, isa_dummyT)) - - fun mk_resolved_var_alloc_typed ctxt val_hol_type init_expr = - let val ref_const = - (resolve_const ctxt "store_reference_const" - handle ERROR _ => - if val_hol_type = isa_dummyT - then Isa_Const (\<^const_name>\store_reference_const\, isa_dummyT) - else Isa_Const (\<^const_name>\store_reference_const\, val_hol_type --> isa_dummyT)) - val ref_const = - if val_hol_type = isa_dummyT then ref_const - else - let val (full_name, _) = Term.dest_Const ref_const - in Isa_Const (full_name, val_hol_type --> isa_dummyT) end - in C_Term_Build.mk_funcall ref_const [init_expr] end - - fun mk_resolved_var_alloc ctxt init_expr = - mk_resolved_var_alloc_typed ctxt isa_dummyT init_expr - - (* Variable read: delegates to mk_var_read. *) - fun mk_resolved_var_read _ ref_var = - C_Term_Build.mk_var_read ref_var - - fun mk_pair_eval unseq ltm rtm lvar rvar body = - if unseq then - C_Term_Build.mk_bind2_unseq (Term.lambda lvar (Term.lambda rvar body)) ltm rtm - else - C_Term_Build.mk_bind ltm (Term.lambda lvar - (C_Term_Build.mk_bind rtm (Term.lambda rvar body))) - - fun mk_index_guard idx_p_cty i_var list_tm body_term = - let - val idx_nat = C_Term_Build.mk_unat i_var - val len_tm = - Isa_Const (\<^const_name>\size\, isa_dummyT --> @{typ nat}) $ list_tm - val in_bounds = - Isa_Const (\<^const_name>\Orderings.less\, @{typ nat} --> @{typ nat} --> @{typ bool}) - $ idx_nat $ len_tm - val overflow = Isa_Const (\<^const_name>\c_bounds_abort\, isa_dummyT) - val guarded_upper = - C_Term_Build.mk_two_armed_cond (C_Term_Build.mk_literal in_bounds) body_term overflow - in - if C_Ast_Utils.is_signed idx_p_cty then - let - val lt_zero = - C_Term_Build.mk_bind2 - (Isa_Const (\<^const_name>\c_signed_less\, isa_dummyT)) - (C_Term_Build.mk_literal i_var) - (C_Term_Build.mk_literal_num idx_p_cty 0) - in - C_Term_Build.mk_two_armed_cond lt_zero overflow guarded_upper - end - else guarded_upper - end - - (* Helper for pre/post increment/decrement. - is_inc: true for increment, false for decrement - is_pre: true for pre (return new), false for post (return old) - expr_fn / lvalue_fn: callbacks for translate_expr / translate_lvalue_location - passed from the mutual-recursion group where those functions are in scope. *) - fun translate_inc_dec _ _ tctx is_inc is_pre (CVar0 (ident, _)) = - let val name = C_Ast_Utils.ident_name ident - in case C_Trans_Ctxt.lookup_var tctx name of - SOME (C_Trans_Ctxt.Local, ref_var, cty) => - let val old_var = Isa_Free ("v__old", isa_dummyT) - val new_var = Isa_Free ("v__new", isa_dummyT) - val arith_cty = C_Ast_Utils.integer_promote cty - val one = C_Term_Build.mk_literal_num arith_cty 1 - val arith_const = - if is_inc then - (if C_Ast_Utils.is_signed arith_cty - then Isa_Const (\<^const_name>\c_signed_add\, isa_dummyT) - else Isa_Const (\<^const_name>\c_unsigned_add\, isa_dummyT)) - else - (if C_Ast_Utils.is_signed arith_cty - then Isa_Const (\<^const_name>\c_signed_sub\, isa_dummyT) - else Isa_Const (\<^const_name>\c_unsigned_sub\, isa_dummyT)) - val read = C_Term_Build.mk_var_read ref_var - val old_promoted = - mk_implicit_cast (C_Term_Build.mk_literal old_var, cty, arith_cty) - val add = C_Term_Build.mk_bind2 arith_const - old_promoted one - val new_assigned = - mk_implicit_cast (C_Term_Build.mk_literal new_var, arith_cty, cty) - val write = C_Term_Build.mk_var_write ref_var - new_assigned - val return_term = - if is_pre then new_assigned else C_Term_Build.mk_literal old_var - in (C_Term_Build.mk_bind read (Term.lambda old_var - (C_Term_Build.mk_bind add (Term.lambda new_var - (C_Term_Build.mk_sequence write - return_term)))), cty) end - | SOME (C_Trans_Ctxt.Param, _, _) => - error ("micro_c_translate: cannot increment/decrement parameter: " ^ name) - | NONE => - (case C_Trans_Ctxt.lookup_global_const tctx name of - SOME _ => - error ("micro_c_translate: cannot increment/decrement global constant: " ^ name) - | NONE => - error ("micro_c_translate: undefined variable: " ^ name)) - end - (* inc/dec through pointer dereference *) - | translate_inc_dec expr_fn _ tctx is_inc is_pre (CUnary0 (CIndOp0, ptr_expr, _)) = - let val (ptr_term, ptr_cty) = expr_fn tctx ptr_expr - val pointee_cty = - (case ptr_cty of C_Ast_Utils.CPtr inner => inner - | _ => unsupported "increment/decrement dereference on non-pointer") - val arith_cty = C_Ast_Utils.integer_promote pointee_cty - val one = C_Term_Build.mk_literal_num arith_cty 1 - val arith_const = - if is_inc then - (if C_Ast_Utils.is_signed arith_cty - then Isa_Const (\<^const_name>\c_signed_add\, isa_dummyT) - else Isa_Const (\<^const_name>\c_unsigned_add\, isa_dummyT)) - else - (if C_Ast_Utils.is_signed arith_cty - then Isa_Const (\<^const_name>\c_signed_sub\, isa_dummyT) - else Isa_Const (\<^const_name>\c_unsigned_sub\, isa_dummyT)) - val ptr_var = Isa_Free ("v__ptr", isa_dummyT) - val old_var = Isa_Free ("v__old", isa_dummyT) - val new_var = Isa_Free ("v__new", isa_dummyT) - val old_promoted = - mk_implicit_cast (C_Term_Build.mk_literal old_var, pointee_cty, arith_cty) - val add = C_Term_Build.mk_bind2 arith_const old_promoted one - val new_assigned = - mk_implicit_cast (C_Term_Build.mk_literal new_var, arith_cty, pointee_cty) - val return_term = - if is_pre then new_assigned else C_Term_Build.mk_literal old_var - in (C_Term_Build.mk_bind ptr_term (Term.lambda ptr_var - (C_Term_Build.mk_bind - (C_Term_Build.mk_deref (C_Term_Build.mk_literal ptr_var)) - (Term.lambda old_var - (C_Term_Build.mk_bind add (Term.lambda new_var - (C_Term_Build.mk_sequence - (C_Term_Build.mk_ptr_write - (C_Term_Build.mk_literal ptr_var) - new_assigned) - return_term)))))), - pointee_cty) end - (* inc/dec struct field via p->f or s.f *) - | translate_inc_dec expr_fn lvalue_fn tctx is_inc is_pre (CMember0 (expr, field_ident, is_ptr, _)) = - let val field_name = C_Ast_Utils.ident_name field_ident - val struct_name = determine_struct_type tctx expr - val ctxt = C_Trans_Ctxt.get_ctxt tctx - val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name - val updater_const = resolve_struct_updater_const ctxt struct_name field_name - val ptr_term = if is_ptr then #1 (expr_fn tctx expr) - else #1 (lvalue_fn tctx expr) - val field_cty = - (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of - SOME cty => cty - | NONE => unsupported ("unknown struct field: " ^ struct_name ^ "." ^ field_name)) - val arith_cty = C_Ast_Utils.integer_promote field_cty - val one = C_Term_Build.mk_literal_num arith_cty 1 - val arith_const = - if is_inc then - (if C_Ast_Utils.is_signed arith_cty - then Isa_Const (\<^const_name>\c_signed_add\, isa_dummyT) - else Isa_Const (\<^const_name>\c_unsigned_add\, isa_dummyT)) - else - (if C_Ast_Utils.is_signed arith_cty - then Isa_Const (\<^const_name>\c_signed_sub\, isa_dummyT) - else Isa_Const (\<^const_name>\c_unsigned_sub\, isa_dummyT)) - val ptr_var = Isa_Free ("v__ptr", isa_dummyT) - val struct_var = Isa_Free ("v__struct", isa_dummyT) - val new_var = Isa_Free ("v__new", isa_dummyT) - val old_val = accessor_const $ struct_var - val old_promoted = - mk_implicit_cast (C_Term_Build.mk_literal old_val, field_cty, arith_cty) - val add = C_Term_Build.mk_bind2 arith_const old_promoted one - val new_assigned = - mk_implicit_cast (C_Term_Build.mk_literal new_var, arith_cty, field_cty) - val return_term = - if is_pre then new_assigned else C_Term_Build.mk_literal old_val - val updated_struct = - updater_const - $ Term.lambda (Isa_Free ("_uu", isa_dummyT)) new_assigned - $ struct_var - in (C_Term_Build.mk_bind ptr_term (Term.lambda ptr_var - (C_Term_Build.mk_bind - (C_Term_Build.mk_deref (C_Term_Build.mk_literal ptr_var)) - (Term.lambda struct_var - (C_Term_Build.mk_bind add (Term.lambda new_var - (C_Term_Build.mk_sequence - (C_Term_Build.mk_ptr_write - (C_Term_Build.mk_literal ptr_var) - (C_Term_Build.mk_literal updated_struct)) - return_term)))))), - field_cty) end - (* inc/dec array element via arr[i] *) - | translate_inc_dec expr_fn _ tctx is_inc is_pre (CIndex0 (arr_expr, idx_expr, _)) = - let val (arr_term, arr_cty) = expr_fn tctx arr_expr - val (idx_term_raw, idx_cty) = expr_fn tctx idx_expr - val idx_p_cty = C_Ast_Utils.integer_promote idx_cty - val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) - val elem_cty = (case arr_cty of - C_Ast_Utils.CPtr inner => inner - | _ => unsupported "increment/decrement on non-array indexing") - val arith_cty = C_Ast_Utils.integer_promote elem_cty - val one = C_Term_Build.mk_literal_num arith_cty 1 - val arith_const = - if is_inc then - (if C_Ast_Utils.is_signed arith_cty - then Isa_Const (\<^const_name>\c_signed_add\, isa_dummyT) - else Isa_Const (\<^const_name>\c_unsigned_add\, isa_dummyT)) - else - (if C_Ast_Utils.is_signed arith_cty - then Isa_Const (\<^const_name>\c_signed_sub\, isa_dummyT) - else Isa_Const (\<^const_name>\c_unsigned_sub\, isa_dummyT)) - val a_var = Isa_Free ("v__arr", isa_dummyT) - val i_var = Isa_Free ("v__idx", isa_dummyT) - val loc_var = Isa_Free ("v__loc", isa_dummyT) - val old_var = Isa_Free ("v__old", isa_dummyT) - val new_var = Isa_Free ("v__new", isa_dummyT) - val unseq_operands = - C_Ast_Utils.expr_has_side_effect arr_expr orelse - C_Ast_Utils.expr_has_side_effect idx_expr - val focused = C_Term_Build.mk_focus_nth (C_Term_Build.mk_unat i_var) a_var - val loc_expr = - mk_pair_eval unseq_operands arr_term idx_term a_var i_var - (mk_index_guard idx_p_cty i_var a_var (C_Term_Build.mk_literal focused)) - val old_promoted = - mk_implicit_cast (C_Term_Build.mk_literal old_var, elem_cty, arith_cty) - val add = C_Term_Build.mk_bind2 arith_const old_promoted one - val new_assigned = - mk_implicit_cast (C_Term_Build.mk_literal new_var, arith_cty, elem_cty) - val return_term = - if is_pre then new_assigned else C_Term_Build.mk_literal old_var - in (C_Term_Build.mk_bind loc_expr (Term.lambda loc_var - (C_Term_Build.mk_bind - (C_Term_Build.mk_deref (C_Term_Build.mk_literal loc_var)) - (Term.lambda old_var - (C_Term_Build.mk_bind add (Term.lambda new_var - (C_Term_Build.mk_sequence - (C_Term_Build.mk_ptr_write - (C_Term_Build.mk_literal loc_var) - new_assigned) - return_term)))))), - elem_cty) end - | translate_inc_dec _ _ _ _ _ _ = - unsupported "increment/decrement on unsupported expression" - - - - fun is_shift_binop CShlOp0 = true - | is_shift_binop CShrOp0 = true - | is_shift_binop _ = false - - (* C11 compound assignment arithmetic: - e1 op= e2 is computed in the same arithmetic type as e1 op e2 - (with integer promotions/usual conversions), then converted back to e1 type. *) - fun prepare_compound_operands lhs_cty rhs_tm rhs_cty binop lhs_old_tm = - if is_shift_binop binop then - let - val lhs_prom_cty = C_Ast_Utils.integer_promote lhs_cty - val rhs_prom_cty = C_Ast_Utils.integer_promote rhs_cty - val lhs_prom = mk_implicit_cast (lhs_old_tm, lhs_cty, lhs_prom_cty) - val rhs_prom = - mk_implicit_cast - (mk_implicit_cast (rhs_tm, rhs_cty, rhs_prom_cty), rhs_prom_cty, lhs_prom_cty) - in - (lhs_prom_cty, lhs_prom, rhs_prom) - end - else - let - val op_cty = C_Ast_Utils.usual_arith_conv (lhs_cty, rhs_cty) - val lhs_prom = mk_implicit_cast (lhs_old_tm, lhs_cty, op_cty) - val rhs_prom = mk_implicit_cast (rhs_tm, rhs_cty, op_cty) - in - (op_cty, lhs_prom, rhs_prom) - end - - fun compound_op_cty lhs_cty rhs_cty binop = - if is_shift_binop binop - then C_Ast_Utils.integer_promote lhs_cty - else C_Ast_Utils.usual_arith_conv (lhs_cty, rhs_cty) - - (* Map compound assignment operators to their binary operator equivalents *) - fun compound_assign_to_binop CAddAssOp0 = SOME CAddOp0 - | compound_assign_to_binop CSubAssOp0 = SOME CSubOp0 - | compound_assign_to_binop CMulAssOp0 = SOME CMulOp0 - | compound_assign_to_binop CDivAssOp0 = SOME CDivOp0 - | compound_assign_to_binop CRmdAssOp0 = SOME CRmdOp0 - | compound_assign_to_binop CShlAssOp0 = SOME CShlOp0 - | compound_assign_to_binop CShrAssOp0 = SOME CShrOp0 - | compound_assign_to_binop CAndAssOp0 = SOME CAndOp0 - | compound_assign_to_binop CXorAssOp0 = SOME CXorOp0 - | compound_assign_to_binop COrAssOp0 = SOME COrOp0 - | compound_assign_to_binop _ = NONE - - fun intinf_to_int_checked what n = - let - val ge_min = - (case Int.minInt of - SOME lo => n >= IntInf.fromInt lo - | NONE => true) - val le_max = - (case Int.maxInt of - SOME hi => n <= IntInf.fromInt hi - | NONE => true) - in - if ge_min andalso le_max then IntInf.toInt n - else error ("micro_c_translate: " ^ what ^ " out of ML-int range: " ^ IntInf.toString n) - end - - val cty_bit_width = C_Ast_Utils.bit_width_of - val sizeof_c_type = C_Ast_Utils.sizeof_c_type - val alignof_c_type = C_Ast_Utils.alignof_c_type - - (* Compute struct size with ABI alignment padding. - Each field aligned to alignof(field); total rounded up to max alignment. *) - fun sizeof_struct (fields : (string * C_Ast_Utils.c_numeric_type) list) = - let fun align_up (offset, alignment) = - let val rem = offset mod alignment - in if rem = 0 then offset else offset + (alignment - rem) end - val (total_size, max_align) = - List.foldl (fn ((_, field_cty), (offset, max_a)) => - let val field_size = sizeof_c_type field_cty - val field_align = alignof_c_type field_cty - val aligned_offset = align_up (offset, field_align) - in (aligned_offset + field_size, Int.max (max_a, field_align)) end) - (0, 1) fields - val final_size = if max_align > 0 then align_up (total_size, max_align) else total_size - in final_size end - - fun fits_int_literal_cty cty n = - case cty_bit_width cty of - NONE => false - | SOME bits => - let val two_pow = IntInf.pow (2, bits) - in - if C_Ast_Utils.is_signed cty then - let - val maxp1 = IntInf.pow (2, bits - 1) - val lo = ~ maxp1 - val hi = maxp1 - 1 - in lo <= n andalso n <= hi end - else - 0 <= n andalso n < two_pow - end - - fun choose_int_literal_type n flags = - let - val unsuffixed = - (case flags of - Flags0 bits => IntInf.andb (bits, 7) = 0) - in - (case C_Ast_Utils.int_literal_type flags of - C_Ast_Utils.CInt => - if fits_int_literal_cty C_Ast_Utils.CInt n then C_Ast_Utils.CInt - else if unsuffixed then - unsupported "unsuffixed integer literal beyond int range is not supported; add an explicit U/L suffix" - else if fits_int_literal_cty C_Ast_Utils.CLong n then C_Ast_Utils.CLong - else unsupported "integer literal out of supported signed range" - | C_Ast_Utils.CUInt => - if fits_int_literal_cty C_Ast_Utils.CUInt n then C_Ast_Utils.CUInt - else if fits_int_literal_cty C_Ast_Utils.CULong n then C_Ast_Utils.CULong - else unsupported "integer literal out of supported unsigned range" - | C_Ast_Utils.CLong => - if fits_int_literal_cty C_Ast_Utils.CLong n then C_Ast_Utils.CLong - else unsupported "integer literal out of supported long range" - | C_Ast_Utils.CULong => - if fits_int_literal_cty C_Ast_Utils.CULong n then C_Ast_Utils.CULong - else unsupported "integer literal out of supported unsigned long range" - | cty => cty) - end - - - - (* --- Switch statement helpers --- *) - - (* Unwrap nested case/default labels from the C AST. - CCase0(1, CCase0(2, stmt)) becomes labels=[SOME 1, SOME 2], stmt *) - fun unwrap_case_labels (CCase0 (expr, inner, _)) labels = - unwrap_case_labels inner (SOME expr :: labels) - | unwrap_case_labels (CDefault0 (inner, _)) labels = - unwrap_case_labels inner (NONE :: labels) - | unwrap_case_labels stmt labels = (rev labels, stmt) - - (* Extract case groups from flat switch body items. - Returns list of {labels, body, has_break}. *) - fun extract_switch_groups items = - let - fun close_group labels body has_break acc = - if null labels then acc - else {labels = rev labels, body = rev body, has_break = has_break} :: acc - fun walk [] labels body acc = rev (close_group labels body false acc) - | walk (CBlockStmt0 (stmt as CCase0 _) :: rest) labels body acc = - let val acc' = close_group labels body false acc - val (new_labels, first_stmt) = unwrap_case_labels stmt [] - in walk rest new_labels [CBlockStmt0 first_stmt] acc' end - | walk (CBlockStmt0 (stmt as CDefault0 _) :: rest) labels body acc = - let val acc' = close_group labels body false acc - val (new_labels, first_stmt) = unwrap_case_labels stmt [] - in walk rest new_labels [CBlockStmt0 first_stmt] acc' end - | walk (CBlockStmt0 (CBreak0 _) :: rest) labels body acc = - let val acc' = close_group labels body true acc - in walk rest [] [] acc' end - | walk (item :: rest) labels body acc = - walk rest labels (item :: body) acc - in walk items [] [] [] end - - (* Translate a case label expression to a pure HOL value *) - fun case_label_value switch_cty _ (CConst0 (CIntConst0 (CInteger0 (n, _, _), _))) = - HOLogic.mk_number (C_Ast_Utils.hol_type_of switch_cty) - (intinf_to_int_checked "switch case label" n) - | case_label_value switch_cty tctx (CVar0 (ident, _)) = - let val name = C_Ast_Utils.ident_name ident - in case C_Trans_Ctxt.lookup_enum_const tctx name of - SOME v => HOLogic.mk_number (C_Ast_Utils.hol_type_of switch_cty) v - | NONE => error ("micro_c_translate: unsupported case label: " ^ name) - end - | case_label_value _ _ _ = error "micro_c_translate: unsupported case label expression" - - (* Build condition for a case group: switch_var = label1 OR ... OR labelN. - Default labels map to default_cond, which should be ~(any explicit case matched). *) - fun make_switch_cond switch_var switch_cty tctx default_cond labels = - let fun one_label (SOME e) = - HOLogic.mk_eq (switch_var, case_label_value switch_cty tctx e) - | one_label NONE = default_cond - fun combine [] = Isa_Const (\<^const_name>\HOL.False\, @{typ bool}) - | combine [c] = c - | combine (c :: cs) = - Isa_Const (\<^const_name>\HOL.disj\, - @{typ bool} --> @{typ bool} --> @{typ bool}) $ c $ (combine cs) - in combine (List.map one_label labels) end - - (* Build a condition that says whether switch_var matches any explicit case label. *) - fun make_any_case_match switch_var switch_cty tctx groups = - let val labels = List.concat (List.map #labels groups) - |> List.mapPartial I - fun one_label e = HOLogic.mk_eq (switch_var, case_label_value switch_cty tctx e) - fun combine [] = Isa_Const (\<^const_name>\HOL.False\, @{typ bool}) - | combine [c] = c - | combine (c :: cs) = - Isa_Const (\<^const_name>\HOL.disj\, - @{typ bool} --> @{typ bool} --> @{typ bool}) $ c $ (combine cs) - in combine (List.map one_label labels) end - - (* --- Break/continue AST scanners --- *) - - fun contains_break (CBreak0 _) = true - | contains_break (CCompound0 (_, items, _)) = List.exists block_has_break items - | contains_break (CIf0 (_, t_br, e_opt, _)) = - contains_break t_br orelse - (case e_opt of Some e => contains_break e | None => false) - | contains_break (CSwitch0 _) = false (* break in switch exits switch, not loop *) - | contains_break (CFor0 _) = false (* break in nested loop is local *) - | contains_break (CWhile0 _) = false - | contains_break _ = false - and block_has_break (CBlockStmt0 s) = contains_break s - | block_has_break _ = false - - fun contains_continue (CCont0 _) = true - | contains_continue (CCompound0 (_, items, _)) = List.exists block_has_continue items - | contains_continue (CIf0 (_, t_br, e_opt, _)) = - contains_continue t_br orelse - (case e_opt of Some e => contains_continue e | None => false) - | contains_continue (CFor0 _) = false - | contains_continue (CWhile0 _) = false - | contains_continue _ = false - and block_has_continue (CBlockStmt0 s) = contains_continue s - | block_has_continue _ = false - - fun struct_name_of_cty (C_Ast_Utils.CStruct sname) = SOME sname - | struct_name_of_cty (C_Ast_Utils.CPtr (C_Ast_Utils.CStruct sname)) = SOME sname - | struct_name_of_cty (C_Ast_Utils.CUnion sname) = SOME sname - | struct_name_of_cty (C_Ast_Utils.CPtr (C_Ast_Utils.CUnion sname)) = SOME sname - | struct_name_of_cty _ = NONE - - fun is_zero_int_const (CConst0 (CIntConst0 (CInteger0 (n, _, _), _))) = (n = 0) - | is_zero_int_const (CCast0 (_, e, _)) = is_zero_int_const e - | is_zero_int_const _ = false - - fun mk_ptr_is_null ptr_term = - let val p = Isa_Free ("v__ptrcmp", isa_dummyT) - val is_null = - Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT --> isa_dummyT --> @{typ bool}) - $ (Isa_Const (\<^const_name>\address\, isa_dummyT --> isa_dummyT) $ p) - $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT) - in C_Term_Build.mk_bind ptr_term (Term.lambda p (C_Term_Build.mk_literal is_null)) end - - (* translate_expr returns (term * c_numeric_type). - The type tracks the C type of the expression for binary operator dispatch. - CInt is used as default when the actual type is unknown/irrelevant. *) - fun translate_expr _ (CConst0 (CIntConst0 (CInteger0 (n, _, flags), _))) = - let val cty = choose_int_literal_type n flags - val n_int = intinf_to_int_checked "integer literal" n - in (C_Term_Build.mk_literal_num cty n_int, cty) - end - | translate_expr tctx (CVar0 (ident, _)) = - let val name = C_Ast_Utils.ident_name ident - in case C_Trans_Ctxt.lookup_var tctx name of - SOME (C_Trans_Ctxt.Param, var, cty) => (C_Term_Build.mk_literal var, cty) - | SOME (C_Trans_Ctxt.Local, var, cty) => - (* For local arrays, the ref IS the pointer (array-to-pointer decay). - Return it directly so CIndex0's deref accesses the list correctly. - For regular locals, use generic dereference to keep the monad universe - polymorphic across pure helper calls. *) - if Option.isSome (C_Trans_Ctxt.lookup_array_decl tctx name) - then (C_Term_Build.mk_literal var, cty) - else (C_Term_Build.mk_var_read var, cty) - | NONE => - (* Fallback: check global consts, then enum constants *) - (case C_Trans_Ctxt.lookup_global_const tctx name of - SOME (tm, cty) => (C_Term_Build.mk_literal tm, cty) - | NONE => - (case C_Trans_Ctxt.lookup_enum_const tctx name of - SOME value => (C_Term_Build.mk_literal_int value, C_Ast_Utils.CInt) - | NONE => error ("micro_c_translate: undefined variable: " ^ name))) - end - | translate_expr tctx (CBinary0 (binop, lhs, rhs, _)) = - let val (lhs', lhs_cty) = translate_expr tctx lhs - val (rhs', rhs_cty) = translate_expr tctx rhs - val unseq_operands = - C_Ast_Utils.expr_has_side_effect lhs orelse C_Ast_Utils.expr_has_side_effect rhs - val _ = - if unseq_operands andalso C_Ast_Utils.expr_has_unsequenced_ub_risk lhs rhs then - unsupported "potential unsequenced side-effect UB in binary expression" - else () - fun to_bool (tm, cty) = mk_implicit_cast (tm, cty, C_Ast_Utils.CBool) - fun mk_ptr_add ptr_term idx_term idx_cty elem_cty = - let val p_var = Isa_Free ("v__ptr", isa_dummyT) - val i_var = Isa_Free ("v__idx", isa_dummyT) - val idx_p_cty = C_Ast_Utils.integer_promote idx_cty - val idx_p_term = mk_implicit_cast (idx_term, idx_cty, idx_p_cty) - val focused = C_Term_Build.mk_focus_nth (C_Term_Build.mk_unat i_var) p_var - val focused_lit = C_Term_Build.mk_literal focused - val guarded = mk_index_guard idx_p_cty i_var p_var focused_lit - in (mk_pair_eval unseq_operands ptr_term idx_p_term p_var i_var guarded, - C_Ast_Utils.CPtr elem_cty) - end - in - case binop of - (* C logical operators short-circuit and return _Bool *) - CLndOp0 => - let val lhs_bool = to_bool (lhs', lhs_cty) - val rhs_bool = to_bool (rhs', rhs_cty) - val v = Isa_Free ("v__lhsb", @{typ bool}) - in (C_Term_Build.mk_bind lhs_bool (Term.lambda v - (C_Term_Build.mk_two_armed_cond - (C_Term_Build.mk_literal v) - rhs_bool - (C_Term_Build.mk_literal (Isa_Const (\<^const_name>\HOL.False\, @{typ bool}))))), - C_Ast_Utils.CBool) - end - | CLorOp0 => - let val lhs_bool = to_bool (lhs', lhs_cty) - val rhs_bool = to_bool (rhs', rhs_cty) - val v = Isa_Free ("v__lhsb", @{typ bool}) - in (C_Term_Build.mk_bind lhs_bool (Term.lambda v - (C_Term_Build.mk_two_armed_cond - (C_Term_Build.mk_literal v) - (C_Term_Build.mk_literal (Isa_Const (\<^const_name>\HOL.True\, @{typ bool}))) - rhs_bool)), - C_Ast_Utils.CBool) - end - | _ => - (* Pointer arithmetic: p + n or n + p via focus_nth *) - (case (binop, lhs_cty, rhs_cty) of - (CEqOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => - let val l = Isa_Free ("v__lptr", isa_dummyT) - val r = Isa_Free ("v__rptr", isa_dummyT) - val eq_t = Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT --> isa_dummyT --> @{typ bool}) $ l $ r - in (mk_pair_eval unseq_operands lhs' rhs' l r (C_Term_Build.mk_literal eq_t), - C_Ast_Utils.CBool) - end - | (CNeqOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => - let val l = Isa_Free ("v__lptr", isa_dummyT) - val r = Isa_Free ("v__rptr", isa_dummyT) - val neq_t = - Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) - $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT --> isa_dummyT --> @{typ bool}) $ l $ r) - in (mk_pair_eval unseq_operands lhs' rhs' l r (C_Term_Build.mk_literal neq_t), - C_Ast_Utils.CBool) - end - | (CEqOp0, C_Ast_Utils.CPtr _, _) => - if is_zero_int_const rhs then - (mk_ptr_is_null lhs', C_Ast_Utils.CBool) - else - unsupported "pointer comparison with non-pointer operand" - | (CEqOp0, _, C_Ast_Utils.CPtr _) => - if is_zero_int_const lhs then - (mk_ptr_is_null rhs', C_Ast_Utils.CBool) - else - unsupported "pointer comparison with non-pointer operand" - | (CNeqOp0, C_Ast_Utils.CPtr _, _) => - if is_zero_int_const rhs then - let val b = Isa_Free ("v__isnull", @{typ bool}) - in (C_Term_Build.mk_bind (mk_ptr_is_null lhs') (Term.lambda b - (C_Term_Build.mk_literal - (Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) $ b))), - C_Ast_Utils.CBool) - end - else - unsupported "pointer comparison with non-pointer operand" - | (CNeqOp0, _, C_Ast_Utils.CPtr _) => - if is_zero_int_const lhs then - let val b = Isa_Free ("v__isnull", @{typ bool}) - in (C_Term_Build.mk_bind (mk_ptr_is_null rhs') (Term.lambda b - (C_Term_Build.mk_literal - (Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) $ b))), - C_Ast_Utils.CBool) - end - else - unsupported "pointer comparison with non-pointer operand" - | (CLeOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => - unsupported "pointer relational comparison" - | (CLeqOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => - unsupported "pointer relational comparison" - | (CGrOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => - unsupported "pointer relational comparison" - | (CGeqOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => - unsupported "pointer relational comparison" - | (CLeOp0, C_Ast_Utils.CPtr _, _) => - unsupported "pointer relational comparison with non-pointer operand" - | (CLeOp0, _, C_Ast_Utils.CPtr _) => - unsupported "pointer relational comparison with non-pointer operand" - | (CLeqOp0, C_Ast_Utils.CPtr _, _) => - unsupported "pointer relational comparison with non-pointer operand" - | (CLeqOp0, _, C_Ast_Utils.CPtr _) => - unsupported "pointer relational comparison with non-pointer operand" - | (CGrOp0, C_Ast_Utils.CPtr _, _) => - unsupported "pointer relational comparison with non-pointer operand" - | (CGrOp0, _, C_Ast_Utils.CPtr _) => - unsupported "pointer relational comparison with non-pointer operand" - | (CGeqOp0, C_Ast_Utils.CPtr _, _) => - unsupported "pointer relational comparison with non-pointer operand" - | (CGeqOp0, _, C_Ast_Utils.CPtr _) => - unsupported "pointer relational comparison with non-pointer operand" - | (CAddOp0, C_Ast_Utils.CPtr elem_cty, _) => - mk_ptr_add lhs' rhs' rhs_cty elem_cty - | (CAddOp0, _, C_Ast_Utils.CPtr elem_cty) => - (* n + p = p + n *) - mk_ptr_add rhs' lhs' lhs_cty elem_cty - | (CSubOp0, C_Ast_Utils.CPtr elem_cty, C_Ast_Utils.CPtr _) => - let val isa_ty = C_Ast_Utils.hol_type_of elem_cty - val itself_ty = Isa_Type (\<^type_name>\itself\, [isa_ty]) - val type_term = Isa_Const (\<^const_name>\Pure.type\, itself_ty) - val stride = Isa_Const (\<^const_name>\c_sizeof\, - itself_ty --> @{typ nat}) $ type_term - val p_var = Isa_Free ("v__lptr", isa_dummyT) - val q_var = Isa_Free ("v__rptr", isa_dummyT) - val diff_body = Isa_Const (\<^const_name>\c_ptr_diff\, isa_dummyT) - $ p_var $ q_var $ stride - val f = Term.lambda p_var (Term.lambda q_var diff_body) - in (C_Term_Build.mk_bindlift2 f lhs' rhs', - C_Ast_Utils.pointer_int_cty ()) - end - | _ => - let - (* C11 integer promotion and usual arithmetic conversions. - Shifts: each operand independently promoted, result = promoted LHS. - Other ops: usual_arith_conv determines common type. *) - val is_shift = case binop of CShlOp0 => true | CShrOp0 => true | _ => false - val (cty, lhs_p, rhs_p) = - if is_shift then - let val lp_cty = C_Ast_Utils.integer_promote lhs_cty - val rp_cty = C_Ast_Utils.integer_promote rhs_cty - in (lp_cty, - mk_implicit_cast (lhs', lhs_cty, lp_cty), - mk_implicit_cast - (mk_implicit_cast (rhs', rhs_cty, rp_cty), rp_cty, lp_cty)) end - else - let val conv_cty = C_Ast_Utils.usual_arith_conv (lhs_cty, rhs_cty) - in (conv_cty, - mk_implicit_cast (lhs', lhs_cty, conv_cty), - mk_implicit_cast (rhs', rhs_cty, conv_cty)) end - (* For > and >=, swap operands to use < and <= *) - val (l, r) = case binop of CGrOp0 => (rhs_p, lhs_p) - | CGeqOp0 => (rhs_p, lhs_p) - | _ => (lhs_p, rhs_p) - (* Comparisons return CBool — they produce Isabelle bool values *) - val result_cty = case binop of - CLeOp0 => C_Ast_Utils.CBool | CLeqOp0 => C_Ast_Utils.CBool - | CGrOp0 => C_Ast_Utils.CBool | CGeqOp0 => C_Ast_Utils.CBool - | CEqOp0 => C_Ast_Utils.CBool | CNeqOp0 => C_Ast_Utils.CBool - | _ => cty - in case translate_binop cty binop of - Monadic f => - ((if unseq_operands then C_Term_Build.mk_bind2_unseq f l r - else C_Term_Build.mk_bind2 f l r), result_cty) - end) - end - (* p->field = rhs / s.field = rhs : struct/union field write *) - | translate_expr tctx (CAssign0 (CAssignOp0, CMember0 (expr, field_ident, is_ptr, _), rhs, _)) = - let val field_name = C_Ast_Utils.ident_name field_ident - val struct_name = determine_struct_type tctx expr - in if is_union_aggregate struct_name then - (* Union field write: cast to typed ref, then write *) - let val field_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of - SOME cty => cty - | NONE => unsupported ("unknown union field type: " ^ struct_name ^ "." ^ field_name)) - val ptr_expr = if is_ptr then #1 (translate_expr tctx expr) - else #1 (translate_lvalue_location tctx expr) - val (rhs', rhs_cty) = translate_expr tctx rhs - val rhs_cast = mk_implicit_cast (rhs', rhs_cty, field_cty) - val cast_expr = mk_cast_from_void field_cty ptr_expr - val rhs_var = Isa_Free ("v__rhs", isa_dummyT) - val ref_var = Isa_Free ("v__uref", isa_dummyT) - val unseq_lhs_rhs = - C_Ast_Utils.expr_has_side_effect expr orelse C_Ast_Utils.expr_has_side_effect rhs - val _ = - if unseq_lhs_rhs andalso C_Ast_Utils.expr_has_unsequenced_ub_risk expr rhs then - unsupported "potential unsequenced side-effect UB in union-field assignment" - else () - val assign_fun = - Term.lambda rhs_var (Term.lambda ref_var - (C_Term_Build.mk_sequence - (C_Term_Build.mk_ptr_write - (C_Term_Build.mk_literal ref_var) - (C_Term_Build.mk_literal rhs_var)) - (C_Term_Build.mk_literal rhs_var))) - val assign_term = - (if unseq_lhs_rhs - then C_Term_Build.mk_bind2_unseq assign_fun rhs_cast cast_expr - else C_Term_Build.mk_bind2 assign_fun rhs_cast cast_expr) - in (assign_term, field_cty) end - else - let val ctxt = C_Trans_Ctxt.get_ctxt tctx - val updater_const = resolve_struct_updater_const ctxt struct_name field_name - val ptr_expr = if is_ptr then #1 (translate_expr tctx expr) - else #1 (translate_lvalue_location tctx expr) - val field_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of - SOME cty => cty - | NONE => unsupported ("unknown struct field type: " ^ struct_name ^ "." ^ field_name)) - val (rhs', rhs_cty) = translate_expr tctx rhs - val rhs_cast = mk_implicit_cast (rhs', rhs_cty, field_cty) - val rhs_var = Isa_Free ("v__rhs", isa_dummyT) - val ptr_var = Isa_Free ("v__ptr", isa_dummyT) - val struct_var = Isa_Free ("v__struct", isa_dummyT) - val dummy_var = Isa_Free ("_uu__", isa_dummyT) - val updated_struct = - updater_const $ (Term.lambda dummy_var rhs_var) $ struct_var - val unseq_lhs_rhs = - C_Ast_Utils.expr_has_side_effect expr orelse C_Ast_Utils.expr_has_side_effect rhs - val _ = - if unseq_lhs_rhs andalso C_Ast_Utils.expr_has_unsequenced_ub_risk expr rhs then - unsupported "potential unsequenced side-effect UB in struct-field assignment" - else () - val assign_fun = - Term.lambda rhs_var (Term.lambda ptr_var - (C_Term_Build.mk_bind - (C_Term_Build.mk_deref (C_Term_Build.mk_literal ptr_var)) - (Term.lambda struct_var - (C_Term_Build.mk_sequence - (C_Term_Build.mk_ptr_write - (C_Term_Build.mk_literal ptr_var) - (C_Term_Build.mk_literal updated_struct)) - (C_Term_Build.mk_literal rhs_var))))) - val assign_term = - (if unseq_lhs_rhs - then C_Term_Build.mk_bind2_unseq assign_fun rhs_cast ptr_expr - else C_Term_Build.mk_bind2 assign_fun rhs_cast ptr_expr) - in (assign_term, - field_cty) - end end - (* p->field op= rhs / s.field op= rhs : compound struct/union field write *) - | translate_expr tctx (CAssign0 (asgn_op, CMember0 (expr, field_ident, is_ptr, _), rhs, _)) = - (case compound_assign_to_binop asgn_op of - SOME binop => - let val field_name = C_Ast_Utils.ident_name field_ident - val struct_name = determine_struct_type tctx expr - val field_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of - SOME cty => cty - | NONE => unsupported ("unknown field type: " ^ struct_name ^ "." ^ field_name)) - val ptr_term = if is_ptr then #1 (translate_expr tctx expr) - else #1 (translate_lvalue_location tctx expr) - val (rhs_term_raw, rhs_cty) = translate_expr tctx rhs - val op_cty = compound_op_cty field_cty rhs_cty binop - val rhs_var = Isa_Free ("v__rhs", isa_dummyT) - val old_var = Isa_Free ("v__old", isa_dummyT) - val new_var = Isa_Free ("v__new", isa_dummyT) - val unseq_lhs_rhs = - C_Ast_Utils.expr_has_side_effect expr orelse C_Ast_Utils.expr_has_side_effect rhs - val _ = - if unseq_lhs_rhs andalso C_Ast_Utils.expr_has_unsequenced_ub_risk expr rhs then - unsupported "potential unsequenced side-effect UB in field compound assignment" - else () - in if is_union_aggregate struct_name then - (* Union: cast void ptr to typed ref, deref, compute, write back *) - case translate_binop op_cty binop of - Monadic f => - let - val ref_var = Isa_Free ("v__uref", isa_dummyT) - val cast_expr = mk_cast_from_void field_cty ptr_term - val combine_rhs_ref = - if unseq_lhs_rhs then C_Term_Build.mk_bind2_unseq else C_Term_Build.mk_bind2 - val assign_fun = - Term.lambda rhs_var (Term.lambda ref_var - (C_Term_Build.mk_bind - (C_Term_Build.mk_deref (C_Term_Build.mk_literal ref_var)) - (Term.lambda old_var - (let - val (_, old_prom, rhs_prom) = - prepare_compound_operands - field_cty - (C_Term_Build.mk_literal rhs_var) - rhs_cty - binop - (C_Term_Build.mk_literal old_var) - in - C_Term_Build.mk_bind - (C_Term_Build.mk_bind2 f old_prom rhs_prom) - (Term.lambda new_var - (let - val new_assigned = - mk_implicit_cast - (C_Term_Build.mk_literal new_var, op_cty, field_cty) - in - C_Term_Build.mk_sequence - (C_Term_Build.mk_ptr_write - (C_Term_Build.mk_literal ref_var) - new_assigned) - new_assigned - end)) - end)))) - val assign_term = combine_rhs_ref assign_fun rhs_term_raw cast_expr - in - (assign_term, field_cty) - end - else - (* Struct: deref ptr, accessor/updater pattern *) - let val ctxt = C_Trans_Ctxt.get_ctxt tctx - val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name - val updater_const = resolve_struct_updater_const ctxt struct_name field_name - val ptr_var = Isa_Free ("v__ptr", isa_dummyT) - val struct_var = Isa_Free ("v__struct", isa_dummyT) - val old_val = accessor_const $ struct_var - in case translate_binop op_cty binop of - Monadic f => - let - val combine_rhs_ptr = - if unseq_lhs_rhs then C_Term_Build.mk_bind2_unseq else C_Term_Build.mk_bind2 - val assign_fun = - Term.lambda rhs_var (Term.lambda ptr_var - (C_Term_Build.mk_bind - (C_Term_Build.mk_deref (C_Term_Build.mk_literal ptr_var)) - (Term.lambda struct_var - (C_Term_Build.mk_bind - (let - val (_, old_prom, rhs_prom) = - prepare_compound_operands - field_cty - (C_Term_Build.mk_literal rhs_var) - rhs_cty - binop - (C_Term_Build.mk_literal old_val) - in - C_Term_Build.mk_bind2 f old_prom rhs_prom - end) - (Term.lambda new_var - (let - val new_assigned = - mk_implicit_cast - (C_Term_Build.mk_literal new_var, op_cty, field_cty) - val updated_struct = - updater_const - $ Term.lambda (Isa_Free ("_uu", isa_dummyT)) new_assigned - $ struct_var - in - C_Term_Build.mk_sequence - (C_Term_Build.mk_ptr_write - (C_Term_Build.mk_literal ptr_var) - (C_Term_Build.mk_literal updated_struct)) - new_assigned - end)))))) - val assign_term = combine_rhs_ptr assign_fun rhs_term_raw ptr_term - in - (assign_term, field_cty) - end - end - end - | NONE => unsupported "unsupported compound operator on struct field") - (* p->field[idx] = rhs / s.field[idx] = rhs : struct field array write *) - | translate_expr tctx (CAssign0 (CAssignOp0, - CIndex0 (CMember0 (expr, field_ident, is_ptr, _), idx_expr, _), rhs, _)) = - let val field_name = C_Ast_Utils.ident_name field_ident - val struct_name = determine_struct_type tctx expr - val ctxt = C_Trans_Ctxt.get_ctxt tctx - val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name - val updater_const = resolve_struct_updater_const ctxt struct_name field_name - val deref_const = resolve_dereference_const ctxt - val ptr_expr = if is_ptr then #1 (translate_expr tctx expr) - else #1 (translate_lvalue_location tctx expr) - val (idx_term_raw, idx_cty) = translate_expr tctx idx_expr - val idx_p_cty = C_Ast_Utils.integer_promote idx_cty - val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) - val (rhs_term_raw, rhs_cty) = translate_expr tctx rhs - (* Side effects in rhs/idx/ptr are safe: the bind chain below - sequences evaluation as rhs, then ptr, then deref, then idx. *) - val ptr_var = Isa_Free ("v__ptr", isa_dummyT) - val struct_var = Isa_Free ("v__struct", isa_dummyT) - val i_var = Isa_Free ("v__idx", isa_dummyT) - val v_var = Isa_Free ("v__rhs", isa_dummyT) - val old_list = accessor_const $ struct_var - val new_list = Isa_Const (\<^const_name>\list_update\, - isa_dummyT --> isa_dummyT --> isa_dummyT --> isa_dummyT) - $ old_list $ (C_Term_Build.mk_unat i_var) $ v_var - val dummy_var = Isa_Free ("_uu__", isa_dummyT) - val new_struct = updater_const $ (Term.lambda dummy_var new_list) $ struct_var - val deref_expr = - Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ ptr_var) - $ (Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) - $ deref_const) - val field_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of - SOME (C_Ast_Utils.CPtr inner) => inner - | _ => unsupported "indexing non-array struct field") - val rhs_term = mk_implicit_cast (rhs_term_raw, rhs_cty, field_cty) - val write_term = - C_Term_Build.mk_ptr_write - (C_Term_Build.mk_literal ptr_var) - (C_Term_Build.mk_literal new_struct) - val write_term = mk_index_guard idx_p_cty i_var old_list write_term - val assign_term = - C_Term_Build.mk_bind rhs_term - (Term.lambda v_var - (C_Term_Build.mk_bind ptr_expr - (Term.lambda ptr_var - (C_Term_Build.mk_bind deref_expr - (Term.lambda struct_var - (C_Term_Build.mk_bind idx_term - (Term.lambda i_var - (C_Term_Build.mk_sequence - write_term - (C_Term_Build.mk_literal v_var))))))))) - in (assign_term, field_cty) - end - (* arr[idx] = rhs : array element write via focus *) - | translate_expr tctx (CAssign0 (CAssignOp0, CIndex0 (arr_expr, idx_expr, _), rhs, _)) = - let val (arr_term, arr_cty) = translate_expr tctx arr_expr - val (idx_term_raw, idx_cty) = translate_expr tctx idx_expr - val idx_p_cty = C_Ast_Utils.integer_promote idx_cty - val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) - val (rhs_term_raw, rhs_cty) = translate_expr tctx rhs - val elem_cty = (case arr_cty of - C_Ast_Utils.CPtr inner => inner - | _ => unsupported "indexing non-array expression") - (* Type-annotate v_var with the element HOL type to constrain - focus/store_update operations and resolve type variables - (e.g. TYPE('a)) for raw pointer parameters. *) - val elem_hol_ty = - let val t = C_Ast_Utils.hol_type_of elem_cty - in if t = isa_dummyT then isa_dummyT else t end - val a_var = Isa_Free ("v__arr", isa_dummyT) - val i_var = Isa_Free ("v__idx", isa_dummyT) - val v_var = Isa_Free ("v__rhs", elem_hol_ty) - val loc_var = Isa_Free ("v__loc", isa_dummyT) - val arr_has_effect = C_Ast_Utils.expr_has_side_effect arr_expr - val idx_has_effect = C_Ast_Utils.expr_has_side_effect idx_expr - val rhs_has_effect = C_Ast_Utils.expr_has_side_effect rhs - val arr_is_global_const = - (case arr_expr of - CVar0 (ident, _) => - (case C_Trans_Ctxt.lookup_global_const tctx (C_Ast_Utils.ident_name ident) of - SOME _ => true - | NONE => false) - | _ => false) - val unseq_lhs = arr_has_effect orelse idx_has_effect - val unseq_lhs_rhs = unseq_lhs orelse rhs_has_effect - val _ = - if arr_is_global_const then - unsupported "assignment to global constant array element" - else if unseq_lhs_rhs andalso - (C_Ast_Utils.expr_has_unsequenced_ub_risk arr_expr idx_expr orelse - C_Ast_Utils.expr_has_unsequenced_ub_risk arr_expr rhs orelse - C_Ast_Utils.expr_has_unsequenced_ub_risk idx_expr rhs) - then - unsupported "potential unsequenced side-effect UB in indexed assignment" - else () - val focused = C_Term_Build.mk_focus_nth (C_Term_Build.mk_unat i_var) a_var - val rhs_term = mk_implicit_cast (rhs_term_raw, rhs_cty, elem_cty) - val loc_expr = - mk_pair_eval unseq_lhs arr_term idx_term a_var i_var - (mk_index_guard idx_p_cty i_var a_var (C_Term_Build.mk_literal focused)) - val write_fun = - Term.lambda v_var (Term.lambda loc_var - (C_Term_Build.mk_sequence - (C_Term_Build.mk_ptr_write - (C_Term_Build.mk_literal loc_var) - (C_Term_Build.mk_literal v_var)) - (C_Term_Build.mk_literal v_var))) - val assign_term = - (if unseq_lhs_rhs - then C_Term_Build.mk_bind2_unseq write_fun rhs_term loc_expr - else C_Term_Build.mk_bind2 write_fun rhs_term loc_expr) - in (assign_term, elem_cty) - end - (* arr[idx] op= rhs : compound array element write *) - | translate_expr tctx (CAssign0 (asgn_op, CIndex0 (arr_expr, idx_expr, _), rhs, _)) = - (case compound_assign_to_binop asgn_op of - SOME binop => - let val (arr_term, arr_cty) = translate_expr tctx arr_expr - val (idx_term_raw, idx_cty) = translate_expr tctx idx_expr - val idx_p_cty = C_Ast_Utils.integer_promote idx_cty - val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) - val (rhs_term_raw, rhs_cty) = translate_expr tctx rhs - val a_var = Isa_Free ("v__arr", isa_dummyT) - val i_var = Isa_Free ("v__idx", isa_dummyT) - val loc_var = Isa_Free ("v__loc", isa_dummyT) - val old_var = Isa_Free ("v__old", isa_dummyT) - val rhs_var = Isa_Free ("v__rhs", isa_dummyT) - val new_var = Isa_Free ("v__new", isa_dummyT) - val arr_has_effect = C_Ast_Utils.expr_has_side_effect arr_expr - val idx_has_effect = C_Ast_Utils.expr_has_side_effect idx_expr - val rhs_has_effect = C_Ast_Utils.expr_has_side_effect rhs - val arr_is_global_const = - (case arr_expr of - CVar0 (ident, _) => - (case C_Trans_Ctxt.lookup_global_const tctx (C_Ast_Utils.ident_name ident) of - SOME _ => true - | NONE => false) - | _ => false) - val unseq_lhs = arr_has_effect orelse idx_has_effect - val unseq_lhs_rhs = unseq_lhs orelse rhs_has_effect - val _ = - if arr_is_global_const then - unsupported "compound assignment to global constant array element" - else if unseq_lhs_rhs andalso - (C_Ast_Utils.expr_has_unsequenced_ub_risk arr_expr idx_expr orelse - C_Ast_Utils.expr_has_unsequenced_ub_risk arr_expr rhs orelse - C_Ast_Utils.expr_has_unsequenced_ub_risk idx_expr rhs) - then - unsupported "potential unsequenced side-effect UB in indexed compound assignment" - else () - val focused = C_Term_Build.mk_focus_nth - (C_Term_Build.mk_unat i_var) a_var - val elem_cty = (case arr_cty of - C_Ast_Utils.CPtr inner => inner - | _ => unsupported "indexing non-array expression") - val op_cty = compound_op_cty elem_cty rhs_cty binop - val loc_expr = - mk_pair_eval unseq_lhs arr_term idx_term a_var i_var - (mk_index_guard idx_p_cty i_var a_var (C_Term_Build.mk_literal focused)) - in case translate_binop op_cty binop of - Monadic f => - let - val combine_rhs_loc = - if unseq_lhs_rhs then C_Term_Build.mk_bind2_unseq else C_Term_Build.mk_bind2 - val assign_fun = - Term.lambda rhs_var (Term.lambda loc_var - (C_Term_Build.mk_bind - (C_Term_Build.mk_deref (C_Term_Build.mk_literal loc_var)) - (Term.lambda old_var - (let - val (_, old_prom, rhs_prom) = - prepare_compound_operands - elem_cty - (C_Term_Build.mk_literal rhs_var) - rhs_cty - binop - (C_Term_Build.mk_literal old_var) - in - C_Term_Build.mk_bind - (C_Term_Build.mk_bind2 f old_prom rhs_prom) - (Term.lambda new_var - (let - val new_assigned = - mk_implicit_cast - (C_Term_Build.mk_literal new_var, op_cty, elem_cty) - in - C_Term_Build.mk_sequence - (C_Term_Build.mk_ptr_write - (C_Term_Build.mk_literal loc_var) - new_assigned) - new_assigned - end)) - end)))) - val assign_term = combine_rhs_loc assign_fun rhs_term_raw loc_expr - in - (assign_term, elem_cty) - end - end - | NONE => unsupported "unsupported compound operator on array element") - | translate_expr tctx (CAssign0 (CAssignOp0, CVar0 (ident, _), rhs, _)) = - let val name = C_Ast_Utils.ident_name ident - val (rhs', rhs_cty) = translate_expr tctx rhs - val rhs_var = Isa_Free ("v__rhs", isa_dummyT) - in case C_Trans_Ctxt.lookup_var tctx name of - SOME (C_Trans_Ctxt.Local, var, cty) => - let val rhs_cast = mk_implicit_cast (rhs', rhs_cty, cty) - in (C_Term_Build.mk_bind rhs_cast (Term.lambda rhs_var - (C_Term_Build.mk_sequence - (C_Term_Build.mk_var_write var (C_Term_Build.mk_literal rhs_var)) - (C_Term_Build.mk_literal rhs_var))), - cty) - end - | SOME (C_Trans_Ctxt.Param, _, _) => - error ("micro_c_translate: assignment to parameter: " ^ name) - | NONE => - (case C_Trans_Ctxt.lookup_global_const tctx name of - SOME _ => - error ("micro_c_translate: assignment to global constant: " ^ name) - | NONE => - error ("micro_c_translate: undefined variable: " ^ name)) - end - | translate_expr tctx (CAssign0 (CAssignOp0, CUnary0 (CIndOp0, lhs, _), rhs, _)) = - (* *p = v : write through pointer *) - let val (lhs', lhs_cty) = translate_expr tctx lhs - val pointee_cty = (case lhs_cty of - C_Ast_Utils.CPtr inner => inner - | _ => unsupported "dereference assignment on non-pointer expression") - val (rhs', rhs_cty) = translate_expr tctx rhs - val rhs_cast = mk_implicit_cast (rhs', rhs_cty, pointee_cty) - val rhs_var = Isa_Free ("v__rhs", isa_dummyT) - val ptr_var = Isa_Free ("v__ptr", isa_dummyT) - val unseq_lhs_rhs = - C_Ast_Utils.expr_has_side_effect lhs orelse C_Ast_Utils.expr_has_side_effect rhs - val _ = - if unseq_lhs_rhs andalso C_Ast_Utils.expr_has_unsequenced_ub_risk lhs rhs then - unsupported "potential unsequenced side-effect UB in dereference assignment" - else () - val write_fun = - Term.lambda rhs_var (Term.lambda ptr_var - (C_Term_Build.mk_sequence - (C_Term_Build.mk_ptr_write - (C_Term_Build.mk_literal ptr_var) - (C_Term_Build.mk_literal rhs_var)) - (C_Term_Build.mk_literal rhs_var))) - val assign_term = - (if unseq_lhs_rhs - then C_Term_Build.mk_bind2_unseq write_fun rhs_cast lhs' - else C_Term_Build.mk_bind2 write_fun rhs_cast lhs') - in (assign_term, - pointee_cty) - end - (* *p op= rhs : compound assignment through pointer dereference *) - | translate_expr tctx (CAssign0 (asgn_op, CUnary0 (CIndOp0, ptr_expr, _), rhs, _)) = - (case compound_assign_to_binop asgn_op of - SOME binop => - let val (ptr_term, cty) = translate_expr tctx ptr_expr - val pointee_cty = (case cty of - C_Ast_Utils.CPtr inner => inner - | _ => unsupported "compound dereference assignment on non-pointer expression") - val (rhs_term_raw, rhs_cty) = translate_expr tctx rhs - val op_cty = compound_op_cty pointee_cty rhs_cty binop - val ptr_var = Isa_Free ("v__ptr", isa_dummyT) - val old_var = Isa_Free ("v__old", isa_dummyT) - val rhs_var = Isa_Free ("v__rhs", isa_dummyT) - val new_var = Isa_Free ("v__new", isa_dummyT) - val unseq_lhs_rhs = - C_Ast_Utils.expr_has_side_effect ptr_expr orelse C_Ast_Utils.expr_has_side_effect rhs - val _ = - if unseq_lhs_rhs andalso C_Ast_Utils.expr_has_unsequenced_ub_risk ptr_expr rhs then - unsupported "potential unsequenced side-effect UB in dereference compound assignment" - else () - in case translate_binop op_cty binop of - Monadic f => - let - val combine_rhs_ptr = - if unseq_lhs_rhs then C_Term_Build.mk_bind2_unseq else C_Term_Build.mk_bind2 - val assign_fun = - Term.lambda rhs_var (Term.lambda ptr_var - (C_Term_Build.mk_bind - (C_Term_Build.mk_deref (C_Term_Build.mk_literal ptr_var)) - (Term.lambda old_var - (let - val (_, old_prom, rhs_prom) = - prepare_compound_operands - pointee_cty - (C_Term_Build.mk_literal rhs_var) - rhs_cty - binop - (C_Term_Build.mk_literal old_var) - in - C_Term_Build.mk_bind - (C_Term_Build.mk_bind2 f old_prom rhs_prom) - (Term.lambda new_var - (let - val new_assigned = - mk_implicit_cast - (C_Term_Build.mk_literal new_var, op_cty, pointee_cty) - in - C_Term_Build.mk_sequence - (C_Term_Build.mk_ptr_write - (C_Term_Build.mk_literal ptr_var) - new_assigned) - new_assigned - end)) - end)))) - val assign_term = combine_rhs_ptr assign_fun rhs_term_raw ptr_term - in - (assign_term, pointee_cty) - end - end - | NONE => unsupported "unsupported operator on dereferenced pointer") - | translate_expr tctx (CAssign0 (asgn_op, CVar0 (ident, _), rhs, _)) = - (* Compound assignment: x op= rhs -> read x, compute (x op rhs), write x, return new *) - (case compound_assign_to_binop asgn_op of - SOME binop => - let val name = C_Ast_Utils.ident_name ident - val (rhs_raw, rhs_cty) = translate_expr tctx rhs - in case C_Trans_Ctxt.lookup_var tctx name of - SOME (C_Trans_Ctxt.Local, var, cty) => - let val old_var = Isa_Free ("v__old", isa_dummyT) - val new_var = Isa_Free ("v__new", isa_dummyT) - val op_cty = compound_op_cty cty rhs_cty binop - in case translate_binop op_cty binop of - Monadic f => - (C_Term_Build.mk_bind (C_Term_Build.mk_var_read var) - (Term.lambda old_var - (C_Term_Build.mk_bind - (let - val (_, old_prom, rhs_prom) = - prepare_compound_operands - cty rhs_raw rhs_cty binop - (C_Term_Build.mk_literal old_var) - in - C_Term_Build.mk_bind2 f old_prom rhs_prom - end) - (Term.lambda new_var - (let - val new_assigned = - mk_implicit_cast - (C_Term_Build.mk_literal new_var, op_cty, cty) - in - (C_Term_Build.mk_sequence - (C_Term_Build.mk_var_write var - new_assigned) - new_assigned) - end)))), cty) - end - | _ => - (case C_Trans_Ctxt.lookup_global_const tctx name of - SOME _ => unsupported ("compound assignment to global constant: " ^ name) - | NONE => unsupported "compound assignment to non-local variable") - end - | NONE => unsupported "compound assignment or non-variable lhs") - | translate_expr _ (CAssign0 _) = - unsupported "non-variable lhs in assignment" - | translate_expr tctx (CCall0 (CVar0 (ident, _), args, _)) = - let val fname = C_Ast_Utils.ident_name ident - val arg_terms_typed = List.map (translate_expr tctx) args - val arg_has_effects = List.map C_Ast_Utils.expr_has_side_effect args - val any_arg_effect = List.exists I arg_has_effects - val param_ctys = C_Trans_Ctxt.lookup_func_param_types tctx fname - val ctxt = C_Trans_Ctxt.get_ctxt tctx - val func_ref = - (case resolve_visible_const_term ctxt (!current_decl_prefix ^ fname) of - SOME fterm => SOME fterm - | NONE => - (case resolve_visible_const_term ctxt fname of - SOME fterm => SOME fterm - | NONE => - (* In locale targets, freshly declared functions may not yet - resolve as constants. If the C signature table knows this - function, synthesize a reference term and let typing/casts - constrain it. *) - (case param_ctys of - SOME _ => SOME (Isa_Free (!current_decl_prefix ^ fname, isa_dummyT)) - | NONE => NONE))) - val _ = - (case param_ctys of - SOME tys => - if List.length arg_terms_typed = List.length tys then () - else unsupported - ("function call arity mismatch for " ^ fname ^ ": expected " ^ - Int.toString (List.length tys) ^ ", got " ^ Int.toString (List.length arg_terms_typed)) - | NONE => - (case func_ref of - SOME _ => () - | NONE => - unsupported ("call to undeclared function: " ^ fname ^ - " (tried symbols: " ^ !current_decl_prefix ^ fname ^ ", " ^ fname ^ ")"))) - fun cast_args [] _ = [] - | cast_args ((arg_tm, _) :: rest) [] = arg_tm :: cast_args rest [] - | cast_args ((arg_tm, arg_cty) :: rest) (p_cty :: p_rest) = - mk_implicit_cast (arg_tm, arg_cty, p_cty) :: cast_args rest p_rest - val arg_terms = - (case param_ctys of - SOME tys => cast_args arg_terms_typed tys - | NONE => List.map #1 arg_terms_typed) - val argc = List.length arg_terms - (* For arity > 2 with side-effecting arguments: funcallN sequences - evaluation left-to-right via bindN, which is a valid ordering for - C's unspecified argument evaluation order. We warn if multiple - arguments have side effects (potential for unsequenced UB), but - allow it when at most one argument is side-effecting. *) - val effect_count = List.length (List.filter I arg_has_effects) - val _ = - if argc > 2 andalso effect_count > 1 then - unsupported ("call to " ^ fname ^ - " has multiple side-effecting arguments with unspecified C evaluation order (arity > 2)") - else () - val _ = - if argc = 2 andalso any_arg_effect andalso - C_Ast_Utils.expr_has_unsequenced_ub_risk (List.nth (args, 0)) (List.nth (args, 1)) - then - unsupported ("call to " ^ fname ^ - " has potential unsequenced side-effect UB across arguments") - else () - in - (case func_ref of - SOME fref => - let - (* Look up callee's fuel parameter count and generate fresh - while_fuel free variables to pass as leading arguments. - These will be picked up by the caller's fuel abstraction - (String.isPrefix "while_fuel" in translate_fundef). *) - val callee_full = !current_decl_prefix ^ fname - val fuel_count = - (case Symtab.lookup (!defined_func_fuels) callee_full of - SOME n => n | NONE => 0) - val fuel_args = List.tabulate (fuel_count, fn i => - Isa_Free ("while_fuel_" ^ fname ^ - (if fuel_count = 1 then "" else "_" ^ Int.toString i), - @{typ nat})) - (* Partial-apply fuel args to fref: fuel params are pure nat - values, not monadic expressions, so they must be applied - directly rather than passed through funcallN. *) - val fref_fueled = List.foldl (fn (a, f) => f $ a) fref fuel_args - val call_term = - if argc = 2 andalso any_arg_effect then - let val call2 = - Isa_Const (\<^const_name>\deep_compose2\, dummyT --> dummyT --> dummyT) - $ Isa_Const (\<^const_name>\call\, dummyT --> dummyT) - $ fref_fueled - in C_Term_Build.mk_bind2_unseq call2 (List.nth (arg_terms, 0)) (List.nth (arg_terms, 1)) end - else - C_Term_Build.mk_funcall fref_fueled arg_terms - val ret_cty = - (case C_Trans_Ctxt.lookup_func_return_type tctx fname of - SOME cty => cty - | NONE => - (case cty_of_hol_type (expr_value_type call_term) of - SOME cty => cty - | NONE => C_Ast_Utils.CInt)) - in (call_term, ret_cty) end - | NONE => - unsupported ("call to undeclared function: " ^ fname ^ - " (tried symbols: " ^ !current_decl_prefix ^ fname ^ ", " ^ fname ^ ")")) - end - | translate_expr _ (CCall0 _) = - unsupported "indirect function call (function pointers)" - | translate_expr tctx (CUnary0 (CAdrOp0, expr, _)) = - translate_lvalue_location tctx expr - | translate_expr tctx (CUnary0 (CIndOp0, expr, _)) = - (* *p : dereference pointer. Resolve dereference_fun from locale context - to avoid adhoc overloading ambiguity (same as CIndex0 reads). - If the inner expression has CPtr ty, unwrap to ty. *) - let val (expr', cty) = translate_expr tctx expr - val result_cty = (case cty of - C_Ast_Utils.CPtr C_Ast_Utils.CVoid => - unsupported "dereference of void pointer (cast first)" - | C_Ast_Utils.CPtr inner => inner - | _ => unsupported "dereference on non-pointer expression") - val ctxt = C_Trans_Ctxt.get_ctxt tctx - val deref_const = resolve_dereference_const ctxt - val deref_fn = - Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) - $ deref_const - in (Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ expr' $ deref_fn, - result_cty) end - | translate_expr tctx (CUnary0 (CCompOp0, expr, _)) = - (* ~x : bitwise complement — C11: operand undergoes integer promotion *) - let val (expr', cty) = translate_expr tctx expr - val pcty = C_Ast_Utils.integer_promote cty - val promoted = mk_implicit_cast (expr', cty, pcty) - val not_const = - if C_Ast_Utils.is_signed pcty - then Isa_Const (\<^const_name>\c_signed_not\, isa_dummyT) - else Isa_Const (\<^const_name>\c_unsigned_not\, isa_dummyT) - val v = Isa_Free ("v__comp", isa_dummyT) - in (C_Term_Build.mk_bind promoted (Term.lambda v (not_const $ v)), pcty) end - | translate_expr tctx (CUnary0 (CMinOp0, expr, _)) = - (* -x : unary minus, translate as 0 - x — C11: operand undergoes integer promotion *) - let val (expr', cty) = translate_expr tctx expr - val pcty = C_Ast_Utils.integer_promote cty - val promoted = mk_implicit_cast (expr', cty, pcty) - val zero = C_Term_Build.mk_literal_num pcty 0 - val sub_const = - if C_Ast_Utils.is_signed pcty - then Isa_Const (\<^const_name>\c_signed_sub\, isa_dummyT) - else Isa_Const (\<^const_name>\c_unsigned_sub\, isa_dummyT) - in (C_Term_Build.mk_bind2 sub_const zero promoted, pcty) end - | translate_expr tctx (CUnary0 (CPreIncOp0, expr, _)) = - translate_inc_dec translate_expr translate_lvalue_location tctx true true expr - | translate_expr tctx (CUnary0 (CPostIncOp0, expr, _)) = - translate_inc_dec translate_expr translate_lvalue_location tctx true false expr - | translate_expr tctx (CUnary0 (CPreDecOp0, expr, _)) = - translate_inc_dec translate_expr translate_lvalue_location tctx false true expr - | translate_expr tctx (CUnary0 (CPostDecOp0, expr, _)) = - translate_inc_dec translate_expr translate_lvalue_location tctx false false expr - | translate_expr tctx (CUnary0 (CPlusOp0, expr, _)) = - (* +x : unary plus — C11: operand undergoes integer promotion *) - let val (expr', cty) = translate_expr tctx expr - val pcty = C_Ast_Utils.integer_promote cty - in (mk_implicit_cast (expr', cty, pcty), pcty) end - | translate_expr tctx (CUnary0 (CNegOp0, expr, _)) = - (* !x : logical NOT *) - let val (expr', cty) = translate_expr tctx expr - val b = mk_implicit_cast (expr', cty, C_Ast_Utils.CBool) - val v = Isa_Free ("v__neg", @{typ bool}) - in (C_Term_Build.mk_bind b - (Term.lambda v - (C_Term_Build.mk_literal - (Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) $ v))), - C_Ast_Utils.CBool) - end - (* p->field[idx] / s.field[idx] : struct field (list) read, then index with nth. - Uses resolved dereference_fun to avoid store_dereference_const adhoc overloading. *) - | translate_expr tctx (CIndex0 (CMember0 (expr, field_ident, is_ptr, _), idx_expr, _)) = - let val field_name = C_Ast_Utils.ident_name field_ident - val struct_name = determine_struct_type tctx expr - val ctxt = C_Trans_Ctxt.get_ctxt tctx - val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name - val deref_const = resolve_dereference_const ctxt - val ptr_expr = if is_ptr then #1 (translate_expr tctx expr) - else #1 (translate_lvalue_location tctx expr) - val (idx_term_raw, idx_cty) = translate_expr tctx idx_expr - val idx_p_cty = C_Ast_Utils.integer_promote idx_cty - val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) - val unseq_index = - C_Ast_Utils.expr_has_side_effect expr orelse C_Ast_Utils.expr_has_side_effect idx_expr - val _ = - if unseq_index andalso C_Ast_Utils.expr_has_unsequenced_ub_risk expr idx_expr then - unsupported "potential unsequenced side-effect UB in indexed access" - else () - val ptr_var = Isa_Free ("v__ptr", isa_dummyT) - val struct_var = Isa_Free ("v__struct", isa_dummyT) - val i_var = Isa_Free ("v__idx", isa_dummyT) - val list_val = accessor_const $ struct_var - val nth_term = Isa_Const (\<^const_name>\nth\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ list_val $ (C_Term_Build.mk_unat i_var) - val deref_expr = - Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ ptr_var) - $ (Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) - $ deref_const) - val elem_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of - SOME (C_Ast_Utils.CPtr inner) => inner - | _ => unsupported "indexing non-array struct field") - val value_term = C_Term_Build.mk_literal nth_term - val value_term = mk_index_guard idx_p_cty i_var list_val value_term - in (mk_pair_eval unseq_index ptr_expr idx_term ptr_var i_var - (C_Term_Build.mk_bind deref_expr (Term.lambda struct_var value_term)), - elem_cty) - end - (* arr[idx] : deref whole list, then index with nth. - We resolve dereference_fun from the locale context instead of using - store_dereference_const, which has ambiguous adhoc overloading - (dereference_fun vs ro_dereference_fun) for read-only references. *) - | translate_expr tctx (CIndex0 (arr_expr, idx_expr, _)) = - let val (arr_term, arr_cty) = translate_expr tctx arr_expr - val (idx_term_raw, idx_cty) = translate_expr tctx idx_expr - val idx_p_cty = C_Ast_Utils.integer_promote idx_cty - val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) - val unseq_index = - C_Ast_Utils.expr_has_side_effect arr_expr orelse C_Ast_Utils.expr_has_side_effect idx_expr - val _ = - if unseq_index andalso C_Ast_Utils.expr_has_unsequenced_ub_risk arr_expr idx_expr then - unsupported "potential unsequenced side-effect UB in indexed access" - else () - val ctxt = C_Trans_Ctxt.get_ctxt tctx - (* Resolve dereference_fun from locale context to avoid adhoc - overloading ambiguity; fall back to store_dereference_const - when outside a reference locale (e.g. smoke tests). *) - val deref_const = resolve_dereference_const ctxt - val a_var = Isa_Free ("v__arr", isa_dummyT) - val i_var = Isa_Free ("v__idx", isa_dummyT) - (* Type-annotate list_var when the array element type is known. - This constrains pointer dereference resolution, avoiding - unconstrained type variables (e.g. TYPE('a)) in definitions - that operate on raw pointer parameters like int16_t r[256]. *) - val list_elem_ty = - (case arr_cty of - C_Ast_Utils.CPtr inner => - (case C_Ast_Utils.hol_type_of inner of - t => if t = isa_dummyT then isa_dummyT - else Isa_Type (\<^type_name>\list\, [t])) - | _ => isa_dummyT) - val list_var = Isa_Free ("v__list", list_elem_ty) - val nth_term = Isa_Const (\<^const_name>\nth\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ list_var $ (C_Term_Build.mk_unat i_var) - (* bind (literal a) (deep_compose1 call dereference_fun) — same structure - as mk_deref but with the resolved constant *) - val deref_expr = - Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ a_var) - $ (Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) - $ deref_const) - val arr_is_global_const = - (case arr_expr of - CVar0 (ident, _) => - (case C_Trans_Ctxt.lookup_global_const tctx (C_Ast_Utils.ident_name ident) of - SOME _ => true - | NONE => false) - | _ => false) - val value_term = C_Term_Build.mk_literal nth_term - val value_term = mk_index_guard idx_p_cty i_var list_var value_term - in (mk_pair_eval unseq_index arr_term idx_term a_var i_var - (if arr_is_global_const then - let - val direct_nth = - Isa_Const (\<^const_name>\nth\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ a_var $ (C_Term_Build.mk_unat i_var) - val direct_term = C_Term_Build.mk_literal direct_nth - val direct_term = mk_index_guard idx_p_cty i_var a_var direct_term - in direct_term end - else - C_Term_Build.mk_bind deref_expr (Term.lambda list_var value_term)), - (case arr_cty of - C_Ast_Utils.CPtr inner => inner - | _ => unsupported "indexing non-array expression")) - end - (* p->field : struct/union field access through pointer. - For unions: cast to typed ref, then dereference. - For array fields (CPtr inner): array-to-pointer decay — create a focused - reference to the field rather than reading the value. - For scalar fields: dereference and read the value. *) - | translate_expr tctx (CMember0 (expr, field_ident, true, _)) = - let val field_name = C_Ast_Utils.ident_name field_ident - val struct_name = determine_struct_type tctx expr - val ctxt = C_Trans_Ctxt.get_ctxt tctx - val (ptr_expr, _) = translate_expr tctx expr - val field_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of - SOME cty => cty - | NONE => unsupported ("unknown struct field type: " ^ struct_name ^ "." ^ field_name)) - in if is_union_aggregate struct_name then - (* Union field read: cast to typed ref, then dereference *) - let val cast_expr = mk_cast_from_void field_cty ptr_expr - val v = Isa_Free ("v__uref", isa_dummyT) - in (C_Term_Build.mk_bind cast_expr - (Term.lambda v (C_Term_Build.mk_deref (C_Term_Build.mk_literal v))), - field_cty) end - else case field_cty of - C_Ast_Utils.CPtr _ => - (* Array field: array-to-pointer decay — create a focused reference - to the array within the struct, rather than reading its value *) - let val focus_const = resolve_struct_focus_const ctxt struct_name field_name - val base_var = Isa_Free ("v__base_loc", isa_dummyT) - val focused = C_Term_Build.mk_focus_field focus_const base_var - in (C_Term_Build.mk_bind ptr_expr (Term.lambda base_var (C_Term_Build.mk_literal focused)), - field_cty) - end - | _ => - (* Scalar field: dereference and read the value *) - let val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name - in (C_Term_Build.mk_struct_field_read accessor_const ptr_expr, field_cty) end - end - (* s.field : direct struct/union member access via value *) - | translate_expr tctx (CMember0 (expr, field_ident, false, _)) = - let val field_name = C_Ast_Utils.ident_name field_ident - val struct_name = determine_struct_type tctx expr - val field_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of - SOME cty => cty - | NONE => unsupported ("unknown field type: " ^ struct_name ^ "." ^ field_name)) - in if is_union_aggregate struct_name then - (* Union: get lvalue location of s, cast void ref to typed ref, deref *) - let val (loc_expr, _) = translate_lvalue_location tctx expr - val cast_expr = mk_cast_from_void field_cty loc_expr - val v = Isa_Free ("v__uref", isa_dummyT) - in (C_Term_Build.mk_bind cast_expr - (Term.lambda v (C_Term_Build.mk_deref (C_Term_Build.mk_literal v))), - field_cty) end - else - let val ctxt = C_Trans_Ctxt.get_ctxt tctx - val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name - val (struct_expr, _) = translate_expr tctx expr - val v = Isa_Free ("v__struct", isa_dummyT) - in (C_Term_Build.mk_bind struct_expr - (Term.lambda v (C_Term_Build.mk_literal (accessor_const $ v))), - field_cty) end - end - | translate_expr tctx (CCond0 (cond, Some then_expr, else_expr, _)) = - (* x ? y : z — ternary conditional *) - let val (then', then_cty) = translate_expr tctx then_expr - val (else', else_cty) = translate_expr tctx else_expr - val result_cty = - if then_cty = else_cty then then_cty - else if C_Ast_Utils.is_ptr then_cty andalso C_Ast_Utils.is_ptr else_cty - then (* Both pointer types: allow void* \ T* coercion *) - (case (then_cty, else_cty) of - (_, C_Ast_Utils.CPtr C_Ast_Utils.CVoid) => then_cty - | (C_Ast_Utils.CPtr C_Ast_Utils.CVoid, _) => else_cty - | _ => unsupported "ternary with incompatible pointer types") - else if C_Ast_Utils.is_ptr then_cty orelse C_Ast_Utils.is_ptr else_cty - then (* One pointer, one integer — use the pointer type *) - if C_Ast_Utils.is_ptr then_cty then then_cty else else_cty - else C_Ast_Utils.usual_arith_conv (then_cty, else_cty) - val then_cast = mk_implicit_cast (then', then_cty, result_cty) - val else_cast = mk_implicit_cast (else', else_cty, result_cty) - in (C_Term_Build.mk_two_armed_cond (ensure_bool_cond tctx cond) then_cast else_cast, result_cty) end - | translate_expr tctx (CCond0 (cond, None, else_expr, _)) = - (* GNU extension: x ?: y means x ? x : y *) - let val (cond_term, cond_cty) = translate_expr tctx cond - val (else', else_cty) = translate_expr tctx else_expr - val result_cty = - if cond_cty = else_cty then cond_cty - else if C_Ast_Utils.is_ptr cond_cty andalso C_Ast_Utils.is_ptr else_cty - then (case (cond_cty, else_cty) of - (_, C_Ast_Utils.CPtr C_Ast_Utils.CVoid) => cond_cty - | (C_Ast_Utils.CPtr C_Ast_Utils.CVoid, _) => else_cty - | _ => unsupported "GNU ?: with incompatible pointer types") - else if C_Ast_Utils.is_ptr cond_cty orelse C_Ast_Utils.is_ptr else_cty - then if C_Ast_Utils.is_ptr cond_cty then cond_cty else else_cty - else C_Ast_Utils.usual_arith_conv (cond_cty, else_cty) - val cond_v = Isa_Free ("v__condv", isa_dummyT) - val cond_bool = mk_implicit_cast (C_Term_Build.mk_literal cond_v, cond_cty, C_Ast_Utils.CBool) - val then_cast = mk_implicit_cast (C_Term_Build.mk_literal cond_v, cond_cty, result_cty) - val else_cast = mk_implicit_cast (else', else_cty, result_cty) - in (C_Term_Build.mk_bind cond_term - (Term.lambda cond_v - (C_Term_Build.mk_two_armed_cond cond_bool then_cast else_cast)), - result_cty) - end - | translate_expr _ (CConst0 (CCharConst0 (CChar0 (c, _), _))) = - (* C character constants have type int. *) - (C_Term_Build.mk_literal_num C_Ast_Utils.CInt - (intinf_to_int_checked "character literal" (integer_of_char c)), - C_Ast_Utils.CInt) - | translate_expr _ (CConst0 (CStrConst0 (CString0 (abr_str, _), _))) = - (* String literal: produce a c_char list with null terminator *) - let val s = C_Ast_Utils.abr_string_to_string abr_str - val char_ty = C_Ast_Utils.hol_type_of C_Ast_Utils.CChar - val bytes = List.map (fn c => HOLogic.mk_number char_ty (Char.ord c)) - (String.explode s) - val with_null = bytes @ [HOLogic.mk_number char_ty 0] - val list_term = HOLogic.mk_list char_ty with_null - in (C_Term_Build.mk_literal list_term, C_Ast_Utils.CPtr C_Ast_Utils.CChar) - end - | translate_expr _ (CComma0 ([], _)) = - (C_Term_Build.mk_literal_unit, C_Ast_Utils.CInt) - | translate_expr tctx (CComma0 (exprs, _)) = - let val translated = List.map (translate_expr tctx) exprs - fun fold_comma [] = error "micro_c_translate: empty comma expression" - | fold_comma [(e, ty)] = (e, ty) - | fold_comma ((e, _) :: rest) = - let val (rest_e, rest_ty) = fold_comma rest - in (C_Term_Build.mk_sequence e rest_e, rest_ty) end - in fold_comma translated end - (* (target_type)expr : type cast *) - | translate_expr tctx (CCast0 (target_decl, source_expr, _)) = - let val (source_term, source_cty) = translate_expr tctx source_expr - val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx - val target_cty = - (case target_decl of - CDecl0 (specs, declrs, _) => - let val struct_names = C_Trans_Ctxt.get_struct_names tctx - val base_cty = - (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of - SOME ct => SOME ct - | NONE => - (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of - SOME sn => SOME (C_Ast_Utils.CStruct sn) - | NONE => - (case C_Ast_Utils.extract_union_type_from_specs_full (!current_union_names) specs of - SOME un => SOME (C_Ast_Utils.CUnion un) - | NONE => NONE))) - val ptr_depth = - List.mapPartial - (fn ((Some declr, _), _) => SOME (C_Ast_Utils.pointer_depth_of_declr declr) - | _ => NONE) declrs - |> (fn d :: _ => d | [] => 0) - in case base_cty of - SOME ct => C_Ast_Utils.apply_ptr_depth ct ptr_depth - | NONE => unsupported "cast to non-numeric type" - end - | _ => unsupported "cast to non-numeric type") - in (mk_implicit_cast (source_term, source_cty, target_cty), target_cty) - end - (* sizeof(type) *) - | translate_expr tctx (CSizeofType0 (decl, _)) = - let val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx - val cty = - (case decl of - CDecl0 (specs, declrs, _) => - let val struct_names = C_Trans_Ctxt.get_struct_names tctx - val base_cty = - (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of - SOME ct => SOME ct - | NONE => - (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of - SOME sn => SOME (C_Ast_Utils.CStruct sn) - | NONE => - (case C_Ast_Utils.extract_union_type_from_specs_full (!current_union_names) specs of - SOME un => SOME (C_Ast_Utils.CUnion un) - | NONE => NONE))) - val ptr_depth = - List.mapPartial - (fn ((Some declr, _), _) => SOME (C_Ast_Utils.pointer_depth_of_declr declr) - | _ => NONE) declrs - |> (fn d :: _ => d | [] => 0) - in case base_cty of - SOME ct => C_Ast_Utils.apply_ptr_depth ct ptr_depth - | NONE => unsupported "sizeof non-numeric type" - end - | _ => unsupported "sizeof non-numeric type") - val size_cty = C_Ast_Utils.pointer_uint_cty () - val word_ty = C_Ast_Utils.hol_type_of size_cty - val sizeof_term = - (case cty of - C_Ast_Utils.CStruct sn => - let val fields = - (case C_Trans_Ctxt.get_struct_fields tctx sn of - SOME fs => fs - | NONE => error ("micro_c_translate: sizeof: unknown struct: " ^ sn)) - val sz = sizeof_struct fields - in Isa_Const (\<^const_name>\of_nat\, @{typ nat} --> word_ty) $ HOLogic.mk_nat sz end - | C_Ast_Utils.CPtr _ => - let val bytes = C_Ast_Utils.sizeof_c_type cty - in Isa_Const (\<^const_name>\of_nat\, @{typ nat} --> word_ty) $ HOLogic.mk_nat bytes end - | _ => - let val isa_ty = C_Ast_Utils.hol_type_of cty - val itself_ty = Isa_Type (\<^type_name>\itself\, [isa_ty]) - val type_term = Isa_Const (\<^const_name>\Pure.type\, itself_ty) - val sizeof_nat = Isa_Const (\<^const_name>\c_sizeof\, - itself_ty --> @{typ nat}) $ type_term - in Isa_Const (\<^const_name>\of_nat\, @{typ nat} --> word_ty) $ sizeof_nat end) - in (C_Term_Build.mk_literal sizeof_term, size_cty) end - (* sizeof(expr) *) - | translate_expr tctx (CSizeofExpr0 (expr, _)) = - let fun sizeof_nat_term cty = - let val isa_ty = C_Ast_Utils.hol_type_of cty - val itself_ty = Isa_Type (\<^type_name>\itself\, [isa_ty]) - val type_term = Isa_Const (\<^const_name>\Pure.type\, itself_ty) - in Isa_Const (\<^const_name>\c_sizeof\, itself_ty --> @{typ nat}) $ type_term end - fun sizeof_nat_for_cty (C_Ast_Utils.CStruct sn) = - let val fields = - (case C_Trans_Ctxt.get_struct_fields tctx sn of - SOME fs => fs - | NONE => error ("micro_c_translate: sizeof: unknown struct: " ^ sn)) - in HOLogic.mk_nat (sizeof_struct fields) end - | sizeof_nat_for_cty (C_Ast_Utils.CPtr ptr_cty) = - HOLogic.mk_nat (C_Ast_Utils.sizeof_c_type (C_Ast_Utils.CPtr ptr_cty)) - | sizeof_nat_for_cty cty = sizeof_nat_term cty - val sizeof_nat = - (case expr of - CVar0 (ident, _) => - let val name = C_Ast_Utils.ident_name ident - in case C_Trans_Ctxt.lookup_array_decl tctx name of - SOME (elem_cty, n) => - Isa_Const (\<^const_name>\Groups.times_class.times\, @{typ nat} --> @{typ nat} --> @{typ nat}) - $ HOLogic.mk_nat n - $ sizeof_nat_for_cty elem_cty - | NONE => - let val (_, cty) = translate_expr tctx expr - in sizeof_nat_for_cty cty end - end - | _ => - let val (_, cty) = translate_expr tctx expr - in sizeof_nat_for_cty cty end) - val size_cty = C_Ast_Utils.pointer_uint_cty () - val word_ty = C_Ast_Utils.hol_type_of size_cty - val sizeof_term = Isa_Const (\<^const_name>\of_nat\, - @{typ nat} --> word_ty) $ sizeof_nat - in (C_Term_Build.mk_literal sizeof_term, size_cty) end - | translate_expr tctx (CAlignofType0 (decl, _)) = - let val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx - val cty = - (case decl of - CDecl0 (specs, declrs, _) => - let val struct_names = C_Trans_Ctxt.get_struct_names tctx - val base_cty = - (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of - SOME ct => SOME ct - | NONE => - (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of - SOME sn => SOME (C_Ast_Utils.CStruct sn) - | NONE => NONE)) - val ptr_depth = - List.mapPartial - (fn ((Some declr, _), _) => SOME (C_Ast_Utils.pointer_depth_of_declr declr) - | _ => NONE) declrs - |> (fn d :: _ => d | [] => 0) - in case base_cty of - SOME ct => C_Ast_Utils.apply_ptr_depth ct ptr_depth - | NONE => unsupported "_Alignof non-numeric type" - end - | _ => unsupported "_Alignof non-numeric type") - val isa_ty = C_Ast_Utils.hol_type_of cty - val itself_ty = Isa_Type (\<^type_name>\itself\, [isa_ty]) - val type_term = Isa_Const (\<^const_name>\Pure.type\, itself_ty) - val alignof_nat = Isa_Const (\<^const_name>\c_alignof\, - itself_ty --> @{typ nat}) $ type_term - val size_cty = C_Ast_Utils.pointer_uint_cty () - val word_ty = C_Ast_Utils.hol_type_of size_cty - val alignof_term = Isa_Const (\<^const_name>\of_nat\, - @{typ nat} --> word_ty) $ alignof_nat - in (C_Term_Build.mk_literal alignof_term, size_cty) end - | translate_expr tctx (CAlignofExpr0 (expr, _)) = - let val (_, cty) = translate_expr tctx expr - val isa_ty = C_Ast_Utils.hol_type_of cty - val itself_ty = Isa_Type (\<^type_name>\itself\, [isa_ty]) - val type_term = Isa_Const (\<^const_name>\Pure.type\, itself_ty) - val alignof_nat = Isa_Const (\<^const_name>\c_alignof\, - itself_ty --> @{typ nat}) $ type_term - val size_cty = C_Ast_Utils.pointer_uint_cty () - val word_ty = C_Ast_Utils.hol_type_of size_cty - val alignof_term = Isa_Const (\<^const_name>\of_nat\, - @{typ nat} --> word_ty) $ alignof_nat - in (C_Term_Build.mk_literal alignof_term, size_cty) end - (* Compound literal: (type){init_list} *) - | translate_expr tctx (CCompoundLit0 (decl, init_list, _)) = - let val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx - val cty = - (case decl of - CDecl0 (specs, declrs, _) => - let val struct_names = C_Trans_Ctxt.get_struct_names tctx - val base_cty = - (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of - SOME ct => SOME ct - | NONE => - (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of - SOME sn => SOME (C_Ast_Utils.CStruct sn) - | NONE => NONE)) - val ptr_depth = - List.mapPartial - (fn ((Some declr, _), _) => SOME (C_Ast_Utils.pointer_depth_of_declr declr) - | _ => NONE) declrs - |> (fn d :: _ => d | [] => 0) - in case base_cty of - SOME ct => C_Ast_Utils.apply_ptr_depth ct ptr_depth - | NONE => unsupported "compound literal with unsupported type" - end - | _ => unsupported "compound literal with unsupported declaration") - in case init_list of - [([], CInitExpr0 (expr, _))] => - (* Scalar compound literal: (type){value} *) - let val (expr_term, expr_cty) = translate_expr tctx expr - in (mk_implicit_cast (expr_term, expr_cty, cty), cty) end - | _ => unsupported "compound literal with complex initializer" - end - | translate_expr tctx (CGenericSelection0 (ctrl_expr, assoc_list, _)) = - (* _Generic(ctrl, type1: expr1, ..., default: expr_default) - Resolved at translation time based on the controlling expression's type. *) - let val (_, ctrl_cty) = translate_expr tctx ctrl_expr - val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx - val struct_names = C_Trans_Ctxt.get_struct_names tctx - fun resolve_assoc_type (CDecl0 (specs, _, _)) = - (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of - SOME ct => ct - | NONE => - (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of - SOME sn => C_Ast_Utils.CStruct sn - | NONE => unsupported "_Generic association type")) - | resolve_assoc_type _ = unsupported "_Generic association type" - fun find_match [] default_opt = - (case default_opt of - SOME expr => translate_expr tctx expr - | NONE => unsupported "_Generic: no matching association and no default") - | find_match ((None, expr) :: rest) _ = - find_match rest (SOME expr) - | find_match ((Some decl, expr) :: rest) default_opt = - if resolve_assoc_type decl = ctrl_cty - then translate_expr tctx expr - else find_match rest default_opt - in find_match assoc_list NONE end - | translate_expr _ _ = - unsupported "expression" - - and translate_lvalue_location tctx (CVar0 (ident, _)) = - let val name = C_Ast_Utils.ident_name ident - in case C_Trans_Ctxt.lookup_var tctx name of - SOME (C_Trans_Ctxt.Local, ref_var, cty) => - (C_Term_Build.mk_literal ref_var, C_Ast_Utils.CPtr cty) - | SOME (C_Trans_Ctxt.Param, _, _) => - unsupported ("address-of by-value parameter: " ^ name) - | NONE => - (case C_Trans_Ctxt.lookup_global_const tctx name of - SOME _ => - unsupported ("address-of global const without reference storage not supported: " ^ name) - | NONE => - error ("micro_c_translate: undefined variable: " ^ name)) - end - | translate_lvalue_location tctx (CUnary0 (CIndOp0, expr, _)) = - let val (ptr_term, ptr_cty) = translate_expr tctx expr - in case ptr_cty of - C_Ast_Utils.CPtr _ => (ptr_term, ptr_cty) - | _ => unsupported "address-of dereference on non-pointer expression" - end - | translate_lvalue_location tctx (CMember0 (expr, field_ident, is_ptr, _)) = - let - val field_name = C_Ast_Utils.ident_name field_ident - val struct_name = determine_struct_type tctx expr - val field_cty = - (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of - SOME cty => cty - | NONE => unsupported ("unknown struct field type: " ^ struct_name ^ "." ^ field_name)) - val focus_const = resolve_struct_focus_const (C_Trans_Ctxt.get_ctxt tctx) struct_name field_name - val base_expr = - if is_ptr then - let val (ptr_expr, ptr_cty) = translate_expr tctx expr - in case ptr_cty of - C_Ast_Utils.CPtr _ => ptr_expr - | _ => unsupported "member access through non-pointer expression" - end - else - #1 (translate_lvalue_location tctx expr) - val base_var = Isa_Free ("v__base_loc", isa_dummyT) - val focused = C_Term_Build.mk_focus_field focus_const base_var - in (C_Term_Build.mk_bind base_expr (Term.lambda base_var (C_Term_Build.mk_literal focused)), - C_Ast_Utils.CPtr field_cty) - end - | translate_lvalue_location tctx (CIndex0 (arr_expr, idx_expr, _)) = - let - val allow_fallback = - (case arr_expr of - CMember0 _ => false - | _ => true) - fun fallback_to_expr msg = - String.isSubstring "address-of non-lvalue expression" msg orelse - String.isSubstring "address-of by-value parameter" msg - val (arr_term, arr_cty) = - (translate_lvalue_location tctx arr_expr - handle ERROR msg => - if allow_fallback andalso fallback_to_expr msg then translate_expr tctx arr_expr - else raise ERROR msg) - val (idx_term_raw, idx_cty) = translate_expr tctx idx_expr - val idx_p_cty = C_Ast_Utils.integer_promote idx_cty - val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) - val arr_is_global_const = - (case arr_expr of - CVar0 (ident, _) => - (case C_Trans_Ctxt.lookup_global_const tctx (C_Ast_Utils.ident_name ident) of - SOME _ => true - | NONE => false) - | _ => false) - val arr_has_effect = C_Ast_Utils.expr_has_side_effect arr_expr - val idx_has_effect = C_Ast_Utils.expr_has_side_effect idx_expr - val unseq_index = arr_has_effect orelse idx_has_effect - val _ = - if arr_is_global_const then - unsupported "address-of global constant array element is not supported without reference storage" - else if unseq_index andalso C_Ast_Utils.expr_has_unsequenced_ub_risk arr_expr idx_expr then - unsupported "potential unsequenced side-effect UB in indexed lvalue" - else () - val a_var = Isa_Free ("v__arr_loc", isa_dummyT) - val i_var = Isa_Free ("v__idx", isa_dummyT) - val focused = C_Term_Build.mk_focus_nth (C_Term_Build.mk_unat i_var) a_var - val elem_cty = - (case arr_cty of - C_Ast_Utils.CPtr inner => inner - | _ => unsupported "indexing non-array expression") - val loc_expr = - mk_pair_eval unseq_index arr_term idx_term a_var i_var - (mk_index_guard idx_p_cty i_var a_var (C_Term_Build.mk_literal focused)) - in (loc_expr, C_Ast_Utils.CPtr elem_cty) end - | translate_lvalue_location _ _ = - unsupported "address-of non-lvalue expression" - - (* Convenience: extract just the term from translate_expr *) - and expr_term tctx e = #1 (translate_expr tctx e) - - (* Ensure a C expression produces a bool condition. - In C, any scalar value in a condition position is implicitly converted - to bool via != 0. If the expression already produces CBool (from a - comparison or _Bool variable), use it directly. Otherwise, wrap with - bind expr (\v. literal (v \ 0)). *) - and ensure_bool_cond tctx cond_expr = - let val (cond_term, cond_cty) = translate_expr tctx cond_expr - in mk_implicit_cast (cond_term, cond_cty, C_Ast_Utils.CBool) - end - - (* Extract variable declarations as a list of (name, init_term, cty, array_meta) tuples. - Handles multiple declarators in a single CDecl0. - For pointer declarators (e.g. int *p = &x), the returned cty is CPtr base_cty. *) - fun translate_decl tctx (CDecl0 (specs, declarators, _)) = - let val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx - val struct_names = C_Trans_Ctxt.get_struct_names tctx - val cty = - (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of - SOME C_Ast_Utils.CVoid => C_Ast_Utils.CInt - | SOME t => t - | NONE => - (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of - SOME sn => C_Ast_Utils.CStruct sn - | NONE => - (case C_Ast_Utils.extract_union_type_from_specs_full (!current_union_names) specs of - SOME un => C_Ast_Utils.CUnion un - | NONE => C_Ast_Utils.CInt))) - fun pointer_depth_of_declr declr = C_Ast_Utils.pointer_depth_of_declr declr - fun has_array_declr (CDeclr0 (_, derived, _, _, _)) = - List.exists (fn CArrDeclr0 _ => true | _ => false) derived - fun array_decl_size (CDeclr0 (_, derived, _, _, _)) = - List.mapPartial - (fn CArrDeclr0 (_, CArrSize0 (_, CConst0 (CIntConst0 (CInteger0 (n, _, _), _))), _) => - if n < 0 then - error "micro_c_translate: negative array bound not supported" - else - SOME (intinf_to_int_checked "array bound" n) - | _ => NONE) derived - |> (fn n :: _ => SOME n | [] => NONE) - fun init_scalar_const_value (CConst0 (CIntConst0 (CInteger0 (n, _, _), _))) = n - | init_scalar_const_value (CConst0 (CCharConst0 (CChar0 (c, _), _))) = - integer_of_char c - | init_scalar_const_value (CVar0 (ident, _)) = - let val name = C_Ast_Utils.ident_name ident - in case C_Trans_Ctxt.lookup_enum_const tctx name of - SOME value => IntInf.fromInt value - | NONE => - unsupported ("unsupported array initializer element: " ^ name) - end - | init_scalar_const_value (CUnary0 (CMinOp0, e, _)) = - IntInf.~ (init_scalar_const_value e) - | init_scalar_const_value (CUnary0 (CPlusOp0, e, _)) = - init_scalar_const_value e - | init_scalar_const_value (CCast0 (_, e, _)) = - init_scalar_const_value e - | init_scalar_const_value _ = - unsupported "non-constant array initializer element" - fun string_literal_bytes (CConst0 (CStrConst0 (CString0 (abr_str, _), _))) = - SOME (List.map Char.ord - (String.explode (C_Ast_Utils.abr_string_to_string abr_str))) - | string_literal_bytes _ = NONE - fun init_scalar_const_term target_cty expr = - HOLogic.mk_number (C_Ast_Utils.hol_type_of target_cty) - (intinf_to_int_checked "array initializer literal" - (init_scalar_const_value expr)) - fun process_one ((Some declr, Some (CInitExpr0 (init, _))), _) = - let val name = C_Ast_Utils.declr_name declr - val ptr_depth = pointer_depth_of_declr declr - val actual_cty = C_Ast_Utils.apply_ptr_depth cty ptr_depth - in - case (has_array_declr declr, string_literal_bytes init) of - (true, SOME char_ords) => - let val elem_cty = - if ptr_depth > 0 - then C_Ast_Utils.apply_ptr_depth cty (ptr_depth - 1) else cty - val elem_type = C_Ast_Utils.hol_type_of elem_cty - val with_null = - List.map (fn b => HOLogic.mk_number elem_type b) char_ords - @ [HOLogic.mk_number elem_type 0] - val declared_n = array_decl_size declr - val arr_size = - case declared_n of SOME n => n | NONE => List.length with_null - val padded = - case declared_n of - SOME n => - if List.length with_null > n then - unsupported "string initializer too long for array" - else with_null @ List.tabulate - (n - List.length with_null, - fn _ => HOLogic.mk_number elem_type 0) - | NONE => with_null - val list_term = - C_Term_Build.mk_literal (HOLogic.mk_list elem_type padded) - in (name, list_term, actual_cty, SOME (elem_cty, arr_size)) end - | _ => - let val (init_raw, init_cty) = translate_expr tctx init - val init_term = mk_implicit_cast (init_raw, init_cty, actual_cty) - val arr_meta = - (case array_decl_size declr of - SOME n => - if ptr_depth > 0 - then SOME (C_Ast_Utils.apply_ptr_depth cty (ptr_depth - 1), n) - else NONE - | NONE => NONE) - in (name, init_term, actual_cty, arr_meta) end - end - | process_one ((Some declr, Some (CInitList0 (init_list, _))), _) = - let val name = C_Ast_Utils.declr_name declr - val ptr_depth = pointer_depth_of_declr declr - val actual_cty = C_Ast_Utils.apply_ptr_depth cty ptr_depth - in if has_array_declr declr then - let val elem_cty = - if ptr_depth > 0 then C_Ast_Utils.apply_ptr_depth cty (ptr_depth - 1) else cty - val elem_type = C_Ast_Utils.hol_type_of elem_cty - (* Resolve position for each element: designators set explicit index, - positional elements use sequential position *) - fun resolve_desig_idx [] pos = pos - | resolve_desig_idx [CArrDesig0 (CConst0 (CIntConst0 (CInteger0 (n, _, _), _)), _)] _ = - intinf_to_int_checked "array designator" n - | resolve_desig_idx _ _ = unsupported "complex designator in array initializer" - fun collect_indices [] _ = [] - | collect_indices ((desigs, CInitExpr0 (e, _)) :: rest) pos = - let val idx = resolve_desig_idx desigs pos - in (idx, e) :: collect_indices rest (idx + 1) end - | collect_indices _ _ = unsupported "complex array initializer element" - val indexed_items = collect_indices init_list 0 - val has_designators = List.exists (fn (desigs, _) => not (null desigs)) init_list - val declared_size = array_decl_size declr - val arr_size = case declared_size of - SOME n => n - | NONE => List.length indexed_items - val _ = if List.length indexed_items > arr_size andalso not has_designators - then error "micro_c_translate: too many initializers for array" - else () - val _ = List.app (fn (idx, _) => - if idx < 0 orelse idx >= arr_size - then error ("micro_c_translate: designator index " ^ - Int.toString idx ^ " out of bounds for array of size " ^ - Int.toString arr_size) - else ()) indexed_items - (* Try constant path first *) - val const_results = List.map (fn (idx, e) => - let val v = (SOME (init_scalar_const_term elem_cty e) handle ERROR _ => NONE) - in (idx, v) end) indexed_items - val all_const = List.all (fn (_, v) => Option.isSome v) const_results - val zero_value = HOLogic.mk_number elem_type 0 - val init_term = - if all_const then - (* All-constant: build zero array, fill in designated positions *) - let val base = List.tabulate (arr_size, fn _ => zero_value) - val filled = List.foldl (fn ((idx, SOME v), arr) => - nth_map idx (K v) arr - | _ => raise Match) base const_results - in C_Term_Build.mk_literal (HOLogic.mk_list elem_type filled) end - else - (* Monadic: evaluate all init values, build array with designators *) - let val init_exprs = List.map (fn (_, e) => - let val (raw, raw_cty) = translate_expr tctx e - in mk_implicit_cast (raw, raw_cty, elem_cty) end) indexed_items - val n = List.length init_exprs - val vars = List.tabulate (n, - fn i => Isa_Free ("v__init_" ^ Int.toString i, isa_dummyT)) - (* Build array: start with zeros, place vars at designated positions *) - val base = List.tabulate (arr_size, fn _ => zero_value) - val filled = ListPair.foldl - (fn ((idx, _), var, arr) => nth_map idx (K var) arr) - base (indexed_items, vars) - val result_list = HOLogic.mk_list elem_type filled - val result = C_Term_Build.mk_literal result_list - in ListPair.foldr - (fn (expr, var, acc) => - C_Term_Build.mk_bind expr (Term.lambda var acc)) - result (init_exprs, vars) - end - val arr_meta = - (case declared_size of - SOME n => SOME (elem_cty, n) - | NONE => NONE) - in (name, init_term, actual_cty, arr_meta) end - else (case actual_cty of - C_Ast_Utils.CStruct struct_name => - let val fields = - (case C_Trans_Ctxt.get_struct_fields tctx struct_name of - SOME fs => fs - | NONE => error ("micro_c_translate: unknown struct: " ^ struct_name)) - (* Map each init item to (field_index, expr_opt, initlist_opt) *) - fun find_field_index _ [] _ = - error "micro_c_translate: struct field not found" - | find_field_index fname ((n, _) :: rest) i = - if n = fname then i - else find_field_index fname rest (i + 1) - fun resolve_field_desig [] pos = pos - | resolve_field_desig [CMemberDesig0 (ident, _)] _ = - find_field_index (C_Ast_Utils.ident_name ident) fields 0 - | resolve_field_desig _ _ = - unsupported "complex designator in struct initializer" - (* field_items: (idx, SOME expr, NONE) for scalar, (idx, NONE, SOME init_list) for nested *) - fun collect_field_items [] _ = [] - | collect_field_items ((desigs, CInitExpr0 (e, _)) :: rest) pos = - let val idx = resolve_field_desig desigs pos - in (idx, SOME e, NONE) :: collect_field_items rest (idx + 1) end - | collect_field_items ((desigs, CInitList0 (inner_list, _)) :: rest) pos = - let val idx = resolve_field_desig desigs pos - in (idx, NONE, SOME inner_list) :: collect_field_items rest (idx + 1) end - val field_items = collect_field_items init_list 0 - (* Helper: build constant array list from CInitList items *) - fun build_const_array_from_initlist arr_elem_cty arr_sz inner_list = - let val elem_type = C_Ast_Utils.hol_type_of arr_elem_cty - fun resolve_arr_desig [] pos = pos - | resolve_arr_desig [CArrDesig0 (CConst0 (CIntConst0 (CInteger0 (n, _, _), _)), _)] _ = - intinf_to_int_checked "nested array designator" n - | resolve_arr_desig _ _ = unsupported "complex nested array designator" - fun collect_arr [] _ = [] - | collect_arr ((ds, CInitExpr0 (e, _)) :: rest) pos = - let val idx = resolve_arr_desig ds pos - in (idx, e) :: collect_arr rest (idx + 1) end - | collect_arr _ _ = unsupported "complex nested array init element" - val indexed = collect_arr inner_list 0 - val sz = case arr_sz of SOME n => n | NONE => List.length indexed - val zero_val = HOLogic.mk_number elem_type 0 - val base = List.tabulate (sz, fn _ => zero_val) - val filled = List.foldl (fn ((idx, e), arr) => - nth_map idx (K (init_scalar_const_term arr_elem_cty e)) arr) base indexed - in HOLogic.mk_list elem_type filled end - (* Helper: try to produce a constant init value for a field *) - fun try_const_field_val field_cty (SOME e) NONE = - (SOME (init_scalar_const_term field_cty e) handle ERROR _ => NONE) - | try_const_field_val field_cty NONE (SOME inner_list) = - (case field_cty of - C_Ast_Utils.CPtr elem_cty => - (SOME (build_const_array_from_initlist elem_cty NONE inner_list) - handle ERROR _ => NONE) - | _ => NONE) - | try_const_field_val _ _ _ = NONE (* e.g. both NONE *) - (* Helper: translate a field init value monadically *) - fun translate_field_val field_cty (SOME e) NONE = - let val (raw, raw_cty) = translate_expr tctx e - in mk_implicit_cast (raw, raw_cty, field_cty) end - | translate_field_val field_cty NONE (SOME inner_list) = - (case field_cty of - C_Ast_Utils.CPtr elem_cty => - let val elem_type = C_Ast_Utils.hol_type_of elem_cty - fun resolve_arr_desig [] pos = pos - | resolve_arr_desig [CArrDesig0 (CConst0 (CIntConst0 (CInteger0 (n, _, _), _)), _)] _ = - intinf_to_int_checked "nested array designator" n - | resolve_arr_desig _ _ = unsupported "complex nested array designator" - fun collect_arr [] _ = [] - | collect_arr ((ds, CInitExpr0 (e, _)) :: rest) pos = - let val idx = resolve_arr_desig ds pos - in (idx, e) :: collect_arr rest (idx + 1) end - | collect_arr _ _ = unsupported "complex nested array init element" - val indexed = collect_arr inner_list 0 - val sz = List.length indexed - val zero_val = HOLogic.mk_number elem_type 0 - val init_exprs_inner = List.map (fn (_, e) => - let val (raw, raw_cty) = translate_expr tctx e - in mk_implicit_cast (raw, raw_cty, elem_cty) end) indexed - val nn = List.length init_exprs_inner - val vars = List.tabulate (nn, - fn i => Isa_Free ("v__ainit_" ^ Int.toString i, isa_dummyT)) - val base = List.tabulate (sz, fn _ => zero_val) - val filled = ListPair.foldl - (fn ((idx, _), var, arr) => nth_map idx (K var) arr) - base (indexed, vars) - val result_list = HOLogic.mk_list elem_type filled - val result = C_Term_Build.mk_literal result_list - in ListPair.foldr - (fn (expr, var, acc) => - C_Term_Build.mk_bind expr (Term.lambda var acc)) - result (init_exprs_inner, vars) - end - | _ => unsupported "nested init list for non-array struct field") - | translate_field_val _ _ _ = - unsupported "malformed struct field initializer" - (* Try constant path first *) - val const_results = List.map (fn (idx, e_opt, il_opt) => - let val (_, field_cty) = List.nth (fields, idx) - val v = try_const_field_val field_cty e_opt il_opt - in (idx, v) end) field_items - val all_const = List.all (fn (_, v) => Option.isSome v) const_results - val ctxt_inner = C_Trans_Ctxt.get_ctxt tctx - val make_name = "make_" ^ (!current_decl_prefix) ^ struct_name - val make_const = - Proof_Context.read_const {proper = true, strict = false} - ctxt_inner make_name - fun default_for_field (_, field_cty) = - (case field_cty of - C_Ast_Utils.CPtr elem_cty => - HOLogic.mk_list (C_Ast_Utils.hol_type_of elem_cty) [] - | _ => HOLogic.mk_number (C_Ast_Utils.hol_type_of field_cty) 0) - val init_term = - if all_const then - let val base_vals = List.map default_for_field fields - val filled = List.foldl (fn ((idx, SOME v), arr) => - nth_map idx (K v) arr - | _ => raise Match) base_vals const_results - val struct_term = List.foldl (fn (v, acc) => acc $ v) - make_const filled - in C_Term_Build.mk_literal struct_term end - else - let val init_exprs = List.map (fn (idx, e_opt, il_opt) => - let val (_, field_cty) = List.nth (fields, idx) - in translate_field_val field_cty e_opt il_opt end) - field_items - val n = List.length init_exprs - val vars = List.tabulate (n, - fn i => Isa_Free ("v__sinit_" ^ Int.toString i, isa_dummyT)) - val base_vals = List.map default_for_field fields - val filled = ListPair.foldl - (fn ((idx, _, _), var, arr) => nth_map idx (K var) arr) - base_vals (field_items, vars) - val struct_term = List.foldl (fn (v, acc) => acc $ v) - make_const filled - val result = C_Term_Build.mk_literal struct_term - in ListPair.foldr - (fn (expr, var, acc) => - C_Term_Build.mk_bind expr (Term.lambda var acc)) - result (init_exprs, vars) - end - in (name, init_term, actual_cty, NONE) end - | _ => unsupported "initializer list for non-array, non-struct declaration") - end - | process_one ((Some declr, None), _) = - let val name = C_Ast_Utils.declr_name declr - val ptr_depth = pointer_depth_of_declr declr - val actual_cty = C_Ast_Utils.apply_ptr_depth cty ptr_depth - val uninit = Isa_Const (\<^const_name>\c_uninitialized\, isa_dummyT) - val arr_meta = - (case array_decl_size declr of - SOME n => - if ptr_depth > 0 - then SOME (C_Ast_Utils.apply_ptr_depth cty (ptr_depth - 1), n) - else NONE - | NONE => NONE) - in (name, C_Term_Build.mk_literal uninit, actual_cty, arr_meta) end - | process_one _ = unsupported "complex declarator" - in List.map process_one declarators end - | translate_decl _ _ = unsupported "complex declaration" - - (* Find label names nested in statements/items, preserving first-seen order. *) - fun find_stmt_labels (CLabel0 (ident, inner, _, _)) = - C_Ast_Utils.ident_name ident :: find_stmt_labels inner - | find_stmt_labels (CCompound0 (_, items, _)) = find_block_labels items - | find_stmt_labels (CIf0 (_, thn, Some els, _)) = - find_stmt_labels thn @ find_stmt_labels els - | find_stmt_labels (CIf0 (_, thn, None, _)) = find_stmt_labels thn - | find_stmt_labels (CWhile0 (_, body, _, _)) = find_stmt_labels body - | find_stmt_labels (CFor0 (_, _, _, body, _)) = find_stmt_labels body - | find_stmt_labels (CSwitch0 (_, body, _)) = find_stmt_labels body - | find_stmt_labels _ = [] - and find_block_labels [] = [] - | find_block_labels (CBlockStmt0 stmt :: rest) = - find_stmt_labels stmt @ find_block_labels rest - | find_block_labels (_ :: rest) = find_block_labels rest - - (* Translate a compound block, right-folding declarations into nested binds. - Goto support: when goto_refs is non-empty, each statement is guarded to be - skipped if any active goto flag is set. At a label site, the corresponding - goto flag is reset (written to 0) and removed from the active list. *) - fun translate_compound_items _ [] = C_Term_Build.mk_literal_unit - | translate_compound_items tctx [CBlockStmt0 stmt] = - (* Last item: if it's a label, handle goto flag reset *) - (case stmt of - CLabel0 (ident, inner_stmt, _, _) => - let val label_name = C_Ast_Utils.ident_name ident - val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 - val active' = List.filter (fn n => n <> label_name) - (C_Trans_Ctxt.get_active_goto_labels tctx) - val tctx' = C_Trans_Ctxt.set_active_goto_labels active' tctx - in case C_Trans_Ctxt.lookup_goto_ref tctx label_name of - SOME goto_ref => - C_Term_Build.mk_sequence - (C_Term_Build.mk_var_write goto_ref false_lit) - (translate_stmt tctx' inner_stmt) - | NONE => translate_stmt tctx' stmt - end - | _ => translate_stmt tctx stmt) - | translate_compound_items _ [CNestedFunDef0 _] = - unsupported "nested function definition" - | translate_compound_items tctx (CBlockDecl0 decl :: rest) = - let val decls = translate_decl tctx decl - fun fold_decls [] tctx' = translate_compound_items tctx' rest - | fold_decls ((name, init_term, cty, arr_meta) :: ds) tctx' = - if C_Ast_Utils.is_ptr cty andalso not (Option.isSome arr_meta) then - (* Pointer-typed (non-array) local variable: bind as a simple value - (Param) instead of allocating a mutable reference via - store_reference_const. Pointer values are focused references - which typically lack prisms. - Note: local arrays (arr_meta = SOME _) must still be allocated as - references so that CIndex0 can dereference them correctly. - in the machine model. They are bound directly and can be rebound - via pointer alias assignment handling below. *) - let val var = Isa_Free (name, isa_dummyT) - val tctx'' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.Param var cty tctx' - val tctx'' = (case struct_name_of_cty cty of - SOME sn => C_Trans_Ctxt.set_struct_type name sn tctx'' - | NONE => tctx'') - val tctx'' = (case arr_meta of - SOME (elem_cty, n) => C_Trans_Ctxt.set_array_decl name elem_cty n tctx'' - | NONE => tctx'') - (* Check if the init term is c_uninitialized (polymorphic type 'a). - For uninitialized pointer declarations, skip the binding entirely - to avoid introducing an unconstrained type variable. The pointer - alias assignment handler will create the actual binding. *) - val is_uninit = - (case Term.strip_comb init_term of - (hd, [arg]) => - (case (try Term.dest_Const hd, try Term.dest_Const arg) of - (SOME (n1, _), SOME (n2, _)) => - n1 = \<^const_name>\Core_Expression.literal\ andalso - n2 = \<^const_name>\c_uninitialized\ - | _ => false) - | _ => false) - in if is_uninit then - fold_decls ds tctx'' - else - C_Term_Build.mk_bind init_term - (Term.lambda var (fold_decls ds tctx'')) - end - else - let val val_type = - let val ty = C_Ast_Utils.hol_type_of cty - in if ty = isa_dummyT then expr_value_type init_term else ty end - val alloc_expr = - mk_resolved_var_alloc_typed (C_Trans_Ctxt.get_ctxt tctx') val_type init_term - val var = mk_typed_ref_var tctx' name alloc_expr - val tctx'' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.Local var cty tctx' - val tctx'' = (case struct_name_of_cty cty of - SOME sn => C_Trans_Ctxt.set_struct_type name sn tctx'' - | NONE => tctx'') - val tctx'' = (case arr_meta of - SOME (elem_cty, n) => C_Trans_Ctxt.set_array_decl name elem_cty n tctx'' - | NONE => tctx'') - in C_Term_Build.mk_bind alloc_expr - (Term.lambda var (fold_decls ds tctx'')) - end - in fold_decls decls tctx end - | translate_compound_items tctx (CBlockStmt0 (CLabel0 (ident, inner_stmt, _, _)) :: rest) = - (* Label site: reset this label's goto flag, translate the labeled statement, - then continue with the rest of the block *) - let val label_name = C_Ast_Utils.ident_name ident - val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 - val active' = List.filter (fn n => n <> label_name) - (C_Trans_Ctxt.get_active_goto_labels tctx) - val tctx' = C_Trans_Ctxt.set_active_goto_labels active' tctx - val stmt_term = translate_stmt tctx' inner_stmt - val rest_term = translate_compound_items tctx' rest - in case C_Trans_Ctxt.lookup_goto_ref tctx label_name of - SOME goto_ref => - C_Term_Build.mk_sequence - (C_Term_Build.mk_var_write goto_ref false_lit) - (C_Term_Build.mk_sequence stmt_term rest_term) - | NONE => - (* Label not targeted by any goto — just translate normally *) - C_Term_Build.mk_sequence stmt_term rest_term - end - | translate_compound_items tctx (CBlockStmt0 stmt :: rest) = - (* Pointer alias assignment: when a pointer-typed Param variable is assigned, - rebind it via a monadic bind instead of writing to a reference. - This handles patterns like: int16_t *r; ... r = p->coeffs; *) - let val ptr_alias_result = - (case stmt of - CExpr0 (Some (CAssign0 (CAssignOp0, CVar0 (ident, _), rhs, _)), _) => - let val name = C_Ast_Utils.ident_name ident - in case C_Trans_Ctxt.lookup_var tctx name of - SOME (C_Trans_Ctxt.Param, _, cty) => - if C_Ast_Utils.is_ptr cty then - let val (rhs_term, _) = translate_expr tctx rhs - val var = Isa_Free (name, isa_dummyT) - val tctx' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.Param var cty tctx - in SOME (C_Term_Build.mk_bind rhs_term - (Term.lambda var (translate_compound_items tctx' rest))) - end - else NONE - | _ => NONE - end - | _ => NONE) - in case ptr_alias_result of - SOME result => result - | NONE => - let val inherited_labels = C_Trans_Ctxt.get_active_goto_labels tctx - val goto_refs = C_Trans_Ctxt.get_goto_refs tctx - (* Determine which goto labels appear later in this block. - Only those need guarding at this point. *) - val later_labels = find_block_labels rest - val active_labels = distinct (op =) (inherited_labels @ later_labels) - val tctx_stmt = C_Trans_Ctxt.set_active_goto_labels active_labels tctx - val stmt_term = translate_stmt tctx_stmt stmt - val active_goto_refs = List.filter - (fn (name, _) => List.exists (fn l => l = name) active_labels) goto_refs - in case (C_Trans_Ctxt.get_break_ref tctx, - C_Trans_Ctxt.get_continue_ref tctx, - active_goto_refs) of - (NONE, NONE, []) => - C_Term_Build.mk_sequence stmt_term - (translate_compound_items tctx rest) - | _ => - let val guard_var = Isa_Free ("v__guard", isa_dummyT) - val guard_nonzero = - Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) - $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) - $ guard_var - $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) - (* Resolve dereference_fun from locale context to avoid - store_dereference_const adhoc overloading issues *) - val ctxt = C_Trans_Ctxt.get_ctxt tctx - val deref_const = resolve_dereference_const ctxt - val deref_fn = - Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) - $ deref_const - fun mk_guard_read ref_var = - Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) - $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ ref_var) - $ deref_fn - fun wrap_guard NONE inner = inner - | wrap_guard (SOME ref_var) inner = - C_Term_Build.mk_bind (mk_guard_read ref_var) - (Term.lambda guard_var - (C_Term_Build.mk_two_armed_cond - (C_Term_Build.mk_literal guard_nonzero) - C_Term_Build.mk_literal_unit inner)) - fun wrap_goto_guards [] inner = inner - | wrap_goto_guards ((_, ref_var) :: refs) inner = - wrap_guard (SOME ref_var) (wrap_goto_guards refs inner) - (* Split rest into guarded prefix (before first active label) - and unguarded suffix (label + remaining items). - The label code must be outside the guard so that the return type - from return statements at/after the label doesn't clash with - the guard's then-branch (literal unit). *) - fun split_at_active_label [] = ([], []) - | split_at_active_label (all as (CBlockStmt0 (CLabel0 (ident, _, _, _)) :: _)) = - let val lname = C_Ast_Utils.ident_name ident - in if List.exists (fn (n, _) => n = lname) active_goto_refs - then ([], all) - else let val (pre, post) = split_at_active_label (tl all) - in (hd all :: pre, post) end - end - | split_at_active_label (item :: items) = - let val (pre, post) = split_at_active_label items - in (item :: pre, post) end - val (guarded_items, label_suffix) = split_at_active_label rest - val guarded_term = translate_compound_items tctx_stmt guarded_items - val label_term = translate_compound_items tctx label_suffix - val guarded_part = - wrap_guard (C_Trans_Ctxt.get_break_ref tctx) - (wrap_guard (C_Trans_Ctxt.get_continue_ref tctx) - (wrap_goto_guards active_goto_refs guarded_term)) - in C_Term_Build.mk_sequence stmt_term - (C_Term_Build.mk_sequence guarded_part label_term) - end - end end - | translate_compound_items _ _ = unsupported "block item" - - (* Translate a C expression to a pure nat term (for loop bounds). - Only integer literals and parameter variables are supported. *) - and translate_pure_nat_expr _ (CConst0 (CIntConst0 (CInteger0 (n, _, _), _))) = - if n < 0 - then error "micro_c_translate: negative literal loop bound not supported in bounded-for lowering" - else HOLogic.mk_nat (intinf_to_int_checked "for-loop bound literal" n) - | translate_pure_nat_expr tctx (CVar0 (ident, _)) = - let val name = C_Ast_Utils.ident_name ident - in case C_Trans_Ctxt.lookup_var tctx name of - SOME (C_Trans_Ctxt.Param, v, cty) => - if C_Ast_Utils.is_signed cty orelse C_Ast_Utils.is_bool cty orelse C_Ast_Utils.is_ptr cty - then error ("micro_c_translate: loop bound parameter must be unsigned integer: " ^ name) - else - (* Convert parameter (word) to nat for range *) - C_Term_Build.mk_unat v - | _ => error ("micro_c_translate: loop bound must be a parameter or literal: " ^ name) - end - | translate_pure_nat_expr _ _ = - error "micro_c_translate: unsupported loop bound expression" - - and try_translate_pure_nat_expr tctx e = - SOME (translate_pure_nat_expr tctx e) - handle ERROR _ => NONE - - (* Try to recognize: for (int i = start; i < bound; i++) body - Returns SOME (var_name, start_nat, bound_nat, body) or NONE *) - and try_bounded_for (CFor0 (Right init_decl, Some cond, Some step, body, _)) = - let fun step_var_name (CUnary0 (CPostIncOp0, CVar0 (v, _), _)) = - SOME (C_Ast_Utils.ident_name v) - | step_var_name (CUnary0 (CPreIncOp0, CVar0 (v, _), _)) = - SOME (C_Ast_Utils.ident_name v) - | step_var_name _ = NONE - in case (init_decl, cond, step_var_name step) of - (CDecl0 (_, [((Some declr, Some (CInitExpr0 (init_expr, _))), _)], _), - CBinary0 (CLeOp0, CVar0 (cond_var, _), bound_expr, _), - SOME step_name) => - let val var_name = C_Ast_Utils.declr_name declr - val cond_name = C_Ast_Utils.ident_name cond_var - in - if var_name = cond_name andalso var_name = step_name - then SOME (var_name, init_expr, bound_expr, body) - else NONE - end - | _ => NONE - end - | try_bounded_for _ = NONE - - and translate_stmt tctx (CCompound0 (_, items, _)) = - translate_compound_items tctx items - | translate_stmt _ (CReturn0 (None, _)) = - C_Term_Build.mk_return_func C_Term_Build.mk_literal_unit - | translate_stmt tctx (CReturn0 (Some expr, _)) = - let val (term, expr_cty) = translate_expr tctx expr - val ret_term = case !current_ret_cty of - SOME ret_cty => mk_implicit_cast (term, expr_cty, ret_cty) - | NONE => term - in C_Term_Build.mk_return_func ret_term end - | translate_stmt tctx (CExpr0 (Some expr, _)) = - (* Expression statements are evaluated for side effects only. - Discard the return value by sequencing with unit. *) - C_Term_Build.mk_sequence (expr_term tctx expr) C_Term_Build.mk_literal_unit - | translate_stmt _ (CExpr0 (None, _)) = - C_Term_Build.mk_literal_unit - | translate_stmt tctx (CIf0 (cond, then_br, Some else_br, _)) = - C_Term_Build.mk_two_armed_cond - (ensure_bool_cond tctx cond) (translate_stmt tctx then_br) (translate_stmt tctx else_br) - | translate_stmt tctx (CIf0 (cond, then_br, None, _)) = - C_Term_Build.mk_two_armed_cond - (ensure_bool_cond tctx cond) (translate_stmt tctx then_br) C_Term_Build.mk_literal_unit - | translate_stmt tctx (stmt as CFor0 (init_part, cond_opt, step_opt, body, _)) = - let - fun translate_general_for () = - let - fun cond_term_of tctx' = - (case cond_opt of - Some c => ensure_bool_cond tctx' c - | None => C_Term_Build.mk_literal - (Isa_Const (\<^const_name>\HOL.True\, @{typ bool}))) - fun step_term_of tctx' = - (case step_opt of - Some s => C_Term_Build.mk_sequence (expr_term tctx' s) C_Term_Build.mk_literal_unit - | None => C_Term_Build.mk_literal_unit) - fun build_while tctx' = - let val has_brk = contains_break body - val has_cont = contains_continue body - val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 - in if not has_brk andalso not has_cont then - let val cond_term = cond_term_of tctx' - val body_term = - C_Term_Build.mk_sequence (translate_stmt tctx' body) (step_term_of tctx') - val fuel_var = fresh_var [cond_term, body_term] "while_fuel" @{typ nat} - in C_Term_Build.mk_bounded_while fuel_var cond_term body_term end - else - let - val dummy_tctx = (if has_brk - then C_Trans_Ctxt.set_break_ref (Isa_Free ("__dummy_brk", isa_dummyT)) tctx' - else tctx') - val dummy_tctx = (if has_cont - then C_Trans_Ctxt.set_continue_ref (Isa_Free ("__dummy_cont", isa_dummyT)) dummy_tctx - else dummy_tctx) - val cond_raw = cond_term_of dummy_tctx - val body_raw = translate_stmt dummy_tctx body - val step_raw = step_term_of dummy_tctx - val flag_ref_ty = mk_flag_ref_type tctx' - val break_ref = if has_brk - then SOME (fresh_var [cond_raw, body_raw, step_raw] "v__for_break" flag_ref_ty) - else NONE - val continue_ref = if has_cont - then SOME (fresh_var [cond_raw, body_raw, step_raw] "v__for_cont" flag_ref_ty) - else NONE - val tctx_loop = case break_ref of - SOME b => C_Trans_Ctxt.set_break_ref b tctx' - | NONE => tctx' - val tctx_loop = case continue_ref of - SOME c => C_Trans_Ctxt.set_continue_ref c tctx_loop - | NONE => tctx_loop - val body_term = translate_stmt tctx_loop body - val step_term = step_term_of tctx_loop - val step_term = - (case break_ref of - SOME br => - let val bf = Isa_Free ("v__for_bf", isa_dummyT) - val bf_nonzero = - Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) - $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) - $ bf - $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) - in C_Term_Build.mk_bind - (mk_resolved_var_read (C_Trans_Ctxt.get_ctxt tctx_loop) br) - (Term.lambda bf - (C_Term_Build.mk_two_armed_cond - (C_Term_Build.mk_literal bf_nonzero) - C_Term_Build.mk_literal_unit - step_term)) - end - | NONE => step_term) - val cond_term = cond_term_of tctx_loop - val cond_term = - (case break_ref of - SOME br => - let val bf = Isa_Free ("v__for_bfc", isa_dummyT) - val bf_nonzero = - Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) - $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) - $ bf - $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) - in C_Term_Build.mk_bind - (mk_resolved_var_read (C_Trans_Ctxt.get_ctxt tctx_loop) br) - (Term.lambda bf - (C_Term_Build.mk_two_armed_cond - (C_Term_Build.mk_literal bf_nonzero) - (C_Term_Build.mk_literal - (Isa_Const (\<^const_name>\HOL.False\, @{typ bool}))) - cond_term)) - end - | NONE => cond_term) - val body_with_resets = - (case continue_ref of - SOME cr => - C_Term_Build.mk_sequence - (C_Term_Build.mk_var_write cr false_lit) - (C_Term_Build.mk_sequence body_term step_term) - | NONE => C_Term_Build.mk_sequence body_term step_term) - val fuel_var = fresh_var [cond_term, body_with_resets] "while_fuel" @{typ nat} - val loop_term = C_Term_Build.mk_bounded_while fuel_var cond_term body_with_resets - fun wrap_ref NONE t = t - | wrap_ref (SOME ref_var) t = - C_Term_Build.mk_bind - (mk_resolved_var_alloc (C_Trans_Ctxt.get_ctxt tctx') false_lit) - (Term.lambda ref_var t) - in wrap_ref break_ref (wrap_ref continue_ref loop_term) end - end - in - case init_part of - Left init_expr_opt => - let val init_term = case init_expr_opt of - Some e => expr_term tctx e - | None => C_Term_Build.mk_literal_unit - in C_Term_Build.mk_sequence init_term (build_while tctx) end - | Right init_decl => - let val decls = translate_decl tctx init_decl - fun fold_decls [] tctx' = build_while tctx' - | fold_decls ((name, init, cty, arr_meta) :: ds) tctx' = - let val val_type = - let val ty = C_Ast_Utils.hol_type_of cty - in if ty = isa_dummyT then expr_value_type init else ty end - val alloc_expr = - mk_resolved_var_alloc_typed (C_Trans_Ctxt.get_ctxt tctx') val_type init - val var = mk_typed_ref_var tctx' name alloc_expr - val tctx'' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.Local var cty tctx' - val tctx'' = (case struct_name_of_cty cty of - SOME sn => C_Trans_Ctxt.set_struct_type name sn tctx'' - | NONE => tctx'') - val tctx'' = (case arr_meta of - SOME (elem_cty, n) => C_Trans_Ctxt.set_array_decl name elem_cty n tctx'' - | NONE => tctx'') - in C_Term_Build.mk_bind alloc_expr - (Term.lambda var (fold_decls ds tctx'')) end - in fold_decls decls tctx end - end - in - case try_bounded_for stmt of - SOME (var_name, init_c_expr, bound_c_expr, body) => - let - val body_assigned = C_Ast_Utils.find_assigned_vars body - val loop_var_mutated_or_escaped = - List.exists (fn n => n = var_name) body_assigned - in - if contains_break body orelse contains_continue body orelse loop_var_mutated_or_escaped then - translate_general_for () - else - (case (try_translate_pure_nat_expr tctx init_c_expr, - try_translate_pure_nat_expr tctx bound_c_expr) of - (SOME start_nat, SOME bound_nat) => - let - val loop_cty = - (case stmt of - CFor0 (Right (CDecl0 (specs, [((Some declr, _), _)], _)), _, _, _, _) => - let - val base_cty = - (case C_Ast_Utils.resolve_c_type_full - (C_Trans_Ctxt.get_typedef_tab tctx) specs of - SOME C_Ast_Utils.CVoid => C_Ast_Utils.CInt - | SOME t => t - | NONE => C_Ast_Utils.CInt) - in - C_Ast_Utils.apply_ptr_depth base_cty - (C_Ast_Utils.pointer_depth_of_declr declr) - end - | _ => C_Ast_Utils.CInt) - in - if C_Ast_Utils.is_signed loop_cty orelse - C_Ast_Utils.is_bool loop_cty orelse - C_Ast_Utils.is_ptr loop_cty then - translate_general_for () - else - let - val loop_hol_ty = C_Ast_Utils.hol_type_of loop_cty - val loop_var = Isa_Free (var_name, loop_hol_ty) - val tctx' = - C_Trans_Ctxt.add_var var_name C_Trans_Ctxt.Param loop_var loop_cty tctx - val body_term = translate_stmt tctx' body - val range = C_Term_Build.mk_upt_int_range start_nat bound_nat - in - C_Term_Build.mk_raw_for_loop range (Term.lambda loop_var body_term) - end - end - | _ => translate_general_for ()) - end - | NONE => translate_general_for () - end - | translate_stmt tctx (CWhile0 (cond, body_stmt, is_do_while, _)) = - let val has_brk = contains_break body_stmt - val has_cont = contains_continue body_stmt - val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 - in if not has_brk andalso not has_cont then - (* Simple case: no break/continue *) - let val cond_term = ensure_bool_cond tctx cond - val body_term = translate_stmt tctx body_stmt - val fuel_var = fresh_var [cond_term, body_term] "while_fuel" @{typ nat} - val while_term = C_Term_Build.mk_bounded_while fuel_var cond_term body_term - in if is_do_while - then C_Term_Build.mk_sequence body_term while_term - else while_term - end - else - (* Allocate break/continue flag refs *) - let (* Pre-set dummy refs so first-pass translation doesn't warn *) - val flag_ref_ty = mk_flag_ref_type tctx - val dummy_tctx = (if has_brk - then C_Trans_Ctxt.set_break_ref (Isa_Free ("__dummy_brk", flag_ref_ty)) tctx - else tctx) - val dummy_tctx = (if has_cont - then C_Trans_Ctxt.set_continue_ref (Isa_Free ("__dummy_cont", flag_ref_ty)) dummy_tctx - else dummy_tctx) - val cond_term_raw = ensure_bool_cond dummy_tctx cond - val body_raw = translate_stmt dummy_tctx body_stmt - val break_ref = if has_brk - then SOME (fresh_var [cond_term_raw, body_raw] "v__break" flag_ref_ty) - else NONE - val continue_ref = if has_cont - then SOME (fresh_var [cond_term_raw, body_raw] "v__cont" flag_ref_ty) - else NONE - (* Update context *) - val tctx' = case break_ref of - SOME b => C_Trans_Ctxt.set_break_ref b tctx | NONE => tctx - val tctx' = case continue_ref of - SOME c => C_Trans_Ctxt.set_continue_ref c tctx' | NONE => tctx' - (* Re-translate body with updated context (guards will be inserted) *) - val body_term = translate_stmt tctx' body_stmt - val cond_term = ensure_bool_cond tctx' cond - (* Augment condition: if break_flag then False else original_cond *) - val augmented_cond = case break_ref of - SOME br => - let val bf = Isa_Free ("v__bf", isa_dummyT) - val bf_nonzero = - Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) - $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) - $ bf - $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) - in C_Term_Build.mk_bind (C_Term_Build.mk_var_read br) - (Term.lambda bf - (C_Term_Build.mk_two_armed_cond - (C_Term_Build.mk_literal bf_nonzero) - (C_Term_Build.mk_literal - (Isa_Const (\<^const_name>\HOL.False\, @{typ bool}))) - cond_term)) - end - | NONE => cond_term - (* For continue: reset flag at start of each iteration *) - val body_with_resets = case continue_ref of - SOME cr => - C_Term_Build.mk_sequence - (C_Term_Build.mk_var_write cr false_lit) body_term - | NONE => body_term - val fuel_var = fresh_var [augmented_cond, body_with_resets] - "while_fuel" @{typ nat} - val while_term = C_Term_Build.mk_bounded_while - fuel_var augmented_cond body_with_resets - val loop_term = if is_do_while - then C_Term_Build.mk_sequence body_with_resets while_term - else while_term - (* Wrap in Ref::new for break/continue refs *) - fun wrap_ref NONE t = t - | wrap_ref (SOME ref_var) t = - C_Term_Build.mk_bind - (mk_resolved_var_alloc (C_Trans_Ctxt.get_ctxt tctx) false_lit) - (Term.lambda ref_var t) - in wrap_ref break_ref (wrap_ref continue_ref loop_term) end - end - | translate_stmt tctx (CSwitch0 (switch_expr, body, _)) = - let val (switch_term_raw, switch_cty_raw) = translate_expr tctx switch_expr - val switch_cty = C_Ast_Utils.integer_promote switch_cty_raw - val switch_term = mk_implicit_cast (switch_term_raw, switch_cty_raw, switch_cty) - val switch_var = fresh_var [switch_term] "v__switch" isa_dummyT - val items = case body of - CCompound0 (_, items, _) => items - | _ => [CBlockStmt0 body] - val groups = extract_switch_groups items - val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 - val true_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 1 - val flag_ref_ty = mk_flag_ref_type tctx - val switch_break_ref = fresh_var [switch_term] "v__switch_break" flag_ref_ty - (* break inside switch exits this switch, not any enclosing loop *) - val tctx_sw = C_Trans_Ctxt.set_break_ref switch_break_ref - (C_Trans_Ctxt.clear_break_ref tctx) - val all_have_break = List.all #has_break groups - orelse List.length groups <= 1 - val any_case_match = make_any_case_match switch_var switch_cty tctx groups - val default_cond = Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) $ any_case_match - val brk = Isa_Free ("v__sw_break", isa_dummyT) - val break_nonzero = - Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) - $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) - $ brk - $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) - fun guard_break inner = - C_Term_Build.mk_bind - (mk_resolved_var_read (C_Trans_Ctxt.get_ctxt tctx_sw) switch_break_ref) - (Term.lambda brk - (C_Term_Build.mk_two_armed_cond - (C_Term_Build.mk_literal break_nonzero) - C_Term_Build.mk_literal_unit - inner)) - in C_Term_Build.mk_bind - (mk_resolved_var_alloc (C_Trans_Ctxt.get_ctxt tctx) false_lit) - (Term.lambda switch_break_ref - (if all_have_break then - (* Simple if-else chain: no fall-through *) - let fun build_chain [] = C_Term_Build.mk_literal_unit - | build_chain ({labels, body, ...} :: rest) = - let val body_term = translate_compound_items tctx_sw body - val rest_term = build_chain rest - val cond = C_Term_Build.mk_literal - (make_switch_cond switch_var switch_cty tctx default_cond labels) - in C_Term_Build.mk_two_armed_cond cond body_term rest_term end - in C_Term_Build.mk_bind switch_term - (Term.lambda switch_var (build_chain groups)) - end - else - (* Fall-through: use matched_ref *) - let val matched_ref = fresh_var [switch_term] "v__matched" flag_ref_ty - val matched_var = Isa_Free ("v__m", isa_dummyT) - val matched_nonzero = - Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) - $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) - $ matched_var - $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) - fun build_groups [] = C_Term_Build.mk_literal_unit - | build_groups ({labels, body, has_break} :: rest) = - let val body_term = translate_compound_items tctx_sw body - val label_cond = - make_switch_cond switch_var switch_cty tctx default_cond labels - val full_cond = - Isa_Const (\<^const_name>\HOL.disj\, - @{typ bool} --> @{typ bool} --> @{typ bool}) - $ matched_nonzero $ label_cond - val group_action = - C_Term_Build.mk_sequence body_term - (if has_break - then C_Term_Build.mk_var_write matched_ref false_lit - else C_Term_Build.mk_var_write matched_ref true_lit) - val group_term = - C_Term_Build.mk_bind (C_Term_Build.mk_var_read matched_ref) - (Term.lambda matched_var - (C_Term_Build.mk_two_armed_cond - (C_Term_Build.mk_literal full_cond) - group_action C_Term_Build.mk_literal_unit)) - in guard_break (C_Term_Build.mk_sequence group_term (build_groups rest)) end - in C_Term_Build.mk_bind switch_term - (Term.lambda switch_var - (C_Term_Build.mk_bind - (mk_resolved_var_alloc (C_Trans_Ctxt.get_ctxt tctx) false_lit) - (Term.lambda matched_ref (build_groups groups)))) - end)) - end - | translate_stmt tctx (CGoto0 (ident, _)) = - let val name = C_Ast_Utils.ident_name ident - val is_forward_target = - List.exists (fn n => n = name) (C_Trans_Ctxt.get_active_goto_labels tctx) - in case C_Trans_Ctxt.lookup_goto_ref tctx name of - SOME goto_ref => - if is_forward_target then - C_Term_Build.mk_var_write goto_ref - (C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 1) - else - unsupported ("non-forward goto not supported: " ^ name) - | NONE => unsupported ("goto target not found: " ^ name) - end - | translate_stmt tctx (CLabel0 (_, stmt, _, _)) = - (* Labels as standalone statements (not in compound block context): - just translate the labeled statement. The label flag reset is handled - by translate_compound_items when the label appears in a block. *) - translate_stmt tctx stmt - | translate_stmt tctx (CCont0 _) = - (case C_Trans_Ctxt.get_continue_ref tctx of - SOME cont_ref => - C_Term_Build.mk_var_write cont_ref - (C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 1) - | NONE => unsupported "continue outside loop") - | translate_stmt tctx (CBreak0 _) = - (case C_Trans_Ctxt.get_break_ref tctx of - SOME break_ref => - C_Term_Build.mk_var_write break_ref - (C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 1) - | NONE => unsupported "break outside loop/switch") - | translate_stmt _ _ = - unsupported "statement" - - fun translate_fundef struct_tab enum_tab typedef_tab func_ret_types func_param_types global_consts ctxt - (CFunDef0 (specs, declr, _, body, _)) = - let - val name = C_Ast_Utils.declr_name declr - val _ = - if C_Ast_Utils.declr_is_variadic declr then - unsupported ("variadic functions are not supported: " ^ name) - else () - (* Register the function's return type for cross-function call type tracking *) - val ret_base_cty = (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of - SOME C_Ast_Utils.CVoid => C_Ast_Utils.CVoid - | SOME t => t | NONE => C_Ast_Utils.CInt) - val ret_cty = C_Ast_Utils.apply_ptr_depth ret_base_cty - (C_Ast_Utils.pointer_depth_of_declr declr) - val _ = func_ret_types := Symtab.update (name, ret_cty) (! func_ret_types) - val param_names = C_Ast_Utils.extract_params declr - val param_decls = C_Ast_Utils.extract_param_decls declr - (* Extract parameter types and pointer-ness from declarations. - Use resolve_c_type_full so that typedef'd types (e.g. uint32) resolve - correctly to their underlying C type for signed/unsigned dispatch. *) - val param_info = List.map (fn pdecl => - let val cty = case pdecl of - CDecl0 (specs, _, _) => - (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of - SOME t => t | NONE => C_Ast_Utils.CInt) - | _ => C_Ast_Utils.CInt - val ptr_depth = C_Ast_Utils.pointer_depth_of_decl pdecl - val reg_cty = C_Ast_Utils.apply_ptr_depth cty ptr_depth - in reg_cty end) param_decls - (* Pair names with type info; fall back to (CInt, false) if lengths differ *) - val param_name_info = ListPair.zipEq (param_names, param_info) - handle ListPair.UnequalLengths => - List.map (fn n => (n, C_Ast_Utils.CInt)) param_names - (* Create free variables for each parameter. - Pointer params use dummyT (Isabelle infers reference types). - Non-pointer params get explicit types for signed/unsigned dispatch. *) - val param_vars = List.map (fn (n, cty) => - let val hol_ty = if C_Ast_Utils.is_ptr cty then isa_dummyT else C_Ast_Utils.hol_type_of cty - in (n, Isa_Free (n, hol_ty), cty) end) param_name_info - (* Add parameters to the translation context as Param (by-value) *) - val tctx = List.foldl - (fn ((n, v, cty), ctx) => C_Trans_Ctxt.add_var n C_Trans_Ctxt.Param v cty ctx) - (C_Trans_Ctxt.make ctxt struct_tab enum_tab typedef_tab func_ret_types func_param_types - (!current_ref_addr_ty) (!current_ref_gv_ty)) param_vars - val tctx = List.foldl (fn ((gname, gterm, gcty, garr_meta, gstruct), ctx) => - let - val ctx' = C_Trans_Ctxt.add_global_const gname gterm gcty ctx - val ctx' = (case gstruct of - SOME sn => C_Trans_Ctxt.set_struct_type gname sn ctx' - | NONE => ctx') - val ctx' = (case garr_meta of - SOME (elem_cty, n) => C_Trans_Ctxt.set_array_decl gname elem_cty n ctx' - | NONE => ctx') - in ctx' end) - tctx global_consts - (* Annotate struct pointer parameters with their struct type. - Uses _full variant to also recognize typedef'd struct names. *) - val struct_names = Symtab.keys struct_tab - val union_names = !current_union_names - val tctx = List.foldl (fn (pdecl, ctx) => - case (C_Ast_Utils.param_name pdecl, - C_Ast_Utils.extract_struct_type_from_decl_full struct_names pdecl) of - (SOME n, SOME sn) => C_Trans_Ctxt.set_struct_type n sn ctx - | _ => - (case (C_Ast_Utils.param_name pdecl, - C_Ast_Utils.extract_union_type_from_decl_full union_names pdecl) of - (SOME n, SOME un) => C_Trans_Ctxt.set_struct_type n un ctx - | _ => ctx)) tctx param_decls - (* Promote parameters that are assigned in the body to local variables. - For each promoted parameter, wrap the body with Ref::new(literal param) - and register the ref as a Local in the context (shadowing the Param). *) - val assigned_names = C_Ast_Utils.find_assigned_vars body - val promoted_params = List.filter (fn (n, _, _) => - List.exists (fn a => a = n) assigned_names) param_vars - val (tctx, promoted_bindings) = List.foldl - (fn ((n, orig_var, cty), (ctx, binds)) => - let - val val_type = C_Ast_Utils.hol_type_of cty - val alloc_expr = - mk_resolved_var_alloc_typed (C_Trans_Ctxt.get_ctxt ctx) val_type - (C_Term_Build.mk_literal orig_var) - val ref_var = mk_typed_ref_var ctx (n ^ "_ref") alloc_expr - val ctx' = C_Trans_Ctxt.add_var n C_Trans_Ctxt.Local ref_var cty ctx - in (ctx', binds @ [(ref_var, alloc_expr)]) end) - (tctx, []) promoted_params - (* Allocate goto flag references for forward-only goto support. - Each label targeted by a goto gets a flag ref initialized to 0. *) - val goto_labels = C_Ast_Utils.find_goto_targets body - val goto_ref_ty = mk_flag_ref_type tctx - val goto_refs = List.map (fn label_name => - (label_name, Isa_Free ("v__goto_" ^ label_name, goto_ref_ty))) goto_labels - val tctx = C_Trans_Ctxt.set_goto_refs goto_refs tctx - (* Set current return type for implicit narrowing in CReturn0 *) - val _ = current_ret_cty := SOME ret_cty - val body_term = translate_stmt tctx body - (* Wrap body with Ref::new for each promoted parameter *) - val body_term = List.foldr - (fn ((ref_var, alloc_expr), b) => - C_Term_Build.mk_bind - alloc_expr - (Term.lambda ref_var b)) - body_term promoted_bindings - (* Wrap body with Ref::new(0) for each goto flag ref *) - val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 - val body_term = List.foldr - (fn ((_, ref_var), b) => - C_Term_Build.mk_bind - (mk_resolved_var_alloc ctxt false_lit) - (Term.lambda ref_var b)) - body_term goto_refs - (* If an expression type constraint is set, constrain the body so that - type inference resolves state/abort/prompt to the locale's types instead of - leaving them as unconstrained variables that get fixated to rigid TFrees. *) - val body_term = - (case !current_ref_expr_constraint of - NONE => body_term - | SOME expr_ty => Type.constraint expr_ty body_term) - val fn_term = C_Term_Build.mk_function_body body_term - (* Wrap in lambdas for each parameter *) - val fn_term = List.foldr - (fn ((_, v, _), t) => Term.lambda v t) - fn_term param_vars - (* Abstract while-loop fuel variables as additional parameters *) - val fuel_frees = Isa_add_frees fn_term [] - |> List.filter (fn (n, _) => String.isPrefix "while_fuel" n) - |> List.map (fn (n, ty) => Isa_Free (n, ty)) - val fuel_count = List.length fuel_frees - val _ = if fuel_count > 0 then - (defined_func_fuels := - Symtab.update (!current_decl_prefix ^ name, fuel_count) (!defined_func_fuels); - writeln (" fuel params: " ^ Int.toString fuel_count)) - else () - val fn_term = List.foldr (fn (v, t) => Term.lambda v t) fn_term fuel_frees - val fn_term' = Syntax.check_term ctxt fn_term - in - (name, fn_term') - end -end -\ - -subsection \Definition Generation\ - -ML \ -structure C_Def_Gen : sig - type manifest = {functions: string list option, types: string list option} - val set_decl_prefix : string -> unit - val set_manifest : manifest -> unit - val set_abi_profile : C_ABI.profile -> unit - val set_ref_universe_types : typ -> typ -> unit - val set_ref_abort_type : typ option -> unit - val define_c_function : string -> string -> term -> local_theory -> local_theory - val process_translation_unit : C_Ast.nodeInfo C_Ast.cTranslationUnit - -> local_theory -> local_theory -end = -struct - type manifest = {functions: string list option, types: string list option} - - val current_decl_prefix : string Unsynchronized.ref = Unsynchronized.ref "c_" - val current_manifest : manifest Unsynchronized.ref = - Unsynchronized.ref {functions = NONE, types = NONE} - val current_abi_profile : C_ABI.profile Unsynchronized.ref = - Unsynchronized.ref C_ABI.LP64_LE - val current_ref_addr_ty : typ Unsynchronized.ref = - Unsynchronized.ref (TFree ("'addr", [])) - val current_ref_gv_ty : typ Unsynchronized.ref = - Unsynchronized.ref (TFree ("'gv", [])) - - fun set_decl_prefix pfx = (current_decl_prefix := pfx) - fun set_manifest m = (current_manifest := m) - fun set_abi_profile abi = (current_abi_profile := abi) - fun set_ref_universe_types addr_ty gv_ty = - (current_ref_addr_ty := addr_ty; current_ref_gv_ty := gv_ty) - fun set_ref_abort_type expr_constraint_opt = - (C_Translate.set_ref_abort_type expr_constraint_opt) - - fun define_c_function prefix name term lthy = - let - val full_name = prefix ^ name - val binding = Binding.name full_name - val term' = term |> Syntax.check_term lthy - val ((lhs_term, (_, _)), lthy') = - Local_Theory.define - ((binding, NoSyn), - ((Thm.def_binding binding, @{attributes [micro_rust_simps]}), term')) - lthy - (* Use target_morphism (cf. specification.ML:269) to convert the - locale Free back to its qualified Const. The morphism result is - Const(c,U) $ param1 $ param2 $ ..., so extract with head_of. *) - val _ = - (case Term.head_of (Morphism.term (Local_Theory.target_morphism lthy') lhs_term) of - Term.Const (c, _) => - (C_Translate.defined_func_consts := - Symtab.update (full_name, c) (! C_Translate.defined_func_consts); - writeln ("Defined: " ^ full_name ^ " (const: " ^ c ^ ")")) - | _ => writeln ("Defined: " ^ full_name ^ " (no const mapping)")) - in lthy' end - - fun define_c_global_value prefix name term lthy = - let - val full_name = prefix ^ "global_" ^ name - val binding = Binding.name full_name - val term' = term |> Syntax.check_term lthy - val ((_, (_, _)), lthy') = - Local_Theory.define - ((binding, NoSyn), - ((Thm.def_binding binding, @{attributes [micro_rust_simps]}), term')) - lthy - val _ = writeln ("Defined: " ^ full_name) - in lthy' end - - fun define_named_value_if_absent full_name term lthy = - let - val ctxt = Local_Theory.target_of lthy - val exists = can (Proof_Context.read_const {proper = true, strict = true} ctxt) full_name - in - if exists then lthy - else - let - val binding = Binding.name full_name - val term' = term |> Syntax.check_term lthy - val ((_, (_, _)), lthy') = - Local_Theory.define - ((binding, NoSyn), - ((Thm.def_binding binding, @{attributes [micro_rust_simps]}), term')) - lthy - val _ = writeln ("Defined: " ^ full_name) - in lthy' end - end - - fun abi_is_big_endian C_ABI.LP64_BE = true - | abi_is_big_endian _ = false - - fun mk_bool_term true = @{term True} - | mk_bool_term false = @{term False} - - fun define_abi_metadata prefix abi_profile lthy = - let - val defs = [ - ("abi_pointer_bits", HOLogic.mk_nat (C_ABI.pointer_bits abi_profile)), - ("abi_long_bits", HOLogic.mk_nat (C_ABI.long_bits abi_profile)), - ("abi_char_is_signed", mk_bool_term (C_ABI.char_is_signed abi_profile)), - ("abi_big_endian", mk_bool_term (abi_is_big_endian abi_profile)) - ] - in - List.foldl (fn ((suffix, tm), lthy_acc) => - define_named_value_if_absent (prefix ^ suffix) tm lthy_acc) lthy defs - end - - fun intinf_to_int_checked what n = - let - val ge_min = - (case Int.minInt of - SOME lo => n >= IntInf.fromInt lo - | NONE => true) - val le_max = - (case Int.maxInt of - SOME hi => n <= IntInf.fromInt hi - | NONE => true) - in - if ge_min andalso le_max then IntInf.toInt n - else error ("micro_c_translate: " ^ what ^ " out of ML-int range: " ^ IntInf.toString n) - end - - fun struct_name_of_cty (C_Ast_Utils.CStruct sname) = SOME sname - | struct_name_of_cty (C_Ast_Utils.CPtr (C_Ast_Utils.CStruct sname)) = SOME sname - | struct_name_of_cty (C_Ast_Utils.CUnion sname) = SOME sname - | struct_name_of_cty (C_Ast_Utils.CPtr (C_Ast_Utils.CUnion sname)) = SOME sname - | struct_name_of_cty _ = NONE - - fun type_exists ctxt tname = - can (Proof_Context.read_type_name {proper = true, strict = true} ctxt) tname - - fun ensure_struct_record prefix (sname, fields) lthy = - let - val tname = prefix ^ sname - val ctxt = Local_Theory.target_of lthy - in - if type_exists ctxt tname then lthy - else - let - val bad_fields = - List.filter (fn (_, ty_opt) => case ty_opt of NONE => true | SOME _ => false) fields - val _ = - if null bad_fields then () - else - error ("micro_c_translate: cannot auto-declare struct " ^ tname ^ - " because field type(s) are unsupported: " ^ - String.concatWith ", " (List.map #1 bad_fields) ^ - ". Please provide an explicit datatype_record declaration.") - val record_fields = - List.map (fn (fname, SOME ty) => (Binding.name (prefix ^ sname ^ "_" ^ fname), ty) - | (_, NONE) => raise Match) fields - val lthy' = - Datatype_Records.record - (Binding.name tname) - Datatype_Records.default_ctr_options - [] - record_fields - lthy - val _ = writeln ("Declared datatype_record: " ^ tname) - in - lthy' - end - end - - fun extract_global_consts typedef_tab struct_tab enum_tab - (C_Ast.CTranslUnit0 (ext_decls, _)) = - let - val struct_names = Symtab.keys struct_tab - fun has_const_qual specs = - List.exists (fn C_Ast.CTypeQual0 (C_Ast.CConstQual0 _) => true | _ => false) specs - fun has_array_declr (C_Ast.CDeclr0 (_, derived, _, _, _)) = - List.exists (fn C_Ast.CArrDeclr0 _ => true | _ => false) derived - fun array_decl_size (C_Ast.CDeclr0 (_, derived, _, _, _)) = - List.mapPartial - (fn C_Ast.CArrDeclr0 (_, C_Ast.CArrSize0 (_, C_Ast.CConst0 - (C_Ast.CIntConst0 (C_Ast.CInteger0 (n, _, _), _))), _) => - if n < 0 then - error "micro_c_translate: negative array bound not supported" - else - SOME (intinf_to_int_checked "array bound" n) - | _ => NONE) derived - |> (fn n :: _ => SOME n | [] => NONE) - fun init_scalar_const_value (C_Ast.CConst0 (C_Ast.CIntConst0 (C_Ast.CInteger0 (n, _, _), _))) = n - | init_scalar_const_value (C_Ast.CConst0 (C_Ast.CCharConst0 (C_Ast.CChar0 (c, _), _))) = - C_Ast.integer_of_char c - | init_scalar_const_value (C_Ast.CVar0 (ident, _)) = - let val name = C_Ast_Utils.ident_name ident - in case Symtab.lookup enum_tab name of - SOME value => IntInf.fromInt value - | NONE => - error ("micro_c_translate: unsupported global initializer element: " ^ name) - end - | init_scalar_const_value (C_Ast.CUnary0 (C_Ast.CMinOp0, e, _)) = - IntInf.~ (init_scalar_const_value e) - | init_scalar_const_value (C_Ast.CUnary0 (C_Ast.CPlusOp0, e, _)) = - init_scalar_const_value e - | init_scalar_const_value (C_Ast.CCast0 (_, e, _)) = - init_scalar_const_value e - | init_scalar_const_value _ = - error "micro_c_translate: non-constant global initializer element" - fun init_scalar_const_term target_cty expr = - HOLogic.mk_number (C_Ast_Utils.hol_type_of target_cty) - (intinf_to_int_checked "global initializer literal" - (init_scalar_const_value expr)) - fun process_decl specs declarators = - if not (has_const_qual specs) then [] - else - let - val base_cty = - (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of - SOME C_Ast_Utils.CVoid => C_Ast_Utils.CInt - | SOME t => t - | NONE => - (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of - SOME sn => C_Ast_Utils.CStruct sn - | NONE => - (case C_Ast_Utils.extract_union_type_from_specs_full (!C_Translate.current_union_names) specs of - SOME un => C_Ast_Utils.CUnion un - | NONE => C_Ast_Utils.CInt))) - fun process_one ((C_Ast.Some declr, C_Ast.Some (C_Ast.CInitExpr0 (init, _))), _) = - let - val name = C_Ast_Utils.declr_name declr - val ptr_depth = C_Ast_Utils.pointer_depth_of_declr declr - val actual_cty = C_Ast_Utils.apply_ptr_depth base_cty ptr_depth - val init_term = init_scalar_const_term actual_cty init - val arr_meta = - (case array_decl_size declr of - SOME n => - if ptr_depth > 0 - then SOME (C_Ast_Utils.apply_ptr_depth base_cty (ptr_depth - 1), n) - else NONE - | NONE => NONE) - in SOME (name, init_term, actual_cty, arr_meta, struct_name_of_cty actual_cty) end - | process_one ((C_Ast.Some declr, C_Ast.Some (C_Ast.CInitList0 (init_list, _))), _) = - let - val name = C_Ast_Utils.declr_name declr - val _ = - if has_array_declr declr then () - else error "micro_c_translate: initializer list for non-array global declaration" - val ptr_depth = C_Ast_Utils.pointer_depth_of_declr declr - val actual_cty = C_Ast_Utils.apply_ptr_depth base_cty ptr_depth - val elem_cty = - if ptr_depth > 0 then C_Ast_Utils.apply_ptr_depth base_cty (ptr_depth - 1) else base_cty - val elem_values = List.map - (fn ([], C_Ast.CInitExpr0 (e, _)) => init_scalar_const_term elem_cty e - | _ => error "micro_c_translate: complex global array initializer element") init_list - val declared_size = array_decl_size declr - val zero_value = HOLogic.mk_number (C_Ast_Utils.hol_type_of elem_cty) 0 - val padded_values = - case declared_size of - SOME n => - if List.length elem_values > n - then error "micro_c_translate: too many initializers for global array" - else elem_values @ List.tabulate (n - List.length elem_values, fn _ => zero_value) - | NONE => elem_values - val list_term = HOLogic.mk_list (C_Ast_Utils.hol_type_of elem_cty) padded_values - val arr_meta = - (case declared_size of - SOME n => SOME (elem_cty, n) - | NONE => NONE) - in SOME (name, list_term, actual_cty, arr_meta, struct_name_of_cty actual_cty) end - | process_one ((C_Ast.Some _, C_Ast.None), _) = NONE - | process_one _ = - error "micro_c_translate: unsupported global declarator" - in List.mapPartial process_one declarators end - fun from_ext_decl (C_Ast.CDeclExt0 (C_Ast.CDecl0 (specs, declarators, _))) = - process_decl specs declarators - | from_ext_decl _ = [] - in - List.concat (List.map from_ext_decl ext_decls) - end - - fun process_translation_unit tu lthy = - let - val decl_prefix = !current_decl_prefix - val abi_profile = !current_abi_profile - val {functions = manifest_functions, types = manifest_types} = !current_manifest - val _ = C_Ast_Utils.set_abi_profile abi_profile - val _ = C_Translate.set_decl_prefix decl_prefix - val _ = C_Translate.set_ref_universe_types (!current_ref_addr_ty) (!current_ref_gv_ty) - fun mk_name_filter NONE = NONE - | mk_name_filter (SOME xs) = - SOME (List.foldl (fn (x, tab) => Symtab.update (x, ()) tab) Symtab.empty xs) - val func_filter = mk_name_filter manifest_functions - val type_filter = mk_name_filter manifest_types - fun keep_func name = - (case func_filter of NONE => true | SOME tab => Symtab.defined tab name) - fun keep_type name = - (case type_filter of NONE => true | SOME tab => Symtab.defined tab name) - val builtin_typedefs = C_Ast_Utils.builtin_typedefs () - (* Extract struct definitions to build the struct field registry. - Use fold/update to allow user typedefs to override builtins. *) - val typedef_defs_early = - builtin_typedefs @ List.filter (fn (n, _) => keep_type n) (C_Ast_Utils.extract_typedefs tu) - val typedef_tab_early = List.foldl (fn ((n, v), tab) => Symtab.update (n, v) tab) - Symtab.empty typedef_defs_early - val struct_defs = - List.filter (fn (n, _) => keep_type n) - (C_Ast_Utils.extract_struct_defs_with_types typedef_tab_early tu) - val struct_record_defs = - List.filter (fn (n, _) => keep_type n) - (C_Ast_Utils.extract_struct_record_defs decl_prefix typedef_tab_early tu) - val union_defs = - List.filter (fn (n, _) => keep_type n) - (C_Ast_Utils.extract_union_defs_with_types typedef_tab_early tu) - val union_names = List.map #1 union_defs - val _ = C_Translate.set_union_names union_names - val struct_tab = List.foldl (fn ((n, v), tab) => Symtab.update (n, v) tab) - (Symtab.make struct_defs) union_defs - val _ = List.app (fn (sname, fields) => - writeln ("Registered struct: " ^ sname ^ " with fields: " ^ - String.concatWith ", " (List.map #1 fields))) struct_defs - val _ = List.app (fn (uname, fields) => - writeln ("Registered union: " ^ uname ^ " with fields: " ^ - String.concatWith ", " (List.map #1 fields))) union_defs - (* Extract enum constant definitions *) - val enum_defs = List.filter (fn (n, _) => keep_type n) (C_Ast_Utils.extract_enum_defs tu) - val enum_tab = Symtab.make enum_defs - val _ = if null enum_defs then () else - List.app (fn (name, value) => - writeln ("Registered enum constant: " ^ name ^ " = " ^ - Int.toString value)) enum_defs - (* Extract typedef mappings *) - val typedef_defs = - builtin_typedefs @ List.filter (fn (n, _) => keep_type n) (C_Ast_Utils.extract_typedefs tu) - val typedef_tab = List.foldl (fn ((n, v), tab) => Symtab.update (n, v) tab) - Symtab.empty typedef_defs - val _ = if null typedef_defs then () else - List.app (fn (name, _) => - writeln ("Registered typedef: " ^ name)) typedef_defs - val fundefs_raw = - List.filter - (fn C_Ast.CFunDef0 (_, declr, _, _, _) => keep_func (C_Ast_Utils.declr_name declr)) - (C_Ast_Utils.extract_fundefs tu) - (* Pre-register all function signatures so calls to later-defined - functions are translated with the correct result and argument types. *) - fun param_cty_of_decl pdecl = - (case pdecl of - C_Ast.CDecl0 (specs, _, _) => - let - val base = (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of - SOME t => t - | NONE => C_Ast_Utils.CInt) - val depth = C_Ast_Utils.pointer_depth_of_decl pdecl - in C_Ast_Utils.apply_ptr_depth base depth end - | _ => C_Ast_Utils.CInt) - fun signature_of_declr specs declr = - let val fname = C_Ast_Utils.declr_name declr - val _ = - if C_Ast_Utils.declr_is_variadic declr then - error ("micro_c_translate: unsupported C construct: variadic function declaration: " ^ fname) - else () - val rty_base = (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of - SOME C_Ast_Utils.CVoid => C_Ast_Utils.CVoid - | SOME t => t | NONE => C_Ast_Utils.CInt) - val rty = C_Ast_Utils.apply_ptr_depth rty_base - (C_Ast_Utils.pointer_depth_of_declr declr) - val ptys = List.map param_cty_of_decl (C_Ast_Utils.extract_param_decls declr) - in (fname, (rty, ptys)) end - fun declr_is_function (C_Ast.CDeclr0 (_, derived, _, _, _)) = - List.exists (fn C_Ast.CFunDeclr0 _ => true | _ => false) derived - fun signatures_from_ext_decl (C_Ast.CDeclExt0 (C_Ast.CDecl0 (specs, declarators, _))) = - List.mapPartial - (fn ((C_Ast.Some declr, _), _) => - if declr_is_function declr andalso keep_func (C_Ast_Utils.declr_name declr) - then SOME (signature_of_declr specs declr) else NONE - | _ => NONE) - declarators - | signatures_from_ext_decl _ = [] - val C_Ast.CTranslUnit0 (ext_decls, _) = tu - fun fundef_signature (C_Ast.CFunDef0 (specs, declr, _, _, _)) = - signature_of_declr specs declr - val decl_signatures = List.concat (List.map signatures_from_ext_decl ext_decls) - fun fundef_name (C_Ast.CFunDef0 (_, declr, _, _, _)) = C_Ast_Utils.declr_name declr - val fun_names = List.map fundef_name fundefs_raw - val fun_name_tab = Symtab.make (List.map (fn n => (n, ())) fun_names) - val dep_tab = - List.foldl - (fn (fdef, tab) => - let - val name = fundef_name fdef - val deps = - List.filter (fn n => n <> name andalso Symtab.defined fun_name_tab n) - (C_Ast_Utils.find_called_functions fdef) - in - Symtab.update (name, deps) tab - end) - Symtab.empty fundefs_raw - val fundef_tab = Symtab.make (List.map (fn fdef => (fundef_name fdef, fdef)) fundefs_raw) - val decl_order_names = distinct (op =) (List.map #1 decl_signatures) - val preferred_names = - decl_order_names @ - List.filter (fn n => not (List.exists (fn m => m = n) decl_order_names)) fun_names - val has_cycle = Unsynchronized.ref false - fun visit stack seen order name = - if Symtab.defined seen name then (seen, order) - else if List.exists (fn n => n = name) stack then - (has_cycle := true; (seen, order)) - else - let - val deps = the_default [] (Symtab.lookup dep_tab name) - val (seen', order') = - List.foldl (fn (d, (s, ord)) => visit (name :: stack) s ord d) (seen, order) deps - val seen'' = Symtab.update (name, ()) seen' - in - (seen'', order' @ [name]) - end - val (_, topo_names) = - List.foldl (fn (n, (s, ord)) => visit [] s ord n) (Symtab.empty, []) preferred_names - val _ = - if !has_cycle then - writeln "micro_c_translate: recursion cycle detected; using deterministic SCC fallback order" - else () - val fundefs = List.mapPartial (fn n => Symtab.lookup fundef_tab n) topo_names - val _ = List.app (fn C_Ast.CFunDef0 (_, declr, _, _, _) => - let val name = C_Ast_Utils.declr_name declr - in if C_Ast_Utils.declr_is_variadic declr then - error ("micro_c_translate: unsupported C construct: variadic function definition: " ^ name) - else () - end) fundefs - val signatures = decl_signatures @ List.map fundef_signature fundefs - val func_ret_table = List.foldl - (fn ((n, (rty, _)), tab) => Symtab.update (n, rty) tab) - Symtab.empty signatures - val func_ret_types = Unsynchronized.ref func_ret_table - val func_param_table = List.foldl - (fn ((n, (_, ptys)), tab) => Symtab.update (n, ptys) tab) - Symtab.empty signatures - val func_param_types = Unsynchronized.ref func_param_table - val lthy = - List.foldl (fn (sdef, lthy_acc) => ensure_struct_record decl_prefix sdef lthy_acc) - lthy struct_record_defs - val global_const_inits = extract_global_consts typedef_tab struct_tab enum_tab tu - val (lthy, global_consts) = - List.foldl (fn ((gname, init_term, gcty, garr_meta, gstruct), (lthy_acc, acc)) => - let - val lthy' = define_c_global_value decl_prefix gname init_term lthy_acc - val ctxt' = Local_Theory.target_of lthy' - val (full_name, _) = - Term.dest_Const - (Proof_Context.read_const {proper = true, strict = false} ctxt' - (decl_prefix ^ "global_" ^ gname)) - val gterm = Const (full_name, dummyT) - in - (lthy', acc @ [(gname, gterm, gcty, garr_meta, gstruct)]) - end) - (lthy, []) global_const_inits - val lthy = - (* Define ABI metadata after type-generation commands (e.g. datatype_record) - so locale-target equations from these definitions cannot interfere with - datatype package obligations. *) - define_abi_metadata decl_prefix abi_profile lthy - in - (* Translate and define each function one at a time, so that later - functions can reference earlier ones via Syntax.check_term. *) - List.foldl (fn (fundef, lthy) => - let val (name, term) = C_Translate.translate_fundef - struct_tab enum_tab typedef_tab func_ret_types func_param_types global_consts lthy fundef - in define_c_function decl_prefix name term lthy end) lthy fundefs - end -end -\ - -subsection \The \micro_c_translate\ Command\ - -text \ - The command parses inline C source via Isabelle/C's parser (reusing the - existing infrastructure including the @{text "Root_Ast_Store"}) and - generates @{command definition} commands for each function found. - - Usage: - @{text [display] "micro_c_translate \void f() { return; }\"} - @{text [display] "micro_c_translate prefix: my_ \void f() { return; }\"} - @{text [display] "micro_c_translate abi: lp64-le \void f() { return; }\"} - @{text [display] "micro_c_translate addr: 'addr gv: 'gv \void f() { return; }\"} - - Notes: - \<^item> Option keywords are exactly @{text "prefix:"}, @{text "addr:"}, @{text "gv:"}, and @{text "abi:"}. - \<^item> Currently supported @{text "abi:"} values are @{text "lp64-le"}, @{text "ilp32-le"}, and @{text "lp64-be"}. - \<^item> When omitted, declaration prefix defaults to @{text "c_"}. - \<^item> When omitted, @{text "abi:"} defaults to @{text "lp64-le"}. - \<^item> When omitted, @{text "addr:"} and @{text "gv:"} default to @{text "'addr"} and @{text "'gv"}. - \<^item> Each translation unit also defines ABI metadata constants - @{text "abi_pointer_bits"}, @{text "abi_long_bits"}, - @{text "abi_char_is_signed"}, and @{text "abi_big_endian"}. - \<^item> Struct declarations in the input are translated to corresponding - @{command "datatype_record"} declarations automatically when possible. -\ - -ML \ -local - datatype translate_opt = - TranslatePrefix of string - | TranslateAddrTy of string - | TranslateGvTy of string - | TranslateAbi of string - | TranslateAbortTy of string - val parse_abi_ident = Scan.one (Token.ident_with (K true)) >> Token.content_of - val parse_abi_dash = - Scan.one (fn tok => Token.is_kind Token.Sym_Ident tok andalso Token.content_of tok = "-") >> K () - val parse_abi_name = - parse_abi_ident -- Scan.repeat (parse_abi_dash |-- parse_abi_ident) - >> (fn (h, t) => String.concatWith "-" (h :: t)) - val parse_prefix_key = Parse.$$$ "prefix:" >> K () - val parse_addr_key = Parse.$$$ "addr:" >> K () - val parse_gv_key = Parse.$$$ "gv:" >> K () - val parse_abi_key = Parse.$$$ "abi:" >> K () - val parse_abort_key = Parse.$$$ "abort:" >> K () - val parse_translate_opt = - (parse_prefix_key |-- Parse.name >> TranslatePrefix) - || (parse_addr_key |-- Parse.typ >> TranslateAddrTy) - || (parse_gv_key |-- Parse.typ >> TranslateGvTy) - || (parse_abi_key |-- parse_abi_name >> TranslateAbi) - || (parse_abort_key |-- Parse.typ >> TranslateAbortTy) - - fun apply_translate_opt (TranslatePrefix pfx) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt) = - (case prefix_opt of - NONE => (SOME pfx, addr_opt, gv_opt, abi_opt, abort_opt) - | SOME _ => error "micro_c_translate: duplicate prefix option") - | apply_translate_opt (TranslateAddrTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt) = - (case addr_opt of - NONE => (prefix_opt, SOME ty, gv_opt, abi_opt, abort_opt) - | SOME _ => error "micro_c_translate: duplicate addr option") - | apply_translate_opt (TranslateGvTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt) = - (case gv_opt of - NONE => (prefix_opt, addr_opt, SOME ty, abi_opt, abort_opt) - | SOME _ => error "micro_c_translate: duplicate gv option") - | apply_translate_opt (TranslateAbi abi_name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt) = - (case abi_opt of - NONE => (prefix_opt, addr_opt, gv_opt, SOME abi_name, abort_opt) - | SOME _ => error "micro_c_translate: duplicate abi option") - | apply_translate_opt (TranslateAbortTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt) = - (case abort_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, SOME ty) - | SOME _ => error "micro_c_translate: duplicate abort option") - - fun collect_translate_opts opts = - fold apply_translate_opt opts (NONE, NONE, NONE, NONE, NONE) -in -val _ = - Outer_Syntax.local_theory \<^command_keyword>\micro_c_translate\ - "parse C source and generate core monad definitions" - (Scan.repeat parse_translate_opt -- Parse.embedded_input -- Scan.repeat parse_translate_opt >> - (fn ((opts_pre, source), opts_post) => fn lthy => - let - val (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt) = collect_translate_opts (opts_pre @ opts_post) - val prefix = the_default "c_" prefix_opt - val abi_profile = C_ABI.parse_profile (the_default "lp64-le" abi_opt) - val addr_ty = Syntax.read_typ lthy (the_default "'addr" addr_opt) - val gv_ty = Syntax.read_typ lthy (the_default "'gv" gv_opt) - val abort_ty_opt = Option.map (Syntax.read_typ lthy) abort_opt - (* Build expression type constraint from abort type + locale's reference_types. - This constrains state/abort/prompt positions so that type inference doesn't - leave them as unconstrained TFrees that can't unify across functions. *) - val expr_constraint = - (case abort_ty_opt of - NONE => NONE - | SOME abort_ty => - let - val ref_args = - (case try (Syntax.check_term lthy) (Free ("reference_types", dummyT)) of - SOME (Free (_, ref_ty)) => - C_Translate.strip_isa_fun_type ref_ty - | _ => []) - val (state_ty, prompt_in_ty, prompt_out_ty) = - (case ref_args of - [s, _, _, _, i, o] => (s, i, o) - | _ => (dummyT, dummyT, dummyT)) - in - SOME (Type (\<^type_name>\expression\, - [state_ty, dummyT, dummyT, abort_ty, prompt_in_ty, prompt_out_ty])) - end) - (* Step 1: Parse the C source using Isabelle/C's parser. - We use a Theory context so that Root_Ast_Store is updated at the - theory level, where get_CTranslUnit can retrieve it. *) - val thy = Proof_Context.theory_of lthy - val context' = C_Module.exec_eval source (Context.Theory thy) - val thy' = Context.theory_of context' - - (* Step 2: Retrieve the parsed AST from Root_Ast_Store *) - val tu = get_CTranslUnit thy' - - (* Step 3: Translate and generate definitions *) - val _ = C_Def_Gen.set_decl_prefix prefix - val _ = C_Def_Gen.set_manifest {functions = NONE, types = NONE} - val _ = C_Def_Gen.set_abi_profile abi_profile - val _ = C_Def_Gen.set_ref_universe_types addr_ty gv_ty - val _ = C_Def_Gen.set_ref_abort_type expr_constraint - in - C_Def_Gen.process_translation_unit tu lthy - end)) -end -\ - -text \ - The @{text "micro_c_file"} command loads C source from an external file, - parses it using Isabelle/C, and generates core monad definitions. - This enables keeping verified C code in separate @{text ".c"} files, - identical to upstream sources. - - Usage: - @{text [display] "micro_c_file \path/to/file.c\"} - @{text [display] "micro_c_file prefix: my_ \path/to/file.c\"} - @{text [display] "micro_c_file prefix: my_ manifest: \path/to/manifest.txt\ \path/to/file.c\"} - @{text [display] "micro_c_file \path/to/file.c\ prefix: my_"} - @{text [display] "micro_c_file \path/to/file.c\ manifest: \path/to/manifest.txt\"} - @{text [display] "micro_c_file abi: ilp32-le \path/to/file.c\"} - @{text [display] "micro_c_file addr: 'addr gv: 'gv \path/to/file.c\"} - - Manifest format (plain text): - @{text [display] "functions:"} - @{text [display] " foo"} - @{text [display] " - bar"} - @{text [display] "types:"} - @{text [display] " my_struct"} - @{text [display] " my_enum"} - - Notes: - \<^item> Option keywords are exactly @{text "prefix:"}, @{text "addr:"}, @{text "gv:"}, @{text "abi:"}, and @{text "manifest:"}. - \<^item> Currently supported @{text "abi:"} values are @{text "lp64-le"}, @{text "ilp32-le"}, and @{text "lp64-be"}. - \<^item> Options may appear before and/or after the C file argument. - \<^item> Each option may appear at most once. - \<^item> When omitted, declaration prefix defaults to @{text "c_"}. - \<^item> When omitted, @{text "abi:"} defaults to @{text "lp64-le"}. - \<^item> When omitted, @{text "addr:"} and @{text "gv:"} default to @{text "'addr"} and @{text "'gv"}. - \<^item> Each translation unit also defines ABI metadata constants - @{text "abi_pointer_bits"}, @{text "abi_long_bits"}, - @{text "abi_char_is_signed"}, and @{text "abi_big_endian"}. - \<^item> Sections are optional; supported section headers are exactly @{text "functions:"} and @{text "types:"}. - \<^item> Lines outside a section are rejected. - \<^item> Leading/trailing whitespace is ignored. - \<^item> A leading @{text "-"} on an entry is optional and ignored. - \<^item> @{text "#"} starts a line comment. - \<^item> Struct declarations in the input are translated to corresponding - @{command "datatype_record"} declarations automatically when possible. -\ - -ML \ -local - datatype manifest_section = Manifest_None | Manifest_Functions | Manifest_Types - datatype load_opt = - LoadPrefix of string - | LoadAddrTy of string - | LoadGvTy of string - | LoadAbi of string - | LoadAbortTy of string - | LoadManifest of (theory -> Token.file) - val parse_abi_ident = Scan.one (Token.ident_with (K true)) >> Token.content_of - val parse_abi_dash = - Scan.one (fn tok => Token.is_kind Token.Sym_Ident tok andalso Token.content_of tok = "-") >> K () - val parse_abi_name = - parse_abi_ident -- Scan.repeat (parse_abi_dash |-- parse_abi_ident) - >> (fn (h, t) => String.concatWith "-" (h :: t)) - val parse_prefix_key = Parse.$$$ "prefix:" >> K () - val parse_addr_key = Parse.$$$ "addr:" >> K () - val parse_gv_key = Parse.$$$ "gv:" >> K () - val parse_abi_key = Parse.$$$ "abi:" >> K () - val parse_abort_key = Parse.$$$ "abort:" >> K () - val parse_manifest_key = Parse.$$$ "manifest:" >> K () - val parse_load_opt = - (parse_prefix_key |-- Parse.name >> LoadPrefix) - || (parse_addr_key |-- Parse.typ >> LoadAddrTy) - || (parse_gv_key |-- Parse.typ >> LoadGvTy) - || (parse_abi_key |-- parse_abi_name >> LoadAbi) - || (parse_abort_key |-- Parse.typ >> LoadAbortTy) - || (parse_manifest_key |-- Resources.parse_file >> LoadManifest) - val semi = Scan.option \<^keyword>\;\; - - fun trim s = Symbol.trim_blanks s - - fun drop_comment line = - (case String.fields (fn c => c = #"#") line of - [] => "" - | x :: _ => x) - - fun parse_manifest_text text = - let - fun add_name sec raw (fs, ts) = - let val name0 = trim raw - val name = if String.isPrefix "-" name0 then trim (String.extract (name0, 1, NONE)) else name0 - in - if name = "" then (fs, ts) - else - (case sec of - Manifest_Functions => (name :: fs, ts) - | Manifest_Types => (fs, name :: ts) - | Manifest_None => - error ("micro_c_file: manifest entry outside section (functions:/types:): " ^ raw)) - end - - fun step (raw, (sec, fs, ts)) = - let val line = trim (drop_comment raw) - in - if line = "" then (sec, fs, ts) - else if line = "functions:" then (Manifest_Functions, fs, ts) - else if line = "types:" then (Manifest_Types, fs, ts) - else - let val (fs', ts') = add_name sec line (fs, ts) - in (sec, fs', ts') end - end - - val (_, rev_fs, rev_ts) = - List.foldl step (Manifest_None, [], []) (String.tokens (fn c => c = #"\n" orelse c = #"\r") text) - val fs = rev rev_fs - val ts = rev rev_ts - in - { functions = if null fs then NONE else SOME fs - , types = if null ts then NONE else SOME ts } - end - - fun apply_load_opt (LoadPrefix prefix) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, manifest_opt) = - (case prefix_opt of - NONE => (SOME prefix, addr_opt, gv_opt, abi_opt, abort_opt, manifest_opt) - | SOME _ => error "micro_c_file: duplicate prefix option") - | apply_load_opt (LoadAddrTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, manifest_opt) = - (case addr_opt of - NONE => (prefix_opt, SOME ty, gv_opt, abi_opt, abort_opt, manifest_opt) - | SOME _ => error "micro_c_file: duplicate addr option") - | apply_load_opt (LoadGvTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, manifest_opt) = - (case gv_opt of - NONE => (prefix_opt, addr_opt, SOME ty, abi_opt, abort_opt, manifest_opt) - | SOME _ => error "micro_c_file: duplicate gv option") - | apply_load_opt (LoadAbi abi_name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, manifest_opt) = - (case abi_opt of - NONE => (prefix_opt, addr_opt, gv_opt, SOME abi_name, abort_opt, manifest_opt) - | SOME _ => error "micro_c_file: duplicate abi option") - | apply_load_opt (LoadAbortTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, manifest_opt) = - (case abort_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, SOME ty, manifest_opt) - | SOME _ => error "micro_c_file: duplicate abort option") - | apply_load_opt (LoadManifest get_file) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, manifest_opt) = - (case manifest_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, SOME get_file) - | SOME _ => error "micro_c_file: duplicate manifest option") - - fun collect_load_opts opts = fold apply_load_opt opts (NONE, NONE, NONE, NONE, NONE, NONE) -in -val _ = - Outer_Syntax.local_theory \<^command_keyword>\micro_c_file\ - "load C file and generate core monad definitions" - (Scan.repeat parse_load_opt -- Resources.parse_file -- Scan.repeat parse_load_opt --| semi >> - (fn ((opts_pre, get_file), opts_post) => fn lthy => - let - val (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, manifest_get_file) = collect_load_opts (opts_pre @ opts_post) - val prefix = the_default "c_" prefix_opt - val abi_profile = C_ABI.parse_profile (the_default "lp64-le" abi_opt) - val addr_ty = Syntax.read_typ lthy (the_default "'addr" addr_opt) - val gv_ty = Syntax.read_typ lthy (the_default "'gv" gv_opt) - val abort_ty_opt = Option.map (Syntax.read_typ lthy) abort_opt - (* Build expression type constraint from abort type + locale's reference_types *) - val expr_constraint = - (case abort_ty_opt of - NONE => NONE - | SOME abort_ty => - let - val ref_args = - (case try (Syntax.check_term lthy) (Free ("reference_types", dummyT)) of - SOME (Free (_, ref_ty)) => - C_Translate.strip_isa_fun_type ref_ty - | _ => []) - val (state_ty, prompt_in_ty, prompt_out_ty) = - (case ref_args of - [s, _, _, _, i, o] => (s, i, o) - | _ => (dummyT, dummyT, dummyT)) - in - SOME (Type (\<^type_name>\expression\, - [state_ty, dummyT, dummyT, abort_ty, prompt_in_ty, prompt_out_ty])) - end) - val thy = Proof_Context.theory_of lthy - val {src_path, lines, digest, pos} : Token.file = get_file thy - - (* Step 1: Parse the C file using Isabelle/C's parser *) - val source = Input.source true (cat_lines lines) (pos, pos) - val context' = C_Module.exec_eval source (Context.Theory thy) - val thy' = Context.theory_of context' - - (* Step 2: Register file dependency so Isabelle rebuilds if file changes. - Allow the same source file to be used across multiple micro_c_file - invocations (e.g. with different manifests for layered extraction). *) - val lthy = Local_Theory.background_theory - (fn thy => Resources.provide (src_path, digest) thy - handle ERROR msg => - if String.isSubstring "Duplicate use of source file" msg - then thy - else error msg) lthy - - (* Optional manifest file controlling which functions/types are extracted. *) - val (manifest, lthy) = - (case manifest_get_file of - NONE => ({functions = NONE, types = NONE}, lthy) - | SOME get_manifest_file => - let - val {src_path = m_src, lines = m_lines, digest = m_digest, ...} : Token.file = - get_manifest_file thy - val lthy' = - Local_Theory.background_theory - (fn thy => Resources.provide (m_src, m_digest) thy - handle ERROR msg => - if String.isSubstring "Duplicate use of source file" msg - then thy - else error msg) lthy - in - (parse_manifest_text (cat_lines m_lines), lthy') - end) - - (* Step 3: Retrieve parsed AST and translate *) - val tu = get_CTranslUnit thy' - val _ = C_Def_Gen.set_decl_prefix prefix - val _ = C_Def_Gen.set_manifest manifest - val _ = C_Def_Gen.set_abi_profile abi_profile - val _ = C_Def_Gen.set_ref_universe_types addr_ty gv_ty - val _ = C_Def_Gen.set_ref_abort_type expr_constraint - in - C_Def_Gen.process_translation_unit tu lthy - end)) -end -\ - -end diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy new file mode 100644 index 00000000..2ecd451f --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -0,0 +1,5991 @@ +theory C_Translation_Engine + imports + C_Ast_Utilities + "Shallow_Micro_Rust.Core_Expression" + "Shallow_Micro_Rust.Prompts_And_Responses" + "Shallow_Micro_Rust.Core_Syntax" + "Shallow_Micro_Rust.Bool_Type" + "Shallow_Micro_Rust.Rust_Iterator" + "Shallow_Micro_C.C_Translation_Model" +begin + +subsection \Translation Context\ + +text \ + The translation context tracks information accumulated during AST traversal: + variable bindings (mapping C variable names to Isabelle free variables), + function signatures, and diagnostics. +\ + +ML \ +structure C_Trans_Ctxt : sig + datatype var_kind = Param | ParamListPtr | Local | LocalPtr (* Param = by-value, ParamListPtr = by-value list-backed pointer alias, Local = mutable reference, LocalPtr = mutable raw-pointer reference *) + type t + val make : Proof.context -> (string * C_Ast_Utils.c_numeric_type) list Symtab.table + -> int Symtab.table -> C_Ast_Utils.c_numeric_type Symtab.table + -> C_Ast_Utils.c_numeric_type Symtab.table Unsynchronized.ref + -> C_Ast_Utils.c_numeric_type list Symtab.table Unsynchronized.ref + -> typ -> typ -> t + val get_ctxt : t -> Proof.context + val get_ref_addr_ty : t -> typ + val get_ref_gv_ty : t -> typ + val add_var : string -> var_kind -> term -> C_Ast_Utils.c_numeric_type -> t -> t + val lookup_var : t -> string -> (var_kind * term * C_Ast_Utils.c_numeric_type) option + val add_global_const : string -> term -> C_Ast_Utils.c_numeric_type -> t -> t + val lookup_global_const : t -> string -> (term * C_Ast_Utils.c_numeric_type) option + val get_struct_names : t -> string list + val set_struct_type : string -> string -> t -> t + val get_struct_type : t -> string -> string option + val get_struct_fields : t -> string -> (string * C_Ast_Utils.c_numeric_type) list option + val lookup_struct_field_type : t -> string -> string -> C_Ast_Utils.c_numeric_type option + val set_array_decl : string -> C_Ast_Utils.c_numeric_type -> int -> t -> t + val lookup_array_decl : t -> string -> (C_Ast_Utils.c_numeric_type * int) option + val lookup_enum_const : t -> string -> int option + val add_enum_consts : (string * int) list -> t -> t + val get_typedef_tab : t -> C_Ast_Utils.c_numeric_type Symtab.table + val register_func_return_type : string -> C_Ast_Utils.c_numeric_type -> t -> unit + val lookup_func_return_type : t -> string -> C_Ast_Utils.c_numeric_type option + val register_func_param_types : string -> C_Ast_Utils.c_numeric_type list -> t -> unit + val lookup_func_param_types : t -> string -> C_Ast_Utils.c_numeric_type list option + val get_break_ref : t -> term option + val get_continue_ref : t -> term option + val set_break_ref : term -> t -> t + val set_continue_ref : term -> t -> t + val clear_break_ref : t -> t + val get_goto_refs : t -> (string * term) list + val set_goto_refs : (string * term) list -> t -> t + val lookup_goto_ref : t -> string -> term option + val get_active_goto_labels : t -> string list + val set_active_goto_labels : string list -> t -> t +end = +struct + datatype var_kind = Param | ParamListPtr | Local | LocalPtr + type t = { + ctxt : Proof.context, + vars : (var_kind * term * C_Ast_Utils.c_numeric_type) Symtab.table, + global_consts : (term * C_Ast_Utils.c_numeric_type) Symtab.table, + struct_types : string Symtab.table, (* var_name -> c_struct_name *) + struct_fields : (string * C_Ast_Utils.c_numeric_type) list Symtab.table, + array_decls : (C_Ast_Utils.c_numeric_type * int) Symtab.table, (* var_name -> (elem_cty, size) *) + enum_consts : int Symtab.table, (* enum_name -> int_value *) + typedef_tab : C_Ast_Utils.c_numeric_type Symtab.table, + func_ret_types : C_Ast_Utils.c_numeric_type Symtab.table Unsynchronized.ref, + func_param_types : C_Ast_Utils.c_numeric_type list Symtab.table Unsynchronized.ref, + ref_addr_ty : typ, + ref_gv_ty : typ, + break_ref : term option, + continue_ref : term option, + goto_refs : (string * term) list, (* label_name -> flag ref variable *) + active_goto_labels : string list (* labels that are valid forward goto targets from here *) + } + + fun make ctxt struct_fields enum_consts typedef_tab func_ret_types func_param_types + ref_addr_ty ref_gv_ty : t = + { ctxt = ctxt, vars = Symtab.empty, global_consts = Symtab.empty, struct_types = Symtab.empty, + struct_fields = struct_fields, array_decls = Symtab.empty, + enum_consts = enum_consts, + typedef_tab = typedef_tab, func_ret_types = func_ret_types, + func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, + break_ref = NONE, continue_ref = NONE, + goto_refs = [], active_goto_labels = [] } + + fun get_ctxt ({ ctxt, ... } : t) = ctxt + fun get_ref_addr_ty ({ ref_addr_ty, ... } : t) = ref_addr_ty + fun get_ref_gv_ty ({ ref_gv_ty, ... } : t) = ref_gv_ty + + fun add_var name kind tm cty ({ ctxt, vars, global_consts, struct_types, struct_fields, + array_decls, enum_consts, typedef_tab, func_ret_types, + func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, goto_refs, + active_goto_labels } : t) : t = + { ctxt = ctxt, vars = Symtab.update (name, (kind, tm, cty)) vars, + global_consts = global_consts, + struct_types = struct_types, struct_fields = struct_fields, + array_decls = array_decls, + enum_consts = enum_consts, typedef_tab = typedef_tab, + func_ret_types = func_ret_types, + func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, + break_ref = break_ref, continue_ref = continue_ref, + goto_refs = goto_refs, active_goto_labels = active_goto_labels } + + fun lookup_var ({ vars, ... } : t) name = + Symtab.lookup vars name + + fun add_global_const name tm cty + ({ ctxt, vars, global_consts, struct_types, struct_fields, array_decls, enum_consts, + typedef_tab, func_ret_types, func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, goto_refs, + active_goto_labels } : t) : t = + { ctxt = ctxt, vars = vars, + global_consts = Symtab.update (name, (tm, cty)) global_consts, + struct_types = struct_types, struct_fields = struct_fields, + array_decls = array_decls, enum_consts = enum_consts, typedef_tab = typedef_tab, + func_ret_types = func_ret_types, func_param_types = func_param_types, + ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, + break_ref = break_ref, continue_ref = continue_ref, + goto_refs = goto_refs, active_goto_labels = active_goto_labels } + + fun lookup_global_const ({ global_consts, ... } : t) name = + Symtab.lookup global_consts name + + fun get_struct_names ({ struct_fields, ... } : t) = + Symtab.keys struct_fields + + fun set_struct_type var_name struct_name + ({ ctxt, vars, global_consts, struct_types, struct_fields, array_decls, enum_consts, typedef_tab, + func_ret_types, func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, goto_refs, + active_goto_labels } : t) : t = + { ctxt = ctxt, vars = vars, global_consts = global_consts, + struct_types = Symtab.update (var_name, struct_name) struct_types, + struct_fields = struct_fields, array_decls = array_decls, + enum_consts = enum_consts, + typedef_tab = typedef_tab, func_ret_types = func_ret_types, + func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, + break_ref = break_ref, continue_ref = continue_ref, + goto_refs = goto_refs, active_goto_labels = active_goto_labels } + + fun get_struct_type ({ struct_types, ... } : t) name = + Symtab.lookup struct_types name + + fun get_struct_fields ({ struct_fields, ... } : t) name = + Symtab.lookup struct_fields name + + fun lookup_struct_field_type tctx struct_name field_name = + case get_struct_fields tctx struct_name of + SOME fields => (case List.find (fn (n, _) => n = field_name) fields of + SOME (_, cty) => SOME cty | NONE => NONE) + | NONE => NONE + + fun set_array_decl var_name elem_cty size + ({ ctxt, vars, global_consts, struct_types, struct_fields, array_decls, enum_consts, + typedef_tab, func_ret_types, func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, + goto_refs, active_goto_labels } : t) : t = + { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, + struct_fields = struct_fields, + array_decls = Symtab.update (var_name, (elem_cty, size)) array_decls, + enum_consts = enum_consts, typedef_tab = typedef_tab, + func_ret_types = func_ret_types, func_param_types = func_param_types, + ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, + break_ref = break_ref, continue_ref = continue_ref, goto_refs = goto_refs, + active_goto_labels = active_goto_labels } + + fun lookup_array_decl ({ array_decls, ... } : t) name = + Symtab.lookup array_decls name + + fun lookup_enum_const ({ enum_consts, ... } : t) name = + Symtab.lookup enum_consts name + + fun add_enum_consts entries ({ ctxt, vars, struct_types, struct_fields, + global_consts, array_decls, enum_consts, typedef_tab, func_ret_types, + func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, goto_refs, + active_goto_labels } : t) : t = + { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, + struct_fields = struct_fields, + array_decls = array_decls, + enum_consts = List.foldl (fn ((n, v), tab) => Symtab.update (n, v) tab) + enum_consts entries, + typedef_tab = typedef_tab, func_ret_types = func_ret_types, + func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, + break_ref = break_ref, continue_ref = continue_ref, + goto_refs = goto_refs, active_goto_labels = active_goto_labels } + + fun get_typedef_tab ({ typedef_tab, ... } : t) = typedef_tab + + fun register_func_return_type name cty ({ func_ret_types, ... } : t) = + func_ret_types := Symtab.update (name, cty) (! func_ret_types) + + fun lookup_func_return_type ({ func_ret_types, ... } : t) name = + Symtab.lookup (! func_ret_types) name + + fun register_func_param_types name ctys ({ func_param_types, ... } : t) = + func_param_types := Symtab.update (name, ctys) (! func_param_types) + + fun lookup_func_param_types ({ func_param_types, ... } : t) name = + Symtab.lookup (! func_param_types) name + + fun get_break_ref ({ break_ref, ... } : t) = break_ref + fun get_continue_ref ({ continue_ref, ... } : t) = continue_ref + + fun set_break_ref ref_term ({ ctxt, vars, struct_types, struct_fields, + global_consts, array_decls, enum_consts, typedef_tab, func_ret_types, + func_param_types, ref_addr_ty, ref_gv_ty, break_ref = _, continue_ref, + goto_refs, active_goto_labels } : t) : t = + { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, + struct_fields = struct_fields, array_decls = array_decls, + enum_consts = enum_consts, + typedef_tab = typedef_tab, func_ret_types = func_ret_types, + func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, + break_ref = SOME ref_term, + continue_ref = continue_ref, goto_refs = goto_refs, + active_goto_labels = active_goto_labels } + + fun set_continue_ref ref_term ({ ctxt, vars, struct_types, struct_fields, + global_consts, array_decls, enum_consts, typedef_tab, func_ret_types, + func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref = _, + goto_refs, active_goto_labels } : t) : t = + { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, + struct_fields = struct_fields, array_decls = array_decls, + enum_consts = enum_consts, + typedef_tab = typedef_tab, func_ret_types = func_ret_types, + func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, + break_ref = break_ref, + continue_ref = SOME ref_term, goto_refs = goto_refs, + active_goto_labels = active_goto_labels } + + fun clear_break_ref ({ ctxt, vars, struct_types, struct_fields, + global_consts, array_decls, enum_consts, typedef_tab, func_ret_types, + func_param_types, ref_addr_ty, ref_gv_ty, break_ref = _, continue_ref, goto_refs, + active_goto_labels } : t) : t = + { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, + struct_fields = struct_fields, array_decls = array_decls, + enum_consts = enum_consts, + typedef_tab = typedef_tab, func_ret_types = func_ret_types, + func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, + break_ref = NONE, continue_ref = continue_ref, + goto_refs = goto_refs, active_goto_labels = active_goto_labels } + + fun get_goto_refs ({ goto_refs, ... } : t) = goto_refs + + fun set_goto_refs refs ({ ctxt, vars, struct_types, struct_fields, + global_consts, array_decls, enum_consts, typedef_tab, func_ret_types, + func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, goto_refs = _, + active_goto_labels } : t) : t = + { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, + struct_fields = struct_fields, array_decls = array_decls, + enum_consts = enum_consts, + typedef_tab = typedef_tab, func_ret_types = func_ret_types, + func_param_types = func_param_types, ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, + break_ref = break_ref, + continue_ref = continue_ref, goto_refs = refs, + active_goto_labels = active_goto_labels } + + fun lookup_goto_ref ({ goto_refs, ... } : t) name = + case List.find (fn (n, _) => n = name) goto_refs of + SOME (_, ref_term) => SOME ref_term + | NONE => NONE + + fun get_active_goto_labels ({ active_goto_labels, ... } : t) = + active_goto_labels + + fun set_active_goto_labels labels ({ ctxt, vars, struct_types, struct_fields, + global_consts, array_decls, enum_consts, typedef_tab, func_ret_types, + func_param_types, ref_addr_ty, ref_gv_ty, break_ref, continue_ref, goto_refs, + active_goto_labels = _ } : t) : t = + { ctxt = ctxt, vars = vars, global_consts = global_consts, struct_types = struct_types, + struct_fields = struct_fields, array_decls = array_decls, + enum_consts = enum_consts, typedef_tab = typedef_tab, + func_ret_types = func_ret_types, func_param_types = func_param_types, + ref_addr_ty = ref_addr_ty, ref_gv_ty = ref_gv_ty, + break_ref = break_ref, continue_ref = continue_ref, + goto_refs = goto_refs, active_goto_labels = distinct (op =) labels } +end +\ + +subsection \Array Indexing Helper\ + +text \ + The @{text unat} function from the Word library is an abbreviation, not a logical + constant, so it cannot be referenced via @{text "\<^const_name>"} in ML. + We define a proper constant that wraps it. +\ + +definition c_idx_to_nat :: \'a::len word \ nat\ where + [simp]: \c_idx_to_nat w = unat w\ + +subsection \Stub Constants for Unsupported C Constructs\ + +text \ + Opaque constants for C constructs that cannot be translated. + They have no WP rules, so symbolic execution silently gets stuck + when encountering these. The translation succeeds, and the user + can see from the constant names which constructs need attention. +\ + +consts c_while_stub :: "('s, 'v, 'r, 'abort, 'i, 'o) expression" +consts c_goto_stub :: "('s, 'v, 'r, 'abort, 'i, 'o) expression" +consts c_unsupported :: "('s, 'v, 'r, 'abort, 'i, 'o) expression" +consts c_uninitialized :: "'a" + +definition c_bounds_abort :: "('s, 'v, 'r, 'abort, 'i, 'o) expression" where [simp]: + "c_bounds_abort \ abort undefined" + +subsection \Term Construction\ + +text \ + Functions for building well-formed core monad terms. Each function + constructs a term using the actual constants from @{theory "Shallow_Micro_Rust.Core_Expression"}. +\ + +ML \ +structure C_Term_Build : sig + val mk_literal_unit : term + val mk_literal : term -> term + val mk_function_body : term -> term + val mk_sequence : term -> term -> term + val mk_literal_num : C_Ast_Utils.c_numeric_type -> int -> term + val mk_literal_int : int -> term + val mk_return_func : term -> term + val mk_bind : term -> term -> term + val mk_var_alloc : term -> term + val mk_var_alloc_typed : typ -> term -> term + val mk_var_read : term -> term + val mk_var_write : term -> term -> term + val mk_bindlift2 : term -> term -> term -> term + val mk_bind2 : term -> term -> term -> term + val mk_bind2_unseq : term -> term -> term -> term + val mk_two_armed_cond : term -> term -> term -> term + val mk_one_armed_cond : term -> term -> term + val mk_funcall : term -> term list -> term + val mk_raw_for_loop : term -> term -> term + val mk_upt_int_range : term -> term -> term + val mk_deref : term -> term + val mk_ptr_write : term -> term -> term + val mk_struct_field_read : term -> term -> term + val mk_struct_field_write : term -> term -> term -> term + val mk_unat : term -> term + val mk_focus_nth : term -> term -> term + val mk_focus_field : term -> term -> term + val mk_bounded_while : term -> term -> term -> term + val mk_goto_stub : term + val mk_unsupported_stub : term +end = +struct + (* literal v *) + fun mk_literal v = + Const (\<^const_name>\literal\, dummyT --> dummyT) $ v + + (* literal () : the "skip" operation *) + val mk_literal_unit = + Const (\<^const_name>\literal\, \<^typ>\unit\ --> dummyT) $ HOLogic.unit + + (* FunctionBody e *) + fun mk_function_body body = + Const (\<^const_name>\FunctionBody\, dummyT --> dummyT) $ body + + (* sequence e1 e2 *) + fun mk_sequence e1 e2 = + Const (\<^const_name>\sequence\, dummyT --> dummyT --> dummyT) $ e1 $ e2 + + (* literal n, typed according to the given c_numeric_type *) + fun mk_literal_num cty n = + let val ty = C_Ast_Utils.hol_type_of cty + in Const (\<^const_name>\literal\, ty --> dummyT) $ HOLogic.mk_number ty n end + + (* literal n, where n is a C integer constant. + Uses dummyT so Isabelle infers the correct word type from context + (e.g. 32 sword in signed expressions, 32 word in unsigned). *) + fun mk_literal_int n = + Const (\<^const_name>\literal\, dummyT --> dummyT) $ HOLogic.mk_number dummyT n + + (* return_func e : for C return statements *) + fun mk_return_func body = + Const (\<^const_name>\return_func\, dummyT --> dummyT) $ body + + (* bind e f : monadic bind *) + fun mk_bind e f = + Const (\<^const_name>\bind\, dummyT --> dummyT --> dummyT) $ e $ f + + (* Allocate a new mutable variable: funcall1 store_reference_const init_expr *) + fun mk_var_alloc init_expr = + Const (\<^const_name>\funcall1\, dummyT --> dummyT --> dummyT) + $ Const (\<^const_name>\store_reference_const\, dummyT) + $ init_expr + + (* Type-annotated variant: constrains the value type of store_reference_const + so adhoc overloading can resolve when multiple word-type prisms exist. *) + fun mk_var_alloc_typed val_hol_type init_expr = + if val_hol_type = dummyT then mk_var_alloc init_expr + else + Const (\<^const_name>\funcall1\, dummyT --> dummyT --> dummyT) + $ Const (\<^const_name>\store_reference_const\, val_hol_type --> dummyT) + $ init_expr + + (* Read a mutable variable: bind (literal ref) (deep_compose1 call store_dereference_const) *) + fun mk_var_read ref_var = + Const (\<^const_name>\bind\, dummyT --> dummyT --> dummyT) + $ mk_literal ref_var + $ (Const (\<^const_name>\deep_compose1\, dummyT --> dummyT --> dummyT) + $ Const (\<^const_name>\call\, dummyT --> dummyT) + $ Const (\<^const_name>\store_dereference_const\, dummyT)) + + (* Write a mutable variable: bind2 (deep_compose2 call store_update_const) (literal ref) val_expr *) + fun mk_var_write ref_var val_expr = + Const (\<^const_name>\bind2\, dummyT --> dummyT --> dummyT --> dummyT) + $ (Const (\<^const_name>\deep_compose2\, dummyT --> dummyT --> dummyT) + $ Const (\<^const_name>\call\, dummyT --> dummyT) + $ Const (\<^const_name>\store_update_const\, dummyT)) + $ mk_literal ref_var + $ val_expr + fun mk_bindlift2 f e1 e2 = + Const (\<^const_name>\bindlift2\, dummyT --> dummyT --> dummyT --> dummyT) + $ f $ e1 $ e2 + + (* bind2 f e1 e2 : evaluate e1 and e2, then apply monadic f *) + fun mk_bind2 f e1 e2 = + Const (\<^const_name>\bind2\, dummyT --> dummyT --> dummyT --> dummyT) + $ f $ e1 $ e2 + + (* bind2_unseq f e1 e2 : evaluate e1/e2 in unspecified order, then apply monadic f *) + fun mk_bind2_unseq f e1 e2 = + Const (\<^const_name>\bind2_unseq\, dummyT --> dummyT --> dummyT --> dummyT) + $ f $ e1 $ e2 + + (* two_armed_conditional test then_br else_br *) + fun mk_two_armed_cond test then_br else_br = + Const (\<^const_name>\two_armed_conditional\, dummyT --> dummyT --> dummyT --> dummyT) + $ test $ then_br $ else_br + + (* one_armed_conditional test then_br *) + fun mk_one_armed_cond test then_br = + Const (\<^const_name>\two_armed_conditional\, dummyT --> dummyT --> dummyT --> dummyT) + $ test $ then_br $ mk_literal_unit + + (* funcallN f arg0 ... argN : call a function with N arguments *) + local + val funcall_names = Vector.fromList [ + \<^const_name>\funcall0\, \<^const_name>\funcall1\, \<^const_name>\funcall2\, + \<^const_name>\funcall3\, \<^const_name>\funcall4\, \<^const_name>\funcall5\, + \<^const_name>\funcall6\, \<^const_name>\funcall7\, \<^const_name>\funcall8\, + \<^const_name>\funcall9\, \<^const_name>\funcall10\, + \<^const_name>\funcall11\, \<^const_name>\funcall12\, \<^const_name>\funcall13\, + \<^const_name>\funcall14\, \<^const_name>\funcall15\, \<^const_name>\funcall16\ + ] + in + fun mk_funcall f args = + let val n = length args + in if n > 16 then error "mk_funcall: more than 16 arguments not supported" + else let val cname = Vector.sub (funcall_names, n) + val ty = Library.foldr (fn (_, t) => dummyT --> t) (args, dummyT) + in Library.foldl (op $) (Const (cname, dummyT --> ty), f :: args) end + end + end + + (* raw_for_loop range_list body_fn *) + fun mk_raw_for_loop range body = + Const (\<^const_name>\raw_for_loop\, dummyT --> dummyT --> dummyT) $ range $ body + + (* Build [start..\List.map\, dummyT --> dummyT --> dummyT) + $ Const (\<^const_name>\of_nat\, dummyT) + $ (Const (\<^const_name>\upt\, dummyT --> dummyT --> dummyT) $ start_nat $ bound_nat) + + (* Dereference a pointer expression: bind ptr_expr (deep_compose1 call store_dereference_const) + This generalizes mk_var_read from literal variables to arbitrary expressions. *) + fun mk_deref ptr_expr = + Const (\<^const_name>\bind\, dummyT --> dummyT --> dummyT) + $ ptr_expr + $ (Const (\<^const_name>\deep_compose1\, dummyT --> dummyT --> dummyT) + $ Const (\<^const_name>\call\, dummyT --> dummyT) + $ Const (\<^const_name>\store_dereference_const\, dummyT)) + + (* Write through a pointer expression: bind2 (deep_compose2 call store_update_const) ptr_expr val_expr + This generalizes mk_var_write from literal variables to arbitrary expressions. *) + fun mk_ptr_write ptr_expr val_expr = + Const (\<^const_name>\bind2\, dummyT --> dummyT --> dummyT --> dummyT) + $ (Const (\<^const_name>\deep_compose2\, dummyT --> dummyT --> dummyT) + $ Const (\<^const_name>\call\, dummyT --> dummyT) + $ Const (\<^const_name>\store_update_const\, dummyT)) + $ ptr_expr + $ val_expr + + (* Struct field read: dereference pointer, then extract field via accessor. + Generates: bind (deref ptr_expr) (\v. literal (accessor v)) *) + fun mk_struct_field_read accessor_const ptr_expr = + let val v = Free ("v__struct", dummyT) + in mk_bind (mk_deref ptr_expr) + (Term.lambda v (mk_literal (accessor_const $ v))) + end + + (* Struct field write: evaluate rhs, dereference pointer, update field, write back. + Generates: bind val_expr (\rhs. bind (deref ptr) (\v. ptr_write ptr (updater (\_. rhs) v))) *) + fun mk_struct_field_write updater_const ptr_expr val_expr = + let val rhs_var = Free ("v__rhs", dummyT) + val struct_var = Free ("v__struct", dummyT) + val dummy_var = Free ("_uu__", dummyT) + val updated = updater_const $ (Term.lambda dummy_var rhs_var) $ struct_var + in mk_bind val_expr (Term.lambda rhs_var + (mk_bind (mk_deref ptr_expr) (Term.lambda struct_var + (mk_ptr_write ptr_expr (mk_literal updated))))) + end + + (* c_idx_to_nat idx : convert word to nat for array indexing (wraps unat) *) + fun mk_unat idx_term = + Const (\<^const_name>\c_idx_to_nat\, dummyT --> dummyT) $ idx_term + + (* focus_focused (nth_focus idx_nat) ref_term : focus reference to nth element *) + fun mk_focus_nth idx_nat ref_term = + Const (\<^const_name>\focus_focused\, dummyT --> dummyT --> dummyT) + $ (Const (\<^const_name>\nth_focus\, dummyT --> dummyT) $ idx_nat) + $ ref_term + + fun mk_focus_field focus_const ref_term = + Const (\<^const_name>\focus_focused\, dummyT --> dummyT --> dummyT) + $ focus_const + $ ref_term + + (* bounded_while fuel cond body *) + fun mk_bounded_while fuel cond body = + Const (\<^const_name>\bounded_while\, dummyT --> dummyT --> dummyT --> dummyT) + $ fuel $ cond $ body + + (* Stub constants for unsupported C constructs *) + val mk_goto_stub = Const (\<^const_name>\c_goto_stub\, dummyT) + val mk_unsupported_stub = Const (\<^const_name>\c_unsupported\, dummyT) +end +\ + +subsection \Statement and Expression Translation\ + +text \ + The core translation: C AST nodes are mapped to core monad expressions. + Unsupported constructs produce explicit errors identifying the construct + that could not be translated. +\ + +ML \ +structure C_Translate : sig + type pointer_model = {ptr_add: string option, ptr_shift_signed: string option, ptr_diff: string option} + val translate_stmt : C_Trans_Ctxt.t -> C_Ast.nodeInfo C_Ast.cStatement -> term + val set_decl_prefix : string -> unit + val set_union_names : string list -> unit + val current_union_names : string list Unsynchronized.ref + val set_ref_universe_types : typ -> typ -> unit + val set_ref_abort_type : typ option -> unit + val set_pointer_model : pointer_model -> unit + val strip_isa_fun_type : typ -> typ list + val defined_func_consts : term Symtab.table Unsynchronized.ref + val defined_func_fuels : int Symtab.table Unsynchronized.ref + val current_list_backed_param_modes : bool list Symtab.table Unsynchronized.ref + val current_struct_array_fields : string list Symtab.table Unsynchronized.ref + val translate_fundef : (string * C_Ast_Utils.c_numeric_type) list Symtab.table + -> int Symtab.table + -> C_Ast_Utils.c_numeric_type Symtab.table + -> C_Ast_Utils.c_numeric_type Symtab.table Unsynchronized.ref + -> C_Ast_Utils.c_numeric_type list Symtab.table Unsynchronized.ref + -> (string * term * C_Ast_Utils.c_numeric_type * + (C_Ast_Utils.c_numeric_type * int) option * string option) list + -> Proof.context + -> C_Ast.nodeInfo C_Ast.cFunctionDef -> string * term +end = +struct + type pointer_model = {ptr_add: string option, ptr_shift_signed: string option, ptr_diff: string option} + + (* Save Isabelle term constructors before C_Ast shadows them *) + val Isa_Const = Const + val Isa_Free = Free + val isa_dummyT = dummyT + val Isa_add_frees = Term.add_frees + val Isa_Type = Type + + (* Table mapping fixed-variable names to qualified const names. + Populated by C_Def_Gen.define_c_function using target_morphism + (the standard Isabelle mechanism from specification.ML:269). *) + val defined_func_consts : term Symtab.table Unsynchronized.ref = + Unsynchronized.ref Symtab.empty + + (* Table mapping function names to their fuel parameter count. + Populated by translate_fundef after abstracting while_fuel variables. *) + val defined_func_fuels : int Symtab.table Unsynchronized.ref = + Unsynchronized.ref Symtab.empty + + (* Per-translation-unit hint for parameters that should be translated as + list-backed pointer aliases rather than raw pointers. *) + val current_list_backed_param_modes : bool list Symtab.table Unsynchronized.ref = + Unsynchronized.ref Symtab.empty + + val current_struct_array_fields : string list Symtab.table Unsynchronized.ref = + Unsynchronized.ref Symtab.empty + + (* Generate a fresh variable name not occurring free in the given terms *) + fun fresh_var terms stem typ = + let val used = List.foldl (fn (t, acc) => Isa_add_frees t acc) [] terms + |> List.map fst + val (name, _) = Name.variant stem (Name.make_context used) + in Isa_Free (name, typ) end + + fun expr_value_type tm = + (case fastype_of tm of + Type (_, _ :: vty :: _) => vty + | _ => isa_dummyT) + + (* Translation-time ambient context shared across expression/function + translation. These must be declared before pointer-cast helpers that use + the reference universe and expression side-type information. *) + val current_ret_cty : C_Ast_Utils.c_numeric_type option Unsynchronized.ref = + Unsynchronized.ref NONE + val current_decl_prefix : string Unsynchronized.ref = + Unsynchronized.ref "c_" + val current_union_names : string list Unsynchronized.ref = + Unsynchronized.ref [] + val current_loop_written_vars : string list Unsynchronized.ref = + Unsynchronized.ref [] + val current_ref_addr_ty : typ Unsynchronized.ref = + Unsynchronized.ref (TFree ("'addr", [])) + val current_ref_gv_ty : typ Unsynchronized.ref = + Unsynchronized.ref (TFree ("'gv", [])) + val current_ref_expr_constraint : typ option Unsynchronized.ref = + Unsynchronized.ref NONE + val current_pointer_model : pointer_model Unsynchronized.ref = + Unsynchronized.ref {ptr_add = SOME "c_ptr_add", ptr_shift_signed = SOME "c_ptr_shift_signed", ptr_diff = SOME "c_ptr_diff"} + val current_visible_ctxt : Proof.context option Unsynchronized.ref = + Unsynchronized.ref NONE + + (* Forward reference for statement-expression translation. + Initialized after translate_compound_items_expr is defined. *) + val stmt_expr_translate_ref : + (C_Trans_Ctxt.t -> C_Ast.nodeInfo C_Ast.cCompoundBlockItem list + -> term * C_Ast_Utils.c_numeric_type) Unsynchronized.ref = + Unsynchronized.ref (fn _ => fn _ => + error "micro_c_translate: statement expression forward ref not initialized") + + fun uses_raw_pointer_model () = true + + fun require_current_visible_ctxt () = + (case !current_visible_ctxt of + SOME ctxt => ctxt + | NONE => error "micro_c_translate: missing translation proof context") + + fun resolve_required_current_visible_const short_name = + let val ctxt = require_current_visible_ctxt () + in + case try (Syntax.check_term ctxt) (Free (short_name, dummyT)) of + SOME tm => tm + | NONE => error ("micro_c_translate: missing required visible constant: " ^ short_name) + end + + fun constrain_expr_side_types tm = + (case !current_ref_expr_constraint of + SOME (Type (ename, [state_ty, _, resid_ty, abort_ty, in_ty, out_ty])) => + let + val value_ty = expr_value_type tm + val target_ty = Type (ename, [state_ty, value_ty, resid_ty, abort_ty, in_ty, out_ty]) + in Type.constraint target_ty tm end + | _ => tm) + + fun constrain_expr_value_type value_ty tm = + (case !current_ref_expr_constraint of + SOME (Type (ename, [state_ty, _, resid_ty, abort_ty, in_ty, out_ty])) => + let val target_ty = Type (ename, [state_ty, value_ty, resid_ty, abort_ty, in_ty, out_ty]) + in Type.constraint target_ty tm end + | _ => tm) + + fun constrain_known_expr_value_type value_ty tm = + (case fastype_of tm of + Type (ename, [state_ty, _, resid_ty, abort_ty, in_ty, out_ty]) => + let val target_ty = Type (ename, [state_ty, value_ty, resid_ty, abort_ty, in_ty, out_ty]) + in Type.constraint target_ty tm end + | _ => constrain_expr_value_type value_ty tm) + + fun expr_value_ty_of_cty cty = + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) cty of + SOME ty => ty + | NONE => C_Ast_Utils.hol_type_of cty) + + fun constrain_expr_cty cty tm = + let val value_ty = expr_value_ty_of_cty cty + in + if value_ty = isa_dummyT then constrain_expr_side_types tm + else constrain_expr_side_types (constrain_expr_value_type value_ty tm) + end + + fun expr_type_with_value value_ty = + (case !current_ref_expr_constraint of + SOME (Type (ename, [state_ty, _, resid_ty, abort_ty, in_ty, out_ty])) => + SOME (Type (ename, [state_ty, value_ty, resid_ty, abort_ty, in_ty, out_ty])) + | _ => NONE) + + fun function_body_type_with_value value_ty = + (case !current_ref_expr_constraint of + SOME (Type (_, [state_ty, _, _, abort_ty, in_ty, out_ty])) => + SOME (Type (\<^type_name>\function_body\, [state_ty, value_ty, abort_ty, in_ty, out_ty])) + | _ => NONE) + + fun expr_type_from_tm value_ty tm = + (case fastype_of tm of + Type (ename, [state_ty, _, resid_ty, abort_ty, in_ty, out_ty]) => + SOME (Type (ename, [state_ty, value_ty, resid_ty, abort_ty, in_ty, out_ty])) + | _ => expr_type_with_value value_ty) + + fun function_body_type_from_tm value_ty tm = + (case fastype_of tm of + Type (_, [state_ty, _, _, abort_ty, in_ty, out_ty]) => + SOME (Type (\<^type_name>\function_body\, [state_ty, value_ty, abort_ty, in_ty, out_ty])) + | _ => function_body_type_with_value value_ty) + + fun constrain_function_body_arrow_from_tm arg_ty value_ty side_tm tm = + (case function_body_type_from_tm value_ty side_tm of + SOME body_ty => Type.constraint (arg_ty --> body_ty) tm + | NONE => tm) + + fun local_ref_value_ty value_ty = + Isa_Type (\<^type_name>\focused\, + [Isa_Type (\<^type_name>\gref\, [!current_ref_addr_ty, !current_ref_gv_ty]), + !current_ref_gv_ty, value_ty]) + + fun mk_typed_funcall1_from_tm arg_tm res_value_ty fn_tm = + (case fastype_of arg_tm of + Type (ename, [state_ty, _, resid_ty, abort_ty, in_ty, out_ty]) => + let + val arg_ty = expr_value_type arg_tm + val body_ty = Type (\<^type_name>\function_body\, [state_ty, res_value_ty, abort_ty, in_ty, out_ty]) + val res_expr_ty = Type (ename, [state_ty, res_value_ty, resid_ty, abort_ty, in_ty, out_ty]) + val funcall1_ty = Isa_Type (\<^type_name>\fun\, + [Isa_Type (\<^type_name>\fun\, [arg_ty, body_ty]), + Isa_Type (\<^type_name>\fun\, [fastype_of arg_tm, res_expr_ty])]) + in + Isa_Const (\<^const_name>\funcall1\, funcall1_ty) + $ Type.constraint (arg_ty --> body_ty) fn_tm + $ arg_tm + end + | _ => C_Term_Build.mk_funcall fn_tm [arg_tm]) + + fun mk_typed_call_deep1_from_tm arg_tm res_value_ty fn_tm = + (case fastype_of arg_tm of + Type (ename, [state_ty, _, resid_ty, abort_ty, in_ty, out_ty]) => + let + val arg_ty = expr_value_type arg_tm + val body_ty = Type (\<^type_name>\function_body\, [state_ty, res_value_ty, abort_ty, in_ty, out_ty]) + val res_expr_ty = Type (ename, [state_ty, res_value_ty, resid_ty, abort_ty, in_ty, out_ty]) + val call_ty = Isa_Type (\<^type_name>\fun\, [body_ty, res_expr_ty]) + val deep_compose1_ty = Isa_Type (\<^type_name>\fun\, + [call_ty, + Isa_Type (\<^type_name>\fun\, + [Isa_Type (\<^type_name>\fun\, [arg_ty, body_ty]), + Isa_Type (\<^type_name>\fun\, [arg_ty, res_expr_ty])])]) + in + Isa_Const (\<^const_name>\deep_compose1\, deep_compose1_ty) + $ Isa_Const (\<^const_name>\call\, call_ty) + $ Type.constraint (arg_ty --> body_ty) fn_tm + end + | _ => + Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) + $ fn_tm) + + fun cty_of_hol_type T = + if T = @{typ bool} then SOME C_Ast_Utils.CBool + else if T = \<^typ>\c_int\ then SOME C_Ast_Utils.CInt + else if T = \<^typ>\c_uint\ then SOME C_Ast_Utils.CUInt + else if T = \<^typ>\c_char\ then SOME C_Ast_Utils.CChar + else if T = \<^typ>\c_schar\ then SOME C_Ast_Utils.CSChar + else if T = \<^typ>\c_short\ then SOME C_Ast_Utils.CShort + else if T = \<^typ>\c_ushort\ then SOME C_Ast_Utils.CUShort + else if T = \<^typ>\c_long\ then SOME C_Ast_Utils.CLong + else if T = \<^typ>\c_ulong\ then SOME C_Ast_Utils.CULong + else NONE + + (* Binary operator classification: arithmetic/comparison/bitwise operators are + monadic and compose via bind2. + NB: Must be defined before 'open C_Ast' which shadows the term type. *) + datatype binop_kind = Monadic of term + + (* void* cast helper: generate c_cast_from_void with type-annotated prism. + The prism constant c_void_cast_prism_for is adhoc-overloaded; the type annotation + on the prism (constraining 'v to the target type) lets Isabelle resolve it. + Must be defined before 'open C_Ast' to use Const/Free/dummyT/Type. *) + fun mk_cast_from_void target_cty void_ptr_term = + let val target_ty = C_Ast_Utils.hol_type_of target_cty + val prism_ty = Type (\<^type_name>\prism\, [!current_ref_gv_ty, target_ty]) + val prism_const = Const (\<^const_name>\c_void_cast_prism_for\, prism_ty) + val cast_const = Const (\<^const_name>\c_cast_from_void\, dummyT) + val v = Free ("v__void_cast", dummyT) + val cast_expr = + C_Term_Build.mk_bind void_ptr_term + (Term.lambda v (C_Term_Build.mk_literal (cast_const $ prism_const $ v))) + val cast_value_ty = + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) (C_Ast_Utils.CPtr target_cty) of + SOME ty => ty + | NONE => Type (\<^type_name>\focused\, [dummyT, dummyT, target_ty])) + in constrain_expr_side_types (constrain_expr_value_type cast_value_ty cast_expr) + end + + fun mk_cast_from_void_in _ target_cty void_ptr_term = + mk_cast_from_void target_cty void_ptr_term + + fun typed_ref_ty_of_cty cty = + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) (C_Ast_Utils.CPtr cty) of + SOME ty => ty + | NONE => isa_dummyT) + + (* Untyped void* cast helper: keep prism target type fully polymorphic so + later context (e.g. indexing vs scalar dereference) can resolve it. + Used for T*\U* reinterprets where the intermediate void* step + should not fix the target prism. *) + fun mk_cast_from_void_untyped void_ptr_term = + let val cast_const = Const (\<^const_name>\c_cast_from_void\, dummyT) + val prism_const = Const (\<^const_name>\c_void_cast_prism_for\, dummyT) + val v = Free ("v__void_cast", dummyT) + in constrain_expr_side_types + (C_Term_Build.mk_bind void_ptr_term + (Term.lambda v (C_Term_Build.mk_literal (cast_const $ prism_const $ v)))) end + + fun scalar_pointer_value_hol_ty (C_Ast_Utils.CPtr inner) = + let + val inner_ty = + (case inner of + C_Ast_Utils.CBool => SOME @{typ bool} + | C_Ast_Utils.CInt => SOME \<^typ>\c_int\ + | C_Ast_Utils.CUInt => SOME \<^typ>\c_uint\ + | C_Ast_Utils.CShort => SOME \<^typ>\c_short\ + | C_Ast_Utils.CUShort => SOME \<^typ>\c_ushort\ + | C_Ast_Utils.CLong => SOME (C_Ast_Utils.hol_type_of C_Ast_Utils.CLong) + | C_Ast_Utils.CULong => SOME (C_Ast_Utils.hol_type_of C_Ast_Utils.CULong) + | C_Ast_Utils.CLongLong => SOME \<^typ>\c_long\ + | C_Ast_Utils.CULongLong => SOME \<^typ>\c_ulong\ + | C_Ast_Utils.CInt128 => SOME \<^typ>\c_int128\ + | C_Ast_Utils.CUInt128 => SOME \<^typ>\c_uint128\ + | _ => NONE) + val gref_ty = + Isa_Type (\<^type_name>\gref\, [!current_ref_addr_ty, !current_ref_gv_ty]) + in + Option.map + (fn ty => Isa_Type (\<^type_name>\focused\, [gref_ty, !current_ref_gv_ty, ty])) + inner_ty + end + | scalar_pointer_value_hol_ty _ = NONE + + fun pointer_expr_value_hol_ty cty = + let + val gref_ty = + Isa_Type (\<^type_name>\gref\, [!current_ref_addr_ty, !current_ref_gv_ty]) + fun mk_focused ty = + Isa_Type (\<^type_name>\focused\, [gref_ty, !current_ref_gv_ty, ty]) + in + case cty of + C_Ast_Utils.CPtr C_Ast_Utils.CVoid => SOME gref_ty + | C_Ast_Utils.CPtr (C_Ast_Utils.CUnion _) => SOME gref_ty + | C_Ast_Utils.CPtr C_Ast_Utils.CChar => + if uses_raw_pointer_model () then + SOME (mk_focused \<^typ>\c_char\) + else + SOME (mk_focused (HOLogic.listT \<^typ>\c_char\)) + | _ => + (case scalar_pointer_value_hol_ty cty of + SOME ty => SOME ty + | NONE => + (case cty of + C_Ast_Utils.CPtr inner => + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) inner of + SOME inner_ty => SOME (mk_focused inner_ty) + | NONE => SOME gref_ty) + | _ => NONE)) + end + + fun list_backed_pointer_value_hol_ty (C_Ast_Utils.CPtr inner) = + let + val gref_ty = + Isa_Type (\<^type_name>\gref\, [!current_ref_addr_ty, !current_ref_gv_ty]) + val elem_ty = + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) inner of + SOME ty => ty + | NONE => C_Ast_Utils.hol_type_of inner) + in + if elem_ty = isa_dummyT then NONE + else SOME (Isa_Type (\<^type_name>\focused\, [gref_ty, !current_ref_gv_ty, HOLogic.listT elem_ty])) + end + | list_backed_pointer_value_hol_ty _ = NONE + + (* C11 \
6.3.1 (integer conversions): implicit cast for promotions and + usual arithmetic conversions. + \
6.3.1.2: _Bool conversion (scalar != 0 -> true). + \
6.3.1.3p2: unsigned conversion (modular reduction). + \
6.3.1.3p3: signed narrowing (implementation-defined; we use c_scast + for truncating, c_scast_checked for conservative profile). + \
6.3.1.4: integer-to-bool and void-cast. + Cast direction: signed source -> c_scast (sign-extend), + unsigned -> c_ucast (zero-extend). + Must be defined before 'open C_Ast' to use Const/Free/dummyT. *) + fun mk_implicit_cast (tm, from_cty, to_cty) = + let + val tm_ty = expr_value_type tm + val to_ty = C_Ast_Utils.hol_type_of to_cty + in + if from_cty = to_cty then + if C_Ast_Utils.is_ptr from_cty then tm + else if tm_ty <> isa_dummyT andalso tm_ty = to_ty then tm + else + let + val v = Isa_Free ("v__idcast", to_ty) + in + C_Term_Build.mk_bind tm (Term.lambda v (C_Term_Build.mk_literal v)) + end + else if tm_ty <> isa_dummyT andalso tm_ty = to_ty then tm + else if C_Ast_Utils.is_bool to_cty then + (* scalar -> _Bool : compare against zero *) + if C_Ast_Utils.is_ptr from_cty then + let val vty = expr_value_type tm + in + if (case vty of Type (\<^type_name>\List.list\, [_]) => true | _ => false) + then + let val v = Isa_Free ("v__promo", vty) + val nil_term = Const (\<^const_name>\Nil\, vty) + val neq_nil = + Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) + $ (Isa_Const (\<^const_name>\HOL.eq\, vty --> vty --> @{typ bool}) $ v $ nil_term) + in C_Term_Build.mk_bind tm (Term.lambda v (C_Term_Build.mk_literal neq_nil)) end + else + let val v = Isa_Free ("v__promo", isa_dummyT) + val addr_term = + Isa_Const (\<^const_name>\address\, isa_dummyT --> isa_dummyT) $ v + val neq_zero = + Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) + $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT --> isa_dummyT --> @{typ bool}) + $ addr_term + $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) + in C_Term_Build.mk_bind tm (Term.lambda v (C_Term_Build.mk_literal neq_zero)) end + end + else + let val from_ty = if C_Ast_Utils.is_bool from_cty + then @{typ bool} + else C_Ast_Utils.hol_type_of from_cty + val v = Isa_Free ("v__promo", from_ty) + val truthy_expr = + if C_Ast_Utils.is_bool from_cty then + C_Term_Build.mk_literal v + else if C_Ast_Utils.is_signed from_cty then + Const (\<^const_name>\c_signed_truthy\, isa_dummyT) $ v + else + Const (\<^const_name>\c_unsigned_truthy\, isa_dummyT) $ v + in C_Term_Build.mk_bind tm (Term.lambda v truthy_expr) end + else if C_Ast_Utils.is_bool from_cty then + (* Bool \ integer: if b then 1 else 0 *) + let val v = Isa_Free ("v__promo", @{typ bool}) + val one = C_Term_Build.mk_literal_num to_cty 1 + val zero = C_Term_Build.mk_literal_num to_cty 0 + in C_Term_Build.mk_bind tm + (Term.lambda v (C_Term_Build.mk_two_armed_cond + (C_Term_Build.mk_literal v) one zero)) end + else if to_cty = C_Ast_Utils.CVoid then + (* (void)expr is a no-op: just evaluate and discard the result *) + tm + else if C_Ast_Utils.is_ptr from_cty andalso C_Ast_Utils.is_ptr to_cty then + let fun is_void_like C_Ast_Utils.CVoid = true + | is_void_like (C_Ast_Utils.CUnion _) = true + | is_void_like _ = false + in case (from_cty, to_cty) of + (C_Ast_Utils.CPtr from_inner, C_Ast_Utils.CPtr to_inner) => + if is_void_like from_inner andalso is_void_like to_inner then tm + (* untyped -> T* : attach prism focus *) + else if is_void_like from_inner then + (case to_inner of + C_Ast_Utils.CStruct _ => mk_cast_from_void to_inner tm + | C_Ast_Utils.CUnion _ => mk_cast_from_void to_inner tm + | _ => + let val target_ty = C_Ast_Utils.hol_type_of to_inner + val prism_ty = Type (\<^type_name>\prism\, [!current_ref_gv_ty, target_ty]) + val prism_const = Const (\<^const_name>\c_void_cast_prism_for\, prism_ty) + val cast_const = Const (\<^const_name>\c_cast_from_void\, + prism_ty --> dummyT --> dummyT) + val v = Free ("v__void_cast", dummyT) + val cast_term = constrain_expr_side_types + (C_Term_Build.mk_bind tm + (Term.lambda v (C_Term_Build.mk_literal (cast_const $ prism_const $ v)))) + val target_ptr_ty = + (case pointer_expr_value_hol_ty to_cty of + SOME ty => ty + | NONE => isa_dummyT) + in if target_ptr_ty = isa_dummyT then cast_term + else constrain_expr_value_type target_ptr_ty cast_term + end) + (* T* -> untyped : strip focus *) + else if is_void_like to_inner then + let val source_ptr_ty = + (case pointer_expr_value_hol_ty from_cty of + SOME ty => ty + | NONE => isa_dummyT) + val tm' = + if source_ptr_ty = isa_dummyT then tm + else constrain_expr_value_type source_ptr_ty tm + val from_ty = expr_value_type tm' + val v = Isa_Free ("v__cast", if from_ty = isa_dummyT then isa_dummyT else from_ty) + val cast = Const (\<^const_name>\c_cast_to_void\, dummyT) + val void_ptr_ty = + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) to_cty of + SOME ty => ty + | NONE => isa_dummyT) + val cast_term = + C_Term_Build.mk_bind tm' (Term.lambda v (C_Term_Build.mk_literal (cast $ v))) + in if void_ptr_ty = isa_dummyT then cast_term + else constrain_expr_value_type void_ptr_ty cast_term + end + (* T* -> U* reinterpret through void *) + else if from_inner = to_inner then tm + else + let val tm' = + (case scalar_pointer_value_hol_ty from_cty of + SOME ptr_ty => constrain_expr_value_type ptr_ty tm + | NONE => tm) + val v = Free ("v__cast", dummyT) + val cast = Const (\<^const_name>\c_cast_to_void\, dummyT) + val as_void = C_Term_Build.mk_bind tm' (Term.lambda v (C_Term_Build.mk_literal (cast $ v))) + in mk_cast_from_void_untyped as_void end + | _ => tm + end + else if C_Ast_Utils.is_ptr from_cty then + (* pointer -> integer cast via semantic uintptr value, then convert as needed *) + let val _ = require_current_visible_ctxt () + val tm = + (case pointer_expr_value_hol_ty from_cty of + SOME ty => constrain_expr_value_type ty tm + | NONE => tm) + val ptr_ty = expr_value_type tm + val v = Free ("v__ptrint", if ptr_ty = isa_dummyT then isa_dummyT else ptr_ty) + val raw_uint_v = Free ("v__uintptr", @{typ int}) + val ptr_uint_cty = C_Ast_Utils.pointer_uint_cty () + val ptr_uint_ty = C_Ast_Utils.hol_type_of ptr_uint_cty + val conv = resolve_required_current_visible_const "c_ptr_to_uintptr" + val raw_ptr_ty = + Isa_Type (\<^type_name>\gref\, [!current_ref_addr_ty, !current_ref_gv_ty]) + val raw_v = + (case fastype_of v of + Term.Type (name, _) => + if name = \<^type_name>\focused\ + then Isa_Const (\<^const_name>\unwrap_focused\, isa_dummyT --> raw_ptr_ty) $ v + else v + | _ => v) + val as_uintptr = + C_Term_Build.mk_bind tm + (Term.lambda v + (C_Term_Build.mk_bind + (C_Term_Build.mk_literal (conv $ raw_v)) + (Term.lambda raw_uint_v + (C_Term_Build.mk_literal + (Isa_Const (\<^const_name>\of_int\, @{typ int} --> ptr_uint_ty) $ raw_uint_v))))) + val as_uintptr = constrain_expr_value_type ptr_uint_ty as_uintptr + in if to_cty = ptr_uint_cty then as_uintptr + else mk_implicit_cast (as_uintptr, ptr_uint_cty, to_cty) + end + else if C_Ast_Utils.is_ptr to_cty then + (* integer -> pointer cast: widen/narrow to ABI uintptr, build a raw pointer, + then attach the target pointer view for non-void pointees. *) + let val ptr_uint_cty = C_Ast_Utils.pointer_uint_cty () + val ptr_uint_ty = C_Ast_Utils.hol_type_of ptr_uint_cty + val as_uintptr = if from_cty = ptr_uint_cty then tm + else mk_implicit_cast (tm, from_cty, ptr_uint_cty) + val v = Free ("v__intptr", ptr_uint_ty) + val conv = resolve_required_current_visible_const "c_uintptr_to_ptr" + val raw_ptr_term = + C_Term_Build.mk_bind as_uintptr + (Term.lambda v + (C_Term_Build.mk_literal + (conv $ + (Isa_Const (\<^const_name>\of_nat\, @{typ nat} --> @{typ int}) + $ (C_Term_Build.mk_unat v))))) + in + case to_cty of + C_Ast_Utils.CPtr to_inner => + let + fun is_void_like C_Ast_Utils.CVoid = true + | is_void_like (C_Ast_Utils.CUnion _) = true + | is_void_like _ = false + in + if is_void_like to_inner then + (case pointer_expr_value_hol_ty to_cty of + SOME ty => constrain_expr_value_type ty raw_ptr_term + | NONE => raw_ptr_term) + else + mk_cast_from_void to_inner raw_ptr_term + end + | _ => raw_ptr_term + end + else let val cast_const = + if C_Ast_Utils.is_signed from_cty + then (case #signed_narrowing (C_Compiler.get_compiler_profile ()) of + C_Compiler.Checked => + Const (\<^const_name>\c_scast_checked\, isa_dummyT) + | C_Compiler.Truncating => + Const (\<^const_name>\c_scast\, isa_dummyT)) + else Const (\<^const_name>\c_ucast\, isa_dummyT) + (* Type-annotate the lambda variable with the source HOL type + so c_scast/c_ucast input type is fully determined. *) + val from_ty = + let val explicit = C_Ast_Utils.hol_type_of from_cty + in if tm_ty <> isa_dummyT then tm_ty else explicit end + val to_ty = C_Ast_Utils.hol_type_of to_cty + val v = Isa_Free ("v__promo", from_ty) + in constrain_expr_side_types + (constrain_expr_value_type to_ty + (C_Term_Build.mk_bind tm (Term.lambda v (cast_const $ v)))) end + end + + fun strip_isa_fun_type (Type ("fun", [A, B])) = A :: strip_isa_fun_type B + | strip_isa_fun_type _ = [] + + fun set_decl_prefix pfx = (current_decl_prefix := pfx) + fun set_union_names names = current_union_names := names + fun set_ref_universe_types addr_ty gv_ty = + (current_ref_addr_ty := addr_ty; current_ref_gv_ty := gv_ty) + fun set_ref_abort_type abort_opt = (current_ref_expr_constraint := abort_opt) + fun set_pointer_model model = (current_pointer_model := model) + + + (* Error conventions: + - error "micro_c_translate: ..." = internal translation error or + valid-but-impossible state (should not happen with well-formed C) + - unsupported "..." = valid C construct that we intentionally + do not translate (missing feature) *) + + open C_Ast + + fun unsupported construct = + error ("micro_c_translate: unsupported C construct: " ^ construct) + + fun normalize_ref_universe_type tctx ty = + let + val addr_ty = C_Trans_Ctxt.get_ref_addr_ty tctx + val gv_ty = C_Trans_Ctxt.get_ref_gv_ty tctx + fun go (Term.Type (name, args)) = + let + val args' = List.map go args + in + (case args' of + [Term.Type (gname, [_ , _]), _, vty] => + if Long_Name.base_name name = "focused" + andalso Long_Name.base_name gname = "gref" + then Isa_Type (name, [Isa_Type (gname, [addr_ty, gv_ty]), gv_ty, vty]) + else Isa_Type (name, args') + | _ => Isa_Type (name, args')) + end + | go t = t + in go ty end + + fun mk_typed_ref_var tctx name alloc_expr = + Isa_Free (name, normalize_ref_universe_type tctx (expr_value_type alloc_expr)) + + fun resolve_visible_const_term ctxt short_name = + let + fun const_or_free x = + (case Symtab.lookup (!defined_func_consts) x of + SOME tm => SOME tm + | NONE => + let + val c_opt = Variable.lookup_const ctxt x + in + case c_opt of + SOME c => + ((let val _ = Consts.type_scheme (Proof_Context.consts_of ctxt) c + in SOME (Isa_Const (c, isa_dummyT)) end) + handle TYPE _ => SOME (Isa_Free (x, isa_dummyT))) + | NONE => SOME (Isa_Free (x, isa_dummyT)) + end) + val fixed_result = + (case Variable.lookup_fixed ctxt short_name of + SOME x => const_or_free x + | NONE => NONE) + val direct = + SOME (Proof_Context.read_const {proper = true, strict = false} ctxt short_name) + handle ERROR _ => NONE + val result = + case fixed_result of + SOME t => SOME t + | NONE => + (case direct of + SOME (Term.Const (n, _)) => SOME (Isa_Const (n, isa_dummyT)) + | SOME (Term.Free (x, _)) => const_or_free x + | _ => + let + val full_name = Proof_Context.intern_const ctxt short_name + val thy = Proof_Context.theory_of ctxt + in + if can (Sign.the_const_type thy) full_name + then SOME (Isa_Const (full_name, isa_dummyT)) + else NONE + end) + in result end + + fun mk_flag_ref_type tctx = + let + val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 + val alloc_expr = + C_Term_Build.mk_var_alloc_typed + (C_Ast_Utils.hol_type_of C_Ast_Utils.CUInt) false_lit + in + normalize_ref_universe_type tctx (expr_value_type alloc_expr) + end + + (* C11 \
6.5: binary operator dispatch table. + Maps each C binary operator to its (signed, unsigned) Isabelle constants. + \
6.5.5: multiplicative [*, /, %] \
6.5.6: additive [+, -] + \
6.5.7: shifts (<<, >>) \
6.5.8: relational (<, >, <=, >=) + \
6.5.9: equality (==, !=) \
6.5.10-12: bitwise (&, ^, |) + Arithmetic, comparison and bitwise operations use the overflow-checked + C operations from C_Numeric_Types which are monadic (they can abort). + Note: CGrOp0/CGeqOp0 reuse less/le with reversed operands (handled at call site). *) + val binop_table = [ + (CAddOp0, (\<^const_name>\c_signed_add\, \<^const_name>\c_unsigned_add\)), + (CSubOp0, (\<^const_name>\c_signed_sub\, \<^const_name>\c_unsigned_sub\)), + (CMulOp0, (\<^const_name>\c_signed_mul\, \<^const_name>\c_unsigned_mul\)), + (CDivOp0, (\<^const_name>\c_signed_div\, \<^const_name>\c_unsigned_div\)), + (CRmdOp0, (\<^const_name>\c_signed_mod\, \<^const_name>\c_unsigned_mod\)), + (CLeOp0, (\<^const_name>\c_signed_less\, \<^const_name>\c_unsigned_less\)), + (CLeqOp0, (\<^const_name>\c_signed_le\, \<^const_name>\c_unsigned_le\)), + (CGrOp0, (\<^const_name>\c_signed_less\, \<^const_name>\c_unsigned_less\)), (* reversed operands *) + (CGeqOp0, (\<^const_name>\c_signed_le\, \<^const_name>\c_unsigned_le\)), (* reversed operands *) + (CEqOp0, (\<^const_name>\c_signed_eq\, \<^const_name>\c_unsigned_eq\)), + (CNeqOp0, (\<^const_name>\c_signed_neq\, \<^const_name>\c_unsigned_neq\)), + (CAndOp0, (\<^const_name>\c_signed_and\, \<^const_name>\c_unsigned_and\)), + (CXorOp0, (\<^const_name>\c_signed_xor\, \<^const_name>\c_unsigned_xor\)), + (COrOp0, (\<^const_name>\c_signed_or\, \<^const_name>\c_unsigned_or\)), + (CShlOp0, (\<^const_name>\c_signed_shl\, \<^const_name>\c_unsigned_shl\)) + ] + fun translate_binop cty op0 = + let + fun lookup [] = NONE + | lookup ((op', pair) :: rest) = + if op' = op0 then SOME pair else lookup rest + in + case lookup binop_table of + SOME (s, u) => + Monadic (Isa_Const (if C_Ast_Utils.is_signed cty then s else u, isa_dummyT)) + | NONE => + (* C11 \
6.5.7p5: signed right shift is implementation-defined *) + if op0 = CShrOp0 then + if C_Ast_Utils.is_signed cty + then (case #signed_shr (C_Compiler.get_compiler_profile ()) of + C_Compiler.ArithmeticShift => + Monadic (Isa_Const (\<^const_name>\c_signed_shr\, isa_dummyT)) + | C_Compiler.ConservativeShift => + Monadic (Isa_Const (\<^const_name>\c_signed_shr_conservative\, isa_dummyT))) + else Monadic (Isa_Const (\<^const_name>\c_unsigned_shr\, isa_dummyT)) + else unsupported "unsupported binary operator" + end + + (* Check if a given aggregate name refers to a union (not a struct). *) + fun is_union_aggregate name = + List.exists (fn n => n = name) (!current_union_names) + + val struct_name_of_cty = C_Ast_Utils.struct_name_of_cty + + fun cty_of_decl_for_struct tctx (CDecl0 (specs, declrs, _)) = + let + val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx + val struct_names = C_Trans_Ctxt.get_struct_names tctx + val base_cty = + (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME ct => SOME ct + | NONE => + (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of + SOME sn => SOME (C_Ast_Utils.CStruct sn) + | NONE => + (case C_Ast_Utils.extract_union_type_from_specs_full (!current_union_names) specs of + SOME un => SOME (C_Ast_Utils.CUnion un) + | NONE => NONE))) + val ptr_depth = + List.mapPartial + (fn ((Some declr, _), _) => SOME (C_Ast_Utils.pointer_depth_of_declr declr) + | _ => NONE) declrs + |> (fn d :: _ => d | [] => 0) + in + Option.map (fn ct => C_Ast_Utils.apply_ptr_depth ct ptr_depth) base_cty + end + | cty_of_decl_for_struct _ _ = NONE + + (* Determine the C struct type of an expression used as a member-access base. + Handles casts and expression wrappers around variables/member chains. *) + fun determine_struct_type tctx (CVar0 (ident, _)) = + let val name = C_Ast_Utils.ident_name ident + in case C_Trans_Ctxt.get_struct_type tctx name of + SOME sname => sname + | NONE => error ("micro_c_translate: cannot determine struct type for: " ^ name) + end + | determine_struct_type tctx (CMember0 (inner_expr, field_ident, _, _)) = + let val inner_struct = determine_struct_type tctx inner_expr + val field_name = C_Ast_Utils.ident_name field_ident + in case C_Trans_Ctxt.lookup_struct_field_type tctx inner_struct field_name of + SOME (C_Ast_Utils.CStruct sname) => sname + | SOME (C_Ast_Utils.CPtr (C_Ast_Utils.CStruct sname)) => sname + | SOME (C_Ast_Utils.CUnion sname) => sname + | SOME (C_Ast_Utils.CPtr (C_Ast_Utils.CUnion sname)) => sname + | _ => error ("micro_c_translate: field " ^ field_name ^ " of " ^ + inner_struct ^ " is not a struct/union type") + end + | determine_struct_type tctx (CUnary0 (CIndOp0, inner_expr, _)) = + (* *p where p points to a struct — recurse to determine struct type *) + determine_struct_type tctx inner_expr + | determine_struct_type tctx (CIndex0 (inner_expr, _, _)) = + (* arr[i] where arr is a struct field — the struct type comes from the array expression *) + determine_struct_type tctx inner_expr + | determine_struct_type tctx (CCast0 (decl, inner_expr, _)) = + (case cty_of_decl_for_struct tctx decl of + SOME cty => + (case struct_name_of_cty cty of + SOME sname => sname + | NONE => determine_struct_type tctx inner_expr) + | NONE => determine_struct_type tctx inner_expr) + | determine_struct_type tctx (CCond0 (_, Some then_expr, else_expr, _)) = + (determine_struct_type tctx then_expr + handle ERROR _ => determine_struct_type tctx else_expr) + | determine_struct_type tctx (CComma0 (exprs, _)) = + (case List.rev exprs of + e :: _ => determine_struct_type tctx e + | [] => error "micro_c_translate: empty comma expression") + | determine_struct_type _ _ = + error "micro_c_translate: struct member access on complex expression not yet supported" + + (* Resolve a struct field accessor/updater constant by naming convention. + Prefix defaults to "c_" and can be overridden via command options. *) + fun struct_accessor_name struct_name field_name = + !current_decl_prefix ^ struct_name ^ "_" ^ field_name + + fun struct_updater_name struct_name field_name = + "update_" ^ struct_accessor_name struct_name field_name + + fun struct_focus_name struct_name field_name = + struct_accessor_name struct_name field_name ^ "_focus" + + fun resolve_const ctxt name = + let val (full_name, _) = Term.dest_Const + (Proof_Context.read_const {proper = true, strict = true} ctxt name) + in Isa_Const (full_name, isa_dummyT) end + + fun try_resolve_const ctxt name = + SOME (resolve_const ctxt name) handle ERROR _ => NONE + + fun pick_preferred_const_by_base ctxt pred = + let + val consts_info = Consts.dest (Proof_Context.consts_of ctxt) + val names = map #1 (#constants consts_info) + val matches = List.filter pred names + fun base n = Long_Name.base_name n + fun pref_rank n = + let val b = base n in + if String.isPrefix (!current_decl_prefix) b then 0 + else if String.isPrefix "c_" b then 1 + else 2 + end + fun best [] = NONE + | best (n :: ns) = + SOME (List.foldl (fn (m, acc) => if pref_rank m < pref_rank acc then m else acc) n ns) + in + best matches + end + + fun resolve_struct_accessor_const ctxt struct_name field_name = + let + val suffix = struct_name ^ "_" ^ field_name + val explicit = + [ struct_accessor_name struct_name field_name + , (!current_decl_prefix ^ struct_name) ^ "." ^ struct_accessor_name struct_name field_name + , struct_name ^ "." ^ struct_accessor_name struct_name field_name + ] + fun try_explicit [] = NONE + | try_explicit (n :: ns) = + (case try_resolve_const ctxt n of SOME c => SOME c | NONE => try_explicit ns) + in + case try_explicit explicit of + SOME c => c + | NONE => + (case pick_preferred_const_by_base ctxt + (fn full => + let val b = Long_Name.base_name full in + String.isSuffix suffix b andalso + not (String.isPrefix "update_" b) andalso + not (String.isSuffix "_focus" b) + end) of + SOME full => Isa_Const (full, isa_dummyT) + | NONE => + error ("micro_c_translate: missing struct field accessor constant: " ^ + struct_accessor_name struct_name field_name)) + end + + fun resolve_struct_updater_const ctxt struct_name field_name = + let + val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name + val (accessor_full, _) = Term.dest_Const accessor_const + val qualifier = Long_Name.qualifier accessor_full + val accessor_base = Long_Name.base_name accessor_full + val updater_base = "update_" ^ accessor_base + val qualified = if qualifier = "" then updater_base else qualifier ^ "." ^ updater_base + val suffix = "update_" ^ struct_name ^ "_" ^ field_name + in + case try_resolve_const ctxt qualified of + SOME c => c + | NONE => + (case try_resolve_const ctxt updater_base of + SOME c => c + | NONE => + (case pick_preferred_const_by_base ctxt + (fn full => String.isSuffix suffix (Long_Name.base_name full)) of + SOME full => Isa_Const (full, isa_dummyT) + | NONE => + error ("micro_c_translate: missing struct field updater constant: " ^ + struct_updater_name struct_name field_name))) + end + + fun resolve_struct_focus_const ctxt struct_name field_name = + let + val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name + val updater_const = resolve_struct_updater_const ctxt struct_name field_name + val (accessor_full, _) = Term.dest_Const accessor_const + val qualifier = Long_Name.qualifier accessor_full + val accessor_base = Long_Name.base_name accessor_full + val focus_base = accessor_base ^ "_focus" + val record_name = !current_decl_prefix ^ struct_name + val candidates = + [ if qualifier = "" then focus_base else qualifier ^ "." ^ focus_base + , focus_base + , struct_focus_name struct_name field_name + , record_name ^ "." ^ struct_focus_name struct_name field_name + , struct_name ^ "." ^ struct_focus_name struct_name field_name + ] + fun mk_focus_from_lens () = + let + val make_lens_const = resolve_const ctxt "make_lens_via_view_modify" + val lens_to_focus_raw_const = resolve_const ctxt "lens_to_focus_raw" + val abs_focus_const = resolve_const ctxt "Abs_focus" + val lens = + make_lens_const $ accessor_const $ updater_const + val focus_raw = lens_to_focus_raw_const $ lens + in + abs_focus_const $ focus_raw + end + fun try_names [] = mk_focus_from_lens () + | try_names (n :: ns) = + (resolve_const ctxt n handle ERROR _ => try_names ns) + in + try_names candidates + end + + fun resolve_dereference_const ctxt = + (let + val (full_name, _) = + Term.dest_Const + (Proof_Context.read_const {proper = true, strict = false} ctxt "dereference_fun") + in + Isa_Const (full_name, isa_dummyT) + end + handle ERROR _ => + Isa_Const (\<^const_name>\store_dereference_const\, isa_dummyT)) + + fun resolve_required_visible_const ctxt short_name = + (case resolve_visible_const_term ctxt short_name of + SOME tm => tm + | NONE => error ("micro_c_translate: missing required interface constant: " ^ short_name)) + + fun resolve_pointer_model_const ctxt (_ : string) opt_name default_name = + (case opt_name of + SOME name => resolve_required_visible_const ctxt name + | NONE => resolve_required_visible_const ctxt default_name) + + fun resolve_ptr_add_const ctxt = + resolve_pointer_model_const ctxt "ptr_add:" (#ptr_add (!current_pointer_model)) "c_ptr_add" + + fun resolve_ptr_shift_signed_const ctxt = + resolve_pointer_model_const ctxt "ptr_shift_signed:" (#ptr_shift_signed (!current_pointer_model)) "c_ptr_shift_signed" + + fun resolve_ptr_diff_const ctxt = + resolve_pointer_model_const ctxt "ptr_diff:" (#ptr_diff (!current_pointer_model)) "c_ptr_diff" + + fun mk_resolved_var_alloc_typed ctxt val_hol_type init_expr = + let val ref_const = + (case resolve_visible_const_term ctxt "store_reference_const" of + SOME tm => tm + | NONE => + (if val_hol_type = isa_dummyT + then Isa_Const (\<^const_name>\store_reference_const\, isa_dummyT) + else Isa_Const (\<^const_name>\store_reference_const\, val_hol_type --> isa_dummyT))) + val init_expr = constrain_expr_side_types init_expr + val arg_ty = + if val_hol_type = isa_dummyT then expr_value_type init_expr else val_hol_type + val res_value_ty = + if arg_ty = isa_dummyT then isa_dummyT else local_ref_value_ty arg_ty + val ref_const = + if arg_ty = isa_dummyT then ref_const + else constrain_function_body_arrow_from_tm arg_ty res_value_ty init_expr ref_const + in constrain_expr_side_types (mk_typed_funcall1_from_tm init_expr res_value_ty ref_const) end + + fun mk_resolved_var_alloc ctxt init_expr = + mk_resolved_var_alloc_typed ctxt isa_dummyT init_expr + + fun raw_ptr_local_gref_typ () = + Isa_Type (\<^type_name>\gref\, [!current_ref_addr_ty, !current_ref_gv_ty]) + + fun supports_raw_ptr_local_refs ctxt = + let + val raw_ptr_ty = raw_ptr_local_gref_typ () + val uninit = Isa_Const (\<^const_name>\c_uninitialized\, raw_ptr_ty) + val probe = mk_resolved_var_alloc_typed ctxt raw_ptr_ty (C_Term_Build.mk_literal uninit) + val _ = Syntax.check_term ctxt probe + in true end + handle ERROR _ => false + | TYPE _ => false + + fun is_uninitialized_literal tm = + (case Term.strip_comb tm of + (hd, [arg]) => + (case (try Term.dest_Const hd, try Term.dest_Const arg) of + (SOME (n1, _), SOME (n2, _)) => + n1 = \<^const_name>\Core_Expression.literal\ andalso + n2 = \<^const_name>\c_uninitialized\ + | _ => false) + | _ => false) + + fun expr_value_ty_is_list_backed_ptr tm = + (case expr_value_type tm of + Term.Type (fname, [_, _, Term.Type (lname, [_])]) => + Long_Name.base_name fname = "focused" andalso Long_Name.base_name lname = "list" + | Term.Type (lname, [_]) => Long_Name.base_name lname = "list" + | _ => false) + + fun prefer_pointer_alias_storage alias_list_backed init_term = + is_uninitialized_literal init_term orelse alias_list_backed orelse expr_value_ty_is_list_backed_ptr init_term + + fun pointer_alias_kind alias_list_backed = + if alias_list_backed then C_Trans_Ctxt.ParamListPtr + else C_Trans_Ctxt.Param + + fun pointer_alias_var_ty tctx alias_list_backed cty init_term = + let + val init_ty = expr_value_type init_term + val fallback_ty = + (case if alias_list_backed then list_backed_pointer_value_hol_ty cty + else pointer_expr_value_hol_ty cty of + SOME ty => ty + | NONE => expr_value_ty_of_cty cty) + val ty = + if is_uninitialized_literal init_term orelse init_ty = isa_dummyT + then fallback_ty + else init_ty + in normalize_ref_universe_type tctx ty end + + (* Variable read: delegates to mk_var_read. *) + fun mk_resolved_var_read _ ref_var = + constrain_expr_side_types (C_Term_Build.mk_var_read ref_var) + + fun mk_literal_value_read var = + let + val tm = C_Term_Build.mk_literal var + val value_ty = fastype_of var + in + if value_ty = isa_dummyT then constrain_expr_side_types tm + else constrain_known_expr_value_type value_ty tm + end + + fun mk_resolved_deref_expr ctxt result_cty ptr_expr = + let + val ptr_expr = constrain_expr_side_types ptr_expr + val deref_const = resolve_dereference_const ctxt + val result_ty = expr_value_ty_of_cty result_cty + val deref_fn = + if result_ty = isa_dummyT then + Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) + $ deref_const + else mk_typed_call_deep1_from_tm ptr_expr result_ty deref_const + in constrain_expr_cty result_cty + (Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ ptr_expr $ deref_fn) + end + + fun mk_pair_eval unseq ltm rtm lvar rvar body = + if unseq then + C_Term_Build.mk_bind2_unseq (Term.lambda lvar (Term.lambda rvar body)) ltm rtm + else + C_Term_Build.mk_bind ltm (Term.lambda lvar + (C_Term_Build.mk_bind rtm (Term.lambda rvar body))) + + fun mk_index_guard idx_p_cty i_var list_tm body_term = + let + val idx_nat = C_Term_Build.mk_unat i_var + val len_tm = + Isa_Const (\<^const_name>\size\, isa_dummyT --> @{typ nat}) $ list_tm + val in_bounds = + Isa_Const (\<^const_name>\Orderings.less\, @{typ nat} --> @{typ nat} --> @{typ bool}) + $ idx_nat $ len_tm + val overflow = Isa_Const (\<^const_name>\c_bounds_abort\, isa_dummyT) + val guarded_upper = + C_Term_Build.mk_two_armed_cond (C_Term_Build.mk_literal in_bounds) body_term overflow + in + if C_Ast_Utils.is_signed idx_p_cty then + let + val lt_zero = + C_Term_Build.mk_bind2 + (Isa_Const (\<^const_name>\c_signed_less\, isa_dummyT)) + (C_Term_Build.mk_literal i_var) + (C_Term_Build.mk_literal_num idx_p_cty 0) + in + C_Term_Build.mk_two_armed_cond lt_zero overflow guarded_upper + end + else guarded_upper + end + + fun struct_field_is_array_backed struct_name field_name = + List.exists (fn fname => fname = field_name) + (the_default [] (Symtab.lookup (!current_struct_array_fields) struct_name)) + + fun expr_is_list_backed_array tctx (CVar0 (ident, _)) = + let val name = C_Ast_Utils.ident_name ident + in + Option.isSome (C_Trans_Ctxt.lookup_array_decl tctx name) orelse + (case C_Trans_Ctxt.lookup_var tctx name of + SOME (C_Trans_Ctxt.ParamListPtr, _, _) => true + | _ => false) + end + | expr_is_list_backed_array tctx (CMember0 (expr, field_ident, _, _)) = + ((let + val struct_name = determine_struct_type tctx expr + val field_name = C_Ast_Utils.ident_name field_ident + in + struct_field_is_array_backed struct_name field_name + end) handle ERROR _ => false) + | expr_is_list_backed_array _ _ = false + + fun use_raw_pointer_indexing tctx arr_expr = + uses_raw_pointer_model () andalso not (expr_is_list_backed_array tctx arr_expr) + + fun is_nonnegative_int_const (CConst0 (CIntConst0 (CInteger0 (n, _, _), _))) = (n >= 0) + | is_nonnegative_int_const _ = false + + fun pointer_arith_result_ty elem_cty = + let + val gref_ty = Isa_Type (\<^type_name>\gref\, [!current_ref_addr_ty, !current_ref_gv_ty]) + in + case elem_cty of + C_Ast_Utils.CVoid => gref_ty + | C_Ast_Utils.CUnion _ => gref_ty + | _ => + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) elem_cty of + SOME inner_ty => Isa_Type (\<^type_name>\focused\, [gref_ty, !current_ref_gv_ty, inner_ty]) + | NONE => gref_ty) + end + + fun mk_ptr_shifted_term ctxt ptr_var idx_var idx_p_cty elem_cty prefer_unsigned_add = + let + val stride_tm = HOLogic.mk_number @{typ nat} (C_Ast_Utils.sizeof_c_type elem_cty) + val ptr_ty = fastype_of ptr_var + val is_focused = + (case ptr_ty of + Term.Type (name, _) => name = \<^type_name>\focused\ + | _ => false) + val raw_ptr = + if is_focused then + Isa_Const (\<^const_name>\unwrap_focused\, isa_dummyT --> isa_dummyT) $ ptr_var + else ptr_var + val signed_idx = + Isa_Const (\<^const_name>\signed\, isa_dummyT --> @{typ int}) $ idx_var + val shifted_raw = + if C_Ast_Utils.is_signed idx_p_cty andalso not prefer_unsigned_add then + resolve_ptr_shift_signed_const ctxt $ raw_ptr $ signed_idx $ stride_tm + else + resolve_ptr_add_const ctxt $ raw_ptr $ (C_Term_Build.mk_unat idx_var) $ stride_tm + in + if is_focused then + Isa_Const (\<^const_name>\make_focused\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ shifted_raw + $ (Isa_Const (\<^const_name>\get_focus\, isa_dummyT --> isa_dummyT) $ ptr_var) + else shifted_raw + end + + fun mk_raw_ptr_loc_expr ctxt unseq_operands ptr_term idx_term idx_cty elem_cty prefer_unsigned_add = + let + val ptr_ty0 = expr_value_type ptr_term + val ptr_ty = if ptr_ty0 = isa_dummyT then pointer_arith_result_ty elem_cty else ptr_ty0 + val p_var = Isa_Free ("v__ptr", ptr_ty) + val idx_p_cty = C_Ast_Utils.integer_promote idx_cty + val idx_p_term = mk_implicit_cast (idx_term, idx_cty, idx_p_cty) + val idx_var_ty = + let val ty = expr_value_type idx_p_term + in if ty = isa_dummyT then C_Ast_Utils.hol_type_of idx_p_cty else ty end + val i_var = Isa_Free ("v__idx", idx_var_ty) + val shifted = mk_ptr_shifted_term ctxt p_var i_var idx_p_cty elem_cty prefer_unsigned_add + in + mk_pair_eval unseq_operands ptr_term idx_p_term p_var i_var (C_Term_Build.mk_literal shifted) + end + + fun raw_struct_field_offset tctx struct_name field_name = + (case C_Trans_Ctxt.get_struct_fields tctx struct_name of + SOME fields => + let + fun align_up_local (offset, alignment) = + let val rem = offset mod alignment + in if rem = 0 then offset else offset + (alignment - rem) end + fun field_offset [] _ _ = + error ("micro_c_translate: unknown struct field in layout: " ^ field_name) + | field_offset ((name, field_cty) :: rest) offset max_align = + let + val field_size = C_Ast_Utils.sizeof_c_type field_cty + val field_align = C_Ast_Utils.alignof_c_type field_cty + val aligned_offset = align_up_local (offset, field_align) + in + if name = field_name then aligned_offset + else field_offset rest (aligned_offset + field_size) (Int.max (max_align, field_align)) + end + in + field_offset fields 0 1 + end + | NONE => error ("micro_c_translate: unknown struct for field offset: " ^ struct_name)) + + fun mk_raw_struct_field_ptr_expr tctx struct_name field_name raw_ptr_expr = + let + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val offset = raw_struct_field_offset tctx struct_name field_name + val raw_ptr_ty = Term.Type (\<^type_name>\gref\, [!current_ref_addr_ty, !current_ref_gv_ty]) + val ptr_ty0 = expr_value_type raw_ptr_expr + val ptr_ty = if ptr_ty0 = isa_dummyT then raw_ptr_ty else ptr_ty0 + val ptr_var = Isa_Free ("v__base_ptr", ptr_ty) + val shifted = + resolve_ptr_add_const ctxt $ ptr_var $ HOLogic.mk_nat offset $ HOLogic.mk_nat 1 + in + constrain_expr_side_types + (constrain_expr_value_type raw_ptr_ty + (C_Term_Build.mk_bind raw_ptr_expr + (Term.lambda ptr_var (C_Term_Build.mk_literal shifted)))) + end + + fun mk_raw_struct_field_loc_expr tctx struct_name field_name field_cty raw_ptr_expr = + let + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val field_ptr = mk_raw_struct_field_ptr_expr tctx struct_name field_name raw_ptr_expr + in + mk_cast_from_void_in ctxt field_cty field_ptr + end + + (* Helper for pre/post increment/decrement. + is_inc: true for increment, false for decrement + is_pre: true for pre (return new), false for post (return old) + expr_fn / lvalue_fn: callbacks for translate_expr / translate_lvalue_location + passed from the mutual-recursion group where those functions are in scope. *) + fun translate_inc_dec _ _ tctx is_inc is_pre (CVar0 (ident, _)) = + let val name = C_Ast_Utils.ident_name ident + in case C_Trans_Ctxt.lookup_var tctx name of + SOME (C_Trans_Ctxt.Local, ref_var, cty) => + (case cty of + C_Ast_Utils.CPtr inner => + let + val read = C_Term_Build.mk_var_read ref_var + val old_var = Isa_Free ("v__old_ptr", isa_dummyT) + val idx_cty = if is_inc then C_Ast_Utils.CUInt else C_Ast_Utils.CInt + val idx_ty = C_Ast_Utils.hol_type_of idx_cty + val idx_term = HOLogic.mk_number idx_ty (if is_inc then 1 else ~1) + val shifted = + mk_ptr_shifted_term (C_Trans_Ctxt.get_ctxt tctx) + old_var idx_term idx_cty inner is_inc + val shifted_expr = C_Term_Build.mk_literal shifted + val write = C_Term_Build.mk_var_write ref_var shifted_expr + val return_term = + if is_pre then shifted_expr else C_Term_Build.mk_literal old_var + in + (C_Term_Build.mk_bind read (Term.lambda old_var + (C_Term_Build.mk_sequence write return_term)), cty) + end + | _ => + let val old_var = Isa_Free ("v__old", isa_dummyT) + val new_var = Isa_Free ("v__new", isa_dummyT) + val arith_cty = C_Ast_Utils.integer_promote cty + val one = C_Term_Build.mk_literal_num arith_cty 1 + val arith_const = + if is_inc then + (if C_Ast_Utils.is_signed arith_cty + then Isa_Const (\<^const_name>\c_signed_add\, isa_dummyT) + else Isa_Const (\<^const_name>\c_unsigned_add\, isa_dummyT)) + else + (if C_Ast_Utils.is_signed arith_cty + then Isa_Const (\<^const_name>\c_signed_sub\, isa_dummyT) + else Isa_Const (\<^const_name>\c_unsigned_sub\, isa_dummyT)) + val read = C_Term_Build.mk_var_read ref_var + val old_promoted = + mk_implicit_cast (C_Term_Build.mk_literal old_var, cty, arith_cty) + val add = C_Term_Build.mk_bind2 arith_const + old_promoted one + val new_assigned = + mk_implicit_cast (C_Term_Build.mk_literal new_var, arith_cty, cty) + val write = C_Term_Build.mk_var_write ref_var + new_assigned + val return_term = + if is_pre then new_assigned else C_Term_Build.mk_literal old_var + in (C_Term_Build.mk_bind read (Term.lambda old_var + (C_Term_Build.mk_bind add (Term.lambda new_var + (C_Term_Build.mk_sequence write + return_term)))), cty) end) + | SOME (C_Trans_Ctxt.LocalPtr, ref_var, cty) => + (case cty of + C_Ast_Utils.CPtr inner => + let + val old_raw = C_Term_Build.mk_var_read ref_var + val old_var = Isa_Free ("v__old_ptr", raw_ptr_local_gref_typ ()) + val typed_old = + (case inner of + C_Ast_Utils.CVoid => old_var + | C_Ast_Utils.CUnion _ => old_var + | _ => + let + val target_ty = C_Ast_Utils.hol_type_of inner + val prism_ty = Isa_Type (\<^type_name>\prism\, [!current_ref_gv_ty, target_ty]) + val prism_const = Isa_Const (\<^const_name>\c_void_cast_prism_for\, prism_ty) + val focused_ty = Isa_Type (\<^type_name>\focused\, + [isa_dummyT, !current_ref_gv_ty, target_ty]) + val cast_const = Isa_Const (\<^const_name>\c_cast_from_void\, + prism_ty --> isa_dummyT --> focused_ty) + in + cast_const $ prism_const $ old_var + end) + val idx_cty = if is_inc then C_Ast_Utils.CUInt else C_Ast_Utils.CInt + val idx_ty = C_Ast_Utils.hol_type_of idx_cty + val idx_term = HOLogic.mk_number idx_ty (if is_inc then 1 else ~1) + val shifted = mk_ptr_shifted_term (C_Trans_Ctxt.get_ctxt tctx) typed_old idx_term idx_cty inner is_inc + val shifted_expr = C_Term_Build.mk_literal shifted + val shifted_raw = mk_implicit_cast (shifted_expr, cty, C_Ast_Utils.CPtr C_Ast_Utils.CVoid) + val new_raw = Isa_Free ("v__new_ptr", raw_ptr_local_gref_typ ()) + val return_term = + if is_pre then shifted_expr else C_Term_Build.mk_literal old_var + in (C_Term_Build.mk_bind old_raw (Term.lambda old_var + (C_Term_Build.mk_bind shifted_raw (Term.lambda new_raw + (C_Term_Build.mk_sequence + (C_Term_Build.mk_var_write ref_var (C_Term_Build.mk_literal new_raw)) + return_term)))), cty) + end + | _ => error ("micro_c_translate: internal error: non-pointer LocalPtr: " ^ name)) + | SOME (C_Trans_Ctxt.Param, _, _) => + error ("micro_c_translate: cannot increment/decrement parameter: " ^ name) + | SOME (C_Trans_Ctxt.ParamListPtr, _, _) => + error ("micro_c_translate: cannot increment/decrement parameter: " ^ name) + | NONE => + (case C_Trans_Ctxt.lookup_global_const tctx name of + SOME _ => + error ("micro_c_translate: cannot increment/decrement global constant: " ^ name) + | NONE => + error ("micro_c_translate: undefined variable: " ^ name)) + end + (* inc/dec through pointer dereference *) + | translate_inc_dec expr_fn _ tctx is_inc is_pre (CUnary0 (CIndOp0, ptr_expr, _)) = + let val (ptr_term, ptr_cty) = expr_fn tctx ptr_expr + val pointee_cty = + (case ptr_cty of C_Ast_Utils.CPtr inner => inner + | _ => unsupported "increment/decrement dereference on non-pointer") + val arith_cty = C_Ast_Utils.integer_promote pointee_cty + val one = C_Term_Build.mk_literal_num arith_cty 1 + val arith_const = + if is_inc then + (if C_Ast_Utils.is_signed arith_cty + then Isa_Const (\<^const_name>\c_signed_add\, isa_dummyT) + else Isa_Const (\<^const_name>\c_unsigned_add\, isa_dummyT)) + else + (if C_Ast_Utils.is_signed arith_cty + then Isa_Const (\<^const_name>\c_signed_sub\, isa_dummyT) + else Isa_Const (\<^const_name>\c_unsigned_sub\, isa_dummyT)) + val ptr_var = Isa_Free ("v__ptr", isa_dummyT) + val old_var = Isa_Free ("v__old", isa_dummyT) + val new_var = Isa_Free ("v__new", isa_dummyT) + val old_promoted = + mk_implicit_cast (C_Term_Build.mk_literal old_var, pointee_cty, arith_cty) + val add = C_Term_Build.mk_bind2 arith_const old_promoted one + val new_assigned = + mk_implicit_cast (C_Term_Build.mk_literal new_var, arith_cty, pointee_cty) + val return_term = + if is_pre then new_assigned else C_Term_Build.mk_literal old_var + in (C_Term_Build.mk_bind ptr_term (Term.lambda ptr_var + (C_Term_Build.mk_bind + (C_Term_Build.mk_deref (C_Term_Build.mk_literal ptr_var)) + (Term.lambda old_var + (C_Term_Build.mk_bind add (Term.lambda new_var + (C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal ptr_var) + new_assigned) + return_term)))))), + pointee_cty) end + (* inc/dec struct field via p->f or s.f *) + | translate_inc_dec expr_fn lvalue_fn tctx is_inc is_pre (CMember0 (expr, field_ident, is_ptr, _)) = + let val field_name = C_Ast_Utils.ident_name field_ident + val struct_name = determine_struct_type tctx expr + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name + val updater_const = resolve_struct_updater_const ctxt struct_name field_name + val ptr_term = if is_ptr then #1 (expr_fn tctx expr) + else #1 (lvalue_fn tctx expr) + val field_cty = + (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of + SOME cty => cty + | NONE => unsupported ("unknown struct field: " ^ struct_name ^ "." ^ field_name)) + val arith_cty = C_Ast_Utils.integer_promote field_cty + val one = C_Term_Build.mk_literal_num arith_cty 1 + val arith_const = + if is_inc then + (if C_Ast_Utils.is_signed arith_cty + then Isa_Const (\<^const_name>\c_signed_add\, isa_dummyT) + else Isa_Const (\<^const_name>\c_unsigned_add\, isa_dummyT)) + else + (if C_Ast_Utils.is_signed arith_cty + then Isa_Const (\<^const_name>\c_signed_sub\, isa_dummyT) + else Isa_Const (\<^const_name>\c_unsigned_sub\, isa_dummyT)) + val ptr_var = Isa_Free ("v__ptr", isa_dummyT) + val struct_var = Isa_Free ("v__struct", isa_dummyT) + val new_var = Isa_Free ("v__new", isa_dummyT) + val old_val = accessor_const $ struct_var + val old_promoted = + mk_implicit_cast (C_Term_Build.mk_literal old_val, field_cty, arith_cty) + val add = C_Term_Build.mk_bind2 arith_const old_promoted one + val new_assigned = + mk_implicit_cast (C_Term_Build.mk_literal new_var, arith_cty, field_cty) + val return_term = + if is_pre then new_assigned else C_Term_Build.mk_literal old_val + val updated_struct = + updater_const + $ Term.lambda (Isa_Free ("_uu", isa_dummyT)) new_assigned + $ struct_var + in (C_Term_Build.mk_bind ptr_term (Term.lambda ptr_var + (C_Term_Build.mk_bind + (C_Term_Build.mk_deref (C_Term_Build.mk_literal ptr_var)) + (Term.lambda struct_var + (C_Term_Build.mk_bind add (Term.lambda new_var + (C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal ptr_var) + (C_Term_Build.mk_literal updated_struct)) + return_term)))))), + field_cty) end + (* inc/dec array element via arr[i] *) + | translate_inc_dec expr_fn _ tctx is_inc is_pre (CIndex0 (arr_expr, idx_expr, _)) = + let val (arr_term, arr_cty) = expr_fn tctx arr_expr + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val deref_const = resolve_dereference_const ctxt + val (idx_term_raw, idx_cty) = expr_fn tctx idx_expr + val idx_p_cty = C_Ast_Utils.integer_promote idx_cty + val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) + val elem_cty = (case arr_cty of + C_Ast_Utils.CPtr inner => inner + | _ => unsupported "increment/decrement on non-array indexing") + val arith_cty = C_Ast_Utils.integer_promote elem_cty + val one = C_Term_Build.mk_literal_num arith_cty 1 + val arith_const = + if is_inc then + (if C_Ast_Utils.is_signed arith_cty + then Isa_Const (\<^const_name>\c_signed_add\, isa_dummyT) + else Isa_Const (\<^const_name>\c_unsigned_add\, isa_dummyT)) + else + (if C_Ast_Utils.is_signed arith_cty + then Isa_Const (\<^const_name>\c_signed_sub\, isa_dummyT) + else Isa_Const (\<^const_name>\c_unsigned_sub\, isa_dummyT)) + val a_var = Isa_Free ("v__arr", isa_dummyT) + val i_var = Isa_Free ("v__idx", isa_dummyT) + val loc_var = Isa_Free ("v__loc", isa_dummyT) + val deref_expr = + Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ a_var) + $ (Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) + $ deref_const) + val old_var = Isa_Free ("v__old", isa_dummyT) + val new_var = Isa_Free ("v__new", isa_dummyT) + val unseq_operands = + C_Ast_Utils.expr_has_side_effect arr_expr orelse + C_Ast_Utils.expr_has_side_effect idx_expr + val focused = C_Term_Build.mk_focus_nth (C_Term_Build.mk_unat i_var) a_var + val loc_expr = + mk_pair_eval unseq_operands arr_term idx_term a_var i_var + (let + val list_ty = + (case C_Ast_Utils.hol_type_of elem_cty of + t => if t = isa_dummyT then isa_dummyT else Isa_Type (\<^type_name>\list\, [t])) + val list_var = Isa_Free ("v__arr_vals", list_ty) + in C_Term_Build.mk_bind deref_expr + (Term.lambda list_var (mk_index_guard idx_p_cty i_var list_var (C_Term_Build.mk_literal focused))) end) + val old_promoted = + mk_implicit_cast (C_Term_Build.mk_literal old_var, elem_cty, arith_cty) + val add = C_Term_Build.mk_bind2 arith_const old_promoted one + val new_assigned = + mk_implicit_cast (C_Term_Build.mk_literal new_var, arith_cty, elem_cty) + val return_term = + if is_pre then new_assigned else C_Term_Build.mk_literal old_var + in (C_Term_Build.mk_bind loc_expr (Term.lambda loc_var + (C_Term_Build.mk_bind + (C_Term_Build.mk_deref (C_Term_Build.mk_literal loc_var)) + (Term.lambda old_var + (C_Term_Build.mk_bind add (Term.lambda new_var + (C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal loc_var) + new_assigned) + return_term)))))), + elem_cty) end + | translate_inc_dec _ _ _ _ _ _ = + unsupported "increment/decrement on unsupported expression" + + + + fun is_shift_binop CShlOp0 = true + | is_shift_binop CShrOp0 = true + | is_shift_binop _ = false + + (* C11 \
6.5.16.2: compound assignment (e1 op= e2). + Computed in the same arithmetic type as (e1 op e2) with integer + promotions/usual conversions (\
6.3.1.8), then converted back to e1's type. + For shifts (\
6.5.7): operands are independently promoted; the RHS is + additionally cast to the LHS promoted type because our Isabelle shift + operations require matching types (semantically safe since unat extracts + the numeric value regardless of type width for valid shift counts). *) + fun prepare_compound_operands lhs_cty rhs_tm rhs_cty binop lhs_old_tm = + if is_shift_binop binop then + let + val lhs_prom_cty = C_Ast_Utils.integer_promote lhs_cty + val rhs_prom_cty = C_Ast_Utils.integer_promote rhs_cty + val lhs_prom = mk_implicit_cast (lhs_old_tm, lhs_cty, lhs_prom_cty) + val rhs_prom = + mk_implicit_cast + (mk_implicit_cast (rhs_tm, rhs_cty, rhs_prom_cty), rhs_prom_cty, lhs_prom_cty) + in + (lhs_prom_cty, lhs_prom, rhs_prom) + end + else + let + val op_cty = C_Ast_Utils.usual_arith_conv (lhs_cty, rhs_cty) + val lhs_prom = mk_implicit_cast (lhs_old_tm, lhs_cty, op_cty) + val rhs_prom = mk_implicit_cast (rhs_tm, rhs_cty, op_cty) + in + (op_cty, lhs_prom, rhs_prom) + end + + fun compound_op_cty lhs_cty rhs_cty binop = + if is_shift_binop binop + then C_Ast_Utils.integer_promote lhs_cty + else C_Ast_Utils.usual_arith_conv (lhs_cty, rhs_cty) + + (* Map compound assignment operators to their binary operator equivalents *) + fun compound_assign_to_binop CAddAssOp0 = SOME CAddOp0 + | compound_assign_to_binop CSubAssOp0 = SOME CSubOp0 + | compound_assign_to_binop CMulAssOp0 = SOME CMulOp0 + | compound_assign_to_binop CDivAssOp0 = SOME CDivOp0 + | compound_assign_to_binop CRmdAssOp0 = SOME CRmdOp0 + | compound_assign_to_binop CShlAssOp0 = SOME CShlOp0 + | compound_assign_to_binop CShrAssOp0 = SOME CShrOp0 + | compound_assign_to_binop CAndAssOp0 = SOME CAndOp0 + | compound_assign_to_binop CXorAssOp0 = SOME CXorOp0 + | compound_assign_to_binop COrAssOp0 = SOME COrOp0 + | compound_assign_to_binop _ = NONE + + val intinf_to_int_checked = C_Ast_Utils.intinf_to_int_checked + + val cty_bit_width = C_Ast_Utils.bit_width_of + val sizeof_c_type = C_Ast_Utils.sizeof_c_type + val alignof_c_type = C_Ast_Utils.alignof_c_type + + fun align_up (offset, alignment) = + let val rem = offset mod alignment + in if rem = 0 then offset else offset + (alignment - rem) end + + (* Compute struct layout with ABI alignment padding. + Each field aligned to alignof(field); total rounded up to max alignment. *) + fun struct_layout (fields : (string * C_Ast_Utils.c_numeric_type) list) = + let + val (total_size, max_align, rev_layout) = + List.foldl (fn ((field_name, field_cty), (offset, max_a, acc)) => + let + val field_size = sizeof_c_type field_cty + val field_align = alignof_c_type field_cty + val aligned_offset = align_up (offset, field_align) + in + (aligned_offset + field_size, Int.max (max_a, field_align), + (field_name, aligned_offset, field_cty) :: acc) + end) + (0, 1, []) fields + val final_size = if max_align > 0 then align_up (total_size, max_align) else total_size + in + (rev rev_layout, final_size) + end + + fun sizeof_struct fields = #2 (struct_layout fields) + + fun fits_int_literal_cty cty n = + case cty_bit_width cty of + NONE => false + | SOME bits => + let val two_pow = IntInf.pow (2, bits) + in + if C_Ast_Utils.is_signed cty then + let + val maxp1 = IntInf.pow (2, bits - 1) + val lo = ~ maxp1 + val hi = maxp1 - 1 + in lo <= n andalso n <= hi end + else + 0 <= n andalso n < two_pow + end + + (* C11 \
6.4.4.1 Table 5: candidate types for integer constants. + The type of an integer constant is the first from the candidate list + in which its value can be represented. The candidate list depends on + the suffix (U, L, LL) and the representation (decimal vs hex/octal). + + Table 5 encoding — (is_unsigned, is_long, is_longlong, non_decimal) -> candidates: + no suffix, decimal: int, long, long long + no suffix, hex/oct: int, unsigned int, long, unsigned long, long long, unsigned long long + U, any: unsigned int, unsigned long, unsigned long long + L, decimal: long, long long + L, hex/oct: long, unsigned long, long long, unsigned long long + UL, any: unsigned long, unsigned long long + LL, decimal: long long + LL, hex/oct: long long, unsigned long long + ULL, any: unsigned long long *) + val int_literal_table : + (bool * bool * bool * bool * C_Ast_Utils.c_numeric_type list) list = + let open C_Ast_Utils in [ + (* (unsigned, long, longlong, non_decimal, candidates) *) + (false, false, false, false, [CInt, CLong, CLongLong]), + (false, false, false, true, [CInt, CUInt, CLong, CULong, CLongLong, CULongLong]), + (true, false, false, false, [CUInt, CULong, CULongLong]), + (true, false, false, true, [CUInt, CULong, CULongLong]), + (false, true, false, false, [CLong, CLongLong]), + (false, true, false, true, [CLong, CULong, CLongLong, CULongLong]), + (true, true, false, false, [CULong, CULongLong]), + (true, true, false, true, [CULong, CULongLong]), + (false, false, true, false, [CLongLong]), + (false, false, true, true, [CLongLong, CULongLong]), + (true, false, true, false, [CULongLong]), + (true, false, true, true, [CULongLong]) + ] end + + fun int_literal_candidates repr (Flags0 bits) = + let + val is_unsigned = IntInf.andb (bits, 1) <> 0 + val is_long = IntInf.andb (bits, 2) <> 0 + val is_long_long = IntInf.andb (bits, 4) <> 0 + val non_decimal = + (case repr of DecRepr0 => false | HexRepr0 => true | OctalRepr0 => true) + fun matches (u, l, ll, nd, _) = + u = is_unsigned andalso l = is_long andalso ll = is_long_long andalso nd = non_decimal + in + case List.find matches int_literal_table of + SOME (_, _, _, _, candidates) => candidates + | NONE => unsupported "unsupported integer literal suffix combination" + end + + (* C11 \
6.4.4.1p5: determine the type of an integer constant by finding + the first candidate type that can represent the constant's value. *) + fun choose_int_literal_type n repr flags = + let + fun first_fit [] = + unsupported ("integer literal out of supported range: " ^ IntInf.toString n) + | first_fit (cty :: rest) = + if fits_int_literal_cty cty n then cty else first_fit rest + in + first_fit (int_literal_candidates repr flags) + end + + + + (* --- Switch statement helpers --- *) + + (* Structured case label representation *) + datatype case_label = SingleCase of nodeInfo cExpression + | RangeCase of nodeInfo cExpression * nodeInfo cExpression + | DefaultCase + + (* Unwrap nested case/default/range labels from the C AST. + CCase0(1, CCase0(2, stmt)) becomes labels=[SingleCase 1, SingleCase 2], stmt + CCases0(lo, hi, stmt) becomes labels=[RangeCase(lo, hi)], stmt *) + fun unwrap_case_labels (CCase0 (expr, inner, _)) labels = + unwrap_case_labels inner (SingleCase expr :: labels) + | unwrap_case_labels (CCases0 (lo, hi, inner, _)) labels = + unwrap_case_labels inner (RangeCase (lo, hi) :: labels) + | unwrap_case_labels (CDefault0 (inner, _)) labels = + unwrap_case_labels inner (DefaultCase :: labels) + | unwrap_case_labels stmt labels = (rev labels, stmt) + + (* Extract case groups from flat switch body items. + Returns list of {labels, body, has_break}. *) + fun extract_switch_groups items = + let + fun close_group labels body has_break acc = + if null labels then acc + else {labels = rev labels, body = rev body, has_break = has_break} :: acc + fun walk [] labels body acc = rev (close_group labels body false acc) + | walk (CBlockStmt0 (stmt as CCase0 _) :: rest) labels body acc = + let val acc' = close_group labels body false acc + val (new_labels, first_stmt) = unwrap_case_labels stmt [] + in walk rest new_labels [CBlockStmt0 first_stmt] acc' end + | walk (CBlockStmt0 (stmt as CCases0 _) :: rest) labels body acc = + let val acc' = close_group labels body false acc + val (new_labels, first_stmt) = unwrap_case_labels stmt [] + in walk rest new_labels [CBlockStmt0 first_stmt] acc' end + | walk (CBlockStmt0 (stmt as CDefault0 _) :: rest) labels body acc = + let val acc' = close_group labels body false acc + val (new_labels, first_stmt) = unwrap_case_labels stmt [] + in walk rest new_labels [CBlockStmt0 first_stmt] acc' end + | walk (CBlockStmt0 (CBreak0 _) :: rest) labels body acc = + let val acc' = close_group labels body true acc + in walk rest [] [] acc' end + | walk (item :: rest) labels body acc = + walk rest labels (item :: body) acc + in walk items [] [] [] end + + (* Translate a case label expression to a pure HOL value *) + fun case_label_value switch_cty _ (CConst0 (CIntConst0 (CInteger0 (n, _, _), _))) = + HOLogic.mk_number (C_Ast_Utils.hol_type_of switch_cty) + (intinf_to_int_checked "switch case label" n) + | case_label_value switch_cty tctx (CVar0 (ident, _)) = + let val name = C_Ast_Utils.ident_name ident + in case C_Trans_Ctxt.lookup_enum_const tctx name of + SOME v => HOLogic.mk_number (C_Ast_Utils.hol_type_of switch_cty) v + | NONE => error ("micro_c_translate: unsupported case label: " ^ name) + end + | case_label_value _ _ _ = error "micro_c_translate: unsupported case label expression" + + (* Build condition for a case group: switch_var = label1 OR ... OR labelN. + Default labels map to default_cond, which should be ~(any explicit case matched). *) + (* Build lo <= switch_var AND switch_var <= hi for range case labels *) + fun mk_range_cond switch_var switch_cty tctx lo hi = + let val lo_val = case_label_value switch_cty tctx lo + val hi_val = case_label_value switch_cty tctx hi + val ty = C_Ast_Utils.hol_type_of switch_cty + val leq = Isa_Const (\<^const_name>\ord_class.less_eq\, ty --> ty --> @{typ bool}) + in HOLogic.mk_conj (leq $ lo_val $ switch_var, leq $ switch_var $ hi_val) end + + fun make_switch_cond switch_var switch_cty tctx default_cond labels = + let fun one_label (SingleCase e) = + HOLogic.mk_eq (switch_var, case_label_value switch_cty tctx e) + | one_label (RangeCase (lo, hi)) = + mk_range_cond switch_var switch_cty tctx lo hi + | one_label DefaultCase = default_cond + fun combine [] = Isa_Const (\<^const_name>\HOL.False\, @{typ bool}) + | combine [c] = c + | combine (c :: cs) = + Isa_Const (\<^const_name>\HOL.disj\, + @{typ bool} --> @{typ bool} --> @{typ bool}) $ c $ (combine cs) + in combine (List.map one_label labels) end + + (* Build a condition that says whether switch_var matches any explicit case label. *) + fun make_any_case_match switch_var switch_cty tctx groups = + let val labels = List.concat (List.map #labels groups) + fun one_label (SingleCase e) = + SOME (HOLogic.mk_eq (switch_var, case_label_value switch_cty tctx e)) + | one_label (RangeCase (lo, hi)) = + SOME (mk_range_cond switch_var switch_cty tctx lo hi) + | one_label DefaultCase = NONE + fun combine [] = Isa_Const (\<^const_name>\HOL.False\, @{typ bool}) + | combine [c] = c + | combine (c :: cs) = + Isa_Const (\<^const_name>\HOL.disj\, + @{typ bool} --> @{typ bool} --> @{typ bool}) $ c $ (combine cs) + in combine (List.mapPartial one_label labels) end + + (* --- Break/continue AST scanners --- *) + + fun contains_break (CBreak0 _) = true + | contains_break (CCompound0 (_, items, _)) = List.exists block_has_break items + | contains_break (CIf0 (_, t_br, e_opt, _)) = + contains_break t_br orelse + (case e_opt of Some e => contains_break e | None => false) + | contains_break (CSwitch0 _) = false (* break in switch exits switch, not loop *) + | contains_break (CFor0 _) = false (* break in nested loop is local *) + | contains_break (CWhile0 _) = false + | contains_break _ = false + and block_has_break (CBlockStmt0 s) = contains_break s + | block_has_break _ = false + + fun contains_continue (CCont0 _) = true + | contains_continue (CCompound0 (_, items, _)) = List.exists block_has_continue items + | contains_continue (CIf0 (_, t_br, e_opt, _)) = + contains_continue t_br orelse + (case e_opt of Some e => contains_continue e | None => false) + | contains_continue (CFor0 _) = false + | contains_continue (CWhile0 _) = false + | contains_continue _ = false + and block_has_continue (CBlockStmt0 s) = contains_continue s + | block_has_continue _ = false + + fun is_zero_int_const (CConst0 (CIntConst0 (CInteger0 (n, _, _), _))) = (n = 0) + | is_zero_int_const (CCast0 (_, e, _)) = is_zero_int_const e + | is_zero_int_const _ = false + + fun mk_ptr_is_null ptr_term = + let val p = Isa_Free ("v__ptrcmp", isa_dummyT) + val raw_p = Isa_Const (\<^const_name>\unwrap_focused\, isa_dummyT --> isa_dummyT) $ p + val conv = resolve_required_current_visible_const "c_ptr_to_uintptr" + val is_null = + Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT --> isa_dummyT --> @{typ bool}) + $ (conv $ raw_p) + $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT) + in C_Term_Build.mk_bind ptr_term (Term.lambda p (C_Term_Build.mk_literal is_null)) end + + (* translate_expr returns (term * c_numeric_type). + The type tracks the C type of the expression for binary operator dispatch. + CInt is used as default when the actual type is unknown/irrelevant. *) + fun translate_expr _ (CConst0 (CIntConst0 (CInteger0 (n, repr, flags), _))) = + let val cty = choose_int_literal_type n repr flags + val n_int = intinf_to_int_checked "integer literal" n + in (C_Term_Build.mk_literal_num cty n_int, cty) + end + | translate_expr tctx (CVar0 (ident, _)) = + let val name = C_Ast_Utils.ident_name ident + in case C_Trans_Ctxt.lookup_var tctx name of + SOME (C_Trans_Ctxt.Param, var, cty) => (mk_literal_value_read var, cty) + | SOME (C_Trans_Ctxt.ParamListPtr, var, cty) => (mk_literal_value_read var, cty) + | SOME (C_Trans_Ctxt.Local, var, cty) => + (* For local arrays, the ref IS the pointer (array-to-pointer decay). + Return it directly so CIndex0's deref accesses the list correctly. + For regular locals, use generic dereference to keep the monad universe + polymorphic across pure helper calls. *) + if Option.isSome (C_Trans_Ctxt.lookup_array_decl tctx name) + then (C_Term_Build.mk_literal var, cty) + else (C_Term_Build.mk_var_read var, cty) + | SOME (C_Trans_Ctxt.LocalPtr, var, cty) => + (mk_implicit_cast (C_Term_Build.mk_var_read var, C_Ast_Utils.CPtr C_Ast_Utils.CVoid, cty), cty) + | NONE => + (* Fallback: check global consts, then enum constants *) + (case C_Trans_Ctxt.lookup_global_const tctx name of + SOME (tm, cty) => + (case C_Trans_Ctxt.lookup_array_decl tctx name of + SOME (elem_cty, _) => (C_Term_Build.mk_literal tm, C_Ast_Utils.CPtr elem_cty) + | NONE => (C_Term_Build.mk_literal tm, cty)) + | NONE => + (case C_Trans_Ctxt.lookup_enum_const tctx name of + SOME value => (C_Term_Build.mk_literal_int value, C_Ast_Utils.CInt) + | NONE => error ("micro_c_translate: undefined variable: " ^ name))) + end + (* C11 \
6.5p2: if a side effect on a scalar object is unsequenced relative + to either a different side effect on the same object or a value computation + using the same object, the behavior is undefined. + C11 \
6.5p3: the order of evaluation of subexpressions and the order in + which side effects take place are both unspecified (except as specified). + Strategy: when both operands have side effects, we use bind2_unseq which + leaves evaluation order unspecified. When only one operand has side effects + or neither does, we use bind2 (left-to-right). If the operands have + unsequenced conflicting accesses to the same variable, we reject. *) + | translate_expr tctx (CBinary0 (binop, lhs, rhs, _)) = + let val ctxt = C_Trans_Ctxt.get_ctxt tctx + val (lhs', lhs_cty) = translate_expr tctx lhs + val (rhs', rhs_cty) = translate_expr tctx rhs + val unseq_operands = + C_Ast_Utils.expr_has_side_effect lhs orelse C_Ast_Utils.expr_has_side_effect rhs + val _ = + if unseq_operands andalso C_Ast_Utils.expr_has_unsequenced_ub_risk lhs rhs then + unsupported "potential unsequenced side-effect UB in binary expression" + else () + fun to_bool (tm, cty) = mk_implicit_cast (tm, cty, C_Ast_Utils.CBool) + fun mk_list_ptr_add ptr_term idx_term idx_cty elem_cty = + let val ptr_ty = expr_value_type ptr_term + val p_var = Isa_Free ("v__ptr", if ptr_ty = isa_dummyT then isa_dummyT else ptr_ty) + val i_var = Isa_Free ("v__idx", isa_dummyT) + val idx_p_cty = C_Ast_Utils.integer_promote idx_cty + val idx_p_term = mk_implicit_cast (idx_term, idx_cty, idx_p_cty) + val focused = C_Term_Build.mk_focus_nth (C_Term_Build.mk_unat i_var) p_var + val focused_lit = C_Term_Build.mk_literal focused + val list_ty = + (case C_Ast_Utils.hol_type_of elem_cty of + t => if t = isa_dummyT then isa_dummyT + else Isa_Type (\<^type_name>\list\, [t])) + val list_var = Isa_Free ("v__ptr_vals", list_ty) + val deref_const = resolve_dereference_const ctxt + val deref_expr = + Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ p_var) + $ (Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) + $ deref_const) + val guarded = + C_Term_Build.mk_bind deref_expr + (Term.lambda list_var (mk_index_guard idx_p_cty i_var list_var focused_lit)) + in (mk_pair_eval unseq_operands ptr_term idx_p_term p_var i_var guarded, + C_Ast_Utils.CPtr elem_cty) + end + fun mk_raw_ptr_add ptr_term idx_term idx_cty elem_cty prefer_unsigned_add = + (mk_raw_ptr_loc_expr ctxt unseq_operands ptr_term idx_term idx_cty elem_cty prefer_unsigned_add, + C_Ast_Utils.CPtr elem_cty) + fun mk_ptr_relcmp const_name short_name = + let val lhs_c = + (case pointer_expr_value_hol_ty lhs_cty of + SOME ty => constrain_expr_value_type ty lhs' + | NONE => lhs') + val rhs_c = + (case pointer_expr_value_hol_ty rhs_cty of + SOME ty => constrain_expr_value_type ty rhs' + | NONE => rhs') + val lhs_ptr_ty = expr_value_type lhs_c + val rhs_ptr_ty = expr_value_type rhs_c + val p_var = Isa_Free ("v__lptr", lhs_ptr_ty) + val q_var = Isa_Free ("v__rptr", rhs_ptr_ty) + val raw_ptr_ty = + Isa_Type (\<^type_name>\gref\, [!current_ref_addr_ty, !current_ref_gv_ty]) + fun raw_ptr_of ptr_ty ptr_var = + (case ptr_ty of + Term.Type (name, _) => + if name = \<^type_name>\focused\ + then Isa_Const (\<^const_name>\unwrap_focused\, isa_dummyT --> raw_ptr_ty) $ ptr_var + else ptr_var + | _ => ptr_var) + val p_raw = raw_ptr_of lhs_ptr_ty p_var + val q_raw = raw_ptr_of rhs_ptr_ty q_var + val cmp_const = + Type.constraint (raw_ptr_ty --> raw_ptr_ty --> @{typ bool}) + (if uses_raw_pointer_model () then resolve_required_visible_const ctxt short_name + else Isa_Const (const_name, isa_dummyT)) + val cmp_body = cmp_const $ p_raw $ q_raw + in (mk_pair_eval unseq_operands lhs_c rhs_c p_var q_var + (C_Term_Build.mk_literal cmp_body), + C_Ast_Utils.CBool) + end + in + case binop of + (* C11 \
6.5.13-14: logical AND/OR short-circuit and return _Bool *) + CLndOp0 => + let val lhs_bool = to_bool (lhs', lhs_cty) + val rhs_bool = to_bool (rhs', rhs_cty) + val v = Isa_Free ("v__lhsb", @{typ bool}) + in (C_Term_Build.mk_bind lhs_bool (Term.lambda v + (C_Term_Build.mk_two_armed_cond + (C_Term_Build.mk_literal v) + rhs_bool + (C_Term_Build.mk_literal (Isa_Const (\<^const_name>\HOL.False\, @{typ bool}))))), + C_Ast_Utils.CBool) + end + | CLorOp0 => + let val lhs_bool = to_bool (lhs', lhs_cty) + val rhs_bool = to_bool (rhs', rhs_cty) + val v = Isa_Free ("v__lhsb", @{typ bool}) + in (C_Term_Build.mk_bind lhs_bool (Term.lambda v + (C_Term_Build.mk_two_armed_cond + (C_Term_Build.mk_literal v) + (C_Term_Build.mk_literal (Isa_Const (\<^const_name>\HOL.True\, @{typ bool}))) + rhs_bool)), + C_Ast_Utils.CBool) + end + | _ => + (* Pointer arithmetic: p + n or n + p via focus_nth *) + (case (binop, lhs_cty, rhs_cty) of + (CEqOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => + if is_zero_int_const rhs then + (mk_ptr_is_null lhs', C_Ast_Utils.CBool) + else if is_zero_int_const lhs then + (mk_ptr_is_null rhs', C_Ast_Utils.CBool) + else + let val l = Isa_Free ("v__lptr", isa_dummyT) + val r = Isa_Free ("v__rptr", isa_dummyT) + val eq_t = Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT --> isa_dummyT --> @{typ bool}) $ l $ r + in (mk_pair_eval unseq_operands lhs' rhs' l r (C_Term_Build.mk_literal eq_t), + C_Ast_Utils.CBool) + end + | (CNeqOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => + if is_zero_int_const rhs then + let val b = Isa_Free ("v__isnull", @{typ bool}) + in (C_Term_Build.mk_bind (mk_ptr_is_null lhs') (Term.lambda b + (C_Term_Build.mk_literal + (Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) $ b))), + C_Ast_Utils.CBool) + end + else if is_zero_int_const lhs then + let val b = Isa_Free ("v__isnull", @{typ bool}) + in (C_Term_Build.mk_bind (mk_ptr_is_null rhs') (Term.lambda b + (C_Term_Build.mk_literal + (Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) $ b))), + C_Ast_Utils.CBool) + end + else + let val l = Isa_Free ("v__lptr", isa_dummyT) + val r = Isa_Free ("v__rptr", isa_dummyT) + val neq_t = + Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) + $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT --> isa_dummyT --> @{typ bool}) $ l $ r) + in (mk_pair_eval unseq_operands lhs' rhs' l r (C_Term_Build.mk_literal neq_t), + C_Ast_Utils.CBool) + end + | (CEqOp0, C_Ast_Utils.CPtr _, _) => + if is_zero_int_const rhs then + (mk_ptr_is_null lhs', C_Ast_Utils.CBool) + else + unsupported "pointer comparison with non-pointer operand" + | (CEqOp0, _, C_Ast_Utils.CPtr _) => + if is_zero_int_const lhs then + (mk_ptr_is_null rhs', C_Ast_Utils.CBool) + else + unsupported "pointer comparison with non-pointer operand" + | (CNeqOp0, C_Ast_Utils.CPtr _, _) => + if is_zero_int_const rhs then + let val b = Isa_Free ("v__isnull", @{typ bool}) + in (C_Term_Build.mk_bind (mk_ptr_is_null lhs') (Term.lambda b + (C_Term_Build.mk_literal + (Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) $ b))), + C_Ast_Utils.CBool) + end + else + unsupported "pointer comparison with non-pointer operand" + | (CNeqOp0, _, C_Ast_Utils.CPtr _) => + if is_zero_int_const lhs then + let val b = Isa_Free ("v__isnull", @{typ bool}) + in (C_Term_Build.mk_bind (mk_ptr_is_null rhs') (Term.lambda b + (C_Term_Build.mk_literal + (Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) $ b))), + C_Ast_Utils.CBool) + end + else + unsupported "pointer comparison with non-pointer operand" + | (CLeOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => + mk_ptr_relcmp \<^const_name>\c_ptr_less\ "c_ptr_less" + | (CLeqOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => + mk_ptr_relcmp \<^const_name>\c_ptr_le\ "c_ptr_le" + | (CGrOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => + mk_ptr_relcmp \<^const_name>\c_ptr_greater\ "c_ptr_greater" + | (CGeqOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => + mk_ptr_relcmp \<^const_name>\c_ptr_ge\ "c_ptr_ge" + | (CLeOp0, C_Ast_Utils.CPtr _, _) => + unsupported "pointer relational comparison with non-pointer operand" + | (CLeOp0, _, C_Ast_Utils.CPtr _) => + unsupported "pointer relational comparison with non-pointer operand" + | (CLeqOp0, C_Ast_Utils.CPtr _, _) => + unsupported "pointer relational comparison with non-pointer operand" + | (CLeqOp0, _, C_Ast_Utils.CPtr _) => + unsupported "pointer relational comparison with non-pointer operand" + | (CGrOp0, C_Ast_Utils.CPtr _, _) => + unsupported "pointer relational comparison with non-pointer operand" + | (CGrOp0, _, C_Ast_Utils.CPtr _) => + unsupported "pointer relational comparison with non-pointer operand" + | (CGeqOp0, C_Ast_Utils.CPtr _, _) => + unsupported "pointer relational comparison with non-pointer operand" + | (CGeqOp0, _, C_Ast_Utils.CPtr _) => + unsupported "pointer relational comparison with non-pointer operand" + | (CAddOp0, C_Ast_Utils.CPtr elem_cty, _) => + if uses_raw_pointer_model () andalso not (expr_is_list_backed_array tctx lhs) then + mk_raw_ptr_add lhs' rhs' rhs_cty elem_cty (is_nonnegative_int_const rhs) + else + mk_list_ptr_add lhs' rhs' rhs_cty elem_cty + | (CAddOp0, _, C_Ast_Utils.CPtr elem_cty) => + (* n + p = p + n *) + if uses_raw_pointer_model () andalso not (expr_is_list_backed_array tctx rhs) then + mk_raw_ptr_add rhs' lhs' lhs_cty elem_cty (is_nonnegative_int_const lhs) + else + mk_list_ptr_add rhs' lhs' lhs_cty elem_cty + | (CSubOp0, C_Ast_Utils.CPtr elem_cty, rhs_sub_cty) => + if not (C_Ast_Utils.is_ptr rhs_sub_cty) then + (* ptr - int: negate the integer and use pointer addition *) + let val neg_rhs = + C_Term_Build.mk_bind2 + (Isa_Const (\<^const_name>\c_signed_sub\, isa_dummyT)) + (C_Term_Build.mk_literal_num rhs_sub_cty 0) + rhs' + in + if uses_raw_pointer_model () andalso not (expr_is_list_backed_array tctx lhs) then + mk_raw_ptr_add lhs' neg_rhs rhs_sub_cty elem_cty false + else + mk_list_ptr_add lhs' neg_rhs rhs_sub_cty elem_cty + end + else + let val isa_ty = C_Ast_Utils.hol_type_of elem_cty + val itself_ty = Isa_Type (\<^type_name>\itself\, [isa_ty]) + val type_term = Isa_Const (\<^const_name>\Pure.type\, itself_ty) + val stride = Isa_Const (\<^const_name>\c_sizeof\, + itself_ty --> @{typ nat}) $ type_term + val lhs' = + (case pointer_expr_value_hol_ty lhs_cty of + SOME ty => constrain_expr_value_type ty lhs' + | NONE => lhs') + val rhs' = + (case pointer_expr_value_hol_ty rhs_cty of + SOME ty => constrain_expr_value_type ty rhs' + | NONE => rhs') + val lhs_ptr_ty = expr_value_type lhs' + val rhs_ptr_ty = expr_value_type rhs' + val diff_raw_ty = @{typ int} + val diff_value_ty = C_Ast_Utils.hol_type_of (C_Ast_Utils.pointer_int_cty ()) + val p_var = Isa_Free ("v__lptr", lhs_ptr_ty) + val q_var = Isa_Free ("v__rptr", rhs_ptr_ty) + val raw_ptr_ty = + Isa_Type (\<^type_name>\gref\, [!current_ref_addr_ty, !current_ref_gv_ty]) + fun raw_ptr_of ptr_ty ptr_var = + (case ptr_ty of + Term.Type (name, _) => + if name = \<^type_name>\focused\ + then Isa_Const (\<^const_name>\unwrap_focused\, isa_dummyT --> raw_ptr_ty) $ ptr_var + else ptr_var + | _ => ptr_var) + val p_raw = raw_ptr_of lhs_ptr_ty p_var + val q_raw = raw_ptr_of rhs_ptr_ty q_var + val diff_const = + Type.constraint (raw_ptr_ty --> raw_ptr_ty --> @{typ nat} --> diff_raw_ty) + (if uses_raw_pointer_model () then resolve_ptr_diff_const ctxt + else Isa_Const (\<^const_name>\c_ptr_diff\, isa_dummyT)) + val diff_body = + Isa_Const (\<^const_name>\of_int\, diff_raw_ty --> diff_value_ty) + $ (diff_const $ p_raw $ q_raw $ stride) + val f = Type.constraint (lhs_ptr_ty --> rhs_ptr_ty --> diff_value_ty) + (Term.lambda p_var (Term.lambda q_var diff_body)) + val diff_expr0 = C_Term_Build.mk_bindlift2 f lhs' rhs' + val diff_expr = + (case expr_type_from_tm diff_value_ty lhs' of + SOME ty => Type.constraint ty diff_expr0 + | NONE => constrain_known_expr_value_type diff_value_ty diff_expr0) + in (constrain_expr_side_types diff_expr, + C_Ast_Utils.pointer_int_cty ()) + end + | _ => + let + (* C11 integer promotion and usual arithmetic conversions. + Shifts: each operand independently promoted, result = promoted LHS. + Other ops: usual_arith_conv determines common type. *) + val is_shift = case binop of CShlOp0 => true | CShrOp0 => true | _ => false + val (cty, lhs_p, rhs_p) = + if is_shift then + let val lp_cty = C_Ast_Utils.integer_promote lhs_cty + val rp_cty = C_Ast_Utils.integer_promote rhs_cty + in (lp_cty, + mk_implicit_cast (lhs', lhs_cty, lp_cty), + mk_implicit_cast + (mk_implicit_cast (rhs', rhs_cty, rp_cty), rp_cty, lp_cty)) end + else + let val conv_cty = C_Ast_Utils.usual_arith_conv (lhs_cty, rhs_cty) + in (conv_cty, + mk_implicit_cast (lhs', lhs_cty, conv_cty), + mk_implicit_cast (rhs', rhs_cty, conv_cty)) end + (* For > and >=, swap operands to use < and <= *) + val (l, r) = case binop of CGrOp0 => (rhs_p, lhs_p) + | CGeqOp0 => (rhs_p, lhs_p) + | _ => (lhs_p, rhs_p) + (* Comparisons return CBool — they produce Isabelle bool values *) + val result_cty = case binop of + CLeOp0 => C_Ast_Utils.CBool | CLeqOp0 => C_Ast_Utils.CBool + | CGrOp0 => C_Ast_Utils.CBool | CGeqOp0 => C_Ast_Utils.CBool + | CEqOp0 => C_Ast_Utils.CBool | CNeqOp0 => C_Ast_Utils.CBool + | _ => cty + in case translate_binop cty binop of + Monadic f => + ((if unseq_operands then C_Term_Build.mk_bind2_unseq f l r + else C_Term_Build.mk_bind2 f l r), result_cty) + end) + end + (* p->field = rhs / s.field = rhs : struct/union field write *) + | translate_expr tctx (CAssign0 (CAssignOp0, CMember0 (expr, field_ident, is_ptr, _), rhs, _)) = + let val field_name = C_Ast_Utils.ident_name field_ident + val struct_name = determine_struct_type tctx expr + in if is_union_aggregate struct_name then + (* Union field write: cast to typed ref, then write *) + let val field_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of + SOME cty => cty + | NONE => unsupported ("unknown union field type: " ^ struct_name ^ "." ^ field_name)) + val ptr_expr = if is_ptr then #1 (translate_expr tctx expr) + else #1 (translate_lvalue_location tctx expr) + val (rhs', rhs_cty) = translate_expr tctx rhs + val rhs_cast = mk_implicit_cast (rhs', rhs_cty, field_cty) + val cast_expr = mk_cast_from_void_in (C_Trans_Ctxt.get_ctxt tctx) field_cty ptr_expr + val rhs_var = Isa_Free ("v__rhs", isa_dummyT) + val ref_var = Isa_Free ("v__uref", typed_ref_ty_of_cty field_cty) + val unseq_lhs_rhs = + C_Ast_Utils.expr_has_side_effect expr orelse C_Ast_Utils.expr_has_side_effect rhs + val _ = + if unseq_lhs_rhs andalso C_Ast_Utils.expr_has_unsequenced_ub_risk expr rhs then + unsupported "potential unsequenced side-effect UB in union-field assignment" + else () + val assign_fun = + Term.lambda rhs_var (Term.lambda ref_var + (C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal ref_var) + (C_Term_Build.mk_literal rhs_var)) + (C_Term_Build.mk_literal rhs_var))) + val assign_term = + (if unseq_lhs_rhs + then C_Term_Build.mk_bind2_unseq assign_fun rhs_cast cast_expr + else C_Term_Build.mk_bind2 assign_fun rhs_cast cast_expr) + in (assign_term, field_cty) end + else + let val ctxt = C_Trans_Ctxt.get_ctxt tctx + val updater_const = resolve_struct_updater_const ctxt struct_name field_name + val (ptr_expr, ptr_is_raw) = + if is_ptr then + (case expr of + CCast0 (_, inner_expr, _) => + let val (inner_ptr, inner_cty) = translate_expr tctx inner_expr + in case inner_cty of + C_Ast_Utils.CPtr C_Ast_Utils.CVoid => (inner_ptr, true) + | C_Ast_Utils.CPtr (C_Ast_Utils.CUnion _) => (inner_ptr, true) + | _ => (#1 (translate_expr tctx expr), false) + end + | _ => (#1 (translate_expr tctx expr), false)) + else + (#1 (translate_lvalue_location tctx expr), false) + val field_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of + SOME cty => cty + | NONE => unsupported ("unknown struct field type: " ^ struct_name ^ "." ^ field_name)) + val (rhs', rhs_cty) = translate_expr tctx rhs + val rhs_cast = mk_implicit_cast (rhs', rhs_cty, field_cty) + val rhs_var = Isa_Free ("v__rhs", isa_dummyT) + val ptr_var = Isa_Free ("v__ptr", isa_dummyT) + val struct_var = Isa_Free ("v__struct", isa_dummyT) + val dummy_var = Isa_Free ("_uu__", isa_dummyT) + val updated_struct = + updater_const $ (Term.lambda dummy_var rhs_var) $ struct_var + val unseq_lhs_rhs = + C_Ast_Utils.expr_has_side_effect expr orelse C_Ast_Utils.expr_has_side_effect rhs + val _ = + if unseq_lhs_rhs andalso C_Ast_Utils.expr_has_unsequenced_ub_risk expr rhs then + unsupported "potential unsequenced side-effect UB in struct-field assignment" + else () + in + if ptr_is_raw then + let + val field_loc_expr = mk_raw_struct_field_loc_expr tctx struct_name field_name field_cty ptr_expr + val ref_var = Isa_Free ("v__field_ref", typed_ref_ty_of_cty field_cty) + val assign_fun = + Term.lambda rhs_var (Term.lambda ref_var + (C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal ref_var) + (C_Term_Build.mk_literal rhs_var)) + (C_Term_Build.mk_literal rhs_var))) + val assign_term = + (if unseq_lhs_rhs + then C_Term_Build.mk_bind2_unseq assign_fun rhs_cast field_loc_expr + else C_Term_Build.mk_bind2 assign_fun rhs_cast field_loc_expr) + in (assign_term, field_cty) end + else + let + val assign_fun = + Term.lambda rhs_var (Term.lambda ptr_var + (C_Term_Build.mk_bind + (C_Term_Build.mk_deref (C_Term_Build.mk_literal ptr_var)) + (Term.lambda struct_var + (C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal ptr_var) + (C_Term_Build.mk_literal updated_struct)) + (C_Term_Build.mk_literal rhs_var))))) + val assign_term = + (if unseq_lhs_rhs + then C_Term_Build.mk_bind2_unseq assign_fun rhs_cast ptr_expr + else C_Term_Build.mk_bind2 assign_fun rhs_cast ptr_expr) + in (assign_term, field_cty) end + end end + (* p->field op= rhs / s.field op= rhs : compound struct/union field write *) + | translate_expr tctx (CAssign0 (asgn_op, CMember0 (expr, field_ident, is_ptr, _), rhs, _)) = + (case compound_assign_to_binop asgn_op of + SOME binop => + let val field_name = C_Ast_Utils.ident_name field_ident + val struct_name = determine_struct_type tctx expr + val field_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of + SOME cty => cty + | NONE => unsupported ("unknown field type: " ^ struct_name ^ "." ^ field_name)) + val (ptr_term, ptr_is_raw) = + if is_ptr then + (case expr of + CCast0 (_, inner_expr, _) => + let val (inner_ptr, inner_cty) = translate_expr tctx inner_expr + in case inner_cty of + C_Ast_Utils.CPtr C_Ast_Utils.CVoid => (inner_ptr, true) + | C_Ast_Utils.CPtr (C_Ast_Utils.CUnion _) => (inner_ptr, true) + | _ => (#1 (translate_expr tctx expr), false) + end + | _ => (#1 (translate_expr tctx expr), false)) + else + (#1 (translate_lvalue_location tctx expr), false) + val (rhs_term_raw, rhs_cty) = translate_expr tctx rhs + val op_cty = compound_op_cty field_cty rhs_cty binop + val rhs_var = Isa_Free ("v__rhs", isa_dummyT) + val old_var = Isa_Free ("v__old", isa_dummyT) + val new_var = Isa_Free ("v__new", isa_dummyT) + val unseq_lhs_rhs = + C_Ast_Utils.expr_has_side_effect expr orelse C_Ast_Utils.expr_has_side_effect rhs + val _ = + if unseq_lhs_rhs andalso C_Ast_Utils.expr_has_unsequenced_ub_risk expr rhs then + unsupported "potential unsequenced side-effect UB in field compound assignment" + else () + in if is_union_aggregate struct_name then + (* Union: cast void ptr to typed ref, deref, compute, write back *) + case translate_binop op_cty binop of + Monadic f => + let + val ref_var = Isa_Free ("v__uref", typed_ref_ty_of_cty field_cty) + val cast_expr = mk_cast_from_void_in (C_Trans_Ctxt.get_ctxt tctx) field_cty ptr_term + val combine_rhs_ref = + if unseq_lhs_rhs then C_Term_Build.mk_bind2_unseq else C_Term_Build.mk_bind2 + val assign_fun = + Term.lambda rhs_var (Term.lambda ref_var + (C_Term_Build.mk_bind + (C_Term_Build.mk_deref (C_Term_Build.mk_literal ref_var)) + (Term.lambda old_var + (let + val (_, old_prom, rhs_prom) = + prepare_compound_operands + field_cty + (C_Term_Build.mk_literal rhs_var) + rhs_cty + binop + (C_Term_Build.mk_literal old_var) + in + C_Term_Build.mk_bind + (C_Term_Build.mk_bind2 f old_prom rhs_prom) + (Term.lambda new_var + (let + val new_assigned = + mk_implicit_cast + (C_Term_Build.mk_literal new_var, op_cty, field_cty) + in + C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal ref_var) + new_assigned) + new_assigned + end)) + end)))) + val assign_term = combine_rhs_ref assign_fun rhs_term_raw cast_expr + in + (assign_term, field_cty) + end + else if ptr_is_raw then + case translate_binop op_cty binop of + Monadic f => + let + val ref_var = Isa_Free ("v__field_ref", typed_ref_ty_of_cty field_cty) + val field_loc_expr = mk_raw_struct_field_loc_expr tctx struct_name field_name field_cty ptr_term + val combine_rhs_ref = + if unseq_lhs_rhs then C_Term_Build.mk_bind2_unseq else C_Term_Build.mk_bind2 + val assign_fun = + Term.lambda rhs_var (Term.lambda ref_var + (C_Term_Build.mk_bind + (C_Term_Build.mk_deref (C_Term_Build.mk_literal ref_var)) + (Term.lambda old_var + (let + val (_, old_prom, rhs_prom) = + prepare_compound_operands + field_cty + (C_Term_Build.mk_literal rhs_var) + rhs_cty + binop + (C_Term_Build.mk_literal old_var) + in + C_Term_Build.mk_bind + (C_Term_Build.mk_bind2 f old_prom rhs_prom) + (Term.lambda new_var + (let + val new_assigned = + mk_implicit_cast + (C_Term_Build.mk_literal new_var, op_cty, field_cty) + in + C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal ref_var) + new_assigned) + new_assigned + end)) + end)))) + val assign_term = combine_rhs_ref assign_fun rhs_term_raw field_loc_expr + in + (assign_term, field_cty) + end + else + (* Struct: deref ptr, accessor/updater pattern *) + let val ctxt = C_Trans_Ctxt.get_ctxt tctx + val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name + val updater_const = resolve_struct_updater_const ctxt struct_name field_name + val ptr_var = Isa_Free ("v__ptr", isa_dummyT) + val struct_var = Isa_Free ("v__struct", isa_dummyT) + val old_val = accessor_const $ struct_var + in case translate_binop op_cty binop of + Monadic f => + let + val combine_rhs_ptr = + if unseq_lhs_rhs then C_Term_Build.mk_bind2_unseq else C_Term_Build.mk_bind2 + val assign_fun = + Term.lambda rhs_var (Term.lambda ptr_var + (C_Term_Build.mk_bind + (C_Term_Build.mk_deref (C_Term_Build.mk_literal ptr_var)) + (Term.lambda struct_var + (C_Term_Build.mk_bind + (let + val (_, old_prom, rhs_prom) = + prepare_compound_operands + field_cty + (C_Term_Build.mk_literal rhs_var) + rhs_cty + binop + (C_Term_Build.mk_literal old_val) + in + C_Term_Build.mk_bind2 f old_prom rhs_prom + end) + (Term.lambda new_var + (let + val new_assigned = + mk_implicit_cast + (C_Term_Build.mk_literal new_var, op_cty, field_cty) + val updated_struct = + updater_const + $ Term.lambda (Isa_Free ("_uu", isa_dummyT)) new_assigned + $ struct_var + in + C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal ptr_var) + (C_Term_Build.mk_literal updated_struct)) + new_assigned + end)))))) + val assign_term = combine_rhs_ptr assign_fun rhs_term_raw ptr_term + in + (assign_term, field_cty) + end + end + end + | NONE => unsupported "unsupported compound operator on struct field") + (* p->field[idx] = rhs / s.field[idx] = rhs : struct field array write *) + | translate_expr tctx (CAssign0 (CAssignOp0, + CIndex0 (CMember0 (expr, field_ident, is_ptr, _), idx_expr, _), rhs, _)) = + let val field_name = C_Ast_Utils.ident_name field_ident + val struct_name = determine_struct_type tctx expr + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name + val updater_const = resolve_struct_updater_const ctxt struct_name field_name + val deref_const = resolve_dereference_const ctxt + val ptr_expr = if is_ptr then #1 (translate_expr tctx expr) + else #1 (translate_lvalue_location tctx expr) + val (idx_term_raw, idx_cty) = translate_expr tctx idx_expr + val idx_p_cty = C_Ast_Utils.integer_promote idx_cty + val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) + val (rhs_term_raw, rhs_cty) = translate_expr tctx rhs + (* Side effects in rhs/idx/ptr are safe: the bind chain below + sequences evaluation as rhs, then ptr, then deref, then idx. *) + val ptr_var = Isa_Free ("v__ptr", isa_dummyT) + val struct_var = Isa_Free ("v__struct", isa_dummyT) + val i_var = Isa_Free ("v__idx", isa_dummyT) + val v_var = Isa_Free ("v__rhs", isa_dummyT) + val old_list = accessor_const $ struct_var + val new_list = Isa_Const (\<^const_name>\list_update\, + isa_dummyT --> isa_dummyT --> isa_dummyT --> isa_dummyT) + $ old_list $ (C_Term_Build.mk_unat i_var) $ v_var + val dummy_var = Isa_Free ("_uu__", isa_dummyT) + val new_struct = updater_const $ (Term.lambda dummy_var new_list) $ struct_var + val deref_expr = + Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ ptr_var) + $ (Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) + $ deref_const) + val field_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of + SOME (C_Ast_Utils.CPtr inner) => inner + | _ => unsupported "indexing non-array struct field") + val rhs_term = mk_implicit_cast (rhs_term_raw, rhs_cty, field_cty) + val write_term = + C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal ptr_var) + (C_Term_Build.mk_literal new_struct) + val write_term = mk_index_guard idx_p_cty i_var old_list write_term + val assign_term = + C_Term_Build.mk_bind rhs_term + (Term.lambda v_var + (C_Term_Build.mk_bind ptr_expr + (Term.lambda ptr_var + (C_Term_Build.mk_bind deref_expr + (Term.lambda struct_var + (C_Term_Build.mk_bind idx_term + (Term.lambda i_var + (C_Term_Build.mk_sequence + write_term + (C_Term_Build.mk_literal v_var))))))))) + in (assign_term, field_cty) + end + (* arr[idx] = rhs : array element write via focus *) + | translate_expr tctx (CAssign0 (CAssignOp0, CIndex0 (arr_expr, idx_expr, _), rhs, _)) = + let val (arr_term, arr_cty) = translate_expr tctx arr_expr + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val deref_const = resolve_dereference_const ctxt + val (idx_term_raw, idx_cty) = translate_expr tctx idx_expr + val idx_p_cty = C_Ast_Utils.integer_promote idx_cty + val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) + val (rhs_term_raw, rhs_cty) = translate_expr tctx rhs + val elem_cty = (case arr_cty of + C_Ast_Utils.CPtr inner => inner + | _ => unsupported "indexing non-array expression") + val elem_hol_ty = + let val t = C_Ast_Utils.hol_type_of elem_cty + in if t = isa_dummyT then isa_dummyT else t end + val a_var = Isa_Free ("v__arr", isa_dummyT) + val i_var = Isa_Free ("v__idx", isa_dummyT) + val v_var = Isa_Free ("v__rhs", elem_hol_ty) + val deref_expr = + Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ a_var) + $ (Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) + $ deref_const) + val loc_var = Isa_Free ("v__loc", isa_dummyT) + val arr_has_effect = C_Ast_Utils.expr_has_side_effect arr_expr + val idx_has_effect = C_Ast_Utils.expr_has_side_effect idx_expr + val rhs_has_effect = C_Ast_Utils.expr_has_side_effect rhs + val arr_is_global_const = + (case arr_expr of + CVar0 (ident, _) => + (case C_Trans_Ctxt.lookup_global_const tctx (C_Ast_Utils.ident_name ident) of + SOME _ => true + | NONE => false) + | _ => false) + val unseq_lhs = arr_has_effect orelse idx_has_effect + val unseq_lhs_rhs = unseq_lhs orelse rhs_has_effect + val _ = + if arr_is_global_const then + unsupported "assignment to global constant array element" + else if unseq_lhs_rhs andalso + (C_Ast_Utils.expr_has_unsequenced_ub_risk arr_expr idx_expr orelse + C_Ast_Utils.expr_has_unsequenced_ub_risk arr_expr rhs orelse + C_Ast_Utils.expr_has_unsequenced_ub_risk idx_expr rhs) + then + unsupported "potential unsequenced side-effect UB in indexed assignment" + else () + val rhs_term = mk_implicit_cast (rhs_term_raw, rhs_cty, elem_cty) + val loc_expr = + if use_raw_pointer_indexing tctx arr_expr then + mk_raw_ptr_loc_expr ctxt unseq_lhs arr_term idx_term_raw idx_cty elem_cty (is_nonnegative_int_const idx_expr) + else + let + val focused = C_Term_Build.mk_focus_nth (C_Term_Build.mk_unat i_var) a_var + in + mk_pair_eval unseq_lhs arr_term idx_term a_var i_var + (let + val list_ty = + (case C_Ast_Utils.hol_type_of elem_cty of + t => if t = isa_dummyT then isa_dummyT else Isa_Type (\<^type_name>\list\, [t])) + val list_var = Isa_Free ("v__arr_vals", list_ty) + in C_Term_Build.mk_bind deref_expr + (Term.lambda list_var (mk_index_guard idx_p_cty i_var list_var (C_Term_Build.mk_literal focused))) end) + end + val write_fun = + Term.lambda v_var (Term.lambda loc_var + (C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal loc_var) + (C_Term_Build.mk_literal v_var)) + (C_Term_Build.mk_literal v_var))) + val assign_term = + (if unseq_lhs_rhs + then C_Term_Build.mk_bind2_unseq write_fun rhs_term loc_expr + else C_Term_Build.mk_bind2 write_fun rhs_term loc_expr) + in (assign_term, elem_cty) + end + (* arr[idx] op= rhs : compound array element write *) + | translate_expr tctx (CAssign0 (asgn_op, CIndex0 (arr_expr, idx_expr, _), rhs, _)) = + (case compound_assign_to_binop asgn_op of + SOME binop => + let val (arr_term, arr_cty) = translate_expr tctx arr_expr + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val deref_const = resolve_dereference_const ctxt + val (idx_term_raw, idx_cty) = translate_expr tctx idx_expr + val idx_p_cty = C_Ast_Utils.integer_promote idx_cty + val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) + val (rhs_term_raw, rhs_cty) = translate_expr tctx rhs + val a_var = Isa_Free ("v__arr", isa_dummyT) + val i_var = Isa_Free ("v__idx", isa_dummyT) + val loc_var = Isa_Free ("v__loc", isa_dummyT) + val deref_expr = + Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ a_var) + $ (Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) + $ deref_const) + val old_var = Isa_Free ("v__old", isa_dummyT) + val rhs_var = Isa_Free ("v__rhs", isa_dummyT) + val new_var = Isa_Free ("v__new", isa_dummyT) + val arr_has_effect = C_Ast_Utils.expr_has_side_effect arr_expr + val idx_has_effect = C_Ast_Utils.expr_has_side_effect idx_expr + val rhs_has_effect = C_Ast_Utils.expr_has_side_effect rhs + val arr_is_global_const = + (case arr_expr of + CVar0 (ident, _) => + (case C_Trans_Ctxt.lookup_global_const tctx (C_Ast_Utils.ident_name ident) of + SOME _ => true + | NONE => false) + | _ => false) + val unseq_lhs = arr_has_effect orelse idx_has_effect + val unseq_lhs_rhs = unseq_lhs orelse rhs_has_effect + val _ = + if arr_is_global_const then + unsupported "compound assignment to global constant array element" + else if unseq_lhs_rhs andalso + (C_Ast_Utils.expr_has_unsequenced_ub_risk arr_expr idx_expr orelse + C_Ast_Utils.expr_has_unsequenced_ub_risk arr_expr rhs orelse + C_Ast_Utils.expr_has_unsequenced_ub_risk idx_expr rhs) + then + unsupported "potential unsequenced side-effect UB in indexed compound assignment" + else () + val focused = C_Term_Build.mk_focus_nth + (C_Term_Build.mk_unat i_var) a_var + val elem_cty = (case arr_cty of + C_Ast_Utils.CPtr inner => inner + | _ => unsupported "indexing non-array expression") + val op_cty = compound_op_cty elem_cty rhs_cty binop + val loc_expr = + if use_raw_pointer_indexing tctx arr_expr then + mk_raw_ptr_loc_expr ctxt unseq_lhs arr_term idx_term_raw idx_cty elem_cty (is_nonnegative_int_const idx_expr) + else + mk_pair_eval unseq_lhs arr_term idx_term a_var i_var + (let + val list_ty = + (case C_Ast_Utils.hol_type_of elem_cty of + t => if t = isa_dummyT then isa_dummyT else Isa_Type (\<^type_name>\list\, [t])) + val list_var = Isa_Free ("v__arr_vals", list_ty) + in C_Term_Build.mk_bind deref_expr + (Term.lambda list_var (mk_index_guard idx_p_cty i_var list_var (C_Term_Build.mk_literal focused))) end) + in case translate_binop op_cty binop of + Monadic f => + let + val combine_rhs_loc = + if unseq_lhs_rhs then C_Term_Build.mk_bind2_unseq else C_Term_Build.mk_bind2 + val assign_fun = + Term.lambda rhs_var (Term.lambda loc_var + (C_Term_Build.mk_bind + (C_Term_Build.mk_deref (C_Term_Build.mk_literal loc_var)) + (Term.lambda old_var + (let + val (_, old_prom, rhs_prom) = + prepare_compound_operands + elem_cty + (C_Term_Build.mk_literal rhs_var) + rhs_cty + binop + (C_Term_Build.mk_literal old_var) + in + C_Term_Build.mk_bind + (C_Term_Build.mk_bind2 f old_prom rhs_prom) + (Term.lambda new_var + (let + val new_assigned = + mk_implicit_cast + (C_Term_Build.mk_literal new_var, op_cty, elem_cty) + in + C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal loc_var) + new_assigned) + new_assigned + end)) + end)))) + val assign_term = combine_rhs_loc assign_fun rhs_term_raw loc_expr + in + (assign_term, elem_cty) + end + end + | NONE => unsupported "unsupported compound operator on array element") + (* C11 \
6.5.16: simple assignment — value of RHS converted to LHS type *) + | translate_expr tctx (CAssign0 (CAssignOp0, CVar0 (ident, _), rhs, _)) = + let val name = C_Ast_Utils.ident_name ident + val (rhs', rhs_cty) = translate_expr tctx rhs + val rhs_var = Isa_Free ("v__rhs", isa_dummyT) + in case C_Trans_Ctxt.lookup_var tctx name of + SOME (C_Trans_Ctxt.Local, var, cty) => + let val rhs_cast = mk_implicit_cast (rhs', rhs_cty, cty) + in (C_Term_Build.mk_bind rhs_cast (Term.lambda rhs_var + (C_Term_Build.mk_sequence + (C_Term_Build.mk_var_write var (C_Term_Build.mk_literal rhs_var)) + (C_Term_Build.mk_literal rhs_var))), + cty) + end + | SOME (C_Trans_Ctxt.LocalPtr, var, cty) => + let val rhs_cast = mk_implicit_cast (rhs', rhs_cty, cty) + val rhs_raw = mk_implicit_cast (rhs_cast, cty, C_Ast_Utils.CPtr C_Ast_Utils.CVoid) + in (C_Term_Build.mk_bind rhs_raw (Term.lambda rhs_var + (C_Term_Build.mk_sequence + (C_Term_Build.mk_var_write var (C_Term_Build.mk_literal rhs_var)) + rhs_cast)), + cty) + end + | SOME (C_Trans_Ctxt.Param, _, _) => + error ("micro_c_translate: assignment to parameter: " ^ name) + | SOME (C_Trans_Ctxt.ParamListPtr, _, _) => + error ("micro_c_translate: assignment to list-backed pointer parameter: " ^ name) + | NONE => + (case C_Trans_Ctxt.lookup_global_const tctx name of + SOME _ => + error ("micro_c_translate: assignment to global constant: " ^ name) + | NONE => + error ("micro_c_translate: undefined variable: " ^ name)) + end + | translate_expr tctx (CAssign0 (CAssignOp0, CUnary0 (CIndOp0, lhs, _), rhs, _)) = + (* *p = v : write through pointer *) + let val (lhs', lhs_cty) = translate_expr tctx lhs + val pointee_cty = (case lhs_cty of + C_Ast_Utils.CPtr inner => inner + | _ => unsupported "dereference assignment on non-pointer expression") + val (rhs', rhs_cty) = translate_expr tctx rhs + val rhs_cast = mk_implicit_cast (rhs', rhs_cty, pointee_cty) + val rhs_var = Isa_Free ("v__rhs", isa_dummyT) + val ptr_var = Isa_Free ("v__ptr", isa_dummyT) + val unseq_lhs_rhs = + C_Ast_Utils.expr_has_side_effect lhs orelse C_Ast_Utils.expr_has_side_effect rhs + val _ = + if unseq_lhs_rhs andalso C_Ast_Utils.expr_has_unsequenced_ub_risk lhs rhs then + unsupported "potential unsequenced side-effect UB in dereference assignment" + else () + val write_fun = + Term.lambda rhs_var (Term.lambda ptr_var + (C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal ptr_var) + (C_Term_Build.mk_literal rhs_var)) + (C_Term_Build.mk_literal rhs_var))) + val assign_term = + (if unseq_lhs_rhs + then C_Term_Build.mk_bind2_unseq write_fun rhs_cast lhs' + else C_Term_Build.mk_bind2 write_fun rhs_cast lhs') + in (assign_term, + pointee_cty) + end + (* *p op= rhs : compound assignment through pointer dereference *) + | translate_expr tctx (CAssign0 (asgn_op, CUnary0 (CIndOp0, ptr_expr, _), rhs, _)) = + (case compound_assign_to_binop asgn_op of + SOME binop => + let val (ptr_term, cty) = translate_expr tctx ptr_expr + val pointee_cty = (case cty of + C_Ast_Utils.CPtr inner => inner + | _ => unsupported "compound dereference assignment on non-pointer expression") + val (rhs_term_raw, rhs_cty) = translate_expr tctx rhs + val op_cty = compound_op_cty pointee_cty rhs_cty binop + val ptr_var = Isa_Free ("v__ptr", isa_dummyT) + val old_var = Isa_Free ("v__old", isa_dummyT) + val rhs_var = Isa_Free ("v__rhs", isa_dummyT) + val new_var = Isa_Free ("v__new", isa_dummyT) + val unseq_lhs_rhs = + C_Ast_Utils.expr_has_side_effect ptr_expr orelse C_Ast_Utils.expr_has_side_effect rhs + val _ = + if unseq_lhs_rhs andalso C_Ast_Utils.expr_has_unsequenced_ub_risk ptr_expr rhs then + unsupported "potential unsequenced side-effect UB in dereference compound assignment" + else () + in case translate_binop op_cty binop of + Monadic f => + let + val combine_rhs_ptr = + if unseq_lhs_rhs then C_Term_Build.mk_bind2_unseq else C_Term_Build.mk_bind2 + val assign_fun = + Term.lambda rhs_var (Term.lambda ptr_var + (C_Term_Build.mk_bind + (C_Term_Build.mk_deref (C_Term_Build.mk_literal ptr_var)) + (Term.lambda old_var + (let + val (_, old_prom, rhs_prom) = + prepare_compound_operands + pointee_cty + (C_Term_Build.mk_literal rhs_var) + rhs_cty + binop + (C_Term_Build.mk_literal old_var) + in + C_Term_Build.mk_bind + (C_Term_Build.mk_bind2 f old_prom rhs_prom) + (Term.lambda new_var + (let + val new_assigned = + mk_implicit_cast + (C_Term_Build.mk_literal new_var, op_cty, pointee_cty) + in + C_Term_Build.mk_sequence + (C_Term_Build.mk_ptr_write + (C_Term_Build.mk_literal ptr_var) + new_assigned) + new_assigned + end)) + end)))) + val assign_term = combine_rhs_ptr assign_fun rhs_term_raw ptr_term + in + (assign_term, pointee_cty) + end + end + | NONE => unsupported "unsupported operator on dereferenced pointer") + | translate_expr tctx (CAssign0 (asgn_op, CVar0 (ident, _), rhs, _)) = + (* Compound assignment: x op= rhs -> read x, compute (x op rhs), write x, return new *) + (case compound_assign_to_binop asgn_op of + SOME binop => + let val name = C_Ast_Utils.ident_name ident + val (rhs_raw, rhs_cty) = translate_expr tctx rhs + in case C_Trans_Ctxt.lookup_var tctx name of + SOME (C_Trans_Ctxt.Local, var, cty) => + let val old_var = Isa_Free ("v__old", isa_dummyT) + val new_var = Isa_Free ("v__new", isa_dummyT) + val op_cty = compound_op_cty cty rhs_cty binop + in case translate_binop op_cty binop of + Monadic f => + (C_Term_Build.mk_bind (C_Term_Build.mk_var_read var) + (Term.lambda old_var + (C_Term_Build.mk_bind + (let + val (_, old_prom, rhs_prom) = + prepare_compound_operands + cty rhs_raw rhs_cty binop + (C_Term_Build.mk_literal old_var) + in + C_Term_Build.mk_bind2 f old_prom rhs_prom + end) + (Term.lambda new_var + (let + val new_assigned = + mk_implicit_cast + (C_Term_Build.mk_literal new_var, op_cty, cty) + in + (C_Term_Build.mk_sequence + (C_Term_Build.mk_var_write var + new_assigned) + new_assigned) + end)))), cty) + end + | _ => + (case C_Trans_Ctxt.lookup_global_const tctx name of + SOME _ => unsupported ("compound assignment to global constant: " ^ name) + | NONE => unsupported "compound assignment to non-local variable") + end + | NONE => unsupported "compound assignment or non-variable lhs") + | translate_expr _ (CAssign0 _) = + unsupported "non-variable lhs in assignment" + (* C11 \
6.5.2.2: function call — arguments converted per parameter types *) + | translate_expr tctx (CCall0 (CVar0 (ident, _), args, _)) = + let val fname = C_Ast_Utils.ident_name ident + val arg_terms_typed = List.map (translate_expr tctx) args + val arg_has_effects = List.map C_Ast_Utils.expr_has_side_effect args + val any_arg_effect = List.exists I arg_has_effects + val param_ctys = C_Trans_Ctxt.lookup_func_param_types tctx fname + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val func_ref = + (case resolve_visible_const_term ctxt (!current_decl_prefix ^ fname) of + SOME fterm => SOME fterm + | NONE => + (case resolve_visible_const_term ctxt fname of + SOME fterm => SOME fterm + | NONE => + (* In locale targets, freshly declared functions may not yet + resolve as constants. If the C signature table knows this + function, synthesize a reference term and let typing/casts + constrain it. *) + (case param_ctys of + SOME _ => SOME (Isa_Free (!current_decl_prefix ^ fname, isa_dummyT)) + | NONE => NONE))) + val _ = + (case param_ctys of + SOME tys => + if List.length arg_terms_typed = List.length tys then () + else unsupported + ("function call arity mismatch for " ^ fname ^ ": expected " ^ + Int.toString (List.length tys) ^ ", got " ^ Int.toString (List.length arg_terms_typed)) + | NONE => + (case func_ref of + SOME _ => () + | NONE => + unsupported ("call to undeclared function: " ^ fname ^ + " (tried symbols: " ^ !current_decl_prefix ^ fname ^ ", " ^ fname ^ ")"))) + fun cast_args [] _ = [] + | cast_args ((arg_tm, _) :: rest) [] = arg_tm :: cast_args rest [] + | cast_args ((arg_tm, arg_cty) :: rest) (p_cty :: p_rest) = + mk_implicit_cast (arg_tm, arg_cty, p_cty) :: cast_args rest p_rest + val arg_terms = + (case param_ctys of + SOME tys => cast_args arg_terms_typed tys + | NONE => List.map #1 arg_terms_typed) + |> List.map constrain_expr_side_types + val argc = List.length arg_terms + (* For arity > 2 with side-effecting arguments: funcallN sequences + evaluation left-to-right via bindN, which is a valid ordering for + C's unspecified argument evaluation order. We warn if multiple + arguments have side effects (potential for unsequenced UB), but + allow it when at most one argument is side-effecting. *) + val effect_count = List.length (List.filter I arg_has_effects) + val _ = + if argc > 2 andalso effect_count > 1 then + unsupported ("call to " ^ fname ^ + " has multiple side-effecting arguments with unspecified C evaluation order (arity > 2)") + else () + val _ = + if argc = 2 andalso any_arg_effect andalso + C_Ast_Utils.expr_has_unsequenced_ub_risk (List.nth (args, 0)) (List.nth (args, 1)) + then + unsupported ("call to " ^ fname ^ + " has potential unsequenced side-effect UB across arguments") + else () + in + (case func_ref of + SOME fref => + let + (* Look up callee's fuel parameter count and generate fresh + while_fuel free variables to pass as leading arguments. + These will be picked up by the caller's fuel abstraction + (String.isPrefix "while_fuel" in translate_fundef). *) + val callee_full = !current_decl_prefix ^ fname + val fuel_count = + (case Symtab.lookup (!defined_func_fuels) callee_full of + SOME n => n | NONE => 0) + val fuel_args = List.tabulate (fuel_count, fn i => + Isa_Free ("while_fuel_" ^ fname ^ + (if fuel_count = 1 then "" else "_" ^ Int.toString i), + @{typ nat})) + (* Partial-apply fuel args to fref: fuel params are pure nat + values, not monadic expressions, so they must be applied + directly rather than passed through funcallN. *) + val fref_fueled = List.foldl (fn (a, f) => f $ a) fref fuel_args + val ret_value_ty = + (case C_Trans_Ctxt.lookup_func_return_type tctx fname of + SOME C_Ast_Utils.CVoid => @{typ unit} + | SOME rcty => + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) rcty of + SOME ty => ty + | NONE => isa_dummyT) + | NONE => isa_dummyT) + val fref_called = + if argc = 0 then fref_fueled + else + let + val arg_tys = List.map expr_value_type arg_terms + (* Pin the return type to function_body with the + locale's side types so funcall's shared type + variables unify across function and arguments. + Use TVars (not TFrees) so names from + current_ref_expr_constraint unify with the + potentially-renamed TFrees of locale params. *) + val fn_result_ty = + if ret_value_ty = isa_dummyT then isa_dummyT + else Isa_Type (\<^type_name>\function_body\, + [isa_dummyT, ret_value_ty, @{typ c_abort}, + isa_dummyT, isa_dummyT]) + val fn_ty = Library.foldr (fn (a_ty, acc_ty) => a_ty --> acc_ty) + (arg_tys, fn_result_ty) + in + Type.constraint fn_ty fref_fueled + end + val call_term = + if argc = 2 andalso any_arg_effect then + let val call2 = + Isa_Const (\<^const_name>\deep_compose2\, dummyT --> dummyT --> dummyT) + $ Isa_Const (\<^const_name>\call\, dummyT --> dummyT) + $ fref_called + in C_Term_Build.mk_bind2_unseq call2 (List.nth (arg_terms, 0)) (List.nth (arg_terms, 1)) end + else + C_Term_Build.mk_funcall fref_called arg_terms + val call_term = + if ret_value_ty = isa_dummyT then call_term + else constrain_known_expr_value_type ret_value_ty call_term + val call_term = constrain_expr_side_types call_term + val ret_cty = + (case C_Trans_Ctxt.lookup_func_return_type tctx fname of + SOME cty => cty + | NONE => + (case cty_of_hol_type (expr_value_type call_term) of + SOME cty => cty + | NONE => C_Ast_Utils.CInt)) + in (call_term, ret_cty) end + | NONE => + unsupported ("call to undeclared function: " ^ fname ^ + " (tried symbols: " ^ !current_decl_prefix ^ fname ^ ", " ^ fname ^ ")")) + end + | translate_expr _ (CCall0 _) = + unsupported "indirect function call (function pointers)" + | translate_expr tctx (CUnary0 (CAdrOp0, expr, _)) = + translate_lvalue_location tctx expr + | translate_expr tctx (CUnary0 (CIndOp0, expr, _)) = + (* *p : dereference pointer. Resolve dereference_fun from locale context + to avoid adhoc overloading ambiguity (same as CIndex0 reads). + If the inner expression has CPtr ty, unwrap to ty. *) + let val (expr', cty) = translate_expr tctx expr + val result_cty = (case cty of + C_Ast_Utils.CPtr C_Ast_Utils.CVoid => + unsupported "dereference of void pointer (cast first)" + | C_Ast_Utils.CPtr inner => inner + | _ => unsupported "dereference on non-pointer expression") + val ctxt = C_Trans_Ctxt.get_ctxt tctx + in (mk_resolved_deref_expr ctxt result_cty expr', result_cty) end + (* C11 \
6.5.3.3p4: bitwise complement — operand undergoes integer promotion *) + | translate_expr tctx (CUnary0 (CCompOp0, expr, _)) = + let val (expr', cty) = translate_expr tctx expr + val pcty = C_Ast_Utils.integer_promote cty + val promoted = mk_implicit_cast (expr', cty, pcty) + val not_const = + if C_Ast_Utils.is_signed pcty + then Isa_Const (\<^const_name>\c_signed_not\, isa_dummyT) + else Isa_Const (\<^const_name>\c_unsigned_not\, isa_dummyT) + val v = Isa_Free ("v__comp", isa_dummyT) + in (C_Term_Build.mk_bind promoted (Term.lambda v (not_const $ v)), pcty) end + (* C11 \
6.5.3.3p3: unary minus — operand undergoes integer promotion *) + | translate_expr tctx (CUnary0 (CMinOp0, expr, _)) = + let val (expr', cty) = translate_expr tctx expr + val pcty = C_Ast_Utils.integer_promote cty + val promoted = mk_implicit_cast (expr', cty, pcty) + val zero = C_Term_Build.mk_literal_num pcty 0 + val sub_const = + if C_Ast_Utils.is_signed pcty + then Isa_Const (\<^const_name>\c_signed_sub\, isa_dummyT) + else Isa_Const (\<^const_name>\c_unsigned_sub\, isa_dummyT) + in (C_Term_Build.mk_bind2 sub_const zero promoted, pcty) end + (* C11 \
6.5.3.1: prefix increment/decrement *) + | translate_expr tctx (CUnary0 (CPreIncOp0, expr, _)) = + translate_inc_dec translate_expr translate_lvalue_location tctx true true expr + (* C11 \
6.5.2.4: postfix increment/decrement *) + | translate_expr tctx (CUnary0 (CPostIncOp0, expr, _)) = + translate_inc_dec translate_expr translate_lvalue_location tctx true false expr + | translate_expr tctx (CUnary0 (CPreDecOp0, expr, _)) = + translate_inc_dec translate_expr translate_lvalue_location tctx false true expr + | translate_expr tctx (CUnary0 (CPostDecOp0, expr, _)) = + translate_inc_dec translate_expr translate_lvalue_location tctx false false expr + (* C11 \
6.5.3.3p2: unary plus — operand undergoes integer promotion *) + | translate_expr tctx (CUnary0 (CPlusOp0, expr, _)) = + let val (expr', cty) = translate_expr tctx expr + val pcty = C_Ast_Utils.integer_promote cty + in (mk_implicit_cast (expr', cty, pcty), pcty) end + (* C11 \
6.5.3.3p5: logical NOT — result is 0 if operand is nonzero, 1 if zero *) + | translate_expr tctx (CUnary0 (CNegOp0, expr, _)) = + let val (expr', cty) = translate_expr tctx expr + val b = mk_implicit_cast (expr', cty, C_Ast_Utils.CBool) + val v = Isa_Free ("v__neg", @{typ bool}) + in (C_Term_Build.mk_bind b + (Term.lambda v + (C_Term_Build.mk_literal + (Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) $ v))), + C_Ast_Utils.CBool) + end + (* p->field[idx] / s.field[idx] : struct field (list) read, then index with nth. + Uses resolved dereference_fun to avoid store_dereference_const adhoc overloading. *) + | translate_expr tctx (CIndex0 (CMember0 (expr, field_ident, is_ptr, _), idx_expr, _)) = + let val field_name = C_Ast_Utils.ident_name field_ident + val struct_name = determine_struct_type tctx expr + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name + val deref_const = resolve_dereference_const ctxt + val ptr_expr = if is_ptr then #1 (translate_expr tctx expr) + else #1 (translate_lvalue_location tctx expr) + val (idx_term_raw, idx_cty) = translate_expr tctx idx_expr + val idx_p_cty = C_Ast_Utils.integer_promote idx_cty + val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) + val unseq_index = + C_Ast_Utils.expr_has_side_effect expr orelse C_Ast_Utils.expr_has_side_effect idx_expr + val _ = + if unseq_index andalso C_Ast_Utils.expr_has_unsequenced_ub_risk expr idx_expr then + unsupported "potential unsequenced side-effect UB in indexed access" + else () + val ptr_var = Isa_Free ("v__ptr", isa_dummyT) + val struct_var = Isa_Free ("v__struct", isa_dummyT) + val i_var = Isa_Free ("v__idx", isa_dummyT) + val list_val = accessor_const $ struct_var + val nth_term = Isa_Const (\<^const_name>\nth\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ list_val $ (C_Term_Build.mk_unat i_var) + val deref_expr = + Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ ptr_var) + $ (Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) + $ deref_const) + val elem_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of + SOME (C_Ast_Utils.CPtr inner) => inner + | SOME inner => + if struct_field_is_array_backed struct_name field_name then inner + else unsupported "indexing non-array struct field" + | NONE => unsupported "indexing unknown struct field") + val value_term = C_Term_Build.mk_literal nth_term + val value_term = mk_index_guard idx_p_cty i_var list_val value_term + in (mk_pair_eval unseq_index ptr_expr idx_term ptr_var i_var + (C_Term_Build.mk_bind deref_expr (Term.lambda struct_var value_term)), + elem_cty) + end + (* arr[idx] : deref whole list, then index with nth. + We resolve dereference_fun from the locale context instead of using + store_dereference_const, which has ambiguous adhoc overloading + (dereference_fun vs ro_dereference_fun) for read-only references. *) + | translate_expr tctx (CIndex0 (arr_expr, idx_expr, _)) = + let val (arr_term, arr_cty) = translate_expr tctx arr_expr + val (idx_term_raw, idx_cty) = translate_expr tctx idx_expr + val idx_p_cty = C_Ast_Utils.integer_promote idx_cty + val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) + val unseq_index = + C_Ast_Utils.expr_has_side_effect arr_expr orelse C_Ast_Utils.expr_has_side_effect idx_expr + val _ = + if unseq_index andalso C_Ast_Utils.expr_has_unsequenced_ub_risk arr_expr idx_expr then + unsupported "potential unsequenced side-effect UB in indexed access" + else () + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val deref_const = resolve_dereference_const ctxt + val elem_cty = + (case arr_cty of + C_Ast_Utils.CPtr inner => inner + | _ => unsupported "indexing non-array expression") + val a_var = Isa_Free ("v__arr", isa_dummyT) + val i_var = Isa_Free ("v__idx", isa_dummyT) + val list_elem_ty = + (case arr_cty of + C_Ast_Utils.CPtr inner => + (case C_Ast_Utils.hol_type_of inner of + t => if t = isa_dummyT then isa_dummyT + else Isa_Type (\<^type_name>\list\, [t])) + | _ => isa_dummyT) + val list_var = Isa_Free ("v__list", list_elem_ty) + val nth_term = Isa_Const (\<^const_name>\nth\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ list_var $ (C_Term_Build.mk_unat i_var) + val deref_expr = + Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ a_var) + $ (Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) + $ deref_const) + val arr_is_global_const = + (case arr_expr of + CVar0 (ident, _) => + (case C_Trans_Ctxt.lookup_global_const tctx (C_Ast_Utils.ident_name ident) of + SOME _ => true + | NONE => false) + | _ => false) + val value_term = C_Term_Build.mk_literal nth_term + val value_term = mk_index_guard idx_p_cty i_var list_var value_term + fun is_nested_index (CIndex0 _) = true + | is_nested_index _ = false + in + if is_nested_index arr_expr then + (* Nested index: arr is a value (sub-list from outer index), not a ref. + Just apply nth directly without dereferencing. *) + (mk_pair_eval unseq_index arr_term idx_term a_var i_var + (let + val direct_nth = + Isa_Const (\<^const_name>\nth\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ a_var $ (C_Term_Build.mk_unat i_var) + val direct_term = C_Term_Build.mk_literal direct_nth + val direct_term = mk_index_guard idx_p_cty i_var a_var direct_term + in direct_term end), + elem_cty) + else if use_raw_pointer_indexing tctx arr_expr then + let + val loc_expr = mk_raw_ptr_loc_expr ctxt unseq_index arr_term idx_term_raw idx_cty elem_cty (is_nonnegative_int_const idx_expr) + val deref_loc = + Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ loc_expr + $ (Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) + $ deref_const) + in + (deref_loc, elem_cty) + end + else + (mk_pair_eval unseq_index arr_term idx_term a_var i_var + (if arr_is_global_const then + let + val direct_nth = + Isa_Const (\<^const_name>\nth\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ a_var $ (C_Term_Build.mk_unat i_var) + val direct_term = C_Term_Build.mk_literal direct_nth + val direct_term = mk_index_guard idx_p_cty i_var a_var direct_term + in direct_term end + else + C_Term_Build.mk_bind deref_expr (Term.lambda list_var value_term)), + elem_cty) + end + (* p->field : struct/union field access through pointer. + For unions: cast to typed ref, then dereference. + For array fields (CPtr inner): array-to-pointer decay — create a focused + reference to the field rather than reading the value. + For scalar fields: dereference and read the value. *) + | translate_expr tctx (CMember0 (expr, field_ident, true, ni)) = + let val field_name = C_Ast_Utils.ident_name field_ident + val struct_name = determine_struct_type tctx expr + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val (ptr_expr, ptr_cty, ptr_is_raw) = + (case expr of + CCast0 (_, inner_expr, _) => + let val (inner_ptr, inner_cty) = translate_expr tctx inner_expr + in case inner_cty of + C_Ast_Utils.CPtr C_Ast_Utils.CVoid => (inner_ptr, inner_cty, true) + | C_Ast_Utils.CPtr (C_Ast_Utils.CUnion _) => (inner_ptr, inner_cty, true) + | _ => let val (ptr_expr, ptr_cty) = translate_expr tctx expr + in (ptr_expr, ptr_cty, false) end + end + | _ => let val (ptr_expr, ptr_cty) = translate_expr tctx expr + in (ptr_expr, ptr_cty, false) end) + val field_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of + SOME cty => cty + | NONE => unsupported ("unknown struct field type: " ^ struct_name ^ "." ^ field_name)) + val array_backed_field = struct_field_is_array_backed struct_name field_name + in if array_backed_field andalso not (is_union_aggregate struct_name) then + let val (loc_expr, _) = translate_lvalue_location tctx (CMember0 (expr, field_ident, true, ni)) + in (constrain_expr_side_types loc_expr, C_Ast_Utils.CPtr field_cty) end + else if is_union_aggregate struct_name then + (* Union field read: cast to typed ref, then dereference *) + let val cast_expr = mk_cast_from_void_in ctxt field_cty ptr_expr + val v = Isa_Free ("v__uref", typed_ref_ty_of_cty field_cty) + in (C_Term_Build.mk_bind cast_expr + (Term.lambda v (mk_resolved_deref_expr ctxt field_cty (C_Term_Build.mk_literal v))), + field_cty) end + else if ptr_is_raw then + let + val loc_expr = mk_raw_struct_field_loc_expr tctx struct_name field_name field_cty ptr_expr + val loc_ty = expr_value_type loc_expr + val loc_var = Isa_Free ("v__field_loc", if loc_ty = isa_dummyT then isa_dummyT else loc_ty) + in case field_cty of + C_Ast_Utils.CPtr _ => (constrain_expr_side_types loc_expr, field_cty) + | _ => (C_Term_Build.mk_bind loc_expr + (Term.lambda loc_var (mk_resolved_deref_expr ctxt field_cty (C_Term_Build.mk_literal loc_var))), + field_cty) + end + else + let + val _ = (case ptr_cty of + C_Ast_Utils.CPtr _ => () + | _ => unsupported "member access through non-pointer expression") + val focus_const = resolve_struct_focus_const ctxt struct_name field_name + val base_ty = expr_value_type ptr_expr + val base_var = Isa_Free ("v__base_loc", if base_ty = isa_dummyT then isa_dummyT else base_ty) + val focused = C_Term_Build.mk_focus_field focus_const base_var + val loc_expr = + C_Term_Build.mk_bind ptr_expr (Term.lambda base_var (C_Term_Build.mk_literal focused)) + val loc_ty = expr_value_type loc_expr + val loc_var = Isa_Free ("v__field_loc", if loc_ty = isa_dummyT then isa_dummyT else loc_ty) + in case field_cty of + C_Ast_Utils.CPtr _ => (constrain_expr_side_types loc_expr, field_cty) + | _ => (C_Term_Build.mk_bind loc_expr + (Term.lambda loc_var (mk_resolved_deref_expr ctxt field_cty (C_Term_Build.mk_literal loc_var))), + field_cty) + end + end + (* s.field : direct struct/union member access via value *) + | translate_expr tctx (CMember0 (expr, field_ident, false, ni)) = + let val field_name = C_Ast_Utils.ident_name field_ident + val struct_name = determine_struct_type tctx expr + val field_cty = (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of + SOME cty => cty + | NONE => unsupported ("unknown field type: " ^ struct_name ^ "." ^ field_name)) + val array_backed_field = struct_field_is_array_backed struct_name field_name + in if array_backed_field andalso not (is_union_aggregate struct_name) then + let val (loc_expr, _) = translate_lvalue_location tctx (CMember0 (expr, field_ident, false, ni)) + in (constrain_expr_side_types loc_expr, C_Ast_Utils.CPtr field_cty) end + else if is_union_aggregate struct_name then + (* Union: get lvalue location of s, cast void ref to typed ref, deref *) + let val (loc_expr, _) = translate_lvalue_location tctx expr + val cast_expr = mk_cast_from_void_in (C_Trans_Ctxt.get_ctxt tctx) field_cty loc_expr + val v = Isa_Free ("v__uref", typed_ref_ty_of_cty field_cty) + in (C_Term_Build.mk_bind cast_expr + (Term.lambda v (mk_resolved_deref_expr (C_Trans_Ctxt.get_ctxt tctx) field_cty + (C_Term_Build.mk_literal v))), + field_cty) end + else + let val ctxt = C_Trans_Ctxt.get_ctxt tctx + val accessor_const = resolve_struct_accessor_const ctxt struct_name field_name + val (struct_expr, _) = translate_expr tctx expr + val v = Isa_Free ("v__struct", isa_dummyT) + in (constrain_expr_cty field_cty + (C_Term_Build.mk_bind struct_expr + (Term.lambda v (C_Term_Build.mk_literal (accessor_const $ v)))), + field_cty) end + end + (* C11 \
6.5.15: conditional operator (ternary) *) + | translate_expr tctx (CCond0 (cond, Some then_expr, else_expr, _)) = + let val (then', then_cty) = translate_expr tctx then_expr + val (else', else_cty) = translate_expr tctx else_expr + val result_cty = + if then_cty = else_cty then then_cty + else if C_Ast_Utils.is_ptr then_cty andalso C_Ast_Utils.is_ptr else_cty + then (* Both pointer types: allow void* \ T* coercion *) + (case (then_cty, else_cty) of + (_, C_Ast_Utils.CPtr C_Ast_Utils.CVoid) => then_cty + | (C_Ast_Utils.CPtr C_Ast_Utils.CVoid, _) => else_cty + | _ => unsupported "ternary with incompatible pointer types") + else if C_Ast_Utils.is_ptr then_cty orelse C_Ast_Utils.is_ptr else_cty + then (* C11 \
6.5.15p6: pointer with null pointer constant (integer 0) *) + if C_Ast_Utils.is_ptr then_cty andalso is_zero_int_const else_expr then then_cty + else if C_Ast_Utils.is_ptr else_cty andalso is_zero_int_const then_expr then else_cty + else unsupported "ternary mixing pointer with non-null integer (C11 \
6.5.15p3 constraint violation)" + else C_Ast_Utils.usual_arith_conv (then_cty, else_cty) + val then_cast = mk_implicit_cast (then', then_cty, result_cty) + val else_cast = mk_implicit_cast (else', else_cty, result_cty) + in (C_Term_Build.mk_two_armed_cond (ensure_bool_cond tctx cond) then_cast else_cast, result_cty) end + | translate_expr tctx (CCond0 (cond, None, else_expr, _)) = + (* GNU extension: x ?: y means x ? x : y *) + let val (cond_term, cond_cty) = translate_expr tctx cond + val (else', else_cty) = translate_expr tctx else_expr + val result_cty = + if cond_cty = else_cty then cond_cty + else if C_Ast_Utils.is_ptr cond_cty andalso C_Ast_Utils.is_ptr else_cty + then (case (cond_cty, else_cty) of + (_, C_Ast_Utils.CPtr C_Ast_Utils.CVoid) => cond_cty + | (C_Ast_Utils.CPtr C_Ast_Utils.CVoid, _) => else_cty + | _ => unsupported "GNU ?: with incompatible pointer types") + else if C_Ast_Utils.is_ptr cond_cty orelse C_Ast_Utils.is_ptr else_cty + then (* C11 \
6.5.15p6: pointer with null pointer constant *) + if C_Ast_Utils.is_ptr cond_cty andalso is_zero_int_const else_expr then cond_cty + else if C_Ast_Utils.is_ptr else_cty andalso is_zero_int_const cond then else_cty + else unsupported "GNU ?: mixing pointer with non-null integer" + else C_Ast_Utils.usual_arith_conv (cond_cty, else_cty) + val cond_v = Isa_Free ("v__condv", isa_dummyT) + val cond_bool = mk_implicit_cast (C_Term_Build.mk_literal cond_v, cond_cty, C_Ast_Utils.CBool) + val then_cast = mk_implicit_cast (C_Term_Build.mk_literal cond_v, cond_cty, result_cty) + val else_cast = mk_implicit_cast (else', else_cty, result_cty) + in (C_Term_Build.mk_bind cond_term + (Term.lambda cond_v + (C_Term_Build.mk_two_armed_cond cond_bool then_cast else_cast)), + result_cty) + end + (* C11 \
6.4.4.4p10: character constants have type int *) + | translate_expr _ (CConst0 (CCharConst0 (CChar0 (c, _), _))) = + (C_Term_Build.mk_literal_num C_Ast_Utils.CInt + (intinf_to_int_checked "character literal" (integer_of_char c)), + C_Ast_Utils.CInt) + | translate_expr _ (CConst0 (CCharConst0 (CChars0 _, _))) = + unsupported "multi-character constant (implementation-defined in C)" + (* C11 \
6.4.5: string literals — produce a c_char list with null terminator *) + | translate_expr _ (CConst0 (CStrConst0 (CString0 (abr_str, _), _))) = + let val s = C_Ast_Utils.abr_string_to_string abr_str + val char_ty = C_Ast_Utils.hol_type_of C_Ast_Utils.CChar + val bytes = List.map (fn c => HOLogic.mk_number char_ty (Char.ord c)) + (String.explode s) + val with_null = bytes @ [HOLogic.mk_number char_ty 0] + val list_term = HOLogic.mk_list char_ty with_null + in (C_Term_Build.mk_literal list_term, C_Ast_Utils.CPtr C_Ast_Utils.CChar) + end + (* C11 \
6.5.17: comma operator — evaluates left-to-right, result is last *) + | translate_expr _ (CComma0 ([], _)) = + (C_Term_Build.mk_literal_unit, C_Ast_Utils.CInt) + | translate_expr tctx (CComma0 (exprs, _)) = + let val translated = List.map (translate_expr tctx) exprs + fun fold_comma [] = error "micro_c_translate: empty comma expression" + | fold_comma [(e, ty)] = (e, ty) + | fold_comma ((e, _) :: rest) = + let val (rest_e, rest_ty) = fold_comma rest + in (C_Term_Build.mk_sequence e rest_e, rest_ty) end + in fold_comma translated end + (* C11 \
6.5.4: cast expression — explicit type conversion *) + | translate_expr tctx (CCast0 (target_decl, source_expr, _)) = + let val (source_term, source_cty) = translate_expr tctx source_expr + val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx + val target_cty = + (case target_decl of + CDecl0 (specs, declrs, _) => + let val struct_names = C_Trans_Ctxt.get_struct_names tctx + val base_cty = + (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME ct => SOME ct + | NONE => + (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of + SOME sn => SOME (C_Ast_Utils.CStruct sn) + | NONE => + (case C_Ast_Utils.extract_union_type_from_specs_full (!current_union_names) specs of + SOME un => SOME (C_Ast_Utils.CUnion un) + | NONE => NONE))) + val ptr_depth = + List.mapPartial + (fn ((Some declr, _), _) => SOME (C_Ast_Utils.pointer_depth_of_declr declr) + | _ => NONE) declrs + |> (fn d :: _ => d | [] => 0) + in case base_cty of + SOME ct => C_Ast_Utils.apply_ptr_depth ct ptr_depth + | NONE => unsupported "cast to non-numeric type" + end + | _ => unsupported "cast to non-numeric type") + in (mk_implicit_cast (source_term, source_cty, target_cty), target_cty) + end + (* C11 \
6.5.3.4: sizeof operator — yields the size in bytes *) + | translate_expr tctx (CSizeofType0 (decl, _)) = + let val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx + val cty = + (case decl of + CDecl0 (specs, declrs, _) => + let val struct_names = C_Trans_Ctxt.get_struct_names tctx + val base_cty = + (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME ct => SOME ct + | NONE => + (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of + SOME sn => SOME (C_Ast_Utils.CStruct sn) + | NONE => + (case C_Ast_Utils.extract_union_type_from_specs_full (!current_union_names) specs of + SOME un => SOME (C_Ast_Utils.CUnion un) + | NONE => NONE))) + val ptr_depth = + List.mapPartial + (fn ((Some declr, _), _) => SOME (C_Ast_Utils.pointer_depth_of_declr declr) + | _ => NONE) declrs + |> (fn d :: _ => d | [] => 0) + in case base_cty of + SOME ct => C_Ast_Utils.apply_ptr_depth ct ptr_depth + | NONE => unsupported "sizeof non-numeric type" + end + | _ => unsupported "sizeof non-numeric type") + val size_cty = C_Ast_Utils.pointer_uint_cty () + val word_ty = C_Ast_Utils.hol_type_of size_cty + val sizeof_term = + (case cty of + C_Ast_Utils.CStruct sn => + let val fields = + (case C_Trans_Ctxt.get_struct_fields tctx sn of + SOME fs => fs + | NONE => error ("micro_c_translate: sizeof: unknown struct: " ^ sn)) + val sz = sizeof_struct fields + in Isa_Const (\<^const_name>\of_nat\, @{typ nat} --> word_ty) $ HOLogic.mk_nat sz end + | C_Ast_Utils.CPtr _ => + let val bytes = C_Ast_Utils.sizeof_c_type cty + in Isa_Const (\<^const_name>\of_nat\, @{typ nat} --> word_ty) $ HOLogic.mk_nat bytes end + | _ => + let val isa_ty = C_Ast_Utils.hol_type_of cty + val itself_ty = Isa_Type (\<^type_name>\itself\, [isa_ty]) + val type_term = Isa_Const (\<^const_name>\Pure.type\, itself_ty) + val sizeof_nat = Isa_Const (\<^const_name>\c_sizeof\, + itself_ty --> @{typ nat}) $ type_term + in Isa_Const (\<^const_name>\of_nat\, @{typ nat} --> word_ty) $ sizeof_nat end) + in (C_Term_Build.mk_literal sizeof_term, size_cty) end + (* sizeof(expr) *) + | translate_expr tctx (CSizeofExpr0 (expr, _)) = + let fun sizeof_nat_term cty = + let val isa_ty = C_Ast_Utils.hol_type_of cty + val itself_ty = Isa_Type (\<^type_name>\itself\, [isa_ty]) + val type_term = Isa_Const (\<^const_name>\Pure.type\, itself_ty) + in Isa_Const (\<^const_name>\c_sizeof\, itself_ty --> @{typ nat}) $ type_term end + fun sizeof_nat_for_cty (C_Ast_Utils.CStruct sn) = + let val fields = + (case C_Trans_Ctxt.get_struct_fields tctx sn of + SOME fs => fs + | NONE => error ("micro_c_translate: sizeof: unknown struct: " ^ sn)) + in HOLogic.mk_nat (sizeof_struct fields) end + | sizeof_nat_for_cty (C_Ast_Utils.CPtr ptr_cty) = + HOLogic.mk_nat (C_Ast_Utils.sizeof_c_type (C_Ast_Utils.CPtr ptr_cty)) + | sizeof_nat_for_cty cty = sizeof_nat_term cty + val sizeof_nat = + (case expr of + CVar0 (ident, _) => + let val name = C_Ast_Utils.ident_name ident + in case C_Trans_Ctxt.lookup_array_decl tctx name of + SOME (elem_cty, n) => + Isa_Const (\<^const_name>\Groups.times_class.times\, @{typ nat} --> @{typ nat} --> @{typ nat}) + $ HOLogic.mk_nat n + $ sizeof_nat_for_cty elem_cty + | NONE => + let val (_, cty) = translate_expr tctx expr + in sizeof_nat_for_cty cty end + end + | _ => + let val (_, cty) = translate_expr tctx expr + in sizeof_nat_for_cty cty end) + val size_cty = C_Ast_Utils.pointer_uint_cty () + val word_ty = C_Ast_Utils.hol_type_of size_cty + val sizeof_term = Isa_Const (\<^const_name>\of_nat\, + @{typ nat} --> word_ty) $ sizeof_nat + in (C_Term_Build.mk_literal sizeof_term, size_cty) end + | translate_expr tctx (CAlignofType0 (decl, _)) = + let val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx + val cty = + (case decl of + CDecl0 (specs, declrs, _) => + let val struct_names = C_Trans_Ctxt.get_struct_names tctx + val base_cty = + (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME ct => SOME ct + | NONE => + (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of + SOME sn => SOME (C_Ast_Utils.CStruct sn) + | NONE => NONE)) + val ptr_depth = + List.mapPartial + (fn ((Some declr, _), _) => SOME (C_Ast_Utils.pointer_depth_of_declr declr) + | _ => NONE) declrs + |> (fn d :: _ => d | [] => 0) + in case base_cty of + SOME ct => C_Ast_Utils.apply_ptr_depth ct ptr_depth + | NONE => unsupported "_Alignof non-numeric type" + end + | _ => unsupported "_Alignof non-numeric type") + val isa_ty = C_Ast_Utils.hol_type_of cty + val itself_ty = Isa_Type (\<^type_name>\itself\, [isa_ty]) + val type_term = Isa_Const (\<^const_name>\Pure.type\, itself_ty) + val alignof_nat = Isa_Const (\<^const_name>\c_alignof\, + itself_ty --> @{typ nat}) $ type_term + val size_cty = C_Ast_Utils.pointer_uint_cty () + val word_ty = C_Ast_Utils.hol_type_of size_cty + val alignof_term = Isa_Const (\<^const_name>\of_nat\, + @{typ nat} --> word_ty) $ alignof_nat + in (C_Term_Build.mk_literal alignof_term, size_cty) end + | translate_expr tctx (CAlignofExpr0 (expr, _)) = + let val (_, cty) = translate_expr tctx expr + val isa_ty = C_Ast_Utils.hol_type_of cty + val itself_ty = Isa_Type (\<^type_name>\itself\, [isa_ty]) + val type_term = Isa_Const (\<^const_name>\Pure.type\, itself_ty) + val alignof_nat = Isa_Const (\<^const_name>\c_alignof\, + itself_ty --> @{typ nat}) $ type_term + val size_cty = C_Ast_Utils.pointer_uint_cty () + val word_ty = C_Ast_Utils.hol_type_of size_cty + val alignof_term = Isa_Const (\<^const_name>\of_nat\, + @{typ nat} --> word_ty) $ alignof_nat + in (C_Term_Build.mk_literal alignof_term, size_cty) end + (* Compound literal: (type){init_list} *) + | translate_expr tctx (CCompoundLit0 (decl, init_list, _)) = + let val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx + val cty = + (case decl of + CDecl0 (specs, declrs, _) => + let val struct_names = C_Trans_Ctxt.get_struct_names tctx + val base_cty = + (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME ct => SOME ct + | NONE => + (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of + SOME sn => SOME (C_Ast_Utils.CStruct sn) + | NONE => NONE)) + val ptr_depth = + List.mapPartial + (fn ((Some declr, _), _) => SOME (C_Ast_Utils.pointer_depth_of_declr declr) + | _ => NONE) declrs + |> (fn d :: _ => d | [] => 0) + in case base_cty of + SOME ct => C_Ast_Utils.apply_ptr_depth ct ptr_depth + | NONE => unsupported "compound literal with unsupported type" + end + | _ => unsupported "compound literal with unsupported declaration") + in case (cty, init_list) of + (_, [([], CInitExpr0 (expr, _))]) => + (* Scalar compound literal: (type){value} *) + let val (expr_term, expr_cty) = translate_expr tctx expr + in (mk_implicit_cast (expr_term, expr_cty, cty), cty) end + | (C_Ast_Utils.CStruct struct_name, _) => + (* Struct compound literal: (struct T){field1, field2, ...} *) + let val fields = + (case C_Trans_Ctxt.get_struct_fields tctx struct_name of + SOME fs => fs + | NONE => error ("micro_c_translate: unknown struct: " ^ struct_name)) + fun find_field_index _ [] _ = + error "micro_c_translate: struct field not found in compound literal" + | find_field_index fname ((n, _) :: rest) i = + if n = fname then i + else find_field_index fname rest (i + 1) + fun resolve_field_desig [] pos = pos + | resolve_field_desig [CMemberDesig0 (ident, _)] _ = + find_field_index (C_Ast_Utils.ident_name ident) fields 0 + | resolve_field_desig _ _ = + unsupported "complex designator in struct compound literal" + fun collect_field_items [] _ = [] + | collect_field_items ((desigs, CInitExpr0 (e, _)) :: rest) pos = + let val idx = resolve_field_desig desigs pos + in (idx, SOME e, NONE) :: collect_field_items rest (idx + 1) end + | collect_field_items ((desigs, CInitList0 (inner_list, _)) :: rest) pos = + let val idx = resolve_field_desig desigs pos + in (idx, NONE, SOME inner_list) :: collect_field_items rest (idx + 1) end + val field_items = collect_field_items init_list 0 + val ctxt_inner = C_Trans_Ctxt.get_ctxt tctx + val make_name = "make_" ^ (!current_decl_prefix) ^ struct_name + val make_const = + Proof_Context.read_const {proper = true, strict = false} + ctxt_inner make_name + fun default_for_field (_, field_cty) = + (case field_cty of + C_Ast_Utils.CPtr elem_cty => + HOLogic.mk_list (C_Ast_Utils.hol_type_of elem_cty) [] + | _ => HOLogic.mk_number (C_Ast_Utils.hol_type_of field_cty) 0) + val init_exprs = List.map (fn (idx, e_opt, _) => + let val (_, field_cty) = List.nth (fields, idx) + in case e_opt of + SOME e => + let val (raw, raw_cty) = translate_expr tctx e + in mk_implicit_cast (raw, raw_cty, field_cty) end + | NONE => unsupported "nested init list in struct compound literal" + end) field_items + val n = List.length init_exprs + val vars = List.tabulate (n, + fn i => Isa_Free ("v__slit_" ^ Int.toString i, isa_dummyT)) + val base_vals = List.map default_for_field fields + val filled = ListPair.foldl + (fn ((idx, _, _), var, arr) => nth_map idx (K var) arr) + base_vals (field_items, vars) + val struct_term = List.foldl (fn (v, acc) => acc $ v) + make_const filled + val result = C_Term_Build.mk_literal struct_term + in (ListPair.foldr + (fn (expr, var, acc) => + C_Term_Build.mk_bind expr (Term.lambda var acc)) + result (init_exprs, vars), cty) end + | _ => unsupported "compound literal with complex initializer" + end + | translate_expr tctx (CGenericSelection0 (ctrl_expr, assoc_list, _)) = + (* _Generic(ctrl, type1: expr1, ..., default: expr_default) + Resolved at translation time based on the controlling expression's type. *) + let val (_, ctrl_cty) = translate_expr tctx ctrl_expr + val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx + val struct_names = C_Trans_Ctxt.get_struct_names tctx + fun resolve_assoc_type (CDecl0 (specs, _, _)) = + (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME ct => ct + | NONE => + (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of + SOME sn => C_Ast_Utils.CStruct sn + | NONE => unsupported "_Generic association type")) + | resolve_assoc_type _ = unsupported "_Generic association type" + fun find_match [] default_opt = + (case default_opt of + SOME expr => translate_expr tctx expr + | NONE => unsupported "_Generic: no matching association and no default") + | find_match ((None, expr) :: rest) _ = + find_match rest (SOME expr) + | find_match ((Some decl, expr) :: rest) default_opt = + if resolve_assoc_type decl = ctrl_cty + then translate_expr tctx expr + else find_match rest default_opt + in find_match assoc_list NONE end + | translate_expr tctx (CBuiltinExpr0 (CBuiltinTypesCompatible0 (decl1, decl2, _))) = + let val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx + fun resolve_decl (CDecl0 (specs, _, _)) = + C_Ast_Utils.resolve_c_type_full typedef_tab specs + | resolve_decl _ = NONE + val ty1 = resolve_decl decl1 + val ty2 = resolve_decl decl2 + val compatible = (ty1 = ty2 andalso Option.isSome ty1) + in (C_Term_Build.mk_literal_num C_Ast_Utils.CInt (if compatible then 1 else 0), + C_Ast_Utils.CInt) + end + | translate_expr tctx (CBuiltinExpr0 (CBuiltinOffsetOf0 (decl, desigs, _))) = + let val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx + val struct_names = C_Trans_Ctxt.get_struct_names tctx + val struct_name = + (case decl of + CDecl0 (specs, _, _) => + (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of + SOME sn => sn + | NONE => + (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME (C_Ast_Utils.CStruct sn) => sn + | _ => unsupported "__builtin_offsetof on non-struct type")) + | _ => unsupported "__builtin_offsetof with unsupported declaration") + fun walk_offset _ [] = unsupported "__builtin_offsetof with empty designators" + | walk_offset sn [CMemberDesig0 (field_ident, _)] = + raw_struct_field_offset tctx sn (C_Ast_Utils.ident_name field_ident) + | walk_offset sn (CMemberDesig0 (field_ident, _) :: rest) = + let val fname = C_Ast_Utils.ident_name field_ident + val base = raw_struct_field_offset tctx sn fname + val fields = the (C_Trans_Ctxt.get_struct_fields tctx sn) + val field_cty = the (AList.lookup (op =) fields fname) + in case field_cty of + C_Ast_Utils.CStruct inner_sn => base + walk_offset inner_sn rest + | _ => unsupported "__builtin_offsetof with non-struct intermediate field" + end + | walk_offset _ _ = unsupported "__builtin_offsetof with array designator" + val offset = walk_offset struct_name desigs + val size_cty = C_Ast_Utils.pointer_uint_cty () + in (C_Term_Build.mk_literal_num size_cty offset, size_cty) end + | translate_expr tctx (CStatExpr0 (CCompound0 (_, items, _), _)) = + (!stmt_expr_translate_ref) tctx items + | translate_expr _ (CStatExpr0 _) = + unsupported "statement expression with non-compound body" + | translate_expr _ (CBuiltinExpr0 _) = + unsupported "GCC builtin expression (only __builtin_types_compatible_p and __builtin_offsetof are supported)" + | translate_expr _ _ = + unsupported "expression" + + and translate_lvalue_location tctx (CVar0 (ident, _)) = + let val name = C_Ast_Utils.ident_name ident + in case C_Trans_Ctxt.lookup_var tctx name of + SOME (C_Trans_Ctxt.Local, ref_var, cty) => + (C_Term_Build.mk_literal ref_var, C_Ast_Utils.CPtr cty) + | SOME (C_Trans_Ctxt.LocalPtr, _, _) => + unsupported ("address-of pointer local variable not supported: " ^ name) + | SOME (C_Trans_Ctxt.Param, _, _) => + unsupported ("address-of by-value parameter: " ^ name) + | SOME (C_Trans_Ctxt.ParamListPtr, _, _) => + unsupported ("address-of list-backed pointer parameter: " ^ name) + | NONE => + (case C_Trans_Ctxt.lookup_global_const tctx name of + SOME (tm, _) => + (case C_Trans_Ctxt.lookup_array_decl tctx name of + SOME (elem_cty, _) => (C_Term_Build.mk_literal tm, C_Ast_Utils.CPtr elem_cty) + | NONE => unsupported ("address-of global const without reference storage not supported: " ^ name)) + | NONE => + error ("micro_c_translate: undefined variable: " ^ name)) + end + | translate_lvalue_location tctx (CUnary0 (CIndOp0, expr, _)) = + let val (ptr_term, ptr_cty) = translate_expr tctx expr + in case ptr_cty of + C_Ast_Utils.CPtr _ => (ptr_term, ptr_cty) + | _ => unsupported "address-of dereference on non-pointer expression" + end + | translate_lvalue_location tctx (CMember0 (expr, field_ident, is_ptr, _)) = + let + val field_name = C_Ast_Utils.ident_name field_ident + val struct_name = determine_struct_type tctx expr + val field_cty = + (case C_Trans_Ctxt.lookup_struct_field_type tctx struct_name field_name of + SOME cty => cty + | NONE => unsupported ("unknown struct field type: " ^ struct_name ^ "." ^ field_name)) + val focus_const = resolve_struct_focus_const (C_Trans_Ctxt.get_ctxt tctx) struct_name field_name + val (base_expr, base_is_raw) = + if is_ptr then + let val (ptr_expr, ptr_cty) = + (case expr of + CCast0 (_, inner_expr, _) => + let val (inner_ptr, inner_cty) = translate_expr tctx inner_expr + in case inner_cty of + C_Ast_Utils.CPtr C_Ast_Utils.CVoid => (inner_ptr, inner_cty) + | C_Ast_Utils.CPtr (C_Ast_Utils.CUnion _) => (inner_ptr, inner_cty) + | _ => translate_expr tctx expr + end + | _ => translate_expr tctx expr) + in case ptr_cty of + C_Ast_Utils.CPtr C_Ast_Utils.CVoid => (ptr_expr, true) + | C_Ast_Utils.CPtr (C_Ast_Utils.CUnion _) => (ptr_expr, true) + | C_Ast_Utils.CPtr _ => (ptr_expr, false) + | _ => unsupported "member access through non-pointer expression" + end + else + (#1 (translate_lvalue_location tctx expr), false) + in + if base_is_raw then + (mk_raw_struct_field_loc_expr tctx struct_name field_name field_cty base_expr, + C_Ast_Utils.CPtr field_cty) + else + let + val base_ty = expr_value_type base_expr + val base_var = Isa_Free ("v__base_loc", if base_ty = isa_dummyT then isa_dummyT else base_ty) + val focused = C_Term_Build.mk_focus_field focus_const base_var + in + (C_Term_Build.mk_bind base_expr (Term.lambda base_var (C_Term_Build.mk_literal focused)), + C_Ast_Utils.CPtr field_cty) + end + end + | translate_lvalue_location tctx (CIndex0 (arr_expr, idx_expr, _)) = + let + val allow_fallback = + (case arr_expr of + CMember0 _ => false + | _ => true) + fun fallback_to_expr msg = + String.isSubstring "address-of non-lvalue expression" msg orelse + String.isSubstring "address-of by-value parameter" msg + val (arr_term, arr_cty) = + (translate_lvalue_location tctx arr_expr + handle ERROR msg => + if allow_fallback andalso fallback_to_expr msg then translate_expr tctx arr_expr + else raise ERROR msg) + val (idx_term_raw, idx_cty) = translate_expr tctx idx_expr + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val deref_const = resolve_dereference_const ctxt + val idx_p_cty = C_Ast_Utils.integer_promote idx_cty + val idx_term = mk_implicit_cast (idx_term_raw, idx_cty, idx_p_cty) + val arr_is_global_const = + (case arr_expr of + CVar0 (ident, _) => + (case C_Trans_Ctxt.lookup_global_const tctx (C_Ast_Utils.ident_name ident) of + SOME _ => true + | NONE => false) + | _ => false) + val arr_has_effect = C_Ast_Utils.expr_has_side_effect arr_expr + val idx_has_effect = C_Ast_Utils.expr_has_side_effect idx_expr + val unseq_index = arr_has_effect orelse idx_has_effect + val _ = + if arr_is_global_const then + unsupported "address-of global constant array element is not supported without reference storage" + else if unseq_index andalso C_Ast_Utils.expr_has_unsequenced_ub_risk arr_expr idx_expr then + unsupported "potential unsequenced side-effect UB in indexed lvalue" + else () + val a_var = Isa_Free ("v__arr_loc", isa_dummyT) + val i_var = Isa_Free ("v__idx", isa_dummyT) + val deref_expr = + Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ a_var) + $ (Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) + $ deref_const) + val elem_cty = + (case arr_cty of + C_Ast_Utils.CPtr inner => inner + | _ => unsupported "indexing non-array expression") + val loc_expr = + if use_raw_pointer_indexing tctx arr_expr then + mk_raw_ptr_loc_expr ctxt unseq_index arr_term idx_term_raw idx_cty elem_cty (is_nonnegative_int_const idx_expr) + else + let + val focused = C_Term_Build.mk_focus_nth (C_Term_Build.mk_unat i_var) a_var + val list_var = + let + val list_ty = + (case C_Ast_Utils.hol_type_of elem_cty of + t => if t = isa_dummyT then isa_dummyT + else Isa_Type (\<^type_name>\list\, [t])) + in Isa_Free ("v__arr_vals", list_ty) end + in + mk_pair_eval unseq_index arr_term idx_term a_var i_var + (C_Term_Build.mk_bind deref_expr + (Term.lambda list_var + (mk_index_guard idx_p_cty i_var list_var + (C_Term_Build.mk_literal focused)))) + end + in (loc_expr, C_Ast_Utils.CPtr elem_cty) end + | translate_lvalue_location _ _ = + unsupported "address-of non-lvalue expression" + + (* Convenience: extract just the term from translate_expr *) + and expr_term tctx e = #1 (translate_expr tctx e) + + (* Ensure a C expression produces a bool condition. + In C, any scalar value in a condition position is implicitly converted + to bool via != 0. If the expression already produces CBool (from a + comparison or _Bool variable), use it directly. Otherwise, wrap with + bind expr (\v. literal (v \ 0)). *) + and ensure_bool_cond tctx cond_expr = + let val (cond_term, cond_cty) = translate_expr tctx cond_expr + in mk_implicit_cast (cond_term, cond_cty, C_Ast_Utils.CBool) + end + + (* C11 \
6.7: declarations; \
6.7.9: initialization. + Extract variable declarations as a list of (name, init_term, cty, array_meta, list_backed_ptr_alias) tuples. + Handles multiple declarators in a single CDecl0. + For pointer declarators (e.g. int *p = &x), the returned cty is CPtr base_cty. *) + fun translate_decl tctx (CDecl0 (specs, declarators, _)) = + let val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx + val struct_names = C_Trans_Ctxt.get_struct_names tctx + val cty = + (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME C_Ast_Utils.CVoid => C_Ast_Utils.CInt + | SOME t => t + | NONE => + (case C_Ast_Utils.extract_struct_type_from_specs_full struct_names specs of + SOME sn => C_Ast_Utils.CStruct sn + | NONE => + (case C_Ast_Utils.extract_union_type_from_specs_full (!current_union_names) specs of + SOME un => C_Ast_Utils.CUnion un + | NONE => C_Ast_Utils.CInt))) + fun pointer_depth_of_declr declr = C_Ast_Utils.pointer_depth_of_declr declr + fun has_array_declr (CDeclr0 (_, derived, _, _, _)) = + List.exists (fn CArrDeclr0 _ => true | _ => false) derived + fun array_decl_size (CDeclr0 (_, derived, _, _, _)) = + List.mapPartial + (fn CArrDeclr0 (_, CArrSize0 (_, CConst0 (CIntConst0 (CInteger0 (n, _, _), _))), _) => + if n < 0 then + error "micro_c_translate: negative array bound not supported" + else + SOME (intinf_to_int_checked "array bound" n) + | _ => NONE) derived + |> (fn n :: _ => SOME n | [] => NONE) + fun init_scalar_const_value (CConst0 (CIntConst0 (CInteger0 (n, _, _), _))) = n + | init_scalar_const_value (CConst0 (CCharConst0 (CChar0 (c, _), _))) = + integer_of_char c + | init_scalar_const_value (CConst0 (CCharConst0 (CChars0 _, _))) = + unsupported "multi-character constant in array initializer" + | init_scalar_const_value (CVar0 (ident, _)) = + let val name = C_Ast_Utils.ident_name ident + in case C_Trans_Ctxt.lookup_enum_const tctx name of + SOME value => IntInf.fromInt value + | NONE => + unsupported ("unsupported array initializer element: " ^ name) + end + | init_scalar_const_value (CUnary0 (CMinOp0, e, _)) = + IntInf.~ (init_scalar_const_value e) + | init_scalar_const_value (CUnary0 (CPlusOp0, e, _)) = + init_scalar_const_value e + | init_scalar_const_value (CCast0 (_, e, _)) = + init_scalar_const_value e + | init_scalar_const_value _ = + unsupported "non-constant array initializer element" + fun string_literal_bytes (CConst0 (CStrConst0 (CString0 (abr_str, _), _))) = + SOME (List.map Char.ord + (String.explode (C_Ast_Utils.abr_string_to_string abr_str))) + | string_literal_bytes _ = NONE + fun init_scalar_const_term target_cty expr = + HOLogic.mk_number (C_Ast_Utils.hol_type_of target_cty) + (intinf_to_int_checked "array initializer literal" + (init_scalar_const_value expr)) + fun process_one ((Some declr, Some (CInitExpr0 (init, _))), _) = + let val name = C_Ast_Utils.declr_name declr + val ptr_depth = pointer_depth_of_declr declr + val actual_cty = C_Ast_Utils.apply_ptr_depth cty ptr_depth + in + case (has_array_declr declr, string_literal_bytes init) of + (true, SOME char_ords) => + let val elem_cty = + if ptr_depth > 0 + then C_Ast_Utils.apply_ptr_depth cty (ptr_depth - 1) else cty + val elem_type = C_Ast_Utils.hol_type_of elem_cty + val with_null = + List.map (fn b => HOLogic.mk_number elem_type b) char_ords + @ [HOLogic.mk_number elem_type 0] + val declared_n = array_decl_size declr + val arr_size = + case declared_n of SOME n => n | NONE => List.length with_null + val padded = + case declared_n of + SOME n => + if List.length with_null > n then + unsupported "string initializer too long for array" + else with_null @ List.tabulate + (n - List.length with_null, + fn _ => HOLogic.mk_number elem_type 0) + | NONE => with_null + val list_term = + C_Term_Build.mk_literal (HOLogic.mk_list elem_type padded) + in (name, list_term, actual_cty, SOME (elem_cty, arr_size), false) end + | _ => + let val (init_raw, init_cty) = translate_expr tctx init + val init_term = mk_implicit_cast (init_raw, init_cty, actual_cty) + val arr_meta = + (case array_decl_size declr of + SOME n => + if ptr_depth > 0 + then SOME (C_Ast_Utils.apply_ptr_depth cty (ptr_depth - 1), n) + else NONE + | NONE => NONE) + val alias_list_backed = + C_Ast_Utils.is_ptr actual_cty andalso expr_is_list_backed_array tctx init + in (name, init_term, actual_cty, arr_meta, alias_list_backed) end + end + | process_one ((Some declr, Some (CInitList0 (init_list, _))), _) = + let val name = C_Ast_Utils.declr_name declr + val ptr_depth = pointer_depth_of_declr declr + val actual_cty = C_Ast_Utils.apply_ptr_depth cty ptr_depth + in if has_array_declr declr then + let val elem_cty = + if ptr_depth > 0 then C_Ast_Utils.apply_ptr_depth cty (ptr_depth - 1) else cty + val elem_type = C_Ast_Utils.hol_type_of elem_cty + in + if C_Ast_Utils.is_ptr elem_cty then + (* N-dimensional array: elements are sub-arrays *) + let (* Extract all array dimension sizes from declarator *) + fun all_arr_sizes (CDeclr0 (_, derived, _, _, _)) = + List.mapPartial + (fn CArrDeclr0 (_, CArrSize0 (_, CConst0 (CIntConst0 (CInteger0 (n, _, _), _))), _) => + SOME (intinf_to_int_checked "array bound" n) + | _ => NONE) derived + val arr_sizes = all_arr_sizes declr + (* Build a zero-filled nested array for padding *) + fun build_zero cur_cty [] = + HOLogic.mk_number (C_Ast_Utils.hol_type_of cur_cty) 0 + | build_zero (C_Ast_Utils.CPtr inner_cty) (dim :: rest) = + let val zero_inner = build_zero inner_cty rest + in HOLogic.mk_list (fastype_of zero_inner) + (List.tabulate (dim, fn _ => zero_inner)) end + | build_zero cur_cty (dim :: _) = + let val ty = C_Ast_Utils.hol_type_of cur_cty + in HOLogic.mk_list ty + (List.tabulate (dim, fn _ => HOLogic.mk_number ty 0)) end + (* Recursively build nested array from init list. + cur_cty = element type at this level. + dims = remaining dimension sizes for sub-levels. *) + fun build_nested cur_cty [] items = + (* Base: scalar elements *) + let val ty = C_Ast_Utils.hol_type_of cur_cty + val vals = List.map + (fn (_, CInitExpr0 (e, _)) => init_scalar_const_term cur_cty e + | _ => unsupported "complex nested array element") items + in HOLogic.mk_list ty vals end + | build_nested (C_Ast_Utils.CPtr inner_cty) (dim :: rest) items = + let val built = List.map + (fn (_, CInitList0 (sub_inits, _)) => + build_nested inner_cty rest sub_inits + | _ => unsupported "expected nested init list for multi-dim array") + items + val zero_inner = build_zero inner_cty rest + val inner_type = fastype_of zero_inner + val padded = + if List.length built < dim + then built @ List.tabulate (dim - List.length built, fn _ => zero_inner) + else built + in HOLogic.mk_list inner_type padded end + | build_nested cur_cty (dim :: _) items = + (* Base with known dimension: scalar elements with padding *) + let val ty = C_Ast_Utils.hol_type_of cur_cty + val vals = List.map + (fn (_, CInitExpr0 (e, _)) => init_scalar_const_term cur_cty e + | _ => unsupported "complex nested array element") items + val padded = + if List.length vals < dim + then vals @ List.tabulate (dim - List.length vals, fn _ => HOLogic.mk_number ty 0) + else vals + in HOLogic.mk_list ty padded end + val outer_size = (case arr_sizes of n :: _ => n | [] => List.length init_list) + val result = build_nested elem_cty arr_sizes init_list + val arr_meta = SOME (elem_cty, outer_size) + in (name, C_Term_Build.mk_literal result, actual_cty, arr_meta, false) end + else + let + (* Resolve position for each element: designators set explicit index, + positional elements use sequential position *) + fun expand_desig [] pos e = [(pos, e)] + | expand_desig [CArrDesig0 (CConst0 (CIntConst0 (CInteger0 (n, _, _), _)), _)] _ e = + [(intinf_to_int_checked "array designator" n, e)] + | expand_desig [CRangeDesig0 ( + CConst0 (CIntConst0 (CInteger0 (lo_n, _, _), _)), + CConst0 (CIntConst0 (CInteger0 (hi_n, _, _), _)), _)] _ e = + let val lo = intinf_to_int_checked "range designator lo" lo_n + val hi = intinf_to_int_checked "range designator hi" hi_n + in List.tabulate (hi - lo + 1, fn i => (lo + i, e)) end + | expand_desig _ _ _ = unsupported "complex designator in array initializer" + fun collect_indices [] _ = [] + | collect_indices ((desigs, CInitExpr0 (e, _)) :: rest) pos = + let val items = expand_desig desigs pos e + val next_pos = #1 (List.last items) + 1 + in items @ collect_indices rest next_pos end + | collect_indices _ _ = unsupported "complex array initializer element" + val indexed_items = collect_indices init_list 0 + val has_designators = List.exists (fn (desigs, _) => not (null desigs)) init_list + val declared_size = array_decl_size declr + val arr_size = case declared_size of + SOME n => n + | NONE => List.length indexed_items + val _ = if List.length indexed_items > arr_size andalso not has_designators + then error "micro_c_translate: too many initializers for array" + else () + val _ = List.app (fn (idx, _) => + if idx < 0 orelse idx >= arr_size + then error ("micro_c_translate: designator index " ^ + Int.toString idx ^ " out of bounds for array of size " ^ + Int.toString arr_size) + else ()) indexed_items + (* Try constant path first *) + val const_results = List.map (fn (idx, e) => + let val v = (SOME (init_scalar_const_term elem_cty e) handle ERROR _ => NONE) + in (idx, v) end) indexed_items + val all_const = List.all (fn (_, v) => Option.isSome v) const_results + val zero_value = HOLogic.mk_number elem_type 0 + val init_term = + if all_const then + (* All-constant: build zero array, fill in designated positions *) + let val base = List.tabulate (arr_size, fn _ => zero_value) + val filled = List.foldl (fn ((idx, SOME v), arr) => + nth_map idx (K v) arr + | _ => raise Match) base const_results + in C_Term_Build.mk_literal (HOLogic.mk_list elem_type filled) end + else + (* Monadic: evaluate all init values, build array with designators *) + let val init_exprs = List.map (fn (_, e) => + let val (raw, raw_cty) = translate_expr tctx e + in mk_implicit_cast (raw, raw_cty, elem_cty) end) indexed_items + val n = List.length init_exprs + val vars = List.tabulate (n, + fn i => Isa_Free ("v__init_" ^ Int.toString i, isa_dummyT)) + (* Build array: start with zeros, place vars at designated positions *) + val base = List.tabulate (arr_size, fn _ => zero_value) + val filled = ListPair.foldl + (fn ((idx, _), var, arr) => nth_map idx (K var) arr) + base (indexed_items, vars) + val result_list = HOLogic.mk_list elem_type filled + val result = C_Term_Build.mk_literal result_list + in ListPair.foldr + (fn (expr, var, acc) => + C_Term_Build.mk_bind expr (Term.lambda var acc)) + result (init_exprs, vars) + end + val arr_meta = + (case declared_size of + SOME n => SOME (elem_cty, n) + | NONE => NONE) + in (name, init_term, actual_cty, arr_meta, false) end + end + else (case actual_cty of + C_Ast_Utils.CStruct struct_name => + let val fields = + (case C_Trans_Ctxt.get_struct_fields tctx struct_name of + SOME fs => fs + | NONE => error ("micro_c_translate: unknown struct: " ^ struct_name)) + (* Map each init item to (field_index, expr_opt, initlist_opt) *) + fun find_field_index _ [] _ = + error "micro_c_translate: struct field not found" + | find_field_index fname ((n, _) :: rest) i = + if n = fname then i + else find_field_index fname rest (i + 1) + fun resolve_field_desig [] pos = pos + | resolve_field_desig [CMemberDesig0 (ident, _)] _ = + find_field_index (C_Ast_Utils.ident_name ident) fields 0 + | resolve_field_desig _ _ = + unsupported "complex designator in struct initializer" + (* field_items: (idx, SOME expr, NONE) for scalar, (idx, NONE, SOME init_list) for nested *) + fun collect_field_items [] _ = [] + | collect_field_items ((desigs, CInitExpr0 (e, _)) :: rest) pos = + let val idx = resolve_field_desig desigs pos + in (idx, SOME e, NONE) :: collect_field_items rest (idx + 1) end + | collect_field_items ((desigs, CInitList0 (inner_list, _)) :: rest) pos = + let val idx = resolve_field_desig desigs pos + in (idx, NONE, SOME inner_list) :: collect_field_items rest (idx + 1) end + val field_items = collect_field_items init_list 0 + (* Helper: build constant array list from CInitList items *) + fun build_const_array_from_initlist arr_elem_cty arr_sz inner_list = + let val elem_type = C_Ast_Utils.hol_type_of arr_elem_cty + fun resolve_arr_desig [] pos = pos + | resolve_arr_desig [CArrDesig0 (CConst0 (CIntConst0 (CInteger0 (n, _, _), _)), _)] _ = + intinf_to_int_checked "nested array designator" n + | resolve_arr_desig _ _ = unsupported "complex nested array designator" + fun collect_arr [] _ = [] + | collect_arr ((ds, CInitExpr0 (e, _)) :: rest) pos = + let val idx = resolve_arr_desig ds pos + in (idx, e) :: collect_arr rest (idx + 1) end + | collect_arr _ _ = unsupported "complex nested array init element" + val indexed = collect_arr inner_list 0 + val sz = case arr_sz of SOME n => n | NONE => List.length indexed + val zero_val = HOLogic.mk_number elem_type 0 + val base = List.tabulate (sz, fn _ => zero_val) + val filled = List.foldl (fn ((idx, e), arr) => + nth_map idx (K (init_scalar_const_term arr_elem_cty e)) arr) base indexed + in HOLogic.mk_list elem_type filled end + (* Helper: try to produce a constant init value for a field *) + fun try_const_field_val field_cty (SOME e) NONE = + (SOME (init_scalar_const_term field_cty e) handle ERROR _ => NONE) + | try_const_field_val field_cty NONE (SOME inner_list) = + (case field_cty of + C_Ast_Utils.CPtr elem_cty => + (SOME (build_const_array_from_initlist elem_cty NONE inner_list) + handle ERROR _ => NONE) + | _ => NONE) + | try_const_field_val _ _ _ = NONE (* e.g. both NONE *) + (* Helper: translate a field init value monadically *) + fun translate_field_val field_cty (SOME e) NONE = + let val (raw, raw_cty) = translate_expr tctx e + in mk_implicit_cast (raw, raw_cty, field_cty) end + | translate_field_val field_cty NONE (SOME inner_list) = + (case field_cty of + C_Ast_Utils.CPtr elem_cty => + let val elem_type = C_Ast_Utils.hol_type_of elem_cty + fun resolve_arr_desig [] pos = pos + | resolve_arr_desig [CArrDesig0 (CConst0 (CIntConst0 (CInteger0 (n, _, _), _)), _)] _ = + intinf_to_int_checked "nested array designator" n + | resolve_arr_desig _ _ = unsupported "complex nested array designator" + fun collect_arr [] _ = [] + | collect_arr ((ds, CInitExpr0 (e, _)) :: rest) pos = + let val idx = resolve_arr_desig ds pos + in (idx, e) :: collect_arr rest (idx + 1) end + | collect_arr _ _ = unsupported "complex nested array init element" + val indexed = collect_arr inner_list 0 + val sz = List.length indexed + val zero_val = HOLogic.mk_number elem_type 0 + val init_exprs_inner = List.map (fn (_, e) => + let val (raw, raw_cty) = translate_expr tctx e + in mk_implicit_cast (raw, raw_cty, elem_cty) end) indexed + val nn = List.length init_exprs_inner + val vars = List.tabulate (nn, + fn i => Isa_Free ("v__ainit_" ^ Int.toString i, isa_dummyT)) + val base = List.tabulate (sz, fn _ => zero_val) + val filled = ListPair.foldl + (fn ((idx, _), var, arr) => nth_map idx (K var) arr) + base (indexed, vars) + val result_list = HOLogic.mk_list elem_type filled + val result = C_Term_Build.mk_literal result_list + in ListPair.foldr + (fn (expr, var, acc) => + C_Term_Build.mk_bind expr (Term.lambda var acc)) + result (init_exprs_inner, vars) + end + | _ => unsupported "nested init list for non-array struct field") + | translate_field_val _ _ _ = + unsupported "malformed struct field initializer" + (* Try constant path first *) + val const_results = List.map (fn (idx, e_opt, il_opt) => + let val (_, field_cty) = List.nth (fields, idx) + val v = try_const_field_val field_cty e_opt il_opt + in (idx, v) end) field_items + val all_const = List.all (fn (_, v) => Option.isSome v) const_results + val ctxt_inner = C_Trans_Ctxt.get_ctxt tctx + val make_name = "make_" ^ (!current_decl_prefix) ^ struct_name + val make_const = + Proof_Context.read_const {proper = true, strict = false} + ctxt_inner make_name + fun default_for_field (_, field_cty) = + (case field_cty of + C_Ast_Utils.CPtr elem_cty => + HOLogic.mk_list (C_Ast_Utils.hol_type_of elem_cty) [] + | _ => HOLogic.mk_number (C_Ast_Utils.hol_type_of field_cty) 0) + val init_term = + if all_const then + let val base_vals = List.map default_for_field fields + val filled = List.foldl (fn ((idx, SOME v), arr) => + nth_map idx (K v) arr + | _ => raise Match) base_vals const_results + val struct_term = List.foldl (fn (v, acc) => acc $ v) + make_const filled + in C_Term_Build.mk_literal struct_term end + else + let val init_exprs = List.map (fn (idx, e_opt, il_opt) => + let val (_, field_cty) = List.nth (fields, idx) + in translate_field_val field_cty e_opt il_opt end) + field_items + val n = List.length init_exprs + val vars = List.tabulate (n, + fn i => Isa_Free ("v__sinit_" ^ Int.toString i, isa_dummyT)) + val base_vals = List.map default_for_field fields + val filled = ListPair.foldl + (fn ((idx, _, _), var, arr) => nth_map idx (K var) arr) + base_vals (field_items, vars) + val struct_term = List.foldl (fn (v, acc) => acc $ v) + make_const filled + val result = C_Term_Build.mk_literal struct_term + in ListPair.foldr + (fn (expr, var, acc) => + C_Term_Build.mk_bind expr (Term.lambda var acc)) + result (init_exprs, vars) + end + in (name, init_term, actual_cty, NONE, false) end + | _ => unsupported "initializer list for non-array, non-struct declaration") + end + | process_one ((Some declr, None), _) = + let val name = C_Ast_Utils.declr_name declr + val ptr_depth = pointer_depth_of_declr declr + val actual_cty = C_Ast_Utils.apply_ptr_depth cty ptr_depth + val uninit = Isa_Const (\<^const_name>\c_uninitialized\, isa_dummyT) + val arr_meta = + (case array_decl_size declr of + SOME n => + if ptr_depth > 0 + then SOME (C_Ast_Utils.apply_ptr_depth cty (ptr_depth - 1), n) + else NONE + | NONE => NONE) + in (name, C_Term_Build.mk_literal uninit, actual_cty, arr_meta, false) end + | process_one _ = unsupported "complex declarator" + in List.map process_one declarators end + | translate_decl _ _ = unsupported "complex declaration" + + (* Find label names nested in statements/items, preserving first-seen order. *) + fun find_stmt_labels (CLabel0 (ident, inner, _, _)) = + C_Ast_Utils.ident_name ident :: find_stmt_labels inner + | find_stmt_labels (CCompound0 (_, items, _)) = find_block_labels items + | find_stmt_labels (CIf0 (_, thn, Some els, _)) = + find_stmt_labels thn @ find_stmt_labels els + | find_stmt_labels (CIf0 (_, thn, None, _)) = find_stmt_labels thn + | find_stmt_labels (CWhile0 (_, body, _, _)) = find_stmt_labels body + | find_stmt_labels (CFor0 (_, _, _, body, _)) = find_stmt_labels body + | find_stmt_labels (CSwitch0 (_, body, _)) = find_stmt_labels body + | find_stmt_labels _ = [] + and find_block_labels [] = [] + | find_block_labels (CBlockStmt0 stmt :: rest) = + find_stmt_labels stmt @ find_block_labels rest + | find_block_labels (_ :: rest) = find_block_labels rest + + (* C11 \
6.8.2: compound statement (block scope \
6.2.1p4). + Translate a compound block, right-folding declarations into nested binds. + Goto support: when goto_refs is non-empty, each statement is guarded to be + skipped if any active goto flag is set. At a label site, the corresponding + goto flag is reset (written to 0) and removed from the active list. *) + fun translate_compound_items _ [] = C_Term_Build.mk_literal_unit + | translate_compound_items tctx [CBlockStmt0 stmt] = + (* Last item: if it's a label, handle goto flag reset *) + (case stmt of + CLabel0 (ident, inner_stmt, _, _) => + let val label_name = C_Ast_Utils.ident_name ident + val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 + val active' = List.filter (fn n => n <> label_name) + (C_Trans_Ctxt.get_active_goto_labels tctx) + val tctx' = C_Trans_Ctxt.set_active_goto_labels active' tctx + in case C_Trans_Ctxt.lookup_goto_ref tctx label_name of + SOME goto_ref => + C_Term_Build.mk_sequence + (C_Term_Build.mk_var_write goto_ref false_lit) + (translate_stmt tctx' inner_stmt) + | NONE => translate_stmt tctx' stmt + end + | _ => translate_stmt tctx stmt) + | translate_compound_items _ [CNestedFunDef0 _] = + unsupported "nested function definition" + | translate_compound_items tctx (CBlockDecl0 (CStaticAssert0 (expr, msg_lit, _)) :: rest) = + let val typedef_tab = C_Trans_Ctxt.get_typedef_tab tctx + fun resolve_decl_type (CDecl0 (specs, _, _)) = + C_Ast_Utils.resolve_c_type_full typedef_tab specs + | resolve_decl_type _ = NONE + val v = C_Ast_Utils.eval_const_int_expr resolve_decl_type expr + in if v = 0 then + unsupported ("_Static_assert failed: " ^ + C_Ast_Utils.extract_string_literal msg_lit) + else translate_compound_items tctx rest + end + | translate_compound_items tctx (CBlockDecl0 decl :: rest) = + let val decls = translate_decl tctx decl + fun fold_decls [] tctx' = translate_compound_items tctx' rest + | fold_decls ((name, init_term, cty, arr_meta, alias_list_backed) :: ds) tctx' = + if C_Ast_Utils.is_ptr cty andalso not (Option.isSome arr_meta) then + let + val ctxt' = C_Trans_Ctxt.get_ctxt tctx' + val supports_raw_ptr = supports_raw_ptr_local_refs ctxt' + val force_mutable_ptr = + List.exists (fn v => v = name) (!current_loop_written_vars) + in + if supports_raw_ptr andalso + (force_mutable_ptr orelse not (prefer_pointer_alias_storage alias_list_backed init_term)) then + let + val raw_ptr_ty = raw_ptr_local_gref_typ () + val stored_init = + if is_uninitialized_literal init_term then init_term + else mk_implicit_cast (init_term, cty, C_Ast_Utils.CPtr C_Ast_Utils.CVoid) + val alloc_expr = + mk_resolved_var_alloc_typed ctxt' raw_ptr_ty stored_init + val var = mk_typed_ref_var tctx' name alloc_expr + val tctx'' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.LocalPtr var cty tctx' + val tctx'' = (case struct_name_of_cty cty of + SOME sn => C_Trans_Ctxt.set_struct_type name sn tctx'' + | NONE => tctx'') + val tctx'' = (case arr_meta of + SOME (elem_cty, n) => C_Trans_Ctxt.set_array_decl name elem_cty n tctx'' + | NONE => tctx'') + in C_Term_Build.mk_bind alloc_expr + (Term.lambda var (fold_decls ds tctx'')) end + else + let + val var = Isa_Free (name, pointer_alias_var_ty tctx' alias_list_backed cty init_term) + val kind = pointer_alias_kind alias_list_backed + val tctx'' = C_Trans_Ctxt.add_var name kind var cty tctx' + val tctx'' = (case struct_name_of_cty cty of + SOME sn => C_Trans_Ctxt.set_struct_type name sn tctx'' + | NONE => tctx'') + val tctx'' = (case arr_meta of + SOME (elem_cty, n) => C_Trans_Ctxt.set_array_decl name elem_cty n tctx'' + | NONE => tctx'') + in if is_uninitialized_literal init_term then + fold_decls ds tctx'' + else + C_Term_Build.mk_bind init_term + (Term.lambda var (fold_decls ds tctx'')) + end + end + else + let val val_type = + let val ty = C_Ast_Utils.hol_type_of cty + in if ty = isa_dummyT then expr_value_type init_term else ty end + val alloc_expr = + mk_resolved_var_alloc_typed (C_Trans_Ctxt.get_ctxt tctx') val_type init_term + val var = mk_typed_ref_var tctx' name alloc_expr + val tctx'' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.Local var cty tctx' + val tctx'' = (case struct_name_of_cty cty of + SOME sn => C_Trans_Ctxt.set_struct_type name sn tctx'' + | NONE => tctx'') + val tctx'' = (case arr_meta of + SOME (elem_cty, n) => C_Trans_Ctxt.set_array_decl name elem_cty n tctx'' + | NONE => tctx'') + in C_Term_Build.mk_bind alloc_expr + (Term.lambda var (fold_decls ds tctx'')) + end + in fold_decls decls tctx end + | translate_compound_items tctx (CBlockStmt0 (CLabel0 (ident, inner_stmt, _, _)) :: rest) = + let val label_name = C_Ast_Utils.ident_name ident + val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 + val true_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 1 + (* Check if any goto in the remaining code (or inner_stmt) targets this label. + If so, this is a backward goto target and needs a bounded_while wrapper. *) + val backward_goto_targets = + C_Ast_Utils.find_goto_targets inner_stmt @ + maps (fn CBlockStmt0 s => C_Ast_Utils.find_goto_targets s | _ => []) rest + val is_backward_target = + List.exists (fn n => n = label_name) backward_goto_targets + in case C_Trans_Ctxt.lookup_goto_ref tctx label_name of + SOME goto_ref => + if is_backward_target then + (* Backward goto: wrap label body in bounded_while. + Split rest at forward goto targets so they stay outside the while. + flag := 1 (force first iteration) + bounded_while fuel (flag != 0) (flag := 0; body; while_items) + after_items (forward goto labels + remaining) *) + let val active' = List.filter (fn n => n <> label_name) + (C_Trans_Ctxt.get_active_goto_labels tctx) + (* Add backward goto label + forward targets from rest to active labels *) + val rest_labels = find_block_labels rest + val inner_labels = find_stmt_labels inner_stmt + val tctx' = C_Trans_Ctxt.set_active_goto_labels + (distinct (op =) (label_name :: active' @ rest_labels @ inner_labels)) tctx + val goto_refs = C_Trans_Ctxt.get_goto_refs tctx + (* Split rest: items before first forward-goto label go in the while body; + the label and everything after go outside. *) + fun split_at_fwd_label [] = ([], []) + | split_at_fwd_label (all as (CBlockStmt0 (CLabel0 (lid, _, _, _)) :: _)) = + let val lname = C_Ast_Utils.ident_name lid + in if List.exists (fn (n, _) => n = lname) goto_refs + andalso lname <> label_name + then ([], all) + else let val (pre, post) = split_at_fwd_label (tl all) + in (hd all :: pre, post) end + end + | split_at_fwd_label (item :: items) = + let val (pre, post) = split_at_fwd_label items + in (item :: pre, post) end + val (while_items, after_items) = split_at_fwd_label rest + (* Combine inner_stmt + while_items into a single compound block + so the guard mechanism correctly wraps items after forward gotos + (e.g., goto done inside if) with the done flag guard. *) + val all_while_items = CBlockStmt0 inner_stmt :: while_items + val while_body_term = translate_compound_items tctx' all_while_items + val body_term = + C_Term_Build.mk_sequence + (C_Term_Build.mk_var_write goto_ref false_lit) + while_body_term + val cond_term = C_Term_Build.mk_var_read goto_ref + val cond_bool = + let val v = Isa_Free ("v__bkgoto", isa_dummyT) + val nonzero = + Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) + $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) + $ v + $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) + in C_Term_Build.mk_bind cond_term + (Term.lambda v (C_Term_Build.mk_literal nonzero)) + end + val fuel_var = fresh_var [cond_bool, body_term] "while_fuel" @{typ nat} + val while_term = C_Term_Build.mk_bounded_while fuel_var cond_bool body_term + val after_term = translate_compound_items tctx after_items + in C_Term_Build.mk_sequence + (C_Term_Build.mk_var_write goto_ref true_lit) + (C_Term_Build.mk_sequence while_term after_term) + end + else + (* Forward goto: reset flag and continue (existing behavior) *) + let val active' = List.filter (fn n => n <> label_name) + (C_Trans_Ctxt.get_active_goto_labels tctx) + val tctx' = C_Trans_Ctxt.set_active_goto_labels active' tctx + val stmt_term = translate_stmt tctx' inner_stmt + val rest_term = translate_compound_items tctx' rest + in C_Term_Build.mk_sequence + (C_Term_Build.mk_var_write goto_ref false_lit) + (C_Term_Build.mk_sequence stmt_term rest_term) + end + | NONE => + (* Label not targeted by any goto — just translate normally *) + let val active' = List.filter (fn n => n <> label_name) + (C_Trans_Ctxt.get_active_goto_labels tctx) + val tctx' = C_Trans_Ctxt.set_active_goto_labels active' tctx + val stmt_term = translate_stmt tctx' inner_stmt + val rest_term = translate_compound_items tctx' rest + in C_Term_Build.mk_sequence stmt_term rest_term end + end + | translate_compound_items tctx (CBlockStmt0 stmt :: rest) = + (* Pointer alias assignment: when a pointer-typed Param variable is assigned, + rebind it via a monadic bind instead of writing to a reference. + This handles patterns like: int16_t *r; ... r = p->coeffs; *) + let val ptr_alias_result = + (case stmt of + CExpr0 (Some (CAssign0 (CAssignOp0, CVar0 (ident, _), rhs, _)), _) => + let val name = C_Ast_Utils.ident_name ident + in case C_Trans_Ctxt.lookup_var tctx name of + SOME (kind0, _, cty) => + if C_Ast_Utils.is_ptr cty andalso + (case kind0 of + C_Trans_Ctxt.Param => true + | C_Trans_Ctxt.ParamListPtr => true + | _ => false) + then + let val (rhs_term, _) = translate_expr tctx rhs + val rhs_list_backed = expr_is_list_backed_array tctx rhs + val var = Isa_Free (name, pointer_alias_var_ty tctx rhs_list_backed cty rhs_term) + val kind = pointer_alias_kind rhs_list_backed + val tctx' = C_Trans_Ctxt.add_var name kind var cty tctx + in SOME (C_Term_Build.mk_bind rhs_term + (Term.lambda var (translate_compound_items tctx' rest))) + end + else NONE + | _ => NONE + end + | _ => NONE) + in case ptr_alias_result of + SOME result => result + | NONE => + let val inherited_labels = C_Trans_Ctxt.get_active_goto_labels tctx + val goto_refs = C_Trans_Ctxt.get_goto_refs tctx + (* Determine which goto labels appear later in this block. + Only those need guarding at this point. *) + val later_labels = find_block_labels rest + val active_labels = distinct (op =) (inherited_labels @ later_labels) + val tctx_stmt = C_Trans_Ctxt.set_active_goto_labels active_labels tctx + val stmt_term = translate_stmt tctx_stmt stmt + val active_goto_refs = List.filter + (fn (name, _) => List.exists (fn l => l = name) active_labels) goto_refs + in case (C_Trans_Ctxt.get_break_ref tctx, + C_Trans_Ctxt.get_continue_ref tctx, + active_goto_refs) of + (NONE, NONE, []) => + C_Term_Build.mk_sequence stmt_term + (translate_compound_items tctx rest) + | _ => + let val guard_var = Isa_Free ("v__guard", isa_dummyT) + val guard_nonzero = + Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) + $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) + $ guard_var + $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) + (* Resolve dereference_fun from locale context to avoid + store_dereference_const adhoc overloading issues *) + val ctxt = C_Trans_Ctxt.get_ctxt tctx + val deref_const = resolve_dereference_const ctxt + val deref_fn = + Isa_Const (\<^const_name>\deep_compose1\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ Isa_Const (\<^const_name>\call\, isa_dummyT --> isa_dummyT) + $ deref_const + fun mk_guard_read ref_var = + Isa_Const (\<^const_name>\Core_Expression.bind\, isa_dummyT --> isa_dummyT --> isa_dummyT) + $ (Isa_Const (\<^const_name>\Core_Expression.literal\, isa_dummyT --> isa_dummyT) $ ref_var) + $ deref_fn + fun wrap_guard NONE inner = inner + | wrap_guard (SOME ref_var) inner = + C_Term_Build.mk_bind (mk_guard_read ref_var) + (Term.lambda guard_var + (C_Term_Build.mk_two_armed_cond + (C_Term_Build.mk_literal guard_nonzero) + C_Term_Build.mk_literal_unit inner)) + fun wrap_goto_guards [] inner = inner + | wrap_goto_guards ((_, ref_var) :: refs) inner = + wrap_guard (SOME ref_var) (wrap_goto_guards refs inner) + (* Split rest into guarded prefix (before first active label) + and unguarded suffix (label + remaining items). + The label code must be outside the guard so that the return type + from return statements at/after the label doesn't clash with + the guard's then-branch (literal unit). *) + fun split_at_active_label [] = ([], []) + | split_at_active_label (all as (CBlockStmt0 (CLabel0 (ident, _, _, _)) :: _)) = + let val lname = C_Ast_Utils.ident_name ident + in if List.exists (fn (n, _) => n = lname) active_goto_refs + then ([], all) + else let val (pre, post) = split_at_active_label (tl all) + in (hd all :: pre, post) end + end + | split_at_active_label (item :: items) = + let val (pre, post) = split_at_active_label items + in (item :: pre, post) end + val (guarded_items, label_suffix) = split_at_active_label rest + val guarded_term = translate_compound_items tctx_stmt guarded_items + val label_term = translate_compound_items tctx label_suffix + val guarded_part = + wrap_guard (C_Trans_Ctxt.get_break_ref tctx) + (wrap_guard (C_Trans_Ctxt.get_continue_ref tctx) + (wrap_goto_guards active_goto_refs guarded_term)) + in C_Term_Build.mk_sequence stmt_term + (C_Term_Build.mk_sequence guarded_part label_term) + end + end end + | translate_compound_items _ _ = unsupported "block item" + + (* GCC statement expression ({...}): like translate_compound_items but + returns the (term, cty) of the last expression instead of unit. *) + and translate_compound_items_expr _ [] = unsupported "empty statement expression" + | translate_compound_items_expr tctx [CBlockStmt0 (CExpr0 (Some expr, _))] = + translate_expr tctx expr + | translate_compound_items_expr tctx [CBlockStmt0 (CReturn0 (Some expr, _))] = + translate_expr tctx expr + | translate_compound_items_expr tctx (CBlockDecl0 decl :: rest) = + let val decls = translate_decl tctx decl + fun fold_decls [] tctx' = translate_compound_items_expr tctx' rest + | fold_decls ((name, init_term, cty, arr_meta, _) :: ds) tctx' = + if C_Ast_Utils.is_ptr cty andalso not (Option.isSome arr_meta) then + let val var = Isa_Free (name, isa_dummyT) + val tctx'' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.Param var cty tctx' + in if is_uninitialized_literal init_term then fold_decls ds tctx'' + else let val (inner, inner_cty) = fold_decls ds tctx'' + in (C_Term_Build.mk_bind init_term + (Term.lambda var inner), inner_cty) end + end + else + let val val_type = + let val ty = C_Ast_Utils.hol_type_of cty + in if ty = isa_dummyT then expr_value_type init_term else ty end + val alloc_expr = + mk_resolved_var_alloc_typed (C_Trans_Ctxt.get_ctxt tctx') val_type init_term + val var = mk_typed_ref_var tctx' name alloc_expr + val tctx'' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.Local var cty tctx' + val (inner, inner_cty) = fold_decls ds tctx'' + in (C_Term_Build.mk_bind alloc_expr + (Term.lambda var inner), inner_cty) end + in fold_decls decls tctx end + | translate_compound_items_expr tctx (CBlockStmt0 stmt :: rest) = + let val (inner, inner_cty) = translate_compound_items_expr tctx rest + in (C_Term_Build.mk_sequence (translate_stmt tctx stmt) inner, inner_cty) end + | translate_compound_items_expr _ _ = unsupported "complex statement expression item" + + (* Translate a C expression to a pure nat term (for loop bounds). + Only integer literals and parameter variables are supported. *) + and translate_pure_nat_expr _ (CConst0 (CIntConst0 (CInteger0 (n, _, _), _))) = + if n < 0 + then error "micro_c_translate: negative literal loop bound not supported in bounded-for lowering" + else HOLogic.mk_nat (intinf_to_int_checked "for-loop bound literal" n) + | translate_pure_nat_expr tctx (CVar0 (ident, _)) = + let val name = C_Ast_Utils.ident_name ident + in case C_Trans_Ctxt.lookup_var tctx name of + SOME (C_Trans_Ctxt.Param, v, cty) => + if C_Ast_Utils.is_signed cty orelse C_Ast_Utils.is_bool cty orelse C_Ast_Utils.is_ptr cty + then error ("micro_c_translate: loop bound parameter must be unsigned integer: " ^ name) + else + (* Convert parameter (word) to nat for range *) + C_Term_Build.mk_unat v + | _ => error ("micro_c_translate: loop bound must be a parameter or literal: " ^ name) + end + | translate_pure_nat_expr _ _ = + error "micro_c_translate: unsupported loop bound expression" + + and try_translate_pure_nat_expr tctx e = + SOME (translate_pure_nat_expr tctx e) + handle ERROR _ => NONE + + (* Try to recognize: for (int i = start; i < bound; i++) body + Returns SOME (var_name, start_nat, bound_nat, body) or NONE *) + and try_bounded_for (CFor0 (Right init_decl, Some cond, Some step, body, _)) = + let fun step_var_name (CUnary0 (CPostIncOp0, CVar0 (v, _), _)) = + SOME (C_Ast_Utils.ident_name v) + | step_var_name (CUnary0 (CPreIncOp0, CVar0 (v, _), _)) = + SOME (C_Ast_Utils.ident_name v) + | step_var_name _ = NONE + in case (init_decl, cond, step_var_name step) of + (CDecl0 (_, [((Some declr, Some (CInitExpr0 (init_expr, _))), _)], _), + CBinary0 (CLeOp0, CVar0 (cond_var, _), bound_expr, _), + SOME step_name) => + let val var_name = C_Ast_Utils.declr_name declr + val cond_name = C_Ast_Utils.ident_name cond_var + in + if var_name = cond_name andalso var_name = step_name + then SOME (var_name, init_expr, bound_expr, body) + else NONE + end + | _ => NONE + end + | try_bounded_for _ = NONE + + (* C11 \
6.8.2: compound statement *) + and translate_stmt tctx (CCompound0 (_, items, _)) = + translate_compound_items tctx items + (* C11 \
6.8.6.4: return statement *) + | translate_stmt _ (CReturn0 (None, _)) = + C_Term_Build.mk_return_func C_Term_Build.mk_literal_unit + | translate_stmt tctx (CReturn0 (Some expr, _)) = + let val (term, expr_cty) = translate_expr tctx expr + val ret_term = case !current_ret_cty of + SOME ret_cty => mk_implicit_cast (term, expr_cty, ret_cty) + | NONE => term + in C_Term_Build.mk_return_func ret_term end + (* C11 \
6.8.3: expression statement *) + | translate_stmt tctx (CExpr0 (Some expr, _)) = + (* Expression statements are evaluated for side effects only. + Discard the return value by sequencing with unit. *) + C_Term_Build.mk_sequence (expr_term tctx expr) C_Term_Build.mk_literal_unit + | translate_stmt _ (CExpr0 (None, _)) = + C_Term_Build.mk_literal_unit + (* C11 \
6.8.4.1: if selection statement *) + | translate_stmt tctx (CIf0 (cond, then_br, Some else_br, _)) = + C_Term_Build.mk_two_armed_cond + (ensure_bool_cond tctx cond) (translate_stmt tctx then_br) (translate_stmt tctx else_br) + | translate_stmt tctx (CIf0 (cond, then_br, None, _)) = + C_Term_Build.mk_two_armed_cond + (ensure_bool_cond tctx cond) (translate_stmt tctx then_br) C_Term_Build.mk_literal_unit + (* C11 \
6.8.5.3: for iteration statement *) + | translate_stmt tctx (stmt as CFor0 (init_part, cond_opt, step_opt, body, _)) = + let + fun translate_general_for () = + let + fun cond_term_of tctx' = + (case cond_opt of + Some c => ensure_bool_cond tctx' c + | None => C_Term_Build.mk_literal + (Isa_Const (\<^const_name>\HOL.True\, @{typ bool}))) + fun step_term_of tctx' = + (case step_opt of + Some s => C_Term_Build.mk_sequence (expr_term tctx' s) C_Term_Build.mk_literal_unit + | None => C_Term_Build.mk_literal_unit) + fun expr_writes_name name (CAssign0 (_, CVar0 (ident, _), rhs, _)) = + C_Ast_Utils.ident_name ident = name orelse expr_writes_name name rhs + | expr_writes_name name (CAssign0 (_, lhs, rhs, _)) = + expr_writes_name name lhs orelse expr_writes_name name rhs + | expr_writes_name name (CUnary0 (CPreIncOp0, CVar0 (ident, _), _)) = + C_Ast_Utils.ident_name ident = name + | expr_writes_name name (CUnary0 (CPostIncOp0, CVar0 (ident, _), _)) = + C_Ast_Utils.ident_name ident = name + | expr_writes_name name (CUnary0 (CPreDecOp0, CVar0 (ident, _), _)) = + C_Ast_Utils.ident_name ident = name + | expr_writes_name name (CUnary0 (CPostDecOp0, CVar0 (ident, _), _)) = + C_Ast_Utils.ident_name ident = name + | expr_writes_name name (CBinary0 (_, l, r, _)) = + expr_writes_name name l orelse expr_writes_name name r + | expr_writes_name name (CUnary0 (_, e, _)) = + expr_writes_name name e + | expr_writes_name name (CIndex0 (a, i, _)) = + expr_writes_name name a orelse expr_writes_name name i + | expr_writes_name name (CMember0 (e, _, _, _)) = + expr_writes_name name e + | expr_writes_name name (CCast0 (_, e, _)) = + expr_writes_name name e + | expr_writes_name name (CCall0 (f, args, _)) = + expr_writes_name name f orelse List.exists (expr_writes_name name) args + | expr_writes_name name (CComma0 (es, _)) = + List.exists (expr_writes_name name) es + | expr_writes_name name (CCond0 (c, t, e, _)) = + expr_writes_name name c orelse + (case t of Some te => expr_writes_name name te | None => false) orelse + expr_writes_name name e + | expr_writes_name _ _ = false + fun loop_var_written_in_step name = + (case step_opt of + Some s => expr_writes_name name s + | None => false) + fun loop_var_needs_mutable_storage name = + loop_var_written_in_step name orelse + List.exists (fn n => n = name) (C_Ast_Utils.find_assigned_vars body) + fun build_while tctx' = + let val has_brk = contains_break body + val has_cont = contains_continue body + val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 + in if not has_brk andalso not has_cont then + let val cond_term = cond_term_of tctx' + val body_term = + C_Term_Build.mk_sequence (translate_stmt tctx' body) (step_term_of tctx') + val fuel_var = fresh_var [cond_term, body_term] "while_fuel" @{typ nat} + in C_Term_Build.mk_bounded_while fuel_var cond_term body_term end + else + let + val dummy_tctx = (if has_brk + then C_Trans_Ctxt.set_break_ref (Isa_Free ("__dummy_brk", isa_dummyT)) tctx' + else tctx') + val dummy_tctx = (if has_cont + then C_Trans_Ctxt.set_continue_ref (Isa_Free ("__dummy_cont", isa_dummyT)) dummy_tctx + else dummy_tctx) + val cond_raw = cond_term_of dummy_tctx + val body_raw = translate_stmt dummy_tctx body + val step_raw = step_term_of dummy_tctx + val flag_ref_ty = mk_flag_ref_type tctx' + val break_ref = if has_brk + then SOME (fresh_var [cond_raw, body_raw, step_raw] "v__for_break" flag_ref_ty) + else NONE + val continue_ref = if has_cont + then SOME (fresh_var [cond_raw, body_raw, step_raw] "v__for_cont" flag_ref_ty) + else NONE + val tctx_loop = case break_ref of + SOME b => C_Trans_Ctxt.set_break_ref b tctx' + | NONE => tctx' + val tctx_loop = case continue_ref of + SOME c => C_Trans_Ctxt.set_continue_ref c tctx_loop + | NONE => tctx_loop + val body_term = translate_stmt tctx_loop body + val step_term = step_term_of tctx_loop + val step_term = + (case break_ref of + SOME br => + let val bf = Isa_Free ("v__for_bf", isa_dummyT) + val bf_nonzero = + Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) + $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) + $ bf + $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) + in C_Term_Build.mk_bind + (mk_resolved_var_read (C_Trans_Ctxt.get_ctxt tctx_loop) br) + (Term.lambda bf + (C_Term_Build.mk_two_armed_cond + (C_Term_Build.mk_literal bf_nonzero) + C_Term_Build.mk_literal_unit + step_term)) + end + | NONE => step_term) + val cond_term = cond_term_of tctx_loop + val cond_term = + (case break_ref of + SOME br => + let val bf = Isa_Free ("v__for_bfc", isa_dummyT) + val bf_nonzero = + Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) + $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) + $ bf + $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) + in C_Term_Build.mk_bind + (mk_resolved_var_read (C_Trans_Ctxt.get_ctxt tctx_loop) br) + (Term.lambda bf + (C_Term_Build.mk_two_armed_cond + (C_Term_Build.mk_literal bf_nonzero) + (C_Term_Build.mk_literal + (Isa_Const (\<^const_name>\HOL.False\, @{typ bool}))) + cond_term)) + end + | NONE => cond_term) + val body_with_resets = + (case continue_ref of + SOME cr => + C_Term_Build.mk_sequence + (C_Term_Build.mk_var_write cr false_lit) + (C_Term_Build.mk_sequence body_term step_term) + | NONE => C_Term_Build.mk_sequence body_term step_term) + val fuel_var = fresh_var [cond_term, body_with_resets] "while_fuel" @{typ nat} + val loop_term = C_Term_Build.mk_bounded_while fuel_var cond_term body_with_resets + fun wrap_ref NONE t = t + | wrap_ref (SOME ref_var) t = + C_Term_Build.mk_bind + (mk_resolved_var_alloc (C_Trans_Ctxt.get_ctxt tctx') false_lit) + (Term.lambda ref_var t) + in wrap_ref break_ref (wrap_ref continue_ref loop_term) end + end + in + case init_part of + Left init_expr_opt => + (case init_expr_opt of + Some (assign_expr as CAssign0 (CAssignOp0, CVar0 (ident, _), rhs, _)) => + let + val name = C_Ast_Utils.ident_name ident + in case C_Trans_Ctxt.lookup_var tctx name of + SOME (kind0, _, cty) => + if C_Ast_Utils.is_ptr cty andalso + (case kind0 of + C_Trans_Ctxt.Param => true + | C_Trans_Ctxt.ParamListPtr => true + | _ => false) + then + let + val (rhs_term, rhs_cty) = translate_expr tctx rhs + val mutable_ptr = loop_var_needs_mutable_storage name + val rhs_list_backed = expr_is_list_backed_array tctx rhs + val init_term = + if mutable_ptr then + let + val rhs_cast = mk_implicit_cast (rhs_term, rhs_cty, cty) + in + if supports_raw_ptr_local_refs (C_Trans_Ctxt.get_ctxt tctx) + then + let + val rhs_raw = + mk_implicit_cast (rhs_cast, cty, C_Ast_Utils.CPtr C_Ast_Utils.CVoid) + val alloc_expr = + mk_resolved_var_alloc_typed + (C_Trans_Ctxt.get_ctxt tctx) + (raw_ptr_local_gref_typ ()) rhs_raw + val var = mk_typed_ref_var tctx name alloc_expr + val tctx' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.LocalPtr var cty tctx + val tctx' = (case struct_name_of_cty cty of + SOME sn => C_Trans_Ctxt.set_struct_type name sn tctx' + | NONE => tctx') + in + C_Term_Build.mk_bind alloc_expr + (Term.lambda var (build_while tctx')) + end + else + let + val val_type = + let val ty = expr_value_type rhs_cast + in if ty = isa_dummyT then expr_value_type rhs_term else ty end + val alloc_expr = + mk_resolved_var_alloc_typed + (C_Trans_Ctxt.get_ctxt tctx) val_type rhs_cast + val var = mk_typed_ref_var tctx name alloc_expr + val tctx' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.Local var cty tctx + val tctx' = (case struct_name_of_cty cty of + SOME sn => C_Trans_Ctxt.set_struct_type name sn tctx' + | NONE => tctx') + in + C_Term_Build.mk_bind alloc_expr + (Term.lambda var (build_while tctx')) + end + end + else + let + val var = Isa_Free (name, pointer_alias_var_ty tctx rhs_list_backed cty rhs_term) + val kind = pointer_alias_kind rhs_list_backed + val tctx' = C_Trans_Ctxt.add_var name kind var cty tctx + in + C_Term_Build.mk_bind rhs_term + (Term.lambda var (build_while tctx')) + end + in + init_term + end + else + let + val init_term = expr_term tctx assign_expr + in + C_Term_Build.mk_sequence init_term (build_while tctx) + end + | _ => + let + val init_term = expr_term tctx assign_expr + in + C_Term_Build.mk_sequence init_term (build_while tctx) + end + end + | Some e => + let val init_term = expr_term tctx e + in C_Term_Build.mk_sequence init_term (build_while tctx) end + | None => build_while tctx) + | Right init_decl => + let val decls = translate_decl tctx init_decl + fun fold_decls [] tctx' = build_while tctx' + | fold_decls ((name, init, cty, arr_meta, alias_list_backed) :: ds) tctx' = + if C_Ast_Utils.is_ptr cty andalso not (Option.isSome arr_meta) then + if supports_raw_ptr_local_refs (C_Trans_Ctxt.get_ctxt tctx') andalso + not (prefer_pointer_alias_storage alias_list_backed init) then + let + val raw_ptr_ty = raw_ptr_local_gref_typ () + val stored_init = + if is_uninitialized_literal init then init + else mk_implicit_cast (init, cty, C_Ast_Utils.CPtr C_Ast_Utils.CVoid) + val alloc_expr = + mk_resolved_var_alloc_typed (C_Trans_Ctxt.get_ctxt tctx') raw_ptr_ty stored_init + val var = mk_typed_ref_var tctx' name alloc_expr + val tctx'' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.LocalPtr var cty tctx' + val tctx'' = (case struct_name_of_cty cty of + SOME sn => C_Trans_Ctxt.set_struct_type name sn tctx'' + | NONE => tctx'') + val tctx'' = (case arr_meta of + SOME (elem_cty, n) => C_Trans_Ctxt.set_array_decl name elem_cty n tctx'' + | NONE => tctx'') + in C_Term_Build.mk_bind alloc_expr + (Term.lambda var (fold_decls ds tctx'')) end + else + let + val var = Isa_Free (name, pointer_alias_var_ty tctx' alias_list_backed cty init) + val kind = pointer_alias_kind alias_list_backed + val tctx'' = C_Trans_Ctxt.add_var name kind var cty tctx' + val tctx'' = (case struct_name_of_cty cty of + SOME sn => C_Trans_Ctxt.set_struct_type name sn tctx'' + | NONE => tctx'') + val tctx'' = (case arr_meta of + SOME (elem_cty, n) => C_Trans_Ctxt.set_array_decl name elem_cty n tctx'' + | NONE => tctx'') + in if is_uninitialized_literal init then + fold_decls ds tctx'' + else + C_Term_Build.mk_bind init + (Term.lambda var (fold_decls ds tctx'')) + end + else + let val val_type = + let val ty = C_Ast_Utils.hol_type_of cty + in if ty = isa_dummyT then expr_value_type init else ty end + val alloc_expr = + mk_resolved_var_alloc_typed (C_Trans_Ctxt.get_ctxt tctx') val_type init + val var = mk_typed_ref_var tctx' name alloc_expr + val tctx'' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.Local var cty tctx' + val tctx'' = (case struct_name_of_cty cty of + SOME sn => C_Trans_Ctxt.set_struct_type name sn tctx'' + | NONE => tctx'') + val tctx'' = (case arr_meta of + SOME (elem_cty, n) => C_Trans_Ctxt.set_array_decl name elem_cty n tctx'' + | NONE => tctx'') + in C_Term_Build.mk_bind alloc_expr + (Term.lambda var (fold_decls ds tctx'')) end + in fold_decls decls tctx end + end + in + case try_bounded_for stmt of + SOME (var_name, init_c_expr, bound_c_expr, body) => + let + val body_assigned = C_Ast_Utils.find_assigned_vars body + val loop_var_mutated_or_escaped = + List.exists (fn n => n = var_name) body_assigned + in + if contains_break body orelse contains_continue body orelse loop_var_mutated_or_escaped then + translate_general_for () + else + let + val loop_cty = + (case stmt of + CFor0 (Right (CDecl0 (specs, [((Some declr, _), _)], _)), _, _, _, _) => + let + val base_cty = + (case C_Ast_Utils.resolve_c_type_full + (C_Trans_Ctxt.get_typedef_tab tctx) specs of + SOME C_Ast_Utils.CVoid => C_Ast_Utils.CInt + | SOME t => t + | NONE => C_Ast_Utils.CInt) + in + C_Ast_Utils.apply_ptr_depth base_cty + (C_Ast_Utils.pointer_depth_of_declr declr) + end + | _ => C_Ast_Utils.CInt) + val is_unsigned_loop = + not (C_Ast_Utils.is_signed loop_cty) andalso + not (C_Ast_Utils.is_bool loop_cty) andalso + not (C_Ast_Utils.is_ptr loop_cty) + fun build_for_loop start_nat bound_nat = + let + val loop_hol_ty = C_Ast_Utils.hol_type_of loop_cty + val loop_var = Isa_Free (var_name, loop_hol_ty) + val tctx' = + C_Trans_Ctxt.add_var var_name C_Trans_Ctxt.Param loop_var loop_cty tctx + val body_term = translate_stmt tctx' body + val range = C_Term_Build.mk_upt_int_range start_nat bound_nat + in + C_Term_Build.mk_raw_for_loop range (Term.lambda loop_var body_term) + end + in + if not is_unsigned_loop then translate_general_for () + else + (case (try_translate_pure_nat_expr tctx init_c_expr, + try_translate_pure_nat_expr tctx bound_c_expr) of + (SOME start_nat, SOME bound_nat) => + build_for_loop start_nat bound_nat + | (SOME start_nat, NONE) => + (* Bound is not a pure nat — evaluate monadically and use unat as fuel *) + let val (bound_term, bound_cty) = translate_expr tctx bound_c_expr + in if C_Ast_Utils.is_unsigned_int bound_cty then + let val bound_var = Isa_Free ("v__bound", C_Ast_Utils.hol_type_of bound_cty) + in C_Term_Build.mk_bind bound_term + (Term.lambda bound_var + (build_for_loop start_nat (C_Term_Build.mk_unat bound_var))) + end + else translate_general_for () + end + | _ => translate_general_for ()) + end + end + | NONE => translate_general_for () + end + (* C11 \
6.8.5.1/\
6.8.5.2: while/do-while iteration statement *) + | translate_stmt tctx (CWhile0 (cond, body_stmt, is_do_while, _)) = + let val has_brk = contains_break body_stmt + val has_cont = contains_continue body_stmt + val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 + in if not has_brk andalso not has_cont then + (* Simple case: no break/continue *) + let val cond_term = ensure_bool_cond tctx cond + val body_term = translate_stmt tctx body_stmt + val fuel_var = fresh_var [cond_term, body_term] "while_fuel" @{typ nat} + val while_term = C_Term_Build.mk_bounded_while fuel_var cond_term body_term + in if is_do_while + then C_Term_Build.mk_sequence body_term while_term + else while_term + end + else + (* Allocate break/continue flag refs *) + let (* Pre-set dummy refs so first-pass translation doesn't warn *) + val flag_ref_ty = mk_flag_ref_type tctx + val dummy_tctx = (if has_brk + then C_Trans_Ctxt.set_break_ref (Isa_Free ("__dummy_brk", flag_ref_ty)) tctx + else tctx) + val dummy_tctx = (if has_cont + then C_Trans_Ctxt.set_continue_ref (Isa_Free ("__dummy_cont", flag_ref_ty)) dummy_tctx + else dummy_tctx) + val cond_term_raw = ensure_bool_cond dummy_tctx cond + val body_raw = translate_stmt dummy_tctx body_stmt + val break_ref = if has_brk + then SOME (fresh_var [cond_term_raw, body_raw] "v__break" flag_ref_ty) + else NONE + val continue_ref = if has_cont + then SOME (fresh_var [cond_term_raw, body_raw] "v__cont" flag_ref_ty) + else NONE + (* Update context *) + val tctx' = case break_ref of + SOME b => C_Trans_Ctxt.set_break_ref b tctx | NONE => tctx + val tctx' = case continue_ref of + SOME c => C_Trans_Ctxt.set_continue_ref c tctx' | NONE => tctx' + (* Re-translate body with updated context (guards will be inserted) *) + val body_term = translate_stmt tctx' body_stmt + val cond_term = ensure_bool_cond tctx' cond + (* Augment condition: if break_flag then False else original_cond *) + val augmented_cond = case break_ref of + SOME br => + let val bf = Isa_Free ("v__bf", isa_dummyT) + val bf_nonzero = + Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) + $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) + $ bf + $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) + in C_Term_Build.mk_bind (C_Term_Build.mk_var_read br) + (Term.lambda bf + (C_Term_Build.mk_two_armed_cond + (C_Term_Build.mk_literal bf_nonzero) + (C_Term_Build.mk_literal + (Isa_Const (\<^const_name>\HOL.False\, @{typ bool}))) + cond_term)) + end + | NONE => cond_term + (* For continue: reset flag at start of each iteration *) + val body_with_resets = case continue_ref of + SOME cr => + C_Term_Build.mk_sequence + (C_Term_Build.mk_var_write cr false_lit) body_term + | NONE => body_term + val fuel_var = fresh_var [augmented_cond, body_with_resets] + "while_fuel" @{typ nat} + val while_term = C_Term_Build.mk_bounded_while + fuel_var augmented_cond body_with_resets + val loop_term = if is_do_while + then C_Term_Build.mk_sequence body_with_resets while_term + else while_term + (* Wrap in Ref::new for break/continue refs *) + fun wrap_ref NONE t = t + | wrap_ref (SOME ref_var) t = + C_Term_Build.mk_bind + (mk_resolved_var_alloc (C_Trans_Ctxt.get_ctxt tctx) false_lit) + (Term.lambda ref_var t) + in wrap_ref break_ref (wrap_ref continue_ref loop_term) end + end + (* C11 \
6.8.4.2: switch selection statement *) + | translate_stmt tctx (CSwitch0 (switch_expr, body, _)) = + let val (switch_term_raw, switch_cty_raw) = translate_expr tctx switch_expr + val switch_cty = C_Ast_Utils.integer_promote switch_cty_raw + val switch_term = mk_implicit_cast (switch_term_raw, switch_cty_raw, switch_cty) + val switch_var = fresh_var [switch_term] "v__switch" isa_dummyT + val items = case body of + CCompound0 (_, items, _) => items + | _ => [CBlockStmt0 body] + val groups = extract_switch_groups items + val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 + val true_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 1 + val flag_ref_ty = mk_flag_ref_type tctx + val switch_break_ref = fresh_var [switch_term] "v__switch_break" flag_ref_ty + (* break inside switch exits this switch, not any enclosing loop *) + val tctx_sw = C_Trans_Ctxt.set_break_ref switch_break_ref + (C_Trans_Ctxt.clear_break_ref tctx) + val all_have_break = List.all #has_break groups + orelse List.length groups <= 1 + val any_case_match = make_any_case_match switch_var switch_cty tctx groups + val default_cond = Isa_Const (\<^const_name>\HOL.Not\, @{typ bool} --> @{typ bool}) $ any_case_match + val brk = Isa_Free ("v__sw_break", isa_dummyT) + val break_nonzero = + Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) + $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) + $ brk + $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) + fun guard_break inner = + C_Term_Build.mk_bind + (mk_resolved_var_read (C_Trans_Ctxt.get_ctxt tctx_sw) switch_break_ref) + (Term.lambda brk + (C_Term_Build.mk_two_armed_cond + (C_Term_Build.mk_literal break_nonzero) + C_Term_Build.mk_literal_unit + inner)) + in C_Term_Build.mk_bind + (mk_resolved_var_alloc (C_Trans_Ctxt.get_ctxt tctx) false_lit) + (Term.lambda switch_break_ref + (if all_have_break then + (* Simple if-else chain: no fall-through *) + let fun build_chain [] = C_Term_Build.mk_literal_unit + | build_chain ({labels, body, ...} :: rest) = + let val body_term = translate_compound_items tctx_sw body + val rest_term = build_chain rest + val cond = C_Term_Build.mk_literal + (make_switch_cond switch_var switch_cty tctx default_cond labels) + in C_Term_Build.mk_two_armed_cond cond body_term rest_term end + in C_Term_Build.mk_bind switch_term + (Term.lambda switch_var (build_chain groups)) + end + else + (* Fall-through: use matched_ref *) + let val matched_ref = fresh_var [switch_term] "v__matched" flag_ref_ty + val matched_var = Isa_Free ("v__m", isa_dummyT) + val matched_nonzero = + Isa_Const (\<^const_name>\HOL.Not\, isa_dummyT) + $ (Isa_Const (\<^const_name>\HOL.eq\, isa_dummyT) + $ matched_var + $ Isa_Const (\<^const_name>\Groups.zero_class.zero\, isa_dummyT)) + fun build_groups [] = C_Term_Build.mk_literal_unit + | build_groups ({labels, body, has_break} :: rest) = + let val body_term = translate_compound_items tctx_sw body + val label_cond = + make_switch_cond switch_var switch_cty tctx default_cond labels + val full_cond = + Isa_Const (\<^const_name>\HOL.disj\, + @{typ bool} --> @{typ bool} --> @{typ bool}) + $ matched_nonzero $ label_cond + val group_action = + C_Term_Build.mk_sequence body_term + (if has_break + then C_Term_Build.mk_var_write matched_ref false_lit + else C_Term_Build.mk_var_write matched_ref true_lit) + val group_term = + C_Term_Build.mk_bind (C_Term_Build.mk_var_read matched_ref) + (Term.lambda matched_var + (C_Term_Build.mk_two_armed_cond + (C_Term_Build.mk_literal full_cond) + group_action C_Term_Build.mk_literal_unit)) + in guard_break (C_Term_Build.mk_sequence group_term (build_groups rest)) end + in C_Term_Build.mk_bind switch_term + (Term.lambda switch_var + (C_Term_Build.mk_bind + (mk_resolved_var_alloc (C_Trans_Ctxt.get_ctxt tctx) false_lit) + (Term.lambda matched_ref (build_groups groups)))) + end)) + end + (* C11 \
6.8.6.1: goto statement *) + | translate_stmt tctx (CGoto0 (ident, _)) = + let val name = C_Ast_Utils.ident_name ident + val is_active_target = + List.exists (fn n => n = name) (C_Trans_Ctxt.get_active_goto_labels tctx) + in case C_Trans_Ctxt.lookup_goto_ref tctx name of + SOME goto_ref => + if is_active_target then + C_Term_Build.mk_var_write goto_ref + (C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 1) + else + unsupported ("goto to label in incompatible scope: " ^ name) + | NONE => unsupported ("goto target not found: " ^ name) + end + (* C11 \
6.8.1: labeled statement *) + | translate_stmt tctx (CLabel0 (_, stmt, _, _)) = + (* Labels as standalone statements (not in compound block context): + just translate the labeled statement. The label flag reset is handled + by translate_compound_items when the label appears in a block. *) + translate_stmt tctx stmt + (* C11 \
6.8.6.2: continue statement *) + | translate_stmt tctx (CCont0 _) = + (case C_Trans_Ctxt.get_continue_ref tctx of + SOME cont_ref => + C_Term_Build.mk_var_write cont_ref + (C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 1) + | NONE => unsupported "continue outside loop") + (* C11 \
6.8.6.3: break statement *) + | translate_stmt tctx (CBreak0 _) = + (case C_Trans_Ctxt.get_break_ref tctx of + SOME break_ref => + C_Term_Build.mk_var_write break_ref + (C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 1) + | NONE => unsupported "break outside loop/switch") + | translate_stmt _ _ = + unsupported "statement" + + local + fun expr_writes_in_loop (CAssign0 (_, CVar0 (ident, _), rhs, _)) acc = + expr_writes_in_loop rhs (C_Ast_Utils.ident_name ident :: acc) + | expr_writes_in_loop (CAssign0 (_, lhs, rhs, _)) acc = + expr_writes_in_loop rhs (expr_writes_in_loop lhs acc) + | expr_writes_in_loop (CUnary0 (CPreIncOp0, CVar0 (ident, _), _)) acc = + C_Ast_Utils.ident_name ident :: acc + | expr_writes_in_loop (CUnary0 (CPostIncOp0, CVar0 (ident, _), _)) acc = + C_Ast_Utils.ident_name ident :: acc + | expr_writes_in_loop (CUnary0 (CPreDecOp0, CVar0 (ident, _), _)) acc = + C_Ast_Utils.ident_name ident :: acc + | expr_writes_in_loop (CUnary0 (CPostDecOp0, CVar0 (ident, _), _)) acc = + C_Ast_Utils.ident_name ident :: acc + | expr_writes_in_loop (CBinary0 (_, l, r, _)) acc = + expr_writes_in_loop r (expr_writes_in_loop l acc) + | expr_writes_in_loop (CUnary0 (_, e, _)) acc = expr_writes_in_loop e acc + | expr_writes_in_loop (CIndex0 (a, i, _)) acc = + expr_writes_in_loop i (expr_writes_in_loop a acc) + | expr_writes_in_loop (CMember0 (e, _, _, _)) acc = expr_writes_in_loop e acc + | expr_writes_in_loop (CCast0 (_, e, _)) acc = expr_writes_in_loop e acc + | expr_writes_in_loop (CCall0 (f, args, _)) acc = + List.foldl (fn (a, ac) => expr_writes_in_loop a ac) (expr_writes_in_loop f acc) args + | expr_writes_in_loop (CComma0 (es, _)) acc = + List.foldl (fn (e, ac) => expr_writes_in_loop e ac) acc es + | expr_writes_in_loop (CCond0 (c, t, e, _)) acc = + expr_writes_in_loop e + ((case t of Some te => expr_writes_in_loop te | None => I) + (expr_writes_in_loop c acc)) + | expr_writes_in_loop _ acc = acc + + fun loop_decl_writes (CDecl0 (_, declarators, _)) acc = + List.foldl + (fn (((_, Some (CInitExpr0 (e, _))), _), ac) => expr_writes_in_loop e ac + | (((_, Some (CInitList0 (inits, _))), _), ac) => + List.foldl (fn ((_, init), ac') => + (case init of + CInitExpr0 (e, _) => expr_writes_in_loop e ac' + | CInitList0 _ => ac')) + ac inits + | (_, ac) => ac) + acc declarators + | loop_decl_writes _ acc = acc + + fun loop_item_writes (CBlockStmt0 s) acc = loop_stmt_writes s acc + | loop_item_writes (CBlockDecl0 d) acc = loop_decl_writes d acc + | loop_item_writes _ acc = acc + + and loop_stmt_writes (CCompound0 (_, items, _)) acc = + List.foldl (fn (it, ac) => loop_item_writes it ac) acc items + | loop_stmt_writes (CExpr0 (Some e, _)) acc = expr_writes_in_loop e acc + | loop_stmt_writes (CReturn0 (Some e, _)) acc = expr_writes_in_loop e acc + | loop_stmt_writes (CIf0 (c, t, e_opt, _)) acc = + let + val acc = expr_writes_in_loop c acc + val acc = loop_stmt_writes t acc + in case e_opt of Some e => loop_stmt_writes e acc | None => acc end + | loop_stmt_writes (CWhile0 (c, b, _, _)) acc = + loop_stmt_writes b (expr_writes_in_loop c acc) + | loop_stmt_writes (CFor0 (init, c, s, b, _)) acc = + let + val acc = + (case init of + Left (Some e) => expr_writes_in_loop e acc + | Right d => loop_decl_writes d acc + | _ => acc) + val acc = (case c of Some e => expr_writes_in_loop e acc | None => acc) + val acc = (case s of Some e => expr_writes_in_loop e acc | None => acc) + in loop_stmt_writes b acc end + | loop_stmt_writes (CSwitch0 (e, s, _)) acc = + loop_stmt_writes s (expr_writes_in_loop e acc) + | loop_stmt_writes (CCase0 (e, s, _)) acc = + loop_stmt_writes s (expr_writes_in_loop e acc) + | loop_stmt_writes (CDefault0 (s, _)) acc = loop_stmt_writes s acc + | loop_stmt_writes (CLabel0 (_, s, _, _)) acc = loop_stmt_writes s acc + | loop_stmt_writes _ acc = acc + in + fun find_loop_written_vars_local stmt = distinct (op =) (loop_stmt_writes stmt []) + end + + val _ = stmt_expr_translate_ref := translate_compound_items_expr + + fun translate_fundef struct_tab enum_tab typedef_tab func_ret_types func_param_types global_consts ctxt + (CFunDef0 (specs, declr, _, body, _)) = + let + val _ = current_visible_ctxt := SOME ctxt + val name = C_Ast_Utils.declr_name declr + val _ = + if C_Ast_Utils.declr_is_variadic declr then + unsupported ("variadic functions are not supported: " ^ name) + else () + (* Register the function's return type for cross-function call type tracking *) + val ret_base_cty = (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME C_Ast_Utils.CVoid => C_Ast_Utils.CVoid + | SOME t => t | NONE => C_Ast_Utils.CInt) + val ret_cty = C_Ast_Utils.apply_ptr_depth ret_base_cty + (C_Ast_Utils.pointer_depth_of_declr declr) + val _ = func_ret_types := Symtab.update (name, ret_cty) (! func_ret_types) + val param_names = C_Ast_Utils.extract_params declr + val param_decls = C_Ast_Utils.extract_param_decls declr + val struct_names = Symtab.keys struct_tab + val union_names = !current_union_names + (* Extract parameter types and pointer-ness from declarations. + Use resolve_c_type_full so that typedef'd types (e.g. uint32) resolve + correctly to their underlying C type for signed/unsigned dispatch. *) + val param_info = List.map (fn pdecl => + let + val cty = case pdecl of + CDecl0 (specs, _, _) => + (case C_Ast_Utils.resolve_c_type_full typedef_tab specs of + SOME t => t + | NONE => + (case C_Ast_Utils.extract_struct_type_from_decl_full struct_names pdecl of + SOME sn => C_Ast_Utils.CStruct sn + | NONE => + (case C_Ast_Utils.extract_union_type_from_decl_full union_names pdecl of + SOME un => C_Ast_Utils.CUnion un + | NONE => C_Ast_Utils.CInt))) + | _ => C_Ast_Utils.CInt + val ptr_depth = C_Ast_Utils.pointer_depth_of_decl pdecl + val reg_cty = C_Ast_Utils.apply_ptr_depth cty ptr_depth + in reg_cty end) param_decls + (* Pair names with type info; fall back to (CInt, false) if lengths differ *) + val param_name_info = ListPair.zipEq (param_names, param_info) + handle ListPair.UnequalLengths => + List.map (fn n => (n, C_Ast_Utils.CInt)) param_names + val param_list_backed_modes = + (case Symtab.lookup (!current_list_backed_param_modes) name of + SOME modes => + if List.length modes = List.length param_name_info then modes + else List.map (K false) param_name_info + | NONE => List.map (K false) param_name_info) + (* Create free variables for each parameter. + List-backed decay parameters must stay concretely list-backed so helper + extraction keeps working; other pointers remain inference-driven except + raw void/union pointers, which need a stable representation. *) + fun param_value_hol_ty list_backed cty = + if list_backed then + (case list_backed_pointer_value_hol_ty cty of + SOME ty => ty + | NONE => isa_dummyT) + else + (case cty of + C_Ast_Utils.CPtr C_Ast_Utils.CVoid => + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) cty of + SOME ty => ty + | NONE => isa_dummyT) + | C_Ast_Utils.CPtr (C_Ast_Utils.CUnion _) => + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) cty of + SOME ty => ty + | NONE => isa_dummyT) + | _ => + if C_Ast_Utils.is_ptr cty then isa_dummyT else C_Ast_Utils.hol_type_of cty) + val param_vars = + ListPair.mapEq (fn ((n, cty), list_backed) => + let val hol_ty = param_value_hol_ty list_backed cty + in (n, Isa_Free (n, hol_ty), cty, list_backed) end) + (param_name_info, param_list_backed_modes) + handle ListPair.UnequalLengths => + List.map (fn (n, cty) => + let val hol_ty = param_value_hol_ty false cty + in (n, Isa_Free (n, hol_ty), cty, false) end) param_name_info + (* Add parameters to the translation context as Param/ParamListPtr. *) + val tctx = List.foldl + (fn ((n, v, cty, list_backed), ctx) => + C_Trans_Ctxt.add_var n + (if list_backed then C_Trans_Ctxt.ParamListPtr else C_Trans_Ctxt.Param) + v cty ctx) + (C_Trans_Ctxt.make ctxt struct_tab enum_tab typedef_tab func_ret_types func_param_types + (!current_ref_addr_ty) (!current_ref_gv_ty)) param_vars + val tctx = List.foldl (fn ((gname, gterm, gcty, garr_meta, gstruct), ctx) => + let + val ctx' = C_Trans_Ctxt.add_global_const gname gterm gcty ctx + val ctx' = (case gstruct of + SOME sn => C_Trans_Ctxt.set_struct_type gname sn ctx' + | NONE => ctx') + val ctx' = (case garr_meta of + SOME (elem_cty, n) => C_Trans_Ctxt.set_array_decl gname elem_cty n ctx' + | NONE => ctx') + in ctx' end) + tctx global_consts + (* Annotate struct pointer parameters with their struct type. + Uses _full variant to also recognize typedef'd struct names. *) + val tctx = List.foldl (fn (pdecl, ctx) => + case (C_Ast_Utils.param_name pdecl, + C_Ast_Utils.extract_struct_type_from_decl_full struct_names pdecl) of + (SOME n, SOME sn) => C_Trans_Ctxt.set_struct_type n sn ctx + | _ => + (case (C_Ast_Utils.param_name pdecl, + C_Ast_Utils.extract_union_type_from_decl_full union_names pdecl) of + (SOME n, SOME un) => C_Trans_Ctxt.set_struct_type n un ctx + | _ => ctx)) tctx param_decls + (* Promote parameters that are assigned in the body to local variables. + For each promoted parameter, wrap the body with Ref::new(literal param) + and register the ref as a Local in the context (shadowing the Param). *) + val assigned_names = C_Ast_Utils.find_assigned_vars body + val _ = current_loop_written_vars := find_loop_written_vars_local body + val promoted_params = List.filter (fn (n, _, _, _) => + List.exists (fn a => a = n) assigned_names) param_vars + val (tctx, promoted_bindings) = List.foldl + (fn ((n, orig_var, cty, list_backed), (ctx, binds)) => + let + val use_raw_ptr = + C_Ast_Utils.is_ptr cty andalso + supports_raw_ptr_local_refs (C_Trans_Ctxt.get_ctxt ctx) andalso + not list_backed + val (kind, alloc_expr) = + if use_raw_ptr then + (C_Trans_Ctxt.LocalPtr, + mk_resolved_var_alloc_typed (C_Trans_Ctxt.get_ctxt ctx) (raw_ptr_local_gref_typ ()) + (mk_implicit_cast (C_Term_Build.mk_literal orig_var, cty, C_Ast_Utils.CPtr C_Ast_Utils.CVoid))) + else + let + val val_type = + let val ty = fastype_of orig_var + in if ty = isa_dummyT then C_Ast_Utils.hol_type_of cty else ty end + in + (C_Trans_Ctxt.Local, + mk_resolved_var_alloc_typed (C_Trans_Ctxt.get_ctxt ctx) val_type + (C_Term_Build.mk_literal orig_var)) + end + val ref_var = mk_typed_ref_var ctx (n ^ "_ref") alloc_expr + val ctx' = C_Trans_Ctxt.add_var n kind ref_var cty ctx + in (ctx', binds @ [(ref_var, alloc_expr)]) end) + (tctx, []) promoted_params + (* Allocate goto flag references for forward-only goto support. + Each label targeted by a goto gets a flag ref initialized to 0. *) + val goto_labels = C_Ast_Utils.find_goto_targets body + val goto_ref_ty = mk_flag_ref_type tctx + val goto_refs = List.map (fn label_name => + (label_name, Isa_Free ("v__goto_" ^ label_name, goto_ref_ty))) goto_labels + val tctx = C_Trans_Ctxt.set_goto_refs goto_refs tctx + (* Set current return type for implicit narrowing in CReturn0 *) + val _ = current_ret_cty := SOME ret_cty + val body_term = translate_stmt tctx body + (* Wrap body with Ref::new for each promoted parameter *) + val body_term = List.foldr + (fn ((ref_var, alloc_expr), b) => + C_Term_Build.mk_bind + alloc_expr + (Term.lambda ref_var b)) + body_term promoted_bindings + (* Wrap body with Ref::new(0) for each goto flag ref *) + val false_lit = C_Term_Build.mk_literal_num C_Ast_Utils.CUInt 0 + val body_term = List.foldr + (fn ((_, ref_var), b) => + C_Term_Build.mk_bind + (mk_resolved_var_alloc ctxt false_lit) + (Term.lambda ref_var b)) + body_term goto_refs + (* Constrain body side types from locale *) + val body_term = + (case !current_ref_expr_constraint of + NONE => body_term + | SOME expr_ty => Type.constraint expr_ty body_term) + (* Pin value AND return type. FunctionBody requires value=return. + For pointer-returning functions, also check pointer_expr_value_hol_ty. *) + fun ret_hol_ty_of ret_cty = + (case ret_cty of + C_Ast_Utils.CPtr _ => NONE + | _ => + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) ret_cty of + SOME ty => SOME ty + | NONE => + let val ty = C_Ast_Utils.hol_type_of ret_cty + in if ty = isa_dummyT then NONE else SOME ty end)) + val body_term = + let val ret_ty_opt = + (case ret_cty of + C_Ast_Utils.CVoid => SOME @{typ unit} + | _ => ret_hol_ty_of ret_cty) + in case ret_ty_opt of + SOME ret_ty => + (case fastype_of body_term of + Term.Type (ename, [s, _, _, a, i, o]) => + Type.constraint + (Term.Type (ename, [s, ret_ty, ret_ty, a, i, o])) + body_term + | _ => constrain_known_expr_value_type ret_ty body_term) + | NONE => body_term + end + val fn_term = C_Term_Build.mk_function_body body_term + (* Wrap in lambdas for each parameter *) + val fn_term = List.foldr + (fn ((_, v, _, _), t) => Term.lambda v t) + fn_term param_vars + (* Abstract while-loop fuel variables as additional parameters *) + val fuel_frees = Isa_add_frees fn_term [] + |> List.filter (fn (n, _) => String.isPrefix "while_fuel" n) + |> List.map (fn (n, ty) => Isa_Free (n, ty)) + val fuel_count = List.length fuel_frees + val _ = if fuel_count > 0 then + (defined_func_fuels := + Symtab.update (!current_decl_prefix ^ name, fuel_count) (!defined_func_fuels); + writeln (" fuel params: " ^ Int.toString fuel_count)) + else () + val fn_term = List.foldr (fn (v, t) => Term.lambda v t) fn_term fuel_frees + fun mk_fun_ty (arg_ty, res_ty) = Isa_Type (\<^type_name>\fun\, [arg_ty, res_ty]) + val fn_term = + let + val all_arg_tys = + List.map fastype_of fuel_frees @ + List.map (fn (_, v, _, _) => fastype_of v) param_vars + val fn_sig_ty = List.foldr mk_fun_ty (fastype_of (C_Term_Build.mk_function_body body_term)) all_arg_tys + in Type.constraint fn_sig_ty fn_term end + val fn_term' = Syntax.check_term ctxt fn_term + in + (name, fn_term') + end +end +\ + +end diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy new file mode 100644 index 00000000..ef89bb36 --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy @@ -0,0 +1,151 @@ +theory C_Translation_Smoke_Advanced + imports + C_To_Core_Translation + "Shallow_Separation_Logic.Separation_Algebra" +begin + +section \Advanced Feature Translation Smoke\ + +text \Smoke tests for features not covered by the core/control/memory/types suites.\ + +subsection \String Literals\ + +micro_c_translate addr: nat \ +void smoke_adv_string_init(void) { + char s[] = "Hi"; + char c = s[0]; +} +\ + +thm c_smoke_adv_string_init_def + +subsection \Compound Literals\ + +micro_c_translate \ +unsigned int smoke_adv_compound_lit(void) { + unsigned int x = (unsigned int){42}; + return x; +} +\ + +thm c_smoke_adv_compound_lit_def + +subsection \sizeof(expr)\ + +micro_c_translate \ +typedef unsigned long size_t; +size_t smoke_adv_sizeof_int(void) { + return sizeof(int); +} +\ + +thm c_smoke_adv_sizeof_int_def + +micro_c_translate \ +struct smoke_adv_pair { + int x; + int y; +}; +typedef unsigned long smoke_adv_size_t; +smoke_adv_size_t smoke_adv_sizeof_struct(void) { + return sizeof(struct smoke_adv_pair); +} +\ + +thm c_smoke_adv_sizeof_struct_def + +subsection \Chained Struct-Array Access\ + +micro_c_translate addr: nat \ +struct smoke_adv_vec { + int data[4]; +}; +int smoke_adv_struct_arr_read(struct smoke_adv_vec *v, unsigned int i) { + return v->data[i]; +} +\ + +thm c_smoke_adv_struct_arr_read_def + +subsection \_Generic Selection\ + +micro_c_translate \ +unsigned int smoke_adv_generic(unsigned int x) { + return _Generic(x, unsigned int: x + 1, int: (unsigned int)(x - 1)); +} +\ + +thm c_smoke_adv_generic_def + +subsection \_Alignof\ + +micro_c_translate \ +typedef unsigned long smoke_adv_al_size_t; +smoke_adv_al_size_t smoke_adv_alignof_int(void) { + return _Alignof(int); +} +\ + +thm c_smoke_adv_alignof_int_def + +subsection \__builtin_offsetof\ + +micro_c_translate \ +struct smoke_adv_offset_pair { int x; int y; }; +typedef unsigned long smoke_adv_off_size_t; +smoke_adv_off_size_t smoke_adv_offsetof(void) { + return __builtin_offsetof(struct smoke_adv_offset_pair, y); +} +\ + +thm c_smoke_adv_offsetof_def + +subsection \Range Designators in Array Initializers\ + +micro_c_translate \ +static unsigned int smoke_adv_range_init[8] = { [2 ... 5] = 42 }; +unsigned int smoke_adv_range_lookup(unsigned int i) { + return smoke_adv_range_init[i]; +} +\ + +thm c_smoke_adv_range_lookup_def + +subsection \Struct Compound Literals\ + +micro_c_translate addr: nat \ +struct smoke_adv_compound_lit_pt { int x; int y; }; +void smoke_adv_struct_compound_lit(struct smoke_adv_compound_lit_pt *out) { + *out = (struct smoke_adv_compound_lit_pt){10, 20}; +} +\ + +thm c_smoke_adv_struct_compound_lit_def + +subsection \Statement Expressions\ + +micro_c_translate \ +unsigned int smoke_adv_stmt_expr(unsigned int a, unsigned int b) { + unsigned int m = ({ + unsigned int t; + if (a > b) t = a; else t = b; + t; + }); + return m; +} +\ + +thm c_smoke_adv_stmt_expr_def + +subsection \3D Array Initialization\ + +micro_c_translate \ +static int smoke_adv_3d[2][2][2] = {{{1,2},{3,4}},{{5,6},{7,8}}}; +int smoke_adv_3d_read(unsigned int i, unsigned int j, unsigned int k) { + return smoke_adv_3d[i][j][k]; +} +\ + +thm c_smoke_adv_3d_read_def + +end diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Compiler.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Compiler.thy new file mode 100644 index 00000000..ac33b1b7 --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Compiler.thy @@ -0,0 +1,65 @@ +theory C_Translation_Smoke_Compiler + imports + C_To_Core_Translation +begin + +section \Compiler Profile Smoke Tests\ + +text \Verify that @{text "compiler:"} parameter selects the expected behavior + for char signedness, signed right shift, and signed narrowing casts.\ + +subsection \Char signedness\ + +text \Under @{text "gcc-x86_64"}, plain @{text "char"} is signed.\ + +micro_c_translate prefix: comp_x86_ compiler: gcc-x86_64 \ +char comp_char_id(char c) { return c; } +\ + +thm comp_x86_comp_char_id_def + +text \Under @{text "gcc-aarch64"}, plain @{text "char"} is unsigned.\ + +micro_c_translate prefix: comp_arm_ compiler: gcc-aarch64 \ +char comp_char_id(char c) { return c; } +\ + +thm comp_arm_comp_char_id_def + +subsection \Signed right shift\ + +text \Under @{text "gcc-x86_64"}, signed right shift uses arithmetic (sign-extending) shift.\ + +micro_c_translate prefix: comp_shr_gcc_ compiler: gcc-x86_64 \ +int comp_shr(int a, int b) { return a >> b; } +\ + +thm comp_shr_gcc_comp_shr_def + +text \Under @{text "conservative"}, signed right shift aborts on negative operand.\ + +micro_c_translate prefix: comp_shr_con_ compiler: conservative \ +int comp_shr(int a, int b) { return a >> b; } +\ + +thm comp_shr_con_comp_shr_def + +subsection \Signed narrowing cast\ + +text \Under @{text "conservative"}, signed narrowing cast checks for overflow.\ + +micro_c_translate prefix: comp_cast_con_ compiler: conservative \ +int comp_narrow(long a) { return (int)a; } +\ + +thm comp_cast_con_comp_narrow_def + +text \Under @{text "gcc-aarch64"}, signed narrowing cast silently truncates.\ + +micro_c_translate prefix: comp_cast_gcc_ compiler: gcc-aarch64 \ +int comp_narrow(long a) { return (int)a; } +\ + +thm comp_cast_gcc_comp_narrow_def + +end diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Control.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Control.thy index 1424cd83..8dbc11f2 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Control.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Control.thy @@ -174,4 +174,108 @@ unsigned int smoke_ctrl_mul_assign(unsigned int a) { thm c_smoke_ctrl_mul_assign_def +section \Switch Statement Smoke\ + +micro_c_translate \ +unsigned int smoke_ctrl_switch_basic(unsigned int x) { + unsigned int r; + switch (x) { + case 0: r = 10; break; + case 1: r = 20; break; + default: r = 99; break; + } + return r; +} +\ + +thm c_smoke_ctrl_switch_basic_def + +micro_c_translate \ +unsigned int smoke_ctrl_switch_fallthrough(unsigned int x) { + unsigned int r; + switch (x) { + case 0: + case 1: r = 42; break; + default: r = 0; break; + } + return r; +} +\ + +thm c_smoke_ctrl_switch_fallthrough_def + +micro_c_translate \ +unsigned int smoke_ctrl_switch_no_default(unsigned int x) { + unsigned int r = 0; + switch (x) { + case 1: r = 1; break; + case 2: r = 2; break; + } + return r; +} +\ + +thm c_smoke_ctrl_switch_no_default_def + +section \Nested Loop and Multi-Function Smoke\ + +micro_c_translate \ +unsigned int smoke_ctrl_nested_break(unsigned int n) { + unsigned int count = 0; + for (unsigned int i = 0; i < n; i++) { + for (unsigned int j = 0; j < n; j++) { + if (j == 2) break; + count += 1; + } + } + return count; +} +\ + +thm c_smoke_ctrl_nested_break_def + +micro_c_translate \ +unsigned int smoke_ctrl_nested_continue(unsigned int n) { + unsigned int count = 0; + for (unsigned int i = 0; i < n; i++) { + for (unsigned int j = 0; j < n; j++) { + if (j == 1) continue; + count += 1; + } + } + return count; +} +\ + +thm c_smoke_ctrl_nested_continue_def + +micro_c_translate \ +static unsigned int smoke_ctrl_helper(unsigned int x) { + return x + 1; +} +unsigned int smoke_ctrl_caller(unsigned int a, unsigned int b) { + return smoke_ctrl_helper(a) + smoke_ctrl_helper(b); +} +\ + +thm c_smoke_ctrl_helper_def +thm c_smoke_ctrl_caller_def + +section \Enum in Expressions Smoke\ + +micro_c_translate \ +enum smoke_ctrl_dir { SMOKE_LEFT = 0, SMOKE_RIGHT = 1, SMOKE_UP = 2, SMOKE_DOWN = 3 }; +unsigned int smoke_ctrl_enum_expr(unsigned int d) { + unsigned int r = 0; + switch (d) { + case SMOKE_LEFT: r = 10; break; + case SMOKE_RIGHT: r = 20; break; + default: r = SMOKE_UP + SMOKE_DOWN; break; + } + return r; +} +\ + +thm c_smoke_ctrl_enum_expr_def + end diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_ILP32.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_ILP32.thy new file mode 100644 index 00000000..b4325bce --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_ILP32.thy @@ -0,0 +1,133 @@ +theory C_Translation_Smoke_ILP32 + imports + C_To_Core_Translation +begin + +section \ILP32 Arithmetic Conversion Smoke Tests\ + +text \ + Regression tests for C11-compliant @{text "usual_arith_conv"} under ILP32, + where @{text "long"} is 32-bit and @{text "long long"} is 64-bit. + + \<^item> @{text "type_rank"}: @{text "CLongLong"} must rank strictly above @{text "CLong"} + (C11 \
6.3.1.1p1). Without this, @{text "long + long long"} returns the + narrower @{text "long"} type. + + \<^item> @{text "usual_arith_conv"} mixed-signedness: when the signed operand has + higher rank but NOT strictly more bits (e.g.\ 32-bit @{text "long"} vs.\ + 32-bit @{text "unsigned int"}), C11 \
6.3.1.8 rule 3 requires converting to + the unsigned type, not the signed one. +\ + +subsection \Rank ordering: \<^verbatim>\long\ vs \<^verbatim>\long long\\ + +text \ + Under ILP32, @{text "long"} is 32-bit and @{text "long long"} is 64-bit. + The result of @{text "long + long long"} must be @{text "long long"} (64-bit). + A buggy @{text "type_rank"} that gives both the same rank would return @{text "long"} + (32-bit), silently losing precision. +\ + +micro_c_translate prefix: ilp32_ abi: ilp32-le \ +long long add_long_longlong(long a, long long b) { + return a + b; +} +\ + +thm ilp32_add_long_longlong_def + +text \Same test for unsigned variants.\ + +micro_c_translate prefix: ilp32_ abi: ilp32-le \ +unsigned long long add_ulong_ulonglong(unsigned long a, unsigned long long b) { + return a + b; +} +\ + +thm ilp32_add_ulong_ulonglong_def + +subsection \Mixed-signedness bit-width check\ + +text \ + Under ILP32, @{text "unsigned int"} (32-bit) and @{text "long"} (32-bit signed) + have the same width. C11 \
6.3.1.8 rule 3: since the signed type cannot represent + all unsigned values, convert to the unsigned counterpart (@{text "unsigned long"}). + A buggy implementation that skips the bit-width check would return @{text "long"} + (signed), silently changing the signedness of the result. +\ + +micro_c_translate prefix: ilp32_ abi: ilp32-le \ +unsigned long add_uint_long(unsigned int a, long b) { + return a + b; +} +\ + +thm ilp32_add_uint_long_def + +subsection \ABI sanity checks\ + +micro_c_translate prefix: ilp32_ abi: ilp32-le \ +unsigned int sizeof_long(void) { return sizeof(long); } +unsigned int sizeof_ptr(void) { return sizeof(int *); } +unsigned int sizeof_longlong(void) { return sizeof(long long); } +\ + +thm ilp32_sizeof_long_def +thm ilp32_sizeof_ptr_def +thm ilp32_sizeof_longlong_def + +lemma ilp32_abi_profile_values: + shows "ilp32_abi_pointer_bits = 32" + and "ilp32_abi_long_bits = 32" + and "ilp32_abi_big_endian = False" + by (simp_all add: ilp32_abi_pointer_bits_def ilp32_abi_long_bits_def ilp32_abi_big_endian_def) + +section \LLP64 (Windows) ABI Smoke Tests\ + +text \ + Under LLP64 (Windows x64), @{text "long"} is 32-bit but pointers are 64-bit. + This distinguishes LLP64 from LP64 (where @{text "long"} is 64-bit) and from + ILP32 (where pointers are 32-bit). +\ + +micro_c_translate prefix: llp64_ abi: llp64-le \ +long long add_long_longlong(long a, long long b) { + return a + b; +} +\ + +thm llp64_add_long_longlong_def + +micro_c_translate prefix: llp64_ abi: llp64-le \ +unsigned int sizeof_long(void) { return sizeof(long); } +unsigned int sizeof_ptr(void) { return sizeof(int *); } +unsigned int sizeof_longlong(void) { return sizeof(long long); } +\ + +thm llp64_sizeof_long_def +thm llp64_sizeof_ptr_def +thm llp64_sizeof_longlong_def + +lemma llp64_abi_profile_values: + shows "llp64_abi_pointer_bits = 64" + and "llp64_abi_long_bits = 32" + and "llp64_abi_big_endian = False" + by (simp_all add: llp64_abi_pointer_bits_def llp64_abi_long_bits_def llp64_abi_big_endian_def) + +section \ILP32-BE (32-bit Big-Endian) ABI Smoke Tests\ + +micro_c_translate prefix: ilp32be_ abi: ilp32-be \ +unsigned int sizeof_long(void) { return sizeof(long); } +unsigned int sizeof_ptr(void) { return sizeof(int *); } +\ + +thm ilp32be_sizeof_long_def +thm ilp32be_sizeof_ptr_def + +lemma ilp32be_abi_profile_values: + shows "ilp32be_abi_pointer_bits = 32" + and "ilp32be_abi_long_bits = 32" + and "ilp32be_abi_big_endian = True" + by (simp_all add: ilp32be_abi_pointer_bits_def ilp32be_abi_long_bits_def ilp32be_abi_big_endian_def) + +end diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy index 8ef604b3..04d63518 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy @@ -1,11 +1,12 @@ theory C_Translation_Smoke_Memory imports C_To_Core_Translation + "Shallow_Separation_Logic.Separation_Algebra" begin section \Memory/Pointer Translation Smoke\ -micro_c_translate \ +micro_c_translate addr: nat \ void smoke_mem_swap(int *a, int *b) { int t = *a; *a = *b; @@ -15,7 +16,7 @@ void smoke_mem_swap(int *a, int *b) { thm c_smoke_mem_swap_def -micro_c_translate \ +micro_c_translate addr: nat \ struct smoke_mem_point { int x; int y; @@ -28,9 +29,8 @@ void smoke_mem_swap_fields(struct smoke_mem_point *p) { \ thm c_smoke_mem_swap_fields_def -thm c_smoke_mem_point.record_simps -micro_c_translate \ +micro_c_translate addr: nat \ int smoke_mem_read_at(int *arr, int idx) { return arr[idx]; } @@ -38,7 +38,7 @@ int smoke_mem_read_at(int *arr, int idx) { thm c_smoke_mem_read_at_def -micro_c_translate \ +micro_c_translate addr: nat \ unsigned int smoke_mem_read_at_u(unsigned int *arr, unsigned int idx) { return arr[idx]; } @@ -46,7 +46,7 @@ unsigned int smoke_mem_read_at_u(unsigned int *arr, unsigned int idx) { thm c_smoke_mem_read_at_u_def -micro_c_translate \ +micro_c_translate addr: nat \ void smoke_mem_write_at(int *arr, int idx, int val) { arr[idx] = val; } @@ -54,7 +54,7 @@ void smoke_mem_write_at(int *arr, int idx, int val) { thm c_smoke_mem_write_at_def -micro_c_translate \ +micro_c_translate addr: nat \ typedef unsigned char uint8_t; uint8_t smoke_mem_read_byte(uint8_t *buf, unsigned int idx) { return *(buf + idx); @@ -63,7 +63,7 @@ uint8_t smoke_mem_read_byte(uint8_t *buf, unsigned int idx) { thm c_smoke_mem_read_byte_def -micro_c_translate \ +micro_c_translate addr: nat \ unsigned int smoke_mem_arr_param(unsigned int arr[], unsigned int i) { return arr[i]; } @@ -71,16 +71,16 @@ unsigned int smoke_mem_arr_param(unsigned int arr[], unsigned int i) { thm c_smoke_mem_arr_param_def -micro_c_translate \ +micro_c_translate addr: nat \ void smoke_mem_local_arr(void) { - unsigned int arr[] = {1, 2, 3}; + unsigned int arr[3] = {1, 2, 3}; unsigned int x = arr[1]; } \ thm c_smoke_mem_local_arr_def -micro_c_translate \ +micro_c_translate addr: nat \ typedef unsigned char smoke_uint8_t; void smoke_mem_zero_init(void) { smoke_uint8_t t[4] = {0}; @@ -90,7 +90,7 @@ void smoke_mem_zero_init(void) { thm c_smoke_mem_zero_init_def -micro_c_translate \ +micro_c_translate addr: nat \ struct smoke_mem_point { int x; int y; @@ -103,7 +103,7 @@ int smoke_mem_get_x(struct smoke_mem_point *p) { thm c_smoke_mem_get_x_def -micro_c_translate \ +micro_c_translate addr: nat \ unsigned int smoke_mem_inc_via_addr(void) { unsigned int x = 5; unsigned int *p = &x; @@ -114,7 +114,7 @@ unsigned int smoke_mem_inc_via_addr(void) { thm c_smoke_mem_inc_via_addr_def -micro_c_translate \ +micro_c_translate addr: nat \ int smoke_mem_addr_of_index(int *arr, unsigned int idx) { int *p = &arr[idx]; return *p; @@ -123,7 +123,7 @@ int smoke_mem_addr_of_index(int *arr, unsigned int idx) { thm c_smoke_mem_addr_of_index_def -micro_c_translate \ +micro_c_translate addr: nat \ struct smoke_mem_holder { int vec[4]; }; @@ -136,7 +136,35 @@ int smoke_mem_addr_of_struct_index(struct smoke_mem_holder *h, unsigned int i) { thm c_smoke_mem_addr_of_struct_index_def thm c_smoke_mem_holder.record_simps -micro_c_translate \ +micro_c_translate addr: nat \ +struct smoke_mem_decay_holder { + int vec[4]; +}; +static int smoke_mem_sum2(int *p) { + return p[0] + p[1]; +} +void smoke_mem_struct_array_decay_assign(struct smoke_mem_decay_holder *h, unsigned int i, int v) { + int *p; + p = h->vec; + p[i] = v; +} +int smoke_mem_struct_array_decay_init(struct smoke_mem_decay_holder *h, unsigned int i) { + int *p = h->vec; + return p[i]; +} +int smoke_mem_struct_array_decay_pass(struct smoke_mem_decay_holder *h) { + int *p = h->vec; + return smoke_mem_sum2(p); +} +\ + +thm c_smoke_mem_sum2_def +thm c_smoke_mem_struct_array_decay_assign_def +thm c_smoke_mem_struct_array_decay_init_def +thm c_smoke_mem_struct_array_decay_pass_def +thm c_smoke_mem_decay_holder.record_simps + +micro_c_translate addr: nat \ const int smoke_mem_global_vals[3] = {1, 2, 3}; int smoke_mem_read_global(unsigned int i) { return smoke_mem_global_vals[i]; @@ -146,4 +174,49 @@ int smoke_mem_read_global(unsigned int i) { thm c_global_smoke_mem_global_vals_def thm c_smoke_mem_read_global_def +section \Pointer Relational Comparison Smoke\ + +micro_c_translate addr: nat \ +unsigned int smoke_mem_ptr_lt(unsigned int *p, unsigned int *q) { + return p < q; +} +\ + +thm c_smoke_mem_ptr_lt_def + +micro_c_translate addr: nat \ +unsigned int smoke_mem_ptr_le(unsigned int *p, unsigned int *q) { + return p <= q; +} +\ + +thm c_smoke_mem_ptr_le_def + +micro_c_translate addr: nat \ +unsigned int smoke_mem_ptr_gt(unsigned int *p, unsigned int *q) { + return p > q; +} +\ + +thm c_smoke_mem_ptr_gt_def + +micro_c_translate addr: nat \ +unsigned int smoke_mem_ptr_ge(unsigned int *p, unsigned int *q) { + return p >= q; +} +\ + +thm c_smoke_mem_ptr_ge_def + +section \Pointer Subtraction Smoke\ + +micro_c_translate addr: nat \ +typedef long ptrdiff_t; +ptrdiff_t smoke_mem_ptr_diff(unsigned int *p, unsigned int *q) { + return p - q; +} +\ + +thm c_smoke_mem_ptr_diff_def + end diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Options.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Options.thy index 77cdd9b4..c8e492c2 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Options.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Options.thy @@ -1,6 +1,7 @@ theory C_Translation_Smoke_Options imports C_To_Core_Translation + "Shallow_Separation_Logic.Separation_Algebra" begin section \\<^verbatim>\micro_c_translate\ Prefix Smoke\ diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy index 4926a1f5..c3b26a89 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy @@ -126,4 +126,46 @@ smoke_int16_t smoke_types_ret_caller(smoke_int16_t a, smoke_int16_t b) { thm c_smoke_types_ret_helper_def c_smoke_types_ret_caller_def +micro_c_translate \ +unsigned int smoke_types_register(register unsigned int x) { + register unsigned int y = x + 1; + return y; +} +\ + +thm c_smoke_types_register_def + +micro_c_translate \ +unsigned __int128 smoke_types_u128_add(unsigned __int128 a, unsigned __int128 b) { + return a + b; +} +\ + +thm c_smoke_types_u128_add_def + +micro_c_translate \ +__int128 smoke_types_i128_negate(__int128 x) { + return 0 - x; +} +\ + +thm c_smoke_types_i128_negate_def + +micro_c_translate addr: nat \ +unsigned int smoke_types_volatile_read(volatile unsigned int *p) { + return *p; +} +\ + +thm c_smoke_types_volatile_read_def + +micro_c_translate \ +unsigned int smoke_types_volatile_local(unsigned int x) { + volatile unsigned int y = x + 1; + return y; +} +\ + +thm c_smoke_types_volatile_local_def + end diff --git a/Micro_C_Parsing_Frontend/ROOT b/Micro_C_Parsing_Frontend/ROOT index 2f92f292..bc41d547 100644 --- a/Micro_C_Parsing_Frontend/ROOT +++ b/Micro_C_Parsing_Frontend/ROOT @@ -7,6 +7,10 @@ session Micro_C_Parsing_Frontend = HOL + Shallow_Micro_Rust Shallow_Micro_C theories + C_ABI_And_Compiler + C_Ast_Utilities + C_Translation_Engine + C_Definition_Generation C_To_Core_Translation theories [document=false] C_Parser_Smoke @@ -14,5 +18,8 @@ session Micro_C_Parsing_Frontend = HOL + C_Translation_Smoke_Control C_Translation_Smoke_Memory C_Translation_Smoke_Types + C_Translation_Smoke_ILP32 + C_Translation_Smoke_Compiler C_Translation_Smoke_Options + C_Translation_Smoke_Advanced C_File_Load_Smoke diff --git a/Shallow_Micro_C/C_Arithmetic_Rules.thy b/Shallow_Micro_C/C_Arithmetic_Rules.thy index 77cdc340..a14127ac 100644 --- a/Shallow_Micro_C/C_Arithmetic_Rules.thy +++ b/Shallow_Micro_C/C_Arithmetic_Rules.thy @@ -565,6 +565,34 @@ proof - unfolding eq by (auto intro: wp_literalI simp add: asepconj_simp) qed +lemma wp_c_signed_shr_conservative [micro_rust_wp_simps]: + fixes a b :: \'l::{len} sword\ + assumes \\r. ucincl (\ r)\ + and \\r. ucincl (\ r)\ + shows \\\

\ (c_signed_shr_conservative a b) \ \ \ = + (if unat b \ LENGTH('l) then + \ (CustomAbort ShiftOutOfRange) + else if sint a < 0 then + \ (CustomAbort SignedOverflow) + else + \ (word_of_int (sint a div 2 ^ unat b)))\ +using assms by (simp add: c_signed_shr_conservative_def c_shift_out_of_range_def + c_signed_overflow_def c_abort_def micro_rust_wp_simps asepconj_simp) + +lemma wp_c_signed_shr_conservativeI [micro_rust_wp_intros]: + fixes a b :: \'l::{len} sword\ + assumes \\r. ucincl (\ r)\ + and \unat b < LENGTH('l)\ + and \sint a \ 0\ + and \\ \ \ (word_of_int (sint a div 2 ^ unat b))\ + shows \\ \ \\

\ (c_signed_shr_conservative a b) \ \ \\ +proof - + from assms have eq: \c_signed_shr_conservative a b = literal (word_of_int (sint a div 2 ^ unat b))\ + by (simp add: c_signed_shr_conservative_def c_shift_out_of_range_def) + from assms this show ?thesis + unfolding eq by (auto intro: wp_literalI simp add: asepconj_simp) +qed + subsection \Type cast operations\ lemma wp_c_ucast [micro_rust_wp_simps]: @@ -589,6 +617,35 @@ lemma wp_c_scastI [micro_rust_wp_intros]: shows \\ \ \\

\ (c_scast w) \ \ \\ using assms by (simp add: c_scast_def wp_literalI asepconj_simp) +lemma wp_c_scast_checked [micro_rust_wp_simps]: + fixes w :: \'a::{len} word\ + and \ :: \'b::{len} word \ 's::{sepalg} set\ + assumes \\r. ucincl (\ r)\ + and \\r. ucincl (\ r)\ + shows \\\

\ (c_scast_checked w) \ \ \ = + (let v = sint w + in if v < -(2^(LENGTH('b) - 1)) \ v \ 2^(LENGTH('b) - 1) then + \ (CustomAbort SignedOverflow) + else + \ (word_of_int v))\ +using assms by (simp add: c_scast_checked_def c_signed_overflow_def c_abort_def + micro_rust_wp_simps asepconj_simp Let_def) + +lemma wp_c_scast_checkedI [micro_rust_wp_intros]: + fixes w :: \'a::{len} word\ + and \ :: \'b::{len} word \ 's::{sepalg} set\ + assumes \\r. ucincl (\ r)\ + and \sint w \ -(2^(LENGTH('b) - 1))\ + and \sint w < 2^(LENGTH('b) - 1)\ + and \\ \ \ (word_of_int (sint w) :: 'b word)\ + shows \\ \ \\

\ (c_scast_checked w) \ \ \\ +proof - + from assms have eq: \c_scast_checked w = literal (word_of_int (sint w) :: 'b word)\ + by (simp add: c_scast_checked_def c_signed_overflow_def Let_def) + from assms this show ?thesis + unfolding eq by (auto intro: wp_literalI simp add: asepconj_simp) +qed + subsection \Unsigned Division and Modulo\ lemma wp_c_unsigned_div [micro_rust_wp_simps]: diff --git a/Shallow_Micro_C/C_Memory_Operations.thy b/Shallow_Micro_C/C_Memory_Operations.thy index 7cefc226..8d5a12e5 100644 --- a/Shallow_Micro_C/C_Memory_Operations.thy +++ b/Shallow_Micro_C/C_Memory_Operations.thy @@ -15,6 +15,20 @@ text \ definition c_ptr_add :: \(nat, 'b) gref \ nat \ nat \ (nat, 'b) gref\ where \c_ptr_add p n stride \ make_gref (gref_address p + n * stride)\ +text \ + Signed pointer arithmetic uses the signed interpretation of the index word. + Negative offsets move the address backwards; for out-of-bounds negative + addresses the surrounding C semantics are already undefined, and nat + subtraction saturates at zero. +\ + +definition c_ptr_shift_signed :: \(nat, 'b) gref \ int \ nat \ (nat, 'b) gref\ where + \c_ptr_shift_signed p n stride \ + if n < 0 then + make_gref (gref_address p - nat (- n) * stride) + else + make_gref (gref_address p + nat n * stride)\ + text \A convenience abbreviation using @{const c_sizeof} for the stride.\ abbreviation c_ptr_add_typed :: \(nat, 'b) gref \ nat \ 'v itself \ (nat, 'b) gref\ where @@ -63,14 +77,13 @@ section \C Pointer Subtraction\ text \ C pointer subtraction yields a signed element-distance (ptrdiff-like), - not an unsigned natural. We model this polymorphically so the result width - is chosen by the surrounding typing context (e.g. ILP32 vs LP64 models). + not an unsigned natural. We expose that semantic distance as a HOL @{typ int} + and let the frontend cast it to the ABI-selected C result type. \ -definition c_ptr_diff :: \(nat, 'b) gref \ (nat, 'b) gref \ nat \ 'l::len sword\ where +definition c_ptr_diff :: \(nat, 'b) gref \ (nat, 'b) gref \ nat \ int\ where \c_ptr_diff p q stride \ - word_of_int - (c_trunc_div_int (int (gref_address p) - int (gref_address q)) (int stride))\ + c_trunc_div_int (int (gref_address p) - int (gref_address q)) (int stride)\ section \C Pointer Relational Comparisons\ @@ -88,10 +101,10 @@ definition c_ptr_ge :: \(nat, 'b) gref \ (nat, 'b) gref \Pointer\Integer Casts\ -definition c_ptr_to_uintptr :: \(nat, 'b) gref \ 'l::len word\ where - \c_ptr_to_uintptr p \ of_nat (gref_address p)\ +definition c_ptr_to_uintptr :: \(nat, 'b) gref \ int\ where + \c_ptr_to_uintptr p \ int (gref_address p)\ -definition c_uintptr_to_ptr :: \'l::len word \ (nat, 'b) gref\ where - \c_uintptr_to_ptr w \ make_gref (unat w)\ +definition c_uintptr_to_ptr :: \int \ (nat, 'b) gref\ where + \c_uintptr_to_ptr w \ make_gref (nat w)\ end diff --git a/Shallow_Micro_C/C_Numeric_Types.thy b/Shallow_Micro_C/C_Numeric_Types.thy index 2415f529..93e95392 100644 --- a/Shallow_Micro_C/C_Numeric_Types.thy +++ b/Shallow_Micro_C/C_Numeric_Types.thy @@ -13,6 +13,16 @@ text \ use @{typ "'l sword"} (from Word\_Lib). \ +text \ + These type synonyms are fixed-width and do not vary with ABI. + ABI-dependent sizing (e.g.\ @{text long} being 32-bit on ILP32 + vs 64-bit on LP64) is handled by @{text hol_type_of} in + @{text C_Ast_Utilities}, which maps @{text CLong} to + @{text c_int} or @{text c_long} depending on the ABI profile. + The @{text sizeof} correctness in translated code follows from + this indirection: the Isabelle type always matches the ABI's + bit width for the C type. +\ type_synonym c_char = \8 word\ type_synonym c_schar = \8 sword\ type_synonym c_short = \16 sword\ @@ -27,9 +37,14 @@ type_synonym c_uint128 = \128 word\ section \C signed arithmetic with overflow detection\ text \ - In C, signed integer overflow is undefined behavior. We model this by - aborting with @{const SignedOverflow} via @{const c_abort}. Unsigned - arithmetic wraps as in standard word arithmetic. + C11 \

6.5p5: if an exceptional condition occurs during the evaluation + of an expression (that is, if the result is not mathematically defined or + not in the range of representable values for its type), the behavior is + undefined. We model signed integer overflow by aborting with + @{const SignedOverflow} via @{const c_abort}. + + C11 \
6.2.5p9: unsigned arithmetic wraps modulo \2\<^sup>N\, which is + exactly the behavior of Isabelle's word arithmetic. \ text \ @@ -40,9 +55,11 @@ text \ \ text \ - C11 signed integer division truncates toward zero. Isabelle/HOL \div\ - on @{typ int} is Euclidean (flooring), so we define helper operations with - C semantics and use those in signed @{text "/"} and @{text "%"}. + C11 \
6.5.5p6: when integers are divided, the result of the @{text "/"} + operator is the algebraic quotient with any fractional part discarded + (truncation toward zero). Isabelle/HOL \div\ on @{typ int} is + Euclidean (flooring), so we define helper operations with C semantics + and use those in signed @{text "/"} and @{text "%"}. \ definition c_trunc_div_int :: \int \ int \ int\ where @@ -82,6 +99,13 @@ definition c_signed_mul :: \'l::{len} sword \ 'l sword \ +text \ + Signed division and modulo hardcode @{typ c_abort} because they must + construct @{const DivisionByZero}, a @{typ c_abort} value. This means + they cannot be used in locales whose @{typ "'abort"} parameter differs + from @{typ c_abort} --- see also @{text c_unsigned_div} below. +\ + definition c_signed_div :: \'l::{len} sword \ 'l sword \ ('s, 'l sword, 'r, c_abort, 'i, 'o) expression\ where \c_signed_div a b \ @@ -94,6 +118,13 @@ definition c_signed_div :: \'l::{len} sword \ 'l sword \ +text \ + @{text "c_signed_mod"} checks the \emph{quotient} for overflow, not the remainder itself. + Per C11 6.5.5p6, if \a/b\ is not representable, both \a/b\ and \a%b\ are undefined. + The canonical case is @{text "INT_MIN % (-1)"}: the remainder is 0, but + @{text "INT_MIN / (-1)"} overflows, so the operation is UB. +\ + definition c_signed_mod :: \'l::{len} sword \ 'l sword \ ('s, 'l sword, 'r, c_abort, 'i, 'o) expression\ where \c_signed_mod a b \ @@ -110,9 +141,9 @@ definition c_signed_mod :: \'l::{len} sword \ 'l sword \C unsigned arithmetic (wrapping)\ text \ - Unsigned arithmetic in C wraps modulo \2^LENGTH('l)\, which is - exactly the behavior of Isabelle's word arithmetic. Division by zero is - still undefined behavior. + C11 \
6.2.5p9: unsigned arithmetic wraps modulo \2^LENGTH('l)\, + which is exactly the behavior of Isabelle's word arithmetic. + C11 \
6.5.5p5: division by zero is undefined behavior. \ definition c_unsigned_add :: \'l::{len} word \ 'l word \ @@ -127,6 +158,17 @@ definition c_unsigned_mul :: \'l::{len} word \ 'l word \ where \c_unsigned_mul a b \ literal (a * b)\ +text \ + Like the signed variants, unsigned division and modulo hardcode + @{typ c_abort} to construct @{const DivisionByZero}. Unlike + @{const c_unsigned_add}/@{const c_unsigned_sub}/@{const c_unsigned_mul} + which are polymorphic in @{typ "'abort"}, these two fix it to + @{typ c_abort}. Consequence: in a locale whose abort type parameter + differs from @{typ c_abort}, using division or modulo causes a type + unification error. Avoid division in examples that also require + locale-specific abort types (e.g.\ pointer operations). +\ + definition c_unsigned_div :: \'l::{len} word \ 'l word \ ('s, 'l word, 'r, c_abort, 'i, 'o) expression\ where \c_unsigned_div a b \ @@ -146,8 +188,10 @@ definition c_unsigned_mod :: \'l::{len} word \ 'l word \C bitwise operations\ text \ - Bitwise AND, OR, XOR, and NOT have no undefined behavior in C — - they operate on the bit representation for both signed and unsigned types. + C11 \
6.5.10--12 (bitwise AND/XOR/OR): these operators have no + undefined behavior --- they operate on the bit representation for both + signed and unsigned types. C11 \
6.5.3.3p4 (bitwise NOT, @{text "~"}): + integer promotions are performed, then the result is the bitwise complement. \ definition c_signed_and :: \'l::{len} sword \ 'l sword \ @@ -185,11 +229,12 @@ definition c_unsigned_not :: \'l::{len} word \ section \C shift operations\ text \ - Shift operations have undefined behavior when the shift amount is - greater than or equal to the bit width. Signed left shift additionally - has UB for negative operands or when the result overflows. - Signed right shift of a negative operand is implementation-defined - in C11/C17; we conservatively abort. + C11 \
6.5.7p3: if the shift count is negative or \\\ the bit width + of the promoted left operand, the behavior is undefined. + C11 \
6.5.7p4: for signed left shift, if the left operand is negative + or the result would overflow, the behavior is undefined. + C11 \
6.5.7p5: for signed right shift of a negative operand, the result + is implementation-defined (arithmetic vs logical shift). \ definition c_unsigned_shl :: \'l::{len} word \ 'l word \ @@ -232,6 +277,26 @@ definition c_signed_shr :: \'l::{len} sword \ 'l sword \ +text \Conservative right shift: aborts on negative operands instead of relying + on implementation-defined arithmetic shift. Used by the @{text "conservative"} + compiler profile where no specific compiler behavior is assumed.\ + +definition c_signed_shr_conservative :: \'l::{len} sword \ 'l sword \ + ('s, 'l sword, 'r, c_abort, 'i, 'o) expression\ where + \c_signed_shr_conservative a b \ + if unat b \ LENGTH('l) then + c_shift_out_of_range + else if sint a < 0 then + c_signed_overflow + else + literal (word_of_int (sint a div 2 ^ unat b))\ + +text \ + C11 \
6.5.8--9: relational and equality operators compare values after + the usual arithmetic conversions. The result type is @{typ int} (we use + @{typ bool} internally and convert at the translation layer). +\ + section \C unsigned comparison operations\ definition c_unsigned_less :: \'l::{len} word \ 'l word \ @@ -271,9 +336,10 @@ definition c_signed_neq :: \'l::{len} sword \ 'l sword \C truthiness conversion\ text \ - In C, scalar conditions are interpreted as booleans via comparison against zero. - These helpers model the implicit conversion used by conditionals and logical - operators. + C11 \
6.3.1.2: when any scalar value is converted to @{text "_Bool"}, + the result is 0 if the value compares equal to 0; otherwise the result is 1. + These helpers model the implicit conversion used by conditionals (\
6.5.15) + and logical operators (\
6.5.13--14). \ definition c_signed_truthy :: \'l::{len} sword \ @@ -286,10 +352,32 @@ definition c_unsigned_truthy :: \'l::{len} word \ section \C type cast operations\ +text \ + C11 \
6.3.1.3 (signed and unsigned integer conversions): + \<^item> Conversion to unsigned: value is reduced modulo \2\<^sup>N\ (\
6.3.1.3p2). + \<^item> Conversion to signed where the value cannot be represented: the result + is implementation-defined or an implementation-defined signal is raised + (\
6.3.1.3p3). We model this with @{text c_scast} (truncating, matching + GCC/Clang) and @{text c_scast_checked} (aborting, for the conservative profile). +\ + definition c_ucast :: \'a::{len} word \ ('s, 'b::{len} word, 'r, 'abort, 'i, 'o) expression\ where \c_ucast w \ literal (ucast w)\ definition c_scast :: \'a::{len} word \ ('s, 'b::{len} word, 'r, 'abort, 'i, 'o) expression\ where \c_scast w \ literal (scast w)\ +text \Checked signed narrowing cast: aborts with @{text "SignedOverflow"} when + @{text "sint w"} does not fit in the target type's signed range. Used by the + @{text "conservative"} compiler profile where implementation-defined narrowing + truncation is not assumed.\ + +definition c_scast_checked :: \'a::{len} word \ ('s, 'b::{len} word, 'r, c_abort, 'i, 'o) expression\ where + \c_scast_checked w \ + let v = sint w + in if v < -(2^(LENGTH('b) - 1)) \ v \ 2^(LENGTH('b) - 1) then + c_signed_overflow + else + literal (word_of_int v)\ + end diff --git a/Shallow_Micro_C/C_Sizeof.thy b/Shallow_Micro_C/C_Sizeof.thy index 2b4a8bdf..bdcdb2d1 100644 --- a/Shallow_Micro_C/C_Sizeof.thy +++ b/Shallow_Micro_C/C_Sizeof.thy @@ -22,6 +22,13 @@ begin \c_sizeof_char _ \ 1\ end +overloading + c_sizeof_schar \ \c_sizeof :: c_schar itself \ nat\ +begin + definition c_sizeof_schar :: \c_schar itself \ nat\ where + \c_sizeof_schar _ \ 1\ +end + overloading c_sizeof_short \ \c_sizeof :: c_short itself \ nat\ begin @@ -84,6 +91,10 @@ lemma c_sizeof_char_val [simp]: shows \c_sizeof TYPE(c_char) = 1\ by (simp add: c_sizeof_char_def) +lemma c_sizeof_schar_val [simp]: + shows \c_sizeof TYPE(c_schar) = 1\ +by (simp add: c_sizeof_schar_def) + lemma c_sizeof_short_val [simp]: shows \c_sizeof TYPE(c_short) = 2\ by (simp add: c_sizeof_short_def) @@ -146,6 +157,13 @@ begin \c_alignof_char _ \ 1\ end +overloading + c_alignof_schar \ \c_alignof :: c_schar itself \ nat\ +begin + definition c_alignof_schar :: \c_schar itself \ nat\ where + \c_alignof_schar _ \ 1\ +end + overloading c_alignof_short \ \c_alignof :: c_short itself \ nat\ begin @@ -206,6 +224,10 @@ lemma c_alignof_char_val [simp]: shows \c_alignof TYPE(c_char) = 1\ by (simp add: c_alignof_char_def) +lemma c_alignof_schar_val [simp]: + shows \c_alignof TYPE(c_schar) = 1\ +by (simp add: c_alignof_schar_def) + lemma c_alignof_short_val [simp]: shows \c_alignof TYPE(c_short) = 2\ by (simp add: c_alignof_short_def) diff --git a/Shallow_Micro_C/C_Translation_Model.thy b/Shallow_Micro_C/C_Translation_Model.thy new file mode 100644 index 00000000..bb3df015 --- /dev/null +++ b/Shallow_Micro_C/C_Translation_Model.thy @@ -0,0 +1,78 @@ +theory C_Translation_Model + imports + C_Memory_Operations + C_Void_Pointer +begin + +section \C Translation Model Interface\ + +text \ + The C frontend translates pointer-manipulating code against a locale-provided + interface rather than hard-wiring one concrete machine model into the parser. + The pointer operations below are the semantic surface that generated terms may + depend on. Domain-specific models can extend this locale with additional + prisms, memory lemmas, and stronger invariants. +\ + +locale c_pointer_model = + fixes + c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + assumes c_ptr_add_zero [simp]: \c_ptr_add p 0 stride = p\ + and c_ptr_add_add: \c_ptr_add (c_ptr_add p m stride) n stride = c_ptr_add p (m + n) stride\ + and c_ptr_diff_self [simp]: \c_ptr_diff p p stride = 0\ + and c_ptr_less_irrefl [simp]: \\ c_ptr_less p p\ + and c_ptr_le_refl [simp]: \c_ptr_le p p\ + and c_ptr_ge_refl [simp]: \c_ptr_ge p p\ + +locale c_abi_model = + fixes + c_abi_pointer_bits :: nat + and c_abi_long_bits :: nat + and c_abi_char_is_signed :: bool + and c_abi_big_endian :: bool + assumes c_abi_pointer_bits_supported [simp]: \c_abi_pointer_bits = 32 \ c_abi_pointer_bits = 64\ + and c_abi_long_bits_supported [simp]: \c_abi_long_bits = 32 \ c_abi_long_bits = 64\ +begin + +text \ + ABI-derived sizeof for C-level type names that vary by ABI. + Use these in manual specifications instead of @{text "c_sizeof TYPE(c_long)"}, + which always returns 8 because @{typ c_long} is a fixed alias for @{typ "64 sword"}. +\ + +definition c_sizeof_c_long :: nat where + \c_sizeof_c_long \ c_abi_long_bits div 8\ + +definition c_sizeof_c_pointer :: nat where + \c_sizeof_c_pointer \ c_abi_pointer_bits div 8\ + +end + +locale c_translation_model = + c_pointer_model c_ptr_add c_ptr_shift_signed c_ptr_diff c_ptr_less c_ptr_le c_ptr_greater c_ptr_ge + c_ptr_to_uintptr c_uintptr_to_ptr + + c_abi_model c_abi_pointer_bits c_abi_long_bits c_abi_char_is_signed c_abi_big_endian + for + c_ptr_add :: \('addr, 'gv) gref \ nat \ nat \ ('addr, 'gv) gref\ + and c_ptr_shift_signed :: \('addr, 'gv) gref \ int \ nat \ ('addr, 'gv) gref\ + and c_ptr_diff :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ nat \ int\ + and c_ptr_less :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_le :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_greater :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_ge :: \('addr, 'gv) gref \ ('addr, 'gv) gref \ bool\ + and c_ptr_to_uintptr :: \('addr, 'gv) gref \ int\ + and c_uintptr_to_ptr :: \int \ ('addr, 'gv) gref\ + and c_abi_pointer_bits :: nat + and c_abi_long_bits :: nat + and c_abi_char_is_signed :: bool + and c_abi_big_endian :: bool + +end diff --git a/Shallow_Micro_C/ROOT b/Shallow_Micro_C/ROOT index 80c618a3..d0d51899 100644 --- a/Shallow_Micro_C/ROOT +++ b/Shallow_Micro_C/ROOT @@ -17,3 +17,4 @@ session Shallow_Micro_C = HOL + C_Arithmetic_Rules C_Byte_Encoding C_Void_Pointer + C_Translation_Model diff --git a/dependencies/afp/README.md b/dependencies/afp/README.md index 7aba08be..7ee4f2e4 100644 --- a/dependencies/afp/README.md +++ b/dependencies/afp/README.md @@ -4,4 +4,19 @@ AutoCorrode depends on the following AFP entries. Download and unpack them here. If they are located in a different directory, set the `AFP_COMPONENT_BASE` environment variable accordingly. - [Word_Lib](https://www.isa-afp.org/entries/Word_Lib.html) — word-level operations and bit manipulation -- [Isabelle_C](https://www.isa-afp.org/entries/Isabelle_C.html) — C11 parser front-end (required for Micro C sessions) \ No newline at end of file +- [Isabelle_C](https://www.isa-afp.org/entries/Isabelle_C.html) — C11 parser front-end (required for Micro C sessions) + +## Required patch: Isabelle_C + +The upstream AFP Isabelle_C has a bug in `C_Parser_Language.thy` where +`transformDeclaration` errors on function parameter declarations with 3+ +type specifiers (e.g. `unsigned long long`). A patch is provided at +`.github/patches/isabelle_c_parser_language.patch`. Apply it to your +Isabelle_C installation: + +```bash +cd path/to/Isabelle_C +git apply path/to/AutoCorrode/.github/patches/isabelle_c_parser_language.patch +``` + +CI applies this patch automatically via the setup-isabelle-action. \ No newline at end of file