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