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