home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / langchecks.tcl < prev    next >
Text File  |  1997-03-24  |  5KB  |  163 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. puts "\nObjectTeam for OMT 4.0 Ada 83 Diagram Checker"
  19.  
  20. source [m4_path_name tcl ada_funcs.tcl]
  21.  
  22. #HM added g_ada_errors
  23. global g_ada_errors
  24. set g_ada_errors 0
  25.  
  26. #
  27. # miscellaneous utility procedures:
  28. #
  29. proc ada_error {error_msg} {
  30.     global g_ada_errors
  31.  
  32.     m4_fmt_message "ERROR: (Ada) $error_msg"
  33.     incr g_ada_errors 1
  34. }
  35.  
  36. proc ada_notes {notes_txt} {
  37.     m4_fmt_message "NOTES: (Ada) $notes_txt\n"
  38. }
  39.  
  40. #
  41. # redefined procedures from check_util.tcl
  42. #
  43.  
  44. #
  45. # Function to show the errors and warnings.
  46. #
  47. proc show_errors {} {
  48.     m4_message $M_NEWLINE
  49.     m4_message $M_ERRORS [M4CheckManager::getErrorCount]
  50.     m4_message $M_WARNINGS [M4CheckManager::getWarningCount]
  51.     m4_fmt_message "Ada Errors: $g_ada_errors"
  52. }
  53.  
  54.  
  55. #
  56. # redefined procedures from product-tcl/chk_funcs.tcl:
  57. #
  58.  
  59. #
  60. # procedure data_attrib::check
  61. #
  62.  
  63. if {[info commands data_attrib::check_pre_ada] == ""} {
  64.     rename data_attrib::check data_attrib::check_pre_ada
  65. }
  66.  
  67. proc data_attrib::check {attrib class} {
  68.     data_attrib::check_pre_ada $attrib $class
  69.     set access [get_attrib_access $attrib]
  70.     if {"$access" != "" && "$access" != "Public-Public"} {
  71.     if {[get_class_visibility $class] == "Public"} {
  72.         ada_error "Class '[get_name $class]' with 'Public' visibility has attribute '[get_name $attrib]' with '[get_attrib_access $attrib]' access"
  73.     }
  74.     }
  75. }
  76.  
  77. #
  78. # procedure assoc_attrib::check
  79. #
  80.  
  81. if {[info commands assoc_attrib::check_pre_ada] == ""} {
  82.     rename assoc_attrib::check assoc_attrib::check_pre_ada
  83. }
  84.  
  85. proc assoc_attrib::check {attrib class} {
  86.     assoc_attrib::check_pre_ada $attrib $class
  87.     set access [get_assoc_access $attrib]
  88.     if {"$access" != "" && "$access" != "Public-Public"} {
  89.     if {[get_class_visibility $class] == "Public"} {
  90.         ada_error "Class '[get_name $class]' with 'Public' visibility has link or association attribute '[get_name $attrib]' with '[get_assoc_access $attrib]' access"
  91.     }
  92.     }
  93.     if {[get_opposite $attrib] != ""} {
  94.     set type [get_type $attrib]
  95.     if {[get_class_visibility $class] != "Opaque" || \
  96.            [get_class_visibility $type]  != "Opaque"} {
  97.         ada_error "Class '[get_name $class]' has a bidirectional association to class '[get_name $type]' - this is currently unsupported"
  98.     }
  99.    }
  100. }
  101.  
  102. #
  103. # procedure operation::check
  104. #
  105.  
  106. if {[info commands operation::check_pre_ada] == ""} {
  107.     rename operation::check operation::check_pre_ada
  108. }
  109.  
  110. proc operation::check {oper class} {
  111.     operation::check_pre_ada $oper $class
  112.     set name [get_name $oper]
  113.     if {[is_oper $name]} {
  114.     set type [get_type $oper]
  115.     if {[get_name $type] == ""} {
  116.         ada_error "Operation $name of class '[get_name $class]' must have a return type"
  117.     }
  118.     }
  119. }
  120.  
  121.  
  122. #
  123. # procedure parameter::check
  124. #
  125.  
  126. if {[info commands parameter::check_pre_ada] == ""} {
  127.     rename parameter::check parameter::check_pre_ada
  128. }
  129.  
  130. proc parameter::check {param oper class} {
  131.     parameter::check_pre_ada $param $oper $class
  132.     set type [get_type $oper]
  133.     if {[get_name $type] != ""} {
  134.     if {[get_param_dfd $param] != "" && [get_param_dfd $param] != "in"} {
  135.         ada_error "Mode of parameter '[get_name $param]' in operation '[get_name $oper]' of class '[get_name $class]' returning '[get_name $type]' must be 'in'"
  136.     }
  137.     }
  138. }
  139.  
  140. #
  141. # redefined procedures from product-tcl/check_conf.tcl:
  142. #
  143.  
  144. #
  145. # procedure add_predefined_methods
  146. #
  147.  
  148. proc add_predefined_methods {ooplmodel} {
  149.     #
  150.     # Call user-supplied function to add methods
  151.     #
  152.     if {[info procs add_user_defined_methods] != ""} {
  153.         add_user_defined_methods $ooplmodel
  154.     }
  155. }
  156.  
  157. #
  158. # redefined procedures from product-tcl/prep_funcs.tcl
  159. #
  160.  
  161. proc data_attrib::prepare {attrib class model forwhat} {
  162. }
  163.