home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
PC World 1998 October
/
PCWorld_1998-10_cd.bin
/
software
/
prehled
/
komix
/
DATA.Z
/
fortegen.tcl
< prev
next >
Wrap
Text File
|
1997-12-01
|
19KB
|
723 lines
#---------------------------------------------------------------------------
#
# Copyright (c) 1997 by Cayenne Software, Inc.
#
# This software is furnished under a license and may be used only in
# accordance with the terms of such license and with the inclusion of
# the above copyright notice. This software or any other copies thereof
# may not be provided or otherwise made available to any other person.
# No title to and ownership of the software is hereby transferred.
#
# The information in this software is subject to change without notice
# and should not be construed as a commitment by Cayenne Software, Inc.
#
#---------------------------------------------------------------------------
#
# File : fortegen.tcl
# Author :
# Original date : November 1997
# Description : Classes for code generation
#
#---------------------------------------------------------------------------
#---------------------------------------------------------------------------
# File: @(#)ftconstant.tcl /main/titanic/4
#---------------------------------------------------------------------------
# Start user added include file section
# End user added include file section
Class FTConstants : {Object} {
constructor
method destructor
}
global FTConstants::startCtor
set FTConstants::startCtor "Start constructor user section"
global FTConstants::endCtor
set FTConstants::endCtor "End constructor user section"
global FTConstants::obsoleteCode
set FTConstants::obsoleteCode "OBSOLETE_CODE"
global FTConstants::oldCode
set FTConstants::oldCode "OLDCODE"
global FTConstants::attribute
set FTConstants::attribute "User-defined attributes"
global FTConstants::constant
set FTConstants::constant ${FTConstants::attribute}
global FTConstants::virtualAttribute
set FTConstants::virtualAttribute ${FTConstants::attribute}
global FTConstants::assocAttribute
set FTConstants::assocAttribute "Association attributes"
global FTConstants::method
set FTConstants::method "User-defined methods"
global FTConstants::event
set FTConstants::event ${FTConstants::method}
global FTConstants::eventHandler
set FTConstants::eventHandler ${FTConstants::method}
global FTConstants::attribAccessMethod
set FTConstants::attribAccessMethod "Attribute accessor methods"
global FTConstants::assocAccessMethod
set FTConstants::assocAccessMethod "Association accessor methods"
constructor FTConstants {class this} {
set this [Object::constructor $class $this $name]
# Start constructor user section
# End constructor user section
return $this
}
method FTConstants::destructor {this} {
# Start destructor user section
# End destructor user section
}
# Do not delete this line -- regeneration end marker
#---------------------------------------------------------------------------
# File: @(#)ftfilehand.tcl /main/titanic/2
#---------------------------------------------------------------------------
# Start user added include file section
# End user added include file section
require "filehandle.tcl"
Class FTFileHandler : {FileHandler} {
constructor
method destructor
method getSpecialFiles
method getFileTypes
attribute fileType
attribute xtraFileType
}
constructor FTFileHandler {class this} {
set this [FileHandler::constructor $class $this]
$this fileType "cex"
$this xtraFileType "hex"
# Start constructor user section
# End constructor user section
return $this
}
method FTFileHandler::destructor {this} {
# Start destructor user section
# End destructor user section
$this FileHandler::destructor
}
method FTFileHandler::getSpecialFiles {this} {
return [List new]
}
method FTFileHandler::getFileTypes {this} {
set list [List new]
$list append [$this fileType]
$list append [$this xtraFileType]
return $list
}
# Do not delete this line -- regeneration end marker
#---------------------------------------------------------------------------
# File: @(#)ftgenerato.tcl /main/titanic/3
#---------------------------------------------------------------------------
# Start user added include file section
# End user added include file section
require "generator.tcl"
Class FTGenerator : {Generator} {
constructor
method destructor
method generate
method check
attribute fileHandler
}
constructor FTGenerator {class this} {
set this [Generator::constructor $class $this]
# Start constructor user section
$this fileHandler [FTFileHandler new]
# End constructor user section
return $this
}
method FTGenerator::destructor {this} {
# Start destructor user section
# End destructor user section
$this Generator::destructor
}
method FTGenerator::generate {this classList} {
set typeToClassDict [Dictionary new]
set tgtModel [FTModel new]
set regenerator [FTRegenerator new]
set fileType [[$this fileHandler] fileType]
$classList foreach class {
$class generate $tgtModel
set fileDesc [[$this fileHandler] openFile $class $fileType]
if {$fileDesc != ""} {
$regenerator regenerate $class $fileDesc $tgtModel
[$this fileHandler] closeFile $fileDesc
}
}
$tgtModel generate $typeToClassDict
return $typeToClassDict
}
method FTGenerator::check {this classList} {
set tgtModel [FTModel new]
$classList foreach class {
#
# we check a class by generating it with 'checkOnly' on
#
$class generate $tgtModel 1
}
}
# Do not delete this line -- regeneration end marker
#---------------------------------------------------------------------------
# File: @(#)ftregenera.tcl /main/titanic/7
#---------------------------------------------------------------------------
# Start user added include file section
# End user added include file section
require "regenerato.tcl"
Class FTRegenerator : {Regenerator} {
constructor
method destructor
method regenerate
method checkFile
method processClass
method processClassDecl
method processClassUserBody
method processClassUserBodies
method processClassInit
method processCursor
method makeOldCode
method makeObsolete
method hasSameKind
attribute tgtClass
}
constructor FTRegenerator {class this} {
set this [Regenerator::constructor $class $this]
# Start constructor user section
# End constructor user section
return $this
}
method FTRegenerator::destructor {this} {
# Start destructor user section
# End destructor user section
$this Regenerator::destructor
}
method FTRegenerator::regenerate {this class fileDesc tgtModel} {
if {[$this checkFile $fileDesc]} {
m4_error $E_OBSOLETESECT [$class getName]
m4_warning $M_NO_REGEN [$class getName]
return
}
$this tgtClass [$tgtModel findDefinition [$class getName]]
if {[$this tgtClass] == ""} {
# an error has occurred while GEnerating for this class, REgeneration
# is needless
return
}
set kind ""
while {![eof $fileDesc]} {
set line [gets $fileDesc]
if {[string match *begin* $line]} {
if {![regexp {^[- \t]*begin ([^;]+);$} $line dummy kind]} {
m4_warning $E_ILL_HEADER [$class getName] $line
m4_warning $M_NO_REGEN [$class getName]
return
}
break
}
}
if {$kind == ""} {
m4_warning $E_NO_HEADER [$class getName]
m4_warning $M_NO_REGEN [$class getName]
return
}
# only CLASS and CURSOR are regenerated
#
if {$kind == "CLASS"} {
if {[$this hasSameKind $class $kind]} {
$this processClass $fileDesc
} else {
m4_warning $M_NO_REGEN [$class getName]
}
} elseif {$kind == "CURSOR"} {
if {[$this hasSameKind $class $kind]} {
$this processCursor $fileDesc
} else {
m4_warning $M_NO_REGEN [$class getName]
}
} else {
$this hasSameKind $class $kind
}
}
method FTRegenerator::checkFile {this fileDesc} {
# check whether there is still OBSOLETE CODE in the file
#
while {![eof $fileDesc]} {
set line [gets $fileDesc]
if {[string match *${FTConstants::obsoleteCode}* $line]} {
seek $fileDesc 0
return 1
}
}
seek $fileDesc 0
return 0
}
method FTRegenerator::processClass {this fileDesc} {
set WS "\[ \t]*"
set WSn "\[ \t]+"
set state START
set methInfos [List new]
while {![eof $fileDesc]} {
set line [gets $fileDesc]
if {$state == "START"} {
if {[regexp "^${WS}class${WSn}" $line]} {
$this processClassDecl $fileDesc
set state DEF
}
} elseif {[regexp "^${WS}method${WSn}" $line]} {
set methInfo [$this processClassUserBody $fileDesc $line method]
if {$methInfo != {}} {
$methInfos append $methInfo
}
} elseif {[regexp "^${WS}event handler${WSn}" $line]} {
set methInfo [$this processClassUserBody $fileDesc $line event]
if {$methInfo != {}} {
$methInfos append $methInfo
}
}
}
if {![$methInfos empty]} {
$this processClassUserBodies $methInfos
}
}
method FTRegenerator::processClassDecl {this fileDesc} {
# class declaration -> props, map
#
set WS "\[ \t]*"
set WSn "\[ \t]+"
set state START
while {![eof $fileDesc]} {
set line [gets $fileDesc]
if {[regexp "^${WS}end${WS}class${WS};" $line]} {
return
} elseif {[regexp "^${WS}$" $line]} {
continue
} elseif {[regexp "^${WS}--" $line]} {
continue
} elseif {[regexp "^${WS}has${WS}property" $line]} {
set sect [[[$this tgtClass] sections] getSection property]
if {$sect != ""} {
$sect append "$line\n"
set state PROPS
}
} elseif {[regexp "^${WS}has${WS}$" $line]} {
set sect [[[$this tgtClass] sections] getSection map]
if {$sect != ""} {
set state MAP1
}
} elseif {[regexp "^\[-+]" $line]} {
if {$state == "MAP1"} {
$sect append "has\n"
set state MAP
}
if {$state == "MAP"} {
$sect append "$line\n"
}
if {[regexp "^-" $line]} {
set state END
}
} elseif {$state == "PROPS"} {
$sect append "$line\n"
}
}
}
method FTRegenerator::processClassUserBody {this fileDesc line kind} {
# kind is one of method, event (meaning "event handler")
# Init -> user sect
# methods, event handlers -> body
#
set signSect [TextSection new]
$signSect append "$line\n"
set name ""
set WS "\[ \t]*"
set kind2 $kind
if {$kind == "event"} {
set kind2 "event handler"
}
# ^ <kind> <system> '.' <name>
regexp "^${WS}$kind2${WS}\[^.]+\.(\[_0-9A-Za-z]+)" $line dummy name
set tgtMethods [[$this tgtClass] findMethods $name $kind]
if {[llength $tgtMethods] == 0} {
# no method found, make OBSOLETE
#
m4_warning $W_OBSOLETECODE [[$this tgtClass] name] $name
$this makeObsolete $fileDesc $signSect $kind
return ""
}
if {[llength $tgtMethods] == 1 && [[lindex $tgtMethods 0] isGenerated]} {
# the method that was found, has been generated; we guess that the user
# did not overload it
#
return ""
}
# special treatment for method 'Init'
#
if {$name == "Init"} {
$this processClassInit $fileDesc [lindex $tgtMethods 0]
return ""
}
# create a list of the method's parameter types
# find out the return type of the method
#
set parTypes {}
set parType ""
# read 1st param, i.e. '(' <name> ':' <type>
# may be followed by '=' or ',' or ')'
regexp "\\(\[^:)]*:${WS}(\[^=,)]*)" $line dummy parType
if {[string trim $parType] != ""} {
lappend parTypes [string trim $parType]
}
set methType ""
if {$kind == "method"} {
# read method type, i.e. ':' ["copy"] <type>
regexp ":${WS}(\[^:=,)]*)$" $line dummy methType
}
set beginLine ""
set endLine ""
while {![eof $fileDesc]} {
set line [gets $fileDesc]
if {[regexp "^${WS}begin${WS}$" $line]} {
set beginLine $line
break
} elseif {[regexp "^${WS}end${WS}$kind" $line]} {
set endLine $line
break
} else {
$signSect append "$line\n"
set parType ""
# read 2nd param, i.e. <name> ':' <type>
# may be followed by '=' or ',' or ')'
regexp "\[^:)]*:${WS}(\[^=,)]*)" $line dummy parType
if {[string trim $parType] != ""} {
lappend parTypes [string trim $parType]
}
if {$kind == "method" && $methType == ""} {
# read method type, i.e. ':' ["copy"] <type>
regexp ":${WS}(\[^:=,)]*)$" $line dummy methType
}
}
}
if {$kind == "method"} {
regsub "${WS}copy${WS}" $methType "" methType
set methType [string trim $methType]
}
# now, find a full match
#
foreach mx [[$this tgtClass] findMethodsX $name $kind] {
set meth [lindex $mx 0]
if {[$meth isGenerated] || [$meth userCode] != ""} {
continue
}
set parTypesX [lindex [lindex $mx 1] 0]
set methTypeX [lindex [lindex $mx 1] 1]
if {$parTypesX == $parTypes && $methTypeX == $methType} {
# regenerate
#
set sect [$meth getUserCode]
while {![eof $fileDesc]} {
set line [gets $fileDesc]
if {[regexp "^${WS}end${WS}$kind" $line]} {
break
} else {
$sect append "$line\n"
}
}
return ""
}
}
# no full match: remember next things
#
# - kind name parTypes methType
# - signSect
# - beginLine
# - bodySect (to be read)
# - endLine
#
set bodySect [TextSection new]
if {$endLine == ""} {
while {![eof $fileDesc]} {
set line [gets $fileDesc]
if {[regexp "^${WS}end${WS}$kind" $line]} {
set endLine $line
break
} else {
$bodySect append "$line\n"
}
}
}
# this is dirty, but hey, what did you expect after the preceding...
#
return [list [list $kind $name $parTypes $methType] $signSect $beginLine $bodySect $endLine]
}
method FTRegenerator::processClassUserBodies {this methodInfos} {
# process all methods in the code that have no full match in the model
#
set m2Infos [List new]
$methodInfos foreach mInfo {
set tmp [lindex $mInfo 0]
set kind [lindex $tmp 0]
set name [lindex $tmp 1]
set parTypes [lindex $tmp 2]
set methType [lindex $tmp 3]
# find the first full parameter list match
#
set found 0
if {![info exists mxs($name.$kind)]} {
set mxs($name.$kind) [[$this tgtClass] findMethodsX $name $kind]
}
foreach mx $mxs($name.$kind) {
set meth [lindex $mx 0]
if {[$meth isGenerated] || [$meth userCode] != ""} {
continue
}
set parTypesX [lindex [lindex $mx 1] 0]
if {$parTypesX == $parTypes} {
$this makeOldCode $meth $mInfo $mx
set found 1
break
}
}
if {!$found} {
$m2Infos append $mInfo
}
}
set m3Infos [List new]
$m2Infos foreach mInfo {
set tmp [lindex $mInfo 0]
set kind [lindex $tmp 0]
set name [lindex $tmp 1]
set parTypes [lindex $tmp 2]
set methType [lindex $tmp 3]
# find the first return type match
#
set found 0
foreach mx $mxs($name.$kind) {
set meth [lindex $mx 0]
if {[$meth isGenerated] || [$meth userCode] != ""} {
continue
}
set methTypeX [lindex [lindex $mx 1] 1]
if {$methTypeX == $methType} {
$this makeOldCode $meth $mInfo $mx
set found 1
break
}
}
if {!$found} {
$m3Infos append $mInfo
}
}
$m3Infos foreach mInfo {
set tmp [lindex $mInfo 0]
set kind [lindex $tmp 0]
set name [lindex $tmp 1]
set parTypes [lindex $tmp 2]
set methType [lindex $tmp 3]
# get the first available method
#
set found 0
foreach mx $mxs($name.$kind) {
set meth [lindex $mx 0]
if {[$meth isGenerated] || [$meth userCode] != ""} {
continue
}
$this makeOldCode $meth $mInfo $mx
set found 1
break
}
if {!$found} {
# no method found: make OBSOLETE
#
set name "$name\($parTypes)"
if {$methType != ""} {
set name "$name: $methType"
}
m4_warning $W_OBSOLETECODE [[$this tgtClass] name] $name
set sect [[[$this tgtClass] sections] getSection obsolete]
if {$sect != ""} {
$sect appendSect [lindex $mInfo 1]
$sect append "[lindex $mInfo 2]\n"
$sect appendSect [lindex $mInfo 3]
$sect append "[lindex $mInfo 4]\n"
$sect append "\n"
}
}
}
}
method FTRegenerator::processClassInit {this fileDesc tgtMethod} {
set sect ""
set WS "\[ \t]*"
set state START
while {![eof $fileDesc]} {
set line [gets $fileDesc]
if {[regexp "^${WS}end${WS}method" $line]} {
return
} elseif {[string match *${FTConstants::startCtor} $line]} {
set state COPY
} elseif {[string match *${FTConstants::endCtor} $line]} {
return
} elseif {$state == "COPY"} {
if {$sect == ""} {
set sect [$tgtMethod getUserCode]
}
$sect append "$line\n"
}
}
}
method FTRegenerator::processCursor {this fileDesc} {
# all lines between "begin" and the final "end;" line will be regenerated
#
set tgtMethod [[[$this tgtClass] methSet] index 0]
set sect ""
set WS "\[ \t]*"
set state START
while {![eof $fileDesc]} {
set line [gets $fileDesc]
if {$state == "START"} {
if {[regexp "^${WS}begin${WS}$" $line]} {
set state BODY
}
} elseif {[regexp "^${WS}end${WS};${WS}$" $line]} {
if {$state == "BODY"} {
set state OPT_BODY
} else {
# state == OPT_BODY
$sect appendSect $optSect
}
set optSect [TextSection new]
$optSect append "$line\n"
} elseif {$state == "BODY"} {
if {$sect == ""} {
set sect [$tgtMethod getUserCode]
}
$sect append "$line\n"
} else {
# state == OPT_BODY
$optSect append "$line\n"
}
}
}
method FTRegenerator::makeOldCode {this method codeInfo modelInfo} {
# generate OLDCODE
#
set tmp [lindex $codeInfo 0]
set kind [lindex $tmp 0]
set name [lindex $tmp 1]
set parTypes [lindex $tmp 2]
set methType [lindex $tmp 3]
set cname "$name\($parTypes)"
if {$methType != ""} {
set cname "$cname: $methType"
}
set mname "$name\([lindex [lindex $modelInfo 1] 0])"
set methType [lindex [lindex $modelInfo 1] 1]
if {$methType != ""} {
set mname "$mname: $methType"
}
m4_warning $W_OLDCODE [[$this tgtClass] name] $cname $mname $kind
$method hasOldCode 1
set sect [$method getUserCode]
$sect appendSect [lindex $codeInfo 3]
}
method FTRegenerator::makeObsolete {this fileDesc methSect kind} {
set sect [[[$this tgtClass] sections] getSection obsolete]
if {$sect == ""} {
return
}
$sect appendSect $methSect
set WS "\[ \t]*"
while {![eof $fileDesc]} {
set line [gets $fileDesc]
$sect append "$line\n"
if {[regexp "^${WS}end${WS}$kind" $line]} {
break
}
}
$sect append "\n"
}
method FTRegenerator::hasSameKind {this class kind} {
if {$kind == [[$this tgtClass] kind]} {
return 1
}
m4_warning $W_KIND_CHANGE [$class getName] $kind [[$this tgtClass] kind]
return 0
}
# Do not delete this line -- regeneration end marker