home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / ada95_util.tcl < prev    next >
Encoding:
Text File  |  1997-10-20  |  3.4 KB  |  115 lines
  1. ###########################################################################
  2. ##
  3. ##  Copyright (c) 1996 by Cadre Technologies Inc.
  4. ##
  5. ##  This software is furnished under a license and may be used only in
  6. ##  accordance with the terms of such license and with the inclusion of
  7. ##  the above copyright notice. This software or any other copies thereof
  8. ##  may not be provided or otherwise made available to any other person.
  9. ##  No title to and ownership of the software is hereby transferred.
  10. ##
  11. ##  The information in this software is subject to change without notice
  12. ##  and should not be construed as a commitment by Cadre Technologies Inc.
  13. ##  or Scientific Toolworks Inc.
  14. ##
  15. ###########################################################################
  16.  
  17. proc find_ada95_file_types {} {
  18.     global ada95_spec_type
  19.     global ada95_body_type
  20.     global ada95_sep_type
  21.  
  22.     set ada95_spec_type "ada_spec"
  23.     set ada95_body_type "ada_body"
  24.     set ada95_sep_type "ada_subunit"
  25. }
  26.  
  27. proc ada95_echo {s} {
  28. #    puts stdout $s
  29. }
  30.  
  31. proc echo {s} {
  32. #    puts stdout $s
  33. }
  34.  
  35. proc add_incl_stmnt {type sect} {
  36.     global link_incl_list    
  37.     if {[lsearch $link_incl_list $type] == -1} {
  38.         section append $sect "with ${type};\n"
  39.         lappend link_incl_list $type
  40.     }
  41. }
  42.  
  43. proc add_incl_stmnt_force {type sect} {
  44. #HM Added this procedure to force withs for association classes
  45.      section append $sect "with ${type};\n"
  46. }
  47.  
  48. #
  49. # Return a class name in child syntax
  50. #
  51. proc get_full_class_name {class} {
  52.     set res_class_name [get_name $class]
  53.     set syntax [get_child_syntax $class]
  54.     if {$syntax == "" || $syntax == "True"} {
  55.         set cur_class $class
  56.         set cur_parents [get_super_classes $cur_class]
  57.         while { ! [lempty $cur_parents]} {
  58.             set cur_parent [get_super_class [lindex $cur_parents 0]]
  59.             set new_name [get_name $cur_parent]
  60.             append new_name "."
  61.             append new_name $res_class_name
  62.             set res_class_name $new_name
  63.             set cur_class $cur_parent
  64.             set cur_parents [get_super_classes $cur_class]
  65.         }
  66. #        if {[get_controlled_type $cur_class] == "Controlled" ||
  67. #         [get_controlled_type $cur_class] == "Limited Controlled"} {
  68. #             set new_name "Ada.Finalization."
  69. #             append new_name $res_class_name
  70. #             set res_class_name $new_name
  71. #        }
  72.     } 
  73.     return $res_class_name
  74. }
  75.  
  76. proc get_ada95_super_classes {class} {
  77.     set supers [get_super_classes $class]
  78.     if { ! [lempty $supers]} {
  79.         return $supers 
  80.     }
  81.     if {[get_controlled_type $class] == "Controlled" ||
  82.         [get_controlled_type $class] == "Limited Controlled"} {
  83.         return "Ada.Finalization"
  84.     }
  85.     return ""
  86. }
  87.  
  88. proc get_g_handle_name {type_name} {
  89.     global cur_model
  90.     set p_class [ $cur_model classByName $type_name ]
  91.     if {$p_class == ""} {
  92.         set ind [string last "." $type_name]
  93.         if { $ind == 0 } {
  94.             return $g_handle_name
  95.         }
  96.         incr ind
  97.         set new_name [string range $type_name $ind end]
  98.         set p_class [ $cur_model classByName $new_name ]
  99.         if {$p_class == ""} {
  100.             return $g_handle_name
  101.         }
  102.     }
  103.     if {[get_sub_classes $p_class] != ""} {
  104.         return Class_$g_handle_name
  105.     }
  106.     return $g_handle_name
  107. }
  108.  
  109.  
  110. proc incr_component_count {} {
  111.    global g_component_count
  112.  
  113.    incr g_component_count 1
  114. }
  115.