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