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