LCS Number: |
LCS-2016-041 |
Version: |
3 |
Date: |
21-Mar-2017 |
Status: |
Approved |
Code Examples
Generic length
-- determines the length of a discrete type
-- this is a utility method used in the examples
function length(tpe : subtype_mirror) return index_type is
constant class : type_class := tpe.get_type_class;
begin
case class is
when class_enumeration =>
return tpe.as_enumeration.length;
when class_integer =>
return tpe.as_integer.length;
when others =>
report type_class'image(class) & " doesn't have a length" severity failure;
end case;
return -1;
end;
Generic to_string
-- can create a string for any value
procedure use_to_string(variable v : some_type) is
constant mirror : value_mirror := v'reflect;
begin
report to_string(mirror);
end procedure;
function to_string(value : value_mirror) return string is
constant dummy : string := "dummy";
function to_string(value : array_value_mirror) return string is
constant array_type : array_subtype_mirror := value.get_subtype;
constant length : index_type := length(array_type.index_subtype(1));
begin
if array_type.dimensions /= 1 then
-- not supported in this example
report "only 1D arrays are supported" severity failure;
return index_type'image(array_type.dimensions) & "D array";
end if;
return "(" & to_string(value, 0, length, "") & ")";
end function;
function to_string(value : array_value_mirror; field_idx, length : index_type; prefix : string) return string is
constant index : index_vector := (0 => field_idx);
constant element_str : string := to_string(value.get(index));
begin
if field_idx < length - 1 then
return to_string(value, field_idx+1, length, prefix & element_str & ", ");
elsif field_idx = length - 1 then
return prefix & element_str;
end if;
end function;
function to_string(value : record_value_mirror) return string is
begin
return "(" & to_string(value, 0, "") & ")";
end function;
function to_string(value : record_value_mirror; element_idx : index_type; prefix : string) return string is
constant element_tpe : record_subtype_mirror := value.get_subtype;
constant element_str : string := to_string(value.get(element_idx));
begin
if element_idx < element_tpe.length - 1 then
return to_string(value, element_idx+1, prefix & element_str & ", ");
elsif element_idx = element_tpe.length - 1 then
return prefix & element_str;
end if;
end function;
constant class : type_class := value.get_subtype.get_type_class;
begin
case class is
when class_integer =>
return system_integer'image(value.as_integer.value);
when class_floating =>
return real'image(value.as_floating.value);
when class_physical =>
-- TODO
null;
when class_enumeration =>
return value.as_enumeration.image;
when class_record =>
return to_string(value.as_record);
when class_array =>
return to_string(value.as_array);
when class_access =>
return "access type " & value.as_access.get_subtype.simple_name;
when class_protected =>
return "protected type";
when class_file =>
return "file type";
end case;
report "unreachable" severity failure;
return dummy;
end function;
Flatten a multi-dimensional array
procedure use_flatten is
type enum is (l1, l2);
type foo is array (enum, natural range 0 to 2) of integer;
constant foo_val : foo := ((1, 2), (2, 3), (4, 5));
constant foo_mir : value_mirror := foo_val'reflect;
begin
report to_string(flatten(foo_mir.as_array));
end procedure;
function flatten(value : array_value_mirror) return integer_vector is
procedure flatten(
foo_arr_mir : array_value_mirror;
arr_type_mir : array_subtype_mirror;
cur_dim : index_type;
dim_vec : inout index_vector;
ret : out integer_vector
) is
variable dim_type : subtype_mirror;
begin
if cur_dim < arr_type_mir.dimensions then
dim_type := arr_type_mir.index_subtype(cur_dim);
for j in 0 to length(dim_type) - 1 loop
dim_vec(cur_dim) := j;
flatten(foo_arr_mir, arr_type_mir, cur_dim + 1, dim_vec, ret);
end loop;
else
dim_type := arr_type_mir.index_subtype(cur_dim);
for j in 0 to length(dim_type) - 1 loop -- loop in the direction of one dimmension, e.g. X, Y, Z
dim_vec(dim_vec'high) := j;
ret(integer(pos(arr_type_mir, dim_vec))) := integer_value(foo_arr_mir.get(dim_vec));
end loop;
end if;
end procedure;
function size(arr_type_mir : array_subtype_mirror) return integer is
variable size : positive_index_type := 1;
variable dim_type : subtype_mirror;
begin
for i in 1 to arr_type_mir.dimensions loop
dim_type := arr_type_mir.index_subtype(i);
size := size * length(dim_type);
end loop;
return integer(size);
end function;
function pos(
arr_type_mir : array_subtype_mirror;
dim_vec : index_vector
) return index_type is
variable pos : index_type := 0;
variable dim_type : subtype_mirror;
begin
for i in dim_vec'range loop
dim_type := arr_type_mir.index_subtype(i);
pos := pos * length(dim_type) + dim_vec(i);
end loop;
return pos;
end function;
function integer_value(value : value_mirror) return integer is
constant type_klass : type_class := value.get_subtype.get_type_class;
begin
if type_klass /= class_integer then
report "Expected an integer type but got " & type_class'image(type_klass);
return 0;
end if;
return integer(value.as_integer.value);
end function;
constant arr_type_mir : array_subtype_mirror := array_value_mirror.get_subtype;
constant dimensions : positive_index_type := arr_type_mir.dimensions;
variable dim_vec : index_vector(0 to dimensions - 1);
variable ret : integer_vector(0 to size(arr_type_mir) - 1);
begin
flatten(value, arr_type_mir, 1, dim_vec, ret);
return ret;
end function;
Randomize any
function randomize(value : subtype_mirror) return value_mirror is
constant class : type_class := subtype_mirror.get_type_class;
-- implementation not provided
function random(\from\, \to\ : system_integer) return system_integer;
function random(\from\, \to\ : real) return real;
function randomize(tpe : enumeration_subtype_mirror) return value_mirror is
constant low : system_integer := tpe.low.pos;
constant high : system_integer := tpe.high.pos;
constant idx : positive_index_type := positive_index_type(random(low, high));
begin
return tpe.value(idx).as_value_mirror;
end function;
function randomize(tpe : integer_subtype_mirror) return value_mirror is
constant low : system_integer := tpe.low.value;
constant high : system_integer := tpe.high.value;
begin
return tpe.value(random(low, high)).as_value_mirror;
end function;
function randomize(tpe : floating_subtype_mirror) return value_mirror is
constant low : real := tpe.low.value;
constant high : real := tpe.high.value;
begin
return tpe.value(random(low, high)).as_value_mirror;
end function;
function randomize(tpe : record_subtype_mirror) return value_mirror is
constant new_value : record_value_mirror := tpe.create;
begin
for i in 0 to tpe.length -1 loop
new_value.set(i, randomize(tpe.element_subtype(i)));
end loop;
return new_value.as_value_mirror;
end function;
function randomize(tpe : array_subtype_mirror) return value_mirror is
constant length : index_type := length(tpe.index_subtype(1));
constant new_value : array_value_mirror := tpe.create((0 => length));
constant element_type : subtype_mirror := tpe.element_subtype;
begin
if tpe.dimensions /= 1 then
report "Not yet supported" severity failure;
end if;
for i in 0 to length loop
new_value.set((0 => i), randomize(element_type));
end loop;
return new_value.as_value_mirror;
end function;
begin
case class is
when class_enumeration =>
return randomize(value.as_enumeration);
when class_integer =>
return randomize(value.as_integer);
when class_floating =>
return randomize(value.as_floating);
when class_record =>
return randomize(value.as_record);
when class_array =>
return randomize(value.as_array);
when class_physical =>
-- TODO
null;
when class_access | class_protected | class_file =>
-- can't randomize these
report "Can't randomize access types & protected types" severity failure;
end case;
end function;