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