home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / forteoopl.tcl < prev    next >
Encoding:
Text File  |  1997-04-18  |  60.6 KB  |  2,400 lines
  1. #--------------------------------------------------------------------------
  2. #
  3. #      (c)     Cayenne Software Inc.    1997
  4. #
  5. #      File:           %W%
  6. #      Author:         <generated>
  7. #
  8. #--------------------------------------------------------------------------
  9.  
  10. #      File:           @(#)ftgfeature.tcl    /main/hindenburg/2
  11.  
  12.  
  13. Class FTGFeature : {Object} {
  14.     constructor
  15.     method destructor
  16.     method generate
  17. }
  18.  
  19. constructor FTGFeature {class this name} {
  20.     set this [Object::constructor $class $this $name]
  21.     # Start constructor user section
  22.     # End constructor user section
  23.     return $this
  24. }
  25.  
  26. method FTGFeature::destructor {this} {
  27.     # Start destructor user section
  28.     # End destructor user section
  29. }
  30.  
  31. method FTGFeature::generate {this class} {
  32.     # empty
  33. }
  34.  
  35. # Do not delete this line -- regeneration end marker
  36.  
  37. Class FTGFeatureD : {FTGFeature OPFeature} {
  38. }
  39.  
  40. selfPromoter OPFeature {this} {
  41.     FTGFeatureD promote $this
  42. }
  43.  
  44. #      File:           @(#)ftggenclas.tcl    /main/hindenburg/8
  45.  
  46.  
  47. Class FTGGenClass : {Object} {
  48.     constructor
  49.     method destructor
  50.     method generate
  51.     method genClass
  52.     method genServiceObject
  53.     method genConstant
  54.     method genCursor
  55.     method genStruct
  56.     method genUnion
  57.     method genComposite
  58.     method isExternal
  59.     method getClassType
  60.     method getDefSysName
  61.     method getSuperNames
  62.     method isDerivable
  63.     method getFinalClass
  64.     method getKind
  65.     attribute classType
  66.     attribute superNames
  67.     attribute loopGuard
  68. }
  69.  
  70. constructor FTGGenClass {class this name} {
  71.     set this [Object::constructor $class $this $name]
  72.     $this loopGuard -1
  73.     # Start constructor user section
  74.     # End constructor user section
  75.     return $this
  76. }
  77.  
  78. method FTGGenClass::destructor {this} {
  79.     # Start destructor user section
  80.     # End destructor user section
  81. }
  82.  
  83. method FTGGenClass::generate {this model} {
  84.     set classType [$this getClassType]
  85.     m4_message $M_GEN_FOR $classType [$this getName]
  86.     $this gen$classType $model
  87. }
  88.  
  89. method FTGGenClass::genClass {this model} {
  90.     set name [$this getName]
  91.  
  92.     # super class (may be "")
  93.     #
  94.     set genNodes [$this genNodeSet]
  95.     set superIsClass 1
  96.     if {[llength $genNodes] == 0} {
  97.     m4_warning $W_CLASS_NO_SUPER $name
  98.     set superClass ""
  99.     } else {
  100.     set superClass [[lindex $genNodes 0] superClass]
  101.     if {[llength $genNodes] > 1} {
  102.         m4_warning $W_N_SUPERS $name [$superClass getDefSysName] [$superClass getName]
  103.     }
  104.     if {![$superClass isDerivable]} {
  105.         m4_error $E_ILL_SUPER $name [$superClass getKind] [$superClass getDefSysName] [$superClass getName]
  106.         return
  107.     }
  108.     if {!([$superClass isA FTGClass] || [$superClass isA FTGLinkClass])} {
  109.         set superIsClass 0
  110.     }
  111.     }
  112.  
  113.     # kind, i.e. Cmn, Win, or Dom
  114.     #
  115.     set superNames [List new]
  116.     $superNames contents [$this getSuperNames]
  117.     if {[$superNames search -exact "UserWindow"] != -1} {
  118.     set kind Win
  119.     } elseif {[$superNames search -glob "*Nullable"] != -1} {
  120.     set kind Dom
  121.     } elseif {[$superNames search -exact "Object"] != -1} {
  122.     set kind Cmn
  123.     } else {
  124.     # not derived from 'Object'
  125.     # return
  126.     set kind Cmn
  127.     }
  128.  
  129.     # target class
  130.     #
  131.     set class [$model findDefinition $name]
  132.     if {$class == ""} {
  133.     # note: a generic typedef class has no defining system
  134.     set class [FT${kind}Class new $name $model [$this getDefSysName] 0]
  135.     $class ooplClass $this
  136.     }
  137.     set tgtSuperType [FTType new]
  138.     if {$superClass == ""} {
  139.     set tgtSuperClass [FTCmnClass new "Object" $model "Framework" 1]
  140.     } else {
  141.     set tgtSuperClass [FTCmnClass new [$superClass getName] $model [$superClass getDefSysName] 1]
  142.     }
  143.     if {$kind == "Win"} {
  144.     $tgtSuperClass isMapped 1
  145.     }
  146.     $tgtSuperType classType $tgtSuperClass
  147.     $tgtSuperType isClass $superIsClass
  148.     $class super $tgtSuperType
  149.  
  150.     # Init, Display methods
  151.     #
  152.     $class constructor [FTInit new "" "" "" $class]
  153.     if {$kind == "Win"} {
  154.     FTDisplay new "" "" "" $class
  155.     }
  156.  
  157.     # features
  158.     #
  159.     foreach feat [$this featureSet] {
  160.     $feat generate $class
  161.     }
  162. }
  163.  
  164. method FTGGenClass::genServiceObject {this model} {
  165.     set name [$this getName]
  166.     set class [$model findDefinition $name]
  167.     if {$class == ""} {
  168.     if {[llength [$this operationSet]] == 0} {
  169.         m4_error $E_SERVICE_OBJ1 $name
  170.         return
  171.     } elseif {[llength [$this operationSet]] > 1 || [llength [$this attributeSet]] != 0} {
  172.         m4_warning $W_SERVICE_OBJ2 $name
  173.     }
  174.     set oper [lindex [$this operationSet] 0]
  175.     set class [FTServiceObject new $name $model [$this getDefSysName] 0]
  176.     $class ooplClass $this
  177.     $oper generate $class Service
  178.     }
  179. }
  180.  
  181. method FTGGenClass::genConstant {this model} {
  182.     set name [$this getName]
  183.     set class [$model findDefinition $name]
  184.     if {$class == ""} {
  185.     if {[llength [$this attributeSet]] == 0} {
  186.         m4_error $E_CONSTANT1 $name
  187.         return
  188.     } elseif {[llength [$this attributeSet]] > 1 || [llength [$this operationSet]] != 0} {
  189.         m4_warning $W_CONSTANT2 $name
  190.     }
  191.     set attr [lindex [$this attributeSet] 0]
  192.     set value [string trim [$attr getPropertyValue initial_value]]
  193.     if {$value == ""} {
  194.         m4_error $E_CONSTANT3 $name
  195.         return
  196.     }
  197.     set class [FTConstant new $name $model [$this getDefSysName] 0 $value]
  198.     $class ooplClass $this
  199.     }
  200. }
  201.  
  202. method FTGGenClass::genCursor {this model} {
  203.     set name [$this getName]
  204.     set class [$model findDefinition $name]
  205.     if {$class == ""} {
  206.     if {[llength [$this operationSet]] == 0} {
  207.         m4_error $E_CURSOR1 $name
  208.         return
  209.     } elseif {[llength [$this operationSet]] > 1 || [llength [$this attributeSet]] != 0} {
  210.         m4_warning $W_CURSOR2 $name
  211.     }
  212.     set oper [lindex [$this operationSet] 0]
  213.     set class [FTCursor new $name $model [$this getDefSysName] 0]
  214.     $class ooplClass $this
  215.     $oper generate $class CursorDef
  216.     }
  217. }
  218.  
  219. method FTGGenClass::genStruct {this model} {
  220.     $this genComposite Struct $model
  221. }
  222.  
  223. method FTGGenClass::genUnion {this model} {
  224.     $this genComposite Union $model
  225. }
  226.  
  227. method FTGGenClass::genComposite {this kind model} {
  228.     set name [$this getName]
  229.     set class [$model findDefinition $name]
  230.     if {$class == ""} {
  231.     set class [FT$kind new $name $model [$this getDefSysName] 0]
  232.     $class ooplClass $this
  233.     foreach attrib [$this dataAttrSet] {
  234.         FTCompItem new [$attrib getName] [[$attrib ooplType] getType $model] $class
  235.     }
  236.     }
  237. }
  238.  
  239. method FTGGenClass::isExternal {this} {
  240.     if {[$this OPClass::isExternal]} {
  241.     return 1
  242.     }
  243.     return 0
  244. }
  245.  
  246. method FTGGenClass::getClassType {this} {
  247.     if {[$this classType] != ""} {
  248.     return [$this classType]
  249.     }
  250.  
  251.     set classType [$this getPropertyValue class_type]
  252.     # IMPR: FTGGenClass::getClassType: default prop
  253.     if {$classType == ""} {
  254.     set classType Class
  255.     }
  256.     regsub -all " " $classType "" classType
  257.     $this classType $classType
  258.     return [$this classType]
  259. }
  260.  
  261. method FTGGenClass::getDefSysName {this} {
  262.     set systemV [[$this smNode] getDefiningSystemVersion]
  263.     if {![$systemV isNil]} {
  264.     return [[$systemV system] name]
  265.     }
  266.     return ""
  267. }
  268.  
  269. method FTGGenClass::getSuperNames {this} {
  270.     if {[$this loopGuard] == 0} {
  271.     # superNames of this class have been retrieved yet
  272.     return [$this superNames]
  273.     }
  274.     if {[$this loopGuard] == 1} {
  275.     # inheritance loop
  276.     return {}
  277.     }
  278.     $this loopGuard 1
  279.  
  280.     set superNames {}
  281.     foreach gen [$this genNodeSet] {
  282.     set superClass [$gen superClass]
  283.     set finalClass [$superClass getFinalClass]
  284.     if {$finalClass != ""} {
  285.         set superClass $finalClass
  286.     }
  287.     lappend superNames [$superClass getName]
  288.     set newNames [$superClass getSuperNames]
  289.     if {$newNames != {}} {
  290.         eval "lappend superNames $newNames"
  291.     }
  292.     # no multiple inheritance supported
  293.     # (classes in Framework library are!)
  294.     break
  295.     }
  296.     $this superNames $superNames
  297.  
  298.     $this loopGuard 0
  299.     return [$this superNames]
  300. }
  301.  
  302. method FTGGenClass::isDerivable {this} {
  303.     set classType [$this getClassType]
  304.     if {$classType == "Class"} {
  305.     return 1
  306.     }
  307.     return 0
  308. }
  309.  
  310. method FTGGenClass::getFinalClass {this} {
  311.     return $this
  312. }
  313.  
  314. method FTGGenClass::getKind {this} {
  315.     return [$this getClassType]
  316. }
  317.  
  318. # Do not delete this line -- regeneration end marker
  319.  
  320.  
  321. #      File:           @(#)ftginitial.tcl    /main/hindenburg/1
  322.  
  323.  
  324. Class FTGInitializer : {Object} {
  325.     constructor
  326.     method destructor
  327.     method generate
  328.     method genCode
  329. }
  330.  
  331. constructor FTGInitializer {class this name} {
  332.     set this [Object::constructor $class $this $name]
  333.     # Start constructor user section
  334.     # End constructor user section
  335.     return $this
  336. }
  337.  
  338. method FTGInitializer::destructor {this} {
  339.     # Start destructor user section
  340.     # End destructor user section
  341. }
  342.  
  343. method FTGInitializer::generate {this ctor} {
  344.     # empty
  345. }
  346.  
  347. method FTGInitializer::genCode {this ctor} {
  348.     if {$ctor == ""} {
  349.     return
  350.     }
  351.     set sect [$ctor genCode]
  352.     $sect append "-- ! the user must initialize attribute '[$this getName]'\n"
  353.     $sect append "-- ! when constructing this object\n"
  354.     $sect append "--\n"
  355. }
  356.  
  357. # Do not delete this line -- regeneration end marker
  358.  
  359. Class FTGInitializerD : {FTGInitializer OPInitializer} {
  360. }
  361.  
  362. selfPromoter OPInitializer {this} {
  363.     FTGInitializerD promote $this
  364. }
  365.  
  366. #      File:           @(#)ftgoperpar.tcl    /main/hindenburg/3
  367.  
  368.  
  369. Class FTGOperParameter : {Object OPOperParameter} {
  370.     constructor
  371.     method destructor
  372.     method generate
  373.     method getMechanism
  374.     method getCopy
  375. }
  376.  
  377. constructor FTGOperParameter {class this name} {
  378.     set this [Object::constructor $class $this $name]
  379.     # Start constructor user section
  380.     # End constructor user section
  381.     return $this
  382. }
  383.  
  384. method FTGOperParameter::destructor {this} {
  385.     # Start destructor user section
  386.     # End destructor user section
  387. }
  388.  
  389. method FTGOperParameter::generate {this tgtMethod forWhat} {
  390.     # forWhat is one of: Method, Event, Event Handler, Service, CursorDef
  391.     #
  392.     set type [$this ooplType]
  393.     if {$type != "" && $forWhat != "Service"} {
  394.     set tgtType [$type getType [[$tgtMethod theClass] model]]
  395.     } else {
  396.     set tgtType ""
  397.     }
  398.  
  399.     set mechanism [$this getMechanism $forWhat]
  400.     set param [FTParameter new [$this getName] $mechanism $tgtMethod $tgtType]
  401.     $param asCopy [$this getCopy $forWhat]
  402.  
  403.     # the following parameters may have a default value:
  404.     #   - 'input' parameters
  405.     #   - parameters of Events
  406.     #   - parameters of Services, CursorDefs
  407.     #
  408.     #    - class type parameters may have only the NIL value
  409.     #
  410.     set defaultVal [string trim [$this getPropertyValue default_value]]
  411.     if {$defaultVal != ""} {
  412.     if {$mechanism == "input" || $forWhat == "Event" || $forWhat == "Service" || $forWhat == "CursorDef"} {
  413.         if {[$type refersClass] && [string tolower $defaultVal] != "nil"} {
  414.         if {$forWhat == "Service"} {
  415.             set forWhat2 "Service Object"
  416.         } elseif {$forWhat == "CursorDef"} {
  417.             set forWhat2 Cursor
  418.         } else {
  419.             set forWhat2 Class
  420.         }
  421.         m4_error $E_DEFVAL_PAR [$this getName] $forWhat [$tgtMethod name] $forWhat2 [[$tgtMethod theClass] name] $defaultVal
  422.         } else {
  423.         $param defaultVal $defaultVal
  424.         }
  425.     }
  426.     }
  427. }
  428.  
  429. method FTGOperParameter::getMechanism {this forWhat} {
  430.     #             input        output        input output
  431.     # --------------------------------------------------------------
  432.     # Method          *          *             *
  433.     # Event          -          -             -
  434.     # EventHandler      *          -             -
  435.     # <other> -> Event
  436.     #
  437.     # Events have no mechanism (i.e. "")
  438.     # defaults for rest to "input"
  439.     #
  440.     if {$forWhat == "Event" || ($forWhat != "EventHandler" && $forWhat != "Method")} {
  441.     return ""
  442.     }
  443.     set mechanism [string tolower [$this getPropertyValue mechanism]]
  444.     if {$mechanism == ""} {
  445.     set mechanism input
  446.     }
  447.     if {$forWhat == "EventHandler" && $mechanism != "input"} {
  448.     set mechanism input
  449.     }
  450.     return $mechanism
  451. }
  452.  
  453. method FTGOperParameter::getCopy {this forWhat} {
  454.     # Events have no copy option (i.e. "")
  455.     # defaults to 0
  456.     #
  457.     if {$forWhat == "Event" || ($forWhat != "EventHandler" && $forWhat != "Method")} {
  458.     return 0
  459.     }
  460.     set copy [$this getPropertyValue copy]
  461.     if {$copy == ""} {
  462.     set copy 0
  463.     }
  464.     return $copy
  465. }
  466.  
  467. # Do not delete this line -- regeneration end marker
  468.  
  469. selfPromoter OPOperParameter {this} {
  470.     FTGOperParameter promote $this
  471. }
  472.  
  473. #      File:           @(#)ftgtype.tcl    /main/hindenburg/3
  474.  
  475.  
  476. Class FTGType : {Object} {
  477.     constructor
  478.     method destructor
  479.     method getType
  480.     method getModifier
  481.     method setOtherModifier
  482.     method isClassType
  483.     method refersClass
  484. }
  485.  
  486. constructor FTGType {class this name} {
  487.     set this [Object::constructor $class $this $name]
  488.     # Start constructor user section
  489.     # End constructor user section
  490.     return $this
  491. }
  492.  
  493. method FTGType::destructor {this} {
  494.     # Start destructor user section
  495.     # End destructor user section
  496. }
  497.  
  498. method FTGType::getType {this model} {
  499.     set class [$this ooplClass]
  500.     if {$class == ""} {
  501.     return ""
  502.     }
  503.  
  504.     set tgtType [FTType new]
  505.     if {[$class getClassType] != "Class"} {
  506.     $tgtType name "[$class getDefSysName].[$class getName]"
  507.     $tgtType isClass 0
  508.     } else {
  509.     $tgtType classType [FTCmnClass new [$class getName] $model [$class getDefSysName] 1]
  510.     $tgtType isClass [$this isClassType]
  511.  
  512.     set modifier [$this getModifier]
  513.     if {$modifier == "Array"} {
  514.         $tgtType arraySize 255
  515.     } elseif {$modifier == "LargeArray"} {
  516.         $tgtType arraySize 256
  517.     } elseif {$modifier == "Pointer"} {
  518.         $tgtType isPointer 1
  519.     } elseif {$modifier == "Other"} {
  520.         $this setOtherModifier $tgtType
  521.     }
  522.     }
  523.  
  524.     return $tgtType
  525. }
  526.  
  527. method FTGType::getModifier {this} {
  528.     return [$this getPropertyValue modifier]
  529. }
  530.  
  531. method FTGType::setOtherModifier {this tgtType} {
  532.     set otherModifier [string trim [$this getPropertyValue other_modifier]]
  533.     if {$otherModifier != ""} {
  534.     $tgtType otherModifier $otherModifier
  535.     }
  536. }
  537.  
  538. method FTGType::isClassType {this} {
  539.     return 0
  540. }
  541.  
  542. method FTGType::refersClass {this} {
  543.     return 0
  544. }
  545.  
  546. # Do not delete this line -- regeneration end marker
  547.  
  548. Class FTGTypeD : {FTGType OPType} {
  549. }
  550.  
  551. selfPromoter OPType {this} {
  552.     FTGTypeD promote $this
  553. }
  554.  
  555. #      File:           @(#)ftgattribu.tcl    /main/hindenburg/2
  556.  
  557.  
  558. Class FTGAttribute : {FTGFeature} {
  559.     constructor
  560.     method destructor
  561.     method generate
  562.     method getAccess
  563.     method getAccessorAccess
  564.     attribute access
  565.     attribute accessorAccess
  566. }
  567.  
  568. constructor FTGAttribute {class this name} {
  569.     set this [FTGFeature::constructor $class $this $name]
  570.     # Start constructor user section
  571.     # End constructor user section
  572.     return $this
  573. }
  574.  
  575. method FTGAttribute::destructor {this} {
  576.     # Start destructor user section
  577.     # End destructor user section
  578. }
  579.  
  580. method FTGAttribute::generate {this tgtClass} {
  581.     # empty
  582. }
  583.  
  584. method FTGAttribute::getAccess {this} {
  585.     if {[$this access] != ""} {
  586.     return [$this access]    
  587.     } else {
  588.     set access [string tolower [$this getPropertyValue attrib_access]]
  589.     }
  590.     if {$access == ""} {
  591.     return private
  592.     }
  593.     return $access
  594. }
  595.  
  596. method FTGAttribute::getAccessorAccess {this mode} {
  597.     if {[$this accessorAccess] != ""} {
  598.     set manip [$this accessorAccess]
  599.     } else {
  600.     set manip [string tolower [$this getPropertyValue attrib_manipulator]]
  601.     if {$manip == ""} {
  602.         return public
  603.     }
  604.     }
  605.  
  606.     set rwAccessList [split $manip -]
  607.     if {[llength $rwAccessList] == 2} {
  608.     if {$mode == "r"} {
  609.         return [lindex $rwAccessList 0]
  610.     }
  611.     return [lindex $rwAccessList 1]
  612.     }
  613.  
  614.     return $manip
  615. }
  616.  
  617. # Do not delete this line -- regeneration end marker
  618.  
  619. Class FTGAttributeD : {FTGAttribute OPAttribute} {
  620. }
  621.  
  622. selfPromoter OPAttribute {this} {
  623.     FTGAttributeD promote $this
  624. }
  625.  
  626. #      File:           @(#)ftgconstru.tcl    /main/hindenburg/4
  627.  
  628.  
  629. Class FTGConstructor : {FTGFeature} {
  630.     constructor
  631.     method destructor
  632.     method generate
  633. }
  634.  
  635. constructor FTGConstructor {class this name} {
  636.     set this [FTGFeature::constructor $class $this $name]
  637.     # Start constructor user section
  638.     # End constructor user section
  639.     return $this
  640. }
  641.  
  642. method FTGConstructor::destructor {this} {
  643.     # Start destructor user section
  644.     # End destructor user section
  645. }
  646.  
  647. method FTGConstructor::generate {this tgtClass} {
  648.     set ctor [$tgtClass constructor]
  649.     if {$ctor == ""} {
  650.     return
  651.     }
  652.  
  653.     set class [$this ooplClass]
  654.     set sect [$ctor genCode]
  655.     foreach assoc [$class genAssocAttrSet] {
  656.     set var [$assoc getAssocVariable]
  657.     if {[$assoc isQualified] || [$assoc getMultiplicity] == "many"} {
  658.         $sect append "$var = new;\n"
  659.     }
  660.  
  661.     set opposite [$assoc opposite]
  662.     if {$opposite != "" && [$assoc isMandatory]} {
  663.         # currently ignore...
  664.         #
  665.         # $sect append "-- > [$opposite extendAssoc $var]"
  666.     }
  667.     }
  668.  
  669.     foreach ini [$this initializerSet] {
  670.     $ini generate $ctor
  671.     }
  672. }
  673.  
  674. # Do not delete this line -- regeneration end marker
  675.  
  676. Class FTGConstructorD : {FTGConstructor OPConstructor} {
  677. }
  678.  
  679. selfPromoter OPConstructor {this} {
  680.     FTGConstructorD promote $this
  681. }
  682.  
  683. #      File:           @(#)ftgoperati.tcl    /main/hindenburg/4
  684.  
  685.  
  686. Class FTGOperation : {FTGFeature} {
  687.     constructor
  688.     method destructor
  689.     method generate
  690.     method genMethod
  691.     method genEvent
  692.     method genEventHandler
  693.     method genService
  694.     method genCursorDef
  695.     method genParams
  696.     method getAccess
  697. }
  698.  
  699. constructor FTGOperation {class this name} {
  700.     set this [FTGFeature::constructor $class $this $name]
  701.     # Start constructor user section
  702.     # End constructor user section
  703.     return $this
  704. }
  705.  
  706. method FTGOperation::destructor {this} {
  707.     # Start destructor user section
  708.     # End destructor user section
  709. }
  710.  
  711. method FTGOperation::generate {this tgtClass {operType ""}} {
  712.     set name [$this getName]
  713.     set lowerName [string tolower $name]
  714.     if {$lowerName == "create" || $lowerName == "init" || ($lowerName == "display" && [$tgtClass isMapped])} {
  715.     m4_warning $W_IGNORE_OPER $name [$tgtClass name]
  716.     return
  717.     }
  718.  
  719.     set type [$this ooplType]
  720.     if {$type != ""} {
  721.     set tgtType [$type getType [$tgtClass model]]
  722.     } else {
  723.     set tgtType ""
  724.     }
  725.  
  726.     if {$operType == ""} {
  727.     set operType [$this getPropertyValue oper_type]
  728.     }
  729.     if {$operType == ""} {
  730.     set operType Method
  731.     }
  732.     regsub " " $operType "" operType
  733.     $this gen${operType} $tgtClass $tgtType
  734. }
  735.  
  736. method FTGOperation::genMethod {this tgtClass tgtType} {
  737.     set method [FTUserMethod new [$this getName] $tgtType [$this getAccess] $tgtClass]
  738.  
  739.     set copy [$this getPropertyValue copy]
  740.     if {$copy == "1"} {
  741.     $method hasCopyType 1
  742.     }
  743.  
  744.     $method returnEvent [string trim [$this getPropertyValue return_event]]
  745.     $method exceptEvent [string trim [$this getPropertyValue except_event]]
  746.  
  747.     $this genParams $method Method
  748. }
  749.  
  750. method FTGOperation::genEvent {this tgtClass tgtType} {
  751.     set event [FTEvent new [$this getName] "" [$this getAccess] $tgtClass]
  752.     $this genParams $event Event
  753. }
  754.  
  755. method FTGOperation::genEventHandler {this tgtClass tgtType} {
  756.     set evHandler [FTEventHandler new [$this getName] "" [$this getAccess] $tgtClass]
  757.     $this genParams $evHandler EventHandler
  758. }
  759.  
  760. method FTGOperation::genService {this tgtClass tgtType} {
  761.     set service [FTService new [$this getName] $tgtType "" $tgtClass]
  762.     $this genParams $service Service
  763. }
  764.  
  765. method FTGOperation::genCursorDef {this tgtClass tgtType} {
  766.     set cursorDef [FTCursorDef new [$tgtClass name] "" "" $tgtClass]
  767.     $this genParams $cursorDef CursorDef
  768. }
  769.  
  770. method FTGOperation::genParams {this tgtMethod forWhat} {
  771.     foreach param [$this parameterSet] {
  772.     $param generate $tgtMethod $forWhat
  773.     }
  774. }
  775.  
  776. method FTGOperation::getAccess {this} {
  777.     return [string tolower [$this getPropertyValue method_access]]
  778. }
  779.  
  780. # Do not delete this line -- regeneration end marker
  781.  
  782. Class FTGOperationD : {FTGOperation OPOperation} {
  783. }
  784.  
  785. selfPromoter OPOperation {this} {
  786.     FTGOperationD promote $this
  787. }
  788.  
  789. #      File:           @(#)ftgclass.tcl    /main/hindenburg/1
  790.  
  791.  
  792. Class FTGClass : {FTGGenClass OPClass} {
  793.     constructor
  794.     method destructor
  795. }
  796.  
  797. constructor FTGClass {class this name} {
  798.     set this [FTGGenClass::constructor $class $this $name]
  799.     # Start constructor user section
  800.     # End constructor user section
  801.     return $this
  802. }
  803.  
  804. method FTGClass::destructor {this} {
  805.     # Start destructor user section
  806.     # End destructor user section
  807. }
  808.  
  809. # Do not delete this line -- regeneration end marker
  810.  
  811. selfPromoter OPClass {this} {
  812.     FTGClass promote $this
  813. }
  814.  
  815. #      File:           @(#)ftgclassen.tcl    /main/hindenburg/5
  816.  
  817.  
  818. Class FTGClassEnum : {FTGGenClass OPClassEnum} {
  819.     constructor
  820.     method destructor
  821.     method generate
  822.     method isDerivable
  823.     method getKind
  824. }
  825.  
  826. constructor FTGClassEnum {class this name} {
  827.     set this [FTGGenClass::constructor $class $this $name]
  828.     # Start constructor user section
  829.     # End constructor user section
  830.     return $this
  831. }
  832.  
  833. method FTGClassEnum::destructor {this} {
  834.     # Start destructor user section
  835.     # End destructor user section
  836. }
  837.  
  838. method FTGClassEnum::generate {this model} {
  839.     set classType [$this getClassType]
  840.     if {$classType != "Class"} {
  841.     # this is not a class enumeration
  842.     $this FTGGenClass::generate $model
  843.     return
  844.     }
  845.  
  846.     set name [$this getName]
  847.     m4_message $M_GEN_FOR "Class Enumeration" $name
  848.     set class [$model findDefinition $name]
  849.     if {$class == ""} {
  850.     set class [FTEnum new $name $model [$this getDefSysName] 0]
  851.     $class ooplClass $this
  852.     foreach feat [$this featureSet] {
  853.         set item [FTEnumItem new [$feat getName] $class]
  854.         if {[string trim [$feat getPropertyValue initial_value]] != ""}  {
  855.         $item value [$feat getPropertyValue initial_value]
  856.         }
  857.     }
  858.     }
  859. }
  860.  
  861. method FTGClassEnum::isDerivable {this} {
  862.     return 0
  863. }
  864.  
  865. method FTGClassEnum::getKind {this} {
  866.     set classType [$this getClassType]
  867.     if {$classType != "Class"} {
  868.     # this is not a class enumeration
  869.     return $classType
  870.     }
  871.     return "Class Enumeration"
  872. }
  873.  
  874. # Do not delete this line -- regeneration end marker
  875.  
  876. selfPromoter OPClassEnum {this} {
  877.     FTGClassEnum promote $this
  878. }
  879.  
  880. #      File:           @(#)ftgclassge.tcl    /main/hindenburg/6
  881.  
  882.  
  883. Class FTGClassGenericTypeDef : {FTGGenClass OPClassGenericTypeDef} {
  884.     constructor
  885.     method destructor
  886.     method generate
  887.     method isDerivable
  888.     method isLegal
  889.     method getKind
  890.     attribute _isLegal
  891. }
  892.  
  893. constructor FTGClassGenericTypeDef {class this name} {
  894.     set this [FTGGenClass::constructor $class $this $name]
  895.     $this _isLegal -1
  896.     # Start constructor user section
  897.     # End constructor user section
  898.     return $this
  899. }
  900.  
  901. method FTGClassGenericTypeDef::destructor {this} {
  902.     # Start destructor user section
  903.     # End destructor user section
  904. }
  905.  
  906. method FTGClassGenericTypeDef::generate {this model} {
  907.     set classType [$this getClassType]
  908.     if {$classType != "Class"} {
  909.     # this is not a class generic typedef
  910.     $this FTGGenClass::generate $model
  911.     return
  912.     }
  913.  
  914.     set name [$this getName]
  915.     m4_message $M_GEN_FOR "Class Generic Typedef" $name
  916.     set class [$model findDefinition $name]
  917.     if {$class == ""} {
  918.     set assocAttr [lindex [$this genAssocAttrSet] 0]
  919.     if {![$this isLegal $assocAttr]} {
  920.         return
  921.     }
  922.     set class [FTTypeDef new $name $model [$this getDefSysName] 0 ""]
  923.     $class ooplClass $this
  924.     $assocAttr genAssocVariable $class
  925.     $class type [[$assocAttr tgtAttrib] type]
  926.     if {![$assocAttr isQualified] && [$assocAttr getMultiplicity] == "one" && ![$assocAttr isMandatory]} {
  927.         [$class type] isPointer 1
  928.     }
  929.     }
  930. }
  931.  
  932. method FTGClassGenericTypeDef::isDerivable {this} {
  933.     set classType [$this getClassType]
  934.     if {$classType != "Class"} {
  935.     # this is not a class generic typedef (and no class too)
  936.     return 0
  937.     }
  938.  
  939.     set assocAttr [lindex [$this genAssocAttrSet] 0]
  940.     if {[[$assocAttr ooplType] getType3GL] != ""} {
  941.     return 0
  942.     }
  943.     if {[$this isLegal $assocAttr] && ([$assocAttr getMultiplicity] == "many" || [$assocAttr isQualified])} {
  944.     return 1
  945.     }
  946.     return 0
  947. }
  948.  
  949. method FTGClassGenericTypeDef::isLegal {this {assocAttr ""}} {
  950.     if {[$this _isLegal] != -1} {
  951.     return [$this _isLegal]
  952.     }
  953.  
  954.     if {$assocAttr == ""} {
  955.     set assocAttr [lindex [$this genAssocAttrSet] 0]
  956.     }
  957.  
  958.     if {![$assocAttr hasLegalDest]} {
  959.     m4_error $E_GTD_2ILL_TYPE [$this getName]
  960.     $this _isLegal 0
  961.     return 0
  962.     }
  963.  
  964.     set destClass [[$assocAttr ooplType] ooplClass]
  965.     if {$destClass == ""} {
  966.     m4_error $E_GTD_2ILL_TYPE [$this getName]
  967.     $this _isLegal 0
  968.     return 0
  969.     }
  970.  
  971.     if {[$destClass isA FTGClassTDef]} {
  972.     set type [$destClass getFinalType]
  973.     if {$type == ""} {
  974.         m4_error $E_GTD_2ILL_TYPE [$this getName]
  975.         $this _isLegal 0
  976.         return 0
  977.     }
  978.     if {[$type getName] == [$this getName]} {
  979.         m4_error $E_GTD_RECURSIVE [$this getName]
  980.         $this _isLegal 0
  981.         return 0
  982.     }
  983.     } elseif {[$destClass isA FTGClassGenericTypeDef]} {
  984.     $this _isLegal [$destClass isLegal]
  985.     if {![$this _isLegal]} {
  986.         m4_error $E_GTD_2ILL_GTD [$this getName] [$destClass getName]
  987.     }
  988.     return [$this _isLegal]
  989.     }
  990.  
  991.     $this _isLegal 1
  992.     return 1
  993. }
  994.  
  995. method FTGClassGenericTypeDef::getKind {this} {
  996.     set classType [$this getClassType]
  997.     if {$classType != "Class"} {
  998.     # this is not a class generic typedef
  999.     return $classType
  1000.     }
  1001.     return "Class Generic Typedef"
  1002. }
  1003.  
  1004. # Do not delete this line -- regeneration end marker
  1005.  
  1006. selfPromoter OPClassGenericTypeDef {this} {
  1007.     FTGClassGenericTypeDef promote $this
  1008.     $this _isLegal -1
  1009. }
  1010.  
  1011. #      File:           @(#)ftgclasstd.tcl    /main/hindenburg/9
  1012.  
  1013.  
  1014. Class FTGClassTDef : {FTGGenClass OPClassTDef} {
  1015.     constructor
  1016.     method destructor
  1017.     method generate
  1018.     method isDerivable
  1019.     method getType
  1020.     method getFinalType
  1021.     method getFinalClass
  1022.     method getKind
  1023.     attribute cid
  1024.     attribute finalType
  1025. }
  1026.  
  1027. global FTGClassTDef::gid
  1028. set FTGClassTDef::gid 0
  1029.  
  1030.  
  1031. constructor FTGClassTDef {class this name} {
  1032.     set this [FTGGenClass::constructor $class $this $name]
  1033.     $this finalType null
  1034.     # Start constructor user section
  1035.     # End constructor user section
  1036.     return $this
  1037. }
  1038.  
  1039. method FTGClassTDef::destructor {this} {
  1040.     # Start destructor user section
  1041.     # End destructor user section
  1042. }
  1043.  
  1044. method FTGClassTDef::generate {this model} {
  1045.     set classType [$this getClassType]
  1046.     if {$classType != "Class"} {
  1047.     # this is not a class typedef
  1048.     $this FTGGenClass::generate $model
  1049.     return
  1050.     }
  1051.  
  1052.     set name [$this getName]
  1053.     m4_message $M_GEN_FOR "Class Typedef" $name
  1054.     set class [$model findDefinition $name]
  1055.     if {$class == ""} {
  1056.     set type [$this getType]
  1057.     if {$type == ""} {
  1058.         m4_error $E_TD_NO_TYPE $name
  1059.         return
  1060.     }
  1061.     set class [FTTypeDef new $name $model [$this getDefSysName] 0 [$type getType $model]]
  1062.     $class ooplClass $this
  1063.     }
  1064. }
  1065.  
  1066. method FTGClassTDef::isDerivable {this} {
  1067.     set classType [$this getClassType]
  1068.     if {$classType != "Class"} {
  1069.     # this is not a class typedef (and no class too)
  1070.     return 0
  1071.     }
  1072.  
  1073.     set type [$this getFinalType]
  1074.     if {$type != ""} {
  1075.     # note: we don't use method OPType::getType3GL()
  1076.     # note: we have an OPTypeDefType in case of a typedef that refers to
  1077.     #    itself
  1078.     #
  1079.     if {[$type isA OPBaseType] || [$type isA OPTypeDefType] || [$type isA OPEnumType]} {
  1080.         return 0
  1081.     }
  1082.     if {[$type isA OPClassType] && [[$type ooplClass] getClassType] != "Class"} {
  1083.         return 0
  1084.     }
  1085.     return 1
  1086.     }
  1087.     return 0
  1088. }
  1089.  
  1090. method FTGClassTDef::getType {this} {
  1091.     # note: this method should have been a member of OPClassTDef
  1092.     #
  1093.     set attr [lindex [$this dataAttrSet] 0]
  1094.     if {$attr == ""} {
  1095.     return ""
  1096.     }
  1097.  
  1098.     # hack: if attr has no type, the OOPL model returns an OPClassType without
  1099.     #  an OPCLass... or an OPClass having no name... !!!
  1100.     #
  1101.     set type [$attr ooplType]
  1102.     if {[$type isA OPClassType]} {
  1103.     if {[$type ooplClass] == "" || [[$type ooplClass] getName] == ""} {
  1104.         return ""
  1105.     }
  1106.     }
  1107.     return $type
  1108. }
  1109.  
  1110. method FTGClassTDef::getFinalType {this} {
  1111.     # return the (final) type to which this typedef really refers, i.e. resolve
  1112.     #  the typedef trail until a non-typedef is discovered
  1113.     # note: this func returns an OPTypeDefType in case of a typedef that refers
  1114.     #        to itself
  1115.     # currently, this is done non-recursively...
  1116.     #
  1117.     if {[$this finalType] != "null"} {
  1118.     return [$this finalType]
  1119.     }
  1120.  
  1121.     global FTGClassTDef::gid
  1122.     incr FTGClassTDef::gid
  1123.     set id ${FTGClassTDef::gid}
  1124.     $this cid $id
  1125.  
  1126.     set type [$this getType]
  1127.     while {1} {
  1128.     if {$type == ""} {
  1129.         $this finalType ""
  1130.         return ""
  1131.     }
  1132.     if {![$type isA OPTypeDefType]} {
  1133.         $this finalType $type
  1134.         return $type
  1135.     }
  1136.     set class [$type ooplClass]
  1137.     if {$class == ""} {
  1138.         $this finalType ""
  1139.         return ""
  1140.     }
  1141.     if {[$class getClassType] != "Class" || ![$class isA OPClassTDef]} {
  1142.         $this finalType $type
  1143.         return $type
  1144.     }
  1145.     if {$id == [$class cid]} {
  1146.         # loop detected
  1147.         $this finalType $type
  1148.         return $type
  1149.     }
  1150.     if {[$class getName] == ""} {
  1151.         $this finalType ""
  1152.         return ""
  1153.     }
  1154.     $class cid $id
  1155.     set type [$class getType]
  1156.     }
  1157. }
  1158.  
  1159. method FTGClassTDef::getFinalClass {this} {
  1160.     # return the final class to which this typedef refers, or ""
  1161.     # this class is a real class, i.e. its class_type equals "Class"
  1162.     #
  1163.     set type [$this getFinalType]
  1164.     if {$type != "" && [$type isA OPClassType] && [[$type ooplClass] getClassType] == "Class"} {
  1165.     return [$type ooplClass]
  1166.     }
  1167.     return ""
  1168. }
  1169.  
  1170. method FTGClassTDef::getKind {this} {
  1171.     set classType [$this getClassType]
  1172.     if {$classType != "Class"} {
  1173.     # this is not a class typedef
  1174.     return $classType
  1175.     }
  1176.     return "Class Typedef"
  1177. }
  1178.  
  1179. # Do not delete this line -- regeneration end marker
  1180.  
  1181. selfPromoter OPClassTDef {this} {
  1182.     FTGClassTDef promote $this
  1183.     $this finalType null
  1184. }
  1185.  
  1186. #      File:           @(#)ftglinkcla.tcl    /main/hindenburg/1
  1187.  
  1188.  
  1189. Class FTGLinkClass : {FTGGenClass OPLinkClass} {
  1190.     constructor
  1191.     method destructor
  1192. }
  1193.  
  1194. constructor FTGLinkClass {class this name} {
  1195.     set this [FTGGenClass::constructor $class $this $name]
  1196.     # Start constructor user section
  1197.     # End constructor user section
  1198.     return $this
  1199. }
  1200.  
  1201. method FTGLinkClass::destructor {this} {
  1202.     # Start destructor user section
  1203.     # End destructor user section
  1204. }
  1205.  
  1206. # Do not delete this line -- regeneration end marker
  1207.  
  1208. selfPromoter OPLinkClass {this} {
  1209.     FTGLinkClass promote $this
  1210. }
  1211.  
  1212. #      File:           @(#)ftgassocin.tcl    /main/hindenburg/3
  1213.  
  1214.  
  1215. Class FTGAssocInitializer : {FTGInitializer} {
  1216.     constructor
  1217.     method destructor
  1218.     method generate
  1219. }
  1220.  
  1221. constructor FTGAssocInitializer {class this name} {
  1222.     set this [FTGInitializer::constructor $class $this $name]
  1223.     # Start constructor user section
  1224.     # End constructor user section
  1225.     return $this
  1226. }
  1227.  
  1228. method FTGAssocInitializer::destructor {this} {
  1229.     # Start destructor user section
  1230.     # End destructor user section
  1231. }
  1232.  
  1233. method FTGAssocInitializer::generate {this ctor} {
  1234.     # currently not supported...
  1235.     #
  1236.     return
  1237.  
  1238.     $this genCode $ctor
  1239. }
  1240.  
  1241. # Do not delete this line -- regeneration end marker
  1242.  
  1243. Class FTGAssocInitializerD : {FTGAssocInitializer OPAssocInitializer} {
  1244. }
  1245.  
  1246. selfPromoter OPAssocInitializer {this} {
  1247.     FTGAssocInitializerD promote $this
  1248. }
  1249.  
  1250. #      File:           @(#)ftgattribi.tcl    /main/hindenburg/1
  1251.  
  1252.  
  1253. Class FTGAttribInitializer : {FTGInitializer} {
  1254.     constructor
  1255.     method destructor
  1256. }
  1257.  
  1258. constructor FTGAttribInitializer {class this name} {
  1259.     set this [FTGInitializer::constructor $class $this $name]
  1260.     # Start constructor user section
  1261.     # End constructor user section
  1262.     return $this
  1263. }
  1264.  
  1265. method FTGAttribInitializer::destructor {this} {
  1266.     # Start destructor user section
  1267.     # End destructor user section
  1268. }
  1269.  
  1270. # Do not delete this line -- regeneration end marker
  1271.  
  1272. Class FTGAttribInitializerD : {FTGAttribInitializer OPAttribInitializer} {
  1273. }
  1274.  
  1275. selfPromoter OPAttribInitializer {this} {
  1276.     FTGAttribInitializerD promote $this
  1277. }
  1278.  
  1279. #      File:           @(#)ftginhkeyi.tcl    /main/hindenburg/1
  1280.  
  1281.  
  1282. Class FTGInhKeyInitializer : {FTGInitializer} {
  1283.     constructor
  1284.     method destructor
  1285. }
  1286.  
  1287. constructor FTGInhKeyInitializer {class this name} {
  1288.     set this [FTGInitializer::constructor $class $this $name]
  1289.     # Start constructor user section
  1290.     # End constructor user section
  1291.     return $this
  1292. }
  1293.  
  1294. method FTGInhKeyInitializer::destructor {this} {
  1295.     # Start destructor user section
  1296.     # End destructor user section
  1297. }
  1298.  
  1299. # Do not delete this line -- regeneration end marker
  1300.  
  1301. Class FTGInhKeyInitializerD : {FTGInhKeyInitializer OPInhKeyInitializer} {
  1302. }
  1303.  
  1304. selfPromoter OPInhKeyInitializer {this} {
  1305.     FTGInhKeyInitializerD promote $this
  1306. }
  1307.  
  1308. #      File:           @(#)ftgqualini.tcl    /main/hindenburg/3
  1309.  
  1310.  
  1311. Class FTGQualInitializer : {FTGInitializer} {
  1312.     constructor
  1313.     method destructor
  1314.     method generate
  1315. }
  1316.  
  1317. constructor FTGQualInitializer {class this name} {
  1318.     set this [FTGInitializer::constructor $class $this $name]
  1319.     # Start constructor user section
  1320.     # End constructor user section
  1321.     return $this
  1322. }
  1323.  
  1324. method FTGQualInitializer::destructor {this} {
  1325.     # Start destructor user section
  1326.     # End destructor user section
  1327. }
  1328.  
  1329. method FTGQualInitializer::generate {this ctor} {
  1330.     # currently not supported...
  1331. }
  1332.  
  1333. # Do not delete this line -- regeneration end marker
  1334.  
  1335. Class FTGQualInitializerD : {FTGQualInitializer OPQualInitializer} {
  1336. }
  1337.  
  1338. selfPromoter OPQualInitializer {this} {
  1339.     FTGQualInitializerD promote $this
  1340. }
  1341.  
  1342. #      File:           @(#)ftgsupercl.tcl    /main/hindenburg/1
  1343.  
  1344.  
  1345. Class FTGSuperClassInitializer : {FTGInitializer} {
  1346.     constructor
  1347.     method destructor
  1348. }
  1349.  
  1350. constructor FTGSuperClassInitializer {class this name} {
  1351.     set this [FTGInitializer::constructor $class $this $name]
  1352.     # Start constructor user section
  1353.     # End constructor user section
  1354.     return $this
  1355. }
  1356.  
  1357. method FTGSuperClassInitializer::destructor {this} {
  1358.     # Start destructor user section
  1359.     # End destructor user section
  1360. }
  1361.  
  1362. # Do not delete this line -- regeneration end marker
  1363.  
  1364. Class FTGSuperClassInitializerD : {FTGSuperClassInitializer OPSuperClassInitializer} {
  1365. }
  1366.  
  1367. selfPromoter OPSuperClassInitializer {this} {
  1368.     FTGSuperClassInitializerD promote $this
  1369. }
  1370.  
  1371. #      File:           @(#)ftgbasetyp.tcl    /main/hindenburg/2
  1372.  
  1373.  
  1374. Class FTGBaseType : {FTGType} {
  1375.     constructor
  1376.     method destructor
  1377.     method getType
  1378. }
  1379.  
  1380. constructor FTGBaseType {class this name} {
  1381.     set this [FTGType::constructor $class $this $name]
  1382.     # Start constructor user section
  1383.     # End constructor user section
  1384.     return $this
  1385. }
  1386.  
  1387. method FTGBaseType::destructor {this} {
  1388.     # Start destructor user section
  1389.     # End destructor user section
  1390. }
  1391.  
  1392. method FTGBaseType::getType {this model} {
  1393.     set tgtType [FTType new]
  1394.     $tgtType isClass 0
  1395.     set type [$this getType3GL]
  1396.  
  1397.     set size ""
  1398.     regexp {\[([0-9]*)\]$} $type dummy size
  1399.     regsub {\[[0-9]*\]$} $type "" type
  1400.     $tgtType name $type
  1401.  
  1402.     if {$size != ""} {
  1403.     $tgtType arraySize $size
  1404.     }
  1405.  
  1406.     set modifier [$this getModifier]
  1407.     if {$modifier == "Pointer"} {
  1408.     $tgtType isPointer 1
  1409.     } elseif {$modifier == "Other"} {
  1410.     $this setOtherModifier $tgtType
  1411.     }
  1412.  
  1413.     return $tgtType
  1414. }
  1415.  
  1416. # Do not delete this line -- regeneration end marker
  1417.  
  1418. Class FTGBaseTypeD : {FTGBaseType OPBaseType} {
  1419. }
  1420.  
  1421. selfPromoter OPBaseType {this} {
  1422.     FTGBaseTypeD promote $this
  1423. }
  1424.  
  1425. #      File:           @(#)ftgclassty.tcl    /main/hindenburg/3
  1426.  
  1427.  
  1428. Class FTGClassType : {FTGType} {
  1429.     constructor
  1430.     method destructor
  1431.     method isClassType
  1432.     method refersClass
  1433. }
  1434.  
  1435. constructor FTGClassType {class this name} {
  1436.     set this [FTGType::constructor $class $this $name]
  1437.     # Start constructor user section
  1438.     # End constructor user section
  1439.     return $this
  1440. }
  1441.  
  1442. method FTGClassType::destructor {this} {
  1443.     # Start destructor user section
  1444.     # End destructor user section
  1445. }
  1446.  
  1447. method FTGClassType::isClassType {this} {
  1448.     return 1
  1449. }
  1450.  
  1451. method FTGClassType::refersClass {this} {
  1452.     return 1
  1453. }
  1454.  
  1455. # Do not delete this line -- regeneration end marker
  1456.  
  1457. Class FTGClassTypeD : {FTGClassType OPClassType} {
  1458. }
  1459.  
  1460. selfPromoter OPClassType {this} {
  1461.     FTGClassTypeD promote $this
  1462. }
  1463.  
  1464. #      File:           @(#)ftgenumtyp.tcl    /main/hindenburg/1
  1465.  
  1466.  
  1467. Class FTGEnumType : {FTGType} {
  1468.     constructor
  1469.     method destructor
  1470. }
  1471.  
  1472. constructor FTGEnumType {class this name} {
  1473.     set this [FTGType::constructor $class $this $name]
  1474.     # Start constructor user section
  1475.     # End constructor user section
  1476.     return $this
  1477. }
  1478.  
  1479. method FTGEnumType::destructor {this} {
  1480.     # Start destructor user section
  1481.     # End destructor user section
  1482. }
  1483.  
  1484. # Do not delete this line -- regeneration end marker
  1485.  
  1486. Class FTGEnumTypeD : {FTGEnumType OPEnumType} {
  1487. }
  1488.  
  1489. selfPromoter OPEnumType {this} {
  1490.     FTGEnumTypeD promote $this
  1491. }
  1492.  
  1493. #      File:           @(#)ftgtypedef.tcl    /main/hindenburg/3
  1494.  
  1495.  
  1496. Class FTGTypeDefType : {FTGType} {
  1497.     constructor
  1498.     method destructor
  1499.     method refersClass
  1500. }
  1501.  
  1502. constructor FTGTypeDefType {class this name} {
  1503.     set this [FTGType::constructor $class $this $name]
  1504.     # Start constructor user section
  1505.     # End constructor user section
  1506.     return $this
  1507. }
  1508.  
  1509. method FTGTypeDefType::destructor {this} {
  1510.     # Start destructor user section
  1511.     # End destructor user section
  1512. }
  1513.  
  1514. method FTGTypeDefType::refersClass {this} {
  1515.     # find out whether this type is an alias for a class type
  1516.     #
  1517.     # note the difference between this method and method refersClass
  1518.     # this method decides whether this IS a class type, i.e. if it may appear
  1519.     #  in the forward section
  1520.     #
  1521.     set class [$this ooplClass]
  1522.     if {$class == ""} {
  1523.     return 0
  1524.     }
  1525.     if {[$class isDerivable]} {
  1526.     return 1
  1527.     }
  1528.     return 0
  1529. }
  1530.  
  1531. # Do not delete this line -- regeneration end marker
  1532.  
  1533. Class FTGTypeDefTypeD : {FTGTypeDefType OPTypeDefType} {
  1534. }
  1535.  
  1536. selfPromoter OPTypeDefType {this} {
  1537.     FTGTypeDefTypeD promote $this
  1538. }
  1539.  
  1540. #      File:           @(#)ftgdataatt.tcl    /main/hindenburg/4
  1541.  
  1542.  
  1543. Class FTGDataAttr : {FTGAttribute} {
  1544.     constructor
  1545.     method destructor
  1546.     method generate
  1547.     method genCmnAttrib
  1548.     method genVirtAttrib
  1549.     method genConstAttrib
  1550. }
  1551.  
  1552. constructor FTGDataAttr {class this name} {
  1553.     set this [FTGAttribute::constructor $class $this $name]
  1554.     # Start constructor user section
  1555.     # End constructor user section
  1556.     return $this
  1557. }
  1558.  
  1559. method FTGDataAttr::destructor {this} {
  1560.     # Start destructor user section
  1561.     # End destructor user section
  1562. }
  1563.  
  1564. method FTGDataAttr::generate {this tgtClass} {
  1565.     set tgtType [[$this ooplType] getType [$tgtClass model]]
  1566.     set const [$this getPropertyValue const]
  1567.     if {$const == 1} {
  1568.     set kind Const
  1569.     } elseif {[$this isDerived]} {
  1570.     set kind Virt
  1571.     } else {
  1572.     set kind Cmn
  1573.     }
  1574.     $this gen${kind}Attrib $tgtClass $tgtType
  1575. }
  1576.  
  1577. method FTGDataAttr::genCmnAttrib {this tgtClass tgtType} {
  1578.     set name [$this getName]
  1579.     if {$tgtType == ""} {
  1580.     m4_error $E_ATTR_HAS_NO "" $name [$tgtClass name] " type"
  1581.     return
  1582.     }
  1583.     set attrib [FTCmnAttrib new $name $tgtType [$this getAccess] $tgtClass]
  1584.  
  1585.     set sect [[$tgtClass constructor] genCode]
  1586.     if {[$tgtType isClassType]} {
  1587.     $sect append "$name = new;\n"
  1588.     }
  1589.     set value [$this getInitialValue]
  1590.     if {[string trim $value] != "" && [$tgtClass constructor] != ""} {
  1591.     $sect append "$name = $value;\n"
  1592.     }
  1593.  
  1594.     set access [$this getAccessorAccess r]
  1595.     if {$access != "none"} {
  1596.     set accessor [FTAccMethod new "get[cap $name]" $tgtType $access $tgtClass $attrib]
  1597.     if {[$tgtType isClassType]} {
  1598.         $accessor hasCopyType 1
  1599.     }
  1600.     set sect [$accessor genCode]
  1601.     $sect append "return $name;\n"
  1602.     }
  1603.  
  1604.     set access [$this getAccessorAccess w]
  1605.     if {$access != "none"} {
  1606.     set accessor [FTAccMethod new "set[cap $name]" "" $access $tgtClass $attrib]
  1607.     set param [FTParameter new "new[cap $name]" input $accessor $tgtType]
  1608.     if {[$tgtType isClassType]} {
  1609.         $param asCopy 1
  1610.     }
  1611.     set sect [$accessor genCode]
  1612.     $sect append "$name = new[cap $name];\n"
  1613.     }
  1614. }
  1615.  
  1616. method FTGDataAttr::genVirtAttrib {this tgtClass tgtType} {
  1617.     set name [$this getName]
  1618.     if {$tgtType == ""} {
  1619.     m4_error $E_ATTR_HAS_NO "Virtual " $name [$tgtClass name] " type"
  1620.     return
  1621.     }
  1622.     set getExpr [$this getPropertyValue get_expr]
  1623.     if {[string trim $getExpr] == ""} {
  1624.     m4_error $E_ATTR_HAS_NO "Virtual " $name [$tgtClass name] " get expression"
  1625.     return
  1626.     }
  1627.     set attr [FTVirtAttrib new $name $tgtType [$this getAccess] $tgtClass $getExpr]
  1628.     set setExpr [$this getPropertyValue set_expr]
  1629.     if {[string trim $setExpr] != ""} {
  1630.     $attr setExpr $setExpr
  1631.     }
  1632. }
  1633.  
  1634. method FTGDataAttr::genConstAttrib {this tgtClass tgtType} {
  1635.     set name [$this getName]
  1636.     set value [$this getInitialValue]
  1637.     if {[string trim $value] == ""} {
  1638.     m4_error $E_ATTR_HAS_NO "Constant " $name [$tgtClass name] " value"
  1639.     return
  1640.     }
  1641.     FTConstAttrib new $name "" [$this getAccess] $tgtClass $value
  1642. }
  1643.  
  1644. # Do not delete this line -- regeneration end marker
  1645.  
  1646. Class FTGDataAttrD : {FTGDataAttr OPDataAttr} {
  1647. }
  1648.  
  1649. selfPromoter OPDataAttr {this} {
  1650.     FTGDataAttrD promote $this
  1651. }
  1652.  
  1653. #      File:           @(#)ftggenasso.tcl    /main/hindenburg/5
  1654.  
  1655.  
  1656. Class FTGGenAssocAttr : {FTGAttribute} {
  1657.     constructor
  1658.     method destructor
  1659.     method generate
  1660.     method genAddAccessor
  1661.     method genGetAccessor
  1662.     method genGetManyAccessor
  1663.     method genRemoveAccessor
  1664.     method genSetAccessor
  1665.     method genAssocVariable
  1666.     method getAssocIdentifier
  1667.     method getAssocVariable
  1668.     method extendAssoc
  1669.     method reduceAssoc
  1670.     method setAssoc
  1671.     method getMaxVolume
  1672.     method overruleAccess
  1673.     method hasLegalDest
  1674.     attribute tgtAttrib
  1675. }
  1676.  
  1677. constructor FTGGenAssocAttr {class this name} {
  1678.     set this [FTGAttribute::constructor $class $this $name]
  1679.     # Start constructor user section
  1680.     # End constructor user section
  1681.     return $this
  1682. }
  1683.  
  1684. method FTGGenAssocAttr::destructor {this} {
  1685.     # Start destructor user section
  1686.     # End destructor user section
  1687. }
  1688.  
  1689. method FTGGenAssocAttr::generate {this tgtClass} {
  1690.     # empty
  1691. }
  1692.  
  1693. method FTGGenAssocAttr::genAddAccessor {this tgtClass} {
  1694.     set access [$this getAccessorAccess w]
  1695.     if {$access == "none"} {
  1696.     return
  1697.     }
  1698.  
  1699.     set ident [$this getAssocIdentifier]
  1700.     if {[$this isOrdered]} {
  1701.     set accessor [FTAccMethod new "append[cap $ident]" "" $access $tgtClass [$this tgtAttrib]]
  1702.     } else {
  1703.     set accessor [FTAccMethod new "add[cap $ident]" "" $access $tgtClass [$this tgtAttrib]]
  1704.     }
  1705.  
  1706.     if {[$this isQualified]} {
  1707.     set qualifier [$this qualifier]
  1708.     set qualType [[$qualifier ooplType] getType [$tgtClass model]]
  1709.     set qualId "[$qualifier getName]Key"
  1710.     FTParameter new $qualId input $accessor $qualType
  1711.     }
  1712.  
  1713.     set opposite [$this opposite]
  1714.     if {$opposite != "" && [$opposite isQualified]} {
  1715.     # update other side
  1716.     #
  1717.     set qualifier [$opposite qualifier]
  1718.     set qualType [[$qualifier ooplType] getType [$tgtClass model]]
  1719.     set qualId "[$qualifier getName]Key"
  1720.     FTParameter new $qualId input $accessor $qualType
  1721.     }
  1722.  
  1723.     set paramId "new[cap $ident]"
  1724.     set paramType [[$this ooplType] getType [$tgtClass model]]
  1725.     FTParameter new $paramId input $accessor $paramType
  1726.  
  1727.     set sect [$accessor genCode]
  1728.     $sect append "if ($paramId = NIL) then\n"
  1729.     $sect append "    return;\n";
  1730.     $sect append "end if;\n";
  1731.  
  1732.     if {$opposite != ""} {
  1733.     if {[$opposite getMultiplicity] == "one" &&
  1734.         ![$opposite isQualified] && ![$this isQualified]} {
  1735.         $sect append [$opposite setAssoc $paramId]
  1736.     }
  1737.     $sect append [$opposite extendAssoc $paramId]
  1738.     }
  1739.  
  1740.     if {[$this isQualified]} {
  1741.     set varName [$this getAssocVariable]
  1742.     set contType [[$this ooplType] getType [$tgtClass model]]
  1743.     if {[$this getMultiplicity] == "many"} {
  1744.         $contType arraySize [$this getMaxVolume]
  1745.     }
  1746.     set contName [$contType getTypeName $tgtClass]
  1747.  
  1748.     $tgtClass addInclude Framework
  1749.     $tgtClass addForward Object
  1750.     $sect append "theSet : $contName;\n"
  1751.     $sect append "obj : Framework.Object = $varName.Find($qualId);\n"
  1752.     $sect append "if (obj = NIL) then\n"
  1753.     $sect append "    theSet = new;\n"
  1754.     $sect append "    $varName.Enter(theSet, $qualId);\n"
  1755.     $sect append "else\n"
  1756.     $sect append "    theSet = ($contName) (obj);\n"
  1757.     $sect append "end if;\n"
  1758.     if {[$this isOrdered]} {
  1759.         $sect append "theSet.AppendRow($paramId);\n"
  1760.     } else {
  1761.         $sect append "if (theSet.FindRowForObject($paramId) = 0) then\n"
  1762.         $sect append "    theSet.AppendRow($paramId);\n"
  1763.         $sect append "end if;\n"
  1764.     }
  1765.     } else {
  1766.     $sect append [$this extendAssoc "" $paramId]
  1767.     }
  1768. }
  1769.  
  1770. method FTGGenAssocAttr::genGetAccessor {this tgtClass} {
  1771.     set access [$this getAccessorAccess r]
  1772.     if {$access == "none"} {
  1773.     return
  1774.     }
  1775.  
  1776.     set varName [$this getAssocVariable]
  1777.     set accType [[$this ooplType] getType [$tgtClass model]]
  1778.     set accessor [FTAccMethod new "get[cap $varName]" $accType $access $tgtClass [$this tgtAttrib]]
  1779.  
  1780.     set sect [$accessor genCode]
  1781.     $sect append "return $varName;\n"
  1782. }
  1783.  
  1784. method FTGGenAssocAttr::genGetManyAccessor {this tgtClass} {
  1785.     set access [$this getAccessorAccess r]
  1786.     if {$access == "none"} {
  1787.     return
  1788.     }
  1789.  
  1790.     set varName [$this getAssocVariable]
  1791.     set accType [[$this ooplType] getType [$tgtClass model]]
  1792.     $accType arraySize [$this getMaxVolume]
  1793.     set accessor [FTAccMethod new "get[cap $varName]" $accType $access $tgtClass [$this tgtAttrib]]
  1794.  
  1795.     set sect [$accessor genCode]
  1796.     $sect append "return $varName;\n"
  1797. }
  1798.  
  1799. method FTGGenAssocAttr::genRemoveAccessor {this tgtClass} {
  1800.     set access [$this getAccessorAccess w]
  1801.     if {$access == "none"} {
  1802.     return
  1803.     }
  1804.  
  1805.     set ident [$this getAssocIdentifier]
  1806.     set accessor [FTAccMethod new "remove[cap $ident]" "" $access $tgtClass [$this tgtAttrib]]
  1807.  
  1808.     set opposite [$this opposite]
  1809.     if {$opposite != "" && [$opposite isQualified]} {
  1810.     set qualifier [$opposite qualifier]
  1811.     set qualType [[$qualifier ooplType] getType [$tgtClass model]]
  1812.     set qualId "[$qualifier getName]Key"
  1813.     FTParameter new $qualId input $accessor $qualType
  1814.     }
  1815.  
  1816.     set paramId "old[cap $ident]"
  1817.     set paramType [[$this ooplType] getType [$tgtClass model]]
  1818.     FTParameter new $paramId input $accessor $paramType
  1819.  
  1820.     set sect [$accessor genCode]
  1821.     $sect append "if ($paramId = NIL) then\n"
  1822.     $sect append "    return;\n"
  1823.     $sect append "end if;\n";
  1824.  
  1825.     if {$opposite != ""} {
  1826.     $sect append [$opposite reduceAssoc $paramId]
  1827.     }
  1828.     $sect append [$this reduceAssoc "" $paramId]
  1829. }
  1830.  
  1831. method FTGGenAssocAttr::genSetAccessor {this tgtClass} {
  1832.     set access [$this getAccessorAccess w]
  1833.     if {$access == "none"} {
  1834.     return
  1835.     }
  1836.  
  1837.     set ident [$this getAssocIdentifier]
  1838.     set accessor [FTAccMethod new "set[cap $ident]" "" $access $tgtClass [$this tgtAttrib]]
  1839.  
  1840.     set opposite [$this opposite]
  1841.     if {$opposite != "" && [$opposite isQualified]} {
  1842.     set qualifier [$opposite qualifier]
  1843.     set qualType [[$qualifier ooplType] getType [$tgtClass model]]
  1844.     set qualId "[$qualifier getName]Key"
  1845.     FTParameter new $qualId input $accessor $qualType
  1846.     }
  1847.  
  1848.     set paramId "new[cap $ident]"
  1849.     set paramType [[$this ooplType] getType [$tgtClass model]]
  1850.     FTParameter new $paramId input $accessor $paramType
  1851.  
  1852.     set sect [$accessor genCode]
  1853.     if {$opposite != ""} {
  1854.     set oppName [$opposite getName]
  1855.  
  1856.     if {[$opposite isQualified]} {
  1857.         $sect append "if ($paramId != NIL) then\n"
  1858.         $sect append "    [$opposite extendAssoc $paramId]"
  1859.         $sect append "end if;\n";
  1860.     } else {
  1861.         $sect append "if ($ident != NIL) then\n"
  1862.         $sect append "    [$opposite reduceAssoc $ident]"
  1863.         $sect append "end if;\n";
  1864.  
  1865.         if {[$opposite getMultiplicity] == "one"} {
  1866.         $sect append "if ($paramId != NIL) then\n"
  1867.         $sect append "    [$opposite setAssoc $paramId]"
  1868.         $sect append "    [$opposite extendAssoc $paramId]"
  1869.         $sect append "end if;\n"
  1870.         } else {
  1871.         $sect append "if ($paramId != NIL) then\n"
  1872.         $sect append "    [$opposite extendAssoc $paramId]"
  1873.         $sect append "end if;\n"
  1874.         }
  1875.     }
  1876.     }
  1877.  
  1878.     $sect append "$ident = $paramId;\n"
  1879. }
  1880.  
  1881. method FTGGenAssocAttr::genAssocVariable {this tgtClass} {
  1882.     if {[$this isQualified]} {
  1883.     set tgtType [FTType new]
  1884.     $tgtType classType [FTCmnClass new "HashTable" [$tgtClass model] "Framework" 1]
  1885.     } else {
  1886.     set tgtType [[$this ooplType] getType [$tgtClass model]]
  1887.     if {[$this getMultiplicity] == "many"} {
  1888.         $tgtType arraySize [$this getMaxVolume]
  1889.     }
  1890.     }
  1891.  
  1892.     if {[$this opposite] != ""} {
  1893.     set access public
  1894.     } else {
  1895.     set access [$this getAccess]
  1896.     }
  1897.  
  1898.     set name [$this getAssocVariable]
  1899.     # if {[$this isQualified]} { set name "${name}Dict" }
  1900.     $this tgtAttrib [FTCmnAttrib new $name $tgtType $access $tgtClass]
  1901. }
  1902.  
  1903. method FTGGenAssocAttr::getAssocIdentifier {this} {
  1904.     if {[$this isLinkAttr]} {
  1905.     return [uncap [[$this ooplType] getName]Of[cap [$this getName]]]
  1906.     }
  1907.     return [$this getName]
  1908. }
  1909.  
  1910. method FTGGenAssocAttr::getAssocVariable {this} {
  1911.     set name [$this getAssocIdentifier]
  1912.     if {[$this getMultiplicity] == "many"} {
  1913.     set name "${name}Set"
  1914.     }
  1915.     return $name
  1916. }
  1917.  
  1918. method FTGGenAssocAttr::extendAssoc {this {prefix ""} {element "self"}} {
  1919.     if {$prefix != ""} {
  1920.     set prefix "${prefix}."
  1921.     }
  1922.  
  1923.     set varName [$this getAssocVariable]
  1924.     if {[$this isQualified]} {
  1925.     set qualId "[[$this qualifier] getName]Key"
  1926.     if {[$this getMultiplicity] == "one"} {
  1927.         return "$prefix$varName.Enter($element, $qualId);\n"
  1928.     }
  1929.  
  1930.     set ident [$this getAssocIdentifier]
  1931.     if {[$this isOrdered]} {
  1932.         return "${prefix}append[cap $ident]($qualId, $element);\n"
  1933.     }
  1934.     return "${prefix}add[cap $ident]($qualId, $element);\n"
  1935.     }
  1936.  
  1937.     if {[$this getMultiplicity] == "one"} {
  1938.     return "$prefix$varName = $element;\n"
  1939.     }
  1940.  
  1941.     if {[$this isOrdered]} {
  1942.     return "$prefix$varName.AppendRow($element);\n"
  1943.     }
  1944.  
  1945.     return "if ($prefix$varName.FindRowForObject($element) = 0) then\n    $prefix$varName.AppendRow($element);\nend if;\n"
  1946. }
  1947.  
  1948. method FTGGenAssocAttr::reduceAssoc {this {prefix ""} {element "self"}} {
  1949.     if {$prefix != ""} {
  1950.     set prefix "${prefix}."
  1951.     }
  1952.  
  1953.     set varName [$this getAssocVariable]
  1954.     if {[$this isQualified]} {
  1955.     set qualId "[[$this qualifier] getName]Key"
  1956.     if {[$this getMultiplicity] == "one"} {
  1957.         return "$prefix$varName.Remove($qualId);\n"
  1958.     }
  1959.  
  1960.     set ident [$this getAssocIdentifier]
  1961.     return "${prefix}remove[cap $ident]($qualId, $element);\n"
  1962.     }
  1963.  
  1964.     if {[$this getMultiplicity] == "one"} {
  1965.     return "$prefix$varName = NIL;\n"
  1966.     }
  1967.  
  1968.     return "$prefix$varName.DeleteRow(object = $element);\n"
  1969. }
  1970.  
  1971. method FTGGenAssocAttr::setAssoc {this {prefix ""} {element "NIL"}} {
  1972.     if {$prefix != ""} {
  1973.     set prefix "${prefix}."
  1974.     }
  1975.     return "${prefix}set[cap [$this getAssocIdentifier]]($element);\n"
  1976. }
  1977.  
  1978. method FTGGenAssocAttr::getMaxVolume {this} {
  1979.     # should be called for 'many' side only
  1980.     # defaults to 255
  1981.     #
  1982.     set maxVol [$this getPropertyValue assoc_volume]
  1983.     if {$maxVol == "" || $maxVol < 1} {
  1984.     return 255
  1985.     }
  1986.     return $maxVol
  1987. }
  1988.  
  1989. method FTGGenAssocAttr::overruleAccess {this} {
  1990.     # makes sure that the access for bidirectional assoc's and mandatory sides
  1991.     # is 'public'
  1992.     #
  1993.     if {[$this isMandatory]} {
  1994.     $this access public
  1995.     }
  1996.     if {[$this opposite] != ""} {
  1997.     $this accessorAccess public-public
  1998.     [$this opposite] accessorAccess public-public
  1999.     }
  2000. }
  2001.  
  2002. method FTGGenAssocAttr::hasLegalDest {this} {
  2003.     if {[[$this ooplType] isA OPBaseType]} {
  2004.     m4_error $E_STDT_DEST [[$this ooplClass] getKind] [[$this ooplClass] getName] [[$this ooplType] getName]
  2005.     return 0
  2006.     }
  2007.  
  2008.     set destClass [[$this ooplType] ooplClass]
  2009.     if {$destClass == ""} {
  2010.     # class without name on other side
  2011.     return 0
  2012.     }
  2013.  
  2014.     if {[$destClass getClassType] != "Class"} {
  2015.     m4_error $E_ILL_DEST [[$this ooplClass] getKind] [[$this ooplClass] getName] [$destClass getKind] [$destClass getDefSysName] [$destClass getName]
  2016.     return 0
  2017.     }
  2018.     return 1
  2019. }
  2020.  
  2021. # Do not delete this line -- regeneration end marker
  2022.  
  2023. Class FTGGenAssocAttrD : {FTGGenAssocAttr OPGenAssocAttr} {
  2024. }
  2025.  
  2026. selfPromoter OPGenAssocAttr {this} {
  2027.     FTGGenAssocAttrD promote $this
  2028. }
  2029.  
  2030. #      File:           @(#)ftgassocat.tcl    /main/hindenburg/3
  2031.  
  2032.  
  2033. Class FTGAssocAttr : {FTGGenAssocAttr} {
  2034.     constructor
  2035.     method destructor
  2036.     method generate
  2037. }
  2038.  
  2039. constructor FTGAssocAttr {class this name} {
  2040.     set this [FTGGenAssocAttr::constructor $class $this $name]
  2041.     # Start constructor user section
  2042.     # End constructor user section
  2043.     return $this
  2044. }
  2045.  
  2046. method FTGAssocAttr::destructor {this} {
  2047.     # Start destructor user section
  2048.     # End destructor user section
  2049. }
  2050.  
  2051. method FTGAssocAttr::generate {this tgtClass} {
  2052.     if {![$this hasLegalDest]} {
  2053.     return
  2054.     }
  2055.  
  2056.     $this genAssocVariable $tgtClass
  2057.  
  2058.     $this overruleAccess
  2059.  
  2060.     if {[$this getMultiplicity] == "one"} {
  2061.     $this genGetAccessor $tgtClass
  2062.     $this genSetAccessor $tgtClass
  2063.     } else {
  2064.     $this genAddAccessor $tgtClass
  2065.     $this genRemoveAccessor $tgtClass
  2066.     $this genGetManyAccessor $tgtClass
  2067.     }
  2068. }
  2069.  
  2070. # Do not delete this line -- regeneration end marker
  2071.  
  2072. Class FTGAssocAttrD : {FTGAssocAttr OPAssocAttr} {
  2073. }
  2074.  
  2075. selfPromoter OPAssocAttr {this} {
  2076.     FTGAssocAttrD promote $this
  2077. }
  2078.  
  2079. #      File:           @(#)ftglinkatt.tcl    /main/hindenburg/3
  2080.  
  2081.  
  2082. Class FTGLinkAttr : {FTGGenAssocAttr} {
  2083.     constructor
  2084.     method destructor
  2085.     method generate
  2086. }
  2087.  
  2088. constructor FTGLinkAttr {class this name} {
  2089.     set this [FTGGenAssocAttr::constructor $class $this $name]
  2090.     # Start constructor user section
  2091.     # End constructor user section
  2092.     return $this
  2093. }
  2094.  
  2095. method FTGLinkAttr::destructor {this} {
  2096.     # Start destructor user section
  2097.     # End destructor user section
  2098. }
  2099.  
  2100. method FTGLinkAttr::generate {this tgtClass} {
  2101.     if {![$this hasLegalDest]} {
  2102.     return
  2103.     }
  2104.  
  2105.     $this genAssocVariable $tgtClass
  2106.  
  2107.     $this overruleAccess
  2108.  
  2109.     if {[$this getMultiplicity] == "one"} {
  2110.     $this genGetAccessor $tgtClass
  2111.     } else {
  2112.     $this genGetManyAccessor $tgtClass
  2113.     }
  2114. }
  2115.  
  2116. # Do not delete this line -- regeneration end marker
  2117.  
  2118. Class FTGLinkAttrD : {FTGLinkAttr OPLinkAttr} {
  2119. }
  2120.  
  2121. selfPromoter OPLinkAttr {this} {
  2122.     FTGLinkAttrD promote $this
  2123. }
  2124.  
  2125. #      File:           @(#)ftgqualatt.tcl    /main/hindenburg/5
  2126.  
  2127.  
  2128. Class FTGQualAttr : {FTGGenAssocAttr} {
  2129.     constructor
  2130.     method destructor
  2131.     method generate
  2132.     method genGetQualifiedAccessor
  2133.     method genRemoveQualifiedAccessor
  2134.     method genSetQualifiedAccessor
  2135. }
  2136.  
  2137. constructor FTGQualAttr {class this name} {
  2138.     set this [FTGGenAssocAttr::constructor $class $this $name]
  2139.     # Start constructor user section
  2140.     # End constructor user section
  2141.     return $this
  2142. }
  2143.  
  2144. method FTGQualAttr::destructor {this} {
  2145.     # Start destructor user section
  2146.     # End destructor user section
  2147. }
  2148.  
  2149. method FTGQualAttr::generate {this tgtClass} {
  2150.     if {![$this hasLegalDest]} {
  2151.     return
  2152.     }
  2153.  
  2154.     $this overruleAccess
  2155.  
  2156.     $this genAssocVariable $tgtClass
  2157.     $this genGetQualifiedAccessor $tgtClass
  2158.  
  2159.     if {[$this getMultiplicity] == "one"} {
  2160.     $this genSetQualifiedAccessor $tgtClass
  2161.     } else {
  2162.     $this genAddAccessor $tgtClass
  2163.     }
  2164.  
  2165.     $this genRemoveQualifiedAccessor $tgtClass
  2166. }
  2167.  
  2168. method FTGQualAttr::genGetQualifiedAccessor {this tgtClass} {
  2169.     set access [$this getAccessorAccess r]
  2170.     if {$access == "none"} {
  2171.     return
  2172.     }
  2173.  
  2174.     set varName [$this getAssocVariable]
  2175.     set accType [[$this ooplType] getType [$tgtClass model]]
  2176.     if {[$this getMultiplicity] == "many"} {
  2177.     $accType arraySize [$this getMaxVolume]
  2178.     }
  2179.     set accessor [FTAccMethod new "get[cap $varName]" $accType public $tgtClass [$this tgtAttrib]]
  2180.  
  2181.     set qualifier [$this qualifier]
  2182.     set qualType [[$qualifier ooplType] getType [$tgtClass model]]
  2183.     set qualId "[$qualifier getName]Key"
  2184.     FTParameter new $qualId input $accessor $qualType
  2185.  
  2186.     if {[$tgtClass constructor] != ""} {
  2187.     set sect [[$tgtClass constructor] genCode]
  2188.     $sect append "-- ! the user should initialize HashTable '$varName' properly\n"
  2189.     $sect append "-- ! by calling ``$varName.Setup(...)'' in the user section\n"
  2190.     $sect append "--\n"
  2191.     m4_message $M_INITIALIZE [$tgtClass name] $varName [$tgtClass name]
  2192.     }
  2193.  
  2194.     set sect [$accessor genCode]
  2195.     $tgtClass addInclude Framework
  2196.     $tgtClass addForward Object
  2197.     $sect append "obj : Framework.Object = $varName.Find($qualId);\n"
  2198.     $sect append "if (obj != NIL) then\n"
  2199.     $sect append "    return ([$accType getTypeName $tgtClass]) (obj);\n"
  2200.     $sect append "end if;\n"
  2201.     $sect append "return NIL;\n"
  2202. }
  2203.  
  2204. method FTGQualAttr::genRemoveQualifiedAccessor {this tgtClass} {
  2205.     set access [$this getAccessorAccess w]
  2206.     if {$access == "none"} {
  2207.     return
  2208.     }
  2209.  
  2210.     set ident [$this getAssocIdentifier]
  2211.     set accessor [FTAccMethod new "remove[cap $ident]" "" $access $tgtClass [$this tgtAttrib]]
  2212.  
  2213.     set qualifier [$this qualifier]
  2214.     set qualType [[$qualifier ooplType] getType [$tgtClass model]]
  2215.     set qualId "[$qualifier getName]Key"
  2216.     FTParameter new $qualId input $accessor $qualType
  2217.  
  2218.     set paramId "old[cap $ident]"
  2219.     set opposite [$this opposite]
  2220.     set varName [$this getAssocVariable]
  2221.  
  2222.     set sect [$accessor genCode]
  2223.     set contType [[$this ooplType] getType [$tgtClass model]]
  2224.     if {[$this getMultiplicity] == "one"} {
  2225.     $tgtClass addInclude Framework
  2226.     $tgtClass addForward Object
  2227.     $sect append "obj : Framework.Object = $varName.Find($qualId);\n"
  2228.     $sect append "if (obj = NIL) then\n"
  2229.     $sect append "    return;\n"
  2230.     $sect append "end if;\n"
  2231.     $sect append [$this reduceAssoc]
  2232.  
  2233.     if {$opposite != ""} {
  2234.         set contName [$contType getTypeName $tgtClass]
  2235.         $sect append "$paramId : $contName = ($contName) (obj);\n"
  2236.     }
  2237.     } else {
  2238.     FTParameter new $paramId input $accessor [[$this ooplType] getType [$tgtClass model]]
  2239.     $contType arraySize [$this getMaxVolume]
  2240.     set contName [$contType getTypeName $tgtClass]
  2241.  
  2242.     $tgtClass addInclude Framework
  2243.     $tgtClass addForward Object
  2244.     $sect append "if ($paramId = NIL) then\n"
  2245.     $sect append "    return;\n"
  2246.     $sect append "end if;\n"
  2247.     $sect append "obj : Framework.Object = $varName.Find($qualId);\n";
  2248.     $sect append "if (obj != NIL) then\n";
  2249.     $sect append "    theSet : $contName = ($contName) (obj);\n";
  2250.     $sect append "    theSet.DeleteRow(object = $paramId);\n"
  2251.     $sect append "end if;\n"
  2252.     }
  2253.  
  2254.     if {$opposite != ""} {
  2255.     $sect append [$opposite reduceAssoc $paramId]
  2256.     }
  2257. }
  2258.  
  2259. method FTGQualAttr::genSetQualifiedAccessor {this tgtClass} {
  2260.     set access [$this getAccessorAccess w]
  2261.     if {$access == "none"} {
  2262.     return
  2263.     }
  2264.  
  2265.     set ident [$this getAssocIdentifier]
  2266.     set accessor [FTAccMethod new "set[cap $ident]" "" $access $tgtClass [$this tgtAttrib]]
  2267.  
  2268.     set qualifier [$this qualifier]
  2269.     set qualType [[$qualifier ooplType] getType [$tgtClass model]]
  2270.     set qualId "[$qualifier getName]Key"
  2271.     FTParameter new $qualId input $accessor $qualType
  2272.  
  2273.     set paramId "new[cap $ident]"
  2274.     FTParameter new $paramId input $accessor [[$this ooplType] getType [$tgtClass model]]
  2275.  
  2276.     set sect [$accessor genCode]
  2277.     $sect append "if ($paramId = NIL) then\n"
  2278.     $sect append "    return;\n"
  2279.     $sect append "end if;\n";
  2280.     $sect append "$ident.Enter($paramId, $qualId);\n"
  2281.  
  2282.     set opposite [$this opposite]
  2283.     if {$opposite != ""} {
  2284.     $sect append [$opposite extendAssoc $paramId]
  2285.     }
  2286. }
  2287.  
  2288. # Do not delete this line -- regeneration end marker
  2289.  
  2290. Class FTGQualAttrD : {FTGQualAttr OPQualAttr} {
  2291. }
  2292.  
  2293. selfPromoter OPQualAttr {this} {
  2294.     FTGQualAttrD promote $this
  2295. }
  2296.  
  2297. #      File:           @(#)ftgreverse.tcl    /main/hindenburg/3
  2298.  
  2299.  
  2300. Class FTGReverseLinkAttr : {FTGGenAssocAttr} {
  2301.     constructor
  2302.     method destructor
  2303.     method generate
  2304. }
  2305.  
  2306. constructor FTGReverseLinkAttr {class this name} {
  2307.     set this [FTGGenAssocAttr::constructor $class $this $name]
  2308.     # Start constructor user section
  2309.     # End constructor user section
  2310.     return $this
  2311. }
  2312.  
  2313. method FTGReverseLinkAttr::destructor {this} {
  2314.     # Start destructor user section
  2315.     # End destructor user section
  2316. }
  2317.  
  2318. method FTGReverseLinkAttr::generate {this tgtClass} {
  2319.     if {![$this hasLegalDest]} {
  2320.     return
  2321.     }
  2322.  
  2323.     $this genAssocVariable $tgtClass
  2324.  
  2325.     $this overruleAccess
  2326.  
  2327.     if {[$this getMultiplicity] == "one"} {
  2328.     $this genGetAccessor $tgtClass
  2329.     } else {
  2330.     $this genGetManyAccessor $tgtClass
  2331.     }
  2332. }
  2333.  
  2334. # Do not delete this line -- regeneration end marker
  2335.  
  2336. Class FTGReverseLinkAttrD : {FTGReverseLinkAttr OPReverseLinkAttr} {
  2337. }
  2338.  
  2339. selfPromoter OPReverseLinkAttr {this} {
  2340.     FTGReverseLinkAttrD promote $this
  2341. }
  2342.  
  2343. #      File:           @(#)ftgqualass.tcl    /main/hindenburg/2
  2344.  
  2345.  
  2346. Class FTGQualAssocAttr : {FTGQualAttr} {
  2347.     constructor
  2348.     method destructor
  2349. }
  2350.  
  2351. constructor FTGQualAssocAttr {class this name} {
  2352.     set this [FTGQualAttr::constructor $class $this $name]
  2353.     # Start constructor user section
  2354.     # End constructor user section
  2355.     return $this
  2356. }
  2357.  
  2358. method FTGQualAssocAttr::destructor {this} {
  2359.     # Start destructor user section
  2360.     # End destructor user section
  2361. }
  2362.  
  2363. # Do not delete this line -- regeneration end marker
  2364.  
  2365. Class FTGQualAssocAttrD : {FTGQualAssocAttr OPQualAssocAttr} {
  2366. }
  2367.  
  2368. selfPromoter OPQualAssocAttr {this} {
  2369.     FTGQualAssocAttrD promote $this
  2370. }
  2371.  
  2372. #      File:           @(#)ftgquallin.tcl    /main/hindenburg/2
  2373.  
  2374.  
  2375. Class FTGQualLinkAttr : {FTGQualAttr} {
  2376.     constructor
  2377.     method destructor
  2378. }
  2379.  
  2380. constructor FTGQualLinkAttr {class this name} {
  2381.     set this [FTGQualAttr::constructor $class $this $name]
  2382.     # Start constructor user section
  2383.     # End constructor user section
  2384.     return $this
  2385. }
  2386.  
  2387. method FTGQualLinkAttr::destructor {this} {
  2388.     # Start destructor user section
  2389.     # End destructor user section
  2390. }
  2391.  
  2392. # Do not delete this line -- regeneration end marker
  2393.  
  2394. Class FTGQualLinkAttrD : {FTGQualLinkAttr OPQualLinkAttr} {
  2395. }
  2396.  
  2397. selfPromoter OPQualLinkAttr {this} {
  2398.     FTGQualLinkAttrD promote $this
  2399. }
  2400.