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