PC World 1998 October/PCWorld_1998-10_cd.bin/software/prehled/komix/DATA.Z/stgentor.tcl

Text File | 1997-12-01 | 25.5 KB | 968 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            : stgentor.tcl
#       Author          :
#       Original date   : November 1997
#       Description     : Classes for code generation
#
#---------------------------------------------------------------------------

#---------------------------------------------------------------------------
#      File:           @(#)stfilehand.tcl    /main/titanic/2
#---------------------------------------------------------------------------

# Start user added include file section
# End user added include file section

require "filehandle.tcl"


Class STFileHandler : {FileHandler} {
    constructor
    method destructor
    method getSpecialFiles
    method getFileTypes
    method getImportFileName
    method getExportFileName
    method sourceTclFiles

    # The Smalltalk file type. All methods using
    # the Smalltalk file type query this attribute.
    #
    attribute stType
}

constructor STFileHandler {class this} {
    set this [FileHandler::constructor $class $this]
    # Start constructor user section
    $this stType "st"
    # End constructor user section
    return $this
}

method STFileHandler::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this FileHandler::destructor
}


# Returns a list with special file names for Smalltalk: the import
# and the export file.
#
method STFileHandler::getSpecialFiles {this} {
    set list [List new]
    $list append [$this getImportFileName]
    $list append [$this getExportFileName]
    return $list
}


# Returns a list with Smalltalk file types: stType.
#
method STFileHandler::getFileTypes {this} {
    set list [List new]
    $list append [$this stType]
    return $list
}


# Returns the file name for the file with the import script.
#
method STFileHandler::getImportFileName {this} {
    return "vwimport.[$this stType]"

}


# Returns the file name for the file with the export script.
#
method STFileHandler::getExportFileName {this} {
    return "vwexport.[$this stType]"
}


#
# Source u_genst.tcl if it exists.
# Call FileHandler::sourceTclFiles.
#
method STFileHandler::sourceTclFiles {this} {
    set cc [ClientContext::global]

    if {[$cc customFileExists u_genst tcl "" 0]} {
        require u_genst.tcl
    }

    $this FileHandler::sourceTclFiles
}

# Do not delete this line -- regeneration end marker

#---------------------------------------------------------------------------
#      File:           @(#)stregenera.tcl    /main/titanic/6
#---------------------------------------------------------------------------

# Start user added include file section
# End user added include file section

require "regenerato.tcl"


Class STRegenerator : {Regenerator} {
    constructor
    method destructor
    method regenerate
    method countExclamationMarks
    method isCategoryHeader
    method processCategoryHeader
    method processMethod
    method getLine
    method isCommentLine
    method parseInitialize
    method parseFile

    # Current parsing state, one of initial, inCategory,
    # inMethod, inMethodBody, skippingGeneratedMethod.
    #
    attribute state

    # Indicates whether the last line that was read
    # started in a single quote delimited string.
    #
    attribute startInSingleQuote

    # Indicates whether the last line that was read
    # ended in a single quote delimited string.
    #
    attribute endInSingleQuote

    # Indicates whether the last line that was read
    # started in a double quote delimited string.
    #
    attribute startInDoubleQuote

    # Indicates whether the last line that was read
    # ended in a double quote delimited string.
    #
    attribute endInDoubleQuote

    # Name of the class currently in regeneration.
    #
    attribute currentClassName

    # Name of the class implementation
    # currently in regeneration.
    #
    attribute currentClassImplementation

    # Category Type currently in regeneration:
    # Class or Instance.
    #
    attribute currentCategoryType

    # parsed comment of current method
    #
    attribute methodComment
}

constructor STRegenerator {class this} {
    set this [Regenerator::constructor $class $this]
    # Start constructor user section
    # End constructor user section
    return $this
}

method STRegenerator::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this Regenerator::destructor
}


# Regeneration entry point.
#
method STRegenerator::regenerate {this class fileObject} {
    set fileHandler [STFileHandler new]
    $this fileObject $fileObject
    $this fileDesc [$fileHandler openFile $class [$fileHandler stType]]
    if { [$this fileDesc] != "" } {
        $this parseFile
        $fileHandler closeFile [$this fileDesc]
    }
}


# Count the exclamation marks in <line>, from right to left.
# Returns 0 when the line ends in a string.
# Stops counting when a character other than <space> or
# ! is encountered. Returns the count and
# strips the found exclamation marks
# from <line>.
#
method STRegenerator::countExclamationMarks {this line} {
    upvar $line l
    if { (![regexp {!} $l]) || [$this endInDoubleQuote] || \
             [$this endInSingleQuote] } {
        return 0
    }
    set l [string trimright $l]
    set index [expr [string length $l]-1]
    set count 0
    while { ($index >= 0) && ([regexp {[! ]} [string index $l $index] ch]) } {
        set index [expr $index-1]
        if { $ch == "!" } {
            set count [expr $count+1]
        }
    }
    set l [string range $l 0 $index]
    return $count
}


# Returns whether <line> contains a category header.
#
method STRegenerator::isCategoryHeader {this line} {
    if { [string first methodsFor $line] != -1 } {
        return 1
    }
    if { [string first publicMethodsFor $line] != -1 } {
        return 1
    }
    if { [string first privateMethodsFor $line] != -1 } {
        return 1
    }
    if { [string first protectedMethodsFor $line] != -1 } {
        return 1
    }
    return 0
}


# Processes <line> (which is a category header).
# Sets currentClassName, currentCategoryType
# and currentClassImplementation.
#
method STRegenerator::processCategoryHeader {this line} {
    regsub -all "!" $line "" tokenList
    if { [llength $tokenList] < 3 } {
        m4_error $EST_BADCATHEAD [$this currentClassName]
    return
    }
    $this currentClassName [lindex $tokenList 0]

    if { [lindex $tokenList 1] == "class" } {
        $this currentCategoryType "Class"
    } else {
        $this currentCategoryType "Instance"
    }
    $this currentClassImplementation [[$this fileObject] getImplementation \
                                          [$this currentClassName]]
    # if this class implemenentation has no super class then it is generated
    if {[[$this currentClassImplementation] super] == "" } {
        m4_warning $WST_OBSOLMETHOD [$this currentClassName]
        [$this currentClassImplementation] super \
            "ObsoleteClass[cap [$this currentClassName]]"
    }
}


# Processes the method found with
# header <header>, temporaries <temporaries> and
# body <expression>:
# Determines selector and arguments, gets a
# method implementation, warns if the method
# is obsolete.
# Adds temporaries, removes code before
# user code marker if it exists and the marker itself.
# Adds the user added code as one expression.
#
method STRegenerator::processMethod {this header temporaries expression} {
    set obsolete 0
    set selector ""
    set isArgument 0
    set arguments [List new]
    foreach part $header {
        if { !$isArgument } {
            set selector "$selector$part"
            set isArgument 1
        } else {
            $arguments append $part
            set isArgument 0
        }
    }

    # do workaround for - as method name: - as parameter is not allowed in tcl
    if { $selector == "-" } {
        set selector "operator-"
    }

    set impl [[$this currentClassImplementation] \
                  get[$this currentCategoryType]MethodImplementation \
                  $selector ""]

    if { $impl == "" } {
        m4_warning $WST_OBSOLMETHODCLASS $selector [$this currentClassName]
        set impl [[$this currentClassImplementation] \
                      get[$this currentCategoryType]MethodImplementation \
                      $selector obsolete]
        # for obsolete methods we need to insert the argument names
        $arguments foreach argument {
            $impl addArgument $argument
        }
        if {[$impl comment] == "" } {
            if {$expression == "" } {
                set expression [$this methodComment]
            } else {
                regsub -all {["']} [$this methodComment] "" cmline
                #"]]
                $impl comment $cmline
            }
        }
        $impl hasUserCodePart 1
    }
    $this methodComment ""

    # do temporaries
    if { $temporaries != "" } {
        regsub -all {\|} [string trim $temporaries] "" tempList
        foreach temporary $tempList {
            $impl addTemporary $temporary
        }
    }

    # delete code before user code marker from expression
    set userMarkerIndex [string first [$globals startUserCodeMarker] $expression]
    if { $userMarkerIndex != -1 } {
        set restIndex [expr $userMarkerIndex+\
                           [string length [$globals startUserCodeMarker]]+1]
        set expression [string range $expression $restIndex end]
    }
    if {$obsolete} {
        set expresion "obsolete code:\n$expresion"
    }
    if { $expression != "" } {
        $impl addExpression $expression
        $impl hasUserCode 1
    }
}


# Reads <line> from file with descriptor fileDesc,
# returns 0 if end of file.
# Updates the start/end in single/double quote
# attributes based on the contents of
# <line>.
#
method STRegenerator::getLine {this line} {
    upvar $line l
    set l [gets [$this fileDesc]]
    if [eof [$this fileDesc]] {
        return 0
    }

    # update count stuff
    $this startInSingleQuote [$this endInDoubleQuote]
    $this startInDoubleQuote [$this endInDoubleQuote]
    # get only the 's and "'s
    regsub -all {[^"']} $l "" newLine
    #"

    foreach char [split $newLine {}] {
        if { $char == "\"" } {
            if { ![$this endInSingleQuote] } {
                $this endInDoubleQuote [expr 1-[$this endInDoubleQuote]]
            }
        } else {
            if { ![$this endInDoubleQuote] } {
                $this endInSingleQuote [expr 1-[$this endInSingleQuote]]
            }
        }
    }
    return 1
}


# Returns whether <line> is a comment line.
#
method STRegenerator::isCommentLine {this line} {
    if { [$this startInDoubleQuote] || [$this endInDoubleQuote] } {
        return 1
    }
    if { [string index [string trim $line] 0] == "\"" } {
        return 1
    }
    return 0
}


# Initializes the parse variables.
#
method STRegenerator::parseInitialize {this} {
    $this startInSingleQuote 0
    $this endInSingleQuote 0
    $this startInDoubleQuote 0
    $this endInDoubleQuote 0
    $this state initial
    $this methodComment ""
}


# This method is the parser. Parses the file
# and adds regenerated method bodies.
#
method STRegenerator::parseFile {this} {
    $this parseInitialize

    set line ""
    while { [$this getLine line] } {
        case [$this state] in {
            {initial} {
                if [$this isCategoryHeader $line] {
                    $this processCategoryHeader $line
                    $this state inCategory
                    $this methodComment ""
                }
            }
            {inCategory} {
                if { ([string trim $line] != "" ) && \
                         (![$this isCommentLine $line]) } {
                    set count [$this countExclamationMarks line]
                    if $count {
                        $this state initial
                    } else {
                        $this state inMethod
                        set methodHeader $line
                        set expression ""
                        set temporaries ""
                        $this methodComment ""
                    }
                }
            }
            {inMethod} {
                set count [$this countExclamationMarks line]
                if { [string trim $line] == "\"Generated\"" } {
                    $this state skippingGeneratedMethod
                    $this methodComment ""
                    continue
                }
                if { ([string trim $line] != "" ) && \
                         (![$this isCommentLine $line]) } {
                    if { [string index [string trim $line] 0] == "|" } {
                        set temporaries [string trim $line]
                    } else {
                        set expression $line
                    }

                    $this state inMethodBody
                }
                if $count {
                    $this processMethod $methodHeader $temporaries $expression
                    $this methodComment ""
                    if { $count == 1 } {
                        $this state inCategory
                    } else {
                        $this state initial
                    }
                }
                if {[$this isCommentLine $line]} {
                    set cmline $line
                    set cmline [string trim $cmline]
                    if {$cmline != ""} {
                        if {[$this methodComment] != ""} {
                            $this methodComment "[$this methodComment]\n$cmline"
                        } else {
                            $this methodComment "$cmline"
                        }
                    }
                }
            }
            {inMethodBody} {
                set count [$this countExclamationMarks line]
                if { $expression != "" } {
                    set expression "$expression\n$line"
                } else {
                    set expression $line
                }
                if $count {
                    $this processMethod $methodHeader $temporaries $expression
                    $this methodComment ""
                    if { $count == 1 } {
                        $this state inCategory
                    } else {
                        $this state initial
                    }
                }
            }
            {skippingGeneratedMethod} {
                set count [$this countExclamationMarks line]
                if $count {
                    if { $count == 1 } {
                        $this state inCategory
                    } else {
                        $this state initial
                    }
                }
            }
        }
    }
}

# Do not delete this line -- regeneration end marker

#---------------------------------------------------------------------------
#      File:           @(#)stgglobal.tcl    /main/titanic/10
#---------------------------------------------------------------------------

# Start user added include file section
global globals
# End user added include file section



Class STGGlobal : {GCObject} {
    method destructor
    constructor
    method setGeneratePrint
    method setDefaultCategory
    method setUserCodeMarker
    method setErrorDictionary
    method setGeneratedMethodMarker

    # Maps the error codes to error messages.
    #
    attribute errorDictionary

    # Indicates whether print methods must be generated.
    #
    attribute generatePrint

    # Default category naming: based on system or diagram names.
    #
    attribute defaultCategory

    # The marker for user added code.
    #
    attribute startUserCodeMarker

    # The marker for generated methods.
    #
    attribute generatedMethodMarker
}

method STGGlobal::destructor {this} {
    # Start destructor user section
    # End destructor user section
}


# Set all the instance variables by calling their set methods.
#
constructor STGGlobal {class this} {
    set this [GCObject::constructor $class $this]
    $this setGeneratePrint
    $this setDefaultCategory
    $this setUserCodeMarker
    $this errorDictionary [Dictionary new]
    $this setErrorDictionary
    return $this
}

proc STGGlobal::getGeneratePrint {} {
    set cc [ClientContext::global]
    set cs [$cc currentSystem]
    if {$cs == ""} {
        return 0
    }
    set generatePrint [$cs getPropertyValue st_generate_print]
    if { [string tolower $generatePrint] == "on" } {
        set generatePrint 1
    } elseif { [string tolower $generatePrint] == "off" } {
        set generatePrint 0
    } elseif { $generatePrint == "0" } {
        set generatePrint 0
    } elseif { $generatePrint == "1" } {
        set generatePrint 1
    } else {
        set generatePrint 0
    }
    return $generatePrint
}

proc STGGlobal::setGeneratePrintProp {value} {
    # this can also be done using the property box
    # of the systemVersion.
    if { $value == "0" } {
        set generatePrint 0
    } else {
        set generatePrint 1
    }
    set cc [ClientContext::global]
    set cs [$cc currentSystem]
    if {$cs == ""} {
        return
    }
    $cs setProperty st_generate_print $generatePrint
}

# Sets generatePrint according to M4_st_generate_print.
# Default is 0.
#
method STGGlobal::setGeneratePrint {this} {
    $this generatePrint [STGGlobal::getGeneratePrint]
}

proc STGGlobal::getDefaultCategory {} {
    set cc [ClientContext::global]
    set cs [$cc currentSystem]
    if {$cs == ""} {
        return "System"
    }
    set defaultCategory [$cs getPropertyValue st_default_category]
    if { [regexp -nocase "diagram" value] } {
        set defaultCategory "Diagram"
    } else {
        set defaultCategory "System"
    }
    return $defaultCategory
}

proc STGGlobal::setDefaultCategoryProp {value} {
    # this can also be done using the property box
    # of the systemVersion.
    if { [regexp -nocase "system" $value] } {
        set defcat "SystemName"
    } else {
        set defcat "DiagramName"
    }
    set cc [ClientContext::global]
    set cs [$cc currentSystem]
    if {$cs == ""} {
        return
    }
    $cs setProperty st_default_category $defcat
}

# Sets defaultCategory according to M4_st_default_category.
# Default is System.
#
method STGGlobal::setDefaultCategory {this} {
    $this defaultCategory [STGGlobal::getDefaultCategory]
}


# Sets startUserCodeMarker.
#
method STGGlobal::setUserCodeMarker {this} {
    $this startUserCodeMarker "\"Start user added code\""
}


# Sets errorDictionary with error codes as keys
# and error messages as values.
#
method STGGlobal::setErrorDictionary {this} {
    [$this errorDictionary] set PARAMETER_NIL "Parameter nil for mandatory association"
    [$this errorDictionary] set ASSOC_OBJ_NOT_FOUND "Associated object not found"
    [$this errorDictionary] set QUAL_NOT_FOUND "Qualifier not found"
    [$this errorDictionary] set CONSTRAINT "Constraint violation"
    [$this errorDictionary] set CANNOT_RELEASE "Cannot release"
}


# Sets generatedMethodMarker.
#
method STGGlobal::setGeneratedMethodMarker {this} {
    $this generatedMethodMarker "\"Generated\""
}

# Do not delete this line -- regeneration end marker

#---------------------------------------------------------------------------
#      File:           @(#)stgenerato.tcl    /main/titanic/4
#---------------------------------------------------------------------------

# Start user added include file section


set globals [STGGlobal new]

# End user added include file section

require "generator.tcl"


Class STGenerator : {Generator} {
    constructor
    method destructor
    method generate
    method check
    method generateSpecialFiles
    method sortClasses
    method generateImport
    method generateExport

    # The file handler for this generator.
    #
    attribute fileHandler
}

constructor STGenerator {class this} {
    set this [Generator::constructor $class $this]
    # Start constructor user section
    $this fileHandler [STFileHandler new]
    # End constructor user section
    return $this
}

method STGenerator::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this Generator::destructor
}


# Generates for <classList>, see description in class Generator.
#
method STGenerator::generate {this classList} {
    # set header variables
    set cc [ClientContext::global]
    set proj [$cc currentProject]
    set configV [$cc currentConfig]
    set phaseV [$cc currentPhase]
    set systemV [$cc currentSystem]
    if {![$proj isNil] } {
        set projName [$proj name]
    }
    if {![$configV isNil] } {
        set configName [[$configV config] name]
    }
    if {![$phaseV isNil] } {
        set phaseName [[$phaseV phase] name]
    }
    if {![$systemV isNil] } {
        set systemName [[$systemV system] name]
    }

    # initialize file handler, type and result variables
    set type [[$this fileHandler] stType]
    set typeToClassDictionary [Dictionary new]
    set classToSection [Dictionary new]
    $typeToClassDictionary set [[$this fileHandler] stType] $classToSection
    set regenerator [STRegenerator new]

    # start generation
    $classList foreach class {
        set tmpErrors 0
        set tmpErrors [$class check]
        if {$tmpErrors == 0} {
            # errorfree so generate
            set fileObject [STFile new]
            set implementation [$fileObject getImplementation \
                                    [$class getSTName]]
            $class generate $implementation

            # do regeneration
            $regenerator regenerate $class $fileObject

            set text [TextSection new]

            # do header
            set fileName [[$this fileHandler] getFileName $class $type]
            expandHeaderIntoSection $fileName $type $text


            $fileObject generate $text

            $classToSection set $class $text
        } else {
            # puts "not generating due to errors ($tmpErrors)"
        }
    }
    return $typeToClassDictionary
}

method STGenerator::check {this classList} {
    set errornr 0
    # set header variables
    set cc [ClientContext::global]
    set proj [$cc currentProject]
    set configV [$cc currentConfig]
    set phaseV [$cc currentPhase]
    set systemV [$cc currentSystem]
    if {![$proj isNil] } {
        set projName [$proj name]
    }
    if {![$configV isNil] } {
        set configName [[$configV config] name]
    }
    if {![$phaseV isNil] } {
        set phaseName [[$phaseV phase] name]
    }
    if {![$systemV isNil] } {
        set systemName [[$systemV system] name]
    }
    # start checking
    $classList foreach class {
        # puts " Language dependence checking for class: [$class getName]"
        if {![$class isExternal]} {
            set tmpError [$class check]
        } else {
            m4_message $MST_NOCHKEXTCLS [$class getName]
        }
        incr errornr $tmpError
        # puts " number of returned errors: $tmpError"
    }
    return $errornr
}


# Generates special files: the import and/or
# the export file.
# Makes a mapping from class to fileName
# and from class to super class and
# generates the file specified in <fileList>.
#
method STGenerator::generateSpecialFiles {this ooplModel fileList} {
    set classList [List new]
    set classToSuper [Dictionary new]
    set classToFile [Dictionary new]

    foreach class [$ooplModel ooplClassSet] {
        if [$class isExternal] {
            continue
        }
        set className [$class getSTName]
        $classList append $className

        # get superclass
        set gnodeSet [$class genNodeSet]

        if { [llength $gnodeSet] == 0 } {
            $classToSuper set $className "Object"
        } else {
            $classToSuper set $className [[[lindex $gnodeSet 0] superClass] getSTName]
        }

        $classToFile set $className [[$this fileHandler] getFileName $class [[$this fileHandler] stType]]
    }

    $fileList foreach specialFile {
        if { [[$this fileHandler] getImportFileName] == $specialFile } {
            m4_message $MST_GENIMPSCRPTS
            $this generateImport $classList $classToSuper $classToFile
        }
        if { [[$this fileHandler] getExportFileName] == $specialFile } {
            m4_message $MST_GENEXPSCRPTS
            $this generateExport $classList $classToFile
        }
    }
}


# Sorts the classes in <classList> in
# prefix order. <classToSuper> maps classes to
# their super classes and <classToFile> maps
# classes to file names, these are used during
# the sort process.
#
method STGenerator::sortClasses {this classList classToSuper classToFile} {
    upvar $classList selectedClasses
    # make class to subs and root classes
    set rootClasses [List new]
    set classToSubs [Dictionary new]
    $classToSuper foreach className superName {
        if { ![$classToSubs exists $superName] } {
            $classToSubs set $superName [List new]
        }
        if { [[$classToSubs set $superName] search $className] == -1 } {
            # if super does not have a file it must be external and thus a root class
            if { ![$classToFile exists $superName] } {
                # now get the subclass of the external root class
                if { [$rootClasses search $className] == -1 } {
                    $rootClasses append $className
                }
            }
            [$classToSubs set $superName] append $className
        }
    }
    # little hack: when an class <Object> was present,
    # an empty import-file was created. This is corrected
    # by setting rootClasses:
    if { [$rootClasses empty] } {
        $rootClasses append "Object"
    }
    # walk the inheritance tree till the leaves and append every selected class visited
    # yielding the classes in prefix order in newSelectedClasses
    set newSelectedClasses [List new]
    while { ![$rootClasses empty] } {
        set currentClass [$rootClasses index 0]
        if { [$selectedClasses search $currentClass] != -1 } {
            $newSelectedClasses append $currentClass
        }
        if [$classToSubs exists $currentClass] {
            [$classToSubs set $currentClass] foreach subClass {
                if { [$rootClasses search $subClass] == -1 } {
                    $rootClasses append $subClass
                }
            }
        }
        $rootClasses removeValue $currentClass
    }
    set selectedClasses $newSelectedClasses
}


# Generates the import file: sorts the
# classes in <classList> , creates a section with
# Smalltalk expression to file in these
# classes and writes the import file.
#
method STGenerator::generateImport {this classList classToSuper classToFile} {
    set importSection [TextSection new]
    set clientContext [ClientContext::global]
    set pathName [[$clientContext currentSystem] path]

    $this sortClasses classList $classToSuper $classToFile
    $classList foreach className {
        set fileName [path_name concat $pathName [$classToFile set $className]]
        $importSection append "(Filename named: \'$fileName\') fileIn!\n"
    }
    set fileName [[$this fileHandler] getImportFileName]
    [$this fileHandler] writeSectionToNamedFile $importSection $fileName
}


# Generates the export file: creates a section
# with Smalltalk expressions to file out
# the classes in <classList> and writes
# the export file.
#
method STGenerator::generateExport {this classList classToFile} {
    set exportSection [TextSection new]
    set clientContext [ClientContext::global]
    set pathName [[$clientContext currentSystem] path]

    $classList foreach className {
        set fileName [path_name concat $pathName [$classToFile set $className]]
        $exportSection append "(Filename named: \'$fileName\') fileOutChangesFor: $className!\n"
    }
    set fileName [[$this fileHandler] getExportFileName]
    [$this fileHandler] writeSectionToNamedFile $exportSection $fileName
}

# Do not delete this line -- regeneration end marker