PC World 1997 November/PCWorld_1997-11_cd.bin/software/programy/komix/DATA.Z/stgclasses.tcl

Text File | 1997-04-18 | 105.3 KB | 3,753 lines

#--------------------------------------------------------------------------
#
#      (c)     Cayenne Software Inc.    1997
#
#      File:           %W%
#      Author:         <generated>
#
#--------------------------------------------------------------------------

#      File:           @(#)stgobject.tcl    /main/1


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

Class STGObject : {Object} {
    constructor
    method destructor
    method asSTName
    method asArgument
    method getSTName
    method getArgumentName

    # 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 ] {
    puts "WARNING: Removed illegal characters from $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] } ] {
    puts "FAILURE HELP ALARM: getSTName called for object without name"
    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] } ] {
    puts "FAILURE ALARM: getArgumentName called for object without argument name"
    return "error"
    }

    return [$this argName]
}

# Do not delete this line -- regeneration end marker


#      File:           @(#)stgassocge.tcl    /main/1


# 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 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 == "" } {
    puts "ERROR: Unknown error $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"
}

# 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/1


# Generator class for association initializers.

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

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
}

# Do not delete this line -- regeneration end marker

selfPromoter OPAssocInitializer {this} {
    STGAssocInitializer promote $this
}

#      File:           @(#)stgattribi.tcl    /main/1


# Attribute initializer generator.

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

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"
}

# Do not delete this line -- regeneration end marker

selfPromoter OPAttribInitializer {this} {
    STGAttribInitializer promote $this
}

#      File:           @(#)stgattribu.tcl    /main/1


# 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} {
    set readAccess [$this readAccess]
    if { $readAccess == "None" } {
    return ""
    }
    if { $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 ""
    }
    if { $writeAccess == "Private" } {
    return "private"
    } else {
    return $name
    }
}


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


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

# Do not delete this line -- regeneration end marker


#      File:           @(#)stgclass.tcl    /main/1


# 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 getSTName

    # 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 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]

    # check if one of them or both  existed already
    if { [$classImpl methodExists "printOn:"] || [$classImpl methodExists "printVars:withIndent:"] } {
    puts "WARNING: Not generating printOn and printVars: already defined by user"
    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] {
    puts "WARNING: Removed \' from comment for [$this getSTName]"
    }
    [$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 } {
    puts "ERROR: [$this getSTName]: Multiple inheritance not supported; discarding additional superclasses"
    }

    if { [llength $gnodeSet] == 0 } {
    puts "WARNING: Class [$this getSTName] has no superclasses, defaulting to Object"
    $this super ""
    $classImpl super "Object"
    } else {
    $this super [[lindex $gnodeSet 0] superClass]
    $classImpl super [[$this super] getSTName]
    }

    $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 inheritanceType [$this getPropertyValue inheritanceType]

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

    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") } {
        puts "WARNING: Class [$this getSTName] with $inheritanceType inheritance and superclass [[$this super] getSTName] with $superInheritanceType inheritance may not be accepted by Smalltalk"
    }
    }

    if { $inheritanceType != "variableByte" } {
    return
    }

    # 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 != "" } {
    # 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 } {
        set checkClass ""
    } else {
        set checkClass [[lindex $gnodeSet 0] superClass]
    }
    }

    if $hasInstanceVariables {
    puts "WARNING: class [$this getSTName] with variableByte inheritance and instance variables may not be accepted by Smalltalk"
    }
}


# Print a message stating that generation for this class is in progress.
#
method STGClass::printGeneratingMessage {this} {
    puts "Generating for class [$this getSTName]"
}


# 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]
}

# Do not delete this line -- regeneration end marker

Class STGClassD : {STGClass OPClass} {
}

selfPromoter OPClass {this} {
    STGClassD promote $this
}

#      File:           @(#)stgconstru.tcl    /main/1


# Constructor generator class.

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

    # 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} {
    if [regsub -all {"} [$this getPropertyValue freeText] "" comment] {
    puts "WARNING: Removed \" from constructor comment"
    }
    [$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] {
    puts "WARNING: Default constructor overrides user defined constructor"
    $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] {
    puts "WARNING: user defined constructor overridden by automatically generated new"
    $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
}

# Do not delete this line -- regeneration end marker

selfPromoter OPConstructor {this} {
    STGConstructor promote $this
}

#      File:           @(#)stgctorpar.tcl    /main/1


# Generator class for constructor parameters.

Class STGCtorParameter : {STGObject OPCtorParameter} {
    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

selfPromoter OPCtorParameter {this} {
    STGCtorParameter promote $this
}

#      File:           @(#)stgoperati.tcl    /main/1


# This class is the generator for user defined operations.

Class STGOperation : {STGObject OPOperation} {
    constructor
    method destructor
    method generate
    method getMethodImplementation
    method generateAbstractMethod
    method generateDescription
    method doTclCall
    method getCategory
    method getSelector
    method getOperatorSelector
    method getSpecialCharacter
    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] {
    puts "WARNING: Removed \" from comment of method [$this getSTName]"
    }
    [$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
    }

    if { [info commands $className] == "" } {
    puts "ERROR: Tcl Method defined but class $className not found for operation [$this getSTName]"
    return 0
    }

    if { [$className info supers] != "STGOperation" } {
    puts "ERROR: Tcl generator class $className must be derived from STGOperation"
    return 0
    }

    if { [lsearch [$className info methods] $generatorMethod] == -1 } {
    puts "ERROR: Tcl method $generatorMethod not found for operation [$this getSTName]"
    return 0
    }

    # Found : promote to custom class and execute method
    $className promote $this
    if [catch {
    $this $generatorMethod [$this methodImplementation]
    } error] {
    puts "ERROR: when calling $generatorMethod: $error"
    return 0
    }
    return 1
}


# Returns category for this operation.
#
method STGOperation::getCategory {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
}


# 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 } {
        puts "ERROR: special operator operator- must have exactly one argument; special characters ignored"
        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 == "" } {
        puts "ERROR: Invalid syntax for special operator [$this getName]; special characters ignored"
        return ""
    }
    }

    # More characters?? Not syntax compliant so ignore it.
    if { $operatorChars != "" } {
    puts "ERROR: Invalid syntax for special operator [$this getName]; special characters ignored"
    return ""
    }

    # Now check if there is exactly one argument
    if { [llength [$this parameterSet]] != 1 } {
    puts "ERROR: special operator [$this getName] must have exactly one argument; special characters ignored"
    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 ""
}

# Do not delete this line -- regeneration end marker

selfPromoter OPOperation {this} {
    STGOperation promote $this
}

#      File:           @(#)stgoperpar.tcl    /main/hindenburg/2


# Generator for operation parameters.

Class STGOperParameter : {STGObject OPOperParameter} {
    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

selfPromoter OPOperParameter {this} {
    STGOperParameter promote $this
}

#      File:           @(#)stgqualifi.tcl    /main/hindenburg/2


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

Class STGQualifier : {STGObject OPQualifier} {
    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

selfPromoter OPQualifier {this} {
    STGQualifier promote $this
}

#      File:           @(#)stgqualini.tcl    /main/1


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

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

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
}

# Do not delete this line -- regeneration end marker

selfPromoter OPQualInitializer {this} {
    STGQualInitializer promote $this
}

#      File:           @(#)stgsupercl.tcl    /main/1


# This is the generator for super class initializers.

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

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
    }
}

# Do not delete this line -- regeneration end marker

selfPromoter OPSuperClassInitializer {this} {
    STGSuperClassInitializer promote $this
}

#      File:           @(#)stgassocma.tcl    /main/1


# 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/1


# 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/1


# 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/1


# 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/hindenburg/2


# This class is the data attribute generator.

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

    # 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] {
    puts "WARNING: Removed \' from description of [$this getSTName]"
    }
    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" } {
        puts "WARNING: Cannot generate initial value expression for class variable [$this name]: no write access"
        } 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]]
}

# Do not delete this line -- regeneration end marker

selfPromoter OPDataAttr {this} {
    STGDataAttr promote $this
}

#      File:           @(#)stggenasso.tcl    /main/1


# 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 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] {
    puts "WARNING: Removed \' from description of [$this getSTName]"
    }

    # 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
}

# 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/1


# Generator for enum classes.

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

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} {
    puts "ERROR: enums not supported by Smalltalk, not generating for [$this getSTName]"
}

# Do not delete this line -- regeneration end marker

Class STGClassEnumD : {STGClassEnum OPClassEnum} {
}

selfPromoter OPClassEnum {this} {
    STGClassEnumD promote $this
}

#      File:           @(#)stgclassge.tcl    /main/1


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

Class STGClassGenericTypeDefD : {STGClassGenericTypeDef OPClassGenericTypeDef} {
}

selfPromoter OPClassGenericTypeDef {this} {
    STGClassGenericTypeDefD promote $this
}

#      File:           @(#)stgclasstd.tcl    /main/1


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

Class STGClassTDefD : {STGClassTDef OPClassTDef} {
}

selfPromoter OPClassTDef {this} {
    STGClassTDefD promote $this
}

#      File:           @(#)stglinkcla.tcl    /main/1


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

Class STGLinkClass : {STGClass} {
    constructor
    method destructor
    method generate
    method printGeneratingMessage
}

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} {
    if { [$this getSTName] == "" } {
    puts "WARNING: Link class without name skipped"
    } else {
    $this STGClass::generate $classImpl
    }
}


# Print a message stating that generation for this link class is in progress.
#
method STGLinkClass::printGeneratingMessage {this} {
    puts "Generating for link class [$this getSTName]"
}

# Do not delete this line -- regeneration end marker

Class STGLinkClassD : {STGLinkClass OPLinkClass} {
}

selfPromoter OPLinkClass {this} {
    STGLinkClassD promote $this
}

#      File:           @(#)stgoneoppq.tcl    /main/1


# 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

    # 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") } {
        puts "WARNING: qualifier $qualifier is defined in $className, but not as instance variable"
        } else {
        set exists 1
        }
    }
    }

    if { (!$exists) && ($userQualifier != "") } {
    puts "WARNING: user defined qualifier $qualifier not defined in $className, creating it"
    }

    $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"
    }
}

# Do not delete this line -- regeneration end marker


#      File:           @(#)stgassocat.tcl    /main/1


# Generator class for normal association attributes.

Class STGAssocAttr : {STGGenAssocAttr OPAssocAttr} {
    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

selfPromoter OPAssocAttr {this} {
    STGAssocAttr promote $this
}

#      File:           @(#)stglinkatt.tcl    /main/1


# Generates for link attributes.

Class STGLinkAttr : {STGGenAssocAttr OPLinkAttr} {
    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

selfPromoter OPLinkAttr {this} {
    STGLinkAttr promote $this
}

#      File:           @(#)stgqualass.tcl    /main/1


# Generator for qualified associations.

Class STGQualAssocAttr : {STGGenAssocAttr OPQualAssocAttr} {
    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

selfPromoter OPQualAssocAttr {this} {
    STGQualAssocAttr promote $this
}

#      File:           @(#)stgquallin.tcl    /main/1


# Generator class for qualified link attributes.

Class STGQualLinkAttr : {STGGenAssocAttr OPQualLinkAttr} {
    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

selfPromoter OPQualLinkAttr {this} {
    STGQualLinkAttr promote $this
}

#      File:           @(#)stgreverse.tcl    /main/1


# Generator class for reverse link attributes.

Class STGReverseLinkAttr : {STGGenAssocAttr OPReverseLinkAttr} {
    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

selfPromoter OPReverseLinkAttr {this} {
    STGReverseLinkAttr promote $this
}