home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / langchecks.tcl < prev    next >
Text File  |  1997-10-20  |  5KB  |  157 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 95 Diagram Checker"
  19.  
  20. source [m4_path_name tcl ada95_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 ada95_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 ada95_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. # TBD - this won't be called anymore
  48. proc show_errors {} {
  49.     m4_message $M_NEWLINE
  50.     m4_message $M_ERRORS [M4CheckManager::getErrorCount]
  51.     m4_message $M_WARNINGS [M4CheckManager::getWarningCount]
  52.     m4_fmt_message "Ada Errors: $g_ada_errors"
  53. }
  54.  
  55.  
  56. #
  57. # redefined method CMCmnClass::checkClassAttributes
  58. #
  59.  
  60. #
  61. # method CMCmnClass::checkClassAttributes
  62. #
  63.  
  64. rename CMCmnClass::checkClassAttributes CMCmnClass::orgCheckClassAttributes
  65.  
  66. method CMCCmnClass::checkClassAttributes {this} {
  67.     CMCmnClass::orgCheckClassAttributes $this
  68.     set dataAttribs [$this findDataAttrs 1]
  69.     foreach attrib $dataAttribs {
  70.        set access [get_attrib_access $attrib]
  71.        if {"$access" != "" && "$access" != "Public-Public"} {
  72.        if {[get_class_visibility $this] == "Public"} {
  73.           ada95_error "Class '[get_name $this]' with 'Public' visibility has attribute '[get_name $attrib]' with '[get_attrib_access $attrib]' access"
  74.        }
  75.     }
  76.     set assocAttribs [$this findAssocAttris 1]
  77.     foreach attrib $assocAttribs {
  78.        set access [get_attrib_access $attrib]
  79.        if {"$access" != "" && "$access" != "Public-Public"} {
  80.         if {[get_class_visibility $this] == "Public"} {
  81.             ada95_error "Class '[get_name $this]' with 'Public' visibility has link or association attribute '[get_name $attrib]' with '[get_assoc_access $attrib]' access"
  82.         }
  83.         }
  84.         if {[get_opposite $attrib] != ""} {
  85.         set type [get_type $attrib]
  86.         if {[get_class_visibility $this] != "Opaque" || \
  87.                [get_class_visibility $type]  != "Opaque"} {
  88.             ada95_error "Class '[get_name $this]' has a bidirectional association to class '[get_name $type]' - this is currently unsupported"
  89.         }
  90.         }
  91.     }
  92. }
  93.  
  94. #
  95. # Redefine method CMCmnClass::checkClassOperations
  96. #
  97. rename CMCmnClass::checkClassOperations CMCmnClass::orgCheckClassOperations
  98.  
  99. method CMCmnClass::checkClassOperations {this} {
  100.     CMCmnClass::orgCheckClassOperations {this}
  101.     set opers [$this operationSet]
  102.     foreach oper $opers {
  103.     {
  104.        set name [get_name $oper]
  105.        if {[is_oper $name]} {
  106.       set type [get_type $oper]
  107.       if {[get_name $type] == ""} {
  108.          ada95_error "Operation $name of class '[get_name $class]' must have a return type"
  109.        }
  110.     }
  111. }
  112.  
  113.  
  114. #
  115. # method CMParamter::mcheck {this oper class}
  116. #
  117.  
  118. # tbd looks like this is called with only param and class (chkmodel.tcl)
  119.  
  120. rename CMParameter::mcheck CMParameter::orgMcheck 
  121.  
  122. method CMParameter::mcheck {this oper class} {
  123.     CMParameter::orgMcheck $this $oper $class
  124.     set type [get_type $oper]
  125.     if {[get_name $type] != ""} {
  126.     if {[get_param_dfd $this] != "" && [get_param_dfd $this] != "in"} {
  127.         ada95_error "Mode of parameter '[get_name $this]' in operation '[get_name $oper]' of class '[get_name $class]' returning '[get_name $type]' must be 'in'"
  128.     }
  129.     }
  130. }
  131.  
  132. #
  133. # redefined procedures from product-tcl/check_conf.tcl:
  134. #
  135.  
  136. #
  137. # procedure add_predefined_methods
  138. #
  139.  
  140. proc add_predefined_methods {ooplmodel} {
  141.     #
  142.     # Call user-supplied function to add methods
  143.     #
  144.     if {[info procs add_user_defined_methods] != ""} {
  145.         add_user_defined_methods $ooplmodel
  146.     }
  147. }
  148.  
  149. #
  150. # redefine method CDMDataAttr::prepare
  151. #
  152.  
  153. method CMDataAttr::prepare {this class model forwhat} {
  154. }
  155.  
  156.  
  157.