home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / ada95_class.tcl < prev    next >
Encoding:
Text File  |  1997-04-02  |  26.4 KB  |  989 lines
  1. ###########################################################################
  2. ##
  3. ##  Copyright (c) 1996 by Cadre Technologies Inc.
  4. ##                          and Scientific Toolworks Inc.
  5. ##
  6. ##  This software is furnished under a license and may be used only in
  7. ##  accordance with the terms of such license and with the inclusion of
  8. ##  the above copyright notice. This software or any other copies thereof
  9. ##  may not be provided or otherwise made available to any other person.
  10. ##  No title to and ownership of the software is hereby transferred.
  11. ##
  12. ##  The information in this software is subject to change without notice
  13. ##  and should not be construed as a commitment by Cadre Technologies Inc.
  14. ##  or Scientific Toolworks Inc.
  15. ##
  16. ###########################################################################
  17.  
  18. # Needed for E_FILE_OPEN_WRITE
  19. #
  20. require cgen_msg.tcl
  21.  
  22. global ada95_hdr_sections
  23. set ada95_hdr_sections {
  24.     h_hdr_sect
  25.     h_user_sect_1
  26.     h_incl_sect
  27.     h_class_nm_sect
  28.     h_user_sect_2
  29.     h_pub_data_sect
  30.     h_conv_func_sect
  31.     h_pub_access_sect
  32.     h_pub_func_sect
  33.     h_priv_data_sect
  34.     h_static_data_sect
  35.     h_priv_access_sect
  36.     h_priv_func_sect
  37.     h_user_sect_3
  38.     h_trailer_sect
  39.     h_user_sect_4
  40. }    
  41.  
  42.  
  43. global ada95_src_sections
  44. set ada95_src_sections {
  45.     c_hdr_sect
  46.     c_user_sect_1
  47.     c_conv_incl_sect
  48.     c_class_nm_sect
  49.     c_user_sect_2
  50.     c_opaque_sect
  51.     c_static_data_sect
  52.     c_user_sect_3
  53.     c_conv_func_sect
  54.     c_access_func_sect
  55.     c_impl_sect
  56.     c_user_sect_4
  57.     c_trailer_sect
  58.     c_user_sect_5
  59. }
  60.  
  61.  
  62. global ada95_assoc_sections
  63. set ada95_assoc_sections {
  64.     h_hdr_sect
  65.     h_user_sect_1
  66.     h_inter_pkg_sect
  67.     h_user_sect_2
  68. }
  69.  
  70.  
  71. global ada95_link_sections
  72. set ada95_link_sections {
  73.     h_sect
  74.     c_sect
  75. }
  76.  
  77. global ada95_separate_sections
  78. set ada95_separate_sections {
  79.     c_hdr_sect
  80.     c_user_sect_1
  81.     c_sep_line_sect
  82.     c_impl_sect
  83. }
  84.  
  85. # Global section array
  86. #
  87. global ada95_sections
  88. global assoc_sections
  89. global separate_sections
  90. global link_sections
  91.  
  92. # Determine the right section based on the accessibility specification and
  93. # whether it is for reading or writing
  94. #
  95. proc get_hdr_sect {access {mode ""}} {
  96.     case [split_access_mode $access $mode] in {
  97.     {Public} {
  98.         return $ada95_sections(h_pub_access_sect)
  99.     }
  100.     {Private} {
  101.         return $ada95_sections(h_priv_access_sect)
  102.     }
  103.     {None} {
  104.         return $ada95_sections(dev_null_sect)
  105.     }}
  106.     return $ada95_sections(h_pub_access_sect)
  107. }
  108.  
  109. proc get_src_sect {access {mode ""}} {
  110.     case [split_access_mode $access $mode] in {
  111.     {Public} {
  112.         echo "SOURCE (mode=$mode) access is Public\n"
  113.         return 1;
  114.     }
  115.     {Private} {
  116.         echo "attrib access is Private\n"
  117.         return 1;
  118.     }
  119.     {None} {
  120.         echo "SOURCE (mode=$mode) access is None\n"
  121.         return 0;
  122.     }}
  123.     return 0;
  124. }
  125.  
  126. # Determine the type of header section based on the accessibility specification and
  127. # whether it is for reading or writing
  128.  
  129.  
  130. proc get_hdr_type {access {mode ""}} {
  131.         return [split_access_mode $access $mode]
  132. }
  133.  
  134.  
  135.  
  136. # Split up the access mode and return the right part of it
  137. #
  138. proc split_access_mode {access mode} {
  139.     if {$access == ""} {
  140.         return Public
  141.     }
  142.     set rw_ac_list [split $access -]
  143.     if {[llength $rw_ac_list] == 2} {
  144.         if {$mode == "r"} {
  145.             return [lindex $rw_ac_list 0]
  146.         }
  147.         return [lindex $rw_ac_list 1]
  148.     }
  149.     return $access
  150. }
  151.  
  152. proc split_op_list_entry {access mode} {
  153.     set rw_ac_list [split $access :]
  154.     if {[llength $rw_ac_list] == 2} {
  155.         if {$mode == "class"} {
  156.             return [lindex $rw_ac_list 0]
  157.         }
  158.         return [lindex $rw_ac_list 1]
  159.     }
  160.     return $access
  161. }
  162.  
  163. # Determine the section for an assoc accesser function based on
  164. # the attribute "assoc_access"
  165. #
  166. proc get_assoc_hdr_sect {assoc {mode ""}} {
  167.     return [get_hdr_sect [get_assoc_access $assoc] $mode]
  168. }
  169.  
  170. proc get_assoc_src_sect {assoc {mode ""}} {
  171.     return [get_src_sect [get_assoc_access $assoc] $mode]
  172. }
  173.  
  174. # Determine the section for an attribute accesser function based on
  175. # the attribute "attrib_access"
  176. #
  177. proc get_attrib_hdr_sect {attrib {mode ""}} {
  178.     return [get_hdr_sect [get_attrib_access $attrib] $mode]
  179. }
  180.  
  181. proc get_attrib_src_sect {attrib {is_inline 0} {mode ""}} {
  182.     return [get_src_sect [get_attrib_access $attrib] $mode]
  183. }
  184.  
  185.  
  186. #Determine the type of header section. "Private", "Public" or "None" is returned.
  187. proc get_attrib_hdr_type {attrib {mode ""}} {
  188.     return [get_hdr_type [get_attrib_access $attrib] $mode]
  189. }
  190.  
  191. proc get_assoc_hdr_type {attrib {mode ""}} {
  192.     return [get_hdr_type [get_assoc_access $attrib] $mode]
  193. }
  194.  
  195.  
  196. # Determine the type of a given section.  "hdr" or "src" is returned.
  197. # Special sections "hdr" and "src" are understood, and are returned as is.
  198. #
  199. proc determine_sect_type {sect} {
  200.     if {$sect == "src"} {
  201.         set type "src"
  202.     } elseif {$sect == "hdr"} {
  203.         set type "hdr"
  204.     } else {
  205.     global ada95_sections
  206.         foreach n [array names ada95_sections] {
  207.             if {$ada95_sections($n) == $sect} {
  208.                 if {[lsearch $ada95_src_sections $n] != -1} {
  209.                     set type "src"
  210.                 } else {
  211.                     set type "hdr"
  212.                 }
  213.                 break
  214.             }
  215.         }
  216.     }
  217.     return $type
  218. }
  219.  
  220. proc get_data_section {class} {
  221.     case [get_class_vis $class] in {
  222.     {Public} {
  223.         return $ada95_sections(h_pub_data_sect)
  224.     }
  225.     {Private} {
  226.         return $ada95_sections(h_priv_data_sect)
  227.     }
  228.     {Limited} {
  229.         return $ada95_sections(h_priv_data_sect)
  230.     }
  231.     {Opaque} {
  232.         return $ada95_sections(c_opaque_sect)
  233.     }
  234.     {Extensions} {
  235.         return $ada95_sections(h_priv_data_sect)
  236.     }}
  237. }
  238.  
  239.  
  240. proc get_func_section {oper} {
  241.     case [get_method_access $oper] in {
  242.     {Public} {
  243.         return $ada95_sections(h_pub_func_sect)
  244.     }
  245.     {Private} {
  246.         return $ada95_sections(h_priv_func_sect)
  247.     }
  248.     {} {
  249.         return $ada95_sections(h_pub_func_sect)
  250.     }}
  251. }
  252.  
  253. proc get_include_section {class} {
  254.     #
  255.     #if {[get_class_visibility $class] != "Opaque"} {
  256.     #    return $ada95_sections(h_incl_sect)
  257.     #} else {
  258.     #    return $ada95_sections(c_hdr_sect)
  259.     #}
  260.     #
  261.     return $ada95_sections(h_incl_sect)
  262. }
  263.  
  264.  
  265.  
  266. # Create ada95 sections
  267. #
  268. proc create_ada95_sections {sects} {
  269.     global ada95_sections
  270.     foreach sect $sects {
  271.         set ada95_sections($sect) [section create]
  272.         section set_indent $ada95_sections($sect) 0 "    "
  273.     }
  274.     set ada95_sections(dev_null_sect) [section create]
  275. }
  276.  
  277. proc create_assoc_sections {sects} {
  278.     global assoc_sections
  279.     foreach sect $sects {
  280.         set assoc_sections($sect) [section create]
  281.         section set_indent $assoc_sections($sect) 0 "    "
  282.     }
  283.     set assoc_sections(dev_null_sect) [section create]
  284. }
  285.  
  286. proc create_separate_sections {sects} {
  287.     global separate_sections
  288.     foreach sect $sects {
  289.         set separate_sections($sect) [section create]
  290.         section set_indent $separate_sections($sect) 0 "    "
  291.     }
  292.     set separate_sections(dev_null_sect) [section create]
  293. }
  294.  
  295. proc get_class_vis {class} {
  296.     set class_visibility [get_class_visibility $class]
  297.     if {$class_visibility == ""} {set class_visibility Public}
  298.     if {$class_visibility == "Private Extensions"} {set class_visibility Extensions}
  299.     return $class_visibility
  300. }
  301.  
  302. # give sections their initial contents
  303.  
  304. proc init_ada95_sections {class} {
  305.     global USERMETHCMMT
  306.  
  307.         set data_sect [get_data_section $class]
  308.         set visibility [get_class_vis $class]
  309.     section append $ada95_sections(h_incl_sect) "with $sysfile_name;\n"
  310.     section set_indent $ada95_sections(h_user_sect_2) +
  311.     section set_indent $ada95_sections(h_pub_data_sect) +
  312.     section set_indent $ada95_sections(h_conv_func_sect) +
  313.     section set_indent $ada95_sections(h_pub_func_sect) +
  314.     section set_indent $ada95_sections(h_pub_access_sect) +
  315.     section set_indent $ada95_sections(h_priv_access_sect) +
  316.     section set_indent $ada95_sections(h_priv_func_sect) +
  317.     section set_indent $ada95_sections(h_user_sect_3) +
  318.  
  319.     section append $ada95_sections(h_priv_data_sect) "private\n\n"
  320.     section set_indent $ada95_sections(h_priv_data_sect) +
  321.     section set_indent $ada95_sections(h_static_data_sect) +
  322.  
  323.         #HM added comments to devide sections
  324.         section append $ada95_sections(h_pub_func_sect) $USERMETHCMMT
  325.         section append $ada95_sections(h_pub_func_sect) "\n"
  326.  
  327.         section append $ada95_sections(h_priv_func_sect) $USERMETHCMMT
  328.         section append $ada95_sections(h_priv_func_sect) "\n"
  329.  
  330.     if {$visibility != "Opaque"} {
  331.             if {[get_super_classes $class] == ""} {
  332.                 if {$g_record_name == "Data"} {
  333.                 section append $data_sect "type $g_record_name is record\n"
  334.                 } elseif {[get_sub_classes $class] != ""} {
  335.                     if {![is_abstract_class $class]} {
  336.                     section append $data_sect \
  337.                          "type $g_record_name is tagged record\n"
  338.                     } else {
  339.                     section append $data_sect \
  340.                          "type $g_record_name is abstract tagged record\n"
  341.                     }
  342.                 } elseif {[is_abstract_class $class]} {
  343.             #HM added keyword tagged here - "abstract record" is not valid
  344.                 section append $data_sect "type $g_record_name is abstract tagged record\n"
  345.                 } elseif {[get_controlled_type $class] == "Controlled"} {
  346.             section append $data_sect \
  347.                      "type $g_record_name is new Ada.Finalization.Controlled with record\n" 
  348.             section append $ada95_sections(h_incl_sect) "with Ada.Finalization;\n"
  349.         } elseif {[get_controlled_type $class] == "Limited Controlled"} {
  350.             section append $data_sect \
  351.                      "type $g_record_name is new Ada.Finalization.Limited_Controlled with record\n" 
  352.             section append $ada95_sections(h_incl_sect) "with Ada.Finalization;\n"
  353.         } else {
  354.                 section append $data_sect "type $g_record_name is record\n"
  355.                 } 
  356.             } else {
  357.                 set parents [get_super_classes $class]
  358.                 set parent [get_super_class [lindex $parents 0]]
  359.                 set pname [get_full_class_name $parent]
  360.                 if {[get_child_syntax $class] == "False"} {
  361.                     section append $ada95_sections(h_incl_sect) "with $pname;\n"
  362.                 }
  363.                 if {$g_record_name == "Data"} {
  364.                 section append $data_sect "type $g_record_name is new $pname.$g_record_name with record\n"
  365.                 } elseif {[is_abstract_class $class]} {
  366.             #HM moved keyword abstract - "with abstract record" is not valid
  367.                 section append $data_sect "type $g_record_name is abstract new $pname.$g_record_name with record\n"
  368.                 } else {
  369.                 section append $data_sect "type $g_record_name is new $pname.$g_record_name with record\n"
  370.                 } 
  371.             }
  372.     }
  373.     section set_indent $data_sect +
  374.     section set_indent $ada95_sections(c_user_sect_2) +
  375.     section set_indent $ada95_sections(c_opaque_sect) +
  376.     section set_indent $ada95_sections(c_static_data_sect) +
  377.     section set_indent $ada95_sections(c_user_sect_3) +
  378.     section set_indent $ada95_sections(c_conv_func_sect) +
  379.     section set_indent $ada95_sections(c_access_func_sect) +
  380.     section set_indent $ada95_sections(c_impl_sect) +
  381.     section set_indent $ada95_sections(c_user_sect_4) +
  382.         set name [get_full_class_name $class]
  383.     section append $ada95_sections(c_trailer_sect) "\nend $name;\n"
  384. }
  385.  
  386. #
  387. # This is only used for the S1_Types file
  388. #
  389. proc init_sys_sections {name} {
  390.     section append $ada95_sections(h_hdr_sect) \
  391.          "-- Specification file for ${name}\n\n"
  392.     section append $ada95_sections(h_class_nm_sect) "package $name is\n"
  393.     section append $ada95_sections(h_pub_data_sect) "\n"
  394.     section set_indent $ada95_sections(h_user_sect_2) +
  395.     section set_indent $ada95_sections(h_pub_data_sect) +
  396.     section set_indent $ada95_sections(h_user_sect_3) +
  397.     section append $ada95_sections(h_trailer_sect) "\nend $name;\n"
  398. }
  399.  
  400. # give sections their terminal contents
  401.  
  402. proc exit_ada95_sections {class} {
  403.     global ada95_sections g_assoc_list g_handle_name g_record_name
  404.         global g_component_count
  405.  
  406.     set sect [get_data_section $class]
  407.     if {[get_class_visibility $class] != "Opaque"} {
  408.         if {$g_component_count == 0} {
  409.                    section append $sect "null;\n"
  410.         }
  411.         section set_indent $sect -
  412.         section append $sect "end record;\n\n"
  413.         section append $ada95_sections(h_static_data_sect) "\n"
  414.  
  415.         # Add the line "type Link is access Instance;" all of
  416.                 # the time, in case the class is used as a type within
  417.                 # another class.
  418.         section append $ada95_sections(h_pub_data_sect) \
  419.                 "type $g_handle_name is access all $g_record_name;\n\n"
  420.  
  421.         if {[get_super_classes $class] != ""} {
  422.                  section append $ada95_sections(h_pub_data_sect) \
  423.                          "type Class_$g_handle_name is access all $g_record_name'Class;\n\n"
  424.         } elseif {[get_sub_classes $class] != ""} {
  425.             section append $ada95_sections(h_pub_data_sect) \
  426.                  "type Class_$g_handle_name is access all $g_record_name'Class;\n\n"
  427.         }
  428.     } else {
  429.         if {$g_component_count == 0} {
  430.                    section append $ada95_sections(c_opaque_sect) "null;\n"
  431.         }
  432.         section set_indent $ada95_sections(c_opaque_sect) -
  433.         section append $ada95_sections(c_opaque_sect) "end record;\n\n"
  434.         section append $ada95_sections(c_static_data_sect) "\n"
  435.     }
  436.  
  437.     set tmp_sect [section create]
  438.     section append_section $tmp_sect $ada95_sections(h_priv_data_sect)
  439.     section append_section $tmp_sect $ada95_sections(h_priv_access_sect)
  440.     section append_section $tmp_sect $ada95_sections(h_priv_func_sect)
  441.     section append_section $tmp_sect $ada95_sections(h_static_data_sect)
  442.  
  443.     echo "private section = [section get_contents $tmp_sect]..."
  444.     if {[section get_contents $tmp_sect] == "private\n\n\n" } {
  445.         set ada95_sections(h_priv_data_sect) [section create]
  446.     }
  447.     section append $ada95_sections(h_user_sect_2) "\n"
  448. }
  449.  
  450. #
  451. # Dependency management. If there is only one target (lib or exe) in the
  452. # system then source files are automatically added to the dependency list
  453. # of that target.
  454. #
  455.  
  456. global the_only_target
  457. set the_only_target [fstorage::dir {exe lib}]
  458. if {[llength $the_only_target] == 1} {
  459.     global the_only_target_deps
  460.     foreach dep [fstorage::get_dependencies $the_only_target] {
  461.         set the_only_target_deps($dep) 1
  462.     }
  463. } else {
  464.     catch {unset the_only_target}
  465. }
  466.  
  467. proc add_only_target_dep {dep} {
  468.     if {[info exists the_only_target] &&
  469.         ![info exists the_only_target_deps($dep)]} {
  470.         fstorage::add_dependency $the_only_target $dep
  471.         set the_only_target_deps($dep) 1
  472.     }
  473. }
  474.  
  475. # Write the sections to the right file and deallocate them
  476. #
  477. proc write_ada95_sections {class hsects csects} {
  478.     set class_name [get_name $class]
  479.     class2tgtfiles $class_name src_file h_file
  480.     #HM do not write the c file if the h file doesn't change
  481.         set do_write 1
  482.         if {[do_write_sections $class_name $h_file $hsects 1 1] == 2} {
  483.            set do_write 0
  484.         }
  485.     do_write_sections $class_name $src_file $csects 1 $do_write
  486.     section dealloc $ada95_sections(dev_null_sect)
  487.     unset ada95_sections(dev_null_sect)
  488. }
  489.  
  490. proc write_assoc_sections {class hsects ext} {
  491.     class2assocfiles $class $ext h_file
  492.     set class_name [get_name $class]
  493.     do_write_sections $class_name $h_file $hsects 0 1
  494. }
  495.  
  496. proc write_link_sections {class hsects csects} {
  497.     class2linkfiles $class src_file h_file
  498.     set class_name [get_name $class]
  499.     #HM do not write the c file if the h file doesn't change
  500.     set do_write 1
  501.     if {[do_write_sections $class_name $h_file $hsects 3 1] == 2}  {
  502.           set do_write 0
  503.     }
  504.     do_write_sections $class_name $src_file $csects 3 $do_write
  505. }
  506.  
  507. proc write_sys_sections {name hsects} {
  508.  
  509.     class2tgtfiles $name c_file h_file
  510.  
  511.     if {[is_file_regenerated $h_file]} {
  512.         puts stdout "Generating for User-Defined Types File '$sysfile_name'"
  513.         do_write_sections $name $h_file $hsects 5 1
  514.     }
  515. }
  516.  
  517. proc write_separate_sections {class csects ext} {
  518.     class2separatefiles $class $ext c_file
  519.     set class_name [get_name $class]
  520.     do_write_sections $class_name $c_file $csects 2 1
  521. }
  522.  
  523.  
  524. proc is_file_regenerated {filename} {
  525.     global skip_file
  526.     global gen_file
  527.  
  528. #    if {[llength $sects] == 0} {return 0}
  529.     if {[info exists gen_file($filename)] ||
  530.         ($import_new && ![info exists skip_file($filename)])} {
  531.         return 1
  532.     }
  533.     return 0
  534. }
  535.  
  536. proc do_write_sections {class_name file_name sects flag do_write} {
  537.     set did_save_file 0
  538.     if {[llength $sects] == 0} {return $did_save_file}
  539.     set nt $file_name
  540.     global skip_file
  541.     global gen_file
  542.     if {[info exists gen_file($nt)] ||
  543.         ($import_new && ![info exists skip_file($nt)])} {
  544.         set cmp_sect [section create]
  545.         foreach sect $sects {
  546.             case $flag in {
  547.             {0} {set sect2 $assoc_sections($sect)}
  548.             {1} {set sect2 $ada95_sections($sect)}
  549.             {2} {set sect2 $separate_sections($sect)}
  550.             {3} {set sect2 $link_sections($sect)}
  551.             {4} {set sect2 $ada95_sections($sect)}
  552.             {5} {set sect2 $ada95_sections($sect)}
  553.             }
  554.             section append_section $cmp_sect $sect2
  555.             section dealloc $sect2
  556.             unset sect2
  557.         }
  558.         if {[section_equals_file $cmp_sect $nt] || $do_write == 0 } {
  559.             puts "   $nt has not changed: file not written"
  560.             section dealloc $cmp_sect
  561.             return 2
  562.         }
  563.         puts stdout "   Creating $nt"
  564.         if {[catch {set fd [fstorage::open $nt w]} reason]} {
  565.             puts stderr $reason
  566.             m4_error $E_FILE_OPEN_WRITE $nt
  567.         } else {
  568.             if { [catch {fstorage::set_imp_from $nt $class_name} \
  569.                   reason] } {
  570.                 puts stderr $reason
  571.             }
  572.             section write $cmp_sect $fd
  573.             section dealloc $cmp_sect
  574.             fstorage::close $fd
  575.             set did_save_file 1
  576.         }
  577.     }
  578.     return $did_save_file
  579. }
  580.  
  581. proc process_external_class_source {class} {
  582.     set class_name [get_name $class]
  583.     set tmp_sect [section create]
  584.     expand_text $tmp_sect [get_class_source $class]
  585.     set files [string trim [section get_contents $tmp_sect]]
  586.     section dealloc $tmp_sect
  587.  
  588.     set first 1
  589.     foreach entry [split $files ,] {
  590.         # first one is ada95_spec_type
  591.         # all others are ada95_body_type
  592.         if $first {
  593.             set first 0
  594.             set ftype $ada95_spec_type
  595.         } else {
  596.             set ftype $ada95_body_type
  597.         }
  598.         set file_name [class2file $class_name]
  599.         set nt ${file_name}.$ftype
  600.         global skip_file
  601.         global gen_file
  602.         if {[info exists gen_file($nt)] ||
  603.             ($import_new && ![info exists skip_file($nt)])} {
  604.             set fullpath [find_file $entry]
  605.             if {$fullpath == ""} {
  606.                 puts -nonewline "ERROR: class '[get_name $class]': "
  607.                 puts "external class source file '$entry' not found"
  608.                 continue
  609.             }
  610.             puts "Importing external '$fullpath'"
  611.             puts "   Creating $nt"
  612.             if {[catch {set out [fstorage::open $nt w]} reason]} {
  613.                 puts stderr $reason
  614.                 m4_error $E_FILE_OPEN_WRITE $nt
  615.             } else {
  616.                 if { [catch {fstorage::set_imp_from $nt \
  617.                     $class_name} reason] } {
  618.                     puts stderr $reason
  619.                 }
  620.                 set max 8092
  621.                 set in [open $fullpath r]
  622.                 while {[set result [read $in $max]] != ""} {
  623.                     puts -nonewline $out $result 
  624.                 }
  625.                 close $in
  626.                 fstorage::close $out
  627.             }
  628.         }
  629.     }
  630. }
  631.  
  632. # find file using global 'exsrc_searchpath'
  633.  
  634. proc find_file {file} {
  635.     if [file exists $file] {
  636.         return $file
  637.     }
  638.     global exsrc_searchpath
  639.     if {! [info exists exsrc_searchpath]} {
  640.         return ""
  641.     }
  642.     foreach dir [split $exsrc_searchpath :] {
  643.         set fullpath $dir/$file
  644.         if [file exists $fullpath] {
  645.             return $fullpath
  646.         }
  647.     }
  648.     return ""
  649. }
  650.  
  651. # read status arrays and generate 'only-once' code
  652.  
  653. proc gen_delayed_code {} {
  654.     global ada95_hdr_incs
  655.     catch {unset cpp_hdr_incs}
  656.     global cpp_hdr_files
  657.     catch {unset cpp_hdr_files}
  658. }
  659.  
  660. # Global friend array
  661. #
  662. global cpp_friends
  663.  
  664. proc add_friend {friend} {
  665.     global cpp_friends
  666.     set cpp_friends([get_name $friend]) 1
  667. }
  668.  
  669. proc gen_friends {} {
  670.     global cpp_friends
  671.     if {![info exists cpp_friends]} {
  672.         return
  673.     }
  674.     set sect $ada95_sections(h_friend_sect)
  675.     section set_indent $sect +
  676.     foreach class [lsort [array names cpp_friends]] {
  677.         section append $sect "friend class $class;\n"
  678.     }
  679.     section set_indent $sect +
  680.     unset cpp_friends
  681. }
  682.  
  683. #
  684. # forward declaration / class header inclusion management functions
  685. #
  686.  
  687. # Global arrays to store the information
  688. #
  689. global cpp_forwards
  690. global cpp_hdr_incs cpp_hdr_incs_name cpp_hdr_incs_name_ext
  691. global cpp_src_incs cpp_src_incs_name cpp_src_incs_name_ext
  692.  
  693. proc add_forward {class} {
  694.     global cpp_forwards
  695.     set cpp_forwards([get_name $class]) $class
  696. }
  697.  
  698. proc add_forward_name {name} {
  699.     global cpp_forwards
  700.     set cpp_forwards($name) 1
  701. }
  702.  
  703. proc add_hdr_inc {class} {
  704.     global cpp_hdr_incs
  705.     set cpp_hdr_incs([get_name $class]) $class
  706. }
  707.  
  708. proc add_hdr_inc_name {class_name {ext "hxx"}} {
  709.     global cpp_hdr_incs_name cpp_hdr_incs_name_ext
  710.     set cpp_hdr_incs_name($class_name) 1
  711.     set cpp_hdr_incs_name_ext($class_name) $ext
  712. }
  713.  
  714. proc add_src_inc {class} {
  715.     global cpp_src_incs
  716.     set cpp_src_incs([get_name $class]) $class
  717. }
  718.  
  719. proc add_src_inc_name {class_name {ext "hxx"}} {
  720.     global cpp_src_incs_name cpp_src_incs_name_ext
  721.     set cpp_src_incs_name($class_name) 1
  722.     set cpp_src_incs_name_ext($class_name) $ext
  723. }
  724.  
  725. # Generate forwards. If the class definition is also included, the forward
  726. # is not generated.
  727. #
  728. proc gen_forwards {} {
  729.     global cpp_forwards cpp_hdr_incs
  730.     if {![info exists cpp_forwards]} {
  731.         return
  732.     }
  733.     set sect $ada95_sections(h_fwd_decl_sect)
  734.     foreach class [lsort [array names cpp_forwards]] {
  735.         if [info exists cpp_hdr_incs($class)] {
  736.             continue
  737.         }
  738.     }
  739.     unset cpp_forwards
  740. }
  741.  
  742. proc gen_hdr_incs {class} {
  743.     set user_include_list ""
  744.     set incls [get_include_list $class]
  745.     echo "incls = $incls"
  746.     if {$incls != ""} {
  747.         foreach incl [config_include_list [split $incls ,]] {
  748.             lappend user_include_list $incl
  749.         }
  750.     }
  751.     # do not sort ! remove duplicates
  752.     foreach entry $user_include_list {
  753.         if [info exists dup($entry)] {
  754.             continue;
  755.         }
  756.         set dup($entry) 1
  757.         section append $ada95_sections(h_incl_sect) "with $entry;\n"
  758.     }
  759. }
  760.  
  761. # Generate includes for source file. Don't generate if the file is already
  762. # included in the header file.
  763. #
  764. proc gen_src_incs {} {
  765.     global cpp_src_incs cpp_src_incs_name cpp_src_incs_name_ext cpp_hdr_files
  766.     if {! [info exists ada95_sections(c_hdr_sect)]} {
  767.         catch {unset cpp_src_incs}
  768.         catch {unset cpp_src_incs_name}
  769.         catch {unset cpp_src_incs_name_ext}
  770.  
  771.         return
  772.     }
  773.     set gen_include_list ""
  774.     set user_include_list ""
  775.     if [info exists cpp_src_incs] {
  776.         foreach class [array names cpp_src_incs] {
  777.             if [info exists cpp_hdr_incs($class)] {
  778.                 continue
  779.             }
  780.             set hdl $cpp_src_incs($class)
  781.             set incls [get_include_list $hdl]
  782.             if {$incls == ""} {
  783.                 lappend gen_include_list [get_name $hdl]
  784.                 set src_files([h_class2file $class]) 1
  785.             } else {
  786.                 foreach incl [config_include_list [split $incls ,]] {
  787.                     if [info exists cpp_hdr_files($incl)] {
  788.                         continue
  789.                     }
  790.                     lappend user_include_list $incl
  791.                     set src_files($incl) 1
  792.                 }
  793.             }
  794.         }
  795.     }
  796.     if [info exists cpp_src_incs_name] {
  797.         foreach entry [array names cpp_src_incs_name] {
  798.             set file [h_class2file $entry $cpp_src_incs_name_ext($entry)]
  799.             if [info exists cpp_hdr_files($file)] {
  800.                 continue
  801.             }
  802.             if [info exists src_files($file)] {
  803.                 continue
  804.             }
  805.             lappend gen_include_list $entry
  806.         }
  807.     }
  808.     foreach entry [lsort $gen_include_list] {
  809.                 if {[info exists cpp_src_incs_name_ext($entry)]} {
  810.                     set ext $cpp_src_incs_name_ext($entry)
  811.                 } else {
  812.                     set ext "hxx"
  813.                 }
  814.         # prefer user includes
  815.         set idx [lsearch -exact $user_include_list [h_class2file $entry $ext]]
  816.         if {$idx == -1} {
  817.             gen_include $entry $ada95_sections(c_hdr_sect) $ext
  818.         }
  819.     }
  820.     catch {unset cpp_src_incs}
  821.     catch {unset cpp_src_incs_name}
  822.     catch {unset cpp_src_incs_name_ext}
  823.     catch {unset src_files}
  824. }
  825.  
  826. # Template emulation management
  827.  
  828. # Sets to be instantiated
  829. #
  830. global cpp_sets
  831.  
  832. proc instantiate_set {class} {
  833.     if $has_templates {
  834.         return
  835.     }
  836.     global cpp_sets
  837.     set cpp_sets($class) 1
  838. }
  839.  
  840. proc gen_sets {} {
  841.     global cpp_sets
  842.     if {![info exists cpp_sets]} {
  843.         return
  844.     }
  845.     set sect $ada95_sections(h_incl_sect)
  846.     foreach class [lsort [array names cpp_sets]] {
  847.         gen_set_type_def $class $sect
  848.     }
  849.     unset cpp_sets
  850. }
  851.  
  852. # Ordered Sets to be instantiated
  853. #
  854. global cpp_osets
  855.  
  856. proc instantiate_oset {class} {
  857.     if $has_templates {
  858.         return
  859.     }
  860.     global cpp_osets
  861.     set cpp_osets($class) 1
  862. }
  863.  
  864. proc gen_osets {} {
  865.     global cpp_osets
  866.     if {![info exists cpp_osets]} {
  867.         return
  868.     }
  869.     set sect $ada95_sections(h_incl_sect)
  870.     foreach class [lsort [array names cpp_osets]] {
  871.         gen_oset_type_def $class $sect
  872.     }
  873.     unset cpp_osets
  874. }
  875.  
  876. # Dicts to be instantiated
  877. #
  878. global cpp_dicts
  879.  
  880. proc instantiate_dict {key value} {
  881.     if $has_templates {
  882.         return
  883.     }
  884.     global cpp_dicts
  885.     set cpp_dicts($key,$value) 1
  886. }
  887.  
  888. proc gen_dicts {} {
  889.     global cpp_dicts
  890.     if {![info exists cpp_dicts]} {
  891.         return
  892.     }
  893.     set sect $ada95_sections(h_incl_sect)
  894.     foreach keyval [lsort [array names cpp_dicts]] {
  895.         set kv_list [split $keyval ,]
  896.         gen_dict_type_def [lindex $kv_list 0] [lindex $kv_list 1] $sect
  897.     }
  898.     unset cpp_dicts
  899. }
  900.  
  901. # Set Dicts to be instantiated
  902. #
  903. global cpp_set_dicts
  904.  
  905. proc instantiate_set_dict {key value} {
  906.     if $has_templates {
  907.         return
  908.     }
  909.     global cpp_set_dicts
  910.     set cpp_set_dicts($key,$value) 1
  911. }
  912.  
  913. proc gen_set_dicts {} {
  914.     global cpp_set_dicts
  915.     if {![info exists cpp_set_dicts]} {
  916.         return
  917.     }
  918.     set sect $ada95_sections(h_incl_sect)
  919.     foreach keyval [lsort [array names cpp_set_dicts]] {
  920.         set kv_list [split $keyval ,]
  921.         gen_set_dict_type_def [lindex $kv_list 0] \
  922.                 [lindex $kv_list 1] $sect
  923.     }
  924.     unset cpp_set_dicts
  925. }
  926.  
  927. # Ordered Set Dicts to be instantiated
  928. #
  929. global cpp_oset_dicts
  930.  
  931. proc instantiate_oset_dict {key value} {
  932.     if $has_templates {
  933.         return
  934.     }
  935.     global cpp_oset_dicts
  936.     set cpp_oset_dicts($key,$value) 1
  937. }
  938.  
  939. proc gen_oset_dicts {} {
  940.     global cpp_oset_dicts
  941.     if {![info exists cpp_oset_dicts]} {
  942.         return
  943.     }
  944.     set sect $ada95_sections(h_incl_sect)
  945.     foreach keyval [lsort [array names cpp_oset_dicts]] {
  946.         set kv_list [split $keyval ,]
  947.         gen_oset_dict_type_def [lindex $kv_list 0] \
  948.                 [lindex $kv_list 1] $sect
  949.     }
  950.     unset cpp_oset_dicts
  951. }
  952.  
  953. # FuncMaps to be instantiated
  954. #
  955. global cpp_funcmaps
  956.  
  957. proc instantiate_funcmap {func} {
  958.     if $has_templates {
  959.         return
  960.     }
  961.     global cpp_funcmaps
  962.     set cpp_funcmaps($func) 1
  963. }
  964.  
  965. proc gen_funcmaps {} {
  966.     global cpp_funcmaps
  967.     if {![info exists cpp_funcmaps]} {
  968.         return
  969.     }
  970.     set sect $ada95_sections(h_incl_sect)
  971.     foreach func [lsort [array names cpp_funcmaps]] {
  972.         gen_funcmap_type_def $func $sect
  973.     }
  974.     unset cpp_funcmaps
  975. }
  976.  
  977.     
  978. #
  979. # Return whether the given class is abstact, i.e. has any abstract operations.
  980. #
  981. proc is_abstract_class {class} {
  982.     foreach f [get_features $class] {
  983.         if {[get_obj_type $f] == "operation" && [is_abstract $f] == "1"} {
  984.             return 1
  985.         }
  986.     }
  987.     return 0
  988. }
  989.