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

Text File | 1997-05-02 | 90.0 KB | 3,554 lines

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

#      File:           @(#)dpgclass.tcl    /main/hindenburg/16


Class DPGClass : {Object} {
    constructor
    method destructor
    method baseType
    method isGUIComponent
    method isDerivable
    method getUnitName
    method getFormVarName
    method getFormTypeName
    method generateComponent
    method generateType
    method generateTObjectType
    method generate
    attribute bseType
    attribute doneComponent
    attribute target
}

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

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

method DPGClass::baseType {this} {
    if {[$this bseType] == ""} {
        set super $this

        if {[$super getName] != "TForm" && [$super getName] != "TComponent"} {
            while {[llength [$super genNodeSet]] > 0} {
                if {[$super getName] == "TForm" || [$super getName] == "TComponent"} {
                    break;
                }
                set super [[lindex [$super genNodeSet] 0] superClass]
            }
        }

        switch [$super getName] {
            "TForm"        {
                $this bseType [$super getName]
            }
            "TComponent"    {
                $this bseType [$super getName]
            }
            default            {
                $this bseType "Class"
            }
        }
    }

    return [$this bseType]
}

method DPGClass::isGUIComponent {this} {
    if {[$this baseType] == "TForm" || [$this baseType] == "TComponent"} {
        return 1
    } else {
        return 0
    }
}

method DPGClass::isDerivable {this} {
    if {[$this baseType] == "TComponent"} {
        return 0
    } else {
        return 1
    }
}

method DPGClass::getUnitName {this} {
    return "[$this getName]Unit"
}

method DPGClass::getFormVarName {this} {
    return [$this getName]
}

method DPGClass::getFormTypeName {this} {
#    if {[$this getPropertyValue "is_vcl"] != 1} {
# }
    if {[$this getName] != "TForm"} {
        return "T[$this getName]"
    } else {
        return [$this getName]
    }
}

method DPGClass::generateComponent {this role class control} {
    if {[$this doneComponent] == 1} {
        m4_fatal $E_CONTLOOP [$class name]
        return
    }

    # Create new component
    #
    set ctrlType [[[lindex [$this genNodeSet] 0] superClass] generateType]
    set newcontrol [DPControl new $ctrlType]
    $newcontrol name $role
    set props [TextSection new]
    $newcontrol properties $props

    # Add new component to child list of parent
    $control addChild $newcontrol

    # Add new component to form
    [$class form] setControl [$newcontrol name] $newcontrol

    # Generate child components
    $this doneComponent 1
    foreach assoc [$this genAssocAttrSet] {
        if {[$assoc hasGUIComponent]} {
            $assoc generateComponent $class $newcontrol
        }
    }
    $this doneComponent 0

    # Generate events
    foreach operation [$this operationSet] {
        if {[$operation getPropertyValue "is_event"] == 1} {

            set controlevent [DPControlEvent new [$operation generateEvent $class $newcontrol]]
            $controlevent name [$operation getName]
            $newcontrol addEvent $controlevent
        } else {
            if {[$this baseType] != "TForm"} {
                m4_error $E_CANTCONTMETH [$this getName]
            }
        }
    }
}

method DPGClass::generateType {this} {
    set type [DPType new]
    $type includeType "user"
    $type includeName [$this getUnitName]
    if {[$this baseType] == "TForm"} {
        $type name [$this getFormTypeName]
    } else {
        $type name "[$this getName]"
    }

    set libunit [$this getPropertyValue "libunit"]
    if {$libunit != "None" && $libunit != ""} {
        $type includeType "system"
        if {$libunit == "Other"} {
            $type includeName [$this getPropertyValue "userlib"]
        } else {
            $type includeName $libunit
        }
    }
    return $type
}

method DPGClass::generateTObjectType {this} {
    set type [DPType new]
    $type includeType "system"
    $type includeName "System"
    $type name "TObject"
    return $type
}

method DPGClass::generate {this tgt} {

    # Hook unit to project

    switch [$this baseType] {
        "TForm" {
            # Create form class
            set formtype [$this generateType]
            set form [DPForm new $formtype]
            $form name "[$this getName]"
            set props [TextSection new]
            $form properties $props
            set unit [DPFormClass new $form]
            $this target $unit
            $unit name [$formtype name]

            #Create global form variable
            set formvar [DPVariable new $formtype]
            $formvar name "[$this getFormVarName]"
            $unit addGlobvar $formvar

            # Hook form to project
            $tgt setForm [$formvar name] $form

            # Generate events
            foreach operation [$this operationSet] {
                if {[$operation getPropertyValue "is_event"] == 1} {
                    set controlevent [DPControlEvent new [$operation generateEvent $unit $form]]
                    $controlevent name [$operation getName]
                    $form addEvent $controlevent
                }
            }

            # Generate components
            foreach assoc [$this genAssocAttrSet] {
                if {[$assoc hasGUIComponent]} {
                    $assoc generateComponent $unit $form
                }
            }
        }
        "Class" {
            set unit [DPClass new]
            $this target $unit
            set type [$this generateType]
            $unit name "[$type name]"
        }
        default {
            return
        }
    }
    $tgt setUnit [$this getName] $unit

    # Set unit attributes

    $unit unitName "[$this getUnitName]"

    # comment

    set comment [DPComment new]
    $unit comment $comment
    $comment comment [$this getPropertyValue "freeText"]

    # Generate superclass

    foreach genNode [$this genNodeSet] {
        $genNode generate $unit
    }

    # Generate attributes

    foreach feature [$this dataAttrSet] {
        $feature generate $unit
    }

    # Generate methods

    foreach feature [$this operationSet] {
        $feature generate $unit
    }

    # Generate constructor

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

    # Generate destructor

    set dtor [DPDestructor new]
    $dtor isOverride 1
    $dtor name "Destroy"
    $dtor access "Published"
    $dtor userCodeFirst 1
    $dtor gencode [TextSection new]
    $dtor gentypes [TextSection new]
    $unit destructr $dtor

    # Generate associations

    foreach assoc [$this genAssocAttrSet] {
        if {[$this baseType] == "Class"} {
            if {[$assoc hasGUIComponent]} {
                m4_error $E_CANTCONTGUI [$this getName] [[[$assoc ooplType] ooplClass] getName]
                return
            }
        }
        $assoc generate $unit
    }

    # Old destructor is last thing to call in a destructor
    [$dtor gencode] append "\ninherited Destroy;\n"
}

# Do not delete this line -- regeneration end marker

Class DPGClassD : {DPGClass OPClass} {
}

selfPromoter OPClass {this} {
    DPGClassD promote $this
}

#      File:           @(#)dpgfeature.tcl    /main/hindenburg/3


Class DPGFeature : {Object} {
    constructor
    method destructor
    method generate
}

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

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

method DPGFeature::generate {this} {
    # !! Implement this function !!
}

# Do not delete this line -- regeneration end marker

Class DPGFeatureD : {DPGFeature OPFeature} {
}

selfPromoter OPFeature {this} {
    DPGFeatureD promote $this
}

#      File:           @(#)dpginhgrou.tcl    /main/hindenburg/5


Class DPGInhGroup : {Object OPInhGroup} {
    constructor
    method destructor
    method generateSuperType
    method generate
}

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

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

method DPGInhGroup::generateSuperType {this} {
    if {![[$this superClass] isDerivable]} {
        m4_error $E_ILLSUPER [[$this superClass] getName]
    }
    set type [[$this superClass] generateType]
    return $type
}

method DPGInhGroup::generate {this class} {

    if {[$class superclass] != ""} {
        m4_warning $W_MULTINH [$class name] [[$class superclass] name] [$this getSuperClassName]
        return
    }
    if {[$this isOverlapping]} {
        m4_warning $W_OVERLAPINH [$class name] [$this getSuperClassName]
    }
    $class superclass [$this generateSuperType]
}

# Do not delete this line -- regeneration end marker

selfPromoter OPInhGroup {this} {
    DPGInhGroup promote $this
}

#      File:           @(#)dpginitial.tcl    /main/hindenburg/1


Class DPGInitializer : {Object} {
    constructor
    method destructor
    method generate
}

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

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

method DPGInitializer::generate {this ctor} {
    # !! Implement this function !!
}

# Do not delete this line -- regeneration end marker

Class DPGInitializerD : {DPGInitializer OPInitializer} {
}

selfPromoter OPInitializer {this} {
    DPGInitializerD promote $this
}

#      File:           @(#)dpgparamet.tcl    /main/hindenburg/1


Class DPGParameter : {Object} {
    constructor
    method destructor
}

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

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

# Do not delete this line -- regeneration end marker

Class DPGParameterD : {DPGParameter OPParameter} {
}

selfPromoter OPParameter {this} {
    DPGParameterD promote $this
}

#      File:           @(#)dpgtype.tcl    /main/hindenburg/4


Class DPGType : {Object Object} {
    constructor
    method destructor
    method generate
}

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

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

method DPGType::generate {this} {

    if {[$this ooplClass] != ""} {
        set type [[$this ooplClass] generateType]
    } else {
        set type [DPType new]
        $type includeType "user"
        $type includeName ""
        $type name ""
    }
    return $type
}

# Do not delete this line -- regeneration end marker

Class DPGTypeD : {DPGType OPType} {
}

selfPromoter OPType {this} {
    DPGTypeD promote $this
}

#      File:           @(#)dpgassocge.tcl    /main/hindenburg/8


Class DPGAssocGen : {GCObject} {
    constructor
    method destructor
    method propRead
    method propWrite
    method hasGet
    method assocattr
    attribute varname
    attribute varref
    attribute varset
    attribute vardict
    attribute varqual
    attribute opvarname
    attribute opvarref
    attribute opvarset
    attribute opvardict
    attribute addWarning
    attribute setWarning
    attribute getWarning
    attribute removeWarning
    attribute dtorWarning
    attribute _assocattr
}

constructor DPGAssocGen {class this assocattr} {
    set this [GCObject::constructor $class $this]
    $this addWarning 0
    $this setWarning 0
    $this getWarning 0
    $this removeWarning 0
    $this dtorWarning 0
    $this _assocattr $assocattr
    $assocattr _generator $this
    # Start constructor user section


    # Check for mtory-mtory
    #
    set assoc [$this assocattr]
    set oppos [[$this assocattr] opposite]
    if {$oppos != ""} {
        if {[$assoc isMandatory] && [$assoc getMultiplicity] == "one" && ![$assoc isQualified]} {
            if {[$oppos isMandatory] && [$oppos getMultiplicity] == "one" && ![$oppos isQualified]} {
                m4_error $E_MTORYMTORY [[[[$this assocattr] opposite] ooplClass] getName] [[[$this assocattr] ooplClass] getName]
            }
        }
    }

    $this varname [[$this assocattr] getName]
    $this varref "[$this varname]Ref"
    $this varset "[$this varname]Set"
    $this vardict "[$this varname]Dict"
    if {[[$this assocattr] get_obj_type] == "qual_assoc_attrib" || [[$this assocattr] get_obj_type] == "qual_link_attrib"} {
        $this varqual [[[$this assocattr] qualifier] getName]
    }
    if {[[$this assocattr] opposite] != ""} {
        $this opvarname [[[$this assocattr] opposite] getName]
        $this opvarref "[$this opvarname]Ref"
        $this opvarset "[$this opvarname]Set"
        $this opvardict "[$this opvarname]Dict"
    }
    # End constructor user section
    return $this
}

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

method DPGAssocGen::propRead {this} {
    set accessList [split [[$this assocattr] getPropertyValue assoc_access] -]
    set accessStr [lindex $accessList 0]
    if {$accessStr == ""} {
        set accessStr "Published"
    }
    return $accessStr
}

method DPGAssocGen::propWrite {this} {
    set accessList [split [[$this assocattr] getPropertyValue assoc_access] -]
    set accessStr [lindex $accessList 1]
    if {$accessStr == ""} {
        set accessStr "Published"
    }
    return $accessStr
}

method DPGAssocGen::hasGet {this self} {
    set rd [$this propRead]
    if {$self} {
        if {$rd == "None"} {
            return 0
        }
    } else {
        if {$rd == "None" || $rd == "Private" || $rd == "Protected"} {
            return 0
        }
    }
    return 1
}

# Do not delete this line -- regeneration end marker

method DPGAssocGen::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:           @(#)dpgclassen.tcl    /main/hindenburg/5


Class DPGClassEnum : {DPGClass} {
    constructor
    method destructor
    method isDerivable
    method generate
}

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

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

method DPGClassEnum::isDerivable {this} {
    return 0
}

method DPGClassEnum::generate {this tgt} {
    set unit [DPEnumUnit new]
    set type [$this generateType]
    $unit name "[$type name]"

    $tgt setUnit [$this getName] $unit
    $unit unitName "[$this getUnitName]"

    set comment [DPComment new]
    $unit comment $comment
    $comment comment [$this getPropertyValue "freeText"]

    # Generate enum fields
    foreach feature [$this dataAttrSet] {
        if {[$feature getInitialValue] != ""} {
            m4_warning $W_ENUMDEFAULT [$this getName]
        }
        set comp [DPEnumComponent new]
        $comp name [$feature getName]
        $unit addComponent $comp
    }
}

# Do not delete this line -- regeneration end marker

Class DPGClassEnumD : {DPGClassEnum OPClassEnum} {
}

selfPromoter OPClassEnum {this} {
    DPGClassEnumD promote $this
}

#      File:           @(#)dpgclassge.tcl    /main/hindenburg/3


Class DPGClassGenericTypeDef : {DPGClass} {
    constructor
    method destructor
    method isDerivable
    method generate
}

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

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

method DPGClassGenericTypeDef::isDerivable {this} {
    return 0
}

method DPGClassGenericTypeDef::generate {this tgt} {

    set assoc [lindex [$this genAssocAttrSet] 0]

    if {[$assoc isQualified]} {
        set typedefType [$assoc generateQualAssocType]
    } else {
        if {[$assoc getMultiplicity] == "many"} {
            set typedefType [$assoc generateManyAssocType]
        } else {
            set typedefType [[$assoc ooplType] generate]
        }
    }
    set unit [DPTypeDefUnit new $typedefType]
    set type [$this generateType]
    $unit name "[$type name]"

    $tgt setUnit [$this getName] $unit
    $unit unitName "[$this getUnitName]"

    set comment [DPComment new]
    $unit comment $comment
    $comment comment [$this getPropertyValue "freeText"]
}

# Do not delete this line -- regeneration end marker

Class DPGClassGenericTypeDefD : {DPGClassGenericTypeDef OPClassGenericTypeDef} {
}

selfPromoter OPClassGenericTypeDef {this} {
    DPGClassGenericTypeDefD promote $this
}

#      File:           @(#)dpgclasstd.tcl    /main/hindenburg/8


Class DPGClassTDef : {DPGClass} {
    constructor
    method destructor
    method isDerivable
    method getFinalType
    method getType
    method generate
    attribute cid
    attribute finalType
}

global DPGClassTDef::gid
set DPGClassTDef::gid 0


constructor DPGClassTDef {class this name} {
    set this [DPGClass::constructor $class $this $name]
    set this [Object::constructor $class $this $name]
    $this finalType null
    # Start constructor user section
    # End constructor user section
    return $this
}

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

method DPGClassTDef::isDerivable {this} {
    set type [$this getFinalType]

    if {$type != ""} {
        if {[$type isA OPBaseType] || [$type isA OPTypeDefType] || [$type isA OPEnumType]} {
            return 0
        }
        if {[$type isA OPClassType] && [[$type ooplClass] baseType] == "TComponent"} {
            return 0
        }
    }
    return 1
}

method DPGClassTDef::getFinalType {this} {
    # return the (final) type to which this typedef really refers, i.e. resolve
    #  the typedef trail until a non-typedef is discovered
    # note: this func returns an OPTypeDefType in case of a typedef that refers
    #        to itself
    # currently, this is done non-recursively...
    #
    # note: copy from Forte generator
    #

    # Note! Constructor is not called so initialization is done in promotor!!
    #
    if {[$this finalType] != "null"} {
    return [$this finalType]
    }

    global DPGClassTDef::gid
    incr DPGClassTDef::gid
    set id ${DPGClassTDef::gid}
    $this cid $id

    set type [$this getType]
    while {1} {
        if {$type == ""} {
            $this finalType ""
            return ""
        }
        if {![$type isA OPTypeDefType]} {
            $this finalType $type
            return $type
        }
        set class [$type ooplClass]
        if {$class == ""} {
            $this finalType ""
            return ""
        }
        if {![$class isA OPClassTDef]} {
            $this finalType $type
            return $type
        }
        if {$id == [$class cid]} {
            # loop detected
            $this finalType $type
            return $type
        }
        if {[$class getName] == ""} {
            $this finalType ""
            return ""
        }
        $class cid $id
        set type [$class getType]
    }
}

method DPGClassTDef::getType {this} {
    # note: this method should have been a member of OPClassTDef
    #
    set attr [lindex [$this dataAttrSet] 0]
    if {$attr == ""} {
        return ""
    }

    # hack: if attr has no type, the OOPL model returns an OPClassType without
    #  an OPCLass... or an OPClass having no name... !!!
    #
    set type [$attr ooplType]
    if {[$type isA OPClassType]} {
        if {[$type ooplClass] == "" || [[$type ooplClass] getName] == ""} {
            return ""
        }
    }
    return $type
}

method DPGClassTDef::generate {this tgt} {
    set unit [DPTypeDefUnit new [[[$this dataAttrSet] ooplType] generate]]
    set type [$this generateType]
    $unit name "[$type name]"

    $tgt setUnit [$this getName] $unit
    $unit unitName "[$this getUnitName]"

    set comment [DPComment new]
    $unit comment $comment
    $comment comment [$this getPropertyValue "freeText"]
}

# Do not delete this line -- regeneration end marker

Class DPGClassTDefD : {DPGClassTDef OPClassTDef} {
}

selfPromoter OPClassTDef {this} {
    DPGClassTDefD promote $this
    $this finalType null
}

#      File:           @(#)dpglinkcla.tcl    /main/hindenburg/3


Class DPGLinkClass : {DPGClass} {
    constructor
    method destructor
    method isDerivable
}

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

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

method DPGLinkClass::isDerivable {this} {
    return 0
}

# Do not delete this line -- regeneration end marker

Class DPGLinkClassD : {DPGLinkClass OPLinkClass} {
}

selfPromoter OPLinkClass {this} {
    DPGLinkClassD promote $this
}

#      File:           @(#)dpgattribu.tcl    /main/hindenburg/1


Class DPGAttribute : {DPGFeature} {
    constructor
    method destructor
}

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

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

# Do not delete this line -- regeneration end marker

Class DPGAttributeD : {DPGAttribute OPAttribute} {
}

selfPromoter OPAttribute {this} {
    DPGAttributeD promote $this
}

#      File:           @(#)dpgconstru.tcl    /main/hindenburg/13


Class DPGConstructor : {DPGFeature} {
    constructor
    method destructor
    method generate
    attribute counted
}

constructor DPGConstructor {class this name} {
    set this [DPGFeature::constructor $class $this $name]
    $this counted 0
    # Start constructor user section
    # End constructor user section
    return $this
}

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

method DPGConstructor::generate {this class} {
    if {[$this counted] == ""} {
        $class userConstructors [expr [$class userConstructors] + 1]
        $this counted 1
    }

    set ctor [DPConstructor new]
    set comment [DPComment new]
    $ctor comment $comment
    $comment comment [$this getPropertyValue "freeText"]

    $ctor name "Create"
    $ctor access [$this getPropertyValue "method_access"]

    # ToDo: Check for automatic override generation?
#    $ctor isOverride 1

    # Method modifier

    switch [$this getPropertyValue "method_modifier"] {
        "Virtual"    {
            $ctor isVirtual 1
        }
        "Dynamic"    {
            $ctor isDynamic 1
        }
        "Virtual Abstract"    {
            $ctor isAbstract 1
            $ctor isVirtual 1
        }
        "Dynamic Abstract"    {
            $ctor isAbstract 1
            $ctor isDynamic 1
        }
        "Override"    {
            $ctor isOverride 1
        }
        default    {
        }
    }

    if {[$ctor access] == ""} {
        $ctor access "Published"
    }
    set gencode [TextSection new]
    set gentypes [TextSection new]
    $ctor gencode $gencode
    $ctor gentypes $gentypes

    # Generate default Delphi parameter for component constructor
    #
    if {[[$this ooplClass] baseType] == "TForm"} {
        set type [DPType new]
        $type name "TComponent"
        $type includeType "system"
        $type includeName "Classes"
        set param [DPArgument new $type]
        $param name "AOwner"
        $ctor addArg $param
    }

    # Generate initializers
    #
    set superctor [DPConstructor new]
    foreach initializer [$this superClassInitializerSet] {
        $initializer generate $superctor
    }

    # Generate key attribute initialization code
    #
    foreach initializer [$this attribInitializerSet] {
        $initializer generate $ctor
    }

    # Generate initialized data attribute values
    #
    foreach attrib [[$this ooplClass] dataAttrSet] {
        $attrib generateInitialValue $ctor
    }
    [$ctor gencode] append "\n"

    # Generate association initialization code
    #
    foreach initializer [$this assocInitializerSet] {
        $initializer generate $ctor
    }

    # Generate superclass call
    #
    $gencode append "inherited Create"
    if {[[$superctor argSet] contents] != "" || [[$this ooplClass] baseType] == "TForm"} {
        $gencode append "("
        set first 1
        if {[[$this ooplClass] baseType] == "TForm"} {
            $gencode append "AOwner"
            set first 0
        }
        [$superctor argSet] foreach arg {
            if {$first} {
                set first 0
            } else {
                $gencode append ", "
            }
            $gencode append [$arg name]
        }
        $gencode append ")"
    }
    $gencode append ";\n"


    # Generate parameters
    #
    foreach param [[$this ooplClass] creationParamSet] {
        if {![$param isGUIComponent [$this ooplClass]]} {
            $param generate $ctor
        }
    }

    $class constructr $ctor
}

# Do not delete this line -- regeneration end marker

Class DPGConstructorD : {DPGConstructor OPConstructor} {
}

selfPromoter OPConstructor {this} {
    DPGConstructorD promote $this
}

#      File:           @(#)dpgoperati.tcl    /main/hindenburg/7


Class DPGOperation : {DPGFeature} {
    constructor
    method destructor
    method getBaseEvent
    method generateEvent
    method generate
}

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

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

method DPGOperation::getBaseEvent {this class} {

    # Find base Event with access "Public" or "Published"
    set eventname [$this getName]
    while {[llength [$class genNodeSet]] > 0} {
        foreach operation [$class operationSet] {
            if {[$operation getName] == $eventname} {
                set access [$operation getPropertyValue "method_access"]
                if {$access == "Published" || $access == "Public" || $access == ""} {
                    return $operation
                }
            }
        }
        set class [[lindex [$class genNodeSet] 0] superClass]
    }

    return ""
}

method DPGOperation::generateEvent {this class control} {

    set event [DPEvent new]
    $event name [$control name][$this getName]

    set tempmod [$this getPropertyValue "method_modifier"]
    if {[$this isClassFeature] || ( $tempmod != "" && $tempmod != "None" )} {
        m4_warning $W_EVTILLTYPE [$event name] [$control name]
    }

    if {[$class getEvent [string tolower [$event name]]] == ""} {
        $class setEvent [string tolower [$event name]] $event
    } else {
        m4_warning $W_EVTDBDEF [$event name] [$control name]
    }

    # Search if event is valid

    if {[[$this ooplClass] isGUIComponent]} {
        set super [[lindex [[$this ooplClass] genNodeSet] 0] superClass]
        set baseEvent [$this getBaseEvent $super]
        if {$baseEvent == ""} {
            m4_warning $E_EVTNOTEXIST [$this getName] [$control name]
            return $event
        }

        # Generate parameters of base-event

        foreach param [$baseEvent parameterSet] {
            $param generate $event
        }
    }

    # Access

    $event access "Published"

    # Comment

    set comment [DPComment new]
    $event comment $comment
    $comment comment [$this getPropertyValue "freeText"]

    # Parameters

    #foreach param [$this parameterSet] {
    #    $param generate $event
    #}

    return $event
}

method DPGOperation::generate {this class} {

    # No events for non-GUI classes

    if {[$this getPropertyValue "is_event"] == 1} {
        if {[[$this ooplClass] isGUIComponent] == 0} {
            m4_error $E_CANTCONTEVENT [[$this ooplClass] getName] [$this getName]
        } else {
            return
        }
    }

    # Constructor

    if {[string tolower [$this getName]] == "create" && [$this isClassFeature]} {
        set oper [DPConstructor new]
        $oper name [$this getName]

        if {[[$this ooplClass] constructor] != ""} {
            if {[[[$this ooplClass] constructor] counted] == ""} {
                [[$this ooplClass] constructor] counted 1
                $class userConstructors [expr [$class userConstructors] + 1]
            }
        }
        $class userConstructors [expr [$class userConstructors] + 1]
        if {[expr [$class userConstructors] > 1]} {
            $oper name [$oper name][$class userConstructors]
        }
    } else {

        # Procedure or function

        set returnType [[$this ooplType] generate]
        if {[$returnType name] != ""} {
            set oper [DPFunction new $returnType]
        } else {
            set oper [DPProcedure new]
        }
        $oper name [$this getName]
        $oper isClassFeature [$this isClassFeature]
    }

    if {[$class getUsermethod [string tolower [$oper name]]] == ""} {
        $class setUsermethod [string tolower [$oper name]] $oper
    } else {
        m4_warning $W_METHDBDEF [$oper name] [$class name]
    }

    # Access

    $oper access [$this getPropertyValue "method_access"]
    if {[$oper access] == ""} {
        $oper access "Published"
    }

    # Comment

    set comment [DPComment new]
    $oper comment $comment
    $comment comment [$this getPropertyValue "freeText"]

    # Method modifier

    switch [$this getPropertyValue "method_modifier"] {
        "Virtual"    {
            $oper isVirtual 1
        }
        "Dynamic"    {
            $oper isDynamic 1
        }
        "Virtual Abstract"    {
            $oper isAbstract 1
            $oper isVirtual 1
        }
        "Dynamic Abstract"    {
            $oper isAbstract 1
            $oper isDynamic 1
        }
        "Override"    {
            $oper isOverride 1
        }
        default    {
        }
    }
    if {[$this isAbstract]} {
        $oper isAbstract 1
        $oper isVirtual 1
    }

    # Parameters

    foreach param [$this parameterSet] {
        $param generate $oper
    }
}

# Do not delete this line -- regeneration end marker

Class DPGOperationD : {DPGOperation OPOperation} {
}

selfPromoter OPOperation {this} {
    DPGOperationD promote $this
}

#      File:           @(#)dpgassocin.tcl    /main/hindenburg/8


Class DPGAssocInitializer : {DPGInitializer} {
    constructor
    method destructor
    method generate
}

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

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

method DPGAssocInitializer::generate {this ctor} {
    if {[[[$this assoc] ooplType] ooplClass] != ""} {
        if {[[[[$this assoc] ooplType] ooplClass] baseType] == "TComponent"} {
            return
        }
    }

    set varname "[[$this assoc] getName]"
    set refname "${varname}Ref"
    set setname "${varname}Set"
    set dictname "${varname}Dict"
    if {[[$this assoc] opposite] != ""} {
        set opvarname "[[[$this assoc] opposite] getName]"
        set oprefname "${opvarname}Ref"
        set opsetname "${opvarname}Set"
        set opdictname "${opvarname}Dict"
    }

    # ToDo: Clean this up!!
    #
    set assoctype [[$this assoc] generateAssocType [[[$this constructor] ooplClass] target]]


    if {[[$this assoc] isMandatory]} {
        [$ctor gencode] append "if ([$this getName] <> NIL) then\nbegin\n"
        [$ctor gencode] indent +
    }
    if {[[$this assoc] getMultiplicity] == "one"} {
        if {[[$this assoc] isMandatory] &&
            [[$this assoc] opposite] != ""} {
            if {[[[$this assoc] opposite] isQualified]} {
                if {[[[$this assoc] opposite] get_obj_type] == "qual_link_attrib"} {
                    [$ctor gencode] append "${refname} := [$this getName];\n"
                    set key [[[$this constructor] qualInitializer] getName]
                    if {[[[$this assoc] opposite] getMultiplicity] == "one"} {
                        [$ctor gencode] append "(${refname} as [$assoctype name]).${opdictname}.Add(${key}, SELF);\n"
                    } else {
                        set tempset "temp${opsetname}"
                        [$ctor gentypes] append "var\n"
                        [$ctor gentypes] indent +
                        [$ctor gentypes] append "${tempset}: TList;\n"
                        [$ctor gentypes] indent -

                        [$ctor gencode] append "if (${refname} as [$assoctype name]).${opdictname}.Item(SELF) <> NIL) then\nbegin\n"
                        [$ctor gencode] indent +
                        [$ctor gencode] append "${tempset} := (${refname} as [$assoctype name]).${opdictname}.Item(SELF;\n"
                        [$ctor gencode] indent -
                        [$ctor gencode] append "end\n"
                        [$ctor gencode] append "else\n"
                        [$ctor gencode] append "begin\n"
                        [$ctor gencode] indent +
                        [$ctor gencode] append "${tempset} := TList.Create;\n"
                        [$ctor gencode] append "(${refname} as [$assoctype name]).${opdictname}.Add(${key}, ${tempset})\n"
                        [$ctor gencode] indent -
                        [$ctor gencode] append "end;\n"
                        [$ctor gencode] append "${tempset}.Add(SELF);\n"
                    }
                } else {
                    m4_warning $W_NOCTORCODE [[[$this assoc] ooplClass] getName] [[[[$this assoc] opposite] ooplClass] getName]
                }
            } else {
                [$ctor gencode] append "${refname} := [$this getName];\n"
                if {[[[$this assoc] opposite] getMultiplicity] == "one"} {
                    [$ctor gencode] append "(${refname} as [$assoctype name]).${oprefname} := SELF;\n"
                } else {
                    [$ctor gencode] append "(${refname} as [$assoctype name]).${opsetname}.Add(SELF);\n"
                }
            }
        } else {
            [$ctor gencode] append "${refname} := [$this getName];\n"
        }
    } else {
        [$ctor gencode] append "${setname} := TList.Create;\n";
        [$ctor gencode] append "add[cap ${varname}]([$this getName]);\n"
    }

    if {[[$this assoc] isMandatory]} {
        set sysutilstype [DPType new]
        $sysutilstype includeName "SysUtils"
        $sysutilstype includeType "imp"
        $sysutilstype addAsInclude [[[$this constructor] ooplClass] target]

        [$ctor gencode] indent -
        [$ctor gencode] append "end\nelse\n"
        [$ctor gencode] indent +
        [$ctor gencode] append "raise EInvalidOp.Create('Object ${varname} has mandatory relation. NIL object reference not allowed.');\n"
        [$ctor gencode] indent -
    }
}

# Do not delete this line -- regeneration end marker

Class DPGAssocInitializerD : {DPGAssocInitializer OPAssocInitializer} {
}

selfPromoter OPAssocInitializer {this} {
    DPGAssocInitializerD promote $this
}

#      File:           @(#)dpgattribi.tcl    /main/hindenburg/3


Class DPGAttribInitializer : {DPGInitializer} {
    constructor
    method destructor
    method generate
}

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

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

method DPGAttribInitializer::generate {this ctor} {

    if {[[$this attrib] isClassFeature]} {
        m4_warning $W_NOKEYFEAT [[$this attrib] getName] [[[$this attrib] ooplClass] getName]
    } else {
        [$ctor gencode] append "[[$this attrib] getName] := [$this getName];\n"
    }
}

# Do not delete this line -- regeneration end marker

Class DPGAttribInitializerD : {DPGAttribInitializer OPAttribInitializer} {
}

selfPromoter OPAttribInitializer {this} {
    DPGAttribInitializerD promote $this
}

#      File:           @(#)dpginhkeyi.tcl    /main/hindenburg/1


Class DPGInhKeyInitializer : {DPGInitializer} {
    constructor
    method destructor
    method generate
}

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

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

method DPGInhKeyInitializer::generate {this ctor} {
    # !! Implement this function !!
}

# Do not delete this line -- regeneration end marker

Class DPGInhKeyInitializerD : {DPGInhKeyInitializer OPInhKeyInitializer} {
}

selfPromoter OPInhKeyInitializer {this} {
    DPGInhKeyInitializerD promote $this
}

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


Class DPGQualInitializer : {DPGInitializer} {
    constructor
    method destructor
    method generate
}

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

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

method DPGQualInitializer::generate {this ctor} {
    # !! Implement this function !!
}

# Do not delete this line -- regeneration end marker

Class DPGQualInitializerD : {DPGQualInitializer OPQualInitializer} {
}

selfPromoter OPQualInitializer {this} {
    DPGQualInitializerD promote $this
}

#      File:           @(#)dpgsupercl.tcl    /main/hindenburg/3


Class DPGSuperClassInitializer : {DPGInitializer} {
    constructor
    method destructor
    method generate
}

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

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

method DPGSuperClassInitializer::generate {this ctor} {
    foreach param [$this parameterSet] {
        if {![$param isGUIComponent [$this ooplClass]]} {
            $param generate $ctor
        }
    }
}

# Do not delete this line -- regeneration end marker

Class DPGSuperClassInitializerD : {DPGSuperClassInitializer OPSuperClassInitializer} {
}

selfPromoter OPSuperClassInitializer {this} {
    DPGSuperClassInitializerD promote $this
}

#      File:           @(#)dpgctorpar.tcl    /main/hindenburg/3


Class DPGCtorParameter : {DPGParameter} {
    constructor
    method destructor
    method isGUIComponent
    method generate
}

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

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

method DPGCtorParameter::isGUIComponent {this class} {
    # ToDo: Modify this for future component inheritance
    if {[$class baseType] != "TForm"} {
        return 0
    }
    set done 0
    while {!$done} {
        foreach assoc [$class genAssocAttrSet] {
            if {[$assoc getName] == [$this getName]} {
                if {[[$assoc ooplClass] isGUIComponent]} {
                    return 1
                }
            }
        }
        set class [[lindex [$class genNodeSet] 0] superClass]
        if {[$class getName] == "TForm"} {
            set done 1
        }
    }
    return 0
}

method DPGCtorParameter::generate {this method} {
    if {[$this attrib] != ""} {
        if [[$this attrib] isClassFeature] {
            return
        }
    }

    # check if GUI association
    #
    if {[$this initializer] != ""} {
        if {[[$this initializer] isA OPAssocInitializer]} {
            if {[[[[$this initializer] assoc] ooplType] ooplClass] != ""} {
                if {[[[[[$this initializer] assoc] ooplType] ooplClass] baseType] == "TComponent"} {
                    return
                }
            }
        }
    }
    set param [DPArgument new [[$this ooplType] generate]]
    $param name [$this getName]
    $param passedBy [$this getPropertyValue "pass_by"]
    $method addArg $param
}

# Do not delete this line -- regeneration end marker

Class DPGCtorParameterD : {DPGCtorParameter OPCtorParameter} {
}

selfPromoter OPCtorParameter {this} {
    DPGCtorParameterD promote $this
}

#      File:           @(#)dpgoperpar.tcl    /main/hindenburg/1


Class DPGOperParameter : {DPGParameter} {
    constructor
    method destructor
    method generate
}

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

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

method DPGOperParameter::generate {this method} {
    set param [DPArgument new [[$this ooplType] generate]]
    $param name [$this getName]
    $param passedBy [$this getPropertyValue "pass_by"]
    $method addArg $param
}

# Do not delete this line -- regeneration end marker

Class DPGOperParameterD : {DPGOperParameter OPOperParameter} {
}

selfPromoter OPOperParameter {this} {
    DPGOperParameterD promote $this
}

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


Class DPGBaseType : {DPGType} {
    constructor
    method destructor
    method generate
}

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

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

method DPGBaseType::generate {this} {
    set type [DPType new]
    $type name [$this getType3GL]
    $type includeType "none"
    $type includeName ""
    return $type
}

# Do not delete this line -- regeneration end marker

Class DPGBaseTypeD : {DPGBaseType OPBaseType} {
}

selfPromoter OPBaseType {this} {
    DPGBaseTypeD promote $this
}

#      File:           @(#)dpgclassty.tcl    /main/hindenburg/1


Class DPGClassType : {DPGType} {
    constructor
    method destructor
}

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

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

# Do not delete this line -- regeneration end marker

Class DPGClassTypeD : {DPGClassType OPClassType} {
}

selfPromoter OPClassType {this} {
    DPGClassTypeD promote $this
}

#      File:           @(#)dpgenumtyp.tcl    /main/hindenburg/1


Class DPGEnumType : {DPGType} {
    constructor
    method destructor
}

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

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

# Do not delete this line -- regeneration end marker

Class DPGEnumTypeD : {DPGEnumType OPEnumType} {
}

selfPromoter OPEnumType {this} {
    DPGEnumTypeD promote $this
}

#      File:           @(#)dpgtypedef.tcl    /main/hindenburg/1


Class DPGTypeDefType : {DPGType} {
    constructor
    method destructor
}

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

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

# Do not delete this line -- regeneration end marker

Class DPGTypeDefTypeD : {DPGTypeDefType OPTypeDefType} {
}

selfPromoter OPTypeDefType {this} {
    DPGTypeDefTypeD promote $this
}

#      File:           @(#)dpgassocma.tcl    /main/hindenburg/16


Class DPGAssocMany : {DPGAssocGen} {
    constructor
    method destructor
    method hasAdd
    method hasDtor
    method hasRemove
    method generate
    method generateAdd
    method generateGet
    method generateRemove
    method generateDtor
}

constructor DPGAssocMany {class this assocattr} {
    set this [DPGAssocGen::constructor $class $this $assocattr]
    # Start constructor user section
    # End constructor user section
    return $this
}

method DPGAssocMany::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this DPGAssocGen::destructor
}

method DPGAssocMany::hasAdd {this self} {
    set wr [$this propWrite]
    if {$self} {
        if {$wr == "None"} {
            return 0
        }
    } else {
        if {$wr == "None" || $wr == "Private" || $wr == "Protected"} {
            return 0
        }
    }
    if {[[$this assocattr] opposite] != ""} {
        if {[[[$this assocattr] opposite] isQualified]} {
            if {![$this addWarning]} {
                $this addWarning 1
                m4_warning $W_NOADD [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
            }
            return 0
        }
    }
    return 1
}

method DPGAssocMany::hasDtor {this self} {
    if {[[$this assocattr] opposite] != ""} {
        if {[[[$this assocattr] opposite] isQualified]} {
            if {![$this dtorWarning]} {
                $this dtorWarning 1
                m4_warning $W_NODTOR [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
            }
            return 0
        }
    }
    return 1
}

method DPGAssocMany::hasRemove {this self} {
    set wr [$this propWrite]
    if {$self} {
        if {$wr == "None"} {
            return 0
        }
    } else {
        if {$wr == "None" || $wr == "Private" || $wr == "Protected"} {
            return 0
        }
    }
    if {[[$this assocattr] opposite] != ""} {
        if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
            return 0
        }
        if {[[[$this assocattr] opposite] isQualified]} {
            if {![$this removeWarning]} {
                $this removeWarning 1
                m4_warning $W_NOREMOVE [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
            }
            return 0
        }
    }
    return 1
}

method DPGAssocMany::generate {this cl} {
    set type [[$this assocattr] generateManyAssocType]
    set vari [DPVariable new $type]
    $vari name "[[$this assocattr] getName]Set"
    $cl addAssocvar $vari
    $vari access "Private"
    if {[$cl constructr] != ""} {
        [[$cl constructr] gencode] append "[$vari name] := TList.Create;\n"
    }
    if {[[$this assocattr] opposite] != ""} {
        [[$this assocattr] opposite] setGenerator
    }
    $this generateGet $vari $cl
    $this generateAdd $vari $cl
    $this generateRemove $vari $cl
    $this generateDtor $vari $cl
}

method DPGAssocMany::generateAdd {this vari cl} {
    # Check if Add method should be generated
    #
    if {![$this hasAdd 0]} {
        $vari access "Published"
    }
    if {![$this hasAdd 1]} {
        return
    }

    # Generate
    #
    set type [[[[$this assocattr] ooplType] ooplClass] generateTObjectType]
    set assoctype [[$this assocattr] generateAssocType $cl]
    set arg "new[$assoctype name]"
    set param [DPArgument new $type]
    $param name $arg
    set addproc [DPProcedure new]
    $addproc addArg $param
    set addcode [TextSection new]

    $addproc gencode $addcode
    $addproc hasUserSection 0
    $addproc access [$this propWrite]
    $addproc name "add[cap [$this varname]]"

    $addcode append "if ([$vari name].IndexOf(${arg}) = -1) then\nbegin\n"
    $addcode indent +
    $addcode append "[$vari name].Add(${arg});\n"

    if {[[$this assocattr] opposite] != ""} {
        if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {

            # many-many
            #
            if {[[[[$this assocattr] opposite] generator] hasAdd 0]} {
                $addcode append "(${arg} as [$assoctype name]).add[cap [$this opvarname]](SELF);\n"
            } else {
                $addcode append "(${arg} as [$assoctype name]).[$this opvarset].Add(SELF);\n"
            }
        } else {
            # one-many
            if {[[[[$this assocattr] opposite] generator] hasSet 0]} {
                $addcode append "(${arg} as [$assoctype name]).set[cap [$this opvarname]](SELF);\n"
            } else {
                $addcode append "(${arg} as [$assoctype name]).[$this opvarname] := SELF;\n"
            }
        }
    }

    $addcode indent -
    $addcode append "end;\n"

    $cl setGenmethod [$addproc name] $addproc
}

method DPGAssocMany::generateGet {this vari cl} {
    # Check if Get method should be generated
    #
    if {![$this hasGet 0]} {
        $vari access "Published"
    }
    if {![$this hasGet 1]} {
        return
    }

    # Generate
    #
    set type [[$this assocattr] generateManyAssocType]
    set getproc [DPFunction new $type]
    set getcode [TextSection new]
    $getproc gencode $getcode
    $getproc hasUserSection 0
    $getproc access [$this propRead]
    $getproc name "get[cap [$this varname]]"
    $getcode append "[$getproc name] := "
    $getcode append "[$this varset];\n"
    $cl setGenmethod [$getproc name] $getproc
}

method DPGAssocMany::generateRemove {this vari cl} {
    # Check if Remove method should be generated
    #
    if {![$this hasRemove 0]} {
        $vari access "Published"
    }
    if {![$this hasRemove 1]} {
        return
    }

    # Generated
    #
    set removeproc [DPProcedure new]
    set type [[[[$this assocattr] ooplType] ooplClass] generateTObjectType]
    set assoctype [[$this assocattr] generateAssocType $cl]
    set arg "old[$assoctype name]"
    set param [DPArgument new $type]
    $param name $arg
    $removeproc addArg $param

    set removecode [TextSection new]
    $removeproc gencode $removecode
    $removeproc hasUserSection 0
    $removeproc access [$this propWrite]
    $removeproc name "remove[cap [$this varname]]"

    $removecode append "if ([$vari name].IndexOf(${arg}) <> -1) then\nbegin\n"
    $removecode indent +
    $removecode append "[$vari name].Remove(${arg});\n"

    if {[[$this assocattr] opposite] != ""} {
        if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
            $removecode append "(${arg} as [$assoctype name]).remove[cap [$this opvarname]]("
            if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
                $removecode append "SELF"
            }
            $removecode append ");\n"
        } else {
            if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
                $removecode append "(${arg} as [$assoctype name]).[$this opvarset].Remove(SELF);\n"
            } else {
                $removecode append "(${arg} as [$assoctype name]).[$this opvarref] := NIL;\n"
            }
        }
    }
    $removecode indent -
    $removecode append "end;\n"

    $cl setGenmethod [$removeproc name] $removeproc
}

method DPGAssocMany::generateDtor {this vari cl} {

    # Check if Destructor should be generated
    #
    if {![$this hasDtor 1]} {
        [[$cl destructr] gencode] append "[$this varset].Destroy;\n"
        return
    }
    # Generate
    #

    if {[[$this assocattr] opposite] != ""} {
        if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
            set sysutilstype [DPType new]
            $sysutilstype includeName "SysUtils"
            $sysutilstype includeType "imp"
            $sysutilstype addAsInclude [[[[[$this assocattr] opposite] ooplType] ooplClass] target]
            [[$cl destructr] gencode] append "if ([$this varset].Count <> 0) then\n"
            [[$cl destructr] gencode] indent +
            [[$cl destructr] gencode] append "raise EInvalidOp.Create('Illegal object destruction. Mandatory relation "
            [[$cl destructr] gencode] append "[$this varset] not empty.');\n"
            [[$cl destructr] gencode] indent -
            [[$cl destructr] gencode] append "[$this varset].Destroy;\n"
            return
        }

        [[$cl destructr] gencode] append "while ([$this varset].Count > 0) do\nbegin\n"
        [[$cl destructr] gencode] indent +
        if {[$this hasRemove 1]} {
            [[$cl destructr] gencode] append "remove[cap [$this varname]]([$this varset].First)\n"
        } else {
            set old "old[[[[$this assocattr] ooplType] ooplClass] getName]"

            [[$cl destructr] gentypes] append "var\n"
            [[$cl destructr] gentypes] indent +
            [[$cl destructr] gentypes] append "${old}: [[$vari type] name];\n\n"
            [[$cl destructr] gentypes] indent -
            [[$cl destructr] gencode] append "${old} := [$this varset].First;\n"
            [[$cl destructr] gencode] append "[$this varset].Remove(${old});\n"
            if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
                [[$cl destructr] gencode] append "${old}.remove[cap [$this varname]];\n"
            } else {
                [[$cl destructr] gencode] append "${old}.[$this opvarname] := NIL;\n"
            }
        }

        [[$cl destructr] gencode] indent -
        [[$cl destructr] gencode] append "end;\n"
    }

    [[$cl destructr] gencode] append "[$this varset].Destroy;\n"
}

# Do not delete this line -- regeneration end marker


#      File:           @(#)dpgassocon.tcl    /main/hindenburg/15


Class DPGAssocOne : {DPGAssocGen} {
    constructor
    method destructor
    method hasSet
    method hasDtor
    method hasRemove
    method generate
    method generateSet
    method generateGet
    method generateRemove
    method generateDtor
}

constructor DPGAssocOne {class this assocattr} {
    set this [DPGAssocGen::constructor $class $this $assocattr]
    # Start constructor user section
    # End constructor user section
    return $this
}

method DPGAssocOne::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this DPGAssocGen::destructor
}

method DPGAssocOne::hasSet {this self} {
    set wr [$this propWrite]
    if {$self} {
        if {$wr == "None"} {
                return 0
        }
    } else {
        if {$wr == "None" || $wr == "Private" || $wr == "Protected"} {
                return 0
        }
    }
    if {[[$this assocattr] opposite] != ""} {
        if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
            return 0
        }
        if {[[[$this assocattr] opposite] isQualified]} {
            if {![$this setWarning]} {
                $this setWarning 1
                m4_warning $W_NOSET [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
            }
            return 0
        }
    }
    return 1
}

method DPGAssocOne::hasDtor {this self} {
    if {[[$this assocattr] opposite] != ""} {
       if {[[[$this assocattr] opposite] isQualified] && [[[$this assocattr] opposite] getMultiplicity] != "one"} {
           if {![$this dtorWarning]} {
            $this dtorWarning 1
              m4_warning $W_NODTOR [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
          }
          return 0
       }
    }
    return 1
}

method DPGAssocOne::hasRemove {this self} {
    set wr [$this propWrite]
    if {$self} {
            if {$wr == "None"} {
                    return 0
            }
    } else {
            if {$wr == "None" || $wr == "Private" || $wr == "Protected"} {
                    return 0
            }
    }
    if {[[$this assocattr] opposite] != ""} {
       if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
          return 0
       }
       if {[[[$this assocattr] opposite] isQualified]} {
               if {![$this removeWarning]} {
                $this removeWarning 1
              m4_warning $W_NOREMOVE [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
              }
          return 0
       }
    }
    if {[[$this assocattr] isMandatory]} {
       return 0
    }
    return 1
}

method DPGAssocOne::generate {this cl} {

    set type [[[[$this assocattr] ooplType] ooplClass] generateTObjectType]
    set vari [DPVariable new $type]
    $vari name [$this varref]
    $cl addAssocvar $vari
    $vari access "Private"

    if {[[$this assocattr] opposite] != ""} {
        [[$this assocattr] opposite] setGenerator
    }
    $this generateGet $vari $cl
    $this generateSet $vari $cl
    $this generateRemove $vari $cl
    $this generateDtor $vari $cl
}

method DPGAssocOne::generateSet {this vari cl} {

    # Check if Set method should be generated
    #
    if {![$this hasSet 0]} {
        $vari access "Published"
    }
    if {![$this hasSet 1]} {
        return
    }

    # Generate
    #
    set type [[[[$this assocattr] ooplType] ooplClass] generateTObjectType]
    set assoctype [[$this assocattr] generateAssocType $cl]
    set arg "new[$assoctype name]"
    set param [DPArgument new $type]
    $param name $arg
    set setproc [DPProcedure new]
    $setproc addArg $param
    set setcode [TextSection new]

    $setproc gencode $setcode
    $setproc hasUserSection 0
    $setproc access [$this propWrite]
    $setproc name "set[cap [$this varname]]"
    if {[[$this assocattr] opposite] != ""} {
        $setcode append "if (${arg} <> NIL) then\nbegin\n"
        $setcode indent +

        if {[[$this assocattr] isMandatory]} {
            if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
                # one-mtory
                #
                if {[[[[$this assocattr] opposite] generator] hasGet 0]} {
                    $setcode append "if ((${arg} as [$assoctype name]).get[cap [$this opvarname]] = NIL) then\nbegin\n"
                } else {
                    $setcode append "if ((${arg} as [$assoctype name]).[$this opvarref] = NIL) then\nbegin\n"
                }
                $setcode indent +
                $setcode append "([$vari name] as [$assoctype name]).[$this opvarref] := NIL;\n"
            } else {
                # many-mtory
                #
                $setcode append "if (${arg} <> [$vari name]) then\nbegin\n"
                $setcode indent +
                $setcode append "if ([$vari name] <> NIL) then\nbegin\n"
                $setcode indent +
                $setcode append "([$vari name] as [$assoctype name]).[$this opvarset].Remove(SELF);\n"
                $setcode indent -
                $setcode append "end;\n"
            }
        } else {

            # one/many - one
            #
            $setcode append "if (${arg} <> [$vari name]) then\nbegin\n"
            $setcode indent +
            $setcode append "if ([$vari name] <> NIL) then\nbegin\n"
            $setcode indent +
            if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
                $setcode append "([$vari name] as [$assoctype name]).remove[cap [$this opvarname]]"
                if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
                    $setcode append "(SELF)"
                }
            } else {
                if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
                    $setcode append "([$vari name] as [$assoctype name]).[$this opvarset].Remove(SELF)"
                } else {
                    $setcode append "([$vari name] as [$assoctype name]).[$this opvarref] := NIL"
                }
            }

            $setcode append ";\n"
            $setcode indent -
            $setcode append "end;\n"
        }

        $setcode append "[$vari name] := ${arg};\n"

        if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {

            # many - one/mtory
            #
            if {[[[[$this assocattr] opposite] generator] hasAdd 0]} {
                $setcode append "(${arg} as [$assoctype name]).add[cap [$this opvarname]](SELF);\n"
            } else {
                $setcode append "(${arg} as [$assoctype name]).[$this opvarset].Add(SELF);\n"
            }
        } else {
            # one - one/mtory
            #
            if {[[[[$this assocattr] opposite] generator] hasSet 0]} {
                $setcode append "(${arg} as [$assoctype name]).set[cap [$this opvarname]](SELF);\n"
            } else {
                $setcode append "(${arg} as [$assoctype name]).[$this opvarref] := SELF;\n"
            }
        }
        $setcode indent -
        $setcode append "end;\n"

        if {[$this hasRemove 1]} {
            # one/many - one
            #
            $setcode indent -
            $setcode append "end\nelse\nbegin\n"
            $setcode indent +
            $setcode append "remove[cap [$this varname]];\n"
        }
        $setcode indent -
        $setcode append "end;\n"

    } else {
        if {[[$this assocattr] isMandatory]} {
            $setcode append "if (${arg} <> NIL) then\nbegin\n"
            $setcode indent +
            $setcode append "[$this varref] := (${arg} as [$assoctype name]);\n"
            $setcode indent -
            $setcode append "end;\n"
        } else {
            $setcode append "[$this varref] := (${arg} as [$assoctype name]);\n"
        }
    }
    $cl setGenmethod [$setproc name] $setproc
}

method DPGAssocOne::generateGet {this vari cl} {
    # Check if Get method should be generated
    #
    if {![$this hasGet 0]} {
        $vari access "Published"
    }
    if {![$this hasGet 1]} {
        return
    }

    # Generate
    #
    set type [[[[$this assocattr] ooplType] ooplClass] generateTObjectType]
    set assoctype [[$this assocattr] generateAssocType $cl]
    set getproc [DPFunction new $type]
    set getcode [TextSection new]
    $getproc gencode $getcode
    $getproc hasUserSection 0
    $getproc access [$this propRead]
    $getproc name  "get[cap [$this varname]]"
    $getcode append "[$getproc name] := ([$vari name] as [$assoctype name]);\n"
    $cl setGenmethod [$getproc name] $getproc
}

method DPGAssocOne::generateRemove {this vari cl} {
    # Check if remove method should be generated
    #
    if {![$this hasRemove 0]} {
        $vari access "Published"
    }
    if {![$this hasRemove 1]} {
        return
    }

    # Generate
    #
    set removeproc [DPProcedure new]
    set removecode [TextSection new]
    set removetypes [TextSection new]

    set old "old[[[[$this assocattr] ooplType] ooplClass] getName]"
    $removeproc gencode $removecode
    $removeproc gentypes $removetypes
    $removeproc hasUserSection 0
    $removeproc access [$this propWrite]
    $removeproc name "remove[cap [$this varname]]"

    if {[[$this assocattr] opposite] != ""} {
        set assoctype [[$this assocattr] generateAssocType $cl]
        $removecode append "if ([$vari name] <> NIL) then\nbegin\n"
        $removecode indent +
        $removetypes append "var\n"
        $removetypes indent +
        $removetypes append "${old}: [[$vari type] name];\n\n"
        $removetypes indent -
        $removecode append "${old} := [$vari name];\n"
        $removecode append "[$vari name] := NIL;\n"

        if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {

            # Use remove method
            #
            $removecode append "(${old} as [$assoctype name]).remove[cap [$this opvarname]]("
            if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
                $removecode append "SELF"
            }
            $removecode append ");\n"
        } else {

            # Use direct access
            #
            if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
                $removecode append "(${old} as [$assoctype name]).[$this opvarname]].Remove(SELF);\n"
            } else {
                $removecode append "(${old} as [$assoctype name]).[$this opvarref] := NIL;\n"
            }
        }
        $removecode indent -
        $removecode append "end;\n"
    } else {
        $removecode append "[$vari name] := NIL;\n"
    }
    $cl setGenmethod [$removeproc name] $removeproc
}

method DPGAssocOne::generateDtor {this vari cl} {

    # Check if Destructor should be generated
    #
    if {![$this hasDtor 1]} {
        return
    }

    # Generate
    #
    if {[[$this assocattr] opposite] != ""} {
        set assoctype [[$this assocattr] generateAssocType $cl]
        if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
            set sysutilstype [DPType new]
            $sysutilstype includeName "SysUtils"
            $sysutilstype includeType "imp"
            $sysutilstype addAsInclude [[[[[$this assocattr] opposite] ooplType] ooplClass] target]
            [[$cl destructr] gencode] append "if ([$this varref] <> NIL) then\n"
            [[$cl destructr] gencode] indent +
            [[$cl destructr] gencode] append "raise EInvalidOp.Create('Illegal object destruction. Object [$this varname] "
            [[$cl destructr] gencode] append "with mandatory relation exists.');\n"
            [[$cl destructr] gencode] indent -
            return
        }
        if {[$this hasRemove 1]} {
            [[$cl destructr] gencode] append "remove[cap [$this varname]];\n"
        } else {
            if {![[[$this assocattr] opposite] isQualified]} {
                if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
                    if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
                        [[$cl destructr] gencode] append "[$this varref].remove[cap [$this opvarname]];\n"
                    } else {
                        [[$cl destructr] gencode] append "[$this varset].remove[cap [$this opvarname]](SELF);\n"
                    }
                } else {
                    if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
                        [[$cl destructr] gencode] append "([$this varref] as [$assoctype name]).[$this opvarref] := NIL;\n"
                    } else {
                        [[$cl destructr] gencode] append "([$this varref] as [$assoctype name]).[$this opvarset].Remove(SELF);\n"
                    }
                }
            }
        }
    }
}

# Do not delete this line -- regeneration end marker


#      File:           @(#)dpgqual.tcl    /main/hindenburg/1


Class DPGQual : {DPGAssocGen} {
    constructor
    method destructor
    method hasAdd
    method hasDtor
    method hasRemove
}

constructor DPGQual {class this assocattr} {
    set this [DPGAssocGen::constructor $class $this $assocattr]
    # Start constructor user section
    # End constructor user section
    return $this
}

method DPGQual::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this DPGAssocGen::destructor
}

method DPGQual::hasAdd {this self} {
    set wr [$this propWrite]
    if {$self} {
        if {$wr == "None"} {
            return 0
        }
    } else {
        if {$wr == "None" || $wr == "Private" || $wr == "Protected"} {
            return 0
        }
    }
    return 1
}

method DPGQual::hasDtor {this self} {
#    if {[[$this assocattr] opposite] != ""} {
#        if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
#            return 0
#        }
#    }
    return 1
}

method DPGQual::hasRemove {this self} {
    set wr [$this propWrite]
    if {$self} {
    } else {
        if {$wr == "None" || $wr == "Private" || $wr == "Protected"} {
            return 0
        }
    }
    if {[[$this assocattr] opposite] != ""} {
        if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
            return 0
        }
    }
    return 1
}

# Do not delete this line -- regeneration end marker


#      File:           @(#)dpgdataatt.tcl    /main/hindenburg/4


Class DPGDataAttr : {DPGAttribute} {
    constructor
    method destructor
    method generateInitialValue
    method generateAccessors
    method generate
}

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

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

method DPGDataAttr::generateInitialValue {this method} {
    if {[$this getInitialValue] == ""} {
        return
    }

    if {[$this isClassFeature]} {
        m4_warning $W_NODEFAULT [$this getName]
    } else {
        [$method gencode] append "[$this getName] := [$this getInitialValue];\n"
    }
}

method DPGDataAttr::generateAccessors {this class var name} {

    # acquire access settings

    set accessTxt [$this getPropertyValue "attrib_access"]
    set accessList [split $accessTxt -]
    set readAccess [lindex $accessList 0]
    if {$readAccess == ""} {
        set readAccess "Published"
    }
    set writeAccess [lindex $accessList 1]
    if {$writeAccess == ""} {
        set writeAccess "Published"
    }

    # create get function

    if {$readAccess != "None"} {
        set getname "get[cap $name]"
        set getmethod [DPFunction new [[$this ooplType] generate]]
        set getcode [TextSection new]

        $getmethod gencode $getcode
        $getmethod access $readAccess
        $getmethod name $getname

        $getcode append "[$getmethod name] := [$var name];\n"
        $class setGenmethod [$getmethod name] $getmethod
    }

    #create set procedure

    if {$writeAccess != "None"} {
        set setname "set[cap $name]"
        set setmethod [DPProcedure new]
        set setcode [TextSection new]
        $setmethod gencode $setcode
        $setmethod access $writeAccess
        $setmethod name $setname

        set arg [DPArgument new [[$this ooplType] generate]]
        $arg name "new[cap $name]"
        $setmethod addArg $arg

        $setcode append "[$var name] := [$arg name];\n"
        $class setGenmethod [$setmethod name] $setmethod
    }
}

method DPGDataAttr::generate {this class} {

    if {[[$this ooplType] getName] == "enum"} {
        m4_error $E_NOENUM [$class name] [$this getName]
    }
    if {[$this getName] == "_"} {
        m4_error $E_CANTCONTTYPEDEF [$class name]
    }

    set variable [DPVariable new [[$this ooplType] generate]]
    $variable isClassFeature [$this isClassFeature]

    set comment [DPComment new]
    $variable comment $comment
    $comment comment [$this getPropertyValue "freeText"]

    if {[$this isClassFeature]} {
        $variable name "[$class name]_[$this getName]"
        $variable access "Published"
        $class addGlobvar $variable
    } else {
        $variable name [$this getName]
        $variable access "Private"
        $class addUservar $variable
    }
    $this generateAccessors $class $variable [$this getName]
}

# Do not delete this line -- regeneration end marker

Class DPGDataAttrD : {DPGDataAttr OPDataAttr} {
}

selfPromoter OPDataAttr {this} {
    DPGDataAttrD promote $this
}

#      File:           @(#)dpggenasso.tcl    /main/hindenburg/7


Class DPGGenAssocAttr : {DPGAttribute} {
    constructor
    method destructor
    method getName
    method hasGUIComponent
    method generateAssocType
    method generateQualAssocType
    method generateManyAssocType
    method generateComponent
    method generator
    attribute _generator
}

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

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

method DPGGenAssocAttr::getName {this} {
    if {[$this isLinkAttr]} {
        if {[$this opposite] != ""} {
            return "[uncap [[[$this opposite] ooplClass] getName]]of[$this OPGenAssocAttr::getName]"
        }
    }
    return [$this OPGenAssocAttr::getName]
}

method DPGGenAssocAttr::hasGUIComponent {this} {
    if {![$this isAggregate]} {
        return 0
    }
    set baseType [[[$this ooplType] ooplClass] baseType]
    if {$baseType == "TComponent"} {
        return 1
    } else {
        return 0
    }
}

method DPGGenAssocAttr::generateAssocType {this unit} {
    set type [[[$this ooplType] ooplClass] generateType]
    $type includeType "imp"
    $type addAsInclude $unit
    return $type
}

method DPGGenAssocAttr::generateQualAssocType {this} {
    set type [DPType new]
    $type name "TClassDict"
    $type includeType "system"
    $type includeName "ClassDict"
    return $type
}

method DPGGenAssocAttr::generateManyAssocType {this} {
    set type [DPType new]
    $type name "TList"
    $type includeType "system"
    $type includeName "Classes"
    return $type
}

method DPGGenAssocAttr::generateComponent {this class control} {
    # Check if associated object is a GUI object
#    if {![$this hasGUIComponent]} {
#        m4_error $E_ONLYCONTGUI [[$this ooplClass] getName] [[[$this ooplType] ooplClass] getName]
#        return
#    }

    [[$this ooplType] ooplClass] generateComponent [$this getName] $class $control
}

# Do not delete this line -- regeneration end marker

Class DPGGenAssocAttrD : {DPGGenAssocAttr OPGenAssocAttr} {
}

selfPromoter OPGenAssocAttr {this} {
    DPGGenAssocAttrD promote $this
}
method DPGGenAssocAttr::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:           @(#)dpgmanyqua.tcl    /main/hindenburg/13


Class DPGManyQual : {DPGQual} {
    constructor
    method destructor
    method generate
    method generateAdd
    method generateGet
    method generateRemove
    method generateDtor
}

constructor DPGManyQual {class this assocattr} {
    set this [DPGQual::constructor $class $this $assocattr]
    # Start constructor user section
    # End constructor user section
    return $this
}

method DPGManyQual::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this DPGQual::destructor
}

method DPGManyQual::generate {this cl} {
    set type [[$this assocattr] generateQualAssocType]
    set vari [DPVariable new $type]
    $vari name "[$this vardict]"
    $cl addAssocvar $vari
    $vari access "Private"
    if {[$cl constructr] != ""} {
        [[$cl constructr] gencode] append "[$vari name] := TClassDict.Create;\n"
    }
    if {[[$this assocattr] opposite] != ""} {
        [[$this assocattr] opposite] setGenerator
    }
    $this generateGet $vari $cl
    $this generateAdd $vari $cl
    $this generateRemove $vari $cl
    $this generateDtor $vari $cl
}

method DPGManyQual::generateAdd {this vari cl} {

    # Check if Add method should be generated
    #
    if {![$this hasAdd 0]} {
        $vari access "Published"
    }
    if {![$this hasAdd 1]} {
        return
    }

    # Generate
    #
    set type [[[[$this assocattr] ooplType] ooplClass] generateTObjectType]
    set assoctype [[$this assocattr] generateAssocType $cl]
    set param [DPArgument new $type]
    set arg "new[$assoctype name]"
    $param name "${arg}"
    set addproc [DPProcedure new]
    set type [DPType new]
    $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
    $type includeType "none"
    set keyparam [DPArgument new $type]
    $keyparam name [$this varqual]
    $addproc addArg $keyparam
    $addproc addArg $param
    set addcode [TextSection new]
    set addtypes [TextSection new]

    $addproc gencode $addcode
    $addproc gentypes $addtypes
    $addproc hasUserSection 0
    $addproc access [$this propWrite]
    $addproc name "add[cap [$this varname]]"

    set tempset "temp[$this varset]"
    $addtypes append "var\n"
    $addtypes indent +
    $addtypes append "${tempset}: TList;\n"
    $addtypes indent -

    if {[[$this assocattr] opposite] != ""} {
        if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
            $addcode append "(${arg} as [$assoctype name]).[$this opvarset].Add(SELF);\n"
        } else {
            $addcode append "(${arg} as [$assoctype name]).[$this opvarref] := SELF;\n"
        }
    }
    $addcode append "if ([$vari name].Item([$this varqual]) <> NIL) then\nbegin\n"
    $addcode indent +
    $addcode append "${tempset} := [$vari name].Item([$this varqual]);\n"
    $addcode indent -
    $addcode append "end\n"
    $addcode append "else\n"
    $addcode append "begin\n"
    $addcode indent +
    $addcode append "${tempset} := TList.Create;\n"
    $addcode append "[$vari name].Add([$this varqual], ${tempset})\n"
    $addcode indent -
    $addcode append "end;\n"
    $addcode append "${tempset}.Add(${arg});\n"

    $cl setGenmethod [$addproc name] $addproc
}

method DPGManyQual::generateGet {this vari cl} {
    # Check if Get method should be generated
    #
    if {![$this hasGet 0]} {
        $vari access "Published"
    }
    if {![$this hasGet 1]} {
        return
    }

    # Generate
    #
    set type [[$this assocattr] generateManyAssocType]
    set getproc [DPFunction new $type]
    set getcode [TextSection new]
    $getproc gencode $getcode
    $getproc hasUserSection 0
    $getproc access [$this propRead]
    $getproc name "get[cap [$this varname]]"
    $getcode append "[$getproc name] := [$this vardict].Item([$this varqual]);\n"

    set type [DPType new]
    $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
    $type includeType "none"
    set arg [DPArgument new $type]
    $arg name [$this varqual]
    $getproc addArg $arg
    $cl setGenmethod [$getproc name] $getproc
}

method DPGManyQual::generateRemove {this vari cl} {
    # Check if method should be generated
    #
    if {![$this hasRemove 0]} {
        $vari access "Published"
    }
    if {![$this hasRemove 1]} {
        return
    }

    # Generate
    #
    set removeproc [DPProcedure new]
    set type [DPType new]
    $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
    $type includeType "none"
    set param [DPArgument new $type]
    $param name [$this varqual]
    $removeproc addArg $param
    set type [[[[$this assocattr] ooplType] ooplClass] generateTObjectType]
    set assoctype [[$this assocattr] generateAssocType $cl]
    set arg "old[$assoctype name]"
    set param [DPArgument new $type]
    $param name $arg

    $removeproc addArg $param
    set removecode [TextSection new]
    set removetypes [TextSection new]
    set tempset "temp[$this varset]"
    $removeproc gencode $removecode
    $removeproc gentypes $removetypes
    $removeproc hasUserSection 0
    $removeproc name "remove[cap [[$this assocattr] getName]]"

    if {[$this propWrite] == "None"} {
        $removeproc access "Private"
        m4_warning $W_CHANGEDREM [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
    } else {
        $removeproc access [$this propWrite]
    }

    $removetypes append "var\n"
    $removetypes indent +
    $removetypes append "${tempset}: TList;\n"
    $removetypes indent -
    $removecode append "${tempset} := [$vari name].Item([$this varqual]);\n"

    $removecode append "if ${tempset} <> NIL then\nbegin\n"
    $removecode indent +

    if {[[$this assocattr] opposite] != ""} {
        if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
            $removecode append "(${arg} as [$assoctype name]).[$this opvarref] := NIL;\n"
        } else {
            $removecode append "(${arg} as [$assoctype name]).[$this opvarset].Remove(SELF);\n"
        }
    }

    $removecode append "${tempset}.Remove(${arg});\n"

    if {![[$this assocattr] isMandatory]} {
       $removecode append "if (${tempset}.Count = 0) then\nbegin\n"
       $removecode indent +
       $removecode append "[$vari name].RemoveUsingKey([$this varqual]);\n"
       $removecode indent -
       $removecode append "end;\n"
    }

    $removecode indent -
    $removecode append "end;\n"
    $cl setGenmethod [$removeproc name] $removeproc
}

method DPGManyQual::generateDtor {this vari cl} {

    # Check if Destructor should be generated
    #
    if {![$this hasDtor 1]} {
        [[$cl destructr] gencode] append "[$this vardict].Destroy;\n"
        return
    }

    # Generate
    #
    if {[[$this assocattr] opposite] != ""} {
        if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
            set sysutilstype [DPType new]
            $sysutilstype includeName "SysUtils"
            $sysutilstype includeType "imp"
            $sysutilstype addAsInclude [[[[[$this assocattr] opposite] ooplType] ooplClass] target]

            [[$cl destructr] gencode] append "if ([$this vardict].Count <> 0) then\n"
            [[$cl destructr] gencode] indent +
            [[$cl destructr] gencode] append "raise EInvalidOp.Create('Illegal object destruction. Mandatory relation "
            [[$cl destructr] gencode] append "[[$this assocattr] getName]Set not empty.');\n"
            [[$cl destructr] gencode] indent -
        } else {
            set assoctype [[$this assocattr] generateAssocType $cl]
            [[$cl destructr] gentypes] append "var\n"
            [[$cl destructr] gentypes] indent +
            [[$cl destructr] gentypes] append "tmp[$this varset]: TList;\n"
            [[$cl destructr] gentypes] append "tmp[$this varname]: [$assoctype name];\n"
            [[$cl destructr] gentypes] indent -
            [[$cl destructr] gencode] append "while ([$this vardict].Count <> 0) do\nbegin\n"
            [[$cl destructr] gencode] indent +
            [[$cl destructr] gencode] append "tmp[$this varset] := [$this vardict].First;\n"
            [[$cl destructr] gencode] append "while (tmp[$this varset].Count > 0) do\nbegin\n"
            [[$cl destructr] gencode] indent +
            [[$cl destructr] gencode] append "tmp[$this varname] := tmp[$this varset].First;\n"

            if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
                [[$cl destructr] gencode] append "tmp[$this varname].[$this opvarset].Remove(SELF);\n"
            } else {
                [[$cl destructr] gencode] append "tmp[$this varname].[$this opvarref] := NIL;\n"
            }
            [[$cl destructr] gencode] append "tmp[$this varset].Remove(tmp[$this varname]);\n"
            [[$cl destructr] gencode] indent -
            [[$cl destructr] gencode] append "end;\n"
            [[$cl destructr] gencode] append "[$this vardict].Remove(tmp[$this varset]);\n"
            [[$cl destructr] gencode] indent -
            [[$cl destructr] gencode] append "end;\n"
        }
    }

    [[$cl destructr] gencode] append "[$this vardict].Destroy;\n"
}

# Do not delete this line -- regeneration end marker


#      File:           @(#)dpgonequal.tcl    /main/hindenburg/14


Class DPGOneQual : {DPGQual} {
    constructor
    method destructor
    method generate
    method generateSet
    method generateGet
    method generateRemove
    method generateDtor
}

constructor DPGOneQual {class this assocattr} {
    set this [DPGQual::constructor $class $this $assocattr]
    # Start constructor user section
    # End constructor user section
    return $this
}

method DPGOneQual::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this DPGQual::destructor
}

method DPGOneQual::generate {this cl} {
    set type [[$this assocattr] generateQualAssocType]
    set vari [DPVariable new $type]
    $vari name "[$this vardict]"
    $cl addAssocvar $vari
    $vari access "Private"
    if {[$cl constructr] != ""} {
        [[$cl constructr] gencode] append "[$vari name] := TClassDict.Create;\n"
    }
    if {[[$this assocattr] opposite] != ""} {
        [[$this assocattr] opposite] setGenerator
    }
    $this generateGet $vari $cl
    $this generateSet $vari $cl
    $this generateRemove $vari $cl
    $this generateDtor $vari $cl
}

method DPGOneQual::generateSet {this vari cl} {
    # Check if Set method should be generated
    #
    if {![$this hasAdd 0]} {
        $vari access "Published"
    }
    if {![$this hasAdd 1]} {
        return
    }

    # Generate
    #
    set type [[[[$this assocattr] ooplType] ooplClass] generateTObjectType]
    set assoctype [[$this assocattr] generateAssocType $cl]
    set param [DPArgument new $type]
    set arg "new[$assoctype name]"
    $param name $arg
    set addproc [DPProcedure new]

    set type [DPType new]
    $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
    $type includeType "none"
    set keyparam [DPArgument new $type]
    $keyparam name  [$this varqual]
    $addproc addArg $keyparam
    $addproc addArg $param
    set addcode [TextSection new]
    set addtypes [TextSection new]
    set vartemp "old[$assoctype name]"

    $addproc gencode $addcode
    $addproc gentypes $addtypes
    $addproc hasUserSection 0
    $addproc access [$this propWrite]
    $addproc name "set[cap [$this varname]]"

    $addtypes append "var\n"
    $addtypes indent +
    $addtypes append "${vartemp}: [$assoctype name];\n"
    $addtypes indent -

    $addcode append "if (${arg} <> NIL) then\nbegin\n"
    $addcode indent +

    if {[[$this assocattr] opposite] != ""} {
        $addcode append "${vartemp} := [$vari name].Item([$keyparam name]);\n"
        $addcode append "if (${vartemp} <> NIL) then\nbegin\n"
        $addcode indent +
        if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
            $addcode append "(${vartemp} as [$assoctype name]).[$this opvarset].Remove(SELF);\n"
        } else {
            $addcode append "(${vartemp} as [$assoctype name]).[$this opvarref] := NIL;\n"
        }
        $addcode append "[$vari name].RemoveUsingKey([$keyparam name]);\n"
        $addcode indent -
        $addcode append "end;\n"

        if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
            $addcode append "(${arg} as [$assoctype name]).[$this opvarset].Add(SELF);\n"
        } else {
            $addcode append "(${arg} as [$assoctype name]).[$this opvarref] := SELF;\n"
        }
    }

    $addcode append "[$vari name].Add([$keyparam name], ${arg});\n"
    $addcode indent -
    $addcode append "end;\n"

    $cl setGenmethod [$addproc name] $addproc
}

method DPGOneQual::generateGet {this vari cl} {

    # Check if Get method should be generated
    #
    if {![$this hasGet 0]} {
        $vari access "Published"
    }
    if {![$this hasGet 1]} {
        return
    }

    # Generate
    #
    set type [[[[$this assocattr] ooplType] ooplClass] generateTObjectType]
    set getproc [DPFunction new $type]
    set getcode [TextSection new]
    $getproc gencode $getcode
    $getproc hasUserSection 0
    $getproc access [$this propRead]
    $getproc name "get[cap [$this varname]]"
    $getcode append "[$getproc name] := [$this vardict].Item([$this varqual]);\n"

    set type [DPType new]
    $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
    $type includeType "none"
    set param [DPArgument new $type]
    $param name [$this varqual]
    $getproc addArg $param
    $cl setGenmethod [$getproc name] $getproc
}

method DPGOneQual::generateRemove {this vari cl} {
    if {![$this hasRemove 0]} {
        $vari access "Published"
    }
    if {![$this hasRemove 1]} {
        return
    }

    set removeproc [DPProcedure new]
    set type [DPType new]
    $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
    $type includeType "none"
    set param [DPArgument new $type]
    $param name [$this varqual]
    $removeproc addArg $param
    set removecode [TextSection new]
    set removetypes [TextSection new]
    $removeproc gencode $removecode
    $removeproc gentypes $removetypes
    $removeproc hasUserSection 0
    $removeproc name "remove[cap [$this varname]]"
    set assoctype [[$this assocattr] generateAssocType $cl]
    set vartemp "old[$assoctype name]"

    if {[$this propWrite] == "None"} {
        $removeproc access "Private"
        m4_warning $W_CHANGEDREM [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
    } else {
        $removeproc access [$this propWrite]
    }

    if {[[$this assocattr] opposite] != ""} {
        $removetypes append "var\n"
        $removetypes indent +
        $removetypes append "${vartemp}: [$assoctype name];\n"
        $removetypes indent -
        $removecode append "${vartemp} := [$vari name].Item([$this varqual]);\n"
        $removecode append "if (${vartemp} <> NIL) then\nbegin\n"
        $removecode indent +

        if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] != "one"} {
           $removecode append "if (${vartemp}.[$this opvarset].Count > 1) then\nbegin\n"
           $removecode indent +
        }
        $removecode append "[$vari name].RemoveUsingKey([$this varqual]);\n"
        if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
            $removecode append "${vartemp}.[$this opvarset].Remove(SELF);\n"
        } else {
            $removecode append "${vartemp}.[$this opvarref] := NIL;\n"
        }
        if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] != "one"} {
           $removecode indent -
           $removecode append "end;\n"
        }

       $removecode indent -
       $removecode append "end;\n"
    } else {
        $removecode append "[$vari name].RemoveUsingKey([$this varqual])\n"
    }

    $cl setGenmethod [$removeproc name] $removeproc
}

method DPGOneQual::generateDtor {this vari cl} {

    # Check if Destructor should be generated
    #
    if {![$this hasDtor 1]} {
        [[$cl destructr] gencode] append "[$this vardict].Destroy;\n"
        return
    }

    # Generate
    #
    if {[[$this assocattr] opposite] != ""} {
        if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
            set sysutilstype [DPType new]
            $sysutilstype includeName "SysUtils"
            $sysutilstype includeType "imp"
            $sysutilstype addAsInclude [[[[[$this assocattr] opposite] ooplType] ooplClass] target]

            [[$cl destructr] gencode] append "if ([$this vardict].Count <> 0) then\n"
            [[$cl destructr] gencode] indent +
            [[$cl destructr] gencode] append "raise EInvalidOp.Create('Illegal object destruction. Mandatory relation "
            [[$cl destructr] gencode] append "[$this vardict] not empty.');\n"
            [[$cl destructr] gencode] indent -
        } else {
            [[$cl destructr] gencode] append "while ([$this vardict].Count > 0) do\nbegin\n"
            [[$cl destructr] gencode] indent +
            [[$cl destructr] gencode] append "remove[cap [$this varname]]([$this vardict].FirstKey)\n"
            [[$cl destructr] gencode] indent -
            [[$cl destructr] gencode] append "end;\n"
        }
    }
    [[$cl destructr] gencode] append "[$this vardict].Destroy;\n"
}

# Do not delete this line -- regeneration end marker


#      File:           @(#)dpgassocat.tcl    /main/hindenburg/4


Class DPGAssocAttr : {DPGGenAssocAttr} {
    constructor
    method destructor
    method setGenerator
    method generate
}

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

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

method DPGAssocAttr::setGenerator {this} {
   if {[$this generator] == ""} {
        if {[$this getMultiplicity] == "one"} {
            $this generator [DPGAssocOne new $this]
        } else {
            $this generator [DPGAssocMany new $this]
        }
    }
}

method DPGAssocAttr::generate {this class} {
    if {[$this hasGUIComponent]} {
        return
    }
    $this setGenerator
    [$this generator] generate $class
}

# Do not delete this line -- regeneration end marker

Class DPGAssocAttrD : {DPGAssocAttr OPAssocAttr} {
}

selfPromoter OPAssocAttr {this} {
    DPGAssocAttrD promote $this
}

#      File:           @(#)dpglinkatt.tcl    /main/hindenburg/4


Class DPGLinkAttr : {DPGGenAssocAttr} {
    constructor
    method destructor
    method setGenerator
    method generate
}

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

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

method DPGLinkAttr::setGenerator {this} {
    if {[$this generator] == ""} {
        if {[$this getMultiplicity] == "one"} {
            $this generator [DPGAssocOne new $this]
        } else {
            $this generator [DPGAssocMany new $this]
        }
    }
}

method DPGLinkAttr::generate {this class} {
    if {[$this hasGUIComponent]} {
        return
    }

    if {[[$this ooplType] isA OPBaseType]} {
        m4_warning $W_ASSOCTYPEERR [$this getName] [[$this ooplType] getName]
        return
    }

    $this setGenerator
    [$this generator] generate $class
}

# Do not delete this line -- regeneration end marker

Class DPGLinkAttrD : {DPGLinkAttr OPLinkAttr} {
}

selfPromoter OPLinkAttr {this} {
    DPGLinkAttrD promote $this
}

#      File:           @(#)dpgqualatt.tcl    /main/hindenburg/5


Class DPGQualAttr : {DPGGenAssocAttr} {
    constructor
    method destructor
    method setGenerator
    method generate
}

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

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

method DPGQualAttr::setGenerator {this} {
    if {[$this generator] == ""} {
        if {[$this getMultiplicity] == "one"} {
            $this generator [DPGOneQual new $this]
        } else {
            $this generator [DPGManyQual new $this]
        }
    }
}

method DPGQualAttr::generate {this class} {
    if {[$this hasGUIComponent]} {
        return
    }

    if {![[[$this qualifier] ooplType] isA OPBaseType]} {
        m4_error $E_QUALTYPEWRONG [[$this qualifier] getName] [$this getName]
        return
    }

    $this setGenerator
    [$this generator] generate $class
}

# Do not delete this line -- regeneration end marker

Class DPGQualAttrD : {DPGQualAttr OPQualAttr} {
}

selfPromoter OPQualAttr {this} {
    DPGQualAttrD promote $this
}

#      File:           @(#)dpgreverse.tcl    /main/hindenburg/4


Class DPGReverseLinkAttr : {DPGGenAssocAttr} {
    constructor
    method destructor
    method setGenerator
    method generate
}

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

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

method DPGReverseLinkAttr::setGenerator {this} {
    if {[$this generator] == ""} {
        if {[$this getMultiplicity] == "one"} {
            $this generator [DPGAssocOne new $this]
        } else {
            $this generator [DPGAssocMany new $this]
        }
    }
}

method DPGReverseLinkAttr::generate {this class} {
    if {[$this hasGUIComponent]} {
        return
    }

    if {[[$this ooplType] isA OPBaseType]} {
        m4_warning $W_ASSOCTYPEERR [$this getName] [[$this ooplType] getName]
        return
    }

    $this setGenerator
    [$this generator] generate $class
}

# Do not delete this line -- regeneration end marker

Class DPGReverseLinkAttrD : {DPGReverseLinkAttr OPReverseLinkAttr} {
}

selfPromoter OPReverseLinkAttr {this} {
    DPGReverseLinkAttrD promote $this
}

#      File:           @(#)dpgqualass.tcl    /main/hindenburg/3


Class DPGQualAssocAttr : {DPGQualAttr} {
    constructor
    method destructor
}

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

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

# Do not delete this line -- regeneration end marker

Class DPGQualAssocAttrD : {DPGQualAssocAttr OPQualAssocAttr} {
}

selfPromoter OPQualAssocAttr {this} {
    DPGQualAssocAttrD promote $this
}

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


Class DPGQualLinkAttr : {DPGQualAttr} {
    constructor
    method destructor
}

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

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

# Do not delete this line -- regeneration end marker

Class DPGQualLinkAttrD : {DPGQualLinkAttr OPQualLinkAttr} {
}

selfPromoter OPQualLinkAttr {this} {
    DPGQualLinkAttrD promote $this
}