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

Text File | 1997-12-01 | 135KB | 4,855 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            : stgclasses.tcl
#       Author          :
#       Original date   : November 1997
#       Description     : Classes for code generation
#
#---------------------------------------------------------------------------


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


# This class contains generic Smalltalk code
# generation object methods.

Class STGObject : {Object} {
    constructor
    method destructor
    method asSTName
    method asArgument
    method getSTName
    method getArgumentName
    method check
    method checkLocal
    method checkSTName
    method checkFreeTextQuote

    # Stores name of this object in Smalltalk compliant format
    # e.g. with illegal characters filtered out.
    #
    attribute stName

    # Used to store the argument name of this object.
    #
    attribute argName
}

constructor STGObject {class this name} {
    set this [Object::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Makes name an ST compliant name by filtering out
# illegal characters and returns it.
#
method STGObject::asSTName {this name} {
    # remove illegal characters from name
    # Illegal characters are all characters except a-z, A-Z, 0-9 and _
    if [regsub -all {[^a-zA-Z0-9_]} $name "" newName ] {
        # m4_warning $WST_REMOVECHARS $name
    }
    return $newName
}


# Transforms <name> into argument name prepending a or an and returns it.
#
method STGObject::asArgument {this name} {
    if { [string first [cap [string index $name 0]] "AEIOU"] > -1 } {
        return "an[cap $name]"
    }
    return "a[cap $name]"
}


# Gets name for object, issues error if it is object without getName method.
# Returns stName if it was set already, otherwise compute Smalltalk compliant
# name, store in stName and return it.
# Issues warning when illegal characters get filtered out.
#
method STGObject::getSTName {this} {
    if { [$this stName] != "" } {
        return [$this stName]
    }
    if [catch { set oldName [$this getName] } ] {
        # m4_error $EST_FAILNONAME
        return "error"
    }
    set newName [$this asSTName $oldName]
    $this stName $newName
    return $newName
}


# If argName is already set, return it.
# Otherwise determine argument name, set
# argName and return it.
#
method STGObject::getArgumentName {this} {
    if { [$this argName] != "" } {
        return [$this argName]
    }
    if [catch { $this argName [$this argumentName] } ] {
        # m4_error $EST_FAILNOARGNAME
        return "error"
    }
    return [$this argName]
}


# Returns number of errors found
# in the class and cascade further
#
method STGObject::check {this} {
    set errornr [$this checkLocal]
    return $errornr
}


# Checks class
#
method STGObject::checkLocal {this} {
    set errornr 0
    return $errornr
}

method STGObject::checkSTName {this} {
    set errornr 0
    set warningnr 0

    if { [$this stName] != "" } {
        return $errornr
    }

    if [catch { set oldName [$this getName] } ] {
        m4_error $EST_FAILNONAME
        incr errornr 1
        return $errornr
    }

    # remove illegal characters from name
    # Illegal characters are all characters except a-z, A-Z, 0-9 and _
    if [regsub -all {[^a-zA-Z0-9_]} [$this getName] "" newName ] {
        m4_warning $WST_REMOVECHARS $oldName
        incr warningnr 1
    }
    $this stName $newName

    return $errornr
}

method STGObject::checkFreeTextQuote {this} {
    set warningnr 0
    if [regexp \' [$this getPropertyValue freeText] comment] {
        m4_warning $WST_REMOVEQUOTEDESCR [$this getSTName]
        incr warningnr 1
    }
    return $warningnr
}

# Do not delete this line -- regeneration end marker



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


# Generic base class for association generators.

Class STGAssocGen : {GCObject} {
    method destructor
    constructor
    method getPrivateImplementation
    method getAccessImplementation
    method getModifyImplementation
    method getRemoveImplementation
    method getErrorMessage
    method generateNilCheck
    method generateConstraintCheck
    method generateIncludesCheck
    method generateExistenceCheck
    method generateRelease
    method removePermitted
    method removeRequired
    method upperConstraint
    method lowerConstraint
    method setType
    method check
    method checkLocal
    method assocAttr

    # Used to store the instance variable name used for this association attribute.
    # Set in getData.
    #
    attribute variableName

    # Used to hold name of this association attribute in parameter format.
    #
    attribute parameterName

    # Used to store role name for this association attribute.
    #
    attribute roleName

    # Implementation object for the class; used to speed up things.
    #
    attribute classImplementation

    # Holds the qualifier name for qualified associations.
    #
    attribute qualifierName

    # Holds the argument name of the qualifier for qualified associations.
    #
    attribute qualifierParameter

    # The generator of the opposite of the association
    # attribute of this generator.
    #
    attribute opposite
    attribute _assocAttr
}

method STGAssocGen::destructor {this} {
    # Start destructor user section
    $this opposite ""
    $this classImplementation ""
    $this _assocAttr ""
    # End destructor user section
}


# Sets the assocAttr association to <assocAttr>.
#
constructor STGAssocGen {class this assocAttr} {
    set this [GCObject::constructor $class $this]
    $this _assocAttr $assocAttr
    $this opposite ""
    return $this
}


# Gets an implementation object for this selector in the instance private category.
#
method STGAssocGen::getPrivateImplementation {this selector} {
    return [[$this classImplementation] getInstanceMethodImplementation \
                $selector "private"]
}


# Gets an implementation object for this selector in the instance access associations category.
#
method STGAssocGen::getAccessImplementation {this selector} {
    set category [[$this assocAttr] getReadCategory "association access"]
    if { $category == "" } {
        return ""
    }
    return [[$this classImplementation] getInstanceMethodImplementation \
                $selector $category]
}


# Gets an implementation for this selector in the instance modify association category.
#
method STGAssocGen::getModifyImplementation {this selector} {
    set category [[$this assocAttr] getWriteCategory "association modification"]
    if { $category == "" } {
        return ""
    }
    return [[$this classImplementation] getInstanceMethodImplementation \
                $selector $category]
}


# Gets an implementation object for a remove method.
#
method STGAssocGen::getRemoveImplementation {this selector} {
    set category [[$this assocAttr] getWriteCategory "association modification"]
    if { ![$this removePermitted] } {
        set category ""
    }
    if { $category == "" } {
        if [$this removeRequired] {
            set category "private"
        } else {
            return ""
        }
    }
    return [[$this classImplementation] getInstanceMethodImplementation \
                $selector $category]
}


# Returns error call string based on error type and selector.
#
method STGAssocGen::getErrorMessage {this errorType selector} {
    set errorMessage [[$globals errorDictionary] set $errorType]
    if { $errorMessage == "" } {
        m4_error $EST_UNKNOWNERRMSG $errorType
        set errorMessage "Unknown error"
    }
    set errorMessage "$errorMessage in $selector in [[[$this assocAttr] ooplClass] getSTName]"
    return "self error: \'$errorMessage\'"
}


# Generate nil check for name in block:
# if name is nil generate an error call.
#
method STGAssocGen::generateNilCheck {this block name} {
    set expr [$block addExpression "$name isNil ifTrue:"]
    set selector [$block selector]
    $expr addExpression [$this getErrorMessage PARAMETER_NIL $selector]
}


# Generates a constraint check in block, this expressions
# check whether the size of <name> is greater than/smaller than bound,
# depending on type. Returns the expression.
#
method STGAssocGen::generateConstraintCheck {this selector block name bound type} {
    if { $type == "upper" } {
        set sizeCheck "$name size < $bound"
    } else {
        set sizeCheck "$name size > $bound"
    }
    set block [$block addExpression "$sizeCheck ifTrue:"]
    set errorPart [$block addExpressionPart "ifFalse:"]
    $errorPart addExpression [$this getErrorMessage CONSTRAINT $selector]
    return $block
}


# Generates an include check for element in name, adds it to block and returns the new expression.
#
method STGAssocGen::generateIncludesCheck {this block name element} {
    set block [$block addExpression "($name includes: $element) ifFalse:"]
    return $block
}


# Generates a check expression that checks whether element is
# in name and generates an error if this is not the case.
#
method STGAssocGen::generateExistenceCheck {this selector block name element} {
    set block [$this generateIncludesCheck $block $name $element]
    $block addExpression [$this getErrorMessage ASSOC_OBJ_NOT_FOUND $selector]
}


# Generates additions to release to release the association
# to which this association attribute belongs.
#
method STGAssocGen::generateRelease {this} {
    set release [[$this classImplementation] release]
    if [[$this assocAttr] oppositeMandatoryOne] {
        $release insertExpression [$this getErrorMessage CANNOT_RELEASE release]
    } else {
        $this generateReleaseCode $release
    }
}


# Returns 1 if generation of a public remove is permitted.
#
method STGAssocGen::removePermitted {this} {
    if [[$this assocAttr] oppositeMandatoryOne] {
        return 0
    }
    return 1
}


# Returns 1 if generation of remove method is required for the generation
# of other methods.
#
method STGAssocGen::removeRequired {this} {
    set opposite [[$this assocAttr] opposite]
    if { $opposite == "" } {
        return 0
    }
    if { [$opposite isMandatory] || ([$opposite writeAccess] != "None") } {
        return 1
    }
    return 0
}


# Gets upper bound of constraint for this association.
#
method STGAssocGen::upperConstraint {this} {
    set constraint [[$this assocAttr] getConstraint]
    if { $constraint == "" } {
        return ""
    }
    if { [string first "\{" $constraint] != -1 } {
        return ""
    }
    set dashIndex [string first "-" $constraint]
    if { $dashIndex == -1 } {
        set plusIndex [string first "+" $constraint]
        if { $plusIndex == -1 } {
            return $constraint
        } else {
            return ""
        }
    } else {
        return [string range $constraint [expr $dashIndex+1] end]
    }
}


# Get lower bound of constraint for this association.
#
method STGAssocGen::lowerConstraint {this} {
    set constraint [[$this assocAttr] getConstraint]
    if { $constraint == "" } {
        return ""
    }
    if { [string first "\{" $constraint] != -1 } {
        return ""
    }

    set dashIndex [string first "-" $constraint]
    if { $dashIndex == -1 } {
        set plusIndex [string first "+" $constraint]
        if { $plusIndex == -1 } {
            return $constraint
        } else {
            return [string range $constraint 0 [expr $plusIndex-1]]
        }
    } else {
        return [string range $constraint 0 [expr $dashIndex-1]]
    }
}


# Returns set type to be used to implement this
# association.
#
method STGAssocGen::setType {this} {
    if [[$this assocAttr] isOrdered] {
        return "OrderedCollection"
    }
    return "Set"
}

method STGAssocGen::check {this} {
    set errornr [$this checkLocal]
    return $errornr
}

method STGAssocGen::checkLocal {this} {
    set errornr 0
    return $errornr
}

# Do not delete this line -- regeneration end marker

method STGAssocGen::assocAttr {this args} {
    if {$args == ""} {
        return [$this _assocAttr]
    }
    set ref [$this _assocAttr]
    if {$ref != ""} {
        $ref _generator ""
    }
    set obj [lindex $args 0]
    if {$obj != ""} {
        $obj _generator $this
    }
    $this _assocAttr $obj
}



#---------------------------------------------------------------------------
#      File:           @(#)stgassocin.tcl    /main/titanic/3


# Generator class for association initializers.

Class STGAssocInitializer : {STGObject} {
    constructor
    method destructor
    method generate
    method check
}

constructor STGAssocInitializer {class this name} {
    set this [STGObject::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Get argument name for initializer and add it to
# the constructor argument list.
#
method STGAssocInitializer::generate {this} {
    # set hasInitializer attribute in association attribute
    [$this assoc] hasInitializer 1

    set constructor [[$this constructor] methodImplementation]
    set argName [[$this assoc] getArgumentName]
    $constructor getUniqueArgumentName [$this getSTName] $argName
}


# For computing newRequired in
# STGConstructor
#
method STGAssocInitializer::check {this} {
    set errornr 0
    incr errornr [$this checkSTName]
    return $errornr
}

# Do not delete this line -- regeneration end marker

if [isCommand CMAssocInitializer] {
    Class  STGAssocInitializerD : {STGAssocInitializer CMAssocInitializer} {
    }
} else {
    Class STGAssocInitializerD : {STGAssocInitializer OPAssocInitializer} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPAssocInitializer) STGAssocInitializerD

selfPromoter OPAssocInitializer {this} {
    STGAssocInitializerD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stgattribi.tcl    /main/titanic/3


# Attribute initializer generator.

Class STGAttribInitializer : {STGObject} {
    constructor
    method destructor
    method generate
    method check
}

constructor STGAttribInitializer {class this name} {
    set this [STGObject::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Determines the argument name and adds it to constructor parameters.
# Generates an expression in the constructor to set the attribute
# to the value supplied by the parameter.
#
method STGAttribInitializer::generate {this} {
    set attrib [$this attrib]
    # set hasInitializer in data attribute
    $attrib hasInitializer 1

    set constructor [[$this constructor] methodImplementation]
    set argName [$attrib getArgumentName]

    # Use original attrib name to avoid i_ 's
    set name [$attrib getSTName]
    if [$attrib isClassFeature] {
        set name [cap $name]
    }

    set uniqueName [$constructor getUniqueArgumentName $name $argName]
    $constructor addExpression "$name := $uniqueName"
}


# For computing newRequired in
# STGConstructor
#
method STGAttribInitializer::check {this} {
    set errornr 0
    incr errornr [$this checkSTName]
    return $errornr
}

# Do not delete this line -- regeneration end marker

if [isCommand CMAttribInitializer] {
    Class  STGAttribInitializerD : {STGAttribInitializer CMAttribInitializer} {
    }
} else {
    Class STGAttribInitializerD : {STGAttribInitializer OPAttribInitializer} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPAttribInitializer) STGAttribInitializerD

selfPromoter OPAttribInitializer {this} {
    STGAttribInitializerD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stgattribu.tcl    /main/titanic/3


# This class contains generic attribute generation methods.

Class STGAttribute : {STGObject} {
    constructor
    method destructor
    method getReadCategory
    method getWriteCategory
    method readAccess
    method writeAccess

    # This attribute is set during generation and indicates whether there is an
    # initializer for this attribute.
    # Note: this can only work if generation for initializers is done before generation for attributes.
    #
    attribute hasInitializer
}

constructor STGAttribute {class this name} {
    set this [STGObject::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

method STGAttribute::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this STGObject::destructor
}


# Returns category name based on read access:
# * return empty string if None
# * return private if Private
# * return <name> if Public
#
method STGAttribute::getReadCategory {this name} {
# and return protected if Protected
    set readAccess [$this readAccess]
    if { $readAccess == "None" } {
        return ""
    } elseif { $readAccess == "Protected" } {
        return "protected"
    } elseif { $readAccess == "Private" } {
        return "private"
    } else {
        return $name
    }
}


# Returns category name based on write access specification:
# as in getReadCategory.
#
method STGAttribute::getWriteCategory {this name} {
    set writeAccess [$this writeAccess]
    if { $writeAccess == "None" } {
        return ""
    } elseif { $writeAccess == "Protected" } {
        return "protected"
    } elseif { $writeAccess == "Private" } {
        return "private"
    } else {
        return $name
    }
}


# Returns read access specification.
#
method STGAttribute::readAccess {this} {
    set accessList [split [$this getPropertyValue attrib_access] '-']
    return [lindex $accessList 0]
}


# Returns write access specification.
#
method STGAttribute::writeAccess {this} {
    set accessList [split [$this getPropertyValue attrib_access] '-']
    return [lindex $accessList 1]
}

# Do not delete this line -- regeneration end marker



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


# This class is the top level class generator.
# It generates the entire class implementation.

Class STGClass : {STGObject} {
    constructor
    method destructor
    method generate
    method generateRelease
    method generatePrint
    method generateComment
    method generateDefinition
    method generateInheritanceType
    method printGeneratingMessage
    method printCheckingMessage
    method getSTName
    method check
    method checkLocal
    method checkSTName
    method checkFreeTextQuote
    method checkPrint
    method checkInheritance
    method checkAssocAttrSet
    method checkDataAttrSet
    method checkOperationSet
    method checkInheritanceLoop
    method checkMultipleInheritance
    method checkSuperClass
    method checkInheritanceType
    method checkVariableByteInheritance

    # Set if this class is abstract e.g. has an abstract method.
    # It is set by operation generators and used by the constructor
    #  generator.
    # Correct operation assumes that operations are generated
    #  before the constructor!
    #
    attribute isAbstract
    attribute loop

    # nr of error found in current class
    # preventing redundancy
    #
    attribute localErrors
    attribute classImplementation
    attribute super
}

constructor STGClass {class this name} {
    set this [STGObject::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Generate the implementation of this class in grammar
# object classImpl.
#
method STGClass::generate {this classImpl} {
    # cache the implementation object
    $this classImplementation $classImpl

    # just call the methods in the right order
    $this printGeneratingMessage
    $this generateDefinition
    $this generateComment

    # Generate for all the features
    foreach method [$this operationSet]    {
        $method generate
    }
    $this generateRelease

    set constructor [$this constructor]
    if { $constructor != "" } {
        $constructor generate
    }

    if [$globals generatePrint] {
        $this generatePrint
    }

    foreach attribute [$this dataAttrSet] {
        $attribute generate
    }

    foreach attribute [$this genAssocAttrSet] {
        $attribute generate
    }

    $this classImplementation ""
}


# Generates the release method and part of it's
# implementation.
#
method STGClass::generateRelease {this} {
    set classImpl [$this classImplementation]
    set release [$classImpl getInstanceMethodImplementation "release" \
                     "initialize-release"]
    $release addExpression "super release"
    $release hasUserCodePart 1
    $classImpl release $release
}


# Generates the printing methods and part of
# their implementation. If there is a user defined method
# with the same selector don't generate.
#
method STGClass::generatePrint {this} {
    set classImpl [$this classImplementation]

    # in checkPrint only oopl can be used
    # here we can use the target model
    if { [$classImpl methodExists "printOn:"] || \
             [$classImpl methodExists "printVars:withIndent:"] } {
        # not generating print functions
        set printOn ""
        set printVars ""
    } else {
        set printOn [$classImpl getInstanceMethodImplementation \
                         "printOn:" "printing"]
        set printVars [$classImpl getInstanceMethodImplementation \
                           "printVars:withIndent:" "printing"]

        $printOn addArgument aStream
        $printVars addArgument aStream
        $printVars addArgument anInteger

        # generate start of printOn implementation
        $printOn addExpression "super printOn: aStream"

        # if super class is in this system call it's printVars
        if { [$this super] != "" } {
            if { ![[$this super] isExternal] } {
                $printVars addExpression \
                    "super printVars: aStream withIndent: anInteger"
            }
        }
    }
    # cache the methods
    $classImpl printOn $printOn
    $classImpl printVars $printVars
}


# Generate the FreeText property in the class comment.
#
method STGClass::generateComment {this} {
    if [regsub -all \' [$this getPropertyValue freeText] "" comment] {
        # '-s removed
    }
    [$this classImplementation] addCommentLine $comment
}


# Generate superclass, inheritance type and category
# in the classImplementation object. Sets the super
# association.
#
method STGClass::generateDefinition {this} {
    set classImpl [$this classImplementation]

    # get superclass
    set gnodeSet [$this genNodeSet]

    if { [llength $gnodeSet] > 1 } {

    }
    if { [llength $gnodeSet] == 0 } {
        $this super ""
        $classImpl super "Object"
    } else {
        $this super [[lindex $gnodeSet 0] superClass]
        $classImpl super [[$this super] getSTName]
    }
    # warning for checkMultipleInheritance and checkSuperClass
    #  already generated.

    $this generateInheritanceType

    # get category
    set category [$this getPropertyValue classCategory]
    if { $category == "" } {
        # not set, use default: diagram or system name
        if { [$globals defaultCategory] == "System" } {
            set cc [ClientContext::global]
            set category [[[$cc currentSystem] system] name]
        } else {
            # more complicated: get all components and find first
            # diagram
            set smNode [$this smNode]
            set component [lindex [$smNode getComponents] 0]
            set category [[[$component diagram] file] name]
        }
    }
    $classImpl category $category
}


# Generates inheritance type from the property inheritanceType.
# Perfroms checks on this type and issues warnings or errors if it
# is likely to give problems in Smalltalk.
#
method STGClass::generateInheritanceType {this} {
    set errornr 0
    set inheritanceType [$this getPropertyValue inheritanceType]

    if { ($inheritanceType == "regular") || ($inheritanceType == "") } {
        [$this classImplementation] inheritanceType ""
        set inheritanceType "regular"
    } else {
        [$this classImplementation] inheritanceType $inheritanceType
    }

    # warnings for checkInheritanceType and checkVariableByteInheritance
    #  already given.

}


# Print a message stating that generation for this class is in progress.
#
method STGClass::printGeneratingMessage {this} {
    m4_message $MST_GENERATE [$this getName]
}

method STGClass::printCheckingMessage {this} {
    m4_message $MST_CHECK [$this getName]
}


# Redefines getSTName to make sure the class name starts with an uppercase charcter.
#
method STGClass::getSTName {this} {
    if { [$this stName] == "" } {
        $this stName [cap [$this asSTName [$this getName]]]
    }
    return [$this stName]
}


# Like generate check is called from outside the object.
# Check calls all sub check-methods for generating errors and warnings
# withoug code generation.
# Generate also calls these sub-check-methods and depending on the
# return values, code is generated.
#
method STGClass::check {this} {
    set errornr 0
    incr errornr [$this checkLocal]
    return $errornr
}

method STGClass::checkLocal {this} {
    set errornr 0
    set warningnr 0
    $this printCheckingMessage

    incr warningnr [$this checkFreeTextQuote]

    set constructor [$this constructor]
    if { $constructor != "" } {
        incr errornr [$constructor check]
    }

    incr errornr [$this checkSTName]

    incr warningnr [$this checkPrint]

    incr errornr [$this checkInheritance]

    incr errornr [$this checkDataAttrSet]

    incr errornr [$this checkOperationSet]

    incr errornr [$this checkAssocAttrSet]
    return $errornr
}

method STGClass::checkSTName {this} {
    set errornr 0
    set warningnr 0

    if { [$this stName] != "" } {
        return $errornr
    }
    if [catch { set oldName [$this getName] } ] {
        m4_error $EST_FAILNONAME
        incr errornr 1
        return $errornr
    }
    # remove illegal characters from name
    # Illegal characters are all characters except a-z, A-Z, 0-9 and _
    if [regsub -all {[^a-zA-Z0-9_]} [$this getName] "" newName ] {
        m4_warning $WST_REMOVECHARS $oldName
        incr warningnr 1
    }
    # check whether first letter is cappitalized
    set capName [cap $newName]
    if {$newName != $capName} {
        m4_warning $WST_CAPITCLASS $oldName $capName
        incr warningnr 1
        set newName $capName
    }
    $this stName $newName

    return $errornr

}

method STGClass::checkFreeTextQuote {this} {
    set warningnr 0
    if [regexp \' [$this getPropertyValue freeText] comment] {
        m4_warning $WST_REMOVEQUOTEDESCR [$this getSTName]
        incr warningnr 1
    }
    return $warningnr
}

method STGClass::checkPrint {this} {
    set warningnr 0
    if [$globals generatePrint] {
        set wrnPrn 0
        foreach operation [$this operationSet] {
            set selector [$operation getSelector]
            if { ($selector == "printOn:") || \
                     ($selector == "printVars:withIndent:") } {
                # a corresponding print function is found , so warn somebody
                m4_warning $WST_NOGENPRINT
                incr warningnr 1
                break
            }
        }
    }
    return $warningnr
}

method STGClass::checkInheritance {this} {
    # when a check returns a warning value is stored in
    # a temporary variable.
    set errornr 0

    incr errornr [$this checkSuperClass]

    incr errornr [$this checkMultipleInheritance]

    incr errornr [$this checkInheritanceLoop]

    incr errornr [$this checkInheritanceType]

    incr errornr [$this checkVariableByteInheritance]

    return $errornr
}

method STGClass::checkAssocAttrSet {this} {
    set errornr 0
    set dataAttrs [List new]
    foreach attribute [$this dataAttrSet] {
        set dName [$attribute getSTName]
        $dataAttrs append $dName
    }
    set oppQualifiers [List new]
    set opposite ""
    foreach association [$this genAssocAttrSet] {
        incr errornr [$association check]
        # check opposite qualifier names , so this class will not have
        # duplicates.
        set aOT [[$association generator] objType]
        set aRN [[$association generator] roleName]
        if {$aOT == "STGManyQual"} {
            set name "${aRN}SetDict"
        } elseif {$aOT == "STGOneQual"} {
            set name "${aRN}Dict"
        } elseif {$aOT == "STGAssocMany"} {
            set name "${aRN}Set"
        } else {
            set name "${aRN}"
        }
        if {[$dataAttrs search -exact $name] >= 0} {
            m4_error $EST_ASSOCEQALDATA [$association getName] \
                [$this getSTName] $name
        }
        set opposite [$association opposite]
        if {$opposite != ""} {
            if {[$opposite isQualified]} {
                set qualifier [$opposite qualifier]
                set qualStName [$qualifier stName]
                set qualName [$qualifier getSTName]
                #reset
                $qualifier stName $qualStName
                # retrieve user specified qualifier
                set userQualName [$opposite getPropertyValue qualifierName]
                if { $userQualName != "" } {
                    set qualName $userQualName
                }
                if {[$dataAttrs search -exact $qualName] >= 0} {
                    m4_error $EST_DATAOPPQUAL [$association getName] \
                        [$this getSTName] $qualName
                } elseif {[$oppQualifiers search -exact $qualName] >= 0} {
                    m4_error $EST_DUPOPPQUAL [$association getName] \
                        [$this getSTName] $qualName
                } else {
                    $oppQualifiers append $qualName
                }
            }
        }
    }
    return $errornr
}

method STGClass::checkDataAttrSet {this} {
    set errornr 0
    foreach attribute [$this dataAttrSet] {
        incr errornr [$attribute check]
    }
    return $errornr
}

method STGClass::checkOperationSet {this} {
    set errornr 0
    foreach operation [$this operationSet] {
        incr errornr [$operation check]
    }
    return $errornr
}

method STGClass::checkInheritanceLoop {this} {
    # inheritance loop:
    set errornr 0
    if {[$this loop] != 1} {
        $this loop 1
        set gnodeSet [$this genNodeSet]
        if { [llength $gnodeSet] > 0 } {
            set errornr [[[lindex $gnodeSet 0] superClass] checkInheritanceLoop]
        }
        $this loop 0
    } else {
        set errornr 1
    }
    return $errornr
}

method STGClass::checkMultipleInheritance {this} {
    set errornr 0
    set gnodeSet [$this genNodeSet]
    if { [llength $gnodeSet] > 1 } {
        m4_error $EST_MULTINHERIT [$this getSTName]
        set errornr 1
    }
    return $errornr
}

method STGClass::checkSuperClass {this} {
    # besides checking also set some things,
    # ok, it is not necessary for checking but though for generation
    # (keeping code clean be doing sometimes something too much.)
    set errornr 0
    set gnodeSet [$this genNodeSet]
    # when checking no classImplementation is set (unlike generating)
    set classImpl [$this classImplementation]

    if { [llength $gnodeSet] == 0 } {
        m4_warning $WST_NOSUPERCLASS [$this getSTName]
        $this super ""
        if {$classImpl != "" } {
            $classImpl super "Object"
        }
        set errornr 0
    } else {
        $this super [[lindex $gnodeSet 0] superClass]
        if {$classImpl != "" } {
            $classImpl super [[$this super] getSTName]
        }
    }
    return $errornr
}

method STGClass::checkInheritanceType {this} {
    set errornr 0

    set inheritanceType [$this getPropertyValue inheritanceType]
    if { ($inheritanceType == "regular") || ($inheritanceType == "") } {
        set inheritanceType "regular"
    }

    if { [$this super] != "" } {
        set superInheritanceType [[$this super] getPropertyValue inheritanceType]
        if { $superInheritanceType == "" } {
            set superInheritanceType "regular"
        }

        # different inheritance types with superclass inheritance other
        # than regular may cause trouble. Print cautious warning as we don't
        # know for sure Smalltalk will reject it.
        if { ($superInheritanceType != $inheritanceType) && \
                 ($superInheritanceType != "regular") } {
            m4_warning $WST_DIFFINHERITTYPE [$this getSTName] $inheritanceType \
                [[$this super] getSTName] $superInheritanceType
            set errornr 0
        }
    }
    return $errornr
}

method STGClass::checkVariableByteInheritance {this} {
    set errornr 0

    set inheritanceType [$this getPropertyValue inheritanceType]
    if { $inheritanceType != "variableByte" } {
        return $errornr
    }

    # If this class has instance variables (possibly by
    # inheritance it may not be accepted by Smalltalk
    # So scan superclasses. This may be slow but variableByte inheritance
    # will not be used very often (?)

    set checkClass $this
    set hasInstanceVariables 0
    while { $checkClass != "" } {
        # when a loop is present this while loop
        # not end so setting loop variable.
        # the actual loop detection is in another method.
        if {[$checkClass loop] == 1 } {
            break
        }
        $checkClass loop 1
        lappend checkedClasses $checkClass

        # associations cause instance variables
        if { [$checkClass genAssocAttrSet] != "" } {
            set hasInstanceVariables 1
            break
        }
        # data attributes cause instance variables if the isPoolDict
        # property is not set and isClassFeature returns 0
        foreach dataAttr [$checkClass dataAttrSet] {
            if { (![$dataAttr isClassFeature]) && \
                     ([$dataAttr getPropertyValue isPoolDict] != "1") } {
                set hasInstanceVariables 1
                break
            }
        }
        # find superclass
        set gnodeSet [$checkClass genNodeSet]
        if { [llength $gnodeSet] == 0 } {
            # break while
            set checkClass ""
        } else {
            # next loop
            set checkClass [[lindex $gnodeSet 0] superClass]
        }
    }
    if $hasInstanceVariables {
        m4_warning $WST_VARBYTEINHERIT [$this getSTName]
        set errornr 0
    }

    # setting all loop variables back to zero
    foreach checkClass $checkedClasses {
        $checkClass loop 0
    }
    set checkedClasses ""

    return $errornr
}

# Do not delete this line -- regeneration end marker

if [isCommand CMClass] {
    Class  STGClassD : {STGClass CMClass} {
    }
} else {
    Class STGClassD : {STGClass OPClass} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPClass) STGClassD

selfPromoter OPClass {this} {
    STGClassD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stgconstru.tcl    /main/titanic/3


# Constructor generator class.

Class STGConstructor : {STGObject} {
    constructor
    method destructor
    method generate
    method getMethodImplementation
    method generateDescription
    method generateNew
    method generateRestrictedNew
    method getSelector
    method getMessage
    method checkLocal
    method checkFreeTextDQuote
    method checkNew

    # Indicates whether the instance creation method must be generated.
    # Set by super class initializer.
    #
    attribute newRequired

    # Used to store the selector for the instance creation method. Set in getMethodImplementation.
    #
    attribute newSelector
    attribute methodImplementation
}

constructor STGConstructor {class this name} {
    set this [STGObject::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Generates the equivalent of a constructor:
# * determines message selector and gets implementation object.
# * Generates a description
# * generates for the initializers
# * generates a redefined new if required.
# * generates a new if indicated by newRequired.
#
method STGConstructor::generate {this} {
    $this getMethodImplementation
    $this generateDescription
    # default for newRequired is 1
    $this newRequired 1
    foreach initializer [$this initializerSet] {
        $initializer generate
    }
    # Generate restricted new if another instance creation method is generated
    if { ([$this newSelector] != "new") && [$this newRequired] } {
        $this generateRestrictedNew
    }
    if [$this newRequired] {
        $this generateNew
    }
    $this methodImplementation ""
}


# Determines the message selector for the initialize method and gets
# an implementation object. Sets the 'initialize' association of
# the class implementation object.
#
method STGConstructor::getMethodImplementation {this} {
    set parList [List new]
    foreach parameter [[$this ooplClass] creationParamSet] {
        $parList append [$this asSTName [$parameter getOriginalName]]
    }

    set selector [$this getSelector initialize $parList]
    $this newSelector [$this getSelector new $parList]

    # Now get the implementation object
    set classImpl [[$this ooplClass] classImplementation]
    set initialize [$classImpl getInstanceMethodImplementation $selector \
                        "initialize-release"]
    # Store in generators
    $classImpl initialize $initialize
    $this methodImplementation $initialize

    $initialize hasUserCodePart 1
}


# Generates the freetext comment.
#
method STGConstructor::generateDescription {this} {
    #juno: check whether \" works instead of previous surrounded by braces
    if [regsub -all \" [$this getPropertyValue freeText] "" comment] {
        # "-s removed
    }

    [$this methodImplementation] comment $comment
}


# Generates the instance creation method which
# calls initialize. If the class is abstract generate
# expressions to check if this class can be instantiated.
#
method STGConstructor::generateNew {this} {
    set selector [$this newSelector]

    # get implementation object
    set classImpl [[$this ooplClass] classImplementation]
    set new [$classImpl getClassMethodImplementation $selector "instance creation"]

    if [$new isUserDefined] {
        # m4_warning $WST_DEFCONSTRULES
        $new isUserDefined 0
    }

    # Create the initialize message
    set initSelector [[$this methodImplementation] selector]
    set argNames [List new]
    [[$this methodImplementation] getArguments] foreach argName {
        $argNames append [$new getNewUniqueArgumentName $argName]
    }
    set initMessage [$this getMessage $initSelector $argNames]

    # Make the new or basicNew message
    if { ($selector != "new") && ([$this superClassInitializerSet] != "") } {
        set newMessage "self basicNew"
    } else {
        set newMessage "super new"
    }

    # Add to implementation
    # Make it conditional for abstract classes
    set block $new
    if { [[$this ooplClass] isAbstract] == 1} {
        set className [[$this ooplClass] getSTName]
        set block [$new addExpression "(self class = $className) ifTrue:"]
        $block addExpression "\^self error: \'Cannot instantiate abstract class\'"
        set block [$block addExpressionPart "ifFalse:"]
    }
    $block addExpression "^$newMessage $initMessage"
}


# Generate a new that forbids use of new.
#
method STGConstructor::generateRestrictedNew {this} {
    set classImpl [[$this ooplClass] classImplementation]
    set new [$classImpl getClassMethodImplementation "new" "instance creation"]
    if [$new isUserDefined] {
        # m4_warning $WST_AUTOCONSTRULES
        $new isUserDefined 0
    }
    $new addExpression "self error: \'Cannot use new, use [$this newSelector]\'"
}


# Returns selector for initialize or new.
# Base it on the <firstPart> of the selector
# and the <parameterNames>.
#
method STGConstructor::getSelector {this firstPart parameterNames} {
    set first 1
    set selector $firstPart
    $parameterNames foreach parName {
        if $first {
            if { $selector == "new" } {
                set selector "$parName:"
            } else {
                set selector "$selector[cap $parName]:"
            }
            set first 0
        } else {
            set selector "$selector$parName:"
        }
    }
    return $selector
}


# Makes a message with selector and the arguments of argList.
#
method STGConstructor::getMessage {this selector argList} {
    set selectorPartList [split $selector ':']
    set message [lindex $selectorPartList 0]
    set index 0
    $argList foreach argName {
        if { $index > 0 } {
            set message "$message [lindex $selectorPartList $index]: $argName"
        } else {
            set message "$message: $argName"
        }
        set index [expr $index+1]
    }
    return $message
}

method STGConstructor::checkLocal {this} {
    set errornr 0
    set warningnr 0
      incr warningnr [$this checkFreeTextDQuote]
      incr warningnr [$this checkNew]
    return $errornr
}

method STGConstructor::checkFreeTextDQuote {this} {
    set warningnr 0
    if [regexp \" [$this getPropertyValue freeText] comment] {
        m4_warning $WST_REMOVEDQUOTECST [$this getSTName]
        incr warningnr 1
    }
    return $warningnr
}

method STGConstructor::checkNew {this} {
    # this code is greped from almost everywhere, so
    # check local model can be executed without using
    # the target model, as was be done while checking
    # during generation.
    set warningnr 0
    # some pre stuff:
    # from getMethodImplementation:
    set parList [List new]
    foreach parameter [[$this ooplClass] creationParamSet] {
        $parList append [$this asSTName [$parameter getOriginalName]]
    }
    set selector [$this getSelector initialize $parList]
    set newSelector [$this getSelector new $parList]


    set isUserDefined 0

    # default for newRequired is 1
    $this newRequired 1
    # check every initializer to test whether newRequired must be set:
    foreach initializer [$this initializerSet] {
        $initializer check
    }
    # Generate restricted new if another instance creation method is generated
    if { ($newSelector != "new") && [$this newRequired] } {
        # RestrictedNew
        # find in the operationSet a class method corresponding to the
        #  generated new by testing the method selector
        foreach method [[$this ooplClass] operationSet] {
            # determine whether class method
            if [$method isClassFeature] {
                # determine method selector
                set mSelector [$method getSelector]
                if {($mSelector == "new") || \
                        ($mSelector == $newSelector)} {
                    # found, so now test whether isUserDef and try to reset
                    #  as done in STGOperation::generate :
                    set isUserDefined 1
                    if [$method isAbstract] {
                        [$method ooplClass] isAbstract 1
                        set isUserDefined 0
                    } else {
                        set tclGenerator [$method getPropertyValue method_impl]
                        if { $tclGenerator != "" } {
                            # when an error in TclCall then reset:
                            if { [$method checkTclCall $tclGenerator] != 0 } {
                                set isUserDefined 0
                            }
                        }
                    }
                    # a match found so break
                    break
                }
            }
        }
        if {$isUserDefined} {
            m4_warning $WST_AUTOCONSTRULES
            set isUserDefined 0
        }
    } elseif [$this newRequired] {
        # New
        # find in the operationSet a class method corresponding to the
        #  generated new by testing the method selector
        foreach method [[$this ooplClass] operationSet] {
            # determine whether class method
            if [$method isClassFeature] {
                # determine selector
                set mSelector [$method getSelector]
                if {($mSelector == $newSelector) } {
                    # found, so now test whether isUserDef and try to reset
                    #  as done in STGOperation::generate :
                    set isUserDefined 1
                    if [$method isAbstract] {
                        [$method ooplClass] isAbstract 1
                        set isUserDefined 0
                    } else {
                        set tclGenerator [$method getPropertyValue method_impl]
                        if { $tclGenerator != "" } {
                            # when an error in TclCall then reset:
                            if { [$method checkTclCall $tclGenerator] != 0 } {
                                set isUserDefined 0
                            }
                        }
                    }
                    # a match found so break
                    break
                }
            }
        }
        if {$isUserDefined} {
            m4_warning $WST_DEFCONSTRULES
            set isUserDefined 0
        }
    }
    return $warningnr
}

# Do not delete this line -- regeneration end marker

if [isCommand CMConstructor] {
    Class  STGConstructorD : {STGConstructor CMConstructor} {
    }
} else {
    Class STGConstructorD : {STGConstructor OPConstructor} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPConstructor) STGConstructorD

selfPromoter OPConstructor {this} {
    STGConstructorD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stgctorpar.tcl    /main/titanic/3


# Generator class for constructor parameters.

Class STGCtorParameter : {STGObject} {
    constructor
    method destructor
    method argumentName
}

constructor STGCtorParameter {class this name} {
    set this [STGObject::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Determine the name of the parameter when used as argument:
# base it on the name for an association attribute, or the type or name for another type
# of attribute.
#
method STGCtorParameter::argumentName {this} {
    set attrib [$this attrib]
    if { $attrib != "" } {
    return [$attrib getArgumentName]
    } else {
    return [$this asArgument [$this getSTName]]
    }
}

# Do not delete this line -- regeneration end marker

if [isCommand CMCtorParameter] {
    Class  STGCtorParameterD : {STGCtorParameter CMCtorParameter} {
    }
} else {
    Class STGCtorParameterD : {STGCtorParameter OPCtorParameter} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPCtorParameter) STGCtorParameterD

selfPromoter OPCtorParameter {this} {
    STGCtorParameterD promote $this
}


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


# This class is the generator for user defined operations.

Class STGOperation : {STGObject} {
    constructor
    method destructor
    method generate
    method getMethodImplementation
    method generateAbstractMethod
    method generateDescription
    method doTclCall
    method getCategory
    method getClassCategory
    method getMethodAccess
    method getSelector
    method getOperatorSelector
    method getSpecialCharacter
    method checkLocal
    method checkTclCall
    method checkOperatorSelector
    method checkParams
    method checkFreeTextQuote
    method checkFreeTextDQuote
    attribute methodImplementation
}

constructor STGOperation {class this name} {
    set this [STGObject::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Generates for user defined operation:
# * determines category and type (instance or class or user defined constructor).
# * determines message selector.
# * Gets a method implementation object.
# * Generates comment
# * Generates for the parameters
# * Generates for abstract methods.
# * Calls Tcl method if required.
#
method STGOperation::generate {this} {
    $this getMethodImplementation
    $this generateDescription

    foreach parameter [$this parameterSet] {
        $parameter generate [$this methodImplementation]
    }
    if [$this isAbstract] {
        $this generateAbstractMethod
        [$this methodImplementation] isUserDefined 0
        return
    }
    set tclGenerator [$this getPropertyValue method_impl]
    if { $tclGenerator != "" } {
        [$this methodImplementation] isUserDefined 0
        if { ![$this doTclCall $tclGenerator] } {
            [$this methodImplementation] isUserDefined 1
        }
    }
    $this methodImplementation ""
}


# Determines category, type and message selector and gets
# a method implementation object.
# Sets the methodImplementation association.
# If the operator name starts with operator,
# a redefined operator is assumed and translation is done.
#
method STGOperation::getMethodImplementation {this} {
    set category [$this getCategory]
    # If name starts with operator call operator naming. If this does not
    # work use normal naming
    if [string match operator* [$this getName]] {
        set selector [$this getOperatorSelector]
        if { $selector == "" } {
            set selector [$this getSelector]
        }
    } else {
        set selector [$this getSelector]
    }
    # Now get the implementation object through the class implementation
    set classImpl [[$this ooplClass] classImplementation]
    if [$this isClassFeature] {
        set operation [$classImpl getClassMethodImplementation $selector $category]
    } else {
        set operation [$classImpl getInstanceMethodImplementation $selector $category]
    }
    # Now store implementation in this generator
    $this methodImplementation $operation

    [$this methodImplementation] isUserDefined 1
}


# Generates for an abstract method.
# Sets isAbstract attribute of corresponding class.
#
method STGOperation::generateAbstractMethod {this} {
    [$this methodImplementation] addExpression "self subclassResponsibility"
    [$this ooplClass] isAbstract 1
}


# Generates comment based on free text property.
#
method STGOperation::generateDescription {this} {
    if [regsub -all \" [$this getPropertyValue freeText] "" comment] {
        # "-s removed
    }

    [$this methodImplementation] comment $comment
}


# Calls Tcl Implementation Method if it
# has been defined. Checks that it exists first.
#
method STGOperation::doTclCall {this generatorMethod} {
    set index [string first "::" $generatorMethod]
    if { $index > 0 } {
        set className [string range $generatorMethod 0 [expr $index-1]]
        set generatorMethod [string range $generatorMethod [expr $index+2] end]
    } else {
        set className STGCustom
    }
    # all error already generated
    if { [info commands $className] == "" } {
        # m4_error $EST_NOTCLMETHCLS [$this getSTName]
        return 0
    }
    if { [$className info supers] == "STGOperation" } {
        # m4_error $EST_TCLUPDDERIV $className
        return 0
    }
    if { [$className info supers] != "STGOperationD" } {
        # m4_error $EST_TCLGENDERIV $className
        return 0
    }
    if { [lsearch [$className info methods] $generatorMethod] == -1 } {
        # m4_error $NOTCLMETH $generatorMethod [$this getSTName]
        return 0
    }

    # Found : promote to custom class and execute method
    $className promote $this
    if [catch {
        $this $generatorMethod [$this methodImplementation]
    } error] {
        m4_error $EST_CALL $generatorMethod $error
        return 0
    }
    return 1
}


# Returns category for this operation.
#
method STGOperation::getCategory {this} {
    # both method_access and classCategory are used
    # to determine the category.
    # Protected and Private have precedence:
    set category [$this getMethodAccess]
    if {$category != ""} {
        return $category
    }
    set category [$this getClassCategory]
    return $category
}

method STGOperation::getClassCategory {this} {
    # special naming for used defined constructor
    if { [$this getName] == "create" } {
        set category "instance creation"
    } else {
        set category "misc"
    }
    # Override default category if another one is specified
    set userCategory [$this getPropertyValue methodCategory]
    if { $userCategory != "" } {
        set category $userCategory
    }
    return $category
}

method STGOperation::getMethodAccess {this} {
    set methodAccess [$this getPropertyValue method_access]
    if { $methodAccess == "Public" } {
        return ""
    } elseif { $methodAccess == "Protected" } {
        return "protected"
    } elseif { $methodAccess == "Private" } {
        return "private"
    } else {
        return ""
    }
}


# Returns selector for this operation.
#
method STGOperation::getSelector {this} {
    if { [$this getSTName] == "create" } {
        set selector "new"
    } else {
        set selector [$this getSTName]
    }

    set first 1
    foreach parameter [$this parameterSet] {
        set parName [$parameter getSTName]
        if $first {
            set first 0
            if { $selector == "new" } {
                set selector "$parName:"
            } else {
                set selector "$selector:"
            }
        } else {
            set selector "$selector$parName:"
        }
    }
    return $selector
}


# Returns a Smalltalk compliant operator selector for this operation.
# It assumes that the name starts with 'operator'.
# Perform check on number of arguments.
#
method STGOperation::getOperatorSelector {this} {
    # Assume name starts with operator and strip it
    set operatorChars [string range [$this getName] 8 end]

    # Now check if it really is a special operator
    # if not return empty string
    if { $operatorChars == "" } {
        return ""
    }
    # - workaround
    if { $operatorChars == "-"} {
        if { [llength [$this parameterSet]] != 1 } {
            # m4_error $EST_ONEARG "-"
            return ""
        }
        return "operator-"
    }
    # If the first character is not a special character we assume that
    # this is not a special operator
    set firstSpecialCharacter [$this getSpecialCharacter operatorChars]
    if { $firstSpecialCharacter == "" } {
        return ""
    }
    set secondSpecialCharacter ""
    if { $operatorChars != "" } {
        set secondSpecialCharacter [$this getSpecialCharacter operatorChars]
        if { $secondSpecialCharacter == "" } {
            # m4_error $EST_INVALIDSYNT [$this getName]
            return ""
        }
    }
    # More characters?? Not syntax compliant so ignore it.
    if { $operatorChars != "" } {
        # m4_error $EST_INVALIDSYNT [$this getName]
        return ""
        }

    # Now check if there is exactly one argument
    if { [llength [$this parameterSet]] != 1 } {
        # m4_error $EST_ONEARG [$this getName]
        return ""
    }
    return "$firstSpecialCharacter$secondSpecialCharacter"
}


# If <chars> starts with a special character, strip it from chars
# and return it.
#
method STGOperation::getSpecialCharacter {this chars} {
    upvar $chars characters
    # Implementation comment: the - as selector name gives problems.
    # Workaround: do nothing with - here but just leave it as operator-
    # and convert in language model. Dirty, but it works
    if [string match "\[\+\\\*\~\<\>\@\%\|\&\?\!\]*" $characters] {
        set result [string index $characters 0]
        set characters [string range $characters 1 end]
        return $result
    }
    foreach name "DIV EQ COMMA" {
        if [string match $name* $characters] {
            set characters [string range $characters [string length $name] end]
            if { $name == "DIV" } {
                return "\/"
            }
            if { $name == "EQ" } {
                return "\="
            }
            return ","
        }
    }
    return ""
}

method STGOperation::checkLocal {this} {
    set errornr 0
    set warningnr 0

    incr errornr [$this checkOperatorSelector]
    if {$errornr == 0 } {
        # there may be an operator so first get that
        # one and if empty then check STName
        if { [$this getOperatorSelector] == "" } {
            incr errornr [$this checkSTName]
        }
    }

    incr warningnr [$this checkFreeTextDQuote]
    incr errornr [$this checkTclCall]

    return $errornr
}

method STGOperation::checkTclCall {this} {
    set errornr 0
    set generatorMethod [$this getPropertyValue method_impl]
    if { $generatorMethod != "" } {
        set index [string first "::" $generatorMethod]
        if { $index > 0 } {
            set className [string range $generatorMethod 0 [expr $index-1]]
            set generatorMethod [string range $generatorMethod [expr $index+2] end]
        } else {
            set className STGCustom
        }
        if { [info commands $className] == "" } {
            m4_error $EST_NOTCLMETHCLS $className [$this getSTName]
            incr errornr 1
        } elseif { [$className info supers] == "STGOperation" } {
            m4_error $EST_TCLUPDDERIV $className
            incr errornr 1
        } elseif { [$className info supers] != "STGOperationD" } {
            m4_error $EST_TCLGENDERIV $className
            incr errornr 1
        } elseif { [lsearch [$className info methods] $generatorMethod] == -1 } {
            m4_error $EST_NOTCLMETH $generatorMethod [$this getSTName]
            incr errornr 1
        }
    }
    return $errornr
}

method STGOperation::checkOperatorSelector {this} {
    set errornr 0
    # Assume name starts with operator and strip it
    set operatorChars [string range [$this getName] 8 end]

    # Now check if it really is a special operator
    # if not return empty string
    if { $operatorChars == "" } {
        return $errornr
    } elseif { $operatorChars == "-"} {
    # - workaround
        if { [llength [$this parameterSet]] != 1 } {
            m4_error $EST_ONEARG "-"
            incr errornr 1
            return $errornr
        }
        return $errornr
    }

    # If the first character is not a special character we assume that
    # this is not a special operator
    set firstSpecialCharacter [$this getSpecialCharacter operatorChars]
    set secondSpecialCharacter ""
    if { $firstSpecialCharacter == "" } {

    } elseif { $operatorChars != "" } {
        set secondSpecialCharacter [$this getSpecialCharacter operatorChars]
        if { $secondSpecialCharacter == "" } {
            m4_error $EST_INVALIDSYNT [$this getName]
            incr errornr 1
        }
    } elseif { $operatorChars != "" } {
    # More characters?? Not syntax compliant so ignore it.
        m4_error $EST_INVALIDSYNT [$this getName]
        incr errornr 1
    } elseif { [llength [$this parameterSet]] != 1 } {
    # Now check if there is exactly one argument
        m4_error $EST_ONEARG [$this getName]
        incr errornr 1
    }
    return $errornr
}

method STGOperation::checkParams {this} {
    set errornr 0

    if { [$this getSTName] == "create" } {
        set selector "new"
    } else {
        set selector [$this getSTName]
    }

    set first 1
    foreach parameter [$this parameterSet] {
        if $first {
            set first 0
            if { $selector == "new" } {
                set parName [$parameter getSTName]
                incr errornr [$parameter checkSTName]
                set selector "$parName:"
            } else {
                set selector "$selector:"
            }
        } else {
            set selector "$selector$parName:"
            incr errornr [$parameter checkSTName]
        }
    }
    return $errornr
}

method STGOperation::checkFreeTextQuote {this} {
    set warningnr 0
    if [regexp \' [$this getPropertyValue freeText] comment] {
        m4_warning $WST_REMOVEQUOTE [$this getSTName]
        incr warningnr 1
    }
    return $warningnr
}

method STGOperation::checkFreeTextDQuote {this} {
    set warningnr 0
    if [regexp \" [$this getPropertyValue freeText] comment] {
        m4_warning $WST_REMOVEDQUOTE [$this getSTName]
        incr warningnr 1
    }
    return $warningnr
}

# Do not delete this line -- regeneration end marker

if [isCommand CMOperation] {
    Class  STGOperationD : {STGOperation CMOperation} {
    }
} else {
    Class STGOperationD : {STGOperation OPOperation} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPOperation) STGOperationD

selfPromoter OPOperation {this} {
    STGOperationD promote $this
}


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


# Generator for operation parameters.

Class STGOperParameter : {STGObject} {
    constructor
    method destructor
    method generate
    method argumentName
}

constructor STGOperParameter {class this name} {
    set this [STGObject::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Generates argument name in method implementation and
# default value if required.
#
method STGOperParameter::generate {this methodImplementation} {
    set argName [$this getArgumentName]
    set argName [$methodImplementation getNewUniqueArgumentName $argName]
    set defaultValue [$this getPropertyValue default_value]

    # If there is a default value add a conditional assignment
    if { $defaultValue!= "" } {
        set assign [$methodImplementation addExpression \
                        "$argName isNil ifTrue:"]
        $assign addExpression "$argName := $defaultValue"
    }
}


# Determine the name of the parameter when used as argument:
# base it on the type if it exists and the name otherwise.
#
method STGOperParameter::argumentName {this} {
    set type [$this ooplType]
    if { $type != "" } {
        if { [$type getType3GL] != "" } {
            return [$this asSTName [$this asArgument [$type getType3GL]]]
        } elseif { [$type getName] != "" } {
            return [$this asSTName [$this asArgument [$type getName]]]
        }
    }
    return [$this asArgument [$this getSTName]]
}

# Do not delete this line -- regeneration end marker

if [isCommand CMOperParameter] {
    Class  STGOperParameterD : {STGOperParameter CMOperParameter} {
    }
} else {
    Class STGOperParameterD : {STGOperParameter OPOperParameter} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPOperParameter) STGOperParameterD

selfPromoter OPOperParameter {this} {
    STGOperParameterD promote $this
}


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


# Qualifier generator class, only used for generating argument names.

Class STGQualifier : {STGObject} {
    constructor
    method destructor
    method argumentName
}

constructor STGQualifier {class this name} {
    set this [STGObject::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Returns name for this qualifier when used as an argument.
# base it on the type if it exists
# or the name otherwise.
#
method STGQualifier::argumentName {this} {
    set type [$this ooplType]
    if { $type != "" } {
    if { [$type getType3GL] != "" } {
        return [$this asSTName [$this asArgument [$type getType3GL]]]
    }  elseif { [$type getName] != "" } {
        return [$this asSTName [$this asArgument [$type getName]]]
    }
    }
    return [$this asArgument [$this getSTName]]
}

# Do not delete this line -- regeneration end marker

if [isCommand CMQualifier] {
    Class  STGQualifierD : {STGQualifier CMQualifier} {
    }
} else {
    Class STGQualifierD : {STGQualifier OPQualifier} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPQualifier) STGQualifierD

selfPromoter OPQualifier {this} {
    STGQualifierD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stgqualini.tcl    /main/titanic/3


# Generator for qualifier initializers.
# Qualifier initializers are generated in qualified link
# associations.

Class STGQualInitializer : {STGObject} {
    constructor
    method destructor
    method generate
    method check
}

constructor STGQualInitializer {class this name} {
    set this [STGObject::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Get argument name for initializer and add it to constructor parameters.
#
method STGQualInitializer::generate {this} {
    set constructor [[$this constructor] methodImplementation]
    set argName [[$this qualifier] getArgumentName]
    $constructor getUniqueArgumentName [$this getSTName] $argName
}


# For computing newRequired in
# STGConstructor
#
method STGQualInitializer::check {this} {
    set errornr 0
    incr errornr [$this checkSTName]
    return $errornr
}

# Do not delete this line -- regeneration end marker

if [isCommand CMQualInitializer] {
    Class  STGQualInitializerD : {STGQualInitializer CMQualInitializer} {
    }
} else {
    Class STGQualInitializerD : {STGQualInitializer OPQualInitializer} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPQualInitializer) STGQualInitializerD

selfPromoter OPQualInitializer {this} {
    STGQualInitializerD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stgsupercl.tcl    /main/titanic/3


# This is the generator for super class initializers.

Class STGSuperClassInitializer : {STGObject} {
    constructor
    method destructor
    method generate
    method check
}

constructor STGSuperClassInitializer {class this name} {
    set this [STGObject::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Determines parameter names for super call.
# Generates the call of the initialize method in the super class and
# inserts it as first constructor statement.
# Sets newRequired in the constructor generator:
# 0 if the class to which this initializer
# belongs has the same constructor parameters
# as the superclass, 1 otherwise.
#
method STGSuperClassInitializer::generate {this} {
    if [[$this ooplClass] isExternal] {
        return
    }

    set constructor [$this constructor]
    set initialize [$constructor methodImplementation]

    set parList [List new]
    set argList [List new]
    # get parameter and argument list for super class constructor
    foreach parameter [$this parameterSet] {
        set parName [$this asSTName [$parameter getOriginalName]]
        $parList append $parName
        set argName [$parameter getArgumentName]
        $argList append [$initialize getUniqueArgumentName $parName $argName]
    }

    set superNewSelector [$constructor getSelector new $parList]
    set superInitSelector [$constructor getSelector initialize $parList]
    set superInitMessage [$constructor getMessage $superInitSelector $argList]

    # Insert message to initialize in super as first expression
    $initialize insertExpression "super $superInitMessage"

    # Now compute newRequired
    # needed if difference in constructor parameters or abstract property
    set thisAbstract [[$constructor ooplClass] isAbstract]
    set superAbstract [[$this ooplClass] isAbstract]
    if { ([$constructor newSelector] == $superNewSelector) && \
             ($thisAbstract == $superAbstract) } {
        $constructor newRequired 0
    }
}


# For computing newRequired in
# STGConstructor
#
method STGSuperClassInitializer::check {this} {
    #body is an abstract of generate!
    set errornr 0
    if [[$this ooplClass] isExternal] {
        return $errornr
    }
    incr errornr [$this checkSTName]

    set constructor [$this constructor]

    set parList [List new]
    # get parameter list for super class constructor
    foreach parameter [$this parameterSet] {
        set parName [$this asSTName [$parameter getOriginalName]]
        $parList append $parName
    }

    set superNewSelector [$constructor getSelector new $parList]

    # Now compute newRequired
    # needed if difference in constructor parameters or abstract property
    set thisAbstract [[$constructor ooplClass] isAbstract]
    set superAbstract [[$this ooplClass] isAbstract]
    if { ([$constructor newSelector] == $superNewSelector) && \
             ($thisAbstract == $superAbstract) } {
        $constructor newRequired 0
    }
    return $errornr
}

# Do not delete this line -- regeneration end marker

if [isCommand CMSuperClassInitializer] {
    Class  STGSuperClassInitializerD : {STGSuperClassInitializer CMSuperClassInitializer} {
    }
} else {
    Class STGSuperClassInitializerD : {STGSuperClassInitializer OPSuperClassInitializer} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPSuperClassInitializer) STGSuperClassInitializerD

selfPromoter OPSuperClassInitializer {this} {
    STGSuperClassInitializerD promote $this
}


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


# This is the generator for normal associations with multiplicity many.

Class STGAssocMany : {STGAssocGen} {
    constructor
    method destructor
    method generateData
    method generateSet
    method generateGet
    method generateRemove
    method generateSetRef
    method generateRemoveRef
    method generateRemoveRefMessage
    method generateSetRefMessage
    method generateRemoveMessage
    method generateSetCode
    method generateRemoveCode
    method generateInitialize
    method generateReleaseCode
    method generatePrintCode
    method removeRequired
}

constructor STGAssocMany {class this assocAttr} {
    set this [STGAssocGen::constructor $class $this $assocAttr]
    # Start constructor user section
    # End constructor user section
    return $this
}

method STGAssocMany::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this STGAssocGen::destructor
}


# Generates instance variable to implement this association
# an sets variableName. The name of the instance
# variable is <roleName>Set.
#
method STGAssocMany::generateData {this} {
    set name "[$this roleName]Set"
    [$this classImplementation] addInstanceVariable $name
    $this variableName $name
}


# Generates the set method that adds to the association.
#
method STGAssocMany::generateSet {this} {
    set selector "add[cap [$this roleName]]:"
    set set [$this getModifyImplementation $selector]
    if { $set == "" } {
    return
    }
    $this generateSetCode $set [$this opposite]
}


# Generates the get method which executes a block for all associated objects.
#
method STGAssocMany::generateGet {this} {
    set selector "[$this roleName]SetDo:"
    set get [$this getAccessImplementation $selector]
    if { $get == "" } {
    return
    }

    $get addArgument aBlock
    $get addExpression "[$this variableName] do: aBlock"
}


# Generate the set method remove which removes an element from the association.
#
method STGAssocMany::generateRemove {this} {
    set selector "remove[cap [$this roleName]]:"
    set remove [$this getRemoveImplementation $selector]
    if { $remove == "" } {
    return
    }
    $this generateRemoveCode $remove [$this opposite]
}


# Generates the implementation method to add to the instance variable for the association.
#
method STGAssocMany::generateSetRef {this} {
    set selector "add[cap [$this roleName]]Ref:"
    set setRef [$this getPrivateImplementation $selector]
    $this generateSetCode $setRef ""
}


# Generates the implementation method to remove an element from the
# instance variable for the association.
#
method STGAssocMany::generateRemoveRef {this} {
    set selector "remove[cap [$this roleName]]Ref:"
    set removeRef [$this getPrivateImplementation $selector]
    $this generateRemoveCode $removeRef ""
}


# Generates an expression in block that sends a removeRef message to
# object with parameter <parameter>.
#
method STGAssocMany::generateRemoveRefMessage {this block object parameter args} {
    set removeRefName "remove[cap [$this roleName]]Ref:"
    $block addExpression "$object $removeRefName $parameter"
}


# Generates an expression in block that sends a SetRef message to object
# with parameter <parameter>.
#
method STGAssocMany::generateSetRefMessage {this block object parameter args} {
    set setRefName "add[cap [$this roleName]]Ref:"
    $block addExpression "$object $setRefName $parameter"
}


# Does nothing: present for interface consistency.
#
method STGAssocMany::generateRemoveMessage {this block object args} {
    # Do nothing: remove must not be called for many associations
}


# Generates the expressions for a set method in block.
#
method STGAssocMany::generateSetCode {this block opposite} {
    set name [$this variableName]
    set parName [$this parameterName]
    set selector [$block selector]

    $block addArgument $parName

    set upper [$this upperConstraint]
    if { $upper != "" } {
    set block [$this generateConstraintCheck $selector $block $name $upper upper]
    }

    if { $opposite != "" } {
    $opposite generateRemoveMessage $block $parName
    $opposite generateSetRefMessage $block $parName self
    }

    # add to Set. If it is an orderedCollection check for no duplicates
    if { [$this setType] == "OrderedCollection" } {
    set block [$this generateIncludesCheck $block $name $parName]
    }
    $block addExpression "$name add: $parName"
}


# Generates the expressions for the remove method in block.
#
method STGAssocMany::generateRemoveCode {this block opposite} {
    set name [$this variableName]
    set parName [$this parameterName]
    set selector [$block selector]
    $block addArgument $parName

    # existence check must be done separately with includes:
    set lower [$this lowerConstraint]
    if { $lower != "" } {
    $this generateExistenceCheck $selector $block $name $parName
    set block [$this generateConstraintCheck $selector $block $name $lower lower]
    }

    if { $opposite != "" } {
    $opposite generateRemoveRefMessage $block $parName self
    }

    # Remove it. Different for constraint and no constraint:
    # in the constraint ifAbsent: is not needed because an includes:
    # test was already generated
    set removeText "$name remove: $parName"
    if { $lower == "" } {
    set  removeExpr [$block addExpression "$removeText ifAbsent:"]
    $removeExpr addExpression [$this getErrorMessage ASSOC_OBJ_NOT_FOUND $selector]
    } else {
    $block addExpression $removeText
    }
}


# Generates additions to initialize method, if it exists.
#
method STGAssocMany::generateInitialize {this} {
    set initialize [[$this classImplementation] initialize]
    if { $initialize == "" } {
    return
    }

    $initialize addExpression "[$this variableName] := [$this setType] new"
    if { [$this lowerConstraint] != "" } {
    set comment "Warning: put association [$this roleName] in consistent state"
    $initialize addCommentLine $comment
    }
}


# Generates expressions for addition to release in block.
#
method STGAssocMany::generateReleaseCode {this block} {
    set name [$this variableName]
    set parName [$this parameterName]
    if { [$this opposite] != "" } {
    set setBlock [$block addExpression "$name do:"]
    $setBlock addArgument $parName
    [$this opposite] generateRemoveRefMessage $setBlock $parName self
    }
    $block addExpression "$name := nil"
}


# Generates expressions in block to print information about the association.
#
method STGAssocMany::generatePrintCode {this block} {
    set name [$this variableName]
    $block addExpression "aStream cr; nextPutAll: \'$name:\' displayString"
    set printAll [$block addExpression "$name inject: 1 into:"]
    $printAll addArgument "count"
    $printAll addArgument "element"
    $printAll addExpression "aStream cr; tab; nextPutAll: count printString"
    $printAll addExpression "element printVars: aStream withIndent: 2"
    $printAll addExpression "count + 1"
}


# Returns 0.
#
method STGAssocMany::removeRequired {this} {
    return 0
}

# Do not delete this line -- regeneration end marker



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


# This is the generator for normal associations with multiplicity one.

Class STGAssocOne : {STGAssocGen} {
    constructor
    method destructor
    method generateData
    method generateSet
    method generateGet
    method generateRemove
    method generateSetRef
    method generateRemoveRef
    method generateRemoveRefMessage
    method generateSetRefMessage
    method generateRemoveMessage
    method generateSetCode
    method generateRemoveCode
    method generateInitialize
    method generateInitializeCode
    method generateReleaseCode
    method generatePrintCode
    method removePermitted
}

constructor STGAssocOne {class this assocAttr} {
    set this [STGAssocGen::constructor $class $this $assocAttr]
    # Start constructor user section
    # End constructor user section
    return $this
}

method STGAssocOne::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this STGAssocGen::destructor
}


# Generates instance variable to implement this association
# and sets variableName. The name of the instance
# variable is the roleName.
#
method STGAssocOne::generateData {this} {
    [$this classImplementation] addInstanceVariable [$this roleName]
    $this variableName [$this roleName]
}


# Generates the set method to set the association.
#
method STGAssocOne::generateSet {this} {
    set selector "set[cap [$this roleName]]:"
    set set [$this getModifyImplementation $selector]
    if { $set != "" } {
        $this generateSetCode $set [$this opposite]
    }
}


# Generates the get method which returns the associated object.
#
method STGAssocOne::generateGet {this} {
    set selector "get[cap [$this roleName]]"
    set get [$this getAccessImplementation $selector]
    if { $get != "" } {
        $get addExpression "\^[$this variableName]"
    }
}


# Generates the remove method to remove the association.
#
method STGAssocOne::generateRemove {this} {
    set selector "remove[cap [$this roleName]]"
    set remove [$this getRemoveImplementation $selector]
    if  { $remove != "" } {
        $this generateRemoveCode $remove [$this opposite]
    }
}


# Generates the implementation method to set the instance variable for the association.
#
method STGAssocOne::generateSetRef {this} {
    set selector "set[cap [$this roleName]]Ref:"
    set setRef [$this getPrivateImplementation $selector]
    $this generateSetCode $setRef ""
}


# Does nothing: this method is here to keep the interfaces of the association generators consistent.
#
method STGAssocOne::generateRemoveRef {this} {
    # Not needed for one association: bye
}


# Generates an expression in block that sends a SetRef message to object with parameter nil.
#
method STGAssocOne::generateRemoveRefMessage {this block object parameter args} {
    $this generateSetRefMessage $block $object nil
}


# Generates an expression in block that sends a SetRef message to object with argument parameter.
#
method STGAssocOne::generateSetRefMessage {this block object parameter args} {
    set setRefName "set[cap [$this roleName]]Ref:"
    $block addExpression "$object $setRefName $parameter"
}


# Generates an expression in block that sends a remove message to object.
#
method STGAssocOne::generateRemoveMessage {this block object args} {
    set removeName "remove[cap [$this roleName]]"
    $block addExpression "$object $removeName"
}


# Generates the expressions for a set method in block.
#
method STGAssocOne::generateSetCode {this block opposite} {
    set name [$this variableName]
    set parName [$this parameterName]
    $block addArgument $parName

    # if it is mandatory generate a nil check and an inequality check
    if [[$this assocAttr] isMandatory] {
    $this generateNilCheck $block $parName
    }

    if { $opposite != "" } {
    if [[$this assocAttr] isMandatory] {
        set compare "$name ~~ $parName"
        set block [$block addExpression "($compare) ifTrue:"]
    }
    # remove old links
    $opposite generateRemoveMessage $block $parName
    set removeBlock $block
    if { ![[$this assocAttr] isMandatory]} {
        set removeBlock [$block addExpression "$name isNil ifFalse:"]
    }
    $opposite generateRemoveRefMessage $removeBlock $name self
    # set new link
    $opposite generateSetRefMessage $block $parName self
    }

    $block addExpression "$name := $parName"
}


# Generates the expressions for the remove method in block.
#
method STGAssocOne::generateRemoveCode {this block opposite args} {
    set name [$this variableName]
    # if the association is not mandatory the instance var may be nil
    # generate remove for opposite if it exists

    if { $opposite != "" } {
    if { ![[$this assocAttr] isMandatory] } {
        set nilCheck "$name isNil ifFalse:"
        set block [$block addExpression $nilCheck]
    }
    $opposite generateRemoveRefMessage $block $name self $args
    }

    $block addExpression "$name := nil"
}


# Generates addition to initialize method (if it exists).
#
method STGAssocOne::generateInitialize {this} {
    set initialize [[$this classImplementation] initialize]

    # If there is no initialize method nothing can be generated
    if { $initialize == "" } {
    return
    }

    $this generateInitializeCode $initialize
}


# Generates the expressions for the addition to initialize in block.
#
method STGAssocOne::generateInitializeCode {this block args} {
    set name [$this variableName]
    set parName [$this parameterName]

    if { [[$this assocAttr] hasInitializer] == 1 } {
    set parName [$block getUniqueArgumentName [$this roleName] $parName]
    $this generateNilCheck $block $parName
    if { [$this opposite] != "" } {
        [$this opposite] generateRemoveMessage $block $parName $args
        [$this opposite] generateSetRefMessage $block $parName self $args
    }
    $block addExpression "$name := $parName"
    } else {
    $block addExpression "$name := nil"
    }
}


# Generates additions to release in block.
#
method STGAssocOne::generateReleaseCode {this block} {
    $this generateRemoveCode $block [$this opposite]
}


# Generates expressions in block to print information about the association.
#
method STGAssocOne::generatePrintCode {this block} {
    set name [$this variableName]
    $block addExpression "aStream cr; nextPutAll: \'$name: \' displayString"
    set printOther [$block addExpression "$name isNil ifFalse:"]
    $printOther addExpression "$name printVars: aStream withIndent: 1"
}


# Returns 0 if this association is mandatory, else defaults to RemovePermitted
# in STGAssocGen.
#
method STGAssocOne::removePermitted {this} {
    if [[$this assocAttr] isMandatory] {
    return 0
    }
    return [$this STGAssocGen::removePermitted]
}

# Do not delete this line -- regeneration end marker



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


# This is the generator for qualified associations with multiplicity many.

Class STGManyQual : {STGAssocGen} {
    constructor
    method destructor
    method generateData
    method generateSet
    method generateGet
    method generateRemove
    method generateSetRef
    method generateRemoveRef
    method generateRemoveRefMessage
    method generateSetRefMessage
    method generateRemoveMessage
    method generateSetCode
    method generateRemoveCode
    method generateInitialize
    method generateReleaseCode
    method generatePrintCode
    method removeRequired
}

constructor STGManyQual {class this assocAttr} {
    set this [STGAssocGen::constructor $class $this $assocAttr]
    # Start constructor user section
    # End constructor user section
    return $this
}

method STGManyQual::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this STGAssocGen::destructor
}


# Generates instance variable to implement this association and sets
# variableName to <roleName>SetDict.
#
method STGManyQual::generateData {this} {
    set name "[$this roleName]SetDict"
    [$this classImplementation] addInstanceVariable $name
    $this variableName $name
}


# Generates the set method to set the association for a given qualifier.
#
method STGManyQual::generateSet {this} {
    set selector "add[cap [$this roleName]]:at:"
    set set [$this getModifyImplementation $selector]
    if { $set == "" } {
    return
    }
    $this generateSetCode $set [$this opposite]
}


# Generates the get methods:
# * One that executes a given block for each object associated for a given qualifier.
# * One that executes a given block for each qualifier.
#
method STGManyQual::generateGet {this} {
    set selector "[$this roleName]SetDo:at:"
    set name [$this variableName]
    set qualPar [$this qualifierParameter]
    set get [$this getAccessImplementation $selector]
    if { $get == "" } {
    return
    }

    $get getNewUniqueArgumentName aBlock
    $get getNewUniqueArgumentName $qualPar
    set setName "[$this roleName]s"
    $get addTemporary $setName
    set getSet [$get addExpression "$setName := $name at: $qualPar ifAbsent:"]
    $getSet addExpression [$this getErrorMessage QUAL_NOT_FOUND $selector]
    $get addExpression "$setName do: aBlock"

    set selector "[$this qualifierName]SetDo:"
    set getAll [$this getAccessImplementation $selector]
    $getAll addArgument aBlock
    $getAll addExpression "$name keysDo: aBlock"
}


# Generates the set method that removes an object from the association for a given qualifier.
#
method STGManyQual::generateRemove {this} {
    set selector "remove[cap [$this roleName]]:at:"
    set remove [$this getRemoveImplementation $selector]
    if { $remove != "" } {
        $this generateRemoveCode $remove [$this opposite]
    }
}


# Generates the implementation method to add to the instance variable for the association.
#
method STGManyQual::generateSetRef {this} {
    set selector "add[cap [$this roleName]]Ref:at:"
    set setRef [$this getPrivateImplementation $selector]
    $this generateSetCode $setRef ""
}


# Generates the implementation method to remove from the instance variable for the association.
#
method STGManyQual::generateRemoveRef {this} {
    set selector "remove[cap [$this roleName]]Ref:at:"
    set removeRef [$this getPrivateImplementation $selector]
    $this generateRemoveCode $removeRef ""
}


# Generates an expression in block that sends a message to object with
# parameters <parameter> and <qualifier>.
#
method STGManyQual::generateRemoveRefMessage {this block object parameter qualifier} {
    set removeRefName "remove[cap [$this roleName]]Ref:"
    $block addExpression "$object $removeRefName $parameter at: $qualifier"
}


# Generates an expression in block that sends a setRef message to object
# with parameters <parameter> and <qualifier>.
#
method STGManyQual::generateSetRefMessage {this block object parameter qualifier} {
    set setRefName "add[cap [$this roleName]]Ref:"
    $block addExpression "$object $setRefName $parameter at: $qualifier"
}


# Does nothing.
#
method STGManyQual::generateRemoveMessage {this block object qualifier} {
    # Do nothing for many associations
}


# Generates the expressions for the set method to add to the association
# in block.
#
method STGManyQual::generateSetCode {this block opposite} {
    set name [$this variableName]
    set parName [$this parameterName]
    set qualName [$this qualifierName]
    set qualPar [$this qualifierParameter]
    set selector [$block selector]
    $block addArgument $parName
    $block addArgument $qualPar
    set setName "[$this roleName]s"
    $block addTemporary $setName

    # do size check for constraint
    set upper [$this upperConstraint]
    if { $upper != "" } {
    set block [$this generateConstraintCheck $selector $block $name $upper upper]
    }

    if { $opposite != "" } {
    $opposite generateRemoveMessage $block $parName $qualPar
    $opposite generateSetRefMessage $block $parName self $qualPar
    }

    # Generate to get old set or make a new one
    set newSet [$block addExpression "$setName := $name at: $qualPar ifAbsent:"]
    $newSet addExpression "$setName := [$this setType] new"
    $newSet addExpression "$name at: $qualPar put: $setName"

    if { [$this setType] == "OrderedCollection"} {
    set block [$this generateIncludesCheck $block $setName $parName]
    }

    $block addExpression "$setName add: $parName"
}


# Generates the expressions to remove from the association in block.
#
method STGManyQual::generateRemoveCode {this block opposite} {
    set name [$this variableName]
    set parName [$this parameterName]
    set qualPar [$this qualifierParameter]
    set selector [$block selector]
    $block addArgument $parName
    $block addArgument $qualPar

    # get set from dictionary
    set setName "[$this roleName]s"
    $block addTemporary $setName
    set getSet [$block addExpression "$setName := $name at: $qualPar ifAbsent:"]
    $getSet addExpression [$this getErrorMessage QUAL_NOT_FOUND $selector]

    # check for constraint
    set lower [$this lowerConstraint]
    if { $lower != "" } {
    $this generateExistenceCheck $selector $block $setName $parName
    set block [$this generateConstraintCheck $selector $block $setName $lower lower]
    # generate remove without ifAbsent:
    $block addExpression "$setName remove: $parName"
    } else {
    # generate remove with existence check
    set remExp [$block addExpression "$setName remove: $parName ifAbsent:"]
    $remExp addExpression [$this getErrorMessage ASSOC_OBJ_NOT_FOUND $selector]
    }

    if { $opposite != "" } {
    $opposite generateRemoveRefMessage $block $parName self $qualPar
    }

    # generate to remove key from dictionary if set gets empty
    if { $lower != "0" } {
    set emptyExpr [$block addExpression "$setName isEmpty ifTrue:"]
    $emptyExpr addExpression "$name removeKey: $qualPar"
    }
}


# Generates the additions to initialize, if it exists.
#
method STGManyQual::generateInitialize {this} {
    set initialize [[$this classImplementation] initialize]
    if { $initialize != "" } {
        $initialize addExpression "[$this variableName] := Dictionary new"
    }
    if { [$this lowerConstraint] != "" } {
    set comment "Warning: put association [$this roleName] in consistent state"
    $initialize addCommentLine $comment
    }
}


# Generates the additions to release in block.
#
method STGManyQual::generateReleaseCode {this block} {
    set name [$this variableName]
    set qualPar [$this qualifierParameter]
    set parName [$this parameterName]
    if { [$this opposite] != "" } {
    set dictBlock [$block addExpression "$name keysDo:"]
    $dictBlock addArgument $qualPar
    set setBlock [$dictBlock addExpression "($name at: $qualPar) do:"]
    $setBlock addArgument $parName
    [$this opposite] generateRemoveRefMessage $setBlock $parName self $qualPar
    }

    $block addExpression "$name := nil"
}


# Generates expressions in block to print information about the association.
#
method STGManyQual::generatePrintCode {this block} {
    set name [$this variableName]
    $block addExpression "aStream cr; nextPutAll: \'$name:\' displayString"
    set printKeys [$block addExpression "$name keysDo:"]
    $printKeys addArgument "key"
    $printKeys addExpression "aStream cr; tab"
    $printKeys addExpression "key printOn: aStream"
    set printAll [$printKeys addExpression "($name at: key) inject: 1 into:"]
    $printAll addArgument "count"
    $printAll addArgument "element"
    $printAll addExpression "aStream cr; tab: 2; nextPutAll: count printString"
    $printAll addExpression "element printVars: aStream withIndent: 3"
    $printAll addExpression "count + 1"
}


# Returns 0.
#
method STGManyQual::removeRequired {this} {
    return 0
}

# Do not delete this line -- regeneration end marker



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


# This is the generator for qualified associations with multiplicity one.

Class STGOneQual : {STGAssocGen} {
    constructor
    method destructor
    method generateData
    method generateGet
    method generateSet
    method generateRemove
    method generateSetRef
    method generateRemoveRef
    method generateRemoveRefMessage
    method generateSetRefMessage
    method generateRemoveMessage
    method generateSetCode
    method generateRemoveCode
    method generateInitialize
    method generateReleaseCode
    method generatePrintCode
    method getQualifierSetRequired
}

constructor STGOneQual {class this assocAttr} {
    set this [STGAssocGen::constructor $class $this $assocAttr]
    # Start constructor user section
    # End constructor user section
    return $this
}

method STGOneQual::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this STGAssocGen::destructor
}


# Generates instance variable to implement the association and sets variableName
# to <roleName>Dict.
#
method STGOneQual::generateData {this} {
    set name "[$this roleName]Dict"
    [$this classImplementation] addInstanceVariable $name
    $this variableName $name
}


# Generates the get methods:
# * One to get the associated object for a given qualifier.
# * One to execute a given block for all qualifiers.
#
method STGOneQual::generateGet {this} {
    set selector "get[cap [$this roleName]]At:"
    set name [$this variableName]
    set qualPar [$this qualifierParameter]
    set get [$this getAccessImplementation $selector]
    if { $get != "" } {
    $get addArgument $qualPar
    set expr [$get addExpression "^$name at: $qualPar ifAbsent:"]
    $expr addExpression [$this getErrorMessage QUAL_NOT_FOUND $selector]
    }

    # Method to get all qualifiers
    set selector "[$this qualifierName]SetDo:"
    set getAll [$this getAccessImplementation $selector]
    if { $getAll == "" } {
    if [$this getQualifierSetRequired] {
        set getAll [$this getPrivateImplementation $selector]
    } else {
        return
    }
    }
    $getAll addArgument aBlock
    $getAll addExpression "$name keysDo: aBlock"
}


# Generates the set method to set the association for a given qualifier.
#
method STGOneQual::generateSet {this} {
    set selector "set[cap [$this roleName]]:at:"
    set set [$this getModifyImplementation $selector]
    if { $set != "" } {
    $this generateSetCode $set [$this opposite]
    }
}


# Generates the remove method to remove the association for a given qualifier.
#
method STGOneQual::generateRemove {this} {
    set selector "remove[cap [$this roleName]]At:"
    set remove [$this getRemoveImplementation $selector]
    if { $remove != "" } {
    $this generateRemoveCode $remove [$this opposite]
    }
}


# Generates the implementation method to set the instance variable for the association.
#
method STGOneQual::generateSetRef {this} {
    set selector "set[cap [$this roleName]]Ref:at:"
    set setRef [$this getPrivateImplementation $selector]
    $this generateSetCode $setRef ""
}


# Generates the implementation method to remove from the association.
#
method STGOneQual::generateRemoveRef {this} {
    set selector "remove[cap [$this roleName]]RefAt:"
    set removeRef [$this getPrivateImplementation $selector]
    $this generateRemoveCode $removeRef ""
}


# Generates an expression in block that sends a removeRef message to
# object with parameters <parameter> and <qualifier>.
#
method STGOneQual::generateRemoveRefMessage {this block object parameter qualifier} {
    set removeRefName "remove[cap [$this roleName]]RefAt:"
    $block addExpression "$object $removeRefName $qualifier"
}


# Generates an expression in block that sends a SetRef message to
# object with parameters <qualifier> and <parameter>.
#
method STGOneQual::generateSetRefMessage {this block object parameter qualifier} {
    set setRefName "set[cap [$this roleName]]Ref:"
    $block addExpression "$object $setRefName $parameter at: $qualifier"
}


# Generates an expression in block that sends a remove message to object
# if there is an association with qualifier <qualifier>.
#
method STGOneQual::generateRemoveMessage {this block object qualifier} {
    set getAllName "[$this qualifierName]SetDo:"
    set block [$block addExpression "$object $getAllName"]

    # make name for block argument
    set blockArgument "some[cap [$this qualifierName]]"
    $block addArgument $blockArgument

    set block [$block addExpression "$blockArgument = $qualifier ifTrue:"]
    set removeName "remove[cap [$this roleName]]At:"
    $block addExpression "$object $removeName $qualifier"
}


# Generates the expressions in block for the set method.
#
method STGOneQual::generateSetCode {this block opposite} {
    set name [$this variableName]
    set parName [$block getNewUniqueArgumentName [$this parameterName]]
    set qualPar [$block getNewUniqueArgumentName [$this qualifierParameter]]

    if [[$this assocAttr] isMandatory] {
    $this generateNilCheck $block $parName
    }

    if { $opposite != "" } {
    # remove old links
    $opposite generateRemoveMessage $block $parName $qualPar

    # Temporary variable for old value in dictionary
    set oldName "old[cap [$this roleName]]"
    $block addTemporary $oldName
    $block addExpression "$oldName := $name at: $qualPar ifAbsent: \[nil\]"
    set subExpr [$block addExpression "$oldName isNil ifFalse:"]
    $opposite generateRemoveRefMessage $subExpr $oldName self $qualPar
    # set new one
    $opposite generateSetRefMessage $block $parName self $qualPar
    }

    $block addExpression "$name at: $qualPar put: $parName"
}


# Generates the expressions for the remove method in block.
#
method STGOneQual::generateRemoveCode {this block opposite} {
    set qualPar [$this qualifierParameter]
    set selector [$block selector]
    $block addArgument $qualPar

    set removeText "[$this variableName] removeKey: $qualPar ifAbsent:"
    if { $opposite != "" } {
    # generate temporary to hold old value
    set oldName "old[cap [$this roleName]]"
    $block addTemporary $oldName
    set removeText "$oldName := $removeText"
    $opposite generateRemoveRefMessage $block $oldName self $qualPar
    }

    set expr [$block insertExpression $removeText]
    $expr addExpression [$this getErrorMessage QUAL_NOT_FOUND $selector]
}


# Generates the additions to initialize, if it exists.
#
method STGOneQual::generateInitialize {this} {
    set initialize [[$this classImplementation] initialize]
    if { $initialize != "" } {
        $initialize addExpression "[$this variableName] := Dictionary new"
    }
}


# Generates the additions to release in block.
#
method STGOneQual::generateReleaseCode {this block} {
    set name [$this variableName]
    set qualPar [$this qualifierParameter]
    if { [$this opposite] != "" } {
    set dictBlock [$block addExpression "$name keysDo:"]
    $dictBlock addArgument $qualPar
    [$this opposite] generateRemoveRefMessage $dictBlock "($name at: $qualPar)" self $qualPar
    }

    $block addExpression "$name := nil"
}


# Generates methods to print information about the association in block.
#
method STGOneQual::generatePrintCode {this block} {
    set name [$this variableName]
    $block addExpression "aStream cr; nextPutAll: \'$name:\' displayString"
    set printKeys [$block addExpression "$name keysDo:"]
    $printKeys addArgument "key"
    $printKeys addExpression "aStream cr; tab"
    $printKeys addExpression "key printOn: aStream"
    set printOther [$printKeys addExpression "($name at: key) isNil ifFalse:"]
    $printOther addExpression "($name at: key)  printVars: aStream withIndent: 2"
}


# Returns whether the method to get all qualifiers is needed by other methods.
#
method STGOneQual::getQualifierSetRequired {this} {
    set oppAttr [[$this assocAttr] opposite]
    if { $oppAttr == "" } {
    return 0
    }

    if { [$oppAttr isMandatory] || ([$oppAttr writeAccess] != "None") } {
    return 1
    }

    return 0
}

# Do not delete this line -- regeneration end marker



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


# This class is the data attribute generator.

Class STGDataAttr : {STGAttribute} {
    constructor
    method destructor
    method generate
    method generateDefinition
    method generateDescription
    method generateInitialValue
    method generateGetSet
    method generatePrint
    method argumentName
    method checkLocal
    method checkInitialValue

    # Used to store name, set in generateDefinition.
    # (This name may be different from STName due to
    # capitalization of first characters).
    #
    attribute name
}

constructor STGDataAttr {class this name} {
    set this [STGAttribute::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Generate for data attributes:
# generate definition and description in
# classImplementation, generate an initial value in
# the initialize method if needed,
# generate Get and Set methods and
# generate print methods if generatePrint in globals
# is set.
#
method STGDataAttr::generate {this} {
    # Call the methods
    $this generateDefinition
    $this generateDescription
    $this generateInitialValue

    # Only generate get and set for class and instance vars
    if { [$this getPropertyValue isPoolDict] != "1" } {
        $this generateGetSet
    }

    if [$globals generatePrint] {
        $this generatePrint
    }
}


# Generates the name of the attribute in the class implementation object.
# Sets the name attribute; capitalizes class variables and pool dictionaries.
#
method STGDataAttr::generateDefinition {this} {
    set classImpl [[$this ooplClass] classImplementation]

    set name [$this getSTName]
    if { [$this getPropertyValue isPoolDict] == "1" } {
        set name [cap $name]
        $classImpl addPoolDictionary $name
    } elseif [$this isClassFeature] {
        set name [cap $name]
        $classImpl addClassVariable $name
    } else {
        $classImpl addInstanceVariable $name
    }
    $this name $name
}


# Generates description of the attribute in the class implementation object.
#
method STGDataAttr::generateDescription {this} {
    if [regsub -all \' [$this getPropertyValue freeText] "" comment] {
        # '-s removed
    }

    set commentLine [$this name]

    # Add type if it exists
    set type [$this ooplType]
    if { $type != "" } {
        if { [$type getName] != "" } {
            set commentLine "$commentLine ([$this asSTName [$type getName]])"
        }
    }

    # Add free text if is there
    if { $comment != "" } {
        set commentLine "$commentLine: $comment"
        [[$this ooplClass] classImplementation] addCommentLine $commentLine
    }
}


# Generates initial value in initialize for instance variable
# or in an expression for class variable.
#
method STGDataAttr::generateInitialValue {this} {
    set initialValue [$this getPropertyValue initial_value]

    if { $initialValue != "" } {
        set classImpl [[$this ooplClass] classImplementation]

        if [$this isClassFeature] {
            # class variable: make expression to set it.
            set expression "[[$this ooplClass] getSTName] [$this name]"
            set expression "$expression: $initialValue"

            # If there is no write access we can't do it
             if { [$this writeAccess] == "None" } {
                # warning also in checkInitialValue
                # m4_warning $WST_NOGENINITVAL [$this name]
            } else {
                $classImpl addExpression $expression
            }
        } else {
            # generate expression in initialize if it exists
            set initialize [$classImpl initialize]
            if { $initialize != "" } {
                # Make it conditional if there is an initializer
                # in that case it may already have a value
                set block $initialize

                if { [$this hasInitializer] == 1} {
                    set block [$initialize addExpression "[$this name] isNil ifTrue:"]
                }
                $block addExpression "[$this name] := $initialValue"
            }
        }
    }
}


# Generates get and set methods for the attribute if allowed by read and write access.
#
method STGDataAttr::generateGetSet {this} {
    set name [$this name]
    set argName [$this getArgumentName]
    set classImpl [[$this ooplClass] classImplementation]
    set isClassVar [$this isClassFeature]
    set readCategory [$this getReadCategory "accessing"]
    if { $readCategory != "" } {
        # generate Get
        if $isClassVar {
            set get [$classImpl getClassMethodImplementation "$name" $readCategory]
        } else {
            set get [$classImpl getInstanceMethodImplementation "$name" $readCategory]
        }
        $get addExpression "^$name"
    }
    set writeCategory [$this getWriteCategory "modifying"]
    if { $writeCategory != ""} {
        # generate Set
        if $isClassVar {
            set set [$classImpl getClassMethodImplementation "$name:" $writeCategory]
        } else {
            set set [$classImpl getInstanceMethodImplementation "$name:" $writeCategory]
        }
        $set addArgument $argName
        $set addExpression "$name := $argName"
    }
}


# Generates an expression in the printVars and printOn methods. to print it.
#
method STGDataAttr::generatePrint {this} {
    set printVars [[[$this ooplClass] classImplementation] printVars]
    set printOn [[[$this ooplClass] classImplementation] printOn]
    if { $printVars != "" } {
        $printVars addExpression \
            "aStream cr; tab: anInteger; nextPutAll: \'[$this name]: \' displayString"
        $printVars addExpression "[$this name] printOn: aStream"
    }
    if { $printOn != "" } {
        $printOn addExpression \
            "aStream cr; nextPutAll: \'[$this name]: \' displayString"
        $printOn addExpression "[$this name] printOn: aStream"
    }
}


# Return name for this attribute when it used as argument:
# base it on type if it exists and the name otherwise.
#
method STGDataAttr::argumentName {this} {
    set type [$this ooplType]
    if { $type != "" } {
        if { [$type getType3GL] != "" } {
            return [$this asSTName [$this asArgument [$type getType3GL]]]
        } elseif { [$type getName] != "" } {
            return [$this asSTName [$this asArgument [$type getName]]]
        }
    }
    # It is safe to use getSTName because first char is always capitalized
    return [$this asArgument [$this getSTName]]
}

method STGDataAttr::checkLocal {this} {
    # message also present in STGDataAttr::generateInitialValue
    set errornr 0
    set warningnr 0

    incr errornr [$this checkSTName]
    incr warningnr [$this checkInitialValue]
    incr warningnr [$this checkFreeTextQuote]

    return $errornr
}

method STGDataAttr::checkInitialValue {this} {
    # message also present in STGDataAttr::generateInitialValue
    set warningnr 0

    set initialValue [$this getPropertyValue initial_value]
    # check presence of initial value
    if { $initialValue != "" } {
        if [$this isClassFeature] {
            # If there is no write access we can't do it
            if { [$this writeAccess] == "None" } {
                # see generateDefinition() for capitalizing the name
                set name [cap [$this getSTName]]
                m4_warning $WST_NOGENINITVAL $name
                set warningnr 1
            }
        }
    }
    return $warningnr
}

# Do not delete this line -- regeneration end marker

if [isCommand CMDataAttr] {
    Class  STGDataAttrD : {STGDataAttr CMDataAttr} {
    }
} else {
    Class STGDataAttrD : {STGDataAttr OPDataAttr} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPDataAttr) STGDataAttrD

selfPromoter OPDataAttr {this} {
    STGDataAttrD promote $this
}


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


# General association generator: contains methods that are
# the same for all types of association.

Class STGGenAssocAttr : {STGAttribute} {
    constructor
    method destructor
    method generateAll
    method setNames
    method generate
    method generateDescription
    method argumentName
    method oppositeMandatoryOne
    method checkLocal
    method checkFreeText
    method generator
    attribute _generator
}

constructor STGGenAssocAttr {class this name} {
    set this [STGAttribute::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

method STGGenAssocAttr::destructor {this} {
    set ref [$this _generator]
    if {$ref != ""} {
        $ref _assocAttr ""
    }
    # Start destructor user section
    $this _generator ""
    # End destructor user section
    $this STGAttribute::destructor
}


# Calls all methods in the generator.
#
method STGGenAssocAttr::generateAll {this} {
    set generator [$this generator]
    $generator generateData
    $generator generateSet
    $generator generateGet
    $generator generateRemove
    if { [$this opposite] != "" } {
        $generator generateSetRef
        $generator generateRemoveRef
    }
    $generator generateInitialize
    $generator generateRelease
}


# Sets the roleName to the ST name for this attribute and parameterName to the argument name
# of this attribute in the association generator object.
#
method STGGenAssocAttr::setNames {this} {
    [$this generator] roleName [$this getSTName]
    [$this generator] parameterName [$this getArgumentName]
}


# Generates for association attribute:
# sets up generator, sets up generator for opposite,
# generates a description,
# calls generateAll (defined in subclasses), and
# generates print methods for the attribute if
# generatePrint is set in STGGlobal.
#
method STGGenAssocAttr::generate {this} {
    # get generator if it didn't exist yet.
    if { [$this generator] == "" } {
        $this setGenerator
        $this setNames
    }

    # Now set class implementation object
    # assumption: generate is called just once
    # if not this code is a bit inefficient
    [$this generator] classImplementation [[$this ooplClass] classImplementation]

    # get a generator for opposite if it exists
    # needed to do generate*call
    set opposite [$this opposite]
    if { $opposite != "" } {
        if { [$opposite generator] == "" } {
            $opposite setGenerator
            $opposite setNames
            # make generators point to each other
            [$this generator] opposite [$opposite generator]
            [$opposite generator] opposite [$this generator]
        }
    }

    # Must first call generateAll because generateDescription needs
    # instance variable name
    $this generateAll
    $this generateDescription

    if [$globals generatePrint] {
        set printOn [[[$this ooplClass] classImplementation] printOn]
        if { $printOn != "" } {
            [$this generator] generatePrintCode $printOn
        }
    }
    [$this generator] classImplementation ""
}


# Generate a description of the association attribute in the class comment,
# based on free text. If there is no free text generate nothing.
#
method STGGenAssocAttr::generateDescription {this} {
    set commentLine "[[$this generator] variableName]"

    if [regsub -all \' [$this getPropertyValue freeText] "" comment] {
        # removed '-s
    }

    # Add free text if is there
    if { $comment != "" } {
        set commentLine "$commentLine: $comment"
        [[$this ooplClass] classImplementation] addCommentLine $commentLine
    }
}


# Returns the name of this attribute when used as argument, based on the role name.
#
method STGGenAssocAttr::argumentName {this} {
    return [$this asArgument [$this getSTName]]
}


# Returns 1 if the opposite of this association attribute is mandatory, one and non-qualified.
#
method STGGenAssocAttr::oppositeMandatoryOne {this} {
    set opposite [$this opposite]
    if { $opposite == "" } {
        return 0
    }
    if  {[$opposite isMandatory] && \
             (![$opposite isQualified]) && \
             ([$opposite getMultiplicity] == "one") } {
        return 1
    }
    return 0
}

method STGGenAssocAttr::checkLocal {this} {
    set errornr 0
    set warning 0
    incr errornr [$this checkSTName]
    # get generator if it didn't exist yet.
    if { [$this generator] == "" } {
        $this setGenerator
        $this setNames
    }
    # now check assoc
    incr errornr [[$this generator] check]

    # and its freeText
    incr warning [$this checkFreeText]

    return $errornr
}

method STGGenAssocAttr::checkFreeText {this} {
    set warningnr 0
    if [regexp \' [$this getPropertyValue freeText] comment] {
        m4_warning $WST_REMOVEQUOTEDESCR [$this getName]
        incr warningnr 1
    }
    return $warningnr
}

# Do not delete this line -- regeneration end marker

method STGGenAssocAttr::generator {this args} {
    if {$args == ""} {
        return [$this _generator]
    }
    set ref [$this _generator]
    if {$ref != ""} {
        $ref _assocAttr ""
    }
    set obj [lindex $args 0]
    if {$obj != ""} {
        $obj _assocAttr $this
    }
    $this _generator $obj
}



#---------------------------------------------------------------------------
#      File:           @(#)stgclassen.tcl    /main/titanic/3


# Generator for enum classes.

Class STGClassEnum : {STGClass} {
    constructor
    method destructor
    method generate
    method checkLocal
}

constructor STGClassEnum {class this name} {
    set this [STGClass::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Prints a message that enums are not supported in Smalltalk.
#
method STGClassEnum::generate {this classImpl} {
    # message already generated by check.
    # enums not supported
}

method STGClassEnum::checkLocal {this} {
    set errornr 0
    incr errornr [$this checkSTName]
    m4_error $EST_ENUMSNOTSUP [$this getSTName]
    incr errornr 1
    return $errornr
}

# Do not delete this line -- regeneration end marker

if [isCommand CMClassEnum] {
    Class  STGClassEnumD : {STGClassEnum CMClassEnum} {
    }
} else {
    Class STGClassEnumD : {STGClassEnum OPClassEnum} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPClassEnum) STGClassEnumD

selfPromoter OPClassEnum {this} {
    STGClassEnumD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stgclassge.tcl    /main/titanic/3


Class STGClassGenericTypeDef : {STGClass} {
    constructor
    method destructor
}

constructor STGClassGenericTypeDef {class this name} {
    set this [STGClass::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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

# Do not delete this line -- regeneration end marker

if [isCommand CMClassGenericTypeDef] {
    Class  STGClassGenericTypeDefD : {STGClassGenericTypeDef CMClassGenericTypeDef} {
    }
} else {
    Class STGClassGenericTypeDefD : {STGClassGenericTypeDef OPClassGenericTypeDef} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPClassGenericTypeDef) STGClassGenericTypeDefD

selfPromoter OPClassGenericTypeDef {this} {
    STGClassGenericTypeDefD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stgclasstd.tcl    /main/titanic/3


Class STGClassTDef : {STGClass} {
    constructor
    method destructor
}

constructor STGClassTDef {class this name} {
    set this [STGClass::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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

# Do not delete this line -- regeneration end marker

if [isCommand CMClassTDef] {
    Class  STGClassTDefD : {STGClassTDef CMClassTDef} {
    }
} else {
    Class STGClassTDefD : {STGClassTDef OPClassTDef} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPClassTDef) STGClassTDefD

selfPromoter OPClassTDef {this} {
    STGClassTDefD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stglinkcla.tcl    /main/titanic/3


# This class is the top level class generator
# for link classes.

Class STGLinkClass : {STGClass} {
    constructor
    method destructor
    method generate
    method printGeneratingMessage
    method printCheckingMessage
    method checkLocal
    method checkLinkClass
}

constructor STGLinkClass {class this name} {
    set this [STGClass::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Check that this link class is named and generate
# as if it were a normal class.
#
method STGLinkClass::generate {this classImpl} {
    # skip if link class has no name (already checked, but...)
    if { [$this getSTName] != "" } {
        $this STGClass::generate $classImpl
    }
}


# Print a message stating that generation for this link class is in progress.
#
method STGLinkClass::printGeneratingMessage {this} {
    m4_message $MST_GENERATELINK [$this getName]
}

method STGLinkClass::printCheckingMessage {this} {
}

method STGLinkClass::checkLocal {this} {
    set errornr 0
    if { [$this checkLinkClass] == 0 } {
        incr errornr [$this STGClass::checkLocal]
    }
    return $errornr
}

method STGLinkClass::checkLinkClass {this} {
    set warningnr 0
    if { [$this getSTName] == "" } {
        m4_warning $WST_LINKCLSSSKIPPED
        incr warningnr 1
    }
    return $warningnr
}

# Do not delete this line -- regeneration end marker

if [isCommand CMLinkClass] {
    Class  STGLinkClassD : {STGLinkClass CMLinkClass} {
    }
} else {
    Class STGLinkClassD : {STGLinkClass OPLinkClass} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPLinkClass) STGLinkClassD

selfPromoter OPLinkClass {this} {
    STGLinkClassD promote $this
}


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


# Generator for roles which are the opposite of qualified associations
# in which this opposite has multiplicity one.

Class STGOneOppQual : {STGAssocOne} {
    constructor
    method destructor
    method generateData
    method generateSet
    method generateRemove
    method generateInitialize
    method generateReleaseCode
    method generateSetRefMessage
    method generateRemoveRefMessage
    method generateRemoveMessage
    method generateQualifierSet
    method generateQualifierGet
    method generateQualifierSetRef
    method generateQualifierPrint
    method checkLocal
    method checkQualifier

    # Used to store the name of the qualifier on the other side.
    # It may be different from the qualifier on this side if
    # the qualifierName property has been set.
    #
    attribute oppositeQualifierName
}

constructor STGOneOppQual {class this assocAttr} {
    set this [STGAssocOne::constructor $class $this $assocAttr]
    # Start constructor user section
    # End constructor user section
    return $this
}

method STGOneOppQual::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this STGAssocOne::destructor
}


# Generates instance variable to implement this
# association and sets variableName to <roleName>.
# Also generates the instance variable for the qualifier on this side
# if necessary and the methods for this qualifier.
#
method STGOneOppQual::generateData {this} {
    $this STGAssocOne::generateData

    set qualifier [$this qualifierName]
    $this oppositeQualifierName $qualifier
    # retrieve user specified qualifier
    set userQualifier [[$this assocAttr] getPropertyValue qualifierName]
    if { $userQualifier != "" } {
        set qualifier $userQualifier
    }

    # check if it exists
    set exists 0
    set className [[[$this assocAttr] ooplClass] getSTName]
    foreach attribute [[[$this assocAttr] ooplClass] dataAttrSet] {
        if { [$attribute getSTName] == $qualifier } {
            if { [$attribute isClassFeature] || \
                     ([$attribute getPropertyValue isPoolDict] == "1") } {
                # m4_warning $WST_QUALNOINSTC $qualifier $className
            } else {
                set exists 1
            }
        }
    }
    if { (!$exists) && ($userQualifier != "") } {
        # m4_warning $WST_QUALNOTDEF $qualifier $className
    }

    $this qualifierName $qualifier
    if { !$exists } {
        [$this classImplementation] addInstanceVariable $qualifier
        [$this classImplementation] addCommentLine \
            "$qualifier: qualifier for [[$this assocAttr] getSTName]"
        $this generateQualifierPrint
    }
    if { ($userQualifier != "") || $exists } {
        $this generateQualifierSet
        $this generateQualifierGet
    }
    $this generateQualifierSetRef
}


# Generates the set method to set the association.
#
method STGOneOppQual::generateSet {this} {
    set name [$this variableName]
    set qualName [$this qualifierName]
    set selector "set[cap [$this roleName]]:at:"
    set set [$this getModifyImplementation $selector]
    if { $set == "" } {
        return
    }

    set parName [$set getNewUniqueArgumentName [$this parameterName]]
    set qualPar [$set getNewUniqueArgumentName [$this qualifierParameter]]

    # if it is mandatory generate a nil check and an inequality check
    if [[$this assocAttr] isMandatory] {
        $this generateNilCheck $set $parName
    }
    if { [$this opposite] != "" } {
        if [[$this assocAttr] isMandatory] {
            set compare "($name ~~ $parName | ($qualName ~= $qualPar))"
            set set [$set addExpression "$compare ifTrue:"]
        }
        # remove old links
        [$this opposite] generateRemoveMessage $set $parName $qualPar
        set removeBlock $set
        if { ![[$this assocAttr] isMandatory]} {
            set removeBlock [$set addExpression "$name isNil ifFalse:"]
        }
        [$this opposite] generateRemoveRefMessage $removeBlock $name self $qualName
        # set new link
        [$this opposite] generateSetRefMessage $set $parName self $qualPar
    }
    $set addExpression "$name := $parName"
    $set addExpression "$qualName := $qualPar"
}


# Generates the set method to remove the association.
#
method STGOneOppQual::generateRemove {this} {
    set selector "remove[cap [$this roleName]]"
    set remove [$this getRemoveImplementation $selector]
    if  { $remove != "" } {
        $this generateRemoveCode $remove [$this opposite] [$this qualifierName]
    }
}


# Generates the additions to initialize, if it exists.
#
method STGOneOppQual::generateInitialize {this} {
    set initialize [[$this classImplementation] initialize]
    if { $initialize == "" } {
        return
    }
    if { [[$this assocAttr] hasInitializer] == 1 } {
        set qualPar [$initialize getUniqueArgumentName \
                         [$this oppositeQualifierName] [$this qualifierParameter] ]
        $this generateInitializeCode $initialize $qualPar
        $initialize addExpression "[$this qualifierName] := $qualPar"
    } else {
        $this generateInitializeCode $initialize
        $initialize addExpression "[$this qualifierName] := nil"
    }

}


# Generates the additions to release in block.
#
method STGOneOppQual::generateReleaseCode {this block} {
    $this generateRemoveCode $block [$this opposite] [$this qualifierName]
}


# Generates expressions in block to send setRef
# messages to object for <parameter> and for <qualifier>.
#
method STGOneOppQual::generateSetRefMessage {this block object parameter qualifier} {
    $this STGAssocOne::generateSetRefMessage $block $object $parameter
    set qualName [[$this assocAttr] getPropertyValue qualifierName]
    if { $qualName == "" } {
        set qualName [$this qualifierName]
    }
    set setQualRefName "set[cap $qualName]Ref:"
    $block addExpression "$object $setQualRefName $qualifier"
}


# Generates expressions in block to send a SetRef
# message to object with parameter nil.
#
method STGOneOppQual::generateRemoveRefMessage {this block object parameter qualifier} {
    $this STGAssocOne::generateSetRefMessage $block $object nil
}


# Generates an expression in block to send a remove
# message to object.
#
method STGOneOppQual::generateRemoveMessage {this block object qualifier} {
    $this STGAssocOne::generateRemoveMessage $block $object
}


# Generates the special method to set a qualifier and
# update the association if necessary.
#
method STGOneOppQual::generateQualifierSet {this} {
    set selector "[$this qualifierName]:"
    set setQual [$this getModifyImplementation $selector]
    if { $setQual == "" } {
        return
    }
    set name [$this variableName]
    set qualName [$this qualifierName]
    set qualPar [$this qualifierParameter]
    $setQual addArgument $qualPar

    # if it's empty generate the set
    if [$setQual isEmpty] {
        $setQual addExpression "$qualName := $qualPar"
    }

    # generate check if update is needed
    set checkExpr "($name notNil & ($qualName ~= $qualPar)) ifTrue:"
    set block [$setQual insertExpression $checkExpr]
    set opposite [$this opposite]

    # remove and set on other side
    $opposite generateRemoveRefMessage $block $name self $qualName
    $opposite generateRemoveMessage $block $name $qualPar
    $opposite generateSetRefMessage $block $name self $qualPar
}


# Generates the method to get the qualifier.
#
method STGOneOppQual::generateQualifierGet {this} {
    set selector "[$this qualifierName]"
    set getQual [$this getAccessImplementation $selector]
    if { $getQual == "" } {
        set getQual [$this getPrivateImplementation $selector]
    }
    # if it's empty generate the get
    if [$getQual isEmpty] {
        $getQual addExpression "\^[$this qualifierName]"
    }
}


# Generates the implementation method to set the
# qualifier instance variable.
#
method STGOneOppQual::generateQualifierSetRef {this} {
    set selector "set[cap [$this qualifierName]]Ref:"
    set setQualRef [$this getPrivateImplementation $selector]
    $setQualRef addArgument [$this qualifierParameter]
    set assign "[$this qualifierName] := [$this qualifierParameter]"
    $setQualRef addExpression $assign
}


# Generates in the printVars method to print the qualifier instance variable.
#
method STGOneOppQual::generateQualifierPrint {this} {
    set printVars [[$this classImplementation] printVars]
    set qualName [$this qualifierName]
    if { $printVars != "" } {
        $printVars addExpression \
            "aStream cr; tab: anInteger; nextPutAll: \'$qualName: \' displayString"
        $printVars addExpression "$qualName printOn: aStream"
    }
}

method STGOneOppQual::checkLocal {this} {
    set errornr 0
    set warningnr 0
    incr warningnr [$this checkQualifier]
    return $errornr
}

method STGOneOppQual::checkQualifier {this} {
    set warningnr 0

    set qualifier [$this qualifierName]
    $this oppositeQualifierName $qualifier
    # retrieve user specified qualifier
    set userQualifier [[$this assocAttr] getPropertyValue qualifierName]
    if { $userQualifier != "" } {
        set qualifier $userQualifier
    }
    # check if it exists
    set exists 0
    set className [[[$this assocAttr] ooplClass] getSTName]
    foreach attribute [[[$this assocAttr] ooplClass] dataAttrSet] {
        if { [$attribute getSTName] == $qualifier } {
            if { [$attribute isClassFeature] || \
                 ([$attribute getPropertyValue isPoolDict] == "1") } {
                m4_warning $WST_QUALNOINSTC $qualifier $className
                incr warningnr 1
            } else {
                set exists 1
            }
        }
    }
    if { (!$exists) && ($userQualifier != "") } {
        m4_warning $WST_QUALNOTDEF $qualifier $className
        incr warningnr 1
    }
    return $warningnr
}

# Do not delete this line -- regeneration end marker



#---------------------------------------------------------------------------
#      File:           @(#)stgassocat.tcl    /main/titanic/3


# Generator class for normal association attributes.

Class STGAssocAttr : {STGGenAssocAttr} {
    constructor
    method destructor
    method setGenerator
}

constructor STGAssocAttr {class this name} {
    set this [STGGenAssocAttr::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Set generator to assocOne or assocMany
# exceptions:
# * opposite of a qualified attribute with multiplicity one,
# where a oneoppqual generator is used.
# * opposite of a qualified attribute with multiplicity many, where a qualMany
# is used.
# In these two special cases set up the
# qualifierName and qualifierParameter
# attributes in the generator.
#
method STGAssocAttr::setGenerator {this} {
    set opposite [$this opposite]
    if { $opposite != "" } {
    if [$opposite isQualified] {
        if { [$this getMultiplicity] == "one" } {
        $this generator [STGOneOppQual new $this]
        } else {
        $this generator [STGManyQual new $this]
        }
        set qualifier [$opposite qualifier]
        [$this generator] qualifierName [$qualifier getSTName]
        [$this generator] qualifierParameter [$qualifier getArgumentName]
        return
    }
    }

    if { [$this getMultiplicity] == "one" } {
    $this generator [STGAssocOne new $this]
    } else {
    $this generator [STGAssocMany new $this]
    }
}

# Do not delete this line -- regeneration end marker

if [isCommand CMAssocAttr] {
    Class  STGAssocAttrD : {STGAssocAttr CMAssocAttr} {
    }
} else {
    Class STGAssocAttrD : {STGAssocAttr OPAssocAttr} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPAssocAttr) STGAssocAttrD

selfPromoter OPAssocAttr {this} {
    STGAssocAttrD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stglinkatt.tcl    /main/titanic/3


# Generates for link attributes.

Class STGLinkAttr : {STGGenAssocAttr} {
    constructor
    method destructor
    method setGenerator
    method setNames
    method argumentName
}

constructor STGLinkAttr {class this name} {
    set this [STGGenAssocAttr::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Initializes generator for link attribute:
# * multiplicity one: uses assocOne
# * multiplicity many: uses assocMany
#
method STGLinkAttr::setGenerator {this} {
    if { [$this getMultiplicity] == "one" } {
    $this generator [STGAssocOne new $this]
    } else {
    $this generator [STGAssocMany new $this]
    }
}


# Set the roleName in the generator to <linkclass_name>Of<role_name> and parameterName accordingly.
#
method STGLinkAttr::setNames {this} {
    set linkClassName [$this asSTName [[$this ooplType] getName]]
    set name "${linkClassName}Of[cap [$this getSTName]]"
    [$this generator] roleName $name
    [$this generator] parameterName [$this asArgument $name]
}


# Return name for this link when used as parameter.
#
method STGLinkAttr::argumentName {this} {
    set linkClassName [$this asSTName [[$this ooplType] getName]]
    set name "${linkClassName}Of[cap [$this getSTName]]"
    return [$this asArgument $name]
}

# Do not delete this line -- regeneration end marker

if [isCommand CMLinkAttr] {
    Class  STGLinkAttrD : {STGLinkAttr CMLinkAttr} {
    }
} else {
    Class STGLinkAttrD : {STGLinkAttr OPLinkAttr} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPLinkAttr) STGLinkAttrD

selfPromoter OPLinkAttr {this} {
    STGLinkAttrD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stgqualass.tcl    /main/titanic/3


# Generator for qualified associations.

Class STGQualAssocAttr : {STGGenAssocAttr} {
    constructor
    method destructor
    method setGenerator
}

constructor STGQualAssocAttr {class this name} {
    set this [STGGenAssocAttr::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Sets generator: oneQualified or manyQualified.
#
method STGQualAssocAttr::setGenerator {this} {
    if { [$this getMultiplicity] == "one" } {
        $this generator [STGOneQual new $this]
    } else {
        $this generator [STGManyQual new $this]
    }
    [$this generator] qualifierName [[$this qualifier] getSTName]
    [$this generator] qualifierParameter [[$this qualifier] getArgumentName]
}

# Do not delete this line -- regeneration end marker

if [isCommand CMQualAssocAttr] {
    Class  STGQualAssocAttrD : {STGQualAssocAttr CMQualAssocAttr} {
    }
} else {
    Class STGQualAssocAttrD : {STGQualAssocAttr OPQualAssocAttr} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPQualAssocAttr) STGQualAssocAttrD

selfPromoter OPQualAssocAttr {this} {
    STGQualAssocAttrD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stgquallin.tcl    /main/titanic/3


# Generator class for qualified link attributes.

Class STGQualLinkAttr : {STGGenAssocAttr} {
    constructor
    method destructor
    method setGenerator
    method setNames
    method argumentName
}

constructor STGQualLinkAttr {class this name} {
    set this [STGGenAssocAttr::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Set the generator: use the generators for normal qualified associations.
#
method STGQualLinkAttr::setGenerator {this} {
    if { [$this getMultiplicity] == "one" } {
    $this generator [STGOneQual new $this]
    } else {
    $this generator [STGManyQual new $this]
    }
    [$this generator] qualifierName [[$this qualifier] getSTName]
    [$this generator] qualifierParameter [[$this qualifier] getArgumentName]
}


# Set role name to <link_name>Of<role_name> style and parameterName accordingly.
#
method STGQualLinkAttr::setNames {this} {
    set linkClassName [$this asSTName [[$this ooplType] getName]]
    set name "${linkClassName}Of[cap [$this getSTName]]"
    [$this generator] roleName $name
    [$this generator] parameterName [$this asArgument $name]
}


# Return name for this attribute when used as parameter.
#
method STGQualLinkAttr::argumentName {this} {
    set linkClassName [$this asSTName [[$this ooplType] getName]]
    set name "${linkClassName}Of[cap [$this getSTName]]"
    return [$this asArgument $name]
}

# Do not delete this line -- regeneration end marker

if [isCommand CMQualLinkAttr] {
    Class  STGQualLinkAttrD : {STGQualLinkAttr CMQualLinkAttr} {
    }
} else {
    Class STGQualLinkAttrD : {STGQualLinkAttr OPQualLinkAttr} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPQualLinkAttr) STGQualLinkAttrD

selfPromoter OPQualLinkAttr {this} {
    STGQualLinkAttrD promote $this
}


#---------------------------------------------------------------------------
#      File:           @(#)stgreverse.tcl    /main/titanic/3


# Generator class for reverse link attributes.

Class STGReverseLinkAttr : {STGGenAssocAttr} {
    constructor
    method destructor
    method setGenerator
}

constructor STGReverseLinkAttr {class this name} {
    set this [STGGenAssocAttr::constructor $class $this $name]
    # Start constructor user section
    # End constructor user section
    return $this
}

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


# Sets the generator: an assocOne for a reverse link in a normal link association or a
# oneOppQual for the opposite of a qualified  association.
#
method STGReverseLinkAttr::setGenerator {this} {
    set opposite [$this opposite]
    set qualifier ""
    if { $opposite != "" } {
    if [$opposite isQualified] {
        set qualifier [$opposite qualifier]
    }
    }
    if { $qualifier != "" } {
    $this generator [STGOneOppQual new $this]
    [$this generator] qualifierName [$qualifier getSTName]
    [$this generator] qualifierParameter [$qualifier getArgumentName]
    } else {
    $this generator [STGAssocOne new $this]
    }
}

# Do not delete this line -- regeneration end marker

if [isCommand CMReverseLinkAttr] {
    Class  STGReverseLinkAttrD : {STGReverseLinkAttr CMReverseLinkAttr} {
    }
} else {
    Class STGReverseLinkAttrD : {STGReverseLinkAttr OPReverseLinkAttr} {
    }
}

global mostDerivedOOPL ; set mostDerivedOOPL(OPReverseLinkAttr) STGReverseLinkAttrD

selfPromoter OPReverseLinkAttr {this} {
    STGReverseLinkAttrD promote $this
}