home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / ada_funcs.tcl < prev    next >
Text File  |  1997-06-02  |  67KB  |  2,249 lines
  1. ###########################################################################
  2. ##
  3. ##  Copyright (c) 1996 by Cadre Technologies Inc.
  4. ##                          and Scientific Toolworks Inc.
  5. ##
  6. ##  This software is furnished under a license and may be used only in
  7. ##  accordance with the terms of such license and with the inclusion of
  8. ##  the above copyright notice. This software or any other copies thereof
  9. ##  may not be provided or otherwise made available to any other person.
  10. ##  No title to and ownership of the software is hereby transferred.
  11. ##
  12. ##  The information in this software is subject to change without notice
  13. ##  and should not be construed as a commitment by Cadre Technologies Inc.
  14. ##  or Scientific Toolworks Inc.
  15. ##
  16. ###########################################################################
  17.  
  18. proc oopl_model::generate {model} {
  19.     global root_classes root_class g_op_list g_assoc_list
  20.     global g_local_op_count g_local_op_list link_class_added
  21.         ## HM - added g_local_pub_assoc_access_count and g_local_priv_assoc_access_count
  22.         ## HM - added g_local_pub_attr_access_count and g_local_pub_attr_access_count
  23.         ## HM - added g_local_assoc_count to count association components
  24.     ## HM - added g_local_inh_op_count to count inherited operations
  25.         global g_local_assoc_count
  26.         global g_local_pub_assoc_access_count
  27.         global g_local_priv_assoc_access_count
  28.         global g_local_pub_attr_access_count
  29.         global g_local_priv_attr_access_count
  30.     global g_local_inh_op_count
  31.  
  32.     check_unique_file_names $model
  33.  
  34.     echo "Generating Ada 83 code"
  35.     set g_assoc_list ""
  36.     set root_classes ""
  37.     set pers_class_exists 0
  38.     set got_a_class 0
  39.  
  40.     create_ada_sections $ada_hdr_sections
  41.     init_sys_sections $sysfile_name
  42.  
  43.     #HM moved class2tgtfiles outside of if and call is_file_generated with h_filename
  44.      #  instead of sysfile_name
  45.     class2tgtfiles $sysfile_name c_filename h_filename
  46.     if {[is_file_regenerated $h_filename]} {
  47.          if [catch {prepare_regeneration $sysfile_name 1} result] {
  48.         # something went wrong, find out what
  49.         switch $errorCode {
  50.             ERR_REGEN {
  51.                 puts stderr $result
  52.                 return
  53.             }
  54.             default {error $result $errorInfo $errorCode}
  55.             }
  56.        }
  57.  
  58.     }
  59.  
  60.     foreach class [get_classes $model] {
  61.         global link_incl_list
  62.         set link_incl_list ""
  63.         set got_a_class 1
  64.         set skip [skip_class $class 0]
  65.         if {$skip == 2} {set pers_class_exists 1}
  66.         if {$skip != 0} {continue}
  67.  
  68.         set class_name [get_name $class]
  69.         set g_op_list($class_name) ""
  70.         if {[get_super_classes $class] == "" } {
  71.             echo "subclasses = [get_sub_classes $class]"
  72.             if {[get_sub_classes $class] != ""} {
  73.                 append root_classes "$class "
  74.             }
  75.         }
  76.         foreach super [get_super_classes $class] {
  77.             set super_name [get_super_name $super]
  78.         }
  79.         gen_assoc_list $class
  80.  
  81.         if {[get_obj_type $class] == "class_typedef" ||
  82.             [get_obj_type $class] == "class_enum"} {
  83.             generate $class
  84.         }
  85.     }
  86.  
  87.  
  88.     write_sys_sections $sysfile_name $ada_hdr_sections
  89.  
  90.     if {$pers_class_exists == 1} {
  91.         puts stderr "At least one class in the model is persistent.  Ada code cannot be generated."
  92.         return
  93.     }
  94.  
  95.     echo "association list:  $g_assoc_list"
  96.  
  97.     echo "Root Classes:"
  98.     foreach root_class $root_classes {
  99.         echo "   [get_name $root_class]"
  100.         set g_class_list([get_name $root_class]) "$root_class "
  101.         gen_op_lists $root_class
  102.     }
  103.  
  104.     if {$got_a_class == 1} {
  105.     foreach i [array names g_op_list] {
  106.         echo "$i:"
  107.         foreach j $g_op_list($i) {
  108.             set cname [get_name [split_op_list_entry $j class]]
  109.             set inh_access [split_op_list_entry $j inh]
  110.             echo "  $cname ($inh_access)"
  111.         }
  112.     }}
  113.  
  114.     foreach class [get_classes $model] {
  115.         set g_local_assoc_count 0
  116.         set g_local_priv_assoc_access_count 0
  117.         set g_local_pub_assoc_access_count 0
  118.         set g_local_priv_attr_access_count 0
  119.         set g_local_pub_attr_access_count 0
  120.         set g_local_inh_op_count 0
  121.         set g_local_op_count 0
  122.  
  123.         if {[skip_class $class 1] == 1 || 
  124.             [get_obj_type $class] == "class_typedef" ||
  125.             [get_obj_type $class] == "class_enum"} {
  126.             continue
  127.         }
  128.         class2tgtfiles [get_name $class] nts nth
  129.         global skip_file
  130.         global gen_file
  131.         global import_new
  132.         if [info exists gen_file($nth)] {
  133.             set gen_file($nts) 1
  134.         }
  135.         if {[get_class_source $class] != ""} {
  136.             process_external_class_source $class
  137.             continue
  138.         }
  139.         if {( $import_new &&
  140.               ([is_special_class $class] || 
  141.                [info exists skip_file($nts)]) &&
  142.               [info exists skip_file($nth)]) ||
  143.             ( !$import_new &&
  144.               ![info exists gen_file($nts)] &&
  145.               ![info exists gen_file($nth)])} {
  146.             continue
  147.         }
  148.  
  149.         echo "   Class Type = [get_obj_type $class]"
  150.         set link_class_added 0
  151.  
  152.         generate $class
  153.  
  154.         for {set x 0} {$x < $g_local_op_count} {incr x} {
  155.             unset g_local_op_list($x)
  156.         }
  157.     }
  158.  
  159.     if {$g_poly == "On"} {
  160.     global g_generate_separates
  161.     set g_generate_separates "Off"
  162.     global g_func_list
  163.     global g_poly_op_list g_poly_op_class_list g_poly_op_param_list g_poly_op_count
  164.  
  165.     foreach root_class $root_classes {
  166.         set g_poly_op_count 0
  167.         class2polyfiles $root_class src_file h_file
  168.         echo "h_file = $h_file"
  169.         global gen_file
  170.  
  171.         create_ada_sections [concat $ada_hdr_sections $ada_src_sections]
  172.         init_poly_sections $root_class
  173.  
  174.         echo "   [get_name $root_class]"
  175.         set g_func_list ""
  176.         set r_name [get_name $root_class]
  177.         global g_parent_list
  178.         set g_parent_list "$r_name "
  179.         global link_incl_list
  180.         set link_incl_list ""
  181.         class::gen_poly $root_class
  182.         gen_poly_body $r_name
  183.         exit_poly_sections $root_class
  184.         write_poly_sections $root_class $ada_hdr_sections $ada_src_sections
  185.     }
  186.    }
  187. }
  188.  
  189. proc skip_class {class flag} {
  190.     if {[is_db_class $class] == 1} {
  191.         puts stderr "ERROR: Class [get_name $class] is persistent."
  192.         return 2
  193.     }
  194.     if [is_external $class] {
  195.         return 1
  196.     }
  197.     if {[get_name $class] == ""} {
  198.         if {$flag == 1} {puts stderr "Class without name skipped"}
  199.         return 1
  200.     }
  201.     return 0
  202. }
  203.  
  204. # Check uniqueness of filenames
  205. #
  206. proc check_unique_file_names {model} {
  207.     foreach class [get_classes $model] {
  208.         set cl_name [get_name $class]
  209.         set file_name [class2file $cl_name]
  210.         if [is_external $class] {
  211.             continue
  212.         }
  213.         if [info exists names($file_name)] {
  214.             error "Classes '$cl_name' and '$names($file_name)' map to the same file name" "" ERR_UNIQUE_FILENAME
  215.         }
  216.         set names($file_name) $cl_name
  217.     }
  218. }
  219.  
  220. proc class::generate {class} {
  221.     #HM added g_component_count to know when to add "null;" to record declarations
  222.         global g_component_count
  223.  
  224.         set g_component_count 0
  225.     create_ada_sections [concat $ada_hdr_sections $ada_src_sections]
  226.     init_ada_sections [get_name $class] [get_data_section $class] [get_class_vis $class]
  227.     if [catch {prepare_regeneration [get_name $class] 0} result] {
  228.         # something went wrong, find out what
  229.         switch $errorCode {
  230.             ERR_REGEN {
  231.                 puts stderr $result
  232.                 return
  233.             }
  234.             default {error $result $errorInfo $errorCode}
  235.         }
  236.         class2tgtfiles [get_name $class] src_file h_file
  237.         global gen_file
  238.         catch {unset gen_file($src_file)}
  239.         if {! [info exists gen_file($h_file)]} {
  240.             return
  241.         }
  242.     }
  243.     set hsect $ada_sections(h_hdr_sect)
  244.     set csect $ada_sections(c_hdr_sect)
  245.     set class_name [get_name $class]
  246.     section append $hsect "-- Specification file for ${class_name}\n\n"
  247.     section append $csect "-- Body file for ${class_name}\n\n"
  248.     puts stdout "Generating for class '${class_name}'"
  249.     gen_hdr_incs $class
  250.     class::gen_description $class $ada_sections(h_class_nm_sect)
  251.     set is_db 0
  252.     add_src_inc $class
  253.  
  254.     set class_visibility [gen_class_decl $class]
  255.  
  256.     # This generates attributes & operation definitions...
  257.     #
  258.     foreach feat [get_features $class] {
  259.         set feat_type [get_obj_type $feat]
  260.         echo "   feature type = $feat_type"
  261.         set inh_mode 0
  262.         if {$feat_type == "operation"} {
  263.             generate $feat $class $class_name $inh_mode
  264.         } else {
  265.             generate $feat $class
  266.         }
  267.     }
  268.  
  269.     gen_inherited_ops $class
  270.     gen_delayed_code
  271.     gen_end_protector $class
  272.     append_obsolete_code $class
  273.     exit_ada_sections $class
  274.     write_ada_sections $class $ada_hdr_sections $ada_src_sections
  275. }
  276.  
  277. proc class::gen_description {class sect} {
  278.     set ftext [$class getFreeText]
  279.     if {$ftext != ""} {
  280.         section append $sect "\n"
  281.         string_to_oopl_comment $sect $ftext
  282.         section append $sect "\n"
  283.     }
  284. }
  285.  
  286.  
  287. proc class_enum::generate {class} {
  288.     set sect $ada_sections(h_pub_data_sect)
  289.     set enum_name [get_name $class]
  290.     section append $sect "type $enum_name is ("
  291.     set first 1
  292.     foreach attrib [get_features $class] {
  293.         if {$first == 0} {section append $sect ","}
  294.         section append $sect "[get_name $attrib]"
  295.         set first 0
  296.     }
  297.     section append $sect ");\n\n"
  298.  
  299.     #puts stderr "ERROR: Enum classes are not supported for Ada"
  300.  
  301.     return
  302. }
  303.  
  304. proc class_typedef::generate {class} {
  305.     set subtype_name [get_name $class]
  306.     set attrib [lindex [get_features $class] 0]
  307.     set type_name [get_name [get_type $attrib]]
  308.     set subtype_text [get_subtype_text $class]
  309.     section append $ada_sections(h_pub_data_sect) \
  310.        "subtype $subtype_name is ${type_name} ${subtype_text};\n\n"
  311. }
  312.  
  313. proc class_generic_typedef::generate {class} {
  314.     if {[get_name $class] == ""} {
  315.         puts stderr "Class without name skipped"
  316.         return
  317.     }
  318.     class::generate $class
  319.     return
  320. }
  321.  
  322. proc class_typedef::gen_class_decl {class} {
  323.     class::gen_class_decl $class
  324. }
  325.  
  326. proc class_generic_typedef::gen_class_decl {class} {
  327.     class::gen_class_decl $class
  328. }
  329.  
  330. proc gen_end_protector {class} {
  331.     set class_name [get_name $class]
  332.     set protector [protector_name $class_name]
  333.     section append $ada_sections(h_trailer_sect) \
  334.         "end $class_name;\n"
  335. }
  336.  
  337.  
  338. proc class::gen_class_decl {class} {
  339.     set class_name [get_name $class]
  340.     set h_sect $ada_sections(h_class_nm_sect)
  341.     set c_sect $ada_sections(c_class_nm_sect)
  342.  
  343.     set class_name [get_name $class]
  344.  
  345.     set class_visibility [get_class_vis $class]
  346.     echo "class name = $class_name ($class_visibility)"
  347.  
  348.     section append $h_sect "package $class_name is \n"
  349.     section append $c_sect "package body $class_name is \n"
  350.  
  351.     set h_sect $ada_sections(h_pub_data_sect)
  352.     set c_sect $ada_sections(c_opaque_sect)
  353.  
  354.     case $class_visibility in {
  355.        {Private} {
  356.         section append $h_sect "\ntype $g_record_name is private;\n"
  357.        }
  358.        {Limited} {
  359.         section append $h_sect "\ntype $g_record_name is limited private;\n"
  360.        }
  361.        {Opaque} {
  362.         set o_sect $ada_sections(h_priv_data_sect)
  363.         section append $h_sect "type $g_record_name is limited private;\n"
  364.         section append $h_sect "type $g_handle_name is access $g_record_name;\n"
  365.         section append $o_sect "type $o_record_name;\n"
  366.         section append $o_sect "type $g_record_name is access $o_record_name;\n"
  367.         section append $c_sect "type $o_record_name is record\n"
  368.         section set_indent $c_sect +
  369.        }
  370.     }
  371.     return $class_visibility
  372. }
  373.  
  374.  
  375. proc gen_inherited_ops {class} {
  376.     global inh_operation_list inh_op_table inh_op_type_list operation_count
  377.     global g_op_list_type g_inh_op_count link_incl_list
  378.  
  379.     set class_name [get_name $class]
  380.     set operation_count -1
  381.     set g_inh_op_count 0
  382.     set link_incl_list ""
  383.     foreach super [get_super_classes $class] {
  384.         generate $super $class
  385.     }
  386.     for {set x 0} {$x <= $operation_count} {incr x} {
  387.         set feat_name [lrange $inh_operation_list($x) 0 0]
  388.  
  389.         if {$g_op_list_type($x) == 0} {
  390.             set f_sect $ada_sections(c_access_func_sect)
  391.             if {$f_sect != ""} {section append $f_sect "\n"}
  392.         } else {
  393.             if {$g_op_list_type($x) == 1} {
  394.                 set f_sect $ada_sections(c_impl_sect)
  395.             }
  396.         } 
  397.         set prefix ""
  398.         if {[section get_line_nr $g_operation_list2($x)] > 2} {
  399.             set prefix "-- "
  400.         }
  401.         section set_indent $g_operation_list($x) + 1 "    ${prefix}"
  402.  
  403.         section append_section $g_operation_list($x) $g_operation_list2($x)
  404.         section append_section $f_sect $g_operation_list($x)
  405.            section append $f_sect "end $feat_name;\n"
  406.  
  407.         section dealloc $g_operation_list($x)
  408.         section dealloc $g_operation_list2($x)
  409.     }
  410. }
  411.     
  412.  
  413. proc link_class::generate {class} {
  414. #    puts stdout "Generating for link class '[get_name $class]'"
  415.     if {[get_name $class] == ""} {
  416.         puts stderr "Link class without name skipped"
  417.         return
  418.     }
  419.     class::generate $class
  420. }
  421.  
  422. proc link_class::gen_class_decl {class} {
  423.     class::gen_class_decl $class
  424. }
  425.  
  426.  
  427. proc append_to_op_list {inh_op_sect flag} {
  428.     global operation_count
  429.  
  430.     set ok_to_append 1
  431.     for {set x 0} {$x < $operation_count} {incr x} {
  432.         if {[section get_contents $g_operation_list($x)] == \
  433.             [section get_contents $g_operation_list($operation_count)]} {
  434.             if {[section get_contents $g_operation_list2($x)] != \
  435.                [section get_contents $g_operation_list2($operation_count)]} {
  436.                 section append_section $g_operation_list2($x) \
  437.                     $g_operation_list2($operation_count)
  438.             }
  439.             set ok_to_append 0
  440.             section dealloc $g_operation_list($operation_count) 
  441.             section dealloc $g_operation_list2($operation_count)
  442.             incr operation_count -1
  443.         }
  444.     }
  445.     if {$ok_to_append == 1} {
  446.         global g_op_list_type
  447.         if {$flag == 1} {
  448.             set g_op_list_type($operation_count) 1
  449.             section append_section $inh_op_sect $tmp_h_sect
  450.         } else {
  451.             set g_op_list_type($operation_count) 0
  452.         }
  453.     }
  454. }
  455.  
  456.  
  457. proc inher_group::generate {group class} {
  458.     global g_op_list
  459.     global tmp_h_sect
  460.     global INHERCOMPCMMT
  461.  
  462.     set class_name [get_name $class]
  463.     set i_sect $ada_sections(h_incl_sect)
  464.     set sect $ada_sections(h_class_nm_sect)
  465.     set super_name [get_super_name $group]
  466.     add_hdr_inc [get_super_class $group]   ;# includes class' include file
  467.     section append $i_sect "with $super_name;\n"
  468.  
  469.     set sect2 [get_data_section $class]
  470.  
  471.     if {[get_class_vis $class] == "Public"} {
  472.         set inh_op_sect $ada_sections(h_pub_func_sect)
  473.     } else {
  474.         set inh_op_sect $ada_sections(h_priv_func_sect)
  475.     }
  476.  
  477.     #HM added comment to signal inheritance component
  478.     section append $sect2 $INHERCOMPCMMT
  479.     section append $sect2 "\n"
  480.  
  481.     section append $sect2 "${super_name}${g_inh_ext} : ${super_name}.$g_record_name;\n"
  482.         incr_component_count
  483.  
  484.     set inh_mode 1
  485.     set super_inh_access [get_inher_access $group]
  486.     if {$super_inh_access == ""} {set inh_access "Public"}
  487.     set current_op_list "[get_super_class $group]:$super_inh_access "
  488.     append current_op_list $g_op_list($super_name)
  489.     foreach entry $current_op_list {
  490.         set inh_class [split_op_list_entry $entry class]
  491.         set inh_access [split_op_list_entry $entry inh]
  492.  
  493.         echo "inh_access = $inh_access for [get_name $inh_class] of $class_name"
  494.         if {$super_inh_access == "Private"  || $inh_access == "Private"} {continue}
  495.  
  496.         foreach feat [get_features $inh_class] {
  497.             set inh_op_sect [get_func_section $feat]
  498.  
  499.             if {$inh_op_sect != $ada_sections(h_pub_func_sect)} {continue}
  500.  
  501.             set feat_type [get_obj_type $feat]
  502.             set inh_name [get_name [get_super_class $group]]
  503.  
  504.             if {$feat_type == "constructor"} {continue}
  505.  
  506.             echo "   Inherited feature: [get_name $feat] ($feat_type)"
  507.  
  508.             if {$feat_type == "operation"} {
  509.                 if {[get_the_class_feature $feat] == 1} {continue}
  510.                 if {[generate $feat $inh_class $inh_name $inh_mode] == -1} {continue}
  511.                 append_to_op_list $inh_op_sect 1
  512.                 set tmp_h_sect [section create]
  513.             } else {
  514.                    set type [get_${feat_type}_type_name $feat] 
  515.                    set result [gen_access_hdr $feat $type 1]
  516.                    echo "RESULT = $result"
  517.                     set name [get_full_feat_name $feat]
  518.  
  519.                    if {[get_attrib_hdr_sect $feat r] == $ada_sections(h_pub_access_sect)} {
  520.                        if {$result == 1 || $result == 3} {
  521.  
  522.                            gen_access_body "get" $feat $class $inh_name $type 1 \
  523.                             "Get_${name} (Self.${inh_name}${g_inh_ext});\n"
  524.                        }
  525.                    }
  526.                     append_to_op_list $inh_op_sect 0
  527.  
  528.                    if {[get_attrib_hdr_sect $feat w] == $ada_sections(h_pub_access_sect)} {
  529.                        if {$result > 1} {
  530.                            gen_access_body "set" $feat $class $inh_name $type 1 \
  531.                            "Set_${name} (Self.${inh_name}${g_inh_ext}, New_${name});\n"
  532.                        }
  533.                    }
  534.                     append_to_op_list $inh_op_sect 0
  535.                 }
  536.         }
  537.     }
  538. }
  539.  
  540.  
  541. proc get_full_feat_name {feat} {
  542.     set name [cap [map_oper [get_name $feat]]]
  543.     set type [cap [get_name [get_type $feat]]]
  544.     if {$name == $type} {
  545.         return "${name}_${g_qualified_rname}"
  546.     } else {
  547.         return $name
  548.     }
  549. }
  550.  
  551. proc ok_to_add {inh_flag sect name} {
  552.     set flag 0
  553.     if {$inh_flag == 0} {
  554.         if {$sect != $ada_sections(dev_null_sect)} {
  555.             set flag 1
  556.         }
  557.     } else {
  558.         if {$sect == $ada_sections(h_pub_access_sect)} {
  559.             set flag 1
  560.         }
  561.     }
  562.     return $flag
  563. }
  564.  
  565.  
  566. proc process_local_op_list {inh_flag real_sect tmp_sect} {
  567.     set method_type [section get_contents $tmp_sect]
  568.     if {$inh_flag ==0} {
  569.         add_to_local_op_list $method_type
  570.         section append_section $real_sect $tmp_sect
  571.         return 1
  572.     } else {
  573.         if {[check_local_op_list $method_type] == 1} {
  574.             return 0
  575.         } else {
  576.             global g_inh_op_count
  577.             global g_inh_op_list
  578.             echo "METHOD = $method_type"
  579.             for {set x 0} {$x < $g_inh_op_count} {incr x} {
  580.                 set inh_op [section get_contents $g_inh_op_list($x)]
  581.                 echo "INH_OP = $inh_op"
  582.                 if {[section get_contents $g_inh_op_list($x)] == $method_type} {return 1}
  583.             }
  584.             section append_section $real_sect $tmp_sect
  585.             return 1
  586.         }
  587.     }
  588. }
  589.  
  590. proc get_get_sig {static_val} {
  591.     if {$static_val == 0} {
  592.         return "(Self : ${g_record_name}) "
  593.     } else {
  594.         return ""
  595.     }
  596. }
  597.  
  598. proc get_set_sig {static_val} {
  599.     if {$static_val == 0} {
  600.         return "Self : in out ${g_record_name}; " 
  601.     } else {
  602.         return ""
  603.     }
  604. }
  605.  
  606.  
  607. proc gen_access_cmmt {is_data hdr_type tmp_sect} {
  608.     global g_local_priv_assoc_access_count
  609.     global g_local_pub_assoc_access_count
  610.      global g_local_priv_attr_access_count
  611.      global g_local_pub_attr_access_count
  612.     global ASSOCACCESSCMMT
  613.     global ATTRACCESSCMMT
  614.  
  615.         if {$is_data == 1}   {
  616.        if {$hdr_type == "Private"} {
  617.           incr g_local_priv_attr_access_count 1
  618.               if {$g_local_priv_attr_access_count == 1}   {
  619.                     section append $tmp_sect $ATTRACCESSCMMT
  620.                  section append $tmp_sect "\n"
  621.                  }
  622.        } else {
  623.           incr g_local_pub_attr_access_count 1
  624.               if {$g_local_pub_attr_access_count == 1}   {
  625.                     section append $tmp_sect $ATTRACCESSCMMT
  626.                  section append $tmp_sect "\n"
  627.                  }
  628.        }
  629.  
  630.         } else {
  631.        if {$hdr_type == "Private"} {
  632.                  incr g_local_priv_assoc_access_count 1
  633.               if {$g_local_priv_assoc_access_count == 1}   {
  634.                  section append $tmp_sect $ASSOCACCESSCMMT
  635.                  section append $tmp_sect "\n"
  636.               }
  637.        } else {
  638.                  incr g_local_pub_assoc_access_count 1
  639.               if {$g_local_pub_assoc_access_count == 1}   {
  640.                  section append $tmp_sect $ASSOCACCESSCMMT
  641.                  section append $tmp_sect "\n"
  642.               }
  643.        }
  644.            }
  645. }
  646.  
  647.  
  648.  
  649. proc gen_access_hdr {feat type inh_flag} {
  650.     set static_val [get_the_class_feature $feat]
  651.  
  652.     if {$inh_flag == 1} {
  653.         if {$static_val == 1} {
  654.             return
  655.         } else {
  656.             set static_val 0
  657.         }
  658.     }
  659.     set name [get_full_feat_name $feat]
  660.     set tmp_get_sect [section create]
  661.     set tmp_set_sect [section create]
  662.  
  663.     if {[get_obj_type $feat] == "data_attrib"} {
  664.         set get_sect [get_attrib_hdr_sect $feat r]
  665.         set set_sect [get_attrib_hdr_sect $feat w]
  666.         set get_hdr_type [get_attrib_hdr_type $feat r]
  667.         set set_hdr_type [get_attrib_hdr_type $feat w]
  668.         set is_data 1
  669.     } else {
  670.         set get_sect [get_assoc_hdr_sect $feat r]
  671.         set set_sect [get_assoc_hdr_sect $feat w]
  672.         set get_hdr_type [get_assoc_hdr_type $feat r]
  673.         set set_hdr_type [get_assoc_hdr_type $feat w]
  674.         set is_data 0
  675.     }
  676.     set gname "Get_${name}"
  677.     set sname "Set_${name}"
  678.     set c_sect $ada_sections(c_access_func_sect)
  679.     set result 0
  680.  
  681.     if {[ok_to_add $inh_flag $get_sect $gname]  ==  1} {
  682.         gen_access_cmmt $is_data $get_hdr_type $tmp_get_sect
  683.         set get_line "function $gname [get_get_sig $static_val]return $type"
  684.         section append $tmp_get_sect "${get_line};\n\n"
  685.         set success [process_local_op_list $inh_flag $get_sect $tmp_get_sect]
  686.         if {$success == 1} {incr result 1}
  687.     }
  688.  
  689.     if {[ok_to_add $inh_flag $set_sect $sname] == 1} {
  690.         gen_access_cmmt $is_data $set_hdr_type $tmp_set_sect
  691.         set set_line "procedure $sname ([get_set_sig $static_val]New_${name} : $type)"
  692.         section append $tmp_set_sect "${set_line};\n\n"
  693.         set success [process_local_op_list $inh_flag $set_sect $tmp_set_sect]
  694.         if {$success == 1} {incr result 2}
  695.     }
  696.     return $result
  697. }
  698.  
  699.  
  700. proc gen_access_body {flag feat class inh_name type inh_flag line2} {
  701.     set feat_name [get_full_feat_name $feat]
  702.     set class_name [get_name $class]
  703.     set static_val [get_the_class_feature $feat]
  704.  
  705.     if {$inh_flag == 0} {
  706.         set line3 "    "
  707.         set tmp_sect [section create]
  708.     } else {
  709.         if {$static_val == 1} {
  710.             return
  711.         } else {
  712.             set static_val 0
  713.         }
  714.     }
  715.  
  716.     if {$flag == "get"} {
  717.         if {[get_obj_type $feat] == "data_attrib"} {
  718.             set get_sect [get_attrib_hdr_sect $feat r]
  719.         } else {
  720.             set get_sect [get_assoc_hdr_sect $feat r]
  721.         }
  722.                 set name "Get_${feat_name}"
  723.         if {[ok_to_add $inh_flag $get_sect $name] == 0} {return}
  724.         set line1 "function $name [get_get_sig $static_val]return $type"
  725.         append line3 "return "
  726.     } else {
  727.         if {[get_obj_type $feat] == "data_attrib"} {
  728.             set set_sect [get_attrib_hdr_sect $feat w]
  729.         } else {
  730.             set set_sect [get_assoc_hdr_sect $feat w]
  731.         }
  732.                 set name "Set_${feat_name}"
  733.         if {[ok_to_add $inh_flag $set_sect $name] == 0} {return}
  734.         set line1 "procedure $name ([get_set_sig $static_val]New_${feat_name} : $type)"
  735.     }
  736.  
  737.     if {$static_val == 1} {
  738.         append line3 $line2
  739.     } else {
  740.         append line3 "${inh_name}." $line2
  741.     }
  742.     if {$inh_flag == 1} {
  743.         set tmp_c_sect2 [section create]
  744.         global g_operation_list g_operation_list2 inh_operation_list operation_count
  745.         global g_inh_op_list g_inh_op_count
  746.  
  747.         incr operation_count
  748.         set inh_operation_list($operation_count) "$name "
  749.         set g_operation_list($operation_count) [section create]
  750.         set tmp_sect $g_operation_list($operation_count)
  751.  
  752.         ##HM section append $tmp_sect "--OT g_operation_list section created in gen_access_body\n"
  753.         set g_operation_list2($operation_count) [section create]
  754.         set tmp_sect2 $g_operation_list2($operation_count)
  755.  
  756.         ##HM section append $tmp_sect2 "--OT g_operation_list2 section created in gen_access_body\n"
  757.         section append $tmp_sect2 $line3
  758.         set g_inh_op_list($g_inh_op_count) [section create]
  759.         section append $g_inh_op_list($g_inh_op_count) "${line1};\n\n"
  760.         incr g_inh_op_count
  761.     }
  762.  
  763.     section append $tmp_sect "${line1} is\n"
  764.  
  765.     section append $tmp_sect "begin\n"
  766.  
  767.     if {$inh_flag == 0} {
  768.         section append $tmp_sect $line3
  769.         section append $tmp_sect "end ${name};\n\n" 
  770.             set c_sect $ada_sections(c_access_func_sect)
  771.         section append_section $c_sect $tmp_sect
  772.     } 
  773. }
  774.  
  775.  
  776. proc feature::gen_description {feature sect} {
  777.     set ftext [$feature getFreeText]
  778.     if {$ftext != ""} {
  779.         string_to_oopl_comment $sect $ftext
  780.     }
  781. }
  782.  
  783. proc get_qual_type {type sect} {
  784. #HM added this routine to get a qualifier type name and with sys types if needed
  785.     set type_name [get_name $type]
  786.     if {$type_name == ""} {return "void "}
  787.     set obj_type [get_obj_type $type]
  788.     if {$obj_type == "class_type"} {
  789.         add_incl_stmnt $type_name
  790.         append type_name ".$g_handle_name"
  791.     } elseif { $obj_type == "base_type" } {
  792.                 set type_name [$type getType3GL]
  793.         } elseif { $obj_type == "typedef_type" } {
  794.         set p_type [cap [getCurrentSystemName]]_Types.$type_name
  795.         set type_name $p_type
  796.         set sys_types_name [cap [getCurrentSystemName]]_Types
  797.         add_incl_stmnt_sect $sys_types_name $sect
  798.     } elseif { $obj_type == "enum_type" } {
  799.         set p_type [cap [getCurrentSystemName]]_Types.$type_name
  800.         set type_name $p_type;
  801.         set sys_types_name [cap [getCurrentSystemName]]_Types
  802.         add_incl_stmnt_sect $sys_types_name $sect
  803.     }
  804.     return $type_name
  805. }
  806.  
  807.  
  808.  
  809. proc get_full_type {type} {
  810. #HM removed cap from "set type_name" - this causes replace in round-trip
  811. #HM added Sys_Types package name to front of enum and subtype names
  812.     set type_name [get_name $type]
  813.     if {$type_name == ""} {return "void "}
  814.     set obj_type [get_obj_type $type]
  815.     if {$obj_type == "class_type"} {
  816.         add_incl_stmnt $type_name
  817.         append type_name ".$g_handle_name"
  818.     } elseif { $obj_type == "base_type" } {
  819.                 set type_name [$type getType3GL]
  820.         } elseif { $obj_type == "typedef_type" } {
  821.         set p_type [cap [getCurrentSystemName]]_Types.$type_name
  822.         set type_name $p_type
  823.     } elseif { $obj_type == "enum_type" } {
  824.         set p_type [cap [getCurrentSystemName]]_Types.$type_name
  825.         set type_name $p_type;
  826.     }
  827.     return $type_name
  828. }
  829.  
  830. proc data_attrib::generate {attrib class} {
  831. #HM removed cap from "set name" - this was cassing attrib delete and add in round trip
  832.     set static_var [get_the_class_feature $attrib]
  833.  
  834.     set sect [get_data_section $class]
  835.     set name [get_name $attrib]
  836.         set type [get_type $attrib]
  837.         set obj_type [get_obj_type $type]
  838.     #HM - Deleted cap call - resulted in replace in round trip
  839.     set type_name [get_name $type]
  840.  
  841.     echo "      data attribute $name ($type_name)"
  842.  
  843.     feature::gen_description $attrib $sect
  844.  
  845.     if {[get_the_class_feature $attrib] == 1} {
  846.         if {[get_class_vis $class] != "Opaque"} {
  847.             set sect $ada_sections(h_static_data_sect)
  848.         } else {
  849.             set sect $ada_sections(c_static_data_sect)
  850.         }
  851.     } else {
  852.            incr_component_count
  853.         }
  854.  
  855.     set type_name [get_full_type [get_type $attrib]]
  856.  
  857.     section append $sect "$name : $type_name;\n"
  858.  
  859.     gen_access_hdr $attrib $type_name 0
  860.  
  861.     set name [cap [get_name $attrib]]
  862.  
  863.     gen_access_body "get" $attrib $class "Self" $type_name 0 "${name};\n"
  864.     gen_access_body "set" $attrib $class "Self" $type_name 0 "${name} := New_${name};\n"
  865. }
  866.  
  867. # Common generate dispatch function for associations
  868. #
  869. proc gen_for_assoc {attrib class} {
  870.     set prefix "[get_obj_type $attrib]::[get_multiplicity $attrib]"
  871.     echo "prefix = $prefix"
  872.     ${prefix}_inter_pkg $attrib
  873.     ${prefix}_data $attrib $class
  874. }
  875.  
  876. # Common generate dispatch function for database associations
  877. #
  878. proc gen_for_db_assoc {attrib class} {
  879.     # do nothing!
  880. }
  881.  
  882. # Common generate dispatch function for links
  883. #
  884. proc gen_for_link {attrib class} {
  885.     set prefix "assoc_attrib::[get_multiplicity $attrib]"
  886.     ${prefix}_inter_pkg $attrib
  887.     ${prefix}_data $attrib $class
  888. }
  889.  
  890. # Common generate dispatch function for reverse links
  891. #
  892. proc gen_for_rv_link {attrib class} {
  893.     set prefix "assoc_attrib::[get_multiplicity $attrib]"
  894.     echo "prefix = $prefix"
  895.     ${prefix}_inter_pkg $attrib
  896.     ${prefix}_data $attrib $class
  897. }
  898.  
  899. proc assoc_attrib::generate {attrib class} {
  900.     #HM added check for bidirectional association
  901.     global g_local_assoc_count
  902.        global ASSOCCMMT
  903.  
  904.         if {[get_opposite $attrib] != ""}  {
  905.            set type [get_type $attrib]
  906.            if {[get_class_visibility $class] != "Opaque" || \
  907.                [get_class_visibility $type] != "Opaque"}  {
  908.               puts stderr "ERROR: Class '[get_name $class]' has a bidirectional association to class '[get_name $type]' - association skipped"
  909.               return
  910.            }
  911.         }
  912.       set sect [get_data_section $class]
  913.     incr g_local_assoc_count 1
  914.     if {$g_local_assoc_count == 1} {
  915.         section append $sect $ASSOCCMMT
  916.         section append $sect "\n"
  917.     }
  918.     gen_for_assoc $attrib $class
  919. }
  920.  
  921. proc assign_var {to from type_obj {sect "src"}} {
  922.     if [type_is_char_array $type_obj] {
  923.                 add_[determine_sect_type $sect]_inc_name "string" "h"
  924.         return "strcpy($to, $from);"
  925.     }
  926.     return "$to = $from;"
  927. }
  928.  
  929. proc gen_assoc_access_sects {class attrib type} {
  930.     gen_access_hdr $attrib $type 0
  931.     set name [cap [get_name $attrib]]
  932.     gen_access_body "get" $attrib $class "Self" $type 0 "${name};\n"
  933.     gen_access_body "set" $attrib $class "Self" $type 0 "${name} := New_${name};\n"
  934. }
  935.  
  936.  
  937. proc gen_link_class_alt_additions {class i_sect} {
  938.     global link_class_added
  939.     global LINKPACKAGECMMT
  940.     global LINKCONVCMMT
  941.  
  942.     echo "class type = [get_obj_type $class]"
  943.     set name "[get_name $class]${g_alt_link_class_ext}"
  944.     if {[get_obj_type $class] == "class_typedef" || [get_obj_type $class] == "link_class"} {
  945.         if {$link_class_added == 0} {
  946.             section append $i_sect "with $name;\n"
  947.             set type1 ${name}.$g_handle_name
  948.             set type2 $g_handle_name
  949.  
  950.             set h_sect $ada_sections(h_conv_func_sect)
  951.             #HM added comment to signal link conversion functions
  952.             section append $h_sect $LINKCONVCMMT
  953.             section append $h_sect "\n"
  954.             section append $h_sect "function Conv (From : $type1) return $type2;\n\n"
  955.             section append $h_sect "function Conv (From : $type2) return $type1;\n\n"
  956.  
  957.             section append $ada_sections(c_conv_incl_sect) "with Unchecked_Conversion;\n"
  958.  
  959.             set sect $ada_sections(c_conv_func_sect)
  960.             section append $sect "function Conv (From : $type1) return $type2 is\n"
  961.             section append $sect \
  962.                 "    function Conv is new Unchecked_Conversion ($type1, $type2);\n"
  963.             section append $sect "begin\n"
  964.             section append $sect "    return Conv(From);\n"
  965.             section append $sect "end Conv;\n\n"
  966.             section append $sect "function Conv (From : $type2) return $type1 is\n"
  967.             section append $sect \
  968.                 "    function Conv is new Unchecked_Conversion ($type2, $type1);\n"
  969.             section append $sect "begin\n"
  970.             section append $sect "    return Conv(From);\n"
  971.             section append $sect "end Conv;\n\n"
  972.  
  973.             class2linkfiles $class s_filename h_filename
  974.  
  975.             global link_sections
  976.             set link_sections(h_sect) [section create]
  977.             set link_sections(c_sect) [section create]
  978.             set l_sect $link_sections(h_sect)
  979.             set l_sect2 $link_sections(c_sect)
  980.  
  981.             section append $l_sect "-- Specification file for ${name}\n\n"
  982.             #HM added comment to signal as a link package
  983.             section append $l_sect $LINKPACKAGECMMT
  984.                 section append $l_sect "\n"
  985.  
  986.             section append $l_sect "package $name is\n"
  987.             section append $l_sect "    type $g_handle_name is private;\n"
  988.             section append $l_sect "private\n"
  989.             section append $l_sect "    type $g_record_name;\n"
  990.             section append $l_sect "    type $g_handle_name is access $g_record_name;\n"
  991.             section append $l_sect "    for ${g_handle_name}'storage_size use 0;\n"
  992.             section append $l_sect "end $name;\n" 
  993.  
  994.             section append $l_sect2 "-- Body file for ${name}\n\n"
  995.             section append $l_sect2 "with [get_name $class];\n"
  996.             section append $l_sect2 "package body $name is\n"
  997.             section append $l_sect2 \
  998.                 "    type $g_record_name is new [get_name $class].${g_record_name};\n"
  999.             section append $l_sect2 "end $name;\n"
  1000.  
  1001.             write_link_sections $class h_sect c_sect
  1002.  
  1003.             set link_class_added 1
  1004.         }
  1005.     }
  1006. }
  1007.  
  1008.  
  1009. proc add_incl_stmnt {type} {
  1010.     global link_incl_list
  1011.     if {[lsearch $link_incl_list $type] == -1} { 
  1012.         section append $ada_sections(h_incl_sect) "with ${type};\n"
  1013.         lappend link_incl_list $type
  1014.     }
  1015. }
  1016.  
  1017.  
  1018. proc add_incl_stmnt_sect {type sect} {
  1019. #HM added this routine to add an include to a specified section - ada95 has only this version
  1020.     global link_incl_list
  1021.     if {[lsearch $link_incl_list $type] == -1} { 
  1022.         section append $sect "with ${type};\n"
  1023.         lappend link_incl_list $type
  1024.     }
  1025. }
  1026.  
  1027.  
  1028. proc get_type_of_attribute {attrib} {
  1029.     set type [cap [get_name [get_type $attrib]]]
  1030.     set obj_type [get_obj_type $attrib]
  1031.     if {$obj_type == "link_attrib" || $obj_type == "qual_link_attrib"} {
  1032.         append type $g_alt_link_class_ext
  1033.     }         
  1034.     return $type
  1035. }
  1036.  
  1037.  
  1038. proc get_data_attrib_type_name {attrib} {
  1039. #    return [cap [get_name [get_type $attrib]]]
  1040.     return [get_full_type [get_type $attrib]]
  1041. }
  1042.  
  1043. proc get_assoc_attrib_type_name {attrib} {
  1044.     set type [get_type_of_attribute $attrib]
  1045.     if {[get_multiplicity $attrib] == "one"} {
  1046.         add_incl_stmnt $type
  1047.         return ${type}.${g_handle_name}
  1048.     } else {
  1049.         if {[is_ordered $attrib] == "1"} {
  1050.             set generic_rname $g_ordered_set_rname
  1051.         } else {
  1052.             set generic_rname $g_unordered_set_rname
  1053.         }
  1054.         add_incl_stmnt ${type}_${generic_rname}
  1055.         return "${type}_${generic_rname}.${generic_rname}"
  1056.     }
  1057. }
  1058.  
  1059. proc get_link_attrib_type_name {attrib} {
  1060.     return [get_assoc_attrib_type_name $attrib]
  1061. }
  1062.  
  1063. proc get_rv_link_attrib_type_name {attrib} {
  1064.     return [get_assoc_attrib_type_name $attrib]
  1065. }
  1066.  
  1067. proc get_qual_assoc_attrib_type_name {attrib} {
  1068.     if {[get_multiplicity $attrib] == "one"} {
  1069.         set type [get_type_of_attribute $attrib]
  1070.     } else {
  1071.         if {[is_ordered $attrib] == "1"} {
  1072.             set generic_cname $g_ordered_set_cname
  1073.             set generic_rname $g_ordered_set_rname
  1074.         } else {
  1075.             set generic_cname $g_unordered_set_cname
  1076.             set generic_rname $g_unordered_set_rname
  1077.         }
  1078.         set type "[get_type_of_attribute $attrib]_${generic_rname}"
  1079.     }
  1080.     set qual_type [get_name [get_type [get_qualifier $attrib]]]
  1081.     set qual_cname "${type}_${g_qualified_rname}_By_${qual_type}"
  1082.     add_incl_stmnt $qual_cname
  1083.     return ${qual_cname}.${g_qualified_rname}
  1084. }
  1085.  
  1086. proc get_qual_link_attrib_type_name {attrib} {
  1087.     return [get_qual_assoc_attrib_type_name $attrib]
  1088. }
  1089.  
  1090. proc get_rv_qual_link_attrib_type_name {attrib} {
  1091.     return [get_qual_assoc_attrib_type_name $attrib]
  1092. }
  1093.  
  1094. proc assoc_attrib::one_typedef {attrib class} {
  1095.     set sect $ada_sections(h_inl_sect)
  1096.     set name [get_name $class]
  1097.     set type [get_type $attrib]
  1098.     set type_nm [get_name $type]
  1099.     ###add_forward $type
  1100.     # gen_var_decl does not deliver it the format we want, alas
  1101.     set dum [gen_var_decl $type $name]
  1102.     section append $sect "typedef $type_nm *$name;\n"
  1103. }
  1104.  
  1105. proc assoc_attrib::one_inter_pkg {attrib} {
  1106.     # nothing to do here
  1107. }
  1108.  
  1109.  
  1110. proc assoc_attrib::one_data {attrib class} {
  1111.     set sect [get_data_section $class]
  1112.     set type [get_type_of_attribute $attrib]
  1113.  
  1114.     ##HM section append $sect "--OT In assoc_attrib::one_data\n"
  1115.  
  1116.     set name [cap [get_name $attrib]]
  1117.     if {$name != $type} {
  1118.         if {[is_mandatory $attrib] == "0"} {
  1119.             section append $sect "-- the following is an optional association\n"
  1120.         }    
  1121.         if {[$attrib isAggregate] == "1"} {
  1122.             section append $sect "-- the following is an aggregation\n"
  1123.         }    
  1124.         set full_type ${type}.${g_handle_name}
  1125.         section append $sect "$name : ${full_type};\n"
  1126.         incr_component_count
  1127.         set i_sect [get_include_section $class]
  1128.  
  1129.         gen_link_class_alt_additions $class $i_sect
  1130.  
  1131.         section append $i_sect "with ${type};\n"
  1132.  
  1133.         # generate get & set routines
  1134.         gen_assoc_access_sects $class $attrib $full_type
  1135.     }
  1136. }
  1137.  
  1138.  
  1139.  
  1140. proc assoc_attrib::many_typedef {attrib class} {
  1141.     set sect $ada_sections(h_inl_sect)
  1142.     set name [get_name $class]
  1143.     set setpfx [set_prefix $attrib]
  1144.     set type [${setpfx}set_type_name [get_type $attrib]]
  1145.     section append $sect "typedef $type $name;\n"
  1146. }
  1147.  
  1148. proc assoc_attrib::many_inter_pkg {attrib} {
  1149.     global LINKPACKAGECMMT
  1150.  
  1151.     set class_name [get_type_of_attribute $attrib]
  1152.  
  1153.     if {[is_ordered $attrib] == "1"} {
  1154.         set generic_cname $g_ordered_set_cname
  1155.         set generic_rname $g_ordered_set_rname
  1156.     } else {
  1157.         set generic_cname $g_unordered_set_cname
  1158.         set generic_rname $g_unordered_set_rname
  1159.     }
  1160.  
  1161.     create_assoc_sections $ada_assoc_sections
  1162.     set sect $assoc_sections(h_inter_pkg_sect)
  1163.  
  1164.     set ext _$generic_rname
  1165.     set obj_type [get_obj_type $attrib]
  1166.     if {$obj_type == "link_attrib" || $obj_type == "qual_link_attrib"} {
  1167.         set ext ${g_alt_link_class_ext}_${generic_rname}
  1168.     }         
  1169.  
  1170.     class2assocfiles [get_type $attrib] $ext h_filename
  1171.  
  1172.     section append $assoc_sections(h_hdr_sect) \
  1173.         "-- Specification file for ${class_name}_${generic_rname}\n\n"
  1174.     #HM added comment to signal as a link package
  1175.     section append $assoc_sections(h_hdr_sect) $LINKPACKAGECMMT
  1176.     section append $assoc_sections(h_hdr_sect) "\n"
  1177.  
  1178.     section append $sect "with $generic_cname;\n"
  1179.  
  1180.     section append $sect "with $class_name;\n"
  1181.     section append $sect "package ${class_name}_${generic_rname} is new $generic_cname "
  1182.     section append $sect "(${class_name}.${g_handle_name});\n\n"
  1183.  
  1184.     write_assoc_sections [get_type $attrib] $ada_assoc_sections $ext
  1185. }
  1186.  
  1187. proc assoc_attrib::many_data {attrib class} {
  1188.     set sect [get_data_section $class]
  1189.     set type [get_type_of_attribute $attrib]
  1190.     set name [cap [get_name $attrib]]
  1191.  
  1192.         ##HM section append $sect "--OT In assoc_attrib::many_data\n"
  1193.  
  1194.     if {$name != $type} {
  1195.         if {[is_ordered $attrib] == "1"} {
  1196.             set generic_rname $g_ordered_set_rname
  1197.         } else {
  1198.             set generic_rname $g_unordered_set_rname
  1199.         }
  1200.         if {[$attrib isAggregate] == "1"} {
  1201.             section append $sect "-- the following is an aggregation\n"
  1202.         }    
  1203.         set full_type "${type}_${generic_rname}.${generic_rname}"
  1204.         section append $sect "$name : ${full_type};\n"
  1205.         incr_component_count
  1206.         set i_sect [get_include_section $class]
  1207.         gen_link_class_alt_additions $class $i_sect
  1208.         section append $i_sect "with ${type}_${generic_rname};\n"
  1209.  
  1210.         # generate get & set routines
  1211.         gen_assoc_access_sects $class $attrib $full_type
  1212.     }
  1213. }
  1214.  
  1215.  
  1216. proc get_qualifier_type {assoc modifier} {
  1217.     return [generate [get_type [get_qualifier $assoc]] fwd $modifier]
  1218. }
  1219.  
  1220. proc get_qualifier_name {assoc} {
  1221.     return [get_name [get_qualifier $assoc]]
  1222. }
  1223.  
  1224. proc qual_assoc_attrib::generate {attrib class} {
  1225.     #HM added check for bidirectional association
  1226.     global g_local_assoc_count
  1227.        global ASSOCCMMT
  1228.  
  1229.         if {[get_opposite $attrib] != ""}  {
  1230.            set type [get_type $attrib]
  1231.            if {[get_class_visibility $class] != "Opaque" || \
  1232.                [get_class_visibility $type] != "Opaque"}  {
  1233.               puts stderr "ERROR: Class '[get_name $class]' has a bidirectional association to class '[get_name $type]' - association skipped"
  1234.               return
  1235.            }
  1236.         }
  1237.     set sect [get_data_section $class]
  1238.     ##HM section append $sect "--OT In qual_assoc_attrib::generate\n"
  1239.  
  1240.     incr g_local_assoc_count 1
  1241.     if {$g_local_assoc_count == 1} {
  1242.         section append $sect $ASSOCCMMT
  1243.         section append $sect "\n"
  1244.     }
  1245.     gen_for_assoc $attrib $class
  1246. }
  1247.  
  1248. proc qual_assoc_attrib::one_typedef {attrib class} {
  1249.     set sect $ada_sections(h_inl_sect)
  1250.     set name [get_name $class]
  1251.     set type [dict_type_name [get_type [get_qualifier $attrib]] \
  1252.         [get_type $attrib]]
  1253.     section append $sect "typedef $type $name;\n"
  1254. }
  1255.  
  1256.  
  1257. proc qual_assoc_attrib::one_inter_pkg {attrib} {
  1258.     global LINKPACKAGECMMT
  1259.  
  1260.     set class_name [get_type_of_attribute $attrib]
  1261.     set qual_type [get_name [get_type [get_qualifier $attrib]]]
  1262.     set ext1 ${g_qualified_rname}_By_${qual_type}
  1263.     set package_name "${class_name}_${ext1}"
  1264.  
  1265.     create_assoc_sections $ada_assoc_sections
  1266.     set sect $assoc_sections(h_inter_pkg_sect)
  1267.  
  1268.     set ext _$ext1
  1269.     set obj_type [get_obj_type $attrib]
  1270.     if {$obj_type == "link_attrib" || $obj_type == "qual_link_attrib"} {
  1271.         set ext ${g_alt_link_class_ext}_${ext1}
  1272.     }         
  1273.     class2assocfiles [get_type $attrib] $ext h_filename
  1274.     section append $assoc_sections(h_hdr_sect) "-- Specification file for ${package_name}\n\n"
  1275.     #HM added comment to signal as a link package
  1276.     section append $sect $LINKPACKAGECMMT
  1277.     section append $sect "\n"
  1278.  
  1279.     #HM - changes qual_type to full_qual_type to prepend "Sys_Types". package name for enums.
  1280.     #HM -   and with the systypes package if necessary
  1281.     set full_qual_type [get_qual_type [get_type [get_qualifier $attrib]] $sect]
  1282.  
  1283.     section append $sect "with $g_qualified_cname;\n"
  1284.     section append $sect "with $class_name;\n"
  1285.     section append $sect "package ${package_name} is new ${g_qualified_cname} "
  1286.     section append $sect "(${full_qual_type}, ${class_name}.${g_handle_name});\n\n"
  1287.  
  1288.     write_assoc_sections [get_type $attrib] $ada_assoc_sections $ext
  1289. }
  1290.  
  1291. proc qual_assoc_attrib::one_data {attrib class} {
  1292.     set sect [get_data_section $class]
  1293.     set type [get_type_of_attribute $attrib]
  1294.     set qual_type [get_name [get_type [get_qualifier $attrib]]]
  1295.  
  1296.     ##HM section append $sect "--OT In qual_assoc_attrib::one_data\n"
  1297.  
  1298.     if {[is_mandatory $attrib] == "0"} {
  1299.         section append $sect "-- the following is an optional association\n"
  1300.     }
  1301.     if {[$attrib isAggregate] == "1"} {
  1302.         section append $sect "-- the following is an aggregation\n"
  1303.     }    
  1304.     set attr_name [cap [get_name $attrib]]
  1305.     if {$attr_name == $type} {
  1306.         set attr_name ${type}_${g_qualified_rname}
  1307.     }
  1308.     set qual_cname "${type}_${g_qualified_rname}_By_${qual_type}"
  1309.     set full_type ${qual_cname}.${g_qualified_rname}
  1310.     section append $sect "${attr_name} : ${full_type};\n"
  1311.     incr_component_count
  1312.  
  1313.     set i_sect [get_include_section $class]
  1314.     gen_link_class_alt_additions $class $i_sect
  1315.     section append $i_sect "with ${qual_cname};\n"
  1316.  
  1317.     # generate get & set routines
  1318.     gen_assoc_access_sects $class $attrib $full_type
  1319. }
  1320.  
  1321.  
  1322. proc qual_assoc_attrib::many_typedef {attrib class} {
  1323.     set sect $ada_sections(h_inl_sect)
  1324.     set name [get_name $class]
  1325.     set setpfx [set_prefix $attrib]
  1326.     set type [${setpfx}set_dict_type_name \
  1327.          [get_type [get_qualifier $attrib]] [get_type $attrib]]
  1328.     section append $sect "typedef $type $name;\n"
  1329. }
  1330.  
  1331. proc qual_assoc_attrib::many_inter_pkg {attrib} {
  1332.     global LINKPACKAGECMMT
  1333.  
  1334.     assoc_attrib::many_inter_pkg $attrib
  1335.  
  1336.     if {[is_ordered $attrib] == "1"} {
  1337.         set generic_cname $g_ordered_set_cname
  1338.         set generic_rname $g_ordered_set_rname
  1339.     } else {
  1340.         set generic_cname $g_unordered_set_cname
  1341.         set generic_rname $g_unordered_set_rname
  1342.     }
  1343.     set class_name "[get_type_of_attribute $attrib]_${generic_rname}"
  1344.     set qual_type [get_name [get_type [get_qualifier $attrib]]]
  1345.     set ext1 ${g_qualified_rname}_By_${qual_type}
  1346.     set package_name "${class_name}_${ext1}"
  1347.  
  1348.     create_assoc_sections $ada_assoc_sections
  1349.     set sect $assoc_sections(h_inter_pkg_sect)
  1350.  
  1351.     set ext _${generic_rname}_${ext1}
  1352.     set obj_type [get_obj_type $attrib]
  1353.     if {$obj_type == "link_attrib" || $obj_type == "qual_link_attrib"} {
  1354.         set ext ${g_alt_link_class_ext}_${generic_rname}_${ext1}
  1355.     }         
  1356.     class2assocfiles [get_type $attrib] $ext h_filename
  1357.  
  1358.     section append $assoc_sections(h_hdr_sect) "-- Specification file for ${package_name}\n\n"
  1359.     #HM added comment to signal as a link package
  1360.     section append $sect $LINKPACKAGECMMT
  1361.     section append $sect "\n"
  1362.  
  1363.     #HM - changes qual_type to full_qual_type to prepend "Sys_Types". package name for enums.
  1364.     #HM -   and with the systypes package if necessary
  1365.     set full_qual_type [get_qual_type [get_type [get_qualifier $attrib]] $sect]
  1366.  
  1367.     section append $sect "with $g_qualified_cname;\n"
  1368.     section append $sect "with $class_name;\n"
  1369.     section append $sect "package ${package_name} is new ${g_qualified_cname} "
  1370.     section append $sect "(${full_qual_type}, ${class_name}.${generic_rname});\n\n"
  1371.  
  1372.     write_assoc_sections [get_type $attrib] $ada_assoc_sections $ext
  1373. }
  1374.  
  1375. proc qual_assoc_attrib::many_data {attrib class} {
  1376.     set sect [get_data_section $class]
  1377.  
  1378.     ##HM section append $sect "--OT In qual_assoc_attrib::many_data\n"
  1379.  
  1380.     if {[is_ordered $attrib] == "1"} {
  1381.         set generic_cname $g_ordered_set_cname
  1382.         set generic_rname $g_ordered_set_rname
  1383.     } else {
  1384.         set generic_cname $g_unordered_set_cname
  1385.         set generic_rname $g_unordered_set_rname
  1386.     }
  1387.  
  1388.     set type "[get_type_of_attribute $attrib]_${generic_rname}"
  1389.     set qual_type [get_name [get_type [get_qualifier $attrib]]]
  1390.     set attr_name [cap [get_name $attrib]]
  1391.     if {$attr_name == $type} {
  1392.         set attr_name ${type}_${g_qualified_rname}
  1393.     }
  1394.     set qual_cname "${type}_${g_qualified_rname}_By_${qual_type}"
  1395.     if {[$attrib isAggregate] == "1"} {
  1396.         section append $sect "-- the following is an aggregation\n"
  1397.     }    
  1398.     set full_type ${qual_cname}.${g_qualified_rname}
  1399.     section append $sect "${attr_name} : ${full_type};\n"
  1400.     incr_component_count
  1401.  
  1402.     set i_sect [get_include_section $class]
  1403.     gen_link_class_alt_additions $class $i_sect
  1404.     section append $i_sect "with ${qual_cname};\n"
  1405.  
  1406.     # generate get & set routines
  1407.     gen_assoc_access_sects $class $attrib $full_type
  1408.  
  1409. }
  1410.  
  1411.  
  1412. proc finish_func_def {sect type num_params} {
  1413.     if {$num_params > 0} {section append $sect ")"}
  1414.     if {$type != "void "} {
  1415.         if {$num_params > 2} {
  1416.             section append $sect "\n"
  1417.         } else {
  1418.             section append $sect " "
  1419.         }
  1420.         section append $sect "return $type"
  1421.     }
  1422. }
  1423.  
  1424.  
  1425. proc add_to_local_op_list {method_type} {
  1426.     global g_local_op_list g_local_op_count
  1427.  
  1428.     set g_local_op_list($g_local_op_count) $method_type
  1429.     incr g_local_op_count
  1430. }
  1431.  
  1432. proc check_local_op_list {method_type} {
  1433.     global g_local_op_list g_local_op_count
  1434.  
  1435.     for {set x 0} {$x < $g_local_op_count} {incr x} {
  1436. #        echo "g_op_list($x) = $g_local_op_list($x)"            
  1437.         if {$g_local_op_list($x) == $method_type} {return 1}
  1438.     }
  1439.     return -1
  1440. }
  1441.  
  1442.  
  1443. proc operation::generate {oper class class_name inh_mode} {
  1444.     global g_local_inh_op_count
  1445.     global INHEROPERCMMT
  1446.     global tmp_h_sect
  1447.  
  1448.     set name [map_oper [get_name $oper]]
  1449.     set static_val [get_the_class_feature $oper]
  1450.     if {$name == "create" && $static_val == 1} {return}
  1451.  
  1452.     case $inh_mode in {
  1453.     {0} {set tmp_h_sect [get_func_section $oper]}
  1454.     {1} {set tmp_h_sect [section create]}
  1455.     {2} {set tmp_h_sect [section create]}
  1456.     }
  1457.  
  1458.     #HM added comment to signal start of inherited operations
  1459.     if {$inh_mode == 1} {
  1460.         incr g_local_inh_op_count 1
  1461.         if {$g_local_inh_op_count == 1}     {
  1462.             section append $tmp_h_sect $INHEROPERCMMT
  1463.             section append $tmp_h_sect "\n"
  1464.         }
  1465.     }        
  1466.  
  1467.     feature::gen_description $oper $tmp_h_sect
  1468.  
  1469.     set tmp_c_sect [section create]
  1470.     set generating_separate 0
  1471.  
  1472.     # May not need this but it doesn't hurt to create them...
  1473.     create_separate_sections $ada_separate_sections
  1474.  
  1475.     if {$g_generate_separates == "On" && $inh_mode != 1 && [is_oper [get_name $oper]] == 0} {
  1476.         set s $separate_sections(c_hdr_sect)
  1477.         section append $s "-- Subunit file for ${name} (${class_name})\n\n"
  1478.         set s $separate_sections(c_sep_line_sect)
  1479.         section append $s "\nseparate ($class_name)"
  1480.         set main_sect $ada_sections(c_impl_sect)
  1481.         set generating_separate 1
  1482.     }
  1483.  
  1484.     if {$inh_mode == 1} {
  1485.         set tmp_c_sect2 [section create]
  1486.         global g_operation_list
  1487.         global g_operation_list2
  1488.         global inh_operation_list
  1489.         global operation_count
  1490.         incr operation_count
  1491.         set inh_operation_list($operation_count) "$name "
  1492.         set g_operation_list($operation_count) [section create]
  1493.         set c_sect $g_operation_list($operation_count)
  1494.  
  1495.         ##HM section append $c_sect "--OT g_operation_list section created in operation::generate\n"
  1496.         set g_operation_list2($operation_count) [section create]
  1497.         set c_sect2 $g_operation_list2($operation_count)
  1498.  
  1499.         ##HM section append $c_sect2 "--OT g_operation_list2 section created in operation::generate\n"
  1500.     } else {
  1501.         if {$generating_separate == 1} {
  1502.             set c_sect $separate_sections(c_impl_sect)
  1503.         } else {
  1504.             set c_sect $ada_sections(c_impl_sect)
  1505.         }
  1506.     }
  1507.  
  1508.     set type [generate [get_type $oper] fwd "" Value]
  1509.  
  1510.     echo "      operation $name ($type)"
  1511.  
  1512.     if {$type != "void "} {
  1513.         set start_decl "function "
  1514.         set in_out ""
  1515.     } else {
  1516.         set start_decl "procedure "
  1517.         set in_out "in out "
  1518.     }
  1519.  
  1520.     if {$inh_mode == 1} {
  1521.         set start_decl2 ""
  1522.         if {$type != "void "} {
  1523.             set start_decl2 "return "
  1524.         }
  1525.         append start_decl2 "$class_name.$name (Self.$class_name${g_inh_ext}"
  1526.         section append $c_sect2 $start_decl2
  1527.     }
  1528.  
  1529.     set params [get_parameters $oper]
  1530.  
  1531.     append start_decl "$name"
  1532.     set num_params [llength $params]
  1533.     if {$static_val == 0} {incr num_params}
  1534.  
  1535.     if {$num_params > 2} {append start_decl "\n "}
  1536.  
  1537.     if {$num_params > 0} {
  1538.         append start_decl " ("
  1539.     }
  1540.     if {$static_val == 0} {
  1541.         append start_decl "Self : ${in_out}${g_record_name}"
  1542.         set first 0
  1543.     } else {
  1544.         set first 1
  1545.     }
  1546.     section append $tmp_h_sect $start_decl
  1547.     section append $tmp_c_sect "\n$start_decl"
  1548.  
  1549.     foreach param [get_parameters $oper] {
  1550.         generate $param $tmp_h_sect 0 $num_params $first
  1551.         generate $param $tmp_c_sect 0 $num_params $first
  1552.         set first 0
  1553.         if {$inh_mode == 1} {
  1554.             generate $param $tmp_c_sect2 1 $num_params 0
  1555.         }
  1556.         set default [get_default_value $param]
  1557.         if {$default != ""} {
  1558.                         if [default_value_allowed [get_parameters $oper] $param] {
  1559.             section append $tmp_h_sect " := $default"
  1560.             section append $tmp_c_sect " := $default"
  1561.                     } else {
  1562.                         puts "WARNING: default value for parameter\
  1563.                             '[get_name $param]' of\
  1564.                             '[get_name $class]::[get_name $oper]()' is not\n   \
  1565.                 generated since this parameter is followed by parameters\
  1566.                             without\n    default values"
  1567.                     }
  1568.         }
  1569.     }
  1570.  
  1571.     finish_func_def $tmp_h_sect $type $num_params
  1572.     finish_func_def $tmp_c_sect $type $num_params
  1573.  
  1574.     if {$inh_mode != 2} {section append $tmp_h_sect ";\n\n"}
  1575.  
  1576.     set method_type [section get_contents $tmp_c_sect]
  1577.  
  1578.     case $inh_mode in {
  1579.     {0} {add_to_local_op_list $method_type}
  1580.     {1} {
  1581.         if {[check_local_op_list $method_type] == 1} {
  1582.             set tmp_h_sect [section create]
  1583.             section dealloc $tmp_c_sect
  1584.             section dealloc $tmp_c_sect2
  1585.             section dealloc $c_sect2
  1586.             incr operation_count -1
  1587.             return -1
  1588.         }
  1589.     }
  1590.     {2} {return}}
  1591.  
  1592.     section append_section $c_sect $tmp_c_sect
  1593.  
  1594.     if {$type == "void " && [llength $params] > 2} {
  1595.         section append $c_sect "\nis"
  1596.     } else {
  1597.         section append $c_sect " is"
  1598.     }
  1599.  
  1600.     if {$inh_mode == 1} {
  1601.         section append $tmp_c_sect2 ");\n"
  1602.         append inh_operation_list($operation_count) "$type"
  1603.         section append_section $c_sect2 $tmp_c_sect2
  1604.         section dealloc $tmp_c_sect2
  1605.     } else {
  1606.         if {$generating_separate == 1} {
  1607.             section append_section $main_sect $c_sect
  1608.             section append $main_sect " separate;\n"
  1609.         }
  1610.     }
  1611.  
  1612.      if {$inh_mode == 1} {section append $c_sect "\nbegin"}
  1613.  
  1614.      section append $c_sect "\n"
  1615.  
  1616.      if {$inh_mode == 0} {
  1617.     set impl_proc [get_method_impl $oper]
  1618.     if {$impl_proc == ""} {
  1619.         # get previously prepared body
  1620.         get_subp_user_body $class $name $method_type $c_sect
  1621.     } else {
  1622.         set impl_proc operation::$impl_proc
  1623.         if {[info procs $impl_proc] != ""} {
  1624.             section append $c_sect "\nbegin\n"
  1625.             section set_indent $c_sect +
  1626.             section append $c_sect [$impl_proc $oper $class $c_sect]
  1627.             section set_indent $c_sect -
  1628.             section append $c_sect "end\n\n"
  1629.              del_subp_info $class $name $method_type
  1630.         } else {
  1631.             puts stderr "WARNING: Tcl procedure " nonewline
  1632.             puts stderr "'$impl_proc' not found"
  1633.             # fall back to regeneration
  1634.             # get_method_body $name $method_type $c_sect [get_name $oper]
  1635.             get_subp_user_body $class $name $tmp_c_sect $c_sect 
  1636.         }
  1637.     }
  1638.    }
  1639.     if {$inh_mode == 0 && $generating_separate == 1} {
  1640.         class2separatefiles $class [get_name $oper] c_filename
  1641.         write_separate_sections $class $ada_separate_sections [get_name $oper]
  1642.     }
  1643.    section dealloc $tmp_c_sect
  1644. }
  1645.  
  1646.  
  1647.  
  1648. proc append_children {cnames class} {
  1649.     foreach child $g_inher_table($class) {
  1650.         if {[lsearch $cnames $child] == -1} {
  1651.             lappend cnames $g_inher_table($class)
  1652.             set cnames [append_children $cnames $child]
  1653.         }
  1654.     }
  1655.     return $cnames
  1656. }
  1657.  
  1658.  
  1659. proc gen_poly_body {root_name} {
  1660.     global g_poly_op_count
  1661.     global g_poly_op_list g_poly_op_param_list g_poly_op_class_list
  1662.     global g_class_list g_inher_table g_op_list
  1663.  
  1664.     set c_sect $ada_sections(c_impl_sect)
  1665.     for {set x 0} {$x < $g_poly_op_count} {incr x} {
  1666.         section append $ada_sections(h_pub_func_sect) "$g_poly_op_list($x);\n\n"
  1667.         section append $c_sect "$g_poly_op_list($x) is\nbegin\n"
  1668.         section append $c_sect "    case Self.${root_name}_Kind is\n"
  1669.         set this_func_list ""
  1670.         set cnames ""
  1671.         echo "\n\n$g_poly_op_list($x)"
  1672.         foreach p_class $g_poly_op_class_list($x) {
  1673.             lappend cnames $p_class
  1674.             foreach opclass $g_inher_table($p_class) {
  1675.                 if {[lsearch $cnames $opclass] == -1} {
  1676.                     lappend cnames $opclass
  1677.                     set cnames [append_children $cnames $opclass]
  1678.                 }
  1679.             }
  1680.         }
  1681.         foreach poly_class $g_class_list($root_name) {
  1682.                  set classname [get_name $poly_class]
  1683.                  if {[lsearch $this_func_list $classname] != -1} {continue}
  1684.             section append $c_sect "        when A_${classname} =>\n"
  1685.             if {[lsearch $cnames $classname] != -1} {
  1686.                 set p_list $g_poly_op_param_list($x)
  1687.                 section append $c_sect "            "
  1688.                 if {[lindex $p_list 0] != "void"} {section append $c_sect "return "}
  1689.                 set func_name [lindex $p_list 1]
  1690.                 section append $c_sect "${classname}.${func_name}"
  1691.                 section append $c_sect " (Self.${classname}_Obj"
  1692.                 for {set y 2} {$y < [llength $p_list]} {incr y} {
  1693.                     section append $c_sect ", [lindex $p_list $y]"
  1694.                 }
  1695.                 section append $c_sect ")"
  1696.                 section append $c_sect ";\n"
  1697.             } else {
  1698.                 section append $c_sect \
  1699.                    "            raise Constraint_Error;\n"
  1700.             }
  1701.             append this_func_list "$classname "
  1702.            }
  1703.         section append $c_sect "    end case;\n"
  1704.         section append $c_sect "end $func_name;\n\n"
  1705.     }    
  1706. }
  1707.  
  1708.  
  1709. proc parameter::generate {param sect inh_mode num_params first} {
  1710.  
  1711.     set type [get_type $param]
  1712.     set dc fwd
  1713.  
  1714.     set param_dfd [get_param_dfd $param]
  1715.     if {$param_dfd == ""} {set param_dfd "in"}
  1716.  
  1717.     if {$inh_mode == 1} {
  1718.         section append $sect ", "
  1719.         global inh_operation_list
  1720.         global operation_count
  1721.         append inh_operation_list($operation_count) "$param_dfd [get_type $param] "
  1722.         section append $sect "[get_name $param]"
  1723.     } else {
  1724.         if {$first == 0} {section append $sect "; "}
  1725.         if {$num_params > 2} {section append $sect "\n   "}
  1726.         section append $sect \
  1727.             "[get_name $param] : $param_dfd [generate [get_type $param] $dc]"
  1728.     }
  1729. }
  1730.  
  1731.  
  1732. proc base_type::generate {type decl {modifier ""} {default_modifier ""}} {
  1733.     return [get_full_type $type]
  1734. }
  1735.  
  1736. proc base_type::gen_var_decl {type name {col ""}} {
  1737.     set type [get_type_3gl $type]
  1738.     if [regsub {(var)?char\[} $type "char $name\[" type] {
  1739.         regexp {\[(.*)\]$} $type dummy index
  1740.         set index [expr {$index + 1}]
  1741.         regsub {\[(.*)\]$} $type "\[$index]" type
  1742.         return $type
  1743.     }
  1744.     return "$type $name"
  1745. }
  1746.  
  1747. proc class_type::generate {type decl {modifier ""} {default_modifier ""}} {
  1748.     set name [get_full_type $type]
  1749.     if {$decl == "fwd"} {
  1750.         add_forward $type
  1751.         add_src_inc $type
  1752.     } else {
  1753.         add_hdr_inc $type
  1754.     }
  1755.     if {$default_modifier == ""} {
  1756.         global default_type_modifier
  1757.         set default_modifier $default_type_modifier
  1758.     }
  1759.     return $name
  1760. }
  1761.  
  1762. proc class_type::gen_var_decl {type name {col ""}} {
  1763.     add_forward $type
  1764.     return "[get_name $type] $name"
  1765. }
  1766.  
  1767. proc typedef_type::generate {type decl {modifier ""} {default_modifier ""}} {
  1768.     return [get_full_type $type]
  1769. }
  1770.  
  1771. proc typedef_type::gen_var_decl {type name {col ""}} {
  1772.     add_hdr_inc $type
  1773.     return "[get_name $type] $name"
  1774. }
  1775.  
  1776. proc enum_type::generate {type decl {modifier ""} {default_modifier ""}} {
  1777.     return [get_full_type $type]
  1778. }
  1779.  
  1780. proc enum_type::gen_var_decl {type name {col ""}} {
  1781.     return "[get_name $type] $name"
  1782. }
  1783.  
  1784. proc generic_typedef_type::generate {type decl {modifier ""} {default_modifier ""}} {
  1785.     return [get_full_type $type]
  1786. }
  1787.  
  1788. proc generic_typedef_type::gen_var_decl {type name {col ""}} {
  1789.     return "[get_name $type] $name"
  1790. }
  1791.  
  1792.  
  1793. proc constructor::generate {ctor class} {
  1794.     # no constructors in ada.
  1795.     return
  1796. }
  1797.  
  1798. #
  1799. # Check if the given parameter is allowed to have a default value.
  1800. #
  1801. # This is the case if all parameters following this one have default values.
  1802. #
  1803. proc default_value_allowed {paramlist param} {
  1804.     set i [lsearch $paramlist $param]
  1805.     if {$i != -1} {
  1806.     foreach p [lrange $paramlist $i end] {
  1807.             if {[get_default_value $p] == ""} {
  1808.                 return 0
  1809.             }
  1810.     }
  1811.     }
  1812.     return 1
  1813. }
  1814.  
  1815.  
  1816. proc ctor_param::generate {param sect f} {
  1817.     # no constructors in ada.
  1818.     return
  1819. }
  1820.  
  1821. proc attrib_init::generate {init init_sect body_sect} {
  1822.     ### hack !?
  1823.     set data_struct 0
  1824.     set attrib [get_attrib $init]
  1825.     if {[get_obj_type $attrib] == "db_data_attrib"} {
  1826.         set tgt "data.[get_unique_name [get_column $attrib]]"
  1827.         set data_struct 1
  1828.     } else {
  1829.         set tgt [get_name $attrib]
  1830.     }
  1831.     if [type_is_char_array [get_type $attrib]] {
  1832.                 add_[determine_sect_type $body_sect]_inc_name "string" "h"
  1833.         section append $body_sect "strcpy($tgt, [get_name $init]);\n"
  1834.     } else {
  1835.         if $data_struct {
  1836.             section append $body_sect "$tgt = [get_name $init];\n"
  1837.             return
  1838.         }
  1839.     }
  1840. }
  1841.  
  1842.  
  1843. proc get_root_class {class} {
  1844.     set supers [get_super_classes $class]
  1845.     if [lempty $supers] {
  1846.         return $class
  1847.     }
  1848.     return [get_root_class [get_super_class [lindex $supers 0]]]
  1849. }
  1850.  
  1851. proc rv_link_attrib::generate {attrib class} {
  1852.     global g_local_assoc_count
  1853.        global ASSOCCMMT
  1854.  
  1855.     set sect [get_data_section $class]
  1856.     incr g_local_assoc_count 1
  1857.     if {$g_local_assoc_count == 1} {
  1858.         section append $sect $ASSOCCMMT
  1859.         section append $sect "\n"
  1860.     }
  1861.     # multiplicity should always be 'one' here
  1862.     gen_for_rv_link $attrib $class
  1863. }
  1864.  
  1865. proc rv_link_attrib::one_data {attrib class} {
  1866.     set sect [get_data_section $class]
  1867.     set i_sect $ada_sections(h_incl_sect)
  1868.  
  1869.     ##HM section append $sect "--OT In rv_link_attrib::one_data\n"
  1870.  
  1871.     set type [get_name [get_type $attrib]]
  1872.     set role_name [get_name $attrib]
  1873.     if {$role_name != $type} {
  1874.         section append $sect "${role_name} : ${type};\n"
  1875.         incr_component_count
  1876.         section append $i_sect "with ${type};\n"
  1877.     }
  1878. }
  1879.  
  1880. proc qual_link_attrib::generate {attrib class} {
  1881.     global g_local_assoc_count
  1882.        global ASSOCCMMT
  1883.  
  1884.     set sect [get_data_section $class]
  1885.     incr g_local_assoc_count 1
  1886.     if {$g_local_assoc_count == 1} {
  1887.         section append $sect $ASSOCCMMT
  1888.         section append $sect "\n"
  1889.     }
  1890.     gen_for_link $attrib $class
  1891. }
  1892.  
  1893. proc link_attrib::generate {attrib class} {
  1894.     global g_local_assoc_count
  1895.         global ASSOCCMMT
  1896.  
  1897.     set sect [get_data_section $class]
  1898.     ##HM section append $sect "--OT In link_attrib::generate\n"
  1899.  
  1900.     incr g_local_assoc_count 1
  1901.     if {$g_local_assoc_count == 1} {
  1902.         section append $sect $ASSOCCMMT
  1903.         section append $sect "\n"
  1904.     }
  1905.     gen_for_link $attrib $class
  1906. }
  1907.  
  1908. proc link_attrib::one_data {attrib class} {
  1909.     set sect [get_data_section $class]
  1910.     set i_sect $ada_sections(h_incl_sect)
  1911.  
  1912.     ##HM section append $sect "--OT In link_attrib::one_data\n"
  1913.  
  1914.     set type [get_name [get_type $attrib]]
  1915.     set role_name [get_name $attrib]
  1916.     section append $sect "${role_name} : $type;\n"
  1917.         incr_component_count
  1918.     section append $i_sect "with ${type};\n"
  1919. }
  1920.  
  1921. proc link_attrib::many_data {attrib} {
  1922.     assoc_attrib::many_inter_pkg $attrib
  1923.     assoc_attrib::many_data $attrib $class
  1924. }
  1925.  
  1926.  
  1927. # Generate a check for the nullability of the columns of a link.  These columns
  1928. # are either ALL null or ALL not null, so it suffices to check only the
  1929. # first column.
  1930. #
  1931. proc gen_null_check {sect link ind_var {ret_val 0}} {
  1932.     set col [lindex [get_columns $link] 0]
  1933.     if {$ret_val == ""} {
  1934.         set space ""
  1935.     } else {
  1936.         set space " "
  1937.     }
  1938.     expand_text $sect {
  1939.         if (~$ind_var~[get_unique_name $col] == -1)
  1940.             return~${space}~$ret_val;
  1941.     }
  1942. }
  1943.  
  1944. proc is_db_class {class} {
  1945.     return [string match {db_*} [get_obj_type $class]]
  1946. }
  1947.  
  1948. proc class2tgtfiles {class_name src inc} {
  1949.     upvar $src src_f
  1950.     upvar $inc inc_f
  1951.     set src_f ${class_name}.$ada_body_type
  1952.     set inc_f ${class_name}.$ada_spec_type
  1953. }
  1954.  
  1955. proc class2polyfiles {class src inc} {
  1956.     upvar $src src_f
  1957.     upvar $inc inc_f
  1958.     set class_name [class2file ${g_poly_prefix}[get_name $class]]
  1959.     set src_f ${class_name}.$ada_body_type
  1960.     set inc_f ${class_name}.$ada_spec_type
  1961. }
  1962.  
  1963. proc class2assocfiles {class ext inc} {
  1964.     upvar $inc inc_f
  1965.     set name [get_name $class]
  1966.     set cname ${name}${ext}
  1967.     set class_name [class2file $cname]
  1968.     set inc_f ${class_name}.$ada_spec_type
  1969. }
  1970.  
  1971. proc class2linkfiles {class src inc} {
  1972.     upvar $src src_f
  1973.     upvar $inc inc_f
  1974.     set class_name [class2file [get_name $class]${g_alt_link_class_ext}]
  1975.     set src_f ${class_name}.$ada_body_type
  1976.     set inc_f ${class_name}.$ada_spec_type
  1977. }
  1978.  
  1979. proc class2separatefiles {class ext inc} {
  1980.     upvar $inc inc_f
  1981.     set cname [get_name $class]__${ext}
  1982.     set class_name [class2file $cname]
  1983.     set inc_f ${class_name}.$ada_sep_type
  1984. }
  1985.  
  1986. # we want    'class_typedef'
  1987. #      or    'class_enum'
  1988. #      or    'class_generic_typedef'
  1989. proc is_special_class {class} {
  1990.     return [string match {*class_*} [get_obj_type $class]]
  1991. }
  1992.  
  1993. proc is_derivable_class {class} {
  1994.     switch [get_obj_type $class] {
  1995.         "class_enum" {
  1996.             return 0
  1997.         }
  1998.         "class_typedef" {
  1999.         set attrib [lindex [get_features $class] 0]
  2000.         if {[get_type_3gl [get_type $attrib]] == ""} {
  2001.         return 1
  2002.         } else {
  2003.         return 0
  2004.             }
  2005.         }
  2006.         "class_generic_typedef" {
  2007.         set assoc [lindex [get_features $class] 0]
  2008.         if {[get_multiplicity $assoc] == "many" ||
  2009.         [string match {qual_*} [get_obj_type $assoc]]} {
  2010.         return 1
  2011.         } else {
  2012.         return 0
  2013.             }
  2014.     }
  2015.         default {
  2016.             return 1
  2017.         }
  2018.     }
  2019. }
  2020.  
  2021.  
  2022. #
  2023. # global array opermap contains mappings for Ada operators that cannot be
  2024. # entered on CAD diagrams in the normal "op" quoted string form:
  2025. #
  2026. global opermap
  2027. #
  2028. # Ada-specific mappings:
  2029. #
  2030. set opermap(operatorEQ)  "\"=\""
  2031. set opermap(operatorLE)  "\"<=\""
  2032. set opermap(operatorGE)  "\">=\""
  2033. set opermap(operatorDIV) "\"/\""
  2034. #
  2035. # C++ compatibility mappings:
  2036. #
  2037. set opermap(operator+)   "\"+\""
  2038. set opermap(operator-)   "\"-\""
  2039. set opermap(operator*)   "\"*\""
  2040. set opermap(operator%)   "\"rem\""
  2041. set opermap(operator&)   "\"and\""
  2042. set opermap(operator|)   "\"or\""
  2043. set opermap(operator!)   "\"not\""
  2044. set opermap(operator<)   "\"<\""
  2045. set opermap(operator>)   "\">\""
  2046. set opermap(operator&&)  "\"and\""
  2047. set opermap(operator||)  "\"or\""
  2048.  
  2049.  
  2050. proc map_oper {name} {
  2051.     if [info exists opermap($name)] {
  2052.         return $opermap($name)
  2053.     }
  2054.     return $name
  2055. }
  2056.  
  2057.  
  2058. proc is_oper {name} {
  2059.     if {[info exists opermap($name)] || [regexp "^\".*\"\$" $name]} {
  2060.         return 1
  2061.     }
  2062.     return 0
  2063. }
  2064.  
  2065. # return set prefix "o" in case ordered set are needed
  2066. #
  2067. proc set_prefix {attrib} {
  2068.     set this_name [get_name $attrib]
  2069.     if {[is_ordered $attrib] == "1"} {
  2070.         echo "ordered is TRUE"
  2071.         return o
  2072.     } else {
  2073.         echo "ordered is FALSE"
  2074.         return
  2075.     }
  2076. }
  2077.  
  2078.  
  2079. proc gen_op_lists {class} {
  2080.     global g_op_list
  2081.     global g_class_list
  2082.     global root_class
  2083.     append g_class_list([get_name $root_class]) "$class "
  2084.     foreach subgroup [get_sub_classes $class] {   ;# this gives each inh. group.
  2085.         set inh_access [get_inher_access $subgroup]
  2086.         if {$inh_access == ""} {set inh_access "Public"}
  2087.         foreach subclass [get_sub_classes $subgroup] {
  2088.             set subclassname [get_name $subclass]
  2089.             if {$inh_access == "Private"} {
  2090.                 foreach entry $g_op_list([get_name $class]) {
  2091.                     set cname [split_op_list_entry $entry class]
  2092.                     append g_op_list($subclassname) "$cname:$inh_access "
  2093.                 }
  2094.             } else {
  2095.                 append g_op_list($subclassname) "$g_op_list([get_name $class]) "
  2096.             }
  2097.             append g_op_list($subclassname) "$class:$inh_access "
  2098.             gen_op_lists $subclass
  2099.         }
  2100.     }
  2101. }
  2102.  
  2103.  
  2104. proc get_feats {class, superclass} {
  2105.     foreach feat [get_features $class] {
  2106.         set feat_type [get_obj_type $feat]
  2107.         echo "type = $feat_type"
  2108.         if {$feat_type == "operation"} {
  2109.             echo "operation for [get_name $class] is [get_name $feat]"
  2110.             append g_op_list([get_name $class],1) $feat
  2111.             append g_op_list([get_name $class],2) $superclass
  2112.                 
  2113.         }
  2114.     }
  2115. }
  2116.  
  2117.  
  2118. proc class::gen_poly {class} {
  2119.     global g_inher_table
  2120.  
  2121.     class::gen_poly_routine $class 
  2122.     set c_name [get_name $class]
  2123.     foreach subclass1 [get_sub_classes $class] {   ;# this gives each inh. group.
  2124.         foreach subclass [get_sub_classes $subclass1] {
  2125.             set sub_name [get_name $subclass]
  2126.             if {[info exists g_inher_table($c_name)]} {
  2127.                 if {[lsearch $g_inher_table($c_name) $sub_name] == -1} {
  2128.                     lappend g_inher_table($c_name) $sub_name
  2129.                 }
  2130.             } else {
  2131.                 set g_inher_table($c_name) "$sub_name "
  2132.             }
  2133.             if {![info exists g_inher_table($sub_name)]} {
  2134.                 set g_inher_table($sub_name) ""
  2135.             }
  2136.             class::gen_poly $subclass
  2137.         }
  2138.     }
  2139. }
  2140.  
  2141. proc class::gen_poly_routine {class} {
  2142.     global g_inher_table g_parent_list root_class g_func_list link_incl_list
  2143.  
  2144.     set name [get_name $class]
  2145.  
  2146.     echo "in gen_poly_routine, name = $name"
  2147.     
  2148.     if {[lsearch $g_func_list $name] == -1} {
  2149.         if {[lsearch $link_incl_list $name] == -1} {
  2150.             section append $ada_sections(h_hdr_sect) "with $name;\n"
  2151.             lappend link_incl_list $name
  2152.         }
  2153.         if {$name != [get_name $root_class]} {
  2154.             section append $ada_sections(h_class_nm_sect) ", "
  2155.         }
  2156.         section append $ada_sections(h_class_nm_sect) "A_$name"
  2157.         section append $ada_sections(h_pub_data_sect) "    when A_${name} =>\n"
  2158.         section append $ada_sections(h_pub_data_sect) \
  2159.             "        ${name}_Obj : ${name}.${g_record_name};\n"
  2160.  
  2161.         foreach feat [get_features $class] {
  2162.             set feat_type [get_obj_type $feat]
  2163.             echo "   feature type = $feat_type"
  2164.  
  2165.             if {$feat_type == "constructor"} {continue}
  2166.  
  2167.             if {[get_the_class_feature $feat] == 1} {continue}
  2168.  
  2169.             if {$feat_type == "operation"} {
  2170.                 if {[get_func_section $feat] != $ada_sections(h_pub_func_sect)} {continue}
  2171.                 generate $feat $class $name 2
  2172.                 set type [get_full_type [get_type $feat]]
  2173.                 add_to_poly_list $name $feat $type [get_name $feat] \
  2174.                     [section get_contents $tmp_h_sect] "" 1
  2175.             } else {
  2176.                 set type [get_${feat_type}_type_name $feat] 
  2177.                 set fname [cap [get_name $feat]]
  2178.                 set gname "Get_$fname"
  2179.                 set sname "Set_$fname"
  2180.                 set h_sect $ada_sections(h_pub_access_sect)
  2181.                 set c_sect $ada_sections(c_access_func_sect)
  2182.  
  2183.                    if {[get_attrib_hdr_sect $feat r] == $ada_sections(h_pub_access_sect)} {
  2184.                     set g_start "function $gname (Self : ${g_record_name}) return $type"
  2185.                     add_to_poly_list $name $feat $type $gname $g_start "" 0
  2186.                 }
  2187.                    if {[get_attrib_hdr_sect $feat w] == $ada_sections(h_pub_access_sect)} {
  2188.                     set s_start "procedure $sname (Self : in out ${g_record_name}; New_${fname} : $type)"
  2189.                     add_to_poly_list $name $feat void $sname $s_start "New_$fname" 0
  2190.                 }
  2191.             }
  2192.         }
  2193.         append g_func_list "$name "
  2194.     }
  2195. }
  2196.  
  2197.  
  2198. proc get_the_class_feature {feat} {
  2199.     set c_feat [is_class_feature $feat]
  2200.     if {$c_feat == 1} {
  2201.         return 1
  2202.     } else {
  2203.         return 0
  2204.     }
  2205. }
  2206.  
  2207. proc add_to_poly_list {class_name feat type feat_name op_sig extra_params flag} {
  2208.     global g_poly_op_count
  2209.     global g_poly_op_list g_poly_op_param_list g_poly_op_class_list
  2210.  
  2211.     for {set x 0} {$x < $g_poly_op_count} {incr x} {
  2212.         if {$g_poly_op_list($x) == $op_sig} {
  2213.             if {[lsearch g_poly_op_class_list($x) $class_name] == -1} {
  2214.                 lappend g_poly_op_class_list($x) $class_name
  2215.             }
  2216.             return
  2217.         }
  2218.     }
  2219.     set g_poly_op_list($x) $op_sig
  2220.     set g_poly_op_param_list($x) "$type "
  2221.     lappend g_poly_op_param_list($x) $feat_name
  2222.     if {$flag == 1} {
  2223.         foreach param [get_parameters $feat] {
  2224.             lappend g_poly_op_param_list($x) [get_name $param]
  2225.         }
  2226.     }
  2227.     if {$extra_params != ""} {
  2228.         lappend g_poly_op_param_list($x) $extra_params
  2229.     }
  2230.     set g_poly_op_class_list($x) $class_name
  2231.     incr g_poly_op_count
  2232. }
  2233.  
  2234. proc gen_assoc_list {class} {
  2235.     global g_assoc_list
  2236.     echo "Class = [get_name $class]"
  2237.     foreach feat [get_features $class] {
  2238.         set feat_type [get_obj_type $feat]
  2239.         echo "   feature type = $feat_type"
  2240.         if {$feat_type == "assoc_attrib" || $feat_type == "qual_assoc_attrib" \
  2241.             || $feat_type == "link_attrib" || $feat_type == "rv_link_attrib" } {
  2242.             set assoc_class [get_name [get_type $feat]]
  2243.                if {[get_name $feat] != $assoc_class && [lsearch $g_assoc_list $assoc_class] == -1} {
  2244.                 append g_assoc_list "$assoc_class "
  2245.             }
  2246.         }
  2247.     }
  2248. }
  2249.