From 23045a4c2c04a62806ee2232b0761ee23522a235 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sun, 8 Mar 2026 23:22:03 +0000 Subject: [PATCH 01/58] Refactor C translation around an abstract pointer/ABI model Introduce `C_Translation_Model` and move the C frontend toward a locale-provided pointer/memory interface instead of hard-wiring one concrete pointer representation into translation. This change: - adds `c_translation_model` with pointer arithmetic, comparisons, pointer/int casts, and ABI parameters - extends `C_To_Core_Translation` to track the reference universe (`addr`/`gv`) explicitly and resolve pointer-heavy types against it - improves typedef resolution, record type resolution, and support for parametric/generated struct types - distinguishes pure helper calls from side-effecting calls during translation - adds signed pointer shifting support (`c_ptr_shift_signed`) - tightens pointer, cast, member-access, and array-index translation, including struct-field access through pointers and raw `void *` handling - updates the memory smoke tests to exercise the nat-addressed model explicitly This is groundwork for translating C against an abstract machine model while keeping pointer semantics and ABI assumptions explicit in the target locale. Signed-off-by: Dominic Mulligan --- Micro_C_Examples/C_ABI_Examples.thy | 99 +- Micro_C_Examples/C_Array_Examples.thy | 117 +- Micro_C_Examples/C_Struct_Examples.thy | 139 +- Micro_C_Examples/C_Union_Examples.thy | 2 +- Micro_C_Examples/C_Void_Pointer_Examples.thy | 12 +- Micro_C_Examples/Simple_C_Functions.thy | 242 +- .../C_To_Core_Translation.thy | 3328 ++++++++++++++--- .../C_Translation_Smoke_Memory.thy | 59 +- Shallow_Micro_C/C_Memory_Operations.thy | 31 +- Shallow_Micro_C/C_Translation_Model.thy | 63 + Shallow_Micro_C/ROOT | 1 + 11 files changed, 3426 insertions(+), 667 deletions(-) create mode 100644 Shallow_Micro_C/C_Translation_Model.thy 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_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..99e71f03 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\ abort: 'abort \ 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/Simple_C_Functions.thy b/Micro_C_Examples/Simple_C_Functions.thy index 630137ba..241ac71a 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 @@ -142,11 +182,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 +214,18 @@ 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 \ The contract for @{text u_add}: unsigned addition wraps, so the result is always @{term \a + b\} (Isabelle word addition already wraps). @@ -592,8 +655,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 +667,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\ @@ -655,10 +720,21 @@ 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 +813,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,11 +928,22 @@ 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\ + 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\ begin @@ -882,22 +980,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 +1023,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 +1043,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 +1092,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 +1145,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 @@ -1224,21 +1368,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_To_Core_Translation.thy b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy index c8c4aa16..e1518eac 100644 --- a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy +++ b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy @@ -10,6 +10,7 @@ theory C_To_Core_Translation "Shallow_Micro_C.C_Sizeof" "Shallow_Micro_C.C_Memory_Operations" "Shallow_Micro_C.C_Void_Pointer" + "Shallow_Micro_C.C_Translation_Model" keywords "micro_c_translate" :: thy_decl and "micro_c_file" :: thy_decl and "prefix:" and "manifest:" and "addr:" and "gv:" and "abi:" and "abort:" @@ -104,6 +105,9 @@ structure C_Ast_Utils : sig 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 @@ -113,6 +117,7 @@ structure C_Ast_Utils : sig 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 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 @@ -161,13 +166,25 @@ structure C_Ast_Utils : sig 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_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 @@ -190,7 +207,24 @@ struct 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 () = @@ -539,30 +573,63 @@ struct (* 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 + 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. @@ -582,25 +649,96 @@ struct (* 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 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 pure_tab (CAssign0 _) = true + | expr_has_side_effect_with pure_tab (CUnary0 (CPreIncOp0, _, _)) = true + | expr_has_side_effect_with pure_tab (CUnary0 (CPostIncOp0, _, _)) = true + | expr_has_side_effect_with pure_tab (CUnary0 (CPreDecOp0, _, _)) = true + | expr_has_side_effect_with pure_tab (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) fun expr_reads_vars (CVar0 (ident, _)) = [ident_name ident] | expr_reads_vars (CAssign0 (_, lhs, rhs, _)) = @@ -706,6 +844,67 @@ struct fun find_assigned_vars stmt = distinct (op =) (fas stmt []) end + local + fun writes_if in_loop e acc = + if in_loop then expr_written_vars e @ acc else acc + + fun loop_init_writes in_loop (Left (Some e)) acc = writes_if in_loop e acc + | loop_init_writes in_loop (Right d) acc = loop_decl_writes in_loop d acc + | loop_init_writes _ _ acc = acc + + and loop_decl_writes in_loop (CDecl0 (_, declarators, _)) acc = + List.foldl + (fn (((_, Some init), _), ac) => loop_initval_writes in_loop init ac + | (_, ac) => ac) + acc declarators + | loop_decl_writes _ _ acc = acc + + and loop_initval_writes in_loop (CInitExpr0 (e, _)) acc = writes_if in_loop e acc + | loop_initval_writes in_loop (CInitList0 (inits, _)) acc = + List.foldl (fn ((_, init), ac) => loop_initval_writes in_loop init ac) acc inits + + fun loop_item_writes in_loop (CBlockStmt0 s) acc = loop_stmt_writes in_loop s acc + | loop_item_writes in_loop (CBlockDecl0 d) acc = loop_decl_writes in_loop d acc + | loop_item_writes _ _ acc = acc + + and loop_stmt_writes in_loop (CCompound0 (_, items, _)) acc = + List.foldl (fn (it, ac) => loop_item_writes in_loop it ac) acc items + | loop_stmt_writes in_loop (CExpr0 (Some e, _)) acc = writes_if in_loop e acc + | loop_stmt_writes _ (CExpr0 (None, _)) acc = acc + | loop_stmt_writes in_loop (CReturn0 (Some e, _)) acc = writes_if in_loop e acc + | loop_stmt_writes _ (CReturn0 (None, _)) acc = acc + | loop_stmt_writes in_loop (CIf0 (c, t, e_opt, _)) acc = + let + val acc = writes_if in_loop c acc + val acc = loop_stmt_writes in_loop t acc + in + (case e_opt of Some e => loop_stmt_writes in_loop e acc | None => acc) + end + | loop_stmt_writes _ (CWhile0 (c, b, _, _)) acc = + let + val acc = writes_if true c acc + val acc = loop_stmt_writes true b acc + in acc end + | loop_stmt_writes _ (CFor0 (init, c, s, b, _)) acc = + let + val acc = loop_init_writes true init acc + val acc = (case c of Some e => writes_if true e acc | None => acc) + val acc = (case s of Some e => writes_if true e acc | None => acc) + val acc = loop_stmt_writes true b acc + in acc end + | loop_stmt_writes in_loop (CSwitch0 (e, s, _)) acc = + loop_stmt_writes in_loop s (writes_if in_loop e acc) + | loop_stmt_writes in_loop (CCase0 (e, s, _)) acc = + loop_stmt_writes in_loop s (writes_if in_loop e acc) + | loop_stmt_writes in_loop (CDefault0 (s, _)) acc = + loop_stmt_writes in_loop s acc + | loop_stmt_writes in_loop (CLabel0 (_, s, _, _)) acc = + loop_stmt_writes in_loop s acc + | loop_stmt_writes _ _ acc = acc + in + fun find_loop_written_vars stmt = distinct (op =) (loop_stmt_writes false 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 @@ -785,6 +984,355 @@ struct distinct (op =) (rev (fc_stmt body [])) end + 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 struct_tab array_field_tab env struct_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 struct_tab array_field_tab env 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_struct_bindings struct_names decl struct_env = + (case (declr_of_decl decl, struct_name_of_decl struct_names decl) of + (SOME declr, SOME sname) => + Symtab.update (declr_name declr, sname) struct_env + | _ => struct_env) + + 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 + + fun indexed_base_vars_expr (CIndex0 (CVar0 (ident, _), idx, _)) acc = + indexed_base_vars_expr idx (ident_name ident :: acc) + | indexed_base_vars_expr (CUnary0 (CIndOp0, CVar0 (ident, _), _)) acc = + ident_name ident :: acc + | indexed_base_vars_expr (CAssign0 (_, lhs, rhs, _)) acc = + indexed_base_vars_expr rhs (indexed_base_vars_expr lhs acc) + | indexed_base_vars_expr (CBinary0 (_, l, r, _)) acc = + indexed_base_vars_expr r (indexed_base_vars_expr l acc) + | indexed_base_vars_expr (CUnary0 (_, e, _)) acc = + indexed_base_vars_expr e acc + | indexed_base_vars_expr (CIndex0 (a, i, _)) acc = + indexed_base_vars_expr i (indexed_base_vars_expr a acc) + | indexed_base_vars_expr (CMember0 (e, _, _, _)) acc = + indexed_base_vars_expr e acc + | indexed_base_vars_expr (CCast0 (_, e, _)) acc = + indexed_base_vars_expr e acc + | indexed_base_vars_expr (CCall0 (f, args, _)) acc = + List.foldl (fn (a, ac) => indexed_base_vars_expr a ac) + (indexed_base_vars_expr f acc) args + | indexed_base_vars_expr (CComma0 (es, _)) acc = + List.foldl (fn (e, ac) => indexed_base_vars_expr e ac) acc es + | indexed_base_vars_expr (CCond0 (c, t, e, _)) acc = + indexed_base_vars_expr e + ((case t of Some te => indexed_base_vars_expr te | None => I) + (indexed_base_vars_expr c acc)) + | indexed_base_vars_expr _ acc = acc + + fun indexed_base_vars_stmt (CCompound0 (_, items, _)) acc = + List.foldl + (fn (CBlockStmt0 stmt, ac) => indexed_base_vars_stmt stmt ac + | (CBlockDecl0 (CDecl0 (_, declarators, _)), ac) => + List.foldl + (fn (((_, Some (CInitExpr0 (e, _))), _), ac') => indexed_base_vars_expr e ac' + | (_, ac') => ac') + ac declarators + | (_, ac) => ac) + acc items + | indexed_base_vars_stmt (CExpr0 (Some e, _)) acc = indexed_base_vars_expr e acc + | indexed_base_vars_stmt (CReturn0 (Some e, _)) acc = indexed_base_vars_expr e acc + | indexed_base_vars_stmt (CIf0 (c, t, e_opt, _)) acc = + (case e_opt of Some e => indexed_base_vars_stmt e | None => I) + (indexed_base_vars_stmt t (indexed_base_vars_expr c acc)) + | indexed_base_vars_stmt (CWhile0 (c, b, _, _)) acc = + indexed_base_vars_stmt b (indexed_base_vars_expr c acc) + | indexed_base_vars_stmt (CFor0 (Left (Some i), c, s, b, _)) acc = + indexed_base_vars_stmt b + (opt_index_expr s (opt_index_expr c (indexed_base_vars_expr i acc))) + | indexed_base_vars_stmt (CFor0 (Left None, c, s, b, _)) acc = + indexed_base_vars_stmt b (opt_index_expr s (opt_index_expr c acc)) + | indexed_base_vars_stmt (CFor0 (Right d, c, s, b, _)) acc = + let + val acc' = + (case d of + CDecl0 (_, declarators, _) => + List.foldl + (fn (((_, Some (CInitExpr0 (e, _))), _), ac') => indexed_base_vars_expr e ac' + | (_, ac') => ac') + acc declarators + | _ => acc) + in + indexed_base_vars_stmt b (opt_index_expr s (opt_index_expr c acc')) + end + | indexed_base_vars_stmt (CSwitch0 (e, s, _)) acc = + indexed_base_vars_stmt s (indexed_base_vars_expr e acc) + | indexed_base_vars_stmt (CCase0 (e, s, _)) acc = + indexed_base_vars_stmt s (indexed_base_vars_expr e acc) + | indexed_base_vars_stmt (CDefault0 (s, _)) acc = + indexed_base_vars_stmt s acc + | indexed_base_vars_stmt (CLabel0 (_, s, _, _)) acc = + indexed_base_vars_stmt s acc + | indexed_base_vars_stmt _ acc = acc + + and opt_index_expr (Some e) acc = indexed_base_vars_expr e acc + | opt_index_expr None acc = acc + + fun named_calls_expr (CCall0 (CVar0 (ident, _), args, _)) acc = + List.foldl (fn (a, ac) => named_calls_expr a ac) + ((ident_name ident, args) :: acc) args + | named_calls_expr (CCall0 (f, args, _)) acc = + List.foldl (fn (a, ac) => named_calls_expr a ac) + (named_calls_expr f acc) args + | named_calls_expr (CAssign0 (_, lhs, rhs, _)) acc = + named_calls_expr rhs (named_calls_expr lhs acc) + | named_calls_expr (CBinary0 (_, l, r, _)) acc = + named_calls_expr r (named_calls_expr l acc) + | named_calls_expr (CUnary0 (_, e, _)) acc = + named_calls_expr e acc + | named_calls_expr (CIndex0 (a, i, _)) acc = + named_calls_expr i (named_calls_expr a acc) + | named_calls_expr (CMember0 (e, _, _, _)) acc = + named_calls_expr e acc + | named_calls_expr (CCast0 (_, e, _)) acc = + named_calls_expr e acc + | named_calls_expr (CComma0 (es, _)) acc = + List.foldl (fn (e, ac) => named_calls_expr e ac) acc es + | named_calls_expr (CCond0 (c, t, e, _)) acc = + named_calls_expr e + ((case t of Some te => named_calls_expr te | None => I) + (named_calls_expr c acc)) + | named_calls_expr _ acc = acc + + fun named_calls_stmt (CCompound0 (_, items, _)) acc = + List.foldl + (fn (CBlockStmt0 stmt, ac) => named_calls_stmt stmt ac + | (CBlockDecl0 (CDecl0 (_, declarators, _)), ac) => + List.foldl + (fn (((_, Some (CInitExpr0 (e, _))), _), ac') => named_calls_expr e ac' + | (_, ac') => ac') + ac declarators + | (_, ac) => ac) + acc items + | named_calls_stmt (CExpr0 (Some e, _)) acc = named_calls_expr e acc + | named_calls_stmt (CReturn0 (Some e, _)) acc = named_calls_expr e acc + | named_calls_stmt (CIf0 (c, t, e_opt, _)) acc = + (case e_opt of Some e => named_calls_stmt e | None => I) + (named_calls_stmt t (named_calls_expr c acc)) + | named_calls_stmt (CWhile0 (c, b, _, _)) acc = + named_calls_stmt b (named_calls_expr c acc) + | named_calls_stmt (CFor0 (Left (Some i), c, s, b, _)) acc = + named_calls_stmt b (opt_call_expr s (opt_call_expr c (named_calls_expr i acc))) + | named_calls_stmt (CFor0 (Left None, c, s, b, _)) acc = + named_calls_stmt b (opt_call_expr s (opt_call_expr c acc)) + | named_calls_stmt (CFor0 (Right d, c, s, b, _)) acc = + let + val acc' = + (case d of + CDecl0 (_, declarators, _) => + List.foldl + (fn (((_, Some (CInitExpr0 (e, _))), _), ac') => named_calls_expr e ac' + | (_, ac') => ac') + acc declarators + | _ => acc) + in + named_calls_stmt b (opt_call_expr s (opt_call_expr c acc')) + end + | named_calls_stmt (CSwitch0 (e, s, _)) acc = + named_calls_stmt s (named_calls_expr e acc) + | named_calls_stmt (CCase0 (e, s, _)) acc = + named_calls_stmt s (named_calls_expr e acc) + | named_calls_stmt (CDefault0 (s, _)) acc = + named_calls_stmt s acc + | named_calls_stmt (CLabel0 (_, s, _, _)) acc = + named_calls_stmt s acc + | named_calls_stmt _ acc = acc + + and opt_call_expr (Some e) acc = named_calls_expr e acc + | opt_call_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 + + fun find_indexed_base_vars (CFunDef0 (_, _, _, body, _)) = + distinct (op =) (indexed_base_vars_stmt body []) + + fun find_named_calls_with_args (CFunDef0 (_, _, _, body, _)) = + rev (named_calls_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. @@ -855,6 +1403,17 @@ struct | _ => 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\ @@ -870,8 +1429,14 @@ struct | 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 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 @@ -890,7 +1455,7 @@ struct 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 + cty_to_record_typ prefix (apply_ptr_depth base_fty (ptr_depth_only derived)) else cty_to_record_typ prefix base_fty @@ -934,6 +1499,31 @@ struct | _ => NONE) ext_decls + fun cty_needs_parametric_struct parametric_structs (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 + (* 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, _)) = @@ -984,6 +1574,37 @@ struct | _ => 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) @@ -1036,7 +1657,7 @@ text \ ML \ structure C_Trans_Ctxt : sig - datatype var_kind = Param | Local (* Param = by-value, Local = mutable reference *) + 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 @@ -1076,7 +1697,7 @@ structure C_Trans_Ctxt : sig val set_active_goto_labels : string list -> t -> t end = struct - datatype var_kind = Param | Local + datatype var_kind = Param | ParamListPtr | Local | LocalPtr type t = { ctxt : Proof.context, vars : (var_kind * term * C_Ast_Utils.c_numeric_type) Symtab.table, @@ -1383,8 +2004,8 @@ struct (* 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 + 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 @@ -1561,15 +2182,19 @@ text \ 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 : string Symtab.table Unsynchronized.ref + 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 @@ -1581,6 +2206,8 @@ structure C_Translate : sig -> 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 @@ -1591,7 +2218,7 @@ struct (* 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 = + val defined_func_consts : term Symtab.table Unsynchronized.ref = Unsynchronized.ref Symtab.empty (* Table mapping function names to their fuel parameter count. @@ -1599,6 +2226,14 @@ struct 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 @@ -1611,6 +2246,167 @@ struct 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 + + 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_expr_arrow arg_ty value_ty tm = + (case expr_type_with_value value_ty of + SOME expr_ty => Type.constraint (arg_ty --> expr_ty) tm + | NONE => tm) + + fun constrain_expr_arrow_from_tm arg_ty value_ty side_tm tm = + (case expr_type_from_tm value_ty side_tm of + SOME expr_ty => Type.constraint (arg_ty --> expr_ty) tm + | NONE => tm) + + fun constrain_function_body_arrow arg_ty value_ty tm = + (case function_body_type_with_value value_ty of + SOME body_ty => Type.constraint (arg_ty --> body_ty) tm + | NONE => tm) + + 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 @@ -1634,14 +2430,104 @@ struct 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_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) - in C_Term_Build.mk_bind void_ptr_term - (Term.lambda v (C_Term_Build.mk_literal (cast_const $ prism_const $ v))) + 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 polymorphic so later + context (e.g. indexing vs scalar dereference) can resolve it. *) + 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 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). @@ -1653,7 +2539,8 @@ struct 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 + 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) @@ -1664,15 +2551,27 @@ struct 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 + 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} @@ -1705,36 +2604,122 @@ struct (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 + 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 cast_term = mk_cast_from_void_untyped tm + val target_ty = + (case pointer_expr_value_hol_ty to_cty of + SOME ty => ty + | NONE => isa_dummyT) + in if target_ty = isa_dummyT then cast_term + else constrain_expr_value_type target_ty cast_term + end) (* T* -> untyped : strip focus *) else if is_void_like to_inner then - let val v = Free ("v__cast", dummyT) + 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) - in C_Term_Build.mk_bind tm (Term.lambda v (C_Term_Build.mk_literal (cast $ v))) + 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* where neither is void/union: no-op *) - else tm + (* T* -> U* where neither is void/union: + reinterpret through void* so the resulting focused reference + carries U's prism (byte-level view), rather than leaving the + term at type T* while only changing the tracked C type. *) + 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 ABI uintptr type, then convert as needed *) - let val v = Free ("v__ptrint", dummyT) + (* pointer -> integer cast via semantic uintptr value, then convert as needed *) + let val ctxt = 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 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) + 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 then convert *) + (* 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 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))) + 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 @@ -1745,28 +2730,13 @@ struct 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 C_Term_Build.mk_bind tm (Term.lambda v (cast_const $ v)) end + 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 - (* 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 _ = [] @@ -1775,6 +2745,7 @@ struct 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) open C_Ast @@ -1806,40 +2777,43 @@ struct 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 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 + 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 = @@ -1926,8 +2900,38 @@ 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 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 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 @@ -1951,6 +2955,20 @@ struct | 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" @@ -2089,26 +3107,131 @@ struct 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 label 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 resolve_ptr_to_uintptr_const ctxt = + resolve_required_visible_const ctxt "c_ptr_to_uintptr" + + fun resolve_uintptr_to_ptr_const ctxt = + resolve_required_visible_const ctxt "c_uintptr_to_ptr" + 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)) + (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 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 + 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 = - C_Term_Build.mk_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 @@ -2142,6 +3265,137 @@ struct 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) @@ -2151,36 +3405,93 @@ struct 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 + (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 cast_const = Isa_Const (\<^const_name>\c_cast_from_void\, isa_dummyT) + 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 _ => @@ -2279,6 +3590,8 @@ struct (* 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) @@ -2299,6 +3612,13 @@ struct 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 list_var = Isa_Free ("v__arr_vals", 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 = @@ -2307,7 +3627,13 @@ struct 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)) + (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 @@ -2396,21 +3722,36 @@ struct 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. + 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 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 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 struct_field_offset (fields : (string * C_Ast_Utils.c_numeric_type) list) field_name = + (case List.find (fn (name, _, _) => name = field_name) (#1 (struct_layout fields)) of + SOME (_, offset, _) => offset + | NONE => error ("micro_c_translate: unknown struct field in layout: " ^ field_name)) fun fits_int_literal_cty cty n = case cty_bit_width cty of @@ -2428,30 +3769,47 @@ struct 0 <= n andalso n < two_pow end - fun choose_int_literal_type n flags = + 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) + in + case (is_unsigned, is_long, is_long_long, non_decimal) of + (false, false, false, false) => + [C_Ast_Utils.CInt, C_Ast_Utils.CLong, C_Ast_Utils.CLongLong] + | (false, false, false, true) => + [C_Ast_Utils.CInt, C_Ast_Utils.CUInt, + C_Ast_Utils.CLong, C_Ast_Utils.CULong, + C_Ast_Utils.CLongLong, C_Ast_Utils.CULongLong] + | (true, false, false, _) => + [C_Ast_Utils.CUInt, C_Ast_Utils.CULong, C_Ast_Utils.CULongLong] + | (false, true, false, false) => + [C_Ast_Utils.CLong, C_Ast_Utils.CLongLong] + | (false, true, false, true) => + [C_Ast_Utils.CLong, C_Ast_Utils.CULong, + C_Ast_Utils.CLongLong, C_Ast_Utils.CULongLong] + | (true, true, false, _) => + [C_Ast_Utils.CULong, C_Ast_Utils.CULongLong] + | (false, false, true, false) => + [C_Ast_Utils.CLongLong] + | (false, false, true, true) => + [C_Ast_Utils.CLongLong, C_Ast_Utils.CULongLong] + | (true, false, true, _) => + [C_Ast_Utils.CULongLong] + | _ => unsupported "unsupported integer literal suffix combination" + end + + fun choose_int_literal_type n repr flags = let - val unsuffixed = - (case flags of - Flags0 bits => IntInf.andb (bits, 7) = 0) + 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 - (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) + first_fit (int_literal_candidates repr flags) end @@ -2572,15 +3930,16 @@ struct (* 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 + 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) => (C_Term_Build.mk_literal var, cty) + 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. @@ -2589,17 +3948,23 @@ struct 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) => (C_Term_Build.mk_literal tm, cty) + 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 | translate_expr tctx (CBinary0 (binop, lhs, rhs, _)) = - let val (lhs', lhs_cty) = translate_expr tctx lhs + 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 @@ -2608,17 +3973,35 @@ struct 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) + 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 guarded = mk_index_guard idx_p_cty i_var p_var focused_lit + 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) in case binop of (* C logical operators short-circuit and return _Bool *) @@ -2718,22 +4101,62 @@ struct | (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 + 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 *) - mk_ptr_add rhs' lhs' lhs_cty elem_cty + 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, 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', + 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 | _ => @@ -2784,9 +4207,9 @@ struct 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 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", 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 _ = @@ -2808,8 +4231,19 @@ struct 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 (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)) @@ -2827,22 +4261,40 @@ struct 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) + 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, _)) = @@ -2853,8 +4305,19 @@ struct 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 (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) @@ -2871,8 +4334,8 @@ struct 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 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 = @@ -2908,6 +4371,47 @@ struct 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 @@ -3020,6 +4524,8 @@ struct (* 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) @@ -3027,15 +4533,18 @@ struct 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 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 @@ -3059,11 +4568,23 @@ struct 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)) + 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 @@ -3082,6 +4603,8 @@ struct (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) @@ -3089,6 +4612,13 @@ struct 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 list_var = Isa_Free ("v__arr_vals", 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) @@ -3121,8 +4651,17 @@ struct | _ => 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)) + 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 @@ -3176,6 +4715,15 @@ struct (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) | NONE => @@ -3361,6 +4909,7 @@ struct (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 @@ -3400,15 +4949,37 @@ struct 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 + val fn_ty = Library.foldr (fn (a_ty, acc_ty) => a_ty --> acc_ty) + (arg_tys, isa_dummyT) + 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_fueled + $ 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_fueled arg_terms + 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 @@ -3436,14 +5007,7 @@ struct | 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 + in (mk_resolved_deref_expr ctxt result_cty expr', 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 @@ -3523,7 +5087,10 @@ struct $ 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") + | 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 @@ -3546,16 +5113,13 @@ struct 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 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) - (* 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 => @@ -3566,8 +5130,6 @@ struct 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) @@ -3583,78 +5145,127 @@ struct | _ => 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")) + in + 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, _)) = + | 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, _) = translate_expr tctx expr + 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)) - in if is_union_aggregate struct_name then + 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 field_cty ptr_expr - val v = Isa_Free ("v__uref", isa_dummyT) + 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 (C_Term_Build.mk_deref (C_Term_Build.mk_literal v))), + (Term.lambda v (mk_resolved_deref_expr ctxt field_cty (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 + 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, _)) = + | 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)) - in if is_union_aggregate struct_name then + 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 field_cty loc_expr - val v = Isa_Free ("v__uref", isa_dummyT) + 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 (C_Term_Build.mk_deref (C_Term_Build.mk_literal v))), + (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 (C_Term_Build.mk_bind struct_expr - (Term.lambda v (C_Term_Build.mk_literal (accessor_const $ v))), + 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 | translate_expr tctx (CCond0 (cond, Some then_expr, else_expr, _)) = @@ -3949,12 +5560,16 @@ struct 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) | NONE => (case C_Trans_Ctxt.lookup_global_const tctx name of - SOME _ => - unsupported ("address-of global const without reference storage not supported: " ^ name) + 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 @@ -3973,19 +5588,39 @@ struct 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 = + val (base_expr, base_is_raw) = if is_ptr then - let val (ptr_expr, ptr_cty) = translate_expr tctx expr + 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 _ => ptr_expr + 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) - 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) + (#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 @@ -4002,6 +5637,8 @@ struct 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 = @@ -4022,14 +5659,36 @@ struct 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 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 = - 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)) + 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" @@ -4047,7 +5706,7 @@ struct 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. + (* 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, _)) = @@ -4130,7 +5789,7 @@ struct | 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 + 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) @@ -4141,7 +5800,9 @@ struct 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 + 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 @@ -4215,7 +5876,7 @@ struct (case declared_size of SOME n => SOME (elem_cty, n) | NONE => NONE) - in (name, init_term, actual_cty, arr_meta) end + in (name, init_term, actual_cty, arr_meta, false) end else (case actual_cty of C_Ast_Utils.CStruct struct_name => let val fields = @@ -4356,7 +6017,7 @@ struct C_Term_Build.mk_bind expr (Term.lambda var acc)) result (init_exprs, vars) end - in (name, init_term, actual_cty, NONE) 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), _) = @@ -4371,7 +6032,7 @@ struct 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 + 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" @@ -4419,42 +6080,50 @@ struct | 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' = + | 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 - (* 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'')) + 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 = @@ -4502,11 +6171,18 @@ struct 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 + 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 var = Isa_Free (name, isa_dummyT) - val tctx' = C_Trans_Ctxt.add_var name C_Trans_Ctxt.Param var cty tctx + 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 @@ -4673,6 +6349,44 @@ struct (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 @@ -4766,29 +6480,149 @@ struct 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 + (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) :: 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 + | 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 @@ -5040,9 +6874,89 @@ struct | 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 + 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 @@ -5057,14 +6971,24 @@ struct 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 + 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) + 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 @@ -5073,15 +6997,48 @@ struct 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. - 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) *) + 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), ctx) => C_Trans_Ctxt.add_var n C_Trans_Ctxt.Param v cty ctx) + (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) => @@ -5097,8 +7054,6 @@ struct 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 @@ -5112,17 +7067,33 @@ struct 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, _, _) => + 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), (ctx, binds)) => + (fn ((n, orig_var, cty, list_backed), (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 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 C_Trans_Ctxt.Local ref_var cty ctx + 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. @@ -5157,10 +7128,17 @@ struct (case !current_ref_expr_constraint of NONE => body_term | SOME expr_ty => Type.constraint expr_ty body_term) + val body_term = + (case ret_cty of + C_Ast_Utils.CVoid => constrain_known_expr_value_type @{typ unit} body_term + | _ => + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) ret_cty of + SOME ty => constrain_known_expr_value_type ty body_term + | NONE => 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 ((_, 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 [] @@ -5173,6 +7151,14 @@ struct 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') @@ -5190,6 +7176,7 @@ structure C_Def_Gen : sig 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 define_c_function : string -> string -> term -> local_theory -> local_theory val process_translation_unit : C_Ast.nodeInfo C_Ast.cTranslationUnit -> local_theory -> local_theory @@ -5206,14 +7193,21 @@ struct 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"} 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) + (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 @@ -5225,16 +7219,20 @@ struct ((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 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 + in + case head of + Term.Const (c, _) => + (Term.list_comb (Const (c, dummyT), args), "const: " ^ c) + | _ => (morphed_lhs, "registered term") + end 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)")) + (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 = @@ -5253,9 +7251,10 @@ struct 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 + 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 then lthy + if exists_const orelse exists_fixed then lthy else let val binding = Binding.name full_name @@ -5332,11 +7331,27 @@ struct 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))) 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) @@ -5345,12 +7360,28 @@ struct end end - fun extract_global_consts typedef_tab struct_tab enum_tab + 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, _, _, _)) = @@ -5381,12 +7412,80 @@ struct 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 = + 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 _) _ = + Const (\<^const_name>\c_uninitialized\, dummyT) + | init_expr_const_term target_cty (C_Ast.CConst0 (C_Ast.CStrConst0 (C_Ast.CString0 (abr_str, _), _))) = + (case target_cty of + _ => + 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 _ _ = + error "micro_c_translate: unsupported non-constant global initializer shape" fun process_decl specs declarators = - if not (has_const_qual specs) then [] + if not (has_const_qual specs orelse has_static_storage specs) then [] else let val base_cty = @@ -5405,7 +7504,7 @@ struct 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 init_term = init_expr_const_term actual_cty init val arr_meta = (case array_decl_size declr of SOME n => @@ -5424,23 +7523,39 @@ struct 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 + fun resolve_desig_idx [] pos = pos + | resolve_desig_idx [C_Ast.CArrDesig0 (C_Ast.CConst0 (C_Ast.CIntConst0 (C_Ast.CInteger0 (n, _, _), _)), _)] _ = + intinf_to_int_checked "global array designator" n + | resolve_desig_idx _ _ = + error "micro_c_translate: complex designator in global array initializer" + fun collect_indices [] _ = [] + | collect_indices ((desigs, init_item) :: rest) pos = + let val idx = resolve_desig_idx desigs pos + in (idx, init_item) :: collect_indices rest (idx + 1) end + val indexed_items = collect_indices init_list 0 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 = + val arr_size = 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 + 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 = - (case declared_size of - SOME n => SOME (elem_cty, n) - | NONE => NONE) + 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 _ = @@ -5455,6 +7570,10 @@ struct fun process_translation_unit tu lthy = 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 {functions = manifest_functions, types = manifest_types} = !current_manifest @@ -5474,15 +7593,22 @@ struct (* 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) + 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) @@ -5505,7 +7631,7 @@ struct 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) + 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 @@ -5601,6 +7727,24 @@ struct 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) @@ -5610,10 +7754,112 @@ struct (fn ((n, (_, ptys)), tab) => Symtab.update (n, ptys) tab) Symtab.empty signatures val func_param_types = Unsynchronized.ref func_param_table + 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) + 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 + val _ = C_Translate.current_list_backed_param_modes := list_backed_param_modes 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 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 @@ -5678,6 +7924,9 @@ local | TranslateGvTy of string | TranslateAbi of string | TranslateAbortTy of string + | TranslatePtrAdd of string + | TranslatePtrShiftSigned of string + | TranslatePtrDiff 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 () @@ -5689,36 +7938,54 @@ local val parse_gv_key = Parse.$$$ "gv:" >> K () val parse_abi_key = Parse.$$$ "abi:" >> K () val parse_abort_key = Parse.$$$ "abort:" >> 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_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) + || (parse_ptr_add_key |-- Parse.name >> TranslatePtrAdd) + || (parse_ptr_shift_signed_key |-- Parse.name >> TranslatePtrShiftSigned) + || (parse_ptr_diff_key |-- Parse.name >> TranslatePtrDiff) - fun apply_translate_opt (TranslatePrefix pfx) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt) = + fun apply_translate_opt (TranslatePrefix pfx) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = (case prefix_opt of - NONE => (SOME pfx, addr_opt, gv_opt, abi_opt, abort_opt) + NONE => (SOME pfx, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) | SOME _ => error "micro_c_translate: duplicate prefix option") - | apply_translate_opt (TranslateAddrTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt) = + | apply_translate_opt (TranslateAddrTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = (case addr_opt of - NONE => (prefix_opt, SOME ty, gv_opt, abi_opt, abort_opt) + NONE => (prefix_opt, SOME ty, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) | SOME _ => error "micro_c_translate: duplicate addr option") - | apply_translate_opt (TranslateGvTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt) = + | apply_translate_opt (TranslateGvTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = (case gv_opt of - NONE => (prefix_opt, addr_opt, SOME ty, abi_opt, abort_opt) + NONE => (prefix_opt, addr_opt, SOME ty, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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) = + | apply_translate_opt (TranslateAbi abi_name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = (case abi_opt of - NONE => (prefix_opt, addr_opt, gv_opt, SOME abi_name, abort_opt) + NONE => (prefix_opt, addr_opt, gv_opt, SOME abi_name, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) | SOME _ => error "micro_c_translate: duplicate abi option") - | apply_translate_opt (TranslateAbortTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt) = + | apply_translate_opt (TranslateAbortTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = (case abort_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, SOME ty) + NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, SOME ty, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) | SOME _ => error "micro_c_translate: duplicate abort option") + | apply_translate_opt (TranslatePtrAdd name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = + (case ptr_add_opt of + NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, SOME name, ptr_shift_signed_opt, ptr_diff_opt) + | SOME _ => error "micro_c_translate: duplicate ptr_add option") + | apply_translate_opt (TranslatePtrShiftSigned name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = + (case ptr_shift_signed_opt of + NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, SOME name, ptr_diff_opt) + | SOME _ => error "micro_c_translate: duplicate ptr_shift_signed option") + | apply_translate_opt (TranslatePtrDiff name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = + (case ptr_diff_opt of + NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, SOME name) + | SOME _ => error "micro_c_translate: duplicate ptr_diff option") fun collect_translate_opts opts = - fold apply_translate_opt opts (NONE, NONE, NONE, NONE, NONE) + fold apply_translate_opt opts (NONE, NONE, NONE, NONE, NONE, NONE, NONE, NONE) in val _ = Outer_Syntax.local_theory \<^command_keyword>\micro_c_translate\ @@ -5726,33 +7993,41 @@ val _ = (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_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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 + fun require_visible_const_name name = + (case try (Syntax.check_term lthy) (Free (name, dummyT)) of + SOME _ => name + | NONE => error ("micro_c_translate: missing required pointer-model constant: " ^ name)) + val pointer_model = + { ptr_add = SOME (require_visible_const_name (the_default "c_ptr_add" ptr_add_opt)) + , ptr_shift_signed = SOME (require_visible_const_name (the_default "c_ptr_shift_signed" ptr_shift_signed_opt)) + , ptr_diff = SOME (require_visible_const_name (the_default "c_ptr_diff" ptr_diff_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) + let + val abort_ty = the_default @{typ c_abort} abort_ty_opt + 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. *) @@ -5769,6 +8044,7 @@ val _ = 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 + val _ = C_Def_Gen.set_pointer_model pointer_model in C_Def_Gen.process_translation_unit tu lthy end)) @@ -5827,6 +8103,9 @@ local | LoadGvTy of string | LoadAbi of string | LoadAbortTy of string + | LoadPtrAdd of string + | LoadPtrShiftSigned of string + | LoadPtrDiff 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 = @@ -5839,6 +8118,9 @@ local val parse_gv_key = Parse.$$$ "gv:" >> K () val parse_abi_key = Parse.$$$ "abi:" >> K () val parse_abort_key = Parse.$$$ "abort:" >> 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_manifest_key = Parse.$$$ "manifest:" >> K () val parse_load_opt = (parse_prefix_key |-- Parse.name >> LoadPrefix) @@ -5846,6 +8128,9 @@ local || (parse_gv_key |-- Parse.typ >> LoadGvTy) || (parse_abi_key |-- parse_abi_name >> LoadAbi) || (parse_abort_key |-- Parse.typ >> LoadAbortTy) + || (parse_ptr_add_key |-- Parse.name >> LoadPtrAdd) + || (parse_ptr_shift_signed_key |-- Parse.name >> LoadPtrShiftSigned) + || (parse_ptr_diff_key |-- Parse.name >> LoadPtrDiff) || (parse_manifest_key |-- Resources.parse_file >> LoadManifest) val semi = Scan.option \<^keyword>\;\; @@ -5891,32 +8176,44 @@ local , 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) = + fun apply_load_opt (LoadPrefix prefix) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = (case prefix_opt of - NONE => (SOME prefix, addr_opt, gv_opt, abi_opt, abort_opt, manifest_opt) + NONE => (SOME prefix, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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) = + | apply_load_opt (LoadAddrTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = (case addr_opt of - NONE => (prefix_opt, SOME ty, gv_opt, abi_opt, abort_opt, manifest_opt) + NONE => (prefix_opt, SOME ty, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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) = + | apply_load_opt (LoadGvTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = (case gv_opt of - NONE => (prefix_opt, addr_opt, SOME ty, abi_opt, abort_opt, manifest_opt) + NONE => (prefix_opt, addr_opt, SOME ty, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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) = + | apply_load_opt (LoadAbi abi_name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = (case abi_opt of - NONE => (prefix_opt, addr_opt, gv_opt, SOME abi_name, abort_opt, manifest_opt) + NONE => (prefix_opt, addr_opt, gv_opt, SOME abi_name, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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) = + | apply_load_opt (LoadAbortTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = (case abort_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, SOME ty, manifest_opt) + NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, SOME ty, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, 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) = + | apply_load_opt (LoadPtrAdd name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = + (case ptr_add_opt of + NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, SOME name, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) + | SOME _ => error "micro_c_file: duplicate ptr_add option") + | apply_load_opt (LoadPtrShiftSigned name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = + (case ptr_shift_signed_opt of + NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, SOME name, ptr_diff_opt, manifest_opt) + | SOME _ => error "micro_c_file: duplicate ptr_shift_signed option") + | apply_load_opt (LoadPtrDiff name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = + (case ptr_diff_opt of + NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, SOME name, manifest_opt) + | SOME _ => error "micro_c_file: duplicate ptr_diff option") + | apply_load_opt (LoadManifest get_file) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = (case manifest_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, SOME get_file) + NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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) + fun collect_load_opts opts = fold apply_load_opt opts (NONE, NONE, NONE, NONE, NONE, NONE, NONE, NONE, NONE) in val _ = Outer_Syntax.local_theory \<^command_keyword>\micro_c_file\ @@ -5924,31 +8221,39 @@ val _ = (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_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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 + fun require_visible_const_name name = + (case try (Syntax.check_term lthy) (Free (name, dummyT)) of + SOME _ => name + | NONE => error ("micro_c_file: missing required pointer-model constant: " ^ name)) + val pointer_model = + { ptr_add = SOME (require_visible_const_name (the_default "c_ptr_add" ptr_add_opt)) + , ptr_shift_signed = SOME (require_visible_const_name (the_default "c_ptr_shift_signed" ptr_shift_signed_opt)) + , ptr_diff = SOME (require_visible_const_name (the_default "c_ptr_diff" ptr_diff_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) + let + val abort_ty = the_default @{typ c_abort} abort_ty_opt + 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 @@ -5993,6 +8298,7 @@ val _ = 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 + val _ = C_Def_Gen.set_pointer_model pointer_model in C_Def_Gen.process_translation_unit tu lthy 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..5af4a3e4 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy @@ -5,7 +5,7 @@ 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 +15,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 +28,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 +37,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 +45,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 +53,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 +62,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 +70,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 +89,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 +102,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 +113,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 +122,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 +135,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]; 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_Translation_Model.thy b/Shallow_Micro_C/C_Translation_Model.thy new file mode 100644 index 00000000..392346d0 --- /dev/null +++ b/Shallow_Micro_C/C_Translation_Model.thy @@ -0,0 +1,63 @@ +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\ + +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 From 20ac2bc06a155e7a9cac0015d902cf21364b770d Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Wed, 18 Mar 2026 23:06:03 +0000 Subject: [PATCH 02/58] Fix type_rank and usual_arith_conv for C11 compliance under ILP32 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit type_rank gave CLong/CULong and CLongLong/CULongLong the same rank (4), violating C11 6.3.1.1p1 which requires long long to rank higher than long. Under ILP32 where long is 32-bit and long long is 64-bit, this caused usual_arith_conv to return the wrong (narrower) type. Also fix the mixed-signedness branch of usual_arith_conv to check actual bit widths per C11 6.3.1.8 rules 2+3. The old code blindly picked the signed type without checking whether it could represent all unsigned values — wrong under ILP32 where e.g. long and unsigned int are both 32-bit. Both bugs were masked under LP64 (long == long long == 64-bit). --- .../C_To_Core_Translation.thy | 24 ++++++++++++------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy index e1518eac..8930d8c7 100644 --- a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy +++ b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy @@ -1620,10 +1620,10 @@ struct | 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 CLongLong = 5 + | type_rank CULongLong = 5 + | type_rank CInt128 = 6 + | type_rank CUInt128 = 6 | type_rank _ = 3 (* default: int rank *) (* C11 \
6.3.1.1: integer promotion — sub-int types promote to int *) @@ -1638,10 +1638,18 @@ struct 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 *) + 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) + | _ => s (* fallback: assume signed is wider *) end end end From 82ce961e75b5e11cf84199041e8faea8a4c8f401 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Wed, 18 Mar 2026 23:25:50 +0000 Subject: [PATCH 03/58] Fix smoke tests: add Separation_Algebra import for struct-array translations Smoke tests for struct-with-array-field patterns (e.g. &h->vec[i], array decay from struct fields) failed with "Undeclared class: Separation_Algebra.sepalg". The struct record declaration succeeded but the subsequent function translation needed the sepalg class in scope. Adding Separation_Algebra as a direct import to the two affected smoke test theories fixes all 16 errors. The session dependency is already transitively available via Shallow_Micro_C. --- Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy | 1 + Micro_C_Parsing_Frontend/C_Translation_Smoke_Options.thy | 1 + 2 files changed, 2 insertions(+) diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy index 5af4a3e4..39e27d41 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy @@ -1,6 +1,7 @@ theory C_Translation_Smoke_Memory imports C_To_Core_Translation + "Shallow_Separation_Logic.Separation_Algebra" begin section \Memory/Pointer Translation Smoke\ 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\ From f866af0db6a453797e747cb05b4398431d981627 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Wed, 18 Mar 2026 23:32:18 +0000 Subject: [PATCH 04/58] Add ILP32 smoke test for type_rank and usual_arith_conv fixes Tests long+long_long rank ordering and unsigned_int+long mixed-signedness conversion under abi: ilp32-le, where long is 32-bit and long long is 64-bit. Also includes sizeof sanity checks and ABI profile assertions. Added to both ROOT and AutoCorrode.thy so it runs in batch builds and jEdit sessions. --- AutoCorrode.thy | 1 + .../C_Translation_Smoke_ILP32.thy | 85 +++++++++++++++++++ Micro_C_Parsing_Frontend/ROOT | 1 + 3 files changed, 87 insertions(+) create mode 100644 Micro_C_Parsing_Frontend/C_Translation_Smoke_ILP32.thy diff --git a/AutoCorrode.thy b/AutoCorrode.thy index e9004874..7dca7b5e 100644 --- a/AutoCorrode.thy +++ b/AutoCorrode.thy @@ -23,6 +23,7 @@ theory AutoCorrode "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" "Shallow_Micro_C.C_Arithmetic_Rules" "Shallow_Micro_C.C_Abort" "Shallow_Micro_C.C_Abort_Rules" 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..249b9504 --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_ILP32.thy @@ -0,0 +1,85 @@ +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) + +end diff --git a/Micro_C_Parsing_Frontend/ROOT b/Micro_C_Parsing_Frontend/ROOT index 2f92f292..44a5c284 100644 --- a/Micro_C_Parsing_Frontend/ROOT +++ b/Micro_C_Parsing_Frontend/ROOT @@ -14,5 +14,6 @@ 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_Options C_File_Load_Smoke From ed11ecc6fdb8c5e8f1d8448e80008b8debe9ecf2 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Wed, 18 Mar 2026 23:33:44 +0000 Subject: [PATCH 05/58] Add c_signed_shr_conservative: abort on negative right shift operand c_signed_shr models GCC/Clang arithmetic (sign-extending) right shift, which is implementation-defined per C11 6.5.7p5. The new c_signed_shr_conservative variant aborts with SignedOverflow when the operand is negative, for use with the conservative compiler profile where no specific implementation-defined behavior is assumed. Includes equational WP rule (wp_c_signed_shr_conservative) and intro rule (wp_c_signed_shr_conservativeI) following the existing pattern. --- Shallow_Micro_C/C_Arithmetic_Rules.thy | 28 ++++++++++++++++++++++++++ Shallow_Micro_C/C_Numeric_Types.thy | 14 +++++++++++++ 2 files changed, 42 insertions(+) diff --git a/Shallow_Micro_C/C_Arithmetic_Rules.thy b/Shallow_Micro_C/C_Arithmetic_Rules.thy index 77cdc340..08b682b9 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]: diff --git a/Shallow_Micro_C/C_Numeric_Types.thy b/Shallow_Micro_C/C_Numeric_Types.thy index 2415f529..a07e94cb 100644 --- a/Shallow_Micro_C/C_Numeric_Types.thy +++ b/Shallow_Micro_C/C_Numeric_Types.thy @@ -232,6 +232,20 @@ 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))\ + section \C unsigned comparison operations\ definition c_unsigned_less :: \'l::{len} word \ 'l word \ From c83601f8ff03e4e2200fc302008c36afb5a1c92b Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Wed, 18 Mar 2026 23:38:26 +0000 Subject: [PATCH 06/58] Add c_scast_checked: abort on signed narrowing overflow c_scast silently truncates when narrowing (two's complement), which is implementation-defined per C11 6.3.1.3p3. The new c_scast_checked variant aborts with SignedOverflow when sint(w) does not fit in the target type's signed range, for use with the conservative compiler profile. Includes equational WP rule (wp_c_scast_checked) and intro rule (wp_c_scast_checkedI) following the existing pattern. --- Shallow_Micro_C/C_Arithmetic_Rules.thy | 29 ++++++++++++++++++++++++++ Shallow_Micro_C/C_Numeric_Types.thy | 13 ++++++++++++ 2 files changed, 42 insertions(+) diff --git a/Shallow_Micro_C/C_Arithmetic_Rules.thy b/Shallow_Micro_C/C_Arithmetic_Rules.thy index 08b682b9..a14127ac 100644 --- a/Shallow_Micro_C/C_Arithmetic_Rules.thy +++ b/Shallow_Micro_C/C_Arithmetic_Rules.thy @@ -617,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_Numeric_Types.thy b/Shallow_Micro_C/C_Numeric_Types.thy index a07e94cb..f0e98f4b 100644 --- a/Shallow_Micro_C/C_Numeric_Types.thy +++ b/Shallow_Micro_C/C_Numeric_Types.thy @@ -306,4 +306,17 @@ definition c_ucast :: \'a::{len} word \ ('s, 'b::{len} word, ' 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 From 4e96ef9c6cd918ea15000d71ed38a95467375229 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Wed, 18 Mar 2026 23:50:34 +0000 Subject: [PATCH 07/58] Add compiler: parameter for implementation-defined behavior control Adds C_Compiler structure with profiles controlling three C11 implementation-defined behaviors: - char signedness (signed on x86, unsigned on ARM) - signed right shift (arithmetic vs conservative/abort) - signed narrowing cast (truncating vs checked/abort) Known profiles: gcc-x86_64, clang-x86_64 (signed char, arithmetic shr, truncating), gcc-aarch64, clang-aarch64 (unsigned char, arithmetic shr, truncating), conservative (unsigned char, abort on negative shr, abort on narrowing overflow). Default (no compiler: specified) preserves existing behavior: unsigned char, arithmetic shr, truncating narrowing. Also refactors micro_c_file to reuse micro_c_translate option parsing instead of duplicating it. --- .../C_To_Core_Translation.thy | 285 ++++++++++-------- 1 file changed, 153 insertions(+), 132 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy index 8930d8c7..81556168 100644 --- a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy +++ b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy @@ -13,7 +13,7 @@ theory C_To_Core_Translation "Shallow_Micro_C.C_Translation_Model" keywords "micro_c_translate" :: thy_decl and "micro_c_file" :: thy_decl - and "prefix:" and "manifest:" and "addr:" and "gv:" and "abi:" and "abort:" + and "prefix:" and "manifest:" and "addr:" and "gv:" and "abi:" and "abort:" and "compiler:" begin section \C-to-Core Monad Translation Infrastructure\ @@ -86,6 +86,52 @@ struct 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 +\ + subsection \AST Utilities\ text \Helper functions for extracting information from Isabelle/C's AST nodes.\ @@ -389,7 +435,7 @@ struct 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 #char_is_signed (C_Compiler.get_compiler_profile ()) then SOME CSChar else SOME CChar else if has_short then if has_unsigned then SOME CUShort else SOME CShort @@ -2731,7 +2777,11 @@ struct end else let val cast_const = if C_Ast_Utils.is_signed from_cty - then Const (\<^const_name>\c_scast\, isa_dummyT) + 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. *) @@ -2900,7 +2950,11 @@ struct 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)) + 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)) | translate_binop _ _ = unsupported "unsupported binary operator" @@ -7287,7 +7341,7 @@ struct 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_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 @@ -7925,7 +7979,6 @@ text \ \ ML \ -local datatype translate_opt = TranslatePrefix of string | TranslateAddrTy of string @@ -7935,6 +7988,7 @@ local | TranslatePtrAdd of string | TranslatePtrShiftSigned of string | TranslatePtrDiff of string + | TranslateCompiler 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 () @@ -7949,6 +8003,7 @@ local 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) @@ -7958,64 +8013,88 @@ local || (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) + + type translate_opts = { + prefix: string option, addr: string option, gv: string option, + abi: string option, abort: string option, + ptr_add: string option, ptr_shift_signed: string option, ptr_diff: string option, + compiler: string option + } - fun apply_translate_opt (TranslatePrefix pfx) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = - (case prefix_opt of - NONE => (SOME pfx, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) - | SOME _ => error "micro_c_translate: duplicate prefix option") - | apply_translate_opt (TranslateAddrTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = - (case addr_opt of - NONE => (prefix_opt, SOME ty, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) - | SOME _ => error "micro_c_translate: duplicate addr option") - | apply_translate_opt (TranslateGvTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = - (case gv_opt of - NONE => (prefix_opt, addr_opt, SOME ty, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = - (case abi_opt of - NONE => (prefix_opt, addr_opt, gv_opt, SOME abi_name, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) - | SOME _ => error "micro_c_translate: duplicate abi option") - | apply_translate_opt (TranslateAbortTy ty) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = - (case abort_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, SOME ty, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) - | SOME _ => error "micro_c_translate: duplicate abort option") - | apply_translate_opt (TranslatePtrAdd name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = - (case ptr_add_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, SOME name, ptr_shift_signed_opt, ptr_diff_opt) - | SOME _ => error "micro_c_translate: duplicate ptr_add option") - | apply_translate_opt (TranslatePtrShiftSigned name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = - (case ptr_shift_signed_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, SOME name, ptr_diff_opt) - | SOME _ => error "micro_c_translate: duplicate ptr_shift_signed option") - | apply_translate_opt (TranslatePtrDiff name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt) = - (case ptr_diff_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, SOME name) - | SOME _ => error "micro_c_translate: duplicate ptr_diff option") + val empty_opts : translate_opts = { + prefix = NONE, addr = NONE, gv = NONE, abi = NONE, abort = NONE, + ptr_add = NONE, ptr_shift_signed = NONE, ptr_diff = NONE, compiler = NONE + } + + 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, + abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler 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, + abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler 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, + abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler 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, + abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler r} + | apply_translate_opt (TranslateAbortTy v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + abort = set_once "abort" (#abort r) v, ptr_add = #ptr_add r, + ptr_shift_signed = #ptr_shift_signed r, ptr_diff = #ptr_diff r, compiler = #compiler r} + | apply_translate_opt (TranslatePtrAdd v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + abort = #abort 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} + | apply_translate_opt (TranslatePtrShiftSigned v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + abort = #abort 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} + | apply_translate_opt (TranslatePtrDiff v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + abort = #abort 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} + | apply_translate_opt (TranslateCompiler v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + abort = #abort 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} fun collect_translate_opts opts = - fold apply_translate_opt opts (NONE, NONE, NONE, NONE, NONE, NONE, NONE, NONE) -in + fold apply_translate_opt opts empty_opts + 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, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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 + val opts = collect_translate_opts (opts_pre @ opts_post) + 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)) + val abort_ty_opt = Option.map (Syntax.read_typ lthy) (#abort opts) fun require_visible_const_name name = (case try (Syntax.check_term lthy) (Free (name, dummyT)) of SOME _ => name | NONE => error ("micro_c_translate: missing required pointer-model constant: " ^ name)) val pointer_model = - { ptr_add = SOME (require_visible_const_name (the_default "c_ptr_add" ptr_add_opt)) - , ptr_shift_signed = SOME (require_visible_const_name (the_default "c_ptr_shift_signed" ptr_shift_signed_opt)) - , ptr_diff = SOME (require_visible_const_name (the_default "c_ptr_diff" ptr_diff_opt)) + { 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))) } (* Build expression type constraint from abort type + locale's reference_types. This constrains state/abort/prompt positions so that type inference doesn't @@ -8050,13 +8129,13 @@ val _ = 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_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 in C_Def_Gen.process_translation_unit tu lthy end)) -end \ text \ @@ -8105,41 +8184,10 @@ text \ 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 - | LoadPtrAdd of string - | LoadPtrShiftSigned of string - | LoadPtrDiff 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_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 () + datatype load_opt = CommonOpt of translate_opt | ManifestOpt of (theory -> Token.file) 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_ptr_add_key |-- Parse.name >> LoadPtrAdd) - || (parse_ptr_shift_signed_key |-- Parse.name >> LoadPtrShiftSigned) - || (parse_ptr_diff_key |-- Parse.name >> LoadPtrDiff) - || (parse_manifest_key |-- Resources.parse_file >> LoadManifest) + (parse_translate_opt >> CommonOpt) || (parse_manifest_key |-- Resources.parse_file >> ManifestOpt) val semi = Scan.option \<^keyword>\;\; fun trim s = Symbol.trim_blanks s @@ -8184,44 +8232,13 @@ local , 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, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = - (case prefix_opt of - NONE => (SOME prefix, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = - (case addr_opt of - NONE => (prefix_opt, SOME ty, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = - (case gv_opt of - NONE => (prefix_opt, addr_opt, SOME ty, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = - (case abi_opt of - NONE => (prefix_opt, addr_opt, gv_opt, SOME abi_name, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = - (case abort_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, SOME ty, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) - | SOME _ => error "micro_c_file: duplicate abort option") - | apply_load_opt (LoadPtrAdd name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = - (case ptr_add_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, SOME name, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) - | SOME _ => error "micro_c_file: duplicate ptr_add option") - | apply_load_opt (LoadPtrShiftSigned name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = - (case ptr_shift_signed_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, SOME name, ptr_diff_opt, manifest_opt) - | SOME _ => error "micro_c_file: duplicate ptr_shift_signed option") - | apply_load_opt (LoadPtrDiff name) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = - (case ptr_diff_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, SOME name, manifest_opt) - | SOME _ => error "micro_c_file: duplicate ptr_diff option") - | apply_load_opt (LoadManifest get_file) (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_opt, manifest_opt) = - (case manifest_opt of - NONE => (prefix_opt, addr_opt, gv_opt, abi_opt, abort_opt, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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, NONE, NONE, NONE) + 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 in val _ = Outer_Syntax.local_theory \<^command_keyword>\micro_c_file\ @@ -8229,21 +8246,24 @@ val _ = (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, ptr_add_opt, ptr_shift_signed_opt, ptr_diff_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 + val (opts, manifest_get_file) = collect_load_opts (opts_pre @ opts_post) + 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)) + val abort_ty_opt = Option.map (Syntax.read_typ lthy) (#abort opts) fun require_visible_const_name name = (case try (Syntax.check_term lthy) (Free (name, dummyT)) of SOME _ => name | NONE => error ("micro_c_file: missing required pointer-model constant: " ^ name)) val pointer_model = - { ptr_add = SOME (require_visible_const_name (the_default "c_ptr_add" ptr_add_opt)) - , ptr_shift_signed = SOME (require_visible_const_name (the_default "c_ptr_shift_signed" ptr_shift_signed_opt)) - , ptr_diff = SOME (require_visible_const_name (the_default "c_ptr_diff" ptr_diff_opt)) + { 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))) } (* Build expression type constraint from abort type + locale's reference_types *) val expr_constraint = @@ -8304,6 +8324,7 @@ val _ = 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_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 From bb9bfa314a745eaf03fca8253780fc8ea9e09459 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Wed, 18 Mar 2026 23:52:00 +0000 Subject: [PATCH 08/58] Add compiler profile smoke tests Tests char signedness (gcc-x86_64 vs gcc-aarch64), signed right shift (arithmetic vs conservative), and signed narrowing cast (truncating vs checked) under different compiler: profiles. Added to both ROOT and AutoCorrode.thy. --- AutoCorrode.thy | 1 + .../C_Translation_Smoke_Compiler.thy | 65 +++++++++++++++++++ Micro_C_Parsing_Frontend/ROOT | 1 + 3 files changed, 67 insertions(+) create mode 100644 Micro_C_Parsing_Frontend/C_Translation_Smoke_Compiler.thy diff --git a/AutoCorrode.thy b/AutoCorrode.thy index 7dca7b5e..468e9ac5 100644 --- a/AutoCorrode.thy +++ b/AutoCorrode.thy @@ -24,6 +24,7 @@ theory AutoCorrode "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" 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/ROOT b/Micro_C_Parsing_Frontend/ROOT index 44a5c284..815fd730 100644 --- a/Micro_C_Parsing_Frontend/ROOT +++ b/Micro_C_Parsing_Frontend/ROOT @@ -15,5 +15,6 @@ session Micro_C_Parsing_Frontend = HOL + C_Translation_Smoke_Memory C_Translation_Smoke_Types C_Translation_Smoke_ILP32 + C_Translation_Smoke_Compiler C_Translation_Smoke_Options C_File_Load_Smoke From 80c1650f5ec2bbb896bdf6ea821d93bd9bcdd48f Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Wed, 18 Mar 2026 23:53:19 +0000 Subject: [PATCH 09/58] Add switch statement smoke tests MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Tests basic switch/case/default, fallthrough between cases, and switch without default. This was a significant gap — switch had translation infrastructure but zero test coverage. --- .../C_Translation_Smoke_Control.thy | 43 +++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Control.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Control.thy index 1424cd83..20e227aa 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Control.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Control.thy @@ -174,4 +174,47 @@ 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 + end From 28d2a9459232750b109e91526e2de22868e68006 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 08:06:52 +0000 Subject: [PATCH 10/58] Fix __int128 alignment in ML struct layout alignof_c_type returned min(sizeof, 8) = 8 for CInt128/CUInt128, but Isabelle c_alignof_int128 returns 16. Pattern-match these two cases to return 16, matching the Isabelle side and real ABI requirements. --- Micro_C_Parsing_Frontend/C_To_Core_Translation.thy | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy index 81556168..6dc06844 100644 --- a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy +++ b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy @@ -8235,7 +8235,7 @@ local 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) (_, 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 From 95be6cc951d18e17d52f5e0569dbb843c4b3ccab Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 08:08:14 +0000 Subject: [PATCH 11/58] Add c_sizeof/c_alignof for c_schar + serialize micro_c_translate Two changes: 1. c_schar (8 sword) had no sizeof/alignof instances, unlike every other C numeric type. Add c_sizeof_schar (= 1) and c_alignof_schar (= 1) with simp lemmas. 2. Fix sporadic "missing struct field accessor constant" concurrency bug. The ML translation pipeline uses ~30 global Unsynchronized.ref cells across C_Ast_Utils, C_Translate, C_Compiler, and C_Def_Gen. When Isabelle processes multiple theories in parallel, concurrent micro_c_translate commands clobber each other's state. Serialize all translations through a Synchronized.var mutex. --- .../C_To_Core_Translation.thy | 28 +++++++++++++++++-- Shallow_Micro_C/C_Sizeof.thy | 22 +++++++++++++++ 2 files changed, 47 insertions(+), 3 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy index 6dc06844..38b90476 100644 --- a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy +++ b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy @@ -320,7 +320,9 @@ struct 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 alignof_c_type CInt128 = 16 + | alignof_c_type CUInt128 = 16 + | alignof_c_type cty = Int.min (sizeof_c_type cty, 8) fun builtin_typedefs () = let @@ -7952,6 +7954,24 @@ struct 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 \ @@ -8076,6 +8096,7 @@ val _ = "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 prefix = the_default "c_" (#prefix opts) @@ -8135,7 +8156,7 @@ val _ = val _ = C_Def_Gen.set_pointer_model pointer_model in C_Def_Gen.process_translation_unit tu lthy - end)) + end))) \ text \ @@ -8245,6 +8266,7 @@ val _ = "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 prefix = the_default "c_" (#prefix opts) @@ -8330,7 +8352,7 @@ val _ = val _ = C_Def_Gen.set_pointer_model pointer_model in C_Def_Gen.process_translation_unit tu lthy - end)) + end))) 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) From c84fe11abffe228c1f52114320cb8e7c500e94e1 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 18:16:14 +0000 Subject: [PATCH 12/58] Document C_ABI.char_is_signed vs compiler profile precedence C_ABI.char_is_signed is not used by the translation pipeline; plain-char signedness is controlled by C_Compiler.get_compiler_profile (set via the compiler: option). Update comments at both sites to clarify this. --- Micro_C_Parsing_Frontend/C_To_Core_Translation.thy | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy index 38b90476..71a9cfa1 100644 --- a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy +++ b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy @@ -80,8 +80,11 @@ struct | 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. *) + (* 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 \ @@ -437,7 +440,8 @@ struct 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 #char_is_signed (C_Compiler.get_compiler_profile ()) then SOME CSChar else SOME CChar + else if #char_is_signed (C_Compiler.get_compiler_profile ()) then SOME CSChar else SOME CChar (* compiler: option controls plain-char signedness *) + else if has_short then if has_unsigned then SOME CUShort else SOME CShort From dcce5ac5f86f5f8fe1a8cd2b936c9a7d62db99a0 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 18:16:57 +0000 Subject: [PATCH 13/58] Document c_signed_div/c_unsigned_div hardcoded c_abort type Both signed and unsigned division/modulo hardcode c_abort (to construct DivisionByZero), unlike the other unsigned operations which are polymorphic in 'abort. Add text blocks explaining why and noting the consequence for locale abort type unification. --- Shallow_Micro_C/C_Numeric_Types.thy | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/Shallow_Micro_C/C_Numeric_Types.thy b/Shallow_Micro_C/C_Numeric_Types.thy index f0e98f4b..d1bbc61a 100644 --- a/Shallow_Micro_C/C_Numeric_Types.thy +++ b/Shallow_Micro_C/C_Numeric_Types.thy @@ -82,6 +82,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 \ @@ -127,6 +134,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 \ From f1abc20aa4304b747d5529539708baac298e2a41 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 20:08:35 +0000 Subject: [PATCH 14/58] Deduplicate intinf_to_int_checked and struct_name_of_cty Both functions had 3 identical copies across C_Ast_Utils, C_Translate, and C_Def_Gen. Move the canonical definitions to C_Ast_Utils (exported in the signature) and replace copies with val aliases. --- .../C_To_Core_Translation.thy | 86 ++++++------------- 1 file changed, 27 insertions(+), 59 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy index 71a9cfa1..b8e79739 100644 --- a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy +++ b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy @@ -164,6 +164,8 @@ structure C_Ast_Utils : sig 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 @@ -327,6 +329,27 @@ struct | 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 + fun builtin_typedefs () = let val uintptr_cty = pointer_uint_cty () @@ -592,20 +615,6 @@ struct 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 @@ -2968,11 +2977,7 @@ struct fun is_union_aggregate name = List.exists (fn n => n = name) (!current_union_names) - 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 + val struct_name_of_cty = C_Ast_Utils.struct_name_of_cty fun cty_of_decl_for_struct tctx (CDecl0 (specs, declrs, _)) = let @@ -3771,20 +3776,7 @@ struct | 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 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 @@ -3977,12 +3969,6 @@ struct 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 @@ -7355,26 +7341,8 @@ struct 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 + 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 From a7ea7a31a29fd035f74cfd92bb98c23e094eb34c Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 20:17:38 +0000 Subject: [PATCH 15/58] Add advanced feature smoke tests Smoke tests for string literals, compound literals, sizeof, _Alignof, struct-array access, and _Generic selection. These features were previously untested at the translation level. --- .../C_Translation_Smoke_Advanced.thy | 91 +++++++++++++++++++ Micro_C_Parsing_Frontend/ROOT | 1 + 2 files changed, 92 insertions(+) create mode 100644 Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy 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..429e7089 --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy @@ -0,0 +1,91 @@ +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 + +end diff --git a/Micro_C_Parsing_Frontend/ROOT b/Micro_C_Parsing_Frontend/ROOT index 815fd730..5620b27c 100644 --- a/Micro_C_Parsing_Frontend/ROOT +++ b/Micro_C_Parsing_Frontend/ROOT @@ -17,4 +17,5 @@ session Micro_C_Parsing_Frontend = HOL + C_Translation_Smoke_ILP32 C_Translation_Smoke_Compiler C_Translation_Smoke_Options + C_Translation_Smoke_Advanced C_File_Load_Smoke From af557be967a059d6841cc0f365af089e6854d69c Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 20:22:17 +0000 Subject: [PATCH 16/58] Factor shared command setup into setup_translation_context Extract the duplicated option processing + global ref setup from micro_c_translate and micro_c_file into a shared helper. Both commands call setup_translation_context, then do their source-specific work (inline source vs file loading + manifest). --- AutoCorrode.thy | 1 + .../C_To_Core_Translation.thy | 141 ++++++------------ 2 files changed, 50 insertions(+), 92 deletions(-) diff --git a/AutoCorrode.thy b/AutoCorrode.thy index 468e9ac5..9c39e369 100644 --- a/AutoCorrode.thy +++ b/AutoCorrode.thy @@ -18,6 +18,7 @@ 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" diff --git a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy index b8e79739..b5c2612d 100644 --- a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy +++ b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy @@ -8063,6 +8063,52 @@ ML \ 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)) + val abort_ty_opt = Option.map (Syntax.read_typ lthy) (#abort 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 abort_ty = the_default @{typ c_abort} abort_ty_opt + 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 _ = 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 + in () end + val _ = Outer_Syntax.local_theory \<^command_keyword>\micro_c_translate\ "parse C source and generate core monad definitions" @@ -8071,61 +8117,12 @@ val _ = with_micro_c_lock (fn () => let val opts = collect_translate_opts (opts_pre @ opts_post) - 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)) - val abort_ty_opt = Option.map (Syntax.read_typ lthy) (#abort opts) - fun require_visible_const_name name = - (case try (Syntax.check_term lthy) (Free (name, dummyT)) of - SOME _ => name - | NONE => error ("micro_c_translate: 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))) - } - (* 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 = - let - val abort_ty = the_default @{typ c_abort} abort_ty_opt - 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 _ = 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' - - (* 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_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 in C_Def_Gen.process_translation_unit tu lthy end))) @@ -8241,41 +8238,7 @@ val _ = with_micro_c_lock (fn () => let val (opts, manifest_get_file) = collect_load_opts (opts_pre @ opts_post) - 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)) - val abort_ty_opt = Option.map (Syntax.read_typ lthy) (#abort opts) - fun require_visible_const_name name = - (case try (Syntax.check_term lthy) (Free (name, dummyT)) of - SOME _ => name - | NONE => error ("micro_c_file: 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))) - } - (* Build expression type constraint from abort type + locale's reference_types *) - val expr_constraint = - let - val abort_ty = the_default @{typ c_abort} abort_ty_opt - 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 _ = 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 @@ -8315,13 +8278,7 @@ val _ = (* 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_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 in C_Def_Gen.process_translation_unit tu lthy end))) From 3b4c08963fd38698557ad0ee9d5b9313690071dd Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 21:05:59 +0000 Subject: [PATCH 17/58] Add generic AST fold, eliminate duplicated walker traversals MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Introduce fold_c_expr, fold_c_init, and fold_c_stmt — generic post-order folds over C AST nodes that factor out the recursive traversal structure shared by all AST analysis passes. Rewrite 7 walkers (expr_reads_vars, expr_written_vars, find_assigned_vars, find_goto_targets, find_called_functions, find_indexed_base_vars, find_named_calls_with_args) as thin handler functions over the generic fold, removing ~250 lines of duplicated pattern matching. Remove dead find_loop_written_vars from C_Ast_Utils (superseded by find_loop_written_vars_local in C_Def_Gen). Complex walkers (expr_has_side_effect_with, find_list_backed_aliases) are left unchanged — they thread context or environment state that doesn't fit the simple fold pattern. --- .../C_To_Core_Translation.thy | 487 +++++------------- 1 file changed, 119 insertions(+), 368 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy index b5c2612d..7e259c75 100644 --- a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy +++ b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy @@ -801,48 +801,96 @@ struct fun fundef_is_pure_with pure_tab (CFunDef0 (_, _, _, body, _)) = not (stmt_has_side_effect_with pure_tab body) - 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 _ = [] + (* ----- 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 @@ -863,187 +911,31 @@ struct end (* Walk the C AST and collect variable names that appear on the LHS of - assignments or as operands of pre/post increment/decrement. + assignments or as operands of pre/post increment/decrement or address-of. 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 - - local - fun writes_if in_loop e acc = - if in_loop then expr_written_vars e @ acc else acc - - fun loop_init_writes in_loop (Left (Some e)) acc = writes_if in_loop e acc - | loop_init_writes in_loop (Right d) acc = loop_decl_writes in_loop d acc - | loop_init_writes _ _ acc = acc - - and loop_decl_writes in_loop (CDecl0 (_, declarators, _)) acc = - List.foldl - (fn (((_, Some init), _), ac) => loop_initval_writes in_loop init ac - | (_, ac) => ac) - acc declarators - | loop_decl_writes _ _ acc = acc - - and loop_initval_writes in_loop (CInitExpr0 (e, _)) acc = writes_if in_loop e acc - | loop_initval_writes in_loop (CInitList0 (inits, _)) acc = - List.foldl (fn ((_, init), ac) => loop_initval_writes in_loop init ac) acc inits - - fun loop_item_writes in_loop (CBlockStmt0 s) acc = loop_stmt_writes in_loop s acc - | loop_item_writes in_loop (CBlockDecl0 d) acc = loop_decl_writes in_loop d acc - | loop_item_writes _ _ acc = acc - - and loop_stmt_writes in_loop (CCompound0 (_, items, _)) acc = - List.foldl (fn (it, ac) => loop_item_writes in_loop it ac) acc items - | loop_stmt_writes in_loop (CExpr0 (Some e, _)) acc = writes_if in_loop e acc - | loop_stmt_writes _ (CExpr0 (None, _)) acc = acc - | loop_stmt_writes in_loop (CReturn0 (Some e, _)) acc = writes_if in_loop e acc - | loop_stmt_writes _ (CReturn0 (None, _)) acc = acc - | loop_stmt_writes in_loop (CIf0 (c, t, e_opt, _)) acc = - let - val acc = writes_if in_loop c acc - val acc = loop_stmt_writes in_loop t acc - in - (case e_opt of Some e => loop_stmt_writes in_loop e acc | None => acc) - end - | loop_stmt_writes _ (CWhile0 (c, b, _, _)) acc = - let - val acc = writes_if true c acc - val acc = loop_stmt_writes true b acc - in acc end - | loop_stmt_writes _ (CFor0 (init, c, s, b, _)) acc = - let - val acc = loop_init_writes true init acc - val acc = (case c of Some e => writes_if true e acc | None => acc) - val acc = (case s of Some e => writes_if true e acc | None => acc) - val acc = loop_stmt_writes true b acc - in acc end - | loop_stmt_writes in_loop (CSwitch0 (e, s, _)) acc = - loop_stmt_writes in_loop s (writes_if in_loop e acc) - | loop_stmt_writes in_loop (CCase0 (e, s, _)) acc = - loop_stmt_writes in_loop s (writes_if in_loop e acc) - | loop_stmt_writes in_loop (CDefault0 (s, _)) acc = - loop_stmt_writes in_loop s acc - | loop_stmt_writes in_loop (CLabel0 (_, s, _, _)) acc = - loop_stmt_writes in_loop s acc - | loop_stmt_writes _ _ acc = acc - in - fun find_loop_written_vars stmt = distinct (op =) (loop_stmt_writes false stmt []) - end + 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. *) - 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 + 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. *) - 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 + 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, _, _, _)) = @@ -1193,153 +1085,6 @@ struct alias_names_from_expr struct_tab array_field_tab env struct_env e acc | opt_alias_expr _ _ _ _ None acc = acc - fun indexed_base_vars_expr (CIndex0 (CVar0 (ident, _), idx, _)) acc = - indexed_base_vars_expr idx (ident_name ident :: acc) - | indexed_base_vars_expr (CUnary0 (CIndOp0, CVar0 (ident, _), _)) acc = - ident_name ident :: acc - | indexed_base_vars_expr (CAssign0 (_, lhs, rhs, _)) acc = - indexed_base_vars_expr rhs (indexed_base_vars_expr lhs acc) - | indexed_base_vars_expr (CBinary0 (_, l, r, _)) acc = - indexed_base_vars_expr r (indexed_base_vars_expr l acc) - | indexed_base_vars_expr (CUnary0 (_, e, _)) acc = - indexed_base_vars_expr e acc - | indexed_base_vars_expr (CIndex0 (a, i, _)) acc = - indexed_base_vars_expr i (indexed_base_vars_expr a acc) - | indexed_base_vars_expr (CMember0 (e, _, _, _)) acc = - indexed_base_vars_expr e acc - | indexed_base_vars_expr (CCast0 (_, e, _)) acc = - indexed_base_vars_expr e acc - | indexed_base_vars_expr (CCall0 (f, args, _)) acc = - List.foldl (fn (a, ac) => indexed_base_vars_expr a ac) - (indexed_base_vars_expr f acc) args - | indexed_base_vars_expr (CComma0 (es, _)) acc = - List.foldl (fn (e, ac) => indexed_base_vars_expr e ac) acc es - | indexed_base_vars_expr (CCond0 (c, t, e, _)) acc = - indexed_base_vars_expr e - ((case t of Some te => indexed_base_vars_expr te | None => I) - (indexed_base_vars_expr c acc)) - | indexed_base_vars_expr _ acc = acc - - fun indexed_base_vars_stmt (CCompound0 (_, items, _)) acc = - List.foldl - (fn (CBlockStmt0 stmt, ac) => indexed_base_vars_stmt stmt ac - | (CBlockDecl0 (CDecl0 (_, declarators, _)), ac) => - List.foldl - (fn (((_, Some (CInitExpr0 (e, _))), _), ac') => indexed_base_vars_expr e ac' - | (_, ac') => ac') - ac declarators - | (_, ac) => ac) - acc items - | indexed_base_vars_stmt (CExpr0 (Some e, _)) acc = indexed_base_vars_expr e acc - | indexed_base_vars_stmt (CReturn0 (Some e, _)) acc = indexed_base_vars_expr e acc - | indexed_base_vars_stmt (CIf0 (c, t, e_opt, _)) acc = - (case e_opt of Some e => indexed_base_vars_stmt e | None => I) - (indexed_base_vars_stmt t (indexed_base_vars_expr c acc)) - | indexed_base_vars_stmt (CWhile0 (c, b, _, _)) acc = - indexed_base_vars_stmt b (indexed_base_vars_expr c acc) - | indexed_base_vars_stmt (CFor0 (Left (Some i), c, s, b, _)) acc = - indexed_base_vars_stmt b - (opt_index_expr s (opt_index_expr c (indexed_base_vars_expr i acc))) - | indexed_base_vars_stmt (CFor0 (Left None, c, s, b, _)) acc = - indexed_base_vars_stmt b (opt_index_expr s (opt_index_expr c acc)) - | indexed_base_vars_stmt (CFor0 (Right d, c, s, b, _)) acc = - let - val acc' = - (case d of - CDecl0 (_, declarators, _) => - List.foldl - (fn (((_, Some (CInitExpr0 (e, _))), _), ac') => indexed_base_vars_expr e ac' - | (_, ac') => ac') - acc declarators - | _ => acc) - in - indexed_base_vars_stmt b (opt_index_expr s (opt_index_expr c acc')) - end - | indexed_base_vars_stmt (CSwitch0 (e, s, _)) acc = - indexed_base_vars_stmt s (indexed_base_vars_expr e acc) - | indexed_base_vars_stmt (CCase0 (e, s, _)) acc = - indexed_base_vars_stmt s (indexed_base_vars_expr e acc) - | indexed_base_vars_stmt (CDefault0 (s, _)) acc = - indexed_base_vars_stmt s acc - | indexed_base_vars_stmt (CLabel0 (_, s, _, _)) acc = - indexed_base_vars_stmt s acc - | indexed_base_vars_stmt _ acc = acc - - and opt_index_expr (Some e) acc = indexed_base_vars_expr e acc - | opt_index_expr None acc = acc - - fun named_calls_expr (CCall0 (CVar0 (ident, _), args, _)) acc = - List.foldl (fn (a, ac) => named_calls_expr a ac) - ((ident_name ident, args) :: acc) args - | named_calls_expr (CCall0 (f, args, _)) acc = - List.foldl (fn (a, ac) => named_calls_expr a ac) - (named_calls_expr f acc) args - | named_calls_expr (CAssign0 (_, lhs, rhs, _)) acc = - named_calls_expr rhs (named_calls_expr lhs acc) - | named_calls_expr (CBinary0 (_, l, r, _)) acc = - named_calls_expr r (named_calls_expr l acc) - | named_calls_expr (CUnary0 (_, e, _)) acc = - named_calls_expr e acc - | named_calls_expr (CIndex0 (a, i, _)) acc = - named_calls_expr i (named_calls_expr a acc) - | named_calls_expr (CMember0 (e, _, _, _)) acc = - named_calls_expr e acc - | named_calls_expr (CCast0 (_, e, _)) acc = - named_calls_expr e acc - | named_calls_expr (CComma0 (es, _)) acc = - List.foldl (fn (e, ac) => named_calls_expr e ac) acc es - | named_calls_expr (CCond0 (c, t, e, _)) acc = - named_calls_expr e - ((case t of Some te => named_calls_expr te | None => I) - (named_calls_expr c acc)) - | named_calls_expr _ acc = acc - - fun named_calls_stmt (CCompound0 (_, items, _)) acc = - List.foldl - (fn (CBlockStmt0 stmt, ac) => named_calls_stmt stmt ac - | (CBlockDecl0 (CDecl0 (_, declarators, _)), ac) => - List.foldl - (fn (((_, Some (CInitExpr0 (e, _))), _), ac') => named_calls_expr e ac' - | (_, ac') => ac') - ac declarators - | (_, ac) => ac) - acc items - | named_calls_stmt (CExpr0 (Some e, _)) acc = named_calls_expr e acc - | named_calls_stmt (CReturn0 (Some e, _)) acc = named_calls_expr e acc - | named_calls_stmt (CIf0 (c, t, e_opt, _)) acc = - (case e_opt of Some e => named_calls_stmt e | None => I) - (named_calls_stmt t (named_calls_expr c acc)) - | named_calls_stmt (CWhile0 (c, b, _, _)) acc = - named_calls_stmt b (named_calls_expr c acc) - | named_calls_stmt (CFor0 (Left (Some i), c, s, b, _)) acc = - named_calls_stmt b (opt_call_expr s (opt_call_expr c (named_calls_expr i acc))) - | named_calls_stmt (CFor0 (Left None, c, s, b, _)) acc = - named_calls_stmt b (opt_call_expr s (opt_call_expr c acc)) - | named_calls_stmt (CFor0 (Right d, c, s, b, _)) acc = - let - val acc' = - (case d of - CDecl0 (_, declarators, _) => - List.foldl - (fn (((_, Some (CInitExpr0 (e, _))), _), ac') => named_calls_expr e ac' - | (_, ac') => ac') - acc declarators - | _ => acc) - in - named_calls_stmt b (opt_call_expr s (opt_call_expr c acc')) - end - | named_calls_stmt (CSwitch0 (e, s, _)) acc = - named_calls_stmt s (named_calls_expr e acc) - | named_calls_stmt (CCase0 (e, s, _)) acc = - named_calls_stmt s (named_calls_expr e acc) - | named_calls_stmt (CDefault0 (s, _)) acc = - named_calls_stmt s acc - | named_calls_stmt (CLabel0 (_, s, _, _)) acc = - named_calls_stmt s acc - | named_calls_stmt _ acc = acc - - and opt_call_expr (Some e) acc = named_calls_expr e acc - | opt_call_expr None acc = acc in fun find_list_backed_aliases struct_tab array_field_tab (CFunDef0 (_, declr, _, body, _)) = let @@ -1387,13 +1132,19 @@ struct Symtab.keys (iterate env0) end - fun find_indexed_base_vars (CFunDef0 (_, _, _, body, _)) = - distinct (op =) (indexed_base_vars_stmt body []) - - fun find_named_calls_with_args (CFunDef0 (_, _, _, body, _)) = - rev (named_calls_stmt body []) 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. From 190384fcb719661482cbf638be8ece40d18c3c37 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 21:08:40 +0000 Subject: [PATCH 18/58] Add verified signed addition example with overflow precondition MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Exercises c_signed_add end-to-end: C source → translation → contract with c_signed_in_range precondition → crush_boot/crush_base proof. This fills the gap identified in the audit where no signed arithmetic operation had a fully verified example demonstrating the overflow precondition pattern. --- Micro_C_Examples/Simple_C_Functions.thy | 26 +++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/Micro_C_Examples/Simple_C_Functions.thy b/Micro_C_Examples/Simple_C_Functions.thy index 241ac71a..f04d4574 100644 --- a/Micro_C_Examples/Simple_C_Functions.thy +++ b/Micro_C_Examples/Simple_C_Functions.thy @@ -171,6 +171,32 @@ 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) + end section \C Unsigned Arithmetic Verification\ From a3c2f2767b879519bfd3362975e57fd16e4cb5ae Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 21:10:35 +0000 Subject: [PATCH 19/58] Add verified unsigned division example with division-by-zero precondition MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Exercises c_unsigned_div end-to-end: C source → translation → contract with b ≠ 0 precondition → crush_boot/crush_base proof. This fills the gap where no division/modulo operation had a fully verified example. --- Micro_C_Examples/Simple_C_Functions.thy | 26 +++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/Micro_C_Examples/Simple_C_Functions.thy b/Micro_C_Examples/Simple_C_Functions.thy index f04d4574..f402de1f 100644 --- a/Micro_C_Examples/Simple_C_Functions.thy +++ b/Micro_C_Examples/Simple_C_Functions.thy @@ -741,6 +741,32 @@ 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) + end section \Fixed-width integer type verification (\<^verbatim>\uint16_t\)\ From 0867f6b5f418fa29ac8a5268173a05f1aead1af7 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 21:13:45 +0000 Subject: [PATCH 20/58] Add multi-function contract composition example Verify u_call_helper (identity) and u_call_caller (calls helper twice and adds results) with composing contracts. The caller's proof automatically uses the helper's [crush_specs]-tagged spec, demonstrating the cross-function verification pattern. --- Micro_C_Examples/Simple_C_Functions.thy | 29 +++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/Micro_C_Examples/Simple_C_Functions.thy b/Micro_C_Examples/Simple_C_Functions.thy index f402de1f..e2cc8603 100644 --- a/Micro_C_Examples/Simple_C_Functions.thy +++ b/Micro_C_Examples/Simple_C_Functions.thy @@ -252,6 +252,35 @@ micro_c_translate \ 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). From 7be339ff19ffb3420e173a4518604022e9689165 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 21:24:38 +0000 Subject: [PATCH 21/58] Split C_To_Core_Translation.thy into 4 focused theory files MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit C_ABI_And_Compiler.thy (~125 lines) — ABI and compiler profiles C_Ast_Utilities.thy (~1340 lines) — AST walking, type resolution, generic fold C_Translation_Engine.thy (~5510 lines) — translation context, term building, expr/stmt translation C_Definition_Generation.thy (~1070 lines) — function definition generation, command registration C_To_Core_Translation.thy is retained as a re-export stub so that all downstream imports continue to work unchanged. --- .../C_ABI_And_Compiler.thy | 125 + Micro_C_Parsing_Frontend/C_Ast_Utilities.thy | 1342 +++ .../C_Definition_Generation.thy | 1074 +++ .../C_To_Core_Translation.thy | 8036 +---------------- .../C_Translation_Engine.thy | 5516 +++++++++++ Micro_C_Parsing_Frontend/ROOT | 4 + 6 files changed, 8062 insertions(+), 8035 deletions(-) create mode 100644 Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy create mode 100644 Micro_C_Parsing_Frontend/C_Ast_Utilities.thy create mode 100644 Micro_C_Parsing_Frontend/C_Definition_Generation.thy create mode 100644 Micro_C_Parsing_Frontend/C_Translation_Engine.thy 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..00477f85 --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy @@ -0,0 +1,125 @@ +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 \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 + + (* 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..0241624a --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy @@ -0,0 +1,1342 @@ +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 \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_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 + + 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 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 + + 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 #char_is_signed (C_Compiler.get_compiler_profile ()) then SOME CSChar else SOME CChar (* compiler: option controls plain-char signedness *) + + 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 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 + + (* 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 pure_tab (CAssign0 _) = true + | expr_has_side_effect_with pure_tab (CUnary0 (CPreIncOp0, _, _)) = true + | expr_has_side_effect_with pure_tab (CUnary0 (CPostIncOp0, _, _)) = true + | expr_has_side_effect_with pure_tab (CUnary0 (CPreDecOp0, _, _)) = true + | expr_has_side_effect_with pure_tab (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 + + 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 struct_tab array_field_tab env struct_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 struct_tab array_field_tab env 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_struct_bindings struct_names decl struct_env = + (case (declr_of_decl decl, struct_name_of_decl struct_names decl) of + (SOME declr, SOME sname) => + Symtab.update (declr_name declr, sname) struct_env + | _ => struct_env) + + 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_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 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 + 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 + + fun cty_needs_parametric_struct parametric_structs (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 + + (* 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_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 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 = 5 + | type_rank CULongLong = 5 + | type_rank CInt128 = 6 + | type_rank CUInt128 = 6 + | 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 (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) + | _ => s (* fallback: assume signed is wider *) + 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..85817dde --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -0,0 +1,1074 @@ +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 "abort:" and "compiler:" +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 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"} + + 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 + in + case head of + Term.Const (c, _) => + (Term.list_comb (Const (c, dummyT), args), "const: " ^ c) + | _ => (morphed_lhs, "registered term") + end + 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 + + 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 (#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))) 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.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 _) _ = + Const (\<^const_name>\c_uninitialized\, dummyT) + | init_expr_const_term target_cty (C_Ast.CConst0 (C_Ast.CStrConst0 (C_Ast.CString0 (abr_str, _), _))) = + (case target_cty of + _ => + 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 _ _ = + 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 resolve_desig_idx [] pos = pos + | resolve_desig_idx [C_Ast.CArrDesig0 (C_Ast.CConst0 (C_Ast.CIntConst0 (C_Ast.CInteger0 (n, _, _), _)), _)] _ = + intinf_to_int_checked "global array designator" n + | resolve_desig_idx _ _ = + error "micro_c_translate: complex designator in global array initializer" + fun collect_indices [] _ = [] + | collect_indices ((desigs, init_item) :: rest) pos = + let val idx = resolve_desig_idx desigs pos + in (idx, init_item) :: collect_indices rest (idx + 1) 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 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 _ = 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 {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 @ 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 + (* 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 @ 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 + 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 + 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) + 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 + val _ = C_Translate.current_list_backed_param_modes := list_backed_param_modes + 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 + (* 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 + | TranslateAbortTy of string + | TranslatePtrAdd of string + | TranslatePtrShiftSigned of string + | TranslatePtrDiff of string + | TranslateCompiler 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_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_abort_key |-- Parse.typ >> TranslateAbortTy) + || (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) + + type translate_opts = { + prefix: string option, addr: string option, gv: string option, + abi: string option, abort: string option, + ptr_add: string option, ptr_shift_signed: string option, ptr_diff: string option, + compiler: string option + } + + val empty_opts : translate_opts = { + prefix = NONE, addr = NONE, gv = NONE, abi = NONE, abort = NONE, + ptr_add = NONE, ptr_shift_signed = NONE, ptr_diff = NONE, compiler = NONE + } + + 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, + abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler 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, + abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler 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, + abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler 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, + abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_diff = #ptr_diff r, compiler = #compiler r} + | apply_translate_opt (TranslateAbortTy v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + abort = set_once "abort" (#abort r) v, ptr_add = #ptr_add r, + ptr_shift_signed = #ptr_shift_signed r, ptr_diff = #ptr_diff r, compiler = #compiler r} + | apply_translate_opt (TranslatePtrAdd v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + abort = #abort 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} + | apply_translate_opt (TranslatePtrShiftSigned v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + abort = #abort 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} + | apply_translate_opt (TranslatePtrDiff v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + abort = #abort 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} + | apply_translate_opt (TranslateCompiler v) (r : translate_opts) = + {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, + abort = #abort 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} + + 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)) + val abort_ty_opt = Option.map (Syntax.read_typ lthy) (#abort 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 abort_ty = the_default @{typ c_abort} abort_ty_opt + 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 _ = 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 + 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 f) (_, 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 +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. + 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_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 7e259c75..bc979fbf 100644 --- a/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy +++ b/Micro_C_Parsing_Frontend/C_To_Core_Translation.thy @@ -1,8039 +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" - "Shallow_Micro_C.C_Translation_Model" - keywords "micro_c_translate" :: thy_decl - and "micro_c_file" :: thy_decl - and "prefix:" and "manifest:" and "addr:" and "gv:" and "abi:" and "abort:" and "compiler:" + 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 - - (* 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 -\ - -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 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_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 - - 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 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 - - 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 #char_is_signed (C_Compiler.get_compiler_profile ()) then SOME CSChar else SOME CChar (* compiler: option controls plain-char signedness *) - - 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 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 - - (* 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 pure_tab (CAssign0 _) = true - | expr_has_side_effect_with pure_tab (CUnary0 (CPreIncOp0, _, _)) = true - | expr_has_side_effect_with pure_tab (CUnary0 (CPostIncOp0, _, _)) = true - | expr_has_side_effect_with pure_tab (CUnary0 (CPreDecOp0, _, _)) = true - | expr_has_side_effect_with pure_tab (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 - - 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 struct_tab array_field_tab env struct_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 struct_tab array_field_tab env 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_struct_bindings struct_names decl struct_env = - (case (declr_of_decl decl, struct_name_of_decl struct_names decl) of - (SOME declr, SOME sname) => - Symtab.update (declr_name declr, sname) struct_env - | _ => struct_env) - - 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_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 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 - 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 - - fun cty_needs_parametric_struct parametric_structs (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 - - (* 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_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 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 = 5 - | type_rank CULongLong = 5 - | type_rank CInt128 = 6 - | type_rank CUInt128 = 6 - | 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 (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) - | _ => s (* fallback: assume signed is wider *) - 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 | 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 - - 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_expr_arrow arg_ty value_ty tm = - (case expr_type_with_value value_ty of - SOME expr_ty => Type.constraint (arg_ty --> expr_ty) tm - | NONE => tm) - - fun constrain_expr_arrow_from_tm arg_ty value_ty side_tm tm = - (case expr_type_from_tm value_ty side_tm of - SOME expr_ty => Type.constraint (arg_ty --> expr_ty) tm - | NONE => tm) - - fun constrain_function_body_arrow arg_ty value_ty tm = - (case function_body_type_with_value value_ty of - SOME body_ty => Type.constraint (arg_ty --> body_ty) tm - | NONE => tm) - - 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 polymorphic so later - context (e.g. indexing vs scalar dereference) can resolve it. *) - 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 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 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 cast_term = mk_cast_from_void_untyped tm - val target_ty = - (case pointer_expr_value_hol_ty to_cty of - SOME ty => ty - | NONE => isa_dummyT) - in if target_ty = isa_dummyT then cast_term - else constrain_expr_value_type target_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* where neither is void/union: - reinterpret through void* so the resulting focused reference - carries U's prism (byte-level view), rather than leaving the - term at type T* while only changing the tracked C type. *) - 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 ctxt = 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) - - - 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 - - (* 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 (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)) - | 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) - - 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 label 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 resolve_ptr_to_uintptr_const ctxt = - resolve_required_visible_const ctxt "c_ptr_to_uintptr" - - fun resolve_uintptr_to_ptr_const ctxt = - resolve_required_visible_const ctxt "c_uintptr_to_ptr" - - 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 cast_const = Isa_Const (\<^const_name>\c_cast_from_void\, isa_dummyT) - 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 list_var = Isa_Free ("v__arr_vals", 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 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 - - 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 struct_field_offset (fields : (string * C_Ast_Utils.c_numeric_type) list) field_name = - (case List.find (fn (name, _, _) => name = field_name) (#1 (struct_layout fields)) of - SOME (_, offset, _) => offset - | NONE => error ("micro_c_translate: unknown struct field in layout: " ^ field_name)) - - 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 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) - in - case (is_unsigned, is_long, is_long_long, non_decimal) of - (false, false, false, false) => - [C_Ast_Utils.CInt, C_Ast_Utils.CLong, C_Ast_Utils.CLongLong] - | (false, false, false, true) => - [C_Ast_Utils.CInt, C_Ast_Utils.CUInt, - C_Ast_Utils.CLong, C_Ast_Utils.CULong, - C_Ast_Utils.CLongLong, C_Ast_Utils.CULongLong] - | (true, false, false, _) => - [C_Ast_Utils.CUInt, C_Ast_Utils.CULong, C_Ast_Utils.CULongLong] - | (false, true, false, false) => - [C_Ast_Utils.CLong, C_Ast_Utils.CLongLong] - | (false, true, false, true) => - [C_Ast_Utils.CLong, C_Ast_Utils.CULong, - C_Ast_Utils.CLongLong, C_Ast_Utils.CULongLong] - | (true, true, false, _) => - [C_Ast_Utils.CULong, C_Ast_Utils.CULongLong] - | (false, false, true, false) => - [C_Ast_Utils.CLongLong] - | (false, false, true, true) => - [C_Ast_Utils.CLongLong, C_Ast_Utils.CULongLong] - | (true, false, true, _) => - [C_Ast_Utils.CULongLong] - | _ => unsupported "unsupported integer literal suffix combination" - end - - 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 --- *) - - (* 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 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, 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 - | 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) - 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, _) => - 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, 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 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 list_var = Isa_Free ("v__arr_vals", 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") - | 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) - | 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) - |> 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 - val fn_ty = Library.foldr (fn (a_ty, acc_ty) => a_ty --> acc_ty) - (arg_tys, isa_dummyT) - 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 - | 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 - | 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 - in - 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 - | 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.LocalPtr, _, _) => - unsupported ("address-of pointer local variable not supported: " ^ name) - | SOME (C_Trans_Ctxt.Param, _, _) => - unsupported ("address-of by-value 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 - - (* 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 (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 - (* 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, false) 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 - - (* 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, 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) = - (* 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 (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" - - (* 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 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 - (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" - - 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 - - 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 - (* 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 body_term = - (case ret_cty of - C_Ast_Utils.CVoid => constrain_known_expr_value_type @{typ unit} body_term - | _ => - (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) ret_cty of - SOME ty => constrain_known_expr_value_type ty body_term - | NONE => 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 - 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 -\ - -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 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"} - - 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 - in - case head of - Term.Const (c, _) => - (Term.list_comb (Const (c, dummyT), args), "const: " ^ c) - | _ => (morphed_lhs, "registered term") - end - 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 - - 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 (#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))) 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.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 _) _ = - Const (\<^const_name>\c_uninitialized\, dummyT) - | init_expr_const_term target_cty (C_Ast.CConst0 (C_Ast.CStrConst0 (C_Ast.CString0 (abr_str, _), _))) = - (case target_cty of - _ => - 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 _ _ = - 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 resolve_desig_idx [] pos = pos - | resolve_desig_idx [C_Ast.CArrDesig0 (C_Ast.CConst0 (C_Ast.CIntConst0 (C_Ast.CInteger0 (n, _, _), _)), _)] _ = - intinf_to_int_checked "global array designator" n - | resolve_desig_idx _ _ = - error "micro_c_translate: complex designator in global array initializer" - fun collect_indices [] _ = [] - | collect_indices ((desigs, init_item) :: rest) pos = - let val idx = resolve_desig_idx desigs pos - in (idx, init_item) :: collect_indices rest (idx + 1) 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 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 _ = 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 {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 @ 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 - (* 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 @ 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 - 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 - 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) - 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 - val _ = C_Translate.current_list_backed_param_modes := list_backed_param_modes - 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 - (* 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 - | TranslateAbortTy of string - | TranslatePtrAdd of string - | TranslatePtrShiftSigned of string - | TranslatePtrDiff of string - | TranslateCompiler 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_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_abort_key |-- Parse.typ >> TranslateAbortTy) - || (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) - - type translate_opts = { - prefix: string option, addr: string option, gv: string option, - abi: string option, abort: string option, - ptr_add: string option, ptr_shift_signed: string option, ptr_diff: string option, - compiler: string option - } - - val empty_opts : translate_opts = { - prefix = NONE, addr = NONE, gv = NONE, abi = NONE, abort = NONE, - ptr_add = NONE, ptr_shift_signed = NONE, ptr_diff = NONE, compiler = NONE - } - - 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, - abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, - ptr_diff = #ptr_diff r, compiler = #compiler 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, - abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, - ptr_diff = #ptr_diff r, compiler = #compiler 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, - abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, - ptr_diff = #ptr_diff r, compiler = #compiler 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, - abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, - ptr_diff = #ptr_diff r, compiler = #compiler r} - | apply_translate_opt (TranslateAbortTy v) (r : translate_opts) = - {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, - abort = set_once "abort" (#abort r) v, ptr_add = #ptr_add r, - ptr_shift_signed = #ptr_shift_signed r, ptr_diff = #ptr_diff r, compiler = #compiler r} - | apply_translate_opt (TranslatePtrAdd v) (r : translate_opts) = - {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, - abort = #abort 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} - | apply_translate_opt (TranslatePtrShiftSigned v) (r : translate_opts) = - {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, - abort = #abort 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} - | apply_translate_opt (TranslatePtrDiff v) (r : translate_opts) = - {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, - abort = #abort 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} - | apply_translate_opt (TranslateCompiler v) (r : translate_opts) = - {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, - abort = #abort 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} - - 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)) - val abort_ty_opt = Option.map (Syntax.read_typ lthy) (#abort 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 abort_ty = the_default @{typ c_abort} abort_ty_opt - 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 _ = 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 - 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 f) (_, 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 -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. - 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_manifest manifest - 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..a6e00a3b --- /dev/null +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -0,0 +1,5516 @@ +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 + + 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_expr_arrow arg_ty value_ty tm = + (case expr_type_with_value value_ty of + SOME expr_ty => Type.constraint (arg_ty --> expr_ty) tm + | NONE => tm) + + fun constrain_expr_arrow_from_tm arg_ty value_ty side_tm tm = + (case expr_type_from_tm value_ty side_tm of + SOME expr_ty => Type.constraint (arg_ty --> expr_ty) tm + | NONE => tm) + + fun constrain_function_body_arrow arg_ty value_ty tm = + (case function_body_type_with_value value_ty of + SOME body_ty => Type.constraint (arg_ty --> body_ty) tm + | NONE => tm) + + 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 polymorphic so later + context (e.g. indexing vs scalar dereference) can resolve it. *) + 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 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 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 cast_term = mk_cast_from_void_untyped tm + val target_ty = + (case pointer_expr_value_hol_ty to_cty of + SOME ty => ty + | NONE => isa_dummyT) + in if target_ty = isa_dummyT then cast_term + else constrain_expr_value_type target_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* where neither is void/union: + reinterpret through void* so the resulting focused reference + carries U's prism (byte-level view), rather than leaving the + term at type T* while only changing the tracked C type. *) + 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 ctxt = 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) + + + 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 + + (* 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 (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)) + | 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) + + 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 label 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 resolve_ptr_to_uintptr_const ctxt = + resolve_required_visible_const ctxt "c_ptr_to_uintptr" + + fun resolve_uintptr_to_ptr_const ctxt = + resolve_required_visible_const ctxt "c_uintptr_to_ptr" + + 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 cast_const = Isa_Const (\<^const_name>\c_cast_from_void\, isa_dummyT) + 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 list_var = Isa_Free ("v__arr_vals", 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 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 + + 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 struct_field_offset (fields : (string * C_Ast_Utils.c_numeric_type) list) field_name = + (case List.find (fn (name, _, _) => name = field_name) (#1 (struct_layout fields)) of + SOME (_, offset, _) => offset + | NONE => error ("micro_c_translate: unknown struct field in layout: " ^ field_name)) + + 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 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) + in + case (is_unsigned, is_long, is_long_long, non_decimal) of + (false, false, false, false) => + [C_Ast_Utils.CInt, C_Ast_Utils.CLong, C_Ast_Utils.CLongLong] + | (false, false, false, true) => + [C_Ast_Utils.CInt, C_Ast_Utils.CUInt, + C_Ast_Utils.CLong, C_Ast_Utils.CULong, + C_Ast_Utils.CLongLong, C_Ast_Utils.CULongLong] + | (true, false, false, _) => + [C_Ast_Utils.CUInt, C_Ast_Utils.CULong, C_Ast_Utils.CULongLong] + | (false, true, false, false) => + [C_Ast_Utils.CLong, C_Ast_Utils.CLongLong] + | (false, true, false, true) => + [C_Ast_Utils.CLong, C_Ast_Utils.CULong, + C_Ast_Utils.CLongLong, C_Ast_Utils.CULongLong] + | (true, true, false, _) => + [C_Ast_Utils.CULong, C_Ast_Utils.CULongLong] + | (false, false, true, false) => + [C_Ast_Utils.CLongLong] + | (false, false, true, true) => + [C_Ast_Utils.CLongLong, C_Ast_Utils.CULongLong] + | (true, false, true, _) => + [C_Ast_Utils.CULongLong] + | _ => unsupported "unsupported integer literal suffix combination" + end + + 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 --- *) + + (* 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 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, 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 + | 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) + 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, _) => + 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, 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 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 list_var = Isa_Free ("v__arr_vals", 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") + | 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) + | 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) + |> 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 + val fn_ty = Library.foldr (fn (a_ty, acc_ty) => a_ty --> acc_ty) + (arg_tys, isa_dummyT) + 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 + | 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 + | 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 + in + 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 + | 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.LocalPtr, _, _) => + unsupported ("address-of pointer local variable not supported: " ^ name) + | SOME (C_Trans_Ctxt.Param, _, _) => + unsupported ("address-of by-value 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 + + (* 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 (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 + (* 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, false) 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 + + (* 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, 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) = + (* 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 (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" + + (* 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 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 + (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" + + 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 + + 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 + (* 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 body_term = + (case ret_cty of + C_Ast_Utils.CVoid => constrain_known_expr_value_type @{typ unit} body_term + | _ => + (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) ret_cty of + SOME ty => constrain_known_expr_value_type ty body_term + | NONE => 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 + 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/ROOT b/Micro_C_Parsing_Frontend/ROOT index 5620b27c..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 From 851d9a164016d10f8de1a6f56e867a8b7f53de9f Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 21:34:40 +0000 Subject: [PATCH 22/58] Remove abort: command option, always use c_abort The abort: parameter for micro_c_translate/micro_c_file was never meaningfully used with a type other than c_abort. Remove the option and extract the abort type directly from reference_types in the locale context (falling back to c_abort outside locales). This removes the TranslateAbortTy variant, the abort field from the options record, and the abort: keyword. The one usage in C_Union_Examples (abort: 'abort) was unnecessary since the locale's reference_types already constrains the abort type correctly. --- Micro_C_Examples/C_Union_Examples.thy | 2 +- .../C_Definition_Generation.thy | 37 +++++++------------ 2 files changed, 15 insertions(+), 24 deletions(-) diff --git a/Micro_C_Examples/C_Union_Examples.thy b/Micro_C_Examples/C_Union_Examples.thy index 99e71f03..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 gv: \byte list\ abort: 'abort \ +micro_c_translate gv: \byte list\ \ union U { int i; unsigned int u; diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy index 85817dde..0f4f3f4c 100644 --- a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -3,7 +3,7 @@ theory C_Definition_Generation 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 "abort:" and "compiler:" + and "prefix:" and "manifest:" and "addr:" and "gv:" and "abi:" and "compiler:" begin subsection \Definition Generation\ @@ -762,7 +762,6 @@ ML \ | TranslateAddrTy of string | TranslateGvTy of string | TranslateAbi of string - | TranslateAbortTy of string | TranslatePtrAdd of string | TranslatePtrShiftSigned of string | TranslatePtrDiff of string @@ -777,7 +776,6 @@ ML \ 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_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 () @@ -787,7 +785,6 @@ ML \ || (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) || (parse_ptr_add_key |-- Parse.name >> TranslatePtrAdd) || (parse_ptr_shift_signed_key |-- Parse.name >> TranslatePtrShiftSigned) || (parse_ptr_diff_key |-- Parse.name >> TranslatePtrDiff) @@ -795,13 +792,13 @@ ML \ type translate_opts = { prefix: string option, addr: string option, gv: string option, - abi: string option, abort: string option, + abi: string option, ptr_add: string option, ptr_shift_signed: string option, ptr_diff: string option, compiler: string option } val empty_opts : translate_opts = { - prefix = NONE, addr = NONE, gv = NONE, abi = NONE, abort = NONE, + prefix = NONE, addr = NONE, gv = NONE, abi = NONE, ptr_add = NONE, ptr_shift_signed = NONE, ptr_diff = NONE, compiler = NONE } @@ -810,40 +807,36 @@ ML \ 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, - abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, ptr_diff = #ptr_diff r, compiler = #compiler 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, - abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, ptr_diff = #ptr_diff r, compiler = #compiler 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, - abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, ptr_diff = #ptr_diff r, compiler = #compiler 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, - abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, + ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed r, ptr_diff = #ptr_diff r, compiler = #compiler r} - | apply_translate_opt (TranslateAbortTy v) (r : translate_opts) = - {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, - abort = set_once "abort" (#abort r) v, ptr_add = #ptr_add r, - ptr_shift_signed = #ptr_shift_signed r, ptr_diff = #ptr_diff r, compiler = #compiler r} | apply_translate_opt (TranslatePtrAdd v) (r : translate_opts) = {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, - abort = #abort r, ptr_add = set_once "ptr_add" (#ptr_add r) v, + 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} | apply_translate_opt (TranslatePtrShiftSigned v) (r : translate_opts) = {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, - abort = #abort r, ptr_add = #ptr_add 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} | apply_translate_opt (TranslatePtrDiff v) (r : translate_opts) = {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, - abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed 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} | apply_translate_opt (TranslateCompiler v) (r : translate_opts) = {prefix = #prefix r, addr = #addr r, gv = #gv r, abi = #abi r, - abort = #abort r, ptr_add = #ptr_add r, ptr_shift_signed = #ptr_shift_signed 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} fun collect_translate_opts opts = @@ -861,7 +854,6 @@ ML \ | 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)) - val abort_ty_opt = Option.map (Syntax.read_typ lthy) (#abort opts) fun require_visible_const_name name = (case try (Syntax.check_term lthy) (Free (name, dummyT)) of SOME _ => name @@ -873,16 +865,15 @@ ML \ } val expr_constraint = let - val abort_ty = the_default @{typ c_abort} abort_ty_opt 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) = + val (state_ty, abort_ty, prompt_in_ty, prompt_out_ty) = (case ref_args of - [s, _, _, _, i, o] => (s, i, o) - | _ => (dummyT, dummyT, dummyT)) + [s, _, _, a, i, o] => (s, a, i, o) + | _ => (dummyT, @{typ c_abort}, dummyT, dummyT)) in SOME (Type (\<^type_name>\expression\, [state_ty, dummyT, dummyT, abort_ty, prompt_in_ty, prompt_out_ty])) From 82597cb2480bdb4fa0baaf1fba6e649664c45678 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 22:09:16 +0000 Subject: [PATCH 23/58] Fix CI: patch AFP Isabelle/C parser for multi-spec declarations The upstream AFP Isabelle_C (mirror-afp-2025-1) has a bug in C_Parser_Language.thy where transformDeclaration errors on function parameter declarations with 3+ type specifiers (e.g. unsigned long long). The local dependencies/afp/Isabelle_C copy already has a fix, but CI checks out the AFP separately and hits the bug. Add a patch file and apply it in the setup-isabelle-action after AFP checkout. Document the requirement in dependencies/afp/README.md so users setting up AutoCorrode locally know to apply it. --- .../actions/setup-isabelle-action/action.yml | 6 ++++++ .../patches/isabelle_c_parser_language.patch | 16 ++++++++++++++++ dependencies/afp/README.md | 17 ++++++++++++++++- 3 files changed, 38 insertions(+), 1 deletion(-) create mode 100644 .github/patches/isabelle_c_parser_language.patch diff --git a/.github/actions/setup-isabelle-action/action.yml b/.github/actions/setup-isabelle-action/action.yml index 8bb90c4c..63ee9a39 100644 --- a/.github/actions/setup-isabelle-action/action.yml +++ b/.github/actions/setup-isabelle-action/action.yml @@ -11,6 +11,12 @@ runs: repository: isabelle-prover/mirror-afp-2025-1 path: afp + - name: Patch AFP Isabelle/C parser + shell: bash + run: | + cd afp + git apply $GITHUB_WORKSPACE/.github/patches/isabelle_c_parser_language.patch + - 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/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 From 70551185099d34db960969e7d77853c7ccf999ba Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Thu, 19 Mar 2026 23:01:50 +0000 Subject: [PATCH 24/58] Implement C frontend audit: pointer comparisons, UB examples, ABI profiles - Translate pointer relational comparisons (< <= > >=) using c_ptr_less/ c_ptr_le/c_ptr_greater/c_ptr_ge from C_Memory_Operations, with focused type unwrapping following the pointer subtraction pattern - Add verified UB detection examples: signed overflow (SignedOverflow), division by zero (DivisionByZero), shift out of range (ShiftOutOfRange) using make_function_contract_with_abort - Add LLP64_LE (Windows x64: long=32bit, ptr=64bit) and ILP32_BE (32-bit big-endian) ABI profiles with smoke tests and metadata validation - Add ABI-parameterized c_sizeof_c_long/c_sizeof_c_pointer in c_abi_model locale for correct manual specifications across ABIs - Document c_signed_mod quotient overflow check (C11 6.5.5p6: INT_MIN%-1) - Add smoke tests for nested loops with break/continue, multi-function calls, enum constants in expressions, pointer subtraction, and pointer relational comparisons --- Micro_C_Examples/C_Bitwise_Examples.thy | 19 ++++++ Micro_C_Examples/Simple_C_Functions.thy | 45 ++++++++++++++ .../C_ABI_And_Compiler.thy | 19 +++++- .../C_Definition_Generation.thy | 3 +- .../C_Translation_Engine.thy | 41 +++++++++++-- .../C_Translation_Smoke_Control.thy | 61 +++++++++++++++++++ .../C_Translation_Smoke_ILP32.thy | 48 +++++++++++++++ .../C_Translation_Smoke_Memory.thy | 45 ++++++++++++++ Shallow_Micro_C/C_Numeric_Types.thy | 7 +++ Shallow_Micro_C/C_Translation_Model.thy | 15 +++++ 10 files changed, 294 insertions(+), 9 deletions(-) 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/Simple_C_Functions.thy b/Micro_C_Examples/Simple_C_Functions.thy index e2cc8603..d99b9b13 100644 --- a/Micro_C_Examples/Simple_C_Functions.thy +++ b/Micro_C_Examples/Simple_C_Functions.thy @@ -197,6 +197,30 @@ lemma c_signed_add_spec [crush_specs]: 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\ @@ -796,6 +820,27 @@ lemma c_u_div_spec [crush_specs]: 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) + end section \Fixed-width integer type verification (\<^verbatim>\uint16_t\)\ diff --git a/Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy b/Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy index 00477f85..d604170e 100644 --- a/Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy +++ b/Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy @@ -32,19 +32,22 @@ text \ ML \ structure C_ABI : sig - datatype profile = LP64_LE | ILP32_LE | LP64_BE + 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 + 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 @@ -55,17 +58,27 @@ struct "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)")) + " (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, diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy index 0f4f3f4c..fb2ebd96 100644 --- a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -108,8 +108,7 @@ struct in lthy' end end - fun abi_is_big_endian C_ABI.LP64_BE = true - | abi_is_big_endian _ = false + val abi_is_big_endian = C_ABI.big_endian fun mk_bool_term true = @{term True} | mk_bool_term false = @{term False} diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index a6e00a3b..af80c8f8 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -2349,6 +2349,39 @@ struct 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 (* C logical operators short-circuit and return _Bool *) @@ -2424,13 +2457,13 @@ struct else unsupported "pointer comparison with non-pointer operand" | (CLeOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => - unsupported "pointer relational comparison" + mk_ptr_relcmp \<^const_name>\c_ptr_less\ "c_ptr_less" | (CLeqOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => - unsupported "pointer relational comparison" + mk_ptr_relcmp \<^const_name>\c_ptr_le\ "c_ptr_le" | (CGrOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => - unsupported "pointer relational comparison" + mk_ptr_relcmp \<^const_name>\c_ptr_greater\ "c_ptr_greater" | (CGeqOp0, C_Ast_Utils.CPtr _, C_Ast_Utils.CPtr _) => - unsupported "pointer relational comparison" + 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 _) => diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Control.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Control.thy index 20e227aa..8dbc11f2 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Control.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Control.thy @@ -217,4 +217,65 @@ unsigned int smoke_ctrl_switch_no_default(unsigned int x) { 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 index 249b9504..b4325bce 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_ILP32.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_ILP32.thy @@ -82,4 +82,52 @@ lemma ilp32_abi_profile_values: 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 39e27d41..04d63518 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Memory.thy @@ -174,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/Shallow_Micro_C/C_Numeric_Types.thy b/Shallow_Micro_C/C_Numeric_Types.thy index d1bbc61a..7a069c4d 100644 --- a/Shallow_Micro_C/C_Numeric_Types.thy +++ b/Shallow_Micro_C/C_Numeric_Types.thy @@ -101,6 +101,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 \ diff --git a/Shallow_Micro_C/C_Translation_Model.thy b/Shallow_Micro_C/C_Translation_Model.thy index 392346d0..bb3df015 100644 --- a/Shallow_Micro_C/C_Translation_Model.thy +++ b/Shallow_Micro_C/C_Translation_Model.thy @@ -40,6 +40,21 @@ locale c_abi_model = 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 From 881e225c934d6e4ac9ce1a4cc82f397790bfc6b1 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Fri, 20 Mar 2026 22:59:58 +0000 Subject: [PATCH 25/58] Add 5 minor C translation features: _Static_assert, range cases, _Alignas, builtins, CChars0 Features implemented: 1. _Static_assert: evaluate constant expressions at translation time (sizeof, _Alignof, comparisons, arithmetic). Handled at both top-level (C_Definition_Generation) and block-level (C_Translation_Engine). New eval_const_int_expr + extract_string_literal utilities in C_Ast_Utilities. 2. Range case labels (case 1 ... 5:): new case_label datatype (SingleCase/RangeCase/DefaultCase) replaces option encoding. CCases0 handled in unwrap_case_labels, extract_switch_groups, make_switch_cond, make_any_case_match. Generates lo <= x AND x <= hi. 3. _Alignas specifier: explicit CAlignSpec0/CFunSpec0 patterns in resolve_c_type accumulator (was already silently ignored by catch-all, now documented). 4. __builtin_types_compatible_p: resolves type compatibility at translation time, produces constant 0/1. Other GCC builtins get explicit rejection message. 5. Multi-character constants (CChars0): explicit rejection with clear error message in translate_expr and init_scalar_const_value (both C_Translation_Engine and C_Definition_Generation). Smoke tests in C_Misc_Examples.thy with verified contracts. --- Micro_C_Examples/C_Misc_Examples.thy | 162 ++++++++++++++++++ Micro_C_Examples/ROOT | 1 + Micro_C_Parsing_Frontend/C_Ast_Utilities.thy | 46 +++++ .../C_Definition_Generation.thy | 28 +++ .../C_Translation_Engine.thy | 71 +++++++- 5 files changed, 299 insertions(+), 9 deletions(-) create mode 100644 Micro_C_Examples/C_Misc_Examples.thy diff --git a/Micro_C_Examples/C_Misc_Examples.thy b/Micro_C_Examples/C_Misc_Examples.thy new file mode 100644 index 00000000..d0b09c45 --- /dev/null +++ b/Micro_C_Examples/C_Misc_Examples.thy @@ -0,0 +1,162 @@ +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) { + switch (x) { + case 1 ... 5: + return 1; + case 10 ... 20: + return 2; + default: + return 0; + } + } +\ + +definition c_range_case_contract :: \c_uint \ ('s::{sepalg}, c_uint, 'b) function_contract\ where + [crush_contracts]: \c_range_case_contract x \ + let pre = \True\; + post = \r. \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 + +end + +end 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_Parsing_Frontend/C_Ast_Utilities.thy b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy index 0241624a..e694544b 100644 --- a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy +++ b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy @@ -97,6 +97,9 @@ structure C_Ast_Utils : sig 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 @@ -325,6 +328,8 @@ struct | accumulate (CTypeSpec0 (CTypeDef0 _)) flags = flags | accumulate (CTypeSpec0 _) _ = error "micro_c_translate: unsupported type specifier" + | accumulate (CAlignSpec0 _) flags = flags (* _Alignas: silently ignored *) + | accumulate (CFunSpec0 _) flags = flags (* inline/_Noreturn: silently ignored *) | 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) @@ -580,6 +585,47 @@ struct | _ => 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, _)) = diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy index fb2ebd96..293abe93 100644 --- a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -218,6 +218,8 @@ struct 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 @@ -382,8 +384,20 @@ struct | 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) @@ -458,6 +472,20 @@ struct 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 val fundefs_raw = List.filter (fn C_Ast.CFunDef0 (_, declr, _, _, _) => keep_func (C_Ast_Utils.declr_name declr)) diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index af80c8f8..299bd01d 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -2169,12 +2169,20 @@ struct (* --- Switch statement helpers --- *) - (* Unwrap nested case/default labels from the C AST. - CCase0(1, CCase0(2, stmt)) becomes labels=[SOME 1, SOME 2], stmt *) + (* 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 (SOME expr :: 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 (NONE :: labels) + unwrap_case_labels inner (DefaultCase :: labels) | unwrap_case_labels stmt labels = (rev labels, stmt) (* Extract case groups from flat switch body items. @@ -2189,6 +2197,10 @@ struct 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 [] @@ -2212,12 +2224,22 @@ struct end | case_label_value _ _ _ = error "micro_c_translate: unsupported case label expression" + (* 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 + (* 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) = + let fun one_label (SingleCase e) = HOLogic.mk_eq (switch_var, case_label_value switch_cty tctx e) - | one_label NONE = default_cond + | 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) = @@ -2228,14 +2250,17 @@ struct (* 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 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.map one_label labels) end + in combine (List.mapPartial one_label labels) end (* --- Break/continue AST scanners --- *) @@ -3695,6 +3720,8 @@ struct (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)" | 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 @@ -3932,6 +3959,19 @@ struct 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 _ (CBuiltinExpr0 _) = + unsupported "GCC builtin expression (only __builtin_types_compatible_p is supported)" | translate_expr _ _ = unsupported "expression" @@ -4118,6 +4158,8 @@ struct 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 @@ -4457,6 +4499,17 @@ struct | _ => 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 From 5b0561098904a00c7be313a71dd72166c505f6d4 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Fri, 20 Mar 2026 23:03:37 +0000 Subject: [PATCH 26/58] Fix CI: use patch instead of git apply for AFP patching The makarius/isabelle container doesn't have git installed, and actions/checkout downloads a tarball (no .git dir) for external repos. Replace `git apply` with `patch -p1` which handles unified diffs. --- .../actions/setup-isabelle-action/action.yml | 2 +- .../C_Translation_Engine.thy | 17 +++++++++++++++-- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/.github/actions/setup-isabelle-action/action.yml b/.github/actions/setup-isabelle-action/action.yml index 63ee9a39..1660752c 100644 --- a/.github/actions/setup-isabelle-action/action.yml +++ b/.github/actions/setup-isabelle-action/action.yml @@ -15,7 +15,7 @@ runs: shell: bash run: | cd afp - git apply $GITHUB_WORKSPACE/.github/patches/isabelle_c_parser_language.patch + patch -p1 < $GITHUB_WORKSPACE/.github/patches/isabelle_c_parser_language.patch - name: Set AFP component base shell: bash diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index 299bd01d..0639eef0 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -2224,6 +2224,8 @@ struct 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 @@ -2232,8 +2234,6 @@ struct 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 - (* 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 (SingleCase e) = HOLogic.mk_eq (switch_var, case_label_value switch_cty tctx e) @@ -3972,6 +3972,19 @@ struct end | translate_expr _ (CBuiltinExpr0 _) = unsupported "GCC builtin expression (only __builtin_types_compatible_p is supported)" + | 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 _ (CBuiltinExpr0 _) = + unsupported "GCC builtin expression (only __builtin_types_compatible_p is supported)" | translate_expr _ _ = unsupported "expression" From 1e52a85e12cf092cec961296d439d9e63506352c Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Fri, 20 Mar 2026 23:46:12 +0000 Subject: [PATCH 27/58] Add mutable parameter examples, fix range_case switch translation - Add verified param_compound (compound assign x += y) and param_inc (post-increment x++) examples demonstrating parameter auto-promotion - Fix range_case in C_Misc_Examples: use result-variable pattern instead of return-inside-switch which caused FunctionBody type clash - Register C_Misc_Examples in root theory --- AutoCorrode.thy | 1 + Micro_C_Examples/C_Misc_Examples.thy | 20 ++++++---- Micro_C_Examples/Simple_C_Functions.thy | 53 +++++++++++++++++++++++++ 3 files changed, 67 insertions(+), 7 deletions(-) diff --git a/AutoCorrode.thy b/AutoCorrode.thy index 9c39e369..14dc494b 100644 --- a/AutoCorrode.thy +++ b/AutoCorrode.thy @@ -43,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_Misc_Examples.thy b/Micro_C_Examples/C_Misc_Examples.thy index d0b09c45..a9b41c48 100644 --- a/Micro_C_Examples/C_Misc_Examples.thy +++ b/Micro_C_Examples/C_Misc_Examples.thy @@ -68,23 +68,29 @@ subsection \Range Case Labels\ micro_c_translate \ unsigned int range_case(unsigned int x) { + unsigned int result; switch (x) { case 1 ... 5: - return 1; + result = 1; + break; case 10 ... 20: - return 2; + result = 2; + break; default: - return 0; + 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 = \True\; - post = \r. \r = (if 1 \ x \ x \ 5 then 1 - else if 10 \ x \ x \ 20 then 2 - else 0)\ + 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 diff --git a/Micro_C_Examples/Simple_C_Functions.thy b/Micro_C_Examples/Simple_C_Functions.thy index d99b9b13..7a9c60fa 100644 --- a/Micro_C_Examples/Simple_C_Functions.thy +++ b/Micro_C_Examples/Simple_C_Functions.thy @@ -632,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 \ From e7ad51c1499dc9349d127219bbba8ad7e1c72d1d Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 08:12:04 +0000 Subject: [PATCH 28/58] Fix null pointer comparison and add verified pointer examples - Fix mk_ptr_is_null: use unwrap_focused + c_ptr_to_uintptr instead of adhoc-overloaded address constant (which was ambiguous in locales) - Add is_zero_int_const checks to CPtr/CPtr equality/inequality handlers so (void*)0 comparisons route through mk_ptr_is_null - Add verified is_null example: p == (void*)0 with non-null precondition - Add ptr_eq smoke test: p != q pointer inequality --- Micro_C_Examples/Simple_C_Functions.thy | 40 +++++++++++++++++++ .../C_Translation_Engine.thy | 24 ++++++++++- 2 files changed, 63 insertions(+), 1 deletion(-) diff --git a/Micro_C_Examples/Simple_C_Functions.thy b/Micro_C_Examples/Simple_C_Functions.thy index 7a9c60fa..7b24d854 100644 --- a/Micro_C_Examples/Simple_C_Functions.thy +++ b/Micro_C_Examples/Simple_C_Functions.thy @@ -894,6 +894,46 @@ lemma c_u_div_zero_spec: 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 + end section \Fixed-width integer type verification (\<^verbatim>\uint16_t\)\ diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index 0639eef0..fdbdf730 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -2293,9 +2293,11 @@ struct 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}) - $ (Isa_Const (\<^const_name>\address\, isa_dummyT --> isa_dummyT) $ p) + $ (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 @@ -2436,6 +2438,11 @@ struct (* 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 @@ -2443,6 +2450,21 @@ struct 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 = From 8bb11dbc50faacd9821e303b1fa2cdb705951015 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 08:24:34 +0000 Subject: [PATCH 29/58] Support arbitrary unsigned expressions as for-loop bounds When try_translate_pure_nat_expr fails on the bound but succeeds on init, evaluate the bound expression monadically and use unat as the range limit. This enables for-loops like for(i=0; i < n+1; i++) where n+1 is not a literal or parameter. Verified with noop_loop example using wp_raw_for_loop_framedI' with trivial invariant. --- Micro_C_Examples/Simple_C_Functions.thy | 33 ++++++++ .../C_Translation_Engine.thy | 78 +++++++++++-------- 2 files changed, 79 insertions(+), 32 deletions(-) diff --git a/Micro_C_Examples/Simple_C_Functions.thy b/Micro_C_Examples/Simple_C_Functions.thy index 7b24d854..8c78270c 100644 --- a/Micro_C_Examples/Simple_C_Functions.thy +++ b/Micro_C_Examples/Simple_C_Functions.thy @@ -934,6 +934,39 @@ micro_c_translate \ 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 + end section \Fixed-width integer type verification (\<^verbatim>\uint16_t\)\ diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index fdbdf730..3ff22f22 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -5104,43 +5104,57 @@ struct 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_cty = + (case stmt of + CFor0 (Right (CDecl0 (specs, [((Some declr, _), _)], _)), _, _, _, _) => 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 + 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_Term_Build.mk_raw_for_loop range (Term.lambda loop_var body_term) + 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 From 064bc2d2813a66d42dbda550b44aff5e2a6d7352 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 08:57:04 +0000 Subject: [PATCH 30/58] Support multi-dimensional array declaration and nested indexing - Handle nested CInitList0 in array initializer: build list-of-lists for 2D arrays like unsigned int mat[2][3] = {{1,2,3},{4,5,6}} - Handle chained CIndex0 reads: when arr expr is itself a CIndex0, apply nth directly to the sub-list value without dereferencing - Extend c_uint_arr_verification_ctx with c_uint_list_list_prism for 2D - Verified mat_read example: mat[1][2] == 6 proved via crush_base --- Micro_C_Examples/Simple_C_Functions.thy | 26 ++++++++- .../C_Translation_Engine.thy | 58 ++++++++++++++++++- 2 files changed, 82 insertions(+), 2 deletions(-) diff --git a/Micro_C_Examples/Simple_C_Functions.thy b/Micro_C_Examples/Simple_C_Functions.thy index 8c78270c..f67bc2f5 100644 --- a/Micro_C_Examples/Simple_C_Functions.thy +++ b/Micro_C_Examples/Simple_C_Functions.thy @@ -1184,7 +1184,8 @@ locale c_uint_arr_verification_ctx = 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 + 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\ @@ -1198,10 +1199,12 @@ locale c_uint_arr_verification_ctx = '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 \ @@ -1576,6 +1579,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\ diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index 3ff22f22..8d619403 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -3572,8 +3572,22 @@ struct | _ => 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 use_raw_pointer_indexing tctx arr_expr then + 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 = @@ -4269,6 +4283,47 @@ struct 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 + (* 2D array: elements are sub-arrays (CInitList0 inside CInitList0) *) + let val inner_elem_cty = + (case elem_cty of C_Ast_Utils.CPtr inner => inner + | _ => error "micro_c_translate: expected pointer element type for 2D array") + val inner_elem_type = C_Ast_Utils.hol_type_of inner_elem_cty + val inner_zero = HOLogic.mk_number inner_elem_type 0 + (* Extract inner array size from second CArrDeclr0 dimension *) + 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 + val outer_size = (case arr_sizes of n :: _ => n | [] => List.length init_list) + val inner_size = (case arr_sizes of _ :: m :: _ => SOME m | _ => NONE) + fun build_inner_list (_, CInitList0 (inits, _)) = + let val vals = List.map + (fn (_, CInitExpr0 (e, _)) => init_scalar_const_term inner_elem_cty e + | _ => unsupported "complex nested array element") inits + val padded = case inner_size of + SOME m => if List.length vals > m + then unsupported "too many elements in inner array" + else vals @ List.tabulate (m - List.length vals, fn _ => inner_zero) + | NONE => vals + in HOLogic.mk_list inner_elem_type padded end + | build_inner_list _ = unsupported "expected inner initializer list for 2D array" + val inner_lists = List.map build_inner_list init_list + val inner_list_type = HOLogic.listT inner_elem_type + val zero_inner = HOLogic.mk_list inner_elem_type + (case inner_size of SOME m => List.tabulate (m, fn _ => inner_zero) | NONE => []) + val padded_outer = + if List.length inner_lists < outer_size + then inner_lists @ List.tabulate (outer_size - List.length inner_lists, fn _ => zero_inner) + else inner_lists + val result = HOLogic.mk_list inner_list_type padded_outer + 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 resolve_desig_idx [] pos = pos @@ -4334,6 +4389,7 @@ struct 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 = From aac6e05a467a26ed31e9eb7cb059e3aac15fdb00 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 09:34:13 +0000 Subject: [PATCH 31/58] Support backward goto via bounded_while loop wrapper - Detect backward goto targets: labels in a compound block where a later goto references the same label name - Wrap backward goto label body in bounded_while with fuel parameter; combine inner_stmt with while_items into a single compound block so forward goto guards correctly skip code after goto done - Split forward goto target labels out of the while body to avoid FunctionBody type clash with return statements - Add backward label to active_goto_labels inside the while so the guard mechanism correctly skips code after the backward goto - Keep error for gotos targeting labels in incompatible scopes - Verified count_down example with wp_bounded_while_framedI invariant --- Micro_C_Examples/Simple_C_Functions.thy | 55 +++++++++++ .../C_Translation_Engine.thy | 98 ++++++++++++++++--- 2 files changed, 139 insertions(+), 14 deletions(-) diff --git a/Micro_C_Examples/Simple_C_Functions.thy b/Micro_C_Examples/Simple_C_Functions.thy index f67bc2f5..33ae9b61 100644 --- a/Micro_C_Examples/Simple_C_Functions.thy +++ b/Micro_C_Examples/Simple_C_Functions.thy @@ -967,6 +967,61 @@ lemma c_noop_loop_spec [crush_specs]: 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\)\ diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index 8d619403..28105b5c 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -4668,23 +4668,93 @@ struct 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 + 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 => - C_Term_Build.mk_sequence - (C_Term_Build.mk_var_write goto_ref false_lit) - (C_Term_Build.mk_sequence stmt_term rest_term) + 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 *) - C_Term_Build.mk_sequence stmt_term rest_term + 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, @@ -5381,15 +5451,15 @@ struct end | translate_stmt tctx (CGoto0 (ident, _)) = let val name = C_Ast_Utils.ident_name ident - val is_forward_target = + 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_forward_target then + 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 ("non-forward goto not supported: " ^ name) + unsupported ("goto to label in incompatible scope: " ^ name) | NONE => unsupported ("goto target not found: " ^ name) end | translate_stmt tctx (CLabel0 (_, stmt, _, _)) = From dacb535b70d1b77055f26af6f5cb40e1ee4ce7a5 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 17:59:31 +0000 Subject: [PATCH 32/58] Audit C translation soundness: add C11 references, fix soundness issues, document impl-defined behavior MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Annotate C_Ast_Utilities, C_Numeric_Types, C_Translation_Engine with C11 standard section references (§6.2.5, §6.3.1, §6.4.4.1, §6.5, §6.7.2, §7.20) - Fix type_rank wildcard: error on non-integer types (CPtr/CVoid/CStruct/CUnion) instead of silently returning int rank - Fix usual_arith_conv fallback: error when bit_width_of returns NONE instead of silently assuming signed is wider - Fix ternary ptr-int mixing: require null pointer constant (zero) when mixing pointer with integer per C11 §6.5.15p6 - Error on volatile qualifier instead of silently ignoring (const/restrict still silently ignored as they don't affect semantics in our model) - Refactor int_literal_candidates to table-driven C11 §6.4.4.1 Table 5 - Document all implementation-defined behaviors in C_ABI_And_Compiler.thy (compiler profile vs hardcoded assumptions) - Add explanatory comment for shift RHS cast in prepare_compound_operands --- .../C_ABI_And_Compiler.thy | 36 +++++ Micro_C_Parsing_Frontend/C_Ast_Utilities.thy | 80 +++++++++-- .../C_Translation_Engine.thy | 125 ++++++++++++------ Shallow_Micro_C/C_Numeric_Types.thy | 64 ++++++--- 4 files changed, 234 insertions(+), 71 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy b/Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy index d604170e..1b36fbe0 100644 --- a/Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy +++ b/Micro_C_Parsing_Frontend/C_ABI_And_Compiler.thy @@ -18,6 +18,42 @@ text \ 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 \ diff --git a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy index e694544b..90d2e0fe 100644 --- a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy +++ b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy @@ -9,6 +9,25 @@ 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 \ @@ -158,6 +177,11 @@ struct 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 @@ -180,6 +204,10 @@ struct 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 @@ -225,6 +253,10 @@ struct | 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 () @@ -276,8 +308,12 @@ struct | 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. *) + (* 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 @@ -290,7 +326,10 @@ struct else CInt end - (* Parse a list of C declaration specifiers into a resolved numeric type. + (* 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. @@ -330,6 +369,10 @@ struct error "micro_c_translate: unsupported type specifier" | accumulate (CAlignSpec0 _) flags = flags (* _Alignas: silently ignored *) | accumulate (CFunSpec0 _) flags = flags (* inline/_Noreturn: silently ignored *) + | accumulate (CTypeQual0 (CVolatQual0 _)) _ = + error "micro_c_translate: volatile qualifier not supported" + | accumulate (CTypeQual0 _) flags = flags (* const/restrict/_Atomic: silently ignored *) + | accumulate (CStorageSpec0 _) flags = flags (* static/extern/register: silently ignored *) | 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) @@ -1340,7 +1383,10 @@ struct (fn CFDefExt0 fundef => SOME fundef | _ => NONE) ext_decls - (* C11 integer conversion rank (\
6.3.1.1) *) + (* 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 @@ -1354,13 +1400,29 @@ struct | type_rank CULongLong = 5 | type_rank CInt128 = 6 | type_rank CUInt128 = 6 - | type_rank _ = 3 (* default: int rank *) - - (* C11 \
6.3.1.1: integer promotion — sub-int types promote to int *) + | 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 ops *) + (* 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 @@ -1379,7 +1441,7 @@ struct else (* rule 3: convert to unsigned type corresponding to signed *) (case s of CLong => CULong | CLongLong => CULongLong | CInt => CUInt | CInt128 => CUInt128 | _ => CUInt) - | _ => s (* fallback: assume signed is wider *) + | _ => error "usual_arith_conv: cannot determine bit width for conversion" end end end diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index 28105b5c..32c35475 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -890,10 +890,15 @@ struct end | list_backed_pointer_value_hol_ty _ = NONE - (* 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. + (* 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 @@ -1194,6 +1199,9 @@ struct (* Translate a C binary operator to a HOL function constant, dispatching signed vs unsigned based on the operand type. + C11 \
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). *) fun translate_binop cty CAddOp0 = @@ -2027,9 +2035,13 @@ struct | 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. *) + (* 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 @@ -2122,6 +2134,39 @@ struct 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 @@ -2129,32 +2174,16 @@ struct 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 (is_unsigned, is_long, is_long_long, non_decimal) of - (false, false, false, false) => - [C_Ast_Utils.CInt, C_Ast_Utils.CLong, C_Ast_Utils.CLongLong] - | (false, false, false, true) => - [C_Ast_Utils.CInt, C_Ast_Utils.CUInt, - C_Ast_Utils.CLong, C_Ast_Utils.CULong, - C_Ast_Utils.CLongLong, C_Ast_Utils.CULongLong] - | (true, false, false, _) => - [C_Ast_Utils.CUInt, C_Ast_Utils.CULong, C_Ast_Utils.CULongLong] - | (false, true, false, false) => - [C_Ast_Utils.CLong, C_Ast_Utils.CLongLong] - | (false, true, false, true) => - [C_Ast_Utils.CLong, C_Ast_Utils.CULong, - C_Ast_Utils.CLongLong, C_Ast_Utils.CULongLong] - | (true, true, false, _) => - [C_Ast_Utils.CULong, C_Ast_Utils.CULongLong] - | (false, false, true, false) => - [C_Ast_Utils.CLongLong] - | (false, false, true, true) => - [C_Ast_Utils.CLongLong, C_Ast_Utils.CULongLong] - | (true, false, true, _) => - [C_Ast_Utils.CULongLong] - | _ => unsupported "unsupported integer literal suffix combination" + 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 [] = @@ -2411,7 +2440,7 @@ struct end in case binop of - (* C logical operators short-circuit and return _Bool *) + (* 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) @@ -3129,6 +3158,7 @@ struct 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 @@ -3294,6 +3324,7 @@ struct | 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 @@ -3435,8 +3466,8 @@ struct | _ => 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, _)) = - (* ~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) @@ -3446,8 +3477,8 @@ struct 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, _)) = - (* -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) @@ -3457,21 +3488,23 @@ struct 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, _)) = - (* +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 + (* C11 \
6.5.3.3p5: logical NOT — result is 0 if operand is nonzero, 1 if zero *) | 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}) @@ -3709,8 +3742,8 @@ struct (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, _)) = - (* 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 = @@ -3722,8 +3755,10 @@ struct | (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 + 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) @@ -3740,7 +3775,10 @@ struct | (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 + 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) @@ -3751,15 +3789,15 @@ struct (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 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 (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, _), _))) = - (* 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)) @@ -3768,6 +3806,7 @@ struct 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, _)) = @@ -3778,7 +3817,7 @@ struct 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 *) + (* 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 @@ -3808,7 +3847,7 @@ struct | _ => unsupported "cast to non-numeric type") in (mk_implicit_cast (source_term, source_cty, target_cty), target_cty) end - (* sizeof(type) *) + (* 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 = diff --git a/Shallow_Micro_C/C_Numeric_Types.thy b/Shallow_Micro_C/C_Numeric_Types.thy index 7a069c4d..d5bbd33c 100644 --- a/Shallow_Micro_C/C_Numeric_Types.thy +++ b/Shallow_Micro_C/C_Numeric_Types.thy @@ -27,9 +27,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 +45,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 @@ -124,9 +131,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 \ @@ -171,8 +178,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 \ @@ -210,11 +219,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 \ @@ -271,6 +281,12 @@ definition c_signed_shr_conservative :: \'l::{len} sword \ 'l 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 \ @@ -310,9 +326,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 \ @@ -325,6 +342,15 @@ 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)\ From 37b43b534cd3c058936e5ba0f99b948ffa444678 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 18:45:06 +0000 Subject: [PATCH 33/58] Add C11 section references to translate_stmt, translate_decl, and evaluation order MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Add C11 standard section references before each translate_stmt pattern (compound, return, expression, if, for, while/do-while, switch, goto, label, continue, break) - Add C11 §6.7/§6.7.9 reference to translate_decl - Add C11 §6.8.2/§6.2.1p4 reference to translate_compound_items - Document evaluation-order strategy at CBinary0 dispatch citing C11 §6.5p2 (unsequenced UB) and §6.5p3 (unspecified order), explaining bind2 vs bind2_unseq - Add C11 §6.5p2 reference to expr_has_unsequenced_ub_risk --- Micro_C_Parsing_Frontend/C_Ast_Utilities.thy | 2 ++ .../C_Translation_Engine.thy | 26 +++++++++++++++++-- 2 files changed, 26 insertions(+), 2 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy index 90d2e0fe..22421f99 100644 --- a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy +++ b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy @@ -856,6 +856,8 @@ struct 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) diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index 32c35475..cc0c307b 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -2365,6 +2365,15 @@ struct 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 @@ -4214,7 +4223,8 @@ struct 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, list_backed_ptr_alias) tuples. + (* 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, _)) = @@ -4605,7 +4615,8 @@ struct 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. + (* 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. *) @@ -4947,8 +4958,10 @@ struct 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, _)) = @@ -4957,18 +4970,21 @@ struct 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 () = @@ -5323,6 +5339,7 @@ struct 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 @@ -5402,6 +5419,7 @@ struct (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 @@ -5488,6 +5506,7 @@ struct (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 = @@ -5501,17 +5520,20 @@ struct 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 => From fc9f8d287f97ae34b253fabb54495b158987c4b6 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 18:45:43 +0000 Subject: [PATCH 34/58] Remove dead code: duplicated CBuiltinExpr0 patterns in translate_expr Lines 4059-4071 were an exact duplicate of lines 4046-4058. ML's sequential pattern matching makes the second copy unreachable since the catch-all `CBuiltinExpr0 _` at line 4057 matches first. --- Micro_C_Parsing_Frontend/C_Translation_Engine.thy | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index cc0c307b..9b4e5780 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -4056,19 +4056,6 @@ struct end | translate_expr _ (CBuiltinExpr0 _) = unsupported "GCC builtin expression (only __builtin_types_compatible_p is supported)" - | 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 _ (CBuiltinExpr0 _) = - unsupported "GCC builtin expression (only __builtin_types_compatible_p is supported)" | translate_expr _ _ = unsupported "expression" From 8d112c4295cf98220cfb878b0bf7b87cb852cafb Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 18:46:32 +0000 Subject: [PATCH 35/58] Error on _Atomic qualifier; document _Alignas ignore rationale MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Replace blanket CTypeQual0 wildcard with granular patterns: _Atomic now errors (atomic semantics not modeled), const and restrict are individually documented with C11 section references - Add rationale comment for _Alignas ignore (C11 §6.7.5: alignment does not affect computation semantics; verified in C_Misc_Examples) - Separate extern from blanket CStorageSpec0 with its own pattern and comment --- Micro_C_Parsing_Frontend/C_Ast_Utilities.thy | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy index 22421f99..41d8d663 100644 --- a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy +++ b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy @@ -367,12 +367,20 @@ struct | accumulate (CTypeSpec0 (CTypeDef0 _)) flags = flags | accumulate (CTypeSpec0 _) _ = error "micro_c_translate: unsupported type specifier" - | accumulate (CAlignSpec0 _) flags = flags (* _Alignas: silently ignored *) + (* 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 _)) _ = error "micro_c_translate: volatile qualifier not supported" - | accumulate (CTypeQual0 _) flags = flags (* const/restrict/_Atomic: silently ignored *) - | accumulate (CStorageSpec0 _) flags = flags (* static/extern/register: silently ignored *) + | 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 *) | 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) From e423ed812156d0ef6184ac2a915cb0f0d2b1196a Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 18:50:11 +0000 Subject: [PATCH 36/58] Make translate_binop table-driven for auditability Replace 70-line pattern-match chain with a declarative binop_table mapping each C binary operator to its (signed, unsigned) Isabelle constants. CShrOp0 remains a special case due to compiler-profile- dependent dispatch (ArithmeticShift vs ConservativeShift). --- .../C_Translation_Engine.thy | 120 +++++++----------- 1 file changed, 45 insertions(+), 75 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index 9b4e5780..3ac96d99 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -1197,82 +1197,52 @@ struct 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. - C11 \
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: &, ^, |). + (* 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). *) - 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 (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)) - | translate_binop _ _ = unsupported "unsupported binary operator" + 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 = From 7f1adb747130060fc93e13e0a2ac0c3e29a8c672 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 18:51:31 +0000 Subject: [PATCH 37/58] Make resolve_c_type flag resolution a declarative pattern match MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Extract the nested if/else chain into resolve_from_flags with pattern matching on the (signed, unsigned, char, short, int, long_count, void, struct) flag tuple. Each pattern is annotated with the C11 §6.7.2p2 specifier combination it represents. --- Micro_C_Parsing_Frontend/C_Ast_Utilities.thy | 40 ++++++++++---------- 1 file changed, 19 insertions(+), 21 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy index 41d8d663..e956e41d 100644 --- a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy +++ b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy @@ -385,28 +385,26 @@ struct 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 - 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 #char_is_signed (C_Compiler.get_compiler_profile ()) then SOME CSChar else SOME CChar (* compiler: option controls plain-char signedness *) - - 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 *) + 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 *) From 6dd4240474b616f69f8893ba1783e3dddd779437 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 18:52:41 +0000 Subject: [PATCH 38/58] Document type mapping strategy and ABI indirection - Add comment block before hol_type_of explaining the ABI indirection strategy: type synonyms are fixed-width, CLong/CULong are mapped to c_int/c_uint on ILP32 vs c_long/c_ulong on LP64, CChar is always unsigned with signedness resolved by resolve_c_type - Add text block in C_Numeric_Types.thy clarifying that type synonyms do not vary with ABI and sizeof correctness follows from the hol_type_of indirection --- Micro_C_Parsing_Frontend/C_Ast_Utilities.thy | 9 +++++++++ Shallow_Micro_C/C_Numeric_Types.thy | 10 ++++++++++ 2 files changed, 19 insertions(+) diff --git a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy index e956e41d..65195404 100644 --- a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy +++ b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy @@ -270,6 +270,15 @@ struct ("__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\ diff --git a/Shallow_Micro_C/C_Numeric_Types.thy b/Shallow_Micro_C/C_Numeric_Types.thy index d5bbd33c..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\ From 92b07a1538350d56fbf97f50896432bda9185cde Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 19:01:55 +0000 Subject: [PATCH 39/58] Remove dead code and fix ML warnings in C_Translation_Engine - Delete 6 unreferenced functions: constrain_expr_arrow, constrain_expr_arrow_from_tm, constrain_function_body_arrow, resolve_ptr_to_uintptr_const, resolve_uintptr_to_ptr_const, struct_field_offset - Remove 2 unused list_var bindings (shadowed by typed versions) - Discard unused ctxt binding in pointer-to-integer cast - Wildcard unused label parameter in resolve_pointer_model_const - Add missing ParamListPtr case to 2 non-exhaustive matches in translate_expr (CAssign0) and translate_lvalue_location (CVar0) Reduces ML warnings from 12 to 0. --- .../C_Translation_Engine.thy | 36 ++++--------------- 1 file changed, 6 insertions(+), 30 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index 3ac96d99..a9093b45 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -704,21 +704,6 @@ struct 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_expr_arrow arg_ty value_ty tm = - (case expr_type_with_value value_ty of - SOME expr_ty => Type.constraint (arg_ty --> expr_ty) tm - | NONE => tm) - - fun constrain_expr_arrow_from_tm arg_ty value_ty side_tm tm = - (case expr_type_from_tm value_ty side_tm of - SOME expr_ty => Type.constraint (arg_ty --> expr_ty) tm - | NONE => tm) - - fun constrain_function_body_arrow arg_ty value_ty tm = - (case function_body_type_with_value value_ty of - SOME body_ty => Type.constraint (arg_ty --> body_ty) tm - | NONE => tm) - 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 @@ -1023,7 +1008,7 @@ struct end else if C_Ast_Utils.is_ptr from_cty then (* pointer -> integer cast via semantic uintptr value, then convert as needed *) - let val ctxt = require_current_visible_ctxt () + 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 @@ -1456,7 +1441,7 @@ struct SOME tm => tm | NONE => error ("micro_c_translate: missing required interface constant: " ^ short_name)) - fun resolve_pointer_model_const ctxt label opt_name default_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) @@ -1470,12 +1455,6 @@ struct fun resolve_ptr_diff_const ctxt = resolve_pointer_model_const ctxt "ptr_diff:" (#ptr_diff (!current_pointer_model)) "c_ptr_diff" - fun resolve_ptr_to_uintptr_const ctxt = - resolve_required_visible_const ctxt "c_ptr_to_uintptr" - - fun resolve_uintptr_to_ptr_const ctxt = - resolve_required_visible_const ctxt "c_uintptr_to_ptr" - 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 @@ -1956,7 +1935,6 @@ struct 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 list_var = Isa_Free ("v__arr_vals", 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) @@ -2083,11 +2061,6 @@ struct fun sizeof_struct fields = #2 (struct_layout fields) - fun struct_field_offset (fields : (string * C_Ast_Utils.c_numeric_type) list) field_name = - (case List.find (fn (name, _, _) => name = field_name) (#1 (struct_layout fields)) of - SOME (_, offset, _) => offset - | NONE => error ("micro_c_translate: unknown struct field in layout: " ^ field_name)) - fun fits_int_literal_cty cty n = case cty_bit_width cty of NONE => false @@ -3047,7 +3020,6 @@ struct 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 list_var = Isa_Free ("v__arr_vals", 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) @@ -3162,6 +3134,8 @@ struct 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 _ => @@ -4038,6 +4012,8 @@ struct 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, _) => From 7fe573f8569f56c8b448e77f0a10214c2641449c Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 19:16:21 +0000 Subject: [PATCH 40/58] Fix all ML warnings in C_Ast_Utilities and C_Definition_Generation C_Ast_Utilities.thy (13 warnings -> 0): - Delete redundant catch-all pattern in resolve_c_type accumulator - Wildcard unused pure_tab parameter in 5 trivially-true clauses of expr_has_side_effect_with - Delete dead function add_decl_struct_bindings (never called) - Wildcard unused parameters in expr_is_list_backed_in_env clauses - Wildcard unused parametric_structs in CPtr clause C_Definition_Generation.thy (5 warnings -> 0): - Add catch-all to tfree_subst map (non-exhaustive match) - Wildcard unused abr_str and target_cty in string literal pattern - Rename variable o to po to avoid SML infix operator conflict - Wildcard unused f in duplicate ManifestOpt error clause --- Micro_C_Parsing_Frontend/C_Ast_Utilities.thy | 23 +++++++------------ .../C_Definition_Generation.thy | 13 +++++------ 2 files changed, 14 insertions(+), 22 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy index 65195404..7319c833 100644 --- a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy +++ b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy @@ -390,7 +390,6 @@ struct | 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 *) - | 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 @@ -690,11 +689,11 @@ struct Symtab.defined pure_tab (ident_name ident) | named_call_is_pure _ _ = false - fun expr_has_side_effect_with pure_tab (CAssign0 _) = true - | expr_has_side_effect_with pure_tab (CUnary0 (CPreIncOp0, _, _)) = true - | expr_has_side_effect_with pure_tab (CUnary0 (CPostIncOp0, _, _)) = true - | expr_has_side_effect_with pure_tab (CUnary0 (CPreDecOp0, _, _)) = true - | expr_has_side_effect_with pure_tab (CUnary0 (CPostDecOp0, _, _)) = true + 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 = @@ -941,23 +940,17 @@ struct List.exists (fn fname => fname = field_name) (the_default [] (Symtab.lookup array_field_tab struct_name)) - fun expr_is_list_backed_in_env struct_tab array_field_tab env struct_env (CVar0 (ident, _)) = + 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 struct_tab array_field_tab env struct_env (CMember0 (base, field_ident, _, _)) = + | 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_struct_bindings struct_names decl struct_env = - (case (declr_of_decl decl, struct_name_of_decl struct_names decl) of - (SOME declr, SOME sname) => - Symtab.update (declr_name declr, sname) struct_env - | _ => struct_env) - fun add_decl_array_bindings decl env = (case declr_of_decl decl of SOME declr => @@ -1289,7 +1282,7 @@ struct | _ => NONE) ext_decls - fun cty_needs_parametric_struct parametric_structs (CPtr _) = true + 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) = diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy index 293abe93..033eac8b 100644 --- a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -167,7 +167,8 @@ struct 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))) tfree_subst + 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) @@ -253,10 +254,8 @@ struct HOLogic.mk_number (C_Ast_Utils.hol_type_of cty) 0 fun init_expr_const_term (C_Ast_Utils.CPtr _) _ = Const (\<^const_name>\c_uninitialized\, dummyT) - | init_expr_const_term target_cty (C_Ast.CConst0 (C_Ast.CStrConst0 (C_Ast.CString0 (abr_str, _), _))) = - (case target_cty of - _ => - error "micro_c_translate: string literal initializer requires char pointer target") + | 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" @@ -899,7 +898,7 @@ ML \ | _ => []) val (state_ty, abort_ty, prompt_in_ty, prompt_out_ty) = (case ref_args of - [s, _, _, a, i, o] => (s, a, i, o) + [s, _, _, a, pi, po] => (s, a, pi, po) | _ => (dummyT, @{typ c_abort}, dummyT, dummyT)) in SOME (Type (\<^type_name>\expression\, @@ -1029,7 +1028,7 @@ local fun collect_load_opts opts = let fun step (CommonOpt topt) (topts, mopt) = (topt :: topts, mopt) - | step (ManifestOpt f) (_, SOME _) = error "micro_c_file: duplicate manifest option" + | 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 From b24ed045aef7be5cb3bf4de17d7501a2154606d9 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 19:32:18 +0000 Subject: [PATCH 41/58] Parameterize struct/union extraction functions by tag Introduce shared implementations parameterized by CStructTag0/CUnionTag0 for 4 function pairs that previously differed only by tag: - extract_aggregate_type_from_specs (was extract_{struct,union}_type_from_specs) - extract_aggregate_type_from_decl_full (was extract_{struct,union}_type_from_decl_full) - extract_aggregate_def_with_types_from_decl (was extract_{struct,union}_def_with_types_from_decl) - extract_aggregate_defs_with_types (was extract_{struct,union}_defs_with_types) The struct/union names remain as thin wrappers for API compatibility. Document why _full variants and struct-only functions are kept separate. --- Micro_C_Parsing_Frontend/C_Ast_Utilities.thy | 124 ++++++++----------- 1 file changed, 53 insertions(+), 71 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy index 7319c833..5b71fd3a 100644 --- a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy +++ b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy @@ -494,32 +494,24 @@ struct | 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, _)) :: _) = + 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) struct_names + in if List.exists (fn s => s = n) agg_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 + | find_agg (_ :: rest) = find_agg rest + in find_agg specs end + | extract_aggregate_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 + 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. *) @@ -1121,21 +1113,20 @@ struct 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 = + fun extract_aggregate_type_from_specs tag specs = case List.find (fn CTypeSpec0 (CSUType0 _) => true | _ => false) specs of - SOME (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, Some ident, _, _, _), _))) => - SOME (ident_name ident) + SOME (CTypeSpec0 (CSUType0 (CStruct0 (tag', Some ident, _, _, _), _))) => + if tag' = tag then SOME (ident_name ident) else NONE | _ => 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 + val extract_struct_type_from_specs = extract_aggregate_type_from_specs CStructTag0 + val extract_union_type_from_specs = extract_aggregate_type_from_specs CUnionTag0 - (* Like extract_struct_type_from_specs, but also recognizes typedef names - that refer to known structs. *) + (* 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 @@ -1257,31 +1248,40 @@ struct | _ => 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, + (* 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, _, _), _)) :: _) = - SOME (ident_name ident, extract_member_field_info typedef_tab members) - | find_struct_def (CTypeSpec0 (CSUType0 (CStruct0 (CStructTag0, + 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, _, _), _)) :: _) = - (* Anonymous struct in typedef: get name from declarator *) - if List.exists (fn CStorageSpec0 (CTypedef0 _) => true | _ => false) specs + 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_struct_def (_ :: rest) = find_struct_def rest - in find_struct_def specs end - | extract_struct_def_with_types_from_decl _ _ = NONE + | find_def (_ :: rest) = find_def rest + in find_def specs end + | extract_aggregate_def_with_types_from_decl _ _ _ = NONE - fun extract_struct_defs_with_types typedef_tab (CTranslUnit0 (ext_decls, _)) = + fun extract_aggregate_defs_with_types tag typedef_tab (CTranslUnit0 (ext_decls, _)) = List.mapPartial - (fn CDeclExt0 decl => extract_struct_def_with_types_from_decl typedef_tab decl + (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 @@ -1307,32 +1307,14 @@ struct List.map #1 (Symtab.dest final) end - (* 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 + 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, From 7a1635165f673f3948f34369ea73f60c63e5644c Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 19:33:18 +0000 Subject: [PATCH 42/58] Extract provide_source_file helper in C_Definition_Generation Deduplicate the identical Resources.provide + ERROR handling pattern that appeared at both the main source file and manifest file registration sites in micro_c_file. --- .../C_Definition_Generation.thy | 29 +++++++++---------- 1 file changed, 13 insertions(+), 16 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy index 033eac8b..b78e1cd7 100644 --- a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -1032,6 +1032,16 @@ local | 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\ @@ -1050,15 +1060,8 @@ val _ = 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 + (* 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) = @@ -1068,13 +1071,7 @@ val _ = 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 + val lthy' = provide_source_file (m_src, m_digest) lthy in (parse_manifest_text (cat_lines m_lines), lthy') end) From 4b69242b666e03dee2ca31a09f7d12ae518998ca Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 19:34:32 +0000 Subject: [PATCH 43/58] Document CVoid => CInt fallback and error conventions Add comments explaining: - Why extract_member_field_info falls back from CVoid to CInt (struct/union fields cannot have void type; CVoid from opaque typedefs) - Error convention in C_Translation_Engine: error "micro_c_translate: ..." for internal errors vs unsupported "..." for missing features --- Micro_C_Parsing_Frontend/C_Ast_Utilities.thy | 4 ++++ Micro_C_Parsing_Frontend/C_Translation_Engine.thy | 6 ++++++ 2 files changed, 10 insertions(+) diff --git a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy index 5b71fd3a..317670a5 100644 --- a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy +++ b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy @@ -1161,6 +1161,9 @@ struct 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 @@ -1237,6 +1240,7 @@ struct 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 diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index a9093b45..aae797ed 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -1104,6 +1104,12 @@ struct 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 = From 5dcc8b177666272ea45d60cea6deceda4fff9e95 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 19:37:56 +0000 Subject: [PATCH 44/58] Break up process_translation_unit into helper functions Extract 4 named phases from the 332-line monolith: - setup_translation_state: reset mutable refs, read config - extract_type_definitions: struct/union/enum/typedef extraction - extract_and_order_functions: signature computation, topo-sort, purity analysis - analyze_list_backed_params: call-site analysis for array parameters process_translation_unit is now a ~40-line orchestrator that calls these phases and threads results into definition generation. --- .../C_Definition_Generation.thy | 89 +++++++++++++++---- 1 file changed, 70 insertions(+), 19 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy index b78e1cd7..d3df3c04 100644 --- a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -402,7 +402,8 @@ struct List.concat (List.map from_ext_decl ext_decls) end - fun process_translation_unit tu lthy = + (* 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 @@ -410,22 +411,18 @@ struct val _ = C_Translate.current_struct_array_fields := Symtab.empty val decl_prefix = !current_decl_prefix val abi_profile = !current_abi_profile - val {functions = manifest_functions, types = manifest_types} = !current_manifest + 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) - 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) + 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 () - (* Extract struct definitions to build the struct field registry. - Use fold/update to allow user typedefs to override builtins. *) + (* 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) @@ -456,14 +453,12 @@ struct 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 @ C_Ast_Utils.extract_typedefs tu val typedef_tab = List.foldl (fn ((n, v), tab) => Symtab.update (n, v) tab) @@ -485,12 +480,21 @@ struct 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) - (* 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, _, _) => @@ -602,6 +606,18 @@ struct (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 @@ -615,6 +631,7 @@ struct 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) => @@ -702,7 +719,41 @@ struct Symtab.update (fname, modes) tab end) Symtab.empty fundefs_raw - val _ = C_Translate.current_list_backed_param_modes := list_backed_param_modes + 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 @@ -728,7 +779,7 @@ struct datatype package obligations. *) define_abi_metadata decl_prefix abi_profile lthy in - (* Translate and define each function one at a time, so that later + (* 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 From 403ede2884ed4d2abab4781b29f44922e3eee92a Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 20:32:06 +0000 Subject: [PATCH 45/58] Add register/auto storage class smoke tests and proof register and auto are already silently ignored by the catch-all in accumulate. Add smoke test in C_Translation_Smoke_Types and verified proof example in C_Misc_Examples documenting this. --- Micro_C_Examples/C_Misc_Examples.thy | 21 +++++++++++++++++++ .../C_Translation_Smoke_Types.thy | 9 ++++++++ 2 files changed, 30 insertions(+) diff --git a/Micro_C_Examples/C_Misc_Examples.thy b/Micro_C_Examples/C_Misc_Examples.thy index a9b41c48..80c2890a 100644 --- a/Micro_C_Examples/C_Misc_Examples.thy +++ b/Micro_C_Examples/C_Misc_Examples.thy @@ -163,6 +163,27 @@ lemma c_char_val_spec [crush_specs]: 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) + end end diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy index 4926a1f5..ed3cca74 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy @@ -126,4 +126,13 @@ 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 + end From 8cfe4109088948811d3cf814bcf7409ab1c79634 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 20:40:29 +0000 Subject: [PATCH 46/58] Implement __builtin_offsetof translation Add CBuiltinOffsetOf0 handler in translate_expr that computes byte offsets using raw_struct_field_offset, with support for nested struct field designator chains. Smoke test and verified proof (offset_of_b returns 4 for second int field). --- Micro_C_Examples/C_Misc_Examples.thy | 22 +++++++++++++ .../C_Translation_Engine.thy | 31 ++++++++++++++++++- .../C_Translation_Smoke_Advanced.thy | 12 +++++++ 3 files changed, 64 insertions(+), 1 deletion(-) diff --git a/Micro_C_Examples/C_Misc_Examples.thy b/Micro_C_Examples/C_Misc_Examples.thy index 80c2890a..14e3b908 100644 --- a/Micro_C_Examples/C_Misc_Examples.thy +++ b/Micro_C_Examples/C_Misc_Examples.thy @@ -184,6 +184,28 @@ lemma c_register_add_spec [crush_specs]: 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 + end end diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index aae797ed..7191e7b7 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -4004,8 +4004,37 @@ struct 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 _ (CBuiltinExpr0 _) = - unsupported "GCC builtin expression (only __builtin_types_compatible_p is supported)" + unsupported "GCC builtin expression (only __builtin_types_compatible_p and __builtin_offsetof are supported)" | translate_expr _ _ = unsupported "expression" diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy index 429e7089..7af2fde4 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy @@ -88,4 +88,16 @@ smoke_adv_al_size_t smoke_adv_alignof_int(void) { 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 + end From c8d292f323d80818ad6e2cd270f140c003476ef3 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 20:44:17 +0000 Subject: [PATCH 47/58] Implement range designators in array initializers Handle CRangeDesig0 ([lo...hi] = val) in both global (C_Definition_Generation) and local (C_Translation_Engine) array initialization by expanding ranges into multiple index-value pairs. Smoke test and verified proof (range_arr with [0..1]=10, [2..3]=20). --- Micro_C_Examples/C_Misc_Examples.thy | 21 +++++++++++++++++++ .../C_Definition_Generation.thy | 19 +++++++++++------ .../C_Translation_Engine.thy | 19 +++++++++++------ .../C_Translation_Smoke_Advanced.thy | 11 ++++++++++ 4 files changed, 58 insertions(+), 12 deletions(-) diff --git a/Micro_C_Examples/C_Misc_Examples.thy b/Micro_C_Examples/C_Misc_Examples.thy index 14e3b908..497fc41d 100644 --- a/Micro_C_Examples/C_Misc_Examples.thy +++ b/Micro_C_Examples/C_Misc_Examples.thy @@ -206,6 +206,27 @@ lemma c_offset_of_b_spec [crush_specs]: 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 + end end diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy index d3df3c04..b0250d02 100644 --- a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -345,15 +345,22 @@ struct 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 resolve_desig_idx [] pos = pos - | resolve_desig_idx [C_Ast.CArrDesig0 (C_Ast.CConst0 (C_Ast.CIntConst0 (C_Ast.CInteger0 (n, _, _), _)), _)] _ = - intinf_to_int_checked "global array designator" n - | resolve_desig_idx _ _ = + 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 idx = resolve_desig_idx desigs pos - in (idx, init_item) :: collect_indices rest (idx + 1) end + 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 = diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index 7191e7b7..e2d0ac2a 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -4343,14 +4343,21 @@ struct let (* 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 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 idx = resolve_desig_idx desigs pos - in (idx, e) :: collect_indices rest (idx + 1) end + 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 diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy index 7af2fde4..6158df1e 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy @@ -100,4 +100,15 @@ smoke_adv_off_size_t smoke_adv_offsetof(void) { 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 + end From cdd22c3e4ff4e2a38675c1c76fc146666d6b60b4 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 20:50:13 +0000 Subject: [PATCH 48/58] Implement struct compound literal translation Handle (struct T){field1, field2, ...} compound literals in translate_expr by reusing the struct field init logic from translate_decl. Uses monadic path with bind variables for each field expression. Smoke test and translation example verified. --- Micro_C_Examples/C_Misc_Examples.thy | 11 ++++ .../C_Translation_Engine.thy | 60 ++++++++++++++++++- .../C_Translation_Smoke_Advanced.thy | 11 ++++ 3 files changed, 80 insertions(+), 2 deletions(-) diff --git a/Micro_C_Examples/C_Misc_Examples.thy b/Micro_C_Examples/C_Misc_Examples.thy index 497fc41d..17081315 100644 --- a/Micro_C_Examples/C_Misc_Examples.thy +++ b/Micro_C_Examples/C_Misc_Examples.thy @@ -227,6 +227,17 @@ lemma c_range_test_spec [crush_specs]: 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 + end end diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index e2d0ac2a..bb38df60 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -3961,11 +3961,67 @@ struct | NONE => unsupported "compound literal with unsupported type" end | _ => unsupported "compound literal with unsupported declaration") - in case init_list of - [([], CInitExpr0 (expr, _))] => + 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, _)) = diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy index 6158df1e..4219dafd 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy @@ -111,4 +111,15 @@ unsigned int smoke_adv_range_lookup(unsigned int 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 + end From 6d44a967405432de799b34b75d5fdbb75281391f Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 21:03:09 +0000 Subject: [PATCH 49/58] Implement GCC statement expression ({...}) translation Add CStatExpr0 handler using a forward-ref pattern to bridge translate_expr (earlier mutual recursion block) with translate_compound_items_expr (later block). The new function processes declarations via Ref::new binds and returns the last expression's value and type. Smoke test and verified proof. --- Micro_C_Examples/C_Misc_Examples.thy | 23 +++++++++ .../C_Translation_Engine.thy | 50 +++++++++++++++++++ .../C_Translation_Smoke_Advanced.thy | 15 ++++++ 3 files changed, 88 insertions(+) diff --git a/Micro_C_Examples/C_Misc_Examples.thy b/Micro_C_Examples/C_Misc_Examples.thy index 17081315..9dd5f632 100644 --- a/Micro_C_Examples/C_Misc_Examples.thy +++ b/Micro_C_Examples/C_Misc_Examples.thy @@ -238,6 +238,29 @@ micro_c_translate addr: nat \ 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_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index bb38df60..70e72e3e 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -630,6 +630,14 @@ struct 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 () = @@ -4089,6 +4097,10 @@ struct 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 _ _ = @@ -4942,6 +4954,42 @@ struct 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, _, _), _))) = @@ -5653,6 +5701,8 @@ struct 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 diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy index 4219dafd..6b658222 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy @@ -122,4 +122,19 @@ void smoke_adv_struct_compound_lit(struct smoke_adv_compound_lit_pt *out) { 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 + end From 08cb65657b832803443b35bb6b872ce5d7e68f1c Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 21:05:10 +0000 Subject: [PATCH 50/58] Add __int128 smoke tests verifying arithmetic dispatch Both unsigned __int128 addition and signed __int128 subtraction translate correctly. Proof example deferred pending c_uint128 verification locale. --- .../C_Translation_Smoke_Types.thy | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy index ed3cca74..4eacb520 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy @@ -135,4 +135,20 @@ unsigned int smoke_types_register(register unsigned int x) { 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 + end From 8deafba988226bff9d1c370b1a6ea4e5eaa13afc Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 21:10:04 +0000 Subject: [PATCH 51/58] Generalize multi-dimensional array init to arbitrary depth Replace hardcoded 2D array init with recursive build_nested that handles 3D+ arrays by unwrapping CPtr levels and matching dimension sizes. Includes build_zero for padding incomplete initializer lists. Smoke test verifies 3D array int[2][2][2] translation. --- .../C_Translation_Engine.thy | 76 ++++++++++++------- .../C_Translation_Smoke_Advanced.thy | 11 +++ 2 files changed, 59 insertions(+), 28 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index 70e72e3e..4ffe6a31 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -4370,41 +4370,61 @@ struct val elem_type = C_Ast_Utils.hol_type_of elem_cty in if C_Ast_Utils.is_ptr elem_cty then - (* 2D array: elements are sub-arrays (CInitList0 inside CInitList0) *) - let val inner_elem_cty = - (case elem_cty of C_Ast_Utils.CPtr inner => inner - | _ => error "micro_c_translate: expected pointer element type for 2D array") - val inner_elem_type = C_Ast_Utils.hol_type_of inner_elem_cty - val inner_zero = HOLogic.mk_number inner_elem_type 0 - (* Extract inner array size from second CArrDeclr0 dimension *) + (* 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 inner_size = (case arr_sizes of _ :: m :: _ => SOME m | _ => NONE) - fun build_inner_list (_, CInitList0 (inits, _)) = - let val vals = List.map - (fn (_, CInitExpr0 (e, _)) => init_scalar_const_term inner_elem_cty e - | _ => unsupported "complex nested array element") inits - val padded = case inner_size of - SOME m => if List.length vals > m - then unsupported "too many elements in inner array" - else vals @ List.tabulate (m - List.length vals, fn _ => inner_zero) - | NONE => vals - in HOLogic.mk_list inner_elem_type padded end - | build_inner_list _ = unsupported "expected inner initializer list for 2D array" - val inner_lists = List.map build_inner_list init_list - val inner_list_type = HOLogic.listT inner_elem_type - val zero_inner = HOLogic.mk_list inner_elem_type - (case inner_size of SOME m => List.tabulate (m, fn _ => inner_zero) | NONE => []) - val padded_outer = - if List.length inner_lists < outer_size - then inner_lists @ List.tabulate (outer_size - List.length inner_lists, fn _ => zero_inner) - else inner_lists - val result = HOLogic.mk_list inner_list_type padded_outer + 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 diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy index 6b658222..ef89bb36 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Advanced.thy @@ -137,4 +137,15 @@ unsigned int smoke_adv_stmt_expr(unsigned int a, unsigned int b) { 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 From d1d34ecf23642ed41383974bf5537587eff4a683 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sat, 21 Mar 2026 21:12:10 +0000 Subject: [PATCH 52/58] Allow volatile qualifier by silently ignoring it Remove the hard error for volatile in accumulate, treating it like const/restrict. This unblocks translation of volatile-qualified C code. Sound yield-based volatile modeling (where volatile reads produce nondeterministic values via Yield) is deferred as a follow-up. Smoke tests for volatile pointer deref and volatile local. --- Micro_C_Parsing_Frontend/C_Ast_Utilities.thy | 3 +-- .../C_Translation_Smoke_Types.thy | 17 +++++++++++++++++ 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy index 317670a5..36f32755 100644 --- a/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy +++ b/Micro_C_Parsing_Frontend/C_Ast_Utilities.thy @@ -381,8 +381,7 @@ struct 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 _)) _ = - error "micro_c_translate: volatile qualifier not supported" + | 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 *) diff --git a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy index 4eacb520..c3b26a89 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Smoke_Types.thy @@ -151,4 +151,21 @@ __int128 smoke_types_i128_negate(__int128 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 From 58b000f0e2fdb3908ffcb86d9208fcba18d54548 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sun, 22 Mar 2026 11:05:38 +0000 Subject: [PATCH 53/58] define_c_function: replace phantom schematic TYPE args with TYPE(unit) When a function definition introduces extra type variables (e.g., from unresolved adhoc overloading in switch bodies or void pointer casts), the locale morphism turns these into schematic type variables (TVar) in phantom TYPE arguments of the registered constant. Later functions that reference this constant then fail with "Illegal schematic type variable". Fix: in define_c_function, detect TYPE args containing TVars and replace them with TYPE(unit). This prevents the cascade while preserving locale type parameters (which appear as TFree, not TVar). --- .../C_Definition_Generation.thy | 25 ++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy index b0250d02..08bef6e2 100644 --- a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -63,10 +63,33 @@ struct 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) + (Term.list_comb (Const (c, dummyT), args'), "const: " ^ c) | _ => (morphed_lhs, "registered term") end val _ = From 9e85b19bc560825ed533cfd439afbe261a0d0f74 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sun, 22 Mar 2026 11:05:56 +0000 Subject: [PATCH 54/58] init_value_term: support nested array initializers Add a case for CInitList0 with non-struct target types, enabling translation of multi-dimensional array initializers like int a[2][2][2] = {{{1,2},{3,4}},{{5,6},{7,8}}}. Previously this hit the catch-all "unsupported non-constant global initializer shape" error. The new case recursively builds nested HOL lists from the sub-array initializer elements. --- .../C_Definition_Generation.thy | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy index 08bef6e2..fc7ee51d 100644 --- a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -327,6 +327,31 @@ struct 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 = From c68644a3a24af0bea6df74135e660a718e1994b4 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sun, 22 Mar 2026 11:12:15 +0000 Subject: [PATCH 55/58] micro_c_translate/micro_c_file: add verbose option for type variable tracing MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add a 'verbose' keyword option to micro_c_translate and micro_c_file. When enabled, functions with extra type variables (TVars or TFrees beyond locale parameters) emit diagnostic output showing: - The variable names and sorts - Sub-term locations (Free/Const/lambda) that introduce them Usage: micro_c_translate verbose ‹...› micro_c_file verbose ‹path.c› This is a debugging aid for pinpointing the source of phantom type variables in translated C functions. --- .../C_Definition_Generation.thy | 95 +++++++++++++++++-- 1 file changed, 85 insertions(+), 10 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy index fc7ee51d..df5fc236 100644 --- a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -4,6 +4,7 @@ theory C_Definition_Generation 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\ @@ -17,6 +18,7 @@ structure C_Def_Gen : sig 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 @@ -35,6 +37,8 @@ struct 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) @@ -92,6 +96,65 @@ struct (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. *) + val verbose_used_tfrees = + let val (_, args) = Term.strip_comb morphed_lhs + val non_type = List.filter + (fn Const (n, Type ("itself", _)) => n <> \<^const_name>\Pure.type\ | _ => true) args + in List.foldl (fn (a, acc) => Term.add_tfrees a acc) [] non_type |> map fst 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 _ (t as Abs (x, T, body)) = + if has_extra_tyvar (Abs (x, T, Term.dummy_pattern (type_of body))) + andalso not (has_extra_tyvar body) + then writeln (" source: lambda " ^ x ^ " :: " ^ + Syntax.string_of_typ_global @{theory} T) + else trace_subterms 0 body + | trace_subterms depth (f $ x) = + if depth < 3 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); @@ -898,6 +961,7 @@ ML \ | 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 () @@ -921,17 +985,20 @@ ML \ || (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 + 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 + ptr_add = NONE, ptr_shift_signed = NONE, ptr_diff = NONE, compiler = NONE, + verbose = false } fun set_once _ NONE v = SOME v @@ -940,36 +1007,43 @@ ML \ 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} + 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} + 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} + 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} + 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} + 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} + 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} + 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} + 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 @@ -1016,6 +1090,7 @@ ML \ 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 _ = From 250012e2e650cdcb857126195a9e68c13acf7636 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sun, 22 Mar 2026 15:20:31 +0000 Subject: [PATCH 56/58] verbose: fix depth limit, false positives, and bound variable crash - Increase sub-term traversal depth from 3 to 20 to reach deeply nested terms in complex functions like fdt_next_tag - Include locale type parameters from the expression constraint and addr/gv refs in the "used" set, preventing false positive reports for simple functions whose only TFrees are the locale's own 's, 'i, 'o - Fix crash on bound variables by checking lambda binding types directly instead of using type_of on the body (which fails on Bound terms) --- .../C_Definition_Generation.thy | 25 +++++++++++-------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy index df5fc236..ba4f5d00 100644 --- a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -99,11 +99,16 @@ struct (* 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 non_type = List.filter - (fn Const (n, Type ("itself", _)) => n <> \<^const_name>\Pure.type\ | _ => true) args - in List.foldl (fn (a, acc) => Term.add_tfrees a acc) [] non_type |> map fst end + 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 @@ -130,14 +135,14 @@ struct 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 _ (t as Abs (x, T, body)) = - if has_extra_tyvar (Abs (x, T, Term.dummy_pattern (type_of body))) - andalso not (has_extra_tyvar body) - then writeln (" source: lambda " ^ x ^ " :: " ^ - Syntax.string_of_typ_global @{theory} T) - else trace_subterms 0 body + 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 < 3 then + if depth < 20 then (trace_subterms (depth + 1) f; trace_subterms (depth + 1) x) else () From 124f208b5574bdddfe62c6731c88a255105acdf3 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sun, 22 Mar 2026 16:03:13 +0000 Subject: [PATCH 57/58] translate_expr: support pointer - integer subtraction (ptr - n) Previously, CSubOp0 with a pointer LHS and integer RHS fell through to the usual_arith_conv catch-all, which called type_rank on the pointer type and failed with "pointer type has no integer conversion rank". Fix: add a case for (CSubOp0, CPtr elem_cty, ) that negates the integer offset (0 - n) and delegates to the existing pointer addition machinery (mk_raw_ptr_add / mk_list_ptr_add). This unblocks fdt_find_string_len_ which uses: const char *last = strtab + tabsize - (slen + 1); --- .../C_Translation_Engine.thy | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index 4ffe6a31..8326abb5 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -2533,7 +2533,21 @@ struct 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, C_Ast_Utils.CPtr _) => + | (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) From 00a347e73a94aa3ddfb029ed212309691fbc0351 Mon Sep 17 00:00:00 2001 From: Dominic Mulligan Date: Sun, 22 Mar 2026 21:00:39 +0000 Subject: [PATCH 58/58] mk_implicit_cast, translate_fundef: fix void pointer casts and locale parameter calls MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Four fixes enabling translation of C functions that call locale-provided stdlib functions (e.g. memcmp/memmove) and return pointer types: 1. void→T* scalar cast: use typed prism and function type skeleton for c_cast_from_void so fastype_of succeeds and adhoc overloading resolves. 2. Pointer increment (LocalPtr): give c_cast_from_void a focused result type so mk_ptr_shifted_term detects the focused value and extracts the raw pointer via unwrap_focused. 3. Function call constraint: pin the return type to function_body with dummyT side types, so funcall's shared type variables propagate through the function reference to the argument expressions. 4. FunctionBody value=return constraint: for pointer-returning functions, construct the focused return type directly (pointer-first dispatch) and constrain both value and return positions to match. --- .../actions/setup-isabelle-action/action.yml | 8 +- .../C_Definition_Generation.thy | 11 ++- .../C_Translation_Engine.thy | 82 ++++++++++++++----- 3 files changed, 76 insertions(+), 25 deletions(-) diff --git a/.github/actions/setup-isabelle-action/action.yml b/.github/actions/setup-isabelle-action/action.yml index 1660752c..8031ac65 100644 --- a/.github/actions/setup-isabelle-action/action.yml +++ b/.github/actions/setup-isabelle-action/action.yml @@ -14,8 +14,12 @@ runs: - name: Patch AFP Isabelle/C parser shell: bash run: | - cd afp - patch -p1 < $GITHUB_WORKSPACE/.github/patches/isabelle_c_parser_language.patch + 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 diff --git a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy index ba4f5d00..1b84c9d0 100644 --- a/Micro_C_Parsing_Frontend/C_Definition_Generation.thy +++ b/Micro_C_Parsing_Frontend/C_Definition_Generation.thy @@ -343,7 +343,15 @@ struct 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 _) _ = + 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" @@ -1089,6 +1097,7 @@ ML \ 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 diff --git a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy index 8326abb5..2ecd451f 100644 --- a/Micro_C_Parsing_Frontend/C_Translation_Engine.thy +++ b/Micro_C_Parsing_Frontend/C_Translation_Engine.thy @@ -807,8 +807,10 @@ struct SOME ty => ty | NONE => isa_dummyT) - (* Untyped void* cast helper: keep prism target type polymorphic so later - context (e.g. indexing vs scalar dereference) can resolve it. *) + (* 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) @@ -969,13 +971,21 @@ struct C_Ast_Utils.CStruct _ => mk_cast_from_void to_inner tm | C_Ast_Utils.CUnion _ => mk_cast_from_void to_inner tm | _ => - let val cast_term = mk_cast_from_void_untyped tm - val target_ty = - (case pointer_expr_value_hol_ty to_cty of - SOME ty => ty - | NONE => isa_dummyT) - in if target_ty = isa_dummyT then cast_term - else constrain_expr_value_type target_ty cast_term + 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 @@ -998,10 +1008,7 @@ struct in if void_ptr_ty = isa_dummyT then cast_term else constrain_expr_value_type void_ptr_ty cast_term end - (* T* -> U* where neither is void/union: - reinterpret through void* so the resulting focused reference - carries U's prism (byte-level view), rather than leaving the - term at type T* while only changing the tracked C type. *) + (* T* -> U* reinterpret through void *) else if from_inner = to_inner then tm else let val tm' = @@ -1805,7 +1812,10 @@ struct 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 cast_const = Isa_Const (\<^const_name>\c_cast_from_void\, isa_dummyT) + 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) @@ -3401,8 +3411,19 @@ struct 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, isa_dummyT) + (arg_tys, fn_result_ty) in Type.constraint fn_ty fref_fueled end @@ -5905,20 +5926,37 @@ struct (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. *) + (* 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) - val 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.CVoid => constrain_known_expr_value_type @{typ unit} body_term + C_Ast_Utils.CPtr _ => NONE | _ => (case C_Ast_Utils.cty_to_record_typ (!current_decl_prefix) ret_cty of - SOME ty => constrain_known_expr_value_type ty body_term - | NONE => body_term)) + 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