with text_io; use text_io; with string_pack; use string_pack; with enumeration_image; with variable_io; with longest_enum; -- ***************************************************************************** package body abstract_domain_generator is -- GENERIC INPUTS -- type package_names is (<>); List of all valid domain package names -- constants needed throughout editting the base_specific_domains package dom_array : constant string := "type domain_package_array is array (positive range <>) of valid_domain_names;"; base_spec : constant string := "base_specific_domains"; bs_dom_types : constant string := "type base_specific_domain_types is "; bs_con_types : constant string := "type corresponding_concrete_types is "; bs_ops_types : constant string := "type ops_packages is "; bs_dom_names : constant string := "valid_domain_names"; char_nn : constant string := "is new sql_char_pkg.sql_char_not_null"; char_wn : constant string := "is new sql_char_pkg.sql_char"; char_ops : constant string := "is new sql_char_pkg.sql_char_ops"; enum_pk : constant string := "sql_enumeration_pkg"; max_length : integer := 1000; -- for maximum length of strings first_ops, first_ops_list, first_list : boolean := true; -- for combining temporary lists the_longest_value : integer := 0; -- strings used to build up lists of valid domains, concrete types and ops -- packages dom_list : string (1..max_length) := (others => ' '); temp_dom_list : string (1..max_length) := (others => ' '); con_list : string (1..max_length) := (others => ' '); temp_con_list : string (1..max_length) := (others => ' '); ops_list : string (1..max_length) := (others => ' '); temp_ops_list : string (1..max_length) := (others => ' '); -- array types and objects used for consitstency checking during execution -- array used for the valid domain package names type pkg_name_array is array(package_names) of boolean; package_created : pkg_name_array := (others => false); -- files to store output base_specific_domains : file_type; domain_package : file_type; -- exceptions duplicate_package : exception; uncreated_package : exception; duplicate_domain : exception; undefined_domain : exception; char_subtype : exception; undefined_based_on : exception; undefined_parent : exception; -- boolean checks error_occured : boolean := false; -- to keep track of whether or not to build the files -- generic instantiations package domain_io is new variable_io(75); -- 75 is longest allowed line in file package specific_io is new variable_io(75); -- 75 is longest allowed line in file -- functions and procedures -- the following procedures are used later in package start_generate -- to generate the domain declarations -- for each domain package based on whether the domain or subtype -- specified is null bearing, non-null bearing or both. -- Used for char, non-null bearing domain declarations procedure print_char_not_null(dom, rng_start, rng_stop : string) is begin domain_io.put_line(domain_package, indent4 & "type " & strip(dom) & "nn_base " & char_nn & ";"); domain_io.put_line(domain_package, indent4 & "subtype " & strip(dom) & "_not_null is " & strip (dom) & "nn_base (" & strip(rng_start) & ".." & strip(rng_stop) & ");"); end print_char_not_null; -- Used for char, null bearing domain declarations procedure print_char_null_only(dom : string) is begin domain_io.put_line(domain_package, indent4 & "type " & strip(dom) &"_base " & char_wn & ";"); domain_io.put_line(domain_package, indent4 & "subtype " & strip(dom) & "_type is " & strip (dom) & "_base;"); end print_char_null_only; -- Used for char null and for char package _ops instantiation procedure print_char_null_ops (dom : string) is begin domain_io.put_line(domain_package, indent4 & "type " & strip(dom) &"_base " & char_wn & ";"); domain_io.put_line(domain_package, indent4 & "subtype " & strip(dom) & "_type is " & strip (dom) & "_base (" & strip(dom) & "_not_null'length);"); domain_io.put_line(domain_package, indent4 & "package " & strip(dom) &"_ops "); domain_io.put_line(domain_package, indent4 & indent4 & char_ops & "(" & strip(dom) & "_base, " & strip(dom) & "nn_base);"); end print_char_null_ops; -- Used for non-enumeration/char, non-null bearing domain declarations procedure print_regular_not_null(dom, sql_type, rng_start, rng_stop : string) is begin domain_io.put_line(domain_package, indent4 & "type " & strip(dom) &"_not_null is new sql_" & strip(sql_type) & "_not_null"); domain_io.put_line(domain_package, indent4 & indent4 & "range " & strip(rng_start) & ".." & strip(rng_stop) & ";"); end print_regular_not_null; -- Used for non-enumeration/char, null bearing domain declarations procedure print_regular_null(dom, sql_type : string) is begin domain_io.put_line(domain_package, indent4 & "type " & strip(dom) &"_type is new sql_" & strip(sql_type) & ";"); end print_regular_null; -- Used for non-enumeration/char, non-null bearing subtype declarations procedure print_sub_not_null(dom, base_dom, rng_start, rng_stop : string) is begin domain_io.put_line(domain_package, indent4 & "subtype " & strip(dom) & "_not_null is " & strip(base_dom) & "_not_null "); domain_io.put_line(domain_package, indent4 & indent4 & "range " & strip(rng_start) & ".." & strip(rng_stop) & ";"); end print_sub_not_null; -- Used for non-enumeration/char, null bearing subtype declarations procedure print_sub_null(dom, base_dom : string) is begin domain_io.put_line(domain_package, indent4 & "subtype " & strip(dom) &"_type is " & strip(base_dom) & "_type;"); end print_sub_null; -- Used for non-enumeration/char package _ops instantiation for -- both domains and subtypes of domains procedure print_ops (dom, sql_type : string) is begin domain_io.put_line(domain_package, indent4 & "package " & strip(dom) &"_ops is new "); domain_io.put_line(domain_package, indent4 & indent4 & "sql_" & strip(sql_type) & "_ops(" & strip(dom) & "_type, " & strip(dom) & "_not_null);"); end print_ops; -- Used for enumeration, non-null bearing domain declarations procedure print_enum_not_null(vals, dom : string) is begin domain_io.put_line(domain_package, indent4 & strip(vals)); domain_io.put_line(domain_package, indent4 & "package " & strip(dom) & "_ops is new " ); domain_io.put_line(domain_package, indent4 & indent4 & enum_pk & "(" & strip(dom) & "_not_null" & ");"); end print_enum_not_null; -- Used for enumeration, null bearing domain declarations procedure print_enum_null(dom : string) is begin domain_io.put_line(domain_package, indent4 & "type " & strip(dom) &"_type is new " & strip(dom) & "_ops.sql_enumeration;"); end print_enum_null; -- Used for enumeration, non-null bearing subtype declarations procedure print_subenum_not_null(dom, base_dom, rng_start, rng_stop : string) is begin domain_io.put_line(domain_package, indent4 & "subtype " & strip(dom) & "_not_null is " & strip(base_dom) & "_not_null "); domain_io.put_line(domain_package, indent4 & indent4 & "range " & strip(rng_start) & ".." & strip(rng_stop) & ";"); domain_io.put_line(domain_package, indent4 & "package " & strip(dom)& "_ops is new "); domain_io.put_line(domain_package, indent4 & indent4 & enum_pk & "(" & strip(dom) & "_not_null);"); end print_subenum_not_null; -- Used for enumeration, null bearing subtype declarations procedure print_subenum_null(dom : string) is begin domain_io.put_line(domain_package, indent4 & "type " & strip(dom) & "_type is new " & strip(dom) & "_ops.sql_enumeration;"); end print_subenum_null; -- **************************************************************************** package body generate_domain_package is -- GENERIC INPUTS -- type domain_package_name : package_names; This specific domain package name -- type domains is (<>); List of valid domains for this package. -- record used for collecting the information -- which defines each domain type domain_information is record r_type_name : domains; r_based_on : domains; -- used when a domain is based upon another domain r_class : sql_types; r_intrange_start : integer; r_intrange_stop : integer; r_fltrange_start : float; r_fltrange_stop : float; r_enum_range_start : string (1..max_length) := (others => ' '); r_enum_range_stop : string (1..max_length) := (others => ' '); r_null_bearing : null_indicator; r_domain_defined : boolean := false; -- used to test for already defined domains r_dependent : boolean := false; -- used to test for dependent domains r_enum_values : string(1..max_enum_length) := (others => ' '); -- converted to string in the enum domain generic package end record; -- array types and objects used for stepping through an array of -- domain information and for consitstency checking during execution -- array used for the records of domains information for each domain package type dom_rec_array is array (domains) of domain_information; domain_array : dom_rec_array; -- array used for the sql_types for each domain package type class_array is array (sql_types) of boolean; class_included : class_array := (others => false); -- ************************************************************************* package body generate_int_domain is -- GENERIC INPUTS -- type_name : domains; The name of this domain -- class : sql_types; The type of SQL domain -- null_bearing : null_indicator := null_and_not_null; -- intrange_start : integer := 0; Represents length, range, etc. -- intrange_stop : integer := 0; begin put_line (indent5 & "defining domain " & change_to_lower_case(domains'image(type_name))); if domain_array(type_name).r_domain_defined = true then raise duplicate_domain; else domain_array(type_name).r_type_name := type_name; domain_array(type_name).r_class := class; domain_array(type_name).r_null_bearing := null_bearing; domain_array(type_name).r_intrange_start := intrange_start; domain_array(type_name).r_intrange_stop := intrange_stop; domain_array(type_name).r_domain_defined := true; class_included (class) := true;-- to include the correct with clauses end if; exception when duplicate_domain => put_line (error & change_to_lower_case(domains'image(type_name)) & " in domain package " & change_to_lower_case(package_names'image(domain_package_name)) & multiple_description); error_occured := true; end generate_int_domain; -- ************************************************************************* package body generate_subint_domain is -- GENERIC INPUTS -- type_name : domains; The name of this domain -- based_on : domains; The name of the domain this subtype is based on -- class : sql_types; The type of SQL domain -- null_bearing : null_indicator := null_and_not_null; -- intrange_start : int := 0; Represents length, range, etc. -- intrange_stop : int := 0; begin put_line (indent5 & "defining domain " & change_to_lower_case(domains'image(type_name))); if domain_array(type_name).r_domain_defined = true then raise duplicate_domain; else if domain_array(based_on).r_domain_defined then if domain_array(based_on).r_null_bearing = null_bearing then null; -- OK, this type has been previously defined elsif domain_array(based_on).r_null_bearing = null_and_not_null then null; -- OK, not equal but the parent type has been declared else raise undefined_parent; end if; else raise undefined_based_on; end if; domain_array(type_name).r_type_name := type_name; domain_array(type_name).r_based_on := based_on; domain_array(type_name).r_class := class; domain_array(type_name).r_null_bearing := null_bearing; domain_array(type_name).r_intrange_start := intrange_start; domain_array(type_name).r_intrange_stop := intrange_stop; domain_array(type_name).r_domain_defined := true; domain_array(type_name).r_dependent := true; class_included (class) := true;-- to include the correct with clauses end if; exception when duplicate_domain => put_line (error & change_to_lower_case(domains'image(type_name)) & " in domain package " & change_to_lower_case(package_names'image(domain_package_name)) & multiple_description); error_occured := true; when undefined_based_on => put_line (error & change_to_lower_case(domains'image(based_on)) & " has not been previously defined."); put_line (indent5 & "...cannot derive a new type unless parent domain has been previously defined"); error_occured := true; when undefined_parent => put_line (error & "parent type for " & change_to_lower_case(domains'image(type_name)) & " has not been previously defined."); put_line (indent5 & "...cannot declare a subtype unless parent type has been previously defined"); error_occured := true; end generate_subint_domain; -- ************************************************************************* package body generate_flt_domain is -- GENERIC INPUTS -- type_name : domains; The name of this domain -- class : sql_types; The type of SQL domain -- null_bearing : null_indicator := null_and_not_null; -- fltrange_start : float := 0.0; Represents length, range, etc. -- fltrange_stop : float := 0.0; begin put_line (indent5 & "defining domain " & change_to_lower_case(domains'image(type_name))); if domain_array(type_name).r_domain_defined = true then raise duplicate_domain; else domain_array(type_name).r_type_name := type_name; if class = decimal then -- decimal types are always handled as real types in this implementation domain_array(type_name).r_class := real; class_included (real) := true;-- to include a real with clauses for decimal else domain_array(type_name).r_class := class; class_included (class) := true;-- to include the correct with clauses end if; domain_array(type_name).r_null_bearing := null_bearing; domain_array(type_name).r_fltrange_start := fltrange_start; domain_array(type_name).r_fltrange_stop := fltrange_stop; domain_array(type_name).r_domain_defined := true; end if; exception when duplicate_domain => put_line (error & change_to_lower_case(domains'image(type_name)) & " in domain package " & change_to_lower_case(package_names'image(domain_package_name)) & multiple_description); error_occured := true; end generate_flt_domain; -- ************************************************************************* package body generate_subflt_domain is -- GENERIC INPUTS -- type_name : domains; The name of this domain -- based_on : domains; The name of the domain this subtype is based on -- class : sql_types; The type of SQL domain -- null_bearing : null_indicator := null_and_not_null; -- fltrange_start : float := 0.0; Represents length, range, etc. -- fltrange_stop : float := 0.0; begin put_line (indent5 & "defining domain " & change_to_lower_case(domains'image(type_name))); if domain_array(type_name).r_domain_defined = true then raise duplicate_domain; else if domain_array(based_on).r_domain_defined then if domain_array(based_on).r_null_bearing = null_bearing then null; -- OK, this type has been previously defined elsif domain_array(based_on).r_null_bearing = null_and_not_null then null; -- OK, not equal but the parent type has been declared else raise undefined_parent; end if; else raise undefined_based_on; end if; domain_array(type_name).r_type_name := type_name; domain_array(type_name).r_based_on := based_on; if class = decimal then -- decimal types are always handled as real types in this implementation domain_array(type_name).r_class := real; class_included (real) := true;-- to include a real with clauses for decimal else domain_array(type_name).r_class := class; class_included (class) := true;-- to include the correct with clauses end if; domain_array(type_name).r_null_bearing := null_bearing; domain_array(type_name).r_fltrange_start := fltrange_start; domain_array(type_name).r_fltrange_stop := fltrange_stop; domain_array(type_name).r_domain_defined := true; domain_array(type_name).r_dependent := true; end if; exception when duplicate_domain => put_line (error & change_to_lower_case(domains'image(type_name)) & " in domain package " & change_to_lower_case(package_names'image(domain_package_name)) & multiple_description); error_occured := true; when undefined_based_on => put_line (error & change_to_lower_case(domains'image(based_on)) & " has not been previously defined."); put_line (indent5 & "...cannot derive a new type unless parent domain has been previously defined"); error_occured := true; when undefined_parent => put_line (error & "parent type for " & change_to_lower_case(domains'image(type_name)) & " has not been previously defined."); put_line (indent5 & "...cannot declare a subtype unless parent type has been previously defined"); error_occured := true; end generate_subflt_domain; -- ************************************************************************* package body generate_enum_domain is -- GENERIC INPUTS -- enum_values is (<>); List of enumerated values for this domain -- type_name : domains; The name of this domain -- class : sql_types; The type of SQL domain -- null_bearing : null_indicator := null_and_not_null; function enum_values_enum is new enumeration_image(enum_values); function longest_enum_value is new longest_enum (enum_values); begin put_line (indent5 & "defining domain " & change_to_lower_case(domains'image(type_name))); if domain_array(type_name).r_domain_defined = true then raise duplicate_domain; else domain_array(type_name).r_type_name := type_name; -- create a string of the enumerated values declare temp_length : integer := (enum_values_enum(domains'image(type_name) & "_not_null")'length); begin domain_array(type_name).r_enum_values(1..temp_length):= change_to_lower_case(enum_values_enum(domains'image(type_name) & "_not_null")); end; domain_array(type_name).r_class := class; domain_array(type_name).r_null_bearing := null_bearing; domain_array(type_name).r_domain_defined := true; end if; class_included (class) := true;-- to include the correct with clauses the_longest_value := longest_enum_value; exception when duplicate_domain => put_line (error & change_to_lower_case(domains'image(type_name)) & " in domain package " & change_to_lower_case(package_names'image(domain_package_name)) & multiple_description); error_occured := true; end generate_enum_domain; -- ************************************************************************* package body generate_subenum_domain is -- GENERIC INPUTS -- type_name : domains; The name of this domain -- based_on : domains; The name of the domain that this subtype is based on -- class : sql_types; The type of SQL domain -- null_bearing : null_indicator := null_and_not_null; -- range_start : string; Represents portion of base type's enumerated values -- range_stop : string; begin put_line (indent5 & "defining domain " & change_to_lower_case(domains'image(type_name))); if domain_array(type_name).r_domain_defined = true then raise duplicate_domain; else domain_array(type_name).r_type_name := type_name; domain_array(type_name).r_based_on := based_on; domain_array(type_name).r_class := class; domain_array(type_name).r_null_bearing := null_bearing; move (strip(enum_range_start), domain_array(type_name).r_enum_range_start); move (strip(enum_range_stop), domain_array(type_name).r_enum_range_stop); domain_array(type_name).r_domain_defined := true; domain_array(type_name).r_dependent := true; end if; class_included (class) := true;-- to include the correct with clauses exception when duplicate_domain => put_line (error & change_to_lower_case(domains'image(type_name)) & " in domain package " & change_to_lower_case(package_names'image(domain_package_name)) & multiple_description); error_occured := true; end generate_subenum_domain; -- ************************************************************************* procedure start_generation is package float_io is new text_io.float_io (float); dom_image : string (1..max_length) := (others => ' '); base_dom_image : string (1..max_length) := (others => ' '); sql_type_image : string (1..max_length) := (others => ' '); range_start_image : string (1..max_length) := (others => ' '); range_stop_image : string (1..max_length) := (others => ' '); vals_image : string (1..max_length) := (others => ' '); begin -- first check to see if errors occured during processing..if none, then -- begin creating the domain package if not error_occured then -- begin generating the beginning of the domain package by including -- with and use clauses for appropriate SAME support packages for i in sql_types loop if class_included(i) then domain_io.put_line(domain_package,"with sql_" & change_to_lower_case(sql_types'image(i)) & "_pkg;"); if i /= enumeration then -- can't use a generic package domain_io.put_line(domain_package,"use sql_" & change_to_lower_case(sql_types'image(i)) & "_pkg;"); end if; end if; end loop; -- put the package names for the domain file domain_io.put_line(domain_package, "package " & change_to_lower_case(package_names'image (domain_package_name)) & " is"); domain_io.put_line(domain_package, " "); -- then check to see that all domains in each package were described in detail -- if they were not, raise undefined domain exception for i in domains loop if domain_array(i).r_domain_defined then -- first get both the sql type and the domain name and change into -- strings for output use move(strip(change_to_lower_case(domains'image(domain_array(i).r_type_name))), dom_image); move(strip(change_to_lower_case(sql_types'image(domain_array(i).r_class))), sql_type_image); -- then add this name to both the collection of all of the valid -- domain names, all valid corresponding concrete types and all valid -- ops packages for this domain package. All three temporary lists -- will be later added to the final dom_list, final con_list or final -- ops_list for inclusion in Base_Specific_Domains. Note that the ops -- package is always added for an enumeration type. case domain_array(i).r_null_bearing is when contains_null => if i = domains'first then move(strip(dom_image) & "_type", temp_dom_list); if domain_array(i).r_class = char then move(strip(dom_image) & "_type_" & strip(sql_type_image) & "_" & strip(integer'image(domain_array(i).r_intrange_stop)), temp_con_list); else move(strip(dom_image) & "_type_" & strip(sql_type_image), temp_con_list); end if; else move(strip(temp_dom_list) & ", " & strip(dom_image) & "_type", temp_dom_list); if domain_array(i).r_class = char then move(strip(temp_con_list) & ", " & strip(dom_image) & "_type_" & strip(sql_type_image) & "_" & strip(integer'image(domain_array(i).r_intrange_stop)), temp_con_list); else move(strip(temp_con_list) & ", " & strip(dom_image) & "_type_" & strip(sql_type_image), temp_con_list); end if; end if; when not_null => if i = domains'first then move(strip(dom_image) & "_not_null", temp_dom_list); if domain_array(i).r_class = char then move(strip(dom_image) & "_not_null_" & strip(sql_type_image) & "_" & strip(integer'image(domain_array(i).r_intrange_stop)), temp_con_list); else move(strip(dom_image) & "_not_null_" & strip(sql_type_image), temp_con_list); end if; else move(strip(temp_dom_list) & ", " & strip(dom_image) & "_not_null", temp_dom_list); if domain_array(i).r_class = char then move(strip(temp_con_list) & ", " & strip(dom_image) & "_not_null_" & strip(sql_type_image) & "_" & strip(integer'image(domain_array(i).r_intrange_stop)), temp_con_list); else move(strip(temp_con_list) & ", " & strip(dom_image) & "_not_null_" & strip(sql_type_image), temp_con_list); end if; end if; when others => if i = domains'first then move(strip(dom_image) & "_not_null", temp_dom_list); move(strip(temp_dom_list) & ", " & strip(dom_image) & "_type", temp_dom_list); if domain_array(i).r_class = char then move(strip(dom_image) & "_not_null_" & strip(sql_type_image) & "_" & strip(integer'image(domain_array(i).r_intrange_stop)),temp_con_list); move(strip(temp_con_list) & ", " & strip(dom_image) & "_type_" & strip(sql_type_image) & "_" & strip(integer'image(domain_array(i).r_intrange_stop)), temp_con_list); else move(strip(dom_image) & "_not_null_" & strip(sql_type_image), temp_con_list); move(strip(temp_con_list) & ", " & strip(dom_image) & "_type_" & strip(sql_type_image), temp_con_list); end if; move(strip(dom_image) & "_ops", temp_ops_list); first_ops := false; else move(strip(temp_dom_list) & ", " & strip(dom_image) & "_not_null", temp_dom_list); move(strip(temp_dom_list) & ", " & strip(dom_image) & "_type", temp_dom_list); if domain_array(i).r_class = char then move(strip(temp_con_list) & ", " & strip(dom_image) & "_not_null_" & strip(sql_type_image) & "_" & strip(integer'image(domain_array(i).r_intrange_stop)), temp_con_list); move(strip(temp_con_list) & ", " & strip(dom_image) & "_type_" & strip(sql_type_image) & "_" & strip(integer'image(domain_array(i).r_intrange_stop)), temp_con_list); else move(strip(temp_con_list) & ", " & strip(dom_image) & "_not_null_" & strip(sql_type_image), temp_con_list); move(strip(temp_con_list) & ", " & strip(dom_image) & "_type_" & strip(sql_type_image), temp_con_list); end if; if first_ops then move(strip(dom_image) & "_ops", temp_ops_list); first_ops := false; else move(strip(temp_ops_list) & ", " & strip(dom_image) & "_ops",temp_ops_list); end if; end if; end case; -- then step through the array of domain records to acquire information -- about each domain in order to generate the appropriate -- domain declarations -- first check to see if this is a dependent domain and if so, generate a -- subtype package appropriate to the sql type if domain_array(i).r_dependent = true then move(strip(change_to_lower_case(domains'image(domain_array(i).r_based_on))), base_dom_image); case domain_array(i).r_class is when enumeration => move(strip(change_to_lower_case(domain_array(i).r_enum_range_start)), range_start_image); move(strip(change_to_lower_case(domain_array(i).r_enum_range_stop)), range_stop_image); -- see if this subtype is non-null bearing or not if domain_array(i).r_null_bearing = not_null then print_subenum_not_null(dom_image, base_dom_image, range_start_image, range_stop_image); else -- it is either null bearing or both and in either case -- handled the same way print_subenum_not_null(dom_image, base_dom_image, range_start_image, range_stop_image); print_subenum_null(dom_image); end if; when char => raise char_subtype; when others => -- see if this subtype is null bearing or not if domain_array(i).r_null_bearing = contains_null then print_sub_null(dom_image, base_dom_image); else -- see if it is non-null bearing or can have both and -- assign range values case domain_array(i).r_class is when int|smallint => move(strip(integer'image(domain_array(i).r_intrange_start)), range_start_image); move(strip(integer'image(domain_array(i).r_intrange_stop)), range_stop_image); when others => -- convert the float range values into a strings float_io.put (range_start_image, domain_array(i).r_fltrange_start, 5, 0); float_io.put (range_stop_image, domain_array(i).r_fltrange_stop, 5, 0); end case; if domain_array(i).r_null_bearing = not_null then print_sub_not_null(dom_image, base_dom_image, range_start_image, range_stop_image); else -- assume that is has both print_sub_not_null(dom_image, base_dom_image, range_start_image, range_stop_image); print_sub_null(dom_image, base_dom_image); print_ops(dom_image, sql_type_image); end if; end if; end case; domain_io.put_line(domain_package, " "); base_dom_image := (others => ' '); else -- the domain is not dependent and generate a domain package -- appropriate to the sql type case domain_array(i).r_class is when enumeration => move(strip(domain_array(i).r_enum_values), vals_image); -- see if this domain is non-null bearing or not if domain_array(i).r_null_bearing = not_null then print_enum_not_null(vals_image, dom_image); else -- it is either null bearing or both and in either case -- handled the same way print_enum_not_null(vals_image, dom_image); print_enum_null(dom_image); end if; vals_image := (others => ' '); when char => -- see if this domain is null bearing or not if domain_array(i).r_null_bearing = contains_null then print_char_null_only(dom_image); else -- see if it is non_null bearing or can have both and assign range values move(strip(integer'image(domain_array(i).r_intrange_start)), range_start_image); move(strip(integer'image(domain_array(i).r_intrange_stop)), range_stop_image); if domain_array(i).r_null_bearing = not_null then print_char_not_null(dom_image, range_start_image, range_stop_image); else -- assume that is has both print_char_not_null(dom_image, range_start_image, range_stop_image); print_char_null_ops(dom_image); end if; end if; when others => -- see if this domain is null bearing or not if domain_array(i).r_null_bearing = contains_null then print_regular_null(dom_image, sql_type_image); else -- see if it is non-null bearing or can have both and assign range values case domain_array(i).r_class is when int|smallint => move(strip(integer'image(domain_array(i).r_intrange_start)), range_start_image); move(strip(integer'image(domain_array(i).r_intrange_stop)), range_stop_image); when others => -- convert the float range values into a strings float_io.put (range_start_image, domain_array(i).r_fltrange_start, 5, 0); float_io.put (range_stop_image, domain_array(i).r_fltrange_stop, 5, 0); end case; if domain_array(i).r_null_bearing = not_null then print_regular_not_null(dom_image, sql_type_image, range_start_image, range_stop_image); else -- assume that is has both print_regular_not_null(dom_image, sql_type_image, range_start_image, range_stop_image); print_regular_null(dom_image, sql_type_image); print_ops(dom_image, sql_type_image); end if; end if; end case; domain_io.put_line(domain_package, " "); end if; -- clear out strings for next loop in domains dom_image := (others => ' '); sql_type_image := (others => ' '); range_start_image := (others => ' '); range_stop_image := (others => ' '); else raise undefined_domain; end if; end loop; -- end the domain file domain_io.put_line(domain_package, "end " & change_to_lower_case(package_names'image(domain_package_name)) & ";"); close(domain_package); -- add to both the list of total valid domains and the list of corresponding -- concrete types from the temporary lists: temp_dom_list and temp_con_list if first_list then move(strip(temp_dom_list), dom_list); move(strip(temp_con_list), con_list); first_list := false; else move(strip(dom_list) & ", " & strip(temp_dom_list), dom_list); move(strip(con_list) & ", " & strip(temp_con_list), con_list); end if; if not first_ops then if first_ops_list then move(strip(temp_ops_list), ops_list); first_ops_list := false; else move(strip(ops_list) & ", " & strip(temp_ops_list), ops_list); end if; end if; temp_dom_list := (others => ' '); temp_con_list := (others => ' '); temp_ops_list := (others => ' '); first_ops := true; else -- processing errors were present..just delete the empty files delete(domain_package); end if; exception when char_subtype => put_line (error & "Subtype based on domain of type char in domain package " & change_to_lower_case(package_names'image(domain_package_name)) & " are not allowed"); delete(domain_package); when undefined_domain => text_io.put_line (error & "One or more domains defined in domain package " & package_names'image(domain_package_name) & missing_description); delete(domain_package); end start_generation; begin create (domain_package, name => package_names'image(domain_package_name) & spec_extension); put_line (" "); put_line (" "); put_line ("creating domain package " & change_to_lower_case(package_names'image(domain_package_name))); if package_created (domain_package_name) = true then raise duplicate_package; else package_created (domain_package_name) := true; end if; exception when duplicate_package => put_line (error & "Domain package " & change_to_lower_case(package_names'image(domain_package_name)) & multiple_description); error_occured := true; end generate_domain_package; -- *************************************************************************** procedure generate_base_specific is function package_names_enum is new enumeration_image(package_names); pack_list : string (1..max_length) := (others => ' '); begin -- check to see that all domain packages were created -- if not, then raise an uncreated package exception for i in package_names loop if package_created (i) then null;--create list of package names else raise uncreated_package; end if; end loop; -- then check to see if any other errors occurred during processing -- if not, begin generating the base_specific_domains package by including the -- with and use clauses and package declaration if not error_occured then put_line (" "); put_line (" "); put_line ("creating the base_specific_domains package"); create (base_specific_domains, name => "base_specific_domains" & spec_extension); specific_io.put_line(base_specific_domains, with_gen); specific_io.put_line(base_specific_domains, use_gen); specific_io.put_line(base_specific_domains, "package " & base_spec &" is"); specific_io.put_line(base_specific_domains, " "); -- declare all domain types and corresponding concrete types -- to be included in base_specifc_domains and add the domain -- "null_domain_type" to the lists of domains move(strip(dom_list) & ", null_domain_type", dom_list); specific_io.put_line(base_specific_domains, indent2 & bs_dom_types & "(" & strip(dom_list) & ");"); specific_io.put_line(base_specific_domains, " "); specific_io.put_line(base_specific_domains, indent2 & bs_con_types & "(" & strip(con_list) & ");"); specific_io.put_line(base_specific_domains, " "); -- create a string of all of the enumerated package names to declare -- in Base_Specific_Domains file declare temp_length : integer := (package_names_enum(bs_dom_names)'length); begin pack_list(1..temp_length):= change_to_lower_case(package_names_enum(bs_dom_names)); end; specific_io.put_line(base_specific_domains, indent2 & strip(pack_list)); specific_io.put_line(base_specific_domains, " "); -- declare all valid ops packages. If no ops packages were needed then -- do not output this line. if not first_ops_list then specific_io.put_line(base_specific_domains, indent2 & bs_ops_types & "(" & strip(ops_list) & ");"); else specific_io.put_line(base_specific_domains, indent2 & bs_ops_types & "(there_are_no_packages);"); end if; specific_io.put_line(base_specific_domains, " "); -- put the longest enum value declaration in to base_specific_domains specific_io.put_line(base_specific_domains, indent2 & "longest_enum_value : constant integer := " & integer'image(the_longest_value) & ";"); specific_io.put_line(base_specific_domains, " "); -- end the base_specific package specific_io.put_line(base_specific_domains, indent2 & dom_array); specific_io.put_line(base_specific_domains, " "); specific_io.put_line(base_specific_domains, "end " & base_spec & ";"); close(base_specific_domains); end if; exception when uncreated_package => text_io.put_line (error & "One or more domain packages " & missing_description); end generate_base_specific; -- **************************************************************************** begin null; end abstract_domain_generator;