home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / u_check.tcl < prev    next >
Text File  |  1997-03-24  |  5KB  |  150 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. ##
  14. ###########################################################################
  15.  
  16. #---------------------------------------------------------------------------
  17. #
  18. #    Description    : Ada diagram checker procedures.  Most of these
  19. #              procedures redefine existing check procedures.
  20. #              Each redefined procedure initially invokes the
  21. #              original procedure and then performs additional
  22. #              Ada-specific checks.
  23. #
  24. #---------------------------------------------------------------------------
  25. #
  26.  
  27. puts "\nObjectTeam for OMT 4.0 Ada 95 Diagram Checker"
  28.  
  29. source [m4_path_name tcl ada95_funcs.tcl]
  30.  
  31. #
  32. # miscellaneous utility procedures:
  33. #
  34. proc ada95_error {error_msg} {
  35.     m4_fmt_message "ERROR: (Ada) $error_msg"
  36. }
  37.  
  38. proc ada95_notes {notes_txt} {
  39.     m4_fmt_message "NOTES: (Ada) $notes_txt\n"
  40. }
  41.  
  42. #
  43. # redefined procedures from product-tcl/chk_funcs.tcl:
  44. #
  45.  
  46. #
  47. # procedure data_attrib::check
  48. #
  49.  
  50. if {[info commands data_attrib::check_pre_ada95] == ""} {
  51.     rename data_attrib::check data_attrib::check_pre_ada95
  52. }
  53.  
  54. proc data_attrib::check {attrib class} {
  55.     data_attrib::check_pre_ada95 $attrib $class
  56.     set access [get_attrib_access $attrib]
  57.     if {"$access" != "" && "$access" != "Public-Public"} {
  58.     if {[get_class_visibility $class] == "Public"} {
  59.         ada95_error "Class '[get_name $class]' with 'Public' visibility has attribute '[get_name $attrib]' with '[get_attrib_access $attrib]' access"
  60.     }
  61.     }
  62. }
  63.  
  64. #
  65. # procedure assoc_attrib::check
  66. #
  67.  
  68. if {[info commands assoc_attrib::check_pre_ada95] == ""} {
  69.     rename assoc_attrib::check assoc_attrib::check_pre_ada95
  70. }
  71.  
  72. proc assoc_attrib::check {attrib class} {
  73.     assoc_attrib::check_pre_ada95 $attrib $class
  74.     set access [get_assoc_access $attrib]
  75.     if {"$access" != "" && "$access" != "Public-Public"} {
  76.     if {[get_class_visibility $class] == "Public"} {
  77.         ada95_error "Class '[get_name $class]' with 'Public' visibility has link or association attribute '[get_name $attrib]' with '[get_assoc_access $attrib]' access"
  78.     }
  79.     }
  80. #   if {[get_opposite $attrib] != ""} {
  81. #    set type [get_type $attrib]
  82. #    if {[get_class_visibility $class] != "Opaque" || \
  83. #           [get_class_visibility $type]  != "Opaque"} {
  84. #        ada95_error "Class '[get_name $class]' with a bidirectional association to class '[get_name $type]' must have 'Opaque' visibility"
  85. #    }
  86. #   }
  87. }
  88.  
  89. #
  90. # procedure operation::check
  91. #
  92.  
  93. if {[info commands operation::check_pre_ada95] == ""} {
  94.     rename operation::check operation::check_pre_ada95
  95. }
  96.  
  97. proc operation::check {oper class} {
  98.     operation::check_pre_ada95 $oper $class
  99.     set name [get_name $oper]
  100.     if {[is_oper $name]} {
  101.     set type [get_type $oper]
  102.     if {[get_name $type] == ""} {
  103.         ada95_error "Operation $name of class '[get_name $class]' must have a return type"
  104.     }
  105.     }
  106. }
  107.  
  108.  
  109. #
  110. # procedure parameter::check
  111. #
  112.  
  113. if {[info commands parameter::check_pre_ada95] == ""} {
  114.     rename parameter::check parameter::check_pre_ada95
  115. }
  116.  
  117. proc parameter::check {param oper class} {
  118.     parameter::check_pre_ada95 $param $oper $class
  119.     set type [get_type $oper]
  120.     if {[get_name $type] != ""} {
  121.     if {[get_param_dfd $param] != "" && [get_param_dfd $param] != "in"} {
  122.         ada95_error "Mode of parameter '[get_name $param]' in operation '[get_name $oper]' of class '[get_name $class]' returning '[get_name $type]' must be 'in'"
  123.     }
  124.     }
  125. }
  126.  
  127. #
  128. # redefined procedures from product-tcl/check_conf.tcl:
  129. #
  130.  
  131. #
  132. # procedure add_predefined_methods
  133. #
  134.  
  135. proc add_predefined_methods {ooplmodel} {
  136.     #
  137.     # Call user-supplied function to add methods
  138.     #
  139.     if {[info procs add_user_defined_methods] != ""} {
  140.         add_user_defined_methods $ooplmodel
  141.     }
  142. }
  143.  
  144. #
  145. # redefined procedures from product-tcl/prep_funcs.tcl
  146. #
  147.  
  148. proc data_attrib::prepare {attrib class model forwhat} {
  149. }
  150.