home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / fortegen.tcl < prev    next >
Encoding:
Text File  |  1997-06-06  |  14.3 KB  |  550 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1997 by Cayenne Software, 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 Cayenne Software, Inc.
  13. #
  14. #---------------------------------------------------------------------------
  15. #
  16. #       File            : fortegen.tcl
  17. #       Author          : 
  18. #       Original date   : May 1997
  19. #       Description     : Classes for code generation
  20. #
  21. #---------------------------------------------------------------------------
  22.  
  23. #---------------------------------------------------------------------------
  24. #      File:           @(#)ftconstant.tcl    /main/hindenburg/2
  25. #---------------------------------------------------------------------------
  26.  
  27. # Start user added include file section
  28. # End user added include file section
  29.  
  30.  
  31. Class FTConstants : {Object} {
  32.     constructor
  33.     method destructor
  34. }
  35.  
  36. global FTConstants::startCtor
  37. set FTConstants::startCtor "Start constructor user section"
  38.  
  39. global FTConstants::endCtor
  40. set FTConstants::endCtor "End constructor user section"
  41.  
  42. global FTConstants::obsoleteCode
  43. set FTConstants::obsoleteCode "OBSOLETE_CODE"
  44.  
  45. global FTConstants::oldCode
  46. set FTConstants::oldCode "OLDCODE"
  47.  
  48.  
  49. constructor FTConstants {class this} {
  50.     set this [Object::constructor $class $this $name]
  51.     # Start constructor user section
  52.     # End constructor user section
  53.     return $this
  54. }
  55.  
  56. method FTConstants::destructor {this} {
  57.     # Start destructor user section
  58.     # End destructor user section
  59. }
  60.  
  61. # Do not delete this line -- regeneration end marker
  62.  
  63. #---------------------------------------------------------------------------
  64. #      File:           @(#)ftfilehand.tcl    /main/hindenburg/2
  65. #---------------------------------------------------------------------------
  66.  
  67. # Start user added include file section
  68. # End user added include file section
  69.  
  70. require "filehandle.tcl"
  71.  
  72. Class FTFileHandler : {FileHandler} {
  73.     constructor
  74.     method destructor
  75.     method getSpecialFiles
  76.     method getFileTypes
  77.     attribute fileType
  78.     attribute xtraFileType
  79. }
  80.  
  81. constructor FTFileHandler {class this} {
  82.     set this [FileHandler::constructor $class $this]
  83.     $this fileType "cex"
  84.     $this xtraFileType "hex"
  85.     # Start constructor user section
  86.     # End constructor user section
  87.     return $this
  88. }
  89.  
  90. method FTFileHandler::destructor {this} {
  91.     # Start destructor user section
  92.     # End destructor user section
  93.     $this FileHandler::destructor
  94. }
  95.  
  96. method FTFileHandler::getSpecialFiles {this} {
  97.     return [List new]
  98. }
  99.  
  100. method FTFileHandler::getFileTypes {this} {
  101.     set list [List new]
  102.     $list append [$this fileType]
  103.     $list append [$this xtraFileType]
  104.     return $list
  105. }
  106.  
  107. # Do not delete this line -- regeneration end marker
  108.  
  109. #---------------------------------------------------------------------------
  110. #      File:           @(#)ftgenerato.tcl    /main/hindenburg/2
  111. #---------------------------------------------------------------------------
  112.  
  113. # Start user added include file section
  114. # End user added include file section
  115.  
  116. require "generator.tcl"
  117.  
  118. Class FTGenerator : {Generator} {
  119.     constructor
  120.     method destructor
  121.     method generate
  122.     attribute fileHandler
  123. }
  124.  
  125. constructor FTGenerator {class this} {
  126.     set this [Generator::constructor $class $this]
  127.     # Start constructor user section
  128.     $this fileHandler [FTFileHandler new]
  129.     # End constructor user section
  130.     return $this
  131. }
  132.  
  133. method FTGenerator::destructor {this} {
  134.     # Start destructor user section
  135.     # End destructor user section
  136.     $this Generator::destructor
  137. }
  138.  
  139. method FTGenerator::generate {this classList} {
  140.     set typeToClassDict [Dictionary new]
  141.     set tgtModel [FTModel new]
  142.     set regenerator [FTRegenerator new]
  143.     set fileType [[$this fileHandler] fileType]
  144.  
  145.     $classList foreach class {
  146.     $class generate $tgtModel
  147.  
  148.     set fileDesc [[$this fileHandler] openFile $class $fileType]
  149.     if {$fileDesc != ""} {
  150.         $regenerator regenerate $class $fileDesc $tgtModel
  151.         [$this fileHandler] closeFile $fileDesc
  152.     }
  153.     }
  154.  
  155.     $tgtModel generate $typeToClassDict
  156.     return $typeToClassDict
  157. }
  158.  
  159. # Do not delete this line -- regeneration end marker
  160.  
  161. #---------------------------------------------------------------------------
  162. #      File:           @(#)ftregenera.tcl    /main/hindenburg/5
  163. #---------------------------------------------------------------------------
  164.  
  165. # Start user added include file section
  166. # End user added include file section
  167.  
  168. require "regenerato.tcl"
  169.  
  170. Class FTRegenerator : {Regenerator} {
  171.     constructor
  172.     method destructor
  173.     method regenerate
  174.     method checkFile
  175.     method processClass
  176.     method processClassDecl
  177.     method processClassUserBody
  178.     method processClassInit
  179.     method processCursor
  180.     method makeObsolete
  181.     method hasSameKind
  182.     attribute tgtClass
  183. }
  184.  
  185. constructor FTRegenerator {class this} {
  186.     set this [Regenerator::constructor $class $this]
  187.     # Start constructor user section
  188.     # End constructor user section
  189.     return $this
  190. }
  191.  
  192. method FTRegenerator::destructor {this} {
  193.     # Start destructor user section
  194.     # End destructor user section
  195.     $this Regenerator::destructor
  196. }
  197.  
  198. method FTRegenerator::regenerate {this class fileDesc tgtModel} {
  199.     if {[$this checkFile $fileDesc]} {
  200.     m4_error $E_OBSOLETESECT [$class getName]
  201.     m4_warning $M_NO_REGEN [$class getName]
  202.     return
  203.     }
  204.  
  205.     $this tgtClass [$tgtModel findDefinition [$class getName]]
  206.     if {[$this tgtClass] == ""} {
  207.     # an error has occurred while GEnerating for this class, REgeneration
  208.     #  is needless
  209.     return
  210.     }
  211.  
  212.     set kind ""
  213.     while {![eof $fileDesc]} {
  214.     set line [gets $fileDesc]
  215.     if {[string match *begin* $line]} {
  216.         if {![regexp {^[- \t]*begin ([^;]+);$} $line dummy kind]} {
  217.         m4_warning $E_ILL_HEADER [$class getName] $line
  218.         m4_warning $M_NO_REGEN [$class getName]
  219.         return
  220.         }
  221.         break
  222.     }
  223.     }
  224.     if {$kind == ""} {
  225.     m4_warning $E_NO_HEADER [$class getName]
  226.     m4_warning $M_NO_REGEN [$class getName]
  227.     return
  228.     }
  229.  
  230.     # only CLASS and CURSOR are regenerated
  231.     #
  232.     if {$kind == "CLASS"} {
  233.     if {[$this hasSameKind $class $kind]} {
  234.         $this processClass $fileDesc
  235.     } else {
  236.         m4_warning $M_NO_REGEN [$class getName]
  237.     }
  238.     } elseif {$kind == "CURSOR"} {
  239.     if {[$this hasSameKind $class $kind]} {
  240.         $this processCursor $fileDesc
  241.     } else {
  242.         m4_warning $M_NO_REGEN [$class getName]
  243.     }
  244.     } else {
  245.     $this hasSameKind $class $kind
  246.     }
  247. }
  248.  
  249. method FTRegenerator::checkFile {this fileDesc} {
  250.     # check whether there is still OBSOLETE CODE in the file
  251.     #
  252.     while {![eof $fileDesc]} {
  253.     set line [gets $fileDesc]
  254.     if {[string match *${FTConstants::obsoleteCode}* $line]} {
  255.         seek $fileDesc 0
  256.         return 1
  257.     }
  258.     }
  259.     
  260.     seek $fileDesc 0
  261.     return 0
  262. }
  263.  
  264. method FTRegenerator::processClass {this fileDesc} {
  265.     set WS "\[ \t]*"
  266.     set WSn "\[ \t]+"
  267.     set state START
  268.     while {![eof $fileDesc]} {
  269.     set line [gets $fileDesc]
  270.     if {$state == "START"} {
  271.         if {[regexp "^${WS}class${WSn}" $line]} {
  272.         $this processClassDecl $fileDesc
  273.         set state DEF
  274.         }
  275.     } elseif {[regexp "^${WS}method${WSn}" $line]} {
  276.         $this processClassUserBody $fileDesc $line method
  277.     } elseif {[regexp "^${WS}event handler${WSn}" $line]} {
  278.         $this processClassUserBody $fileDesc $line event
  279.     }
  280.     }
  281. }
  282.  
  283. method FTRegenerator::processClassDecl {this fileDesc} {
  284.     # class declaration -> props, map
  285.     #
  286.     set WS "\[ \t]*"
  287.     set WSn "\[ \t]+"
  288.     set state START
  289.     while {![eof $fileDesc]} {
  290.     set line [gets $fileDesc]
  291.     if {[regexp "^${WS}end${WS}class${WS};" $line]} {
  292.         return
  293.     } elseif {[regexp "^${WS}$" $line]} {
  294.         continue
  295.     } elseif {[regexp "^${WS}has${WS}property" $line]} {
  296.         set sect [[[$this tgtClass] sections] getSection property]
  297.         if {$sect != ""} {
  298.         $sect append "$line\n"
  299.         set state PROPS
  300.         }
  301.     } elseif {[regexp "^${WS}has${WS}$" $line]} {
  302.         set sect [[[$this tgtClass] sections] getSection map]
  303.         if {$sect != ""} {
  304.         set state MAP1
  305.         }
  306.     } elseif {[regexp "^\[-+]" $line]} {
  307.         if {$state == "MAP1"} {
  308.         $sect append "has\n"
  309.         set state MAP
  310.         }
  311.         if {$state == "MAP"} {
  312.         $sect append "$line\n"
  313.         }
  314.         if {[regexp "^-" $line]} {
  315.         set state END
  316.         }
  317.     } elseif {$state == "PROPS"} {
  318.         $sect append "$line\n"
  319.     }
  320.     }
  321. }
  322.  
  323. method FTRegenerator::processClassUserBody {this fileDesc line kind} {
  324.     # kind is one of method, event (meaning "event handler")
  325.     # Init -> user sect
  326.     # methods, event handlers -> body
  327.     #
  328.     set methSect [TextSection new]
  329.     $methSect append "$line\n"
  330.  
  331.     set name ""
  332.     set WS "\[ \t]*"
  333.     set kind2 $kind
  334.     if {$kind == "event"} {
  335.     set kind2 "event handler"
  336.     }
  337.     # ^ <kind> <system> '.' <name>
  338.     regexp "^${WS}$kind2${WS}\[^.]+\.(\[_0-9A-Za-z]+)" $line dummy name
  339.  
  340.     set tgtMethods [[$this tgtClass] findMethods $name $kind]
  341.     if {[llength $tgtMethods] == 0} {
  342.     # no method found, make OBSOLETE
  343.     #
  344.     m4_warning $W_OBSOLETECODE [[$this tgtClass] name] $name
  345.     $this makeObsolete $fileDesc $methSect $kind
  346.     return
  347.     }
  348.     if {[llength $tgtMethods] == 1 && [[lindex $tgtMethods 0] isGenerated]} {
  349.     # the method that was found, has been generated; we guess that the user
  350.     # did not overload it
  351.     #
  352.     return
  353.     }
  354.  
  355.     # special treatment for method 'Init'
  356.     #
  357.     if {$name == "Init"} {
  358.     $this processClassInit $fileDesc [lindex $tgtMethods 0]
  359.     return
  360.     }
  361.  
  362.     # create a list of the method's parameter types
  363.     # find out the return type of the method
  364.     #
  365.     set parTypes {}
  366.     set parType ""
  367.     # read 1st param, i.e. '(' <name> ':' <type>
  368.     #   may be followed by '=' or ',' or ')'
  369.     regexp "\\(\[^:)]*:${WS}(\[^=,)]*)" $line dummy parType
  370.     if {[string trim $parType] != ""} {
  371.     lappend parTypes [string trim $parType]
  372.     }
  373.     set methType ""
  374.     if {$kind == "method"} {
  375.     # read method type, i.e. ':' ["copy"] <type>
  376.     regexp ":${WS}(\[^:=,)]*)$" $line dummy methType
  377.     }
  378.  
  379.     while {![eof $fileDesc]} {
  380.     set line [gets $fileDesc]
  381.     $methSect append "$line\n"
  382.     if {[regexp "^${WS}begin${WS}$" $line]} {
  383.         break
  384.     } elseif {[regexp "^${WS}end${WS}$kind" $line]} {
  385.         break
  386.     } else {
  387.         set parType ""
  388.         # read 2nd param, i.e. <name> ':' <type>
  389.         #   may be followed by '=' or ',' or ')'
  390.         regexp "\[^:)]*:${WS}(\[^=,)]*)" $line dummy parType
  391.         if {[string trim $parType] != ""} {
  392.         lappend parTypes [string trim $parType]
  393.         }
  394.         if {$kind == "method" && $methType == ""} {
  395.         # read method type, i.e. ':' ["copy"] <type>
  396.         regexp ":${WS}(\[^:=,)]*)$" $line dummy methType
  397.         }
  398.     }
  399.     }
  400.     if {$kind == "method"} {
  401.     regsub "${WS}copy${WS}" $methType "" methType
  402.     set methType [string trim $methType]
  403.     }
  404.  
  405.     # now, find the best match possible
  406.     # first one found will be taken
  407.     #
  408.     set tgtMethod ""
  409.     set properMatch 0
  410.     foreach mx [[$this tgtClass] findMethodsX $name $kind] {
  411.     set meth [lindex $mx 0]
  412.     if {[$meth isGenerated] || [$meth userCode] != ""} {
  413.         continue
  414.     }
  415.  
  416.     set parTypesX [lindex [lindex $mx 1] 0]
  417.     if {$parTypesX != $parTypes} {
  418.         if {$tgtMethod == ""} {
  419.         set tgtMethod $meth
  420.         }
  421.         continue
  422.     }
  423.  
  424.     set methTypeX [lindex [lindex $mx 1] 1]
  425.     if {$methTypeX != $methType} {
  426.         if {$tgtMethod == ""} {
  427.         set tgtMethod $meth
  428.         }
  429.         continue
  430.     }
  431.  
  432.     set tgtMethod $meth
  433.     set properMatch 1
  434.     break
  435.     }
  436.  
  437.     # no method found: make OBSOLETE
  438.     #
  439.     if {$tgtMethod == ""} {
  440.     m4_warning $W_OBSOLETECODE [[$this tgtClass] name] $name
  441.     $this makeObsolete $fileDesc $methSect $kind
  442.     return
  443.     }
  444.  
  445.     # no proper match: generate OLDCODE
  446.     #
  447.     if {!$properMatch} {
  448.     $tgtMethod hasOldCode 1
  449.     }
  450.  
  451.     # regenerate
  452.     #
  453.     set sect ""
  454.     while {![eof $fileDesc]} {
  455.     set line [gets $fileDesc]
  456.     if {[regexp "^${WS}end${WS}$kind" $line]} {
  457.         return
  458.     } else {
  459.         if {$sect == ""} {
  460.         set sect [$tgtMethod getUserCode]
  461.         }
  462.         $sect append "$line\n"
  463.     }
  464.     }
  465. }
  466.  
  467. method FTRegenerator::processClassInit {this fileDesc tgtMethod} {
  468.     set sect ""
  469.     set WS "\[ \t]*"
  470.     set state START
  471.     while {![eof $fileDesc]} {
  472.     set line [gets $fileDesc]
  473.     if {[regexp "^${WS}end${WS}method" $line]} {
  474.         return
  475.     } elseif {[string match *${FTConstants::startCtor} $line]} {
  476.         set state COPY
  477.     } elseif {[string match *${FTConstants::endCtor} $line]} {
  478.         return
  479.     } elseif {$state == "COPY"} {
  480.         if {$sect == ""} {
  481.         set sect [$tgtMethod getUserCode]
  482.         }
  483.         $sect append "$line\n"
  484.     }
  485.     }
  486. }
  487.  
  488. method FTRegenerator::processCursor {this fileDesc} {
  489.     # all lines between "begin" and the final "end;" line will be regenerated
  490.     #
  491.     set tgtMethod [[[$this tgtClass] methSet] index 0]
  492.     set sect ""
  493.     set WS "\[ \t]*"
  494.     set state START
  495.     while {![eof $fileDesc]} {
  496.     set line [gets $fileDesc]
  497.     if {$state == "START"} {
  498.         if {[regexp "^${WS}begin${WS}$" $line]} {
  499.         set state BODY
  500.         }
  501.     } elseif {[regexp "^${WS}end${WS};${WS}$" $line]} {
  502.         if {$state == "BODY"} {
  503.         set state OPT_BODY
  504.         } else {
  505.         # state == OPT_BODY
  506.         $sect appendSect $optSect
  507.         }
  508.         set optSect [TextSection new]
  509.         $optSect append "$line\n"
  510.     } elseif {$state == "BODY"} {
  511.         if {$sect == ""} {
  512.         set sect [$tgtMethod getUserCode]
  513.         }
  514.         $sect append "$line\n"
  515.     } else {
  516.         # state == OPT_BODY
  517.         $optSect append "$line\n"
  518.     }
  519.     }
  520. }
  521.  
  522. method FTRegenerator::makeObsolete {this fileDesc methSect kind} {
  523.     set sect [[[$this tgtClass] sections] getSection obsolete]
  524.     if {$sect == ""} {
  525.     return
  526.     }
  527.     $sect appendSect $methSect
  528.     set WS "\[ \t]*"
  529.     while {![eof $fileDesc]} {
  530.     set line [gets $fileDesc]
  531.     $sect append "$line\n"
  532.     if {[regexp "^${WS}end${WS}$kind" $line]} {
  533.         break
  534.     }
  535.     }
  536.     $sect append "\n"
  537. }
  538.  
  539. method FTRegenerator::hasSameKind {this class kind} {
  540.     if {$kind == [[$this tgtClass] kind]} {
  541.     return 1
  542.     }
  543.  
  544.     m4_warning $W_KIND_CHANGE [$class getName] $kind [[$this tgtClass] kind]
  545.     return 0
  546. }
  547.  
  548. # Do not delete this line -- regeneration end marker
  549.  
  550.