home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / delphioopl.tcl < prev    next >
Encoding:
Text File  |  1997-11-07  |  122.7 KB  |  5,059 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            : delphioopl.tcl
  17. #       Author          : 
  18. #       Original date   : November 1997
  19. #       Description     : Classes for code generation
  20. #
  21. #---------------------------------------------------------------------------
  22.  
  23.  
  24. #      File:           @(#)dpgclass.tcl    /main/titanic/24
  25.  
  26.  
  27. Class DPGClass : {Object} {
  28.     constructor
  29.     method destructor
  30.     method baseType
  31.     method isGUIComponent
  32.     method isComponent
  33.     method isComponentClass
  34.     method isComponentDummy
  35.     method isControl
  36.     method isDataModule
  37.     method isDerivable
  38.     method isForm
  39.     method getUnitName
  40.     method getClassType
  41.     method getFormVarName
  42.     method getFormTypeName
  43.     method getSuperClass
  44.     method generateComponent
  45.     method generateType
  46.     method generateFormClass
  47.     method generateInterface
  48.     method generateRecord
  49.     method generate
  50.     method check
  51.     method checkComponent
  52.     method checkComponentLocal
  53.     method checkLocal
  54.     attribute bseType
  55.     attribute doneComponent
  56.     attribute target
  57. }
  58.  
  59. constructor DPGClass {class this name} {
  60.     set this [Object::constructor $class $this $name]
  61.     $this doneComponent 0
  62.     # Start constructor user section
  63.     # End constructor user section
  64.     return $this
  65. }
  66.  
  67. method DPGClass::destructor {this} {
  68.     # Start destructor user section
  69.     # End destructor user section
  70. }
  71.  
  72. method DPGClass::baseType {this} {
  73.     set classtype [$this getClassType]
  74.     if {$classtype != "Class"} {
  75.         return [$this bseType]
  76.     }
  77.     if {[$this bseType] == ""} {
  78.         set super $this
  79.  
  80.         if {[$super getName] != "TForm" &&
  81.             [$super getName] != "TControl" &&
  82.             [$super getName] != "TComponent" &&
  83.             [$super getName] != "TDataModule"} {
  84.  
  85.             while {[$super getSuperClass] != ""} {
  86.                 set super [$super getSuperClass]
  87.                 if {[$super getName] == "TForm" || 
  88.                     [$super getName] == "TControl" ||
  89.                     [$super getName] == "TComponent" ||
  90.                     [$super getName] == "TDataModule"} {
  91.                     break;
  92.                 }
  93.             }
  94.         }
  95.  
  96.         switch [$super getName] {
  97.             "TForm"        {
  98.                 $this bseType [$super getName]
  99.             }
  100.             "TControl"    {
  101.                 $this bseType [$super getName]
  102.             }
  103.             "TComponent"    {
  104.                 $this bseType [$super getName]
  105.             }
  106.             "TDataModule"    {
  107.                 $this bseType [$super getName]
  108.             }
  109.             default            {
  110.                 $this bseType "Class"
  111.             }
  112.         }
  113.     }
  114.  
  115.     return [$this bseType]
  116. }
  117.  
  118. method DPGClass::isGUIComponent {this} {
  119.     if {[$this isForm] || [$this isComponent]} {
  120.         return 1
  121.     } else {
  122.         return 0
  123.     }
  124. }
  125.  
  126. method DPGClass::isComponent {this} {
  127.     if {[$this baseType] == "TComponent" || [$this isControl]} {
  128.         return 1
  129.     } else { 
  130.         return 0
  131.     }
  132. }
  133.  
  134. method DPGClass::isComponentClass {this} {
  135.     if {[$this isGUIComponent] && [$this getPropertyValue "is_declaration"] == 1} {
  136.         return 1
  137.     } else { 
  138.         return 0
  139.     }
  140. }
  141.  
  142. method DPGClass::isComponentDummy {this} {
  143.     if {[$this isComponent] && [$this getPropertyValue "is_declaration"] != "1"} {
  144.         return 1
  145.     } else { 
  146.         return 0
  147.     }
  148. }
  149.  
  150. method DPGClass::isControl {this} {
  151.     if {[$this baseType] == "TControl"} {
  152.         return 1
  153.     } else { 
  154.         return 0
  155.     }
  156. }
  157.  
  158. method DPGClass::isDataModule {this} {
  159.     if {[$this baseType] == "TDataModule"} {
  160.         return 1
  161.     } else { 
  162.         return 0
  163.     }
  164. }
  165.  
  166. method DPGClass::isDerivable {this} {
  167.     if {[$this isComponentDummy]} {
  168.         return 0
  169.     } else {
  170.         return 1
  171.     }
  172. }
  173.  
  174. method DPGClass::isForm {this} {
  175.     if {[$this baseType] == "TForm" || [$this isDataModule]} {
  176.         return 1
  177.     } else {
  178.         return 0
  179.     }
  180. }
  181.  
  182. method DPGClass::getUnitName {this} {
  183.     return "[$this getName]Unit"
  184. }
  185.  
  186. method DPGClass::getClassType {this} {
  187.     set type [$this getPropertyValue "class_type"]
  188.     if {$type == ""} {
  189.         set type "Class"
  190.     }
  191.     return $type
  192. }
  193.  
  194. method DPGClass::getFormVarName {this} {
  195.     set name [string range [$this getName] 1 [expr [string length [$this getName]] + 1]]
  196.     return $name
  197. }
  198.  
  199. method DPGClass::getFormTypeName {this} {
  200.     #if {[$this getName] != "TForm" && [$this getName] != "TDataModule"} {
  201.     #    return "T[$this getName]"
  202.     #} else {
  203.         return [$this getName]
  204.     #}
  205. }
  206.  
  207. method DPGClass::getSuperClass {this} {
  208.     foreach node [$this genNodeSet] {
  209.         set classtype [[$node superClass] getClassType]
  210.         if {$classtype == "Class"} {
  211.             return [$node superClass]
  212.         }
  213.     }
  214.     return ""
  215. }
  216.  
  217. method DPGClass::generateComponent {this role class control} {
  218.     if {[$this checkComponentLocal $role [$class form]] > 0} {
  219.         return
  220.     }
  221.  
  222.     # Create new component
  223.     #
  224.     set ctrlType [[$this getSuperClass] generateType]
  225.     set newcontrol [DPControl new $ctrlType]
  226.     $newcontrol name $role
  227.     set props [DPTextSection new]
  228.     $newcontrol properties $props
  229.     $newcontrol compclass [$this getName]
  230.  
  231.     # Add new component to child list of parent
  232.     $control addChild $newcontrol
  233.  
  234.     # Set Field property
  235.     $control controlType "normal"
  236.     if {[$this isComponent] && ([$this isControl] == 0)} {
  237.         set super $this
  238.         while {[$super getSuperClass] != ""} {
  239.             if {[$super getName] == "TField"} {
  240.                 $newcontrol controlType "TField"
  241.                 break;
  242.             }
  243.             set super [$super getSuperClass]
  244.         }
  245.     }
  246.  
  247.     # Add new component to form
  248.     [$class form] setControl [$newcontrol name] $newcontrol
  249.     
  250.     # Generate child components
  251.     $this doneComponent 1
  252.     foreach assoc [$this genAssocAttrSet] {
  253.         if {[$assoc hasGUIComponent]} {
  254.             $assoc generateComponent $class $newcontrol
  255.         }
  256.     }
  257.     $this doneComponent 0
  258.  
  259.     # Generate events
  260.     foreach operation [$this operationSet] {
  261.         if {[$operation isEvent]} {
  262.             set event [$operation generateEvent $class $newcontrol]
  263.             # Only add event if found
  264.             if {$event != ""} {
  265.                 set controlevent [DPControlEvent new $event]
  266.                 $controlevent name [$operation getName] 
  267.                 $newcontrol addEvent $controlevent
  268.             }
  269.         }
  270.     }
  271. }
  272.  
  273. method DPGClass::generateType {this} {
  274.     set type [DPType new]
  275.     $type includeType "user"
  276.     $type includeName [$this getUnitName]
  277.     if {[$this isForm]} {
  278.         $type name [$this getFormTypeName]
  279.     } else {
  280.         $type name "[$this getName]"
  281.     }
  282.  
  283.     set libunit [$this getPropertyValue "libunit"]
  284.     if {$libunit != "None" && $libunit != ""} {
  285.         $type includeType "system"
  286.         if {$libunit == "Other"} {
  287.             $type includeName [$this getPropertyValue "userlib"]
  288.         } else {
  289.             $type includeName $libunit
  290.         }
  291.     }
  292.     return $type
  293. }
  294.  
  295. method DPGClass::generateFormClass {this tgt unit form} {
  296.  
  297.     # Set form instance properties
  298.     $form name "[$this getFormVarName]"
  299.     set props [DPTextSection new]
  300.     $form properties $props
  301.  
  302.     $unit name [[$form type] name]
  303.     $this target $unit
  304.  
  305.     # Create global form variable
  306.     set formvar [DPVariable new [$form type]]
  307.     $formvar name "[$this getFormVarName]"
  308.     $formvar formVar 1
  309.     $unit addGlobvar $formvar
  310.  
  311.     # Hook form to project
  312.     $tgt setForm [$formvar name] $form
  313.  
  314.     # Generate events
  315.     foreach operation [$this operationSet] {
  316.         if {[$operation isEvent]} {
  317.             set event [$operation generateEvent $unit $form]
  318.             # Only add events if found
  319.             if {$event != ""} {
  320.                 set controlevent [DPControlEvent new $event]
  321.                 $controlevent name [$operation getName] 
  322.                 $form addEvent $controlevent
  323.             }
  324.         }
  325.     }
  326.  
  327.     # Generate components
  328.     foreach assoc [$this genAssocAttrSet] {
  329.         if {[$assoc hasGUIComponent]} {
  330.             $assoc generateComponent $unit $form
  331.         }
  332.     }
  333. }
  334.  
  335. method DPGClass::generateInterface {this tgt} {
  336.     set unit [DPInterfaceUnit new]
  337.     $this target $unit
  338.     set type [$this generateType]
  339.     $unit name "[$type name]"
  340.  
  341.     # Hook to project
  342.  
  343.     $tgt setUnit [$this getName] $unit
  344.  
  345.     # Set unit attributes
  346.     
  347.     $unit unitName "[$this getUnitName]"
  348.     
  349.     # comment
  350.  
  351.     set comment [DPComment new]
  352.     $unit comment $comment
  353.     $comment comment [$this getPropertyValue "freeText"]
  354.  
  355.     # identifier
  356.  
  357.     $unit interface_id [$this getPropertyValue "interface_id"]
  358.  
  359.     # Generate superclass
  360.  
  361.     foreach genNode [$this genNodeSet] {
  362.         $genNode generate $unit
  363.     }
  364.  
  365.     # Generate methods
  366.  
  367.     foreach feature [$this operationSet] {
  368.         $feature generate $unit
  369.     }
  370.  
  371.     # Generate properties (attributes)
  372.  
  373.     foreach feature [$this dataAttrSet] {
  374.         $feature generate $unit
  375.     }
  376. }
  377.  
  378. method DPGClass::generateRecord {this tgt} {
  379.     set unit [DPRecordUnit new]
  380.     $this target $unit
  381.     set type [$this generateType]
  382.     $unit name "[$type name]"
  383.  
  384.     # Hook to project
  385.  
  386.     $tgt setUnit [$this getName] $unit
  387.  
  388.     # Set unit attributes
  389.     
  390.     $unit unitName "[$this getUnitName]"
  391.     
  392.     # comment
  393.  
  394.     set comment [DPComment new]
  395.     $unit comment $comment
  396.     $comment comment [$this getPropertyValue "freeText"]
  397.  
  398.     # Generate attributes
  399.  
  400.     foreach feature [$this dataAttrSet] {
  401.         $feature generate $unit
  402.     }
  403. }
  404.  
  405. method DPGClass::generate {this tgt} {
  406.     if {[$this checkLocal] > 0} {
  407.         return
  408.     }
  409.  
  410.     # Check if class is a record class
  411.  
  412.     if {[$this getClassType] == "Record"} {
  413.         $this generateRecord $tgt
  414.         return
  415.     }
  416.  
  417.     # Check if class is an interface class
  418.  
  419.     if {[$this getClassType] == "Interface"} {
  420.         $this generateInterface $tgt
  421.         return
  422.     }
  423.  
  424.     # Hook unit to project
  425.     
  426.     switch [$this baseType] {
  427.         "TDataModule" {
  428.  
  429.             # Create data module class
  430.             #
  431.             set formtype [$this generateType]
  432.             set form [DPForm new $formtype]
  433.             set unit [DPFormClass new $form]
  434.             $unit formType "datamodule"
  435.  
  436.             $this generateFormClass $tgt $unit $form
  437.         }
  438.         "TForm" {
  439.  
  440.             # Create form class
  441.             #
  442.             set formtype [$this generateType]
  443.             set form [DPForm new $formtype]
  444.             set unit [DPFormClass new $form]
  445.  
  446.             $this generateFormClass $tgt $unit $form
  447.         }
  448.         "Class" {
  449.             set unit [DPClass new]
  450.             $this target $unit
  451.             set type [$this generateType]
  452.             $unit name "[$type name]"
  453.         }
  454.         "TControl" -
  455.         "TComponent" {
  456.             if {[$this isComponentDummy]} {
  457.                 return
  458.             }
  459.             set unit [DPClass new]
  460.             $this target $unit
  461.             set type [$this generateType]
  462.             $unit name "[$type name]"
  463.         }
  464.         default {
  465.             return
  466.         }
  467.     }
  468.     $tgt setUnit [$this getName] $unit
  469.  
  470.     # Set unit attributes
  471.     
  472.     $unit unitName "[$this getUnitName]"
  473.     
  474.     # comment
  475.  
  476.     set comment [DPComment new]
  477.     $unit comment $comment
  478.     $comment comment [$this getPropertyValue "freeText"]
  479.  
  480.     # Generate superclass
  481.  
  482.     foreach genNode [$this genNodeSet] {
  483.         $genNode generate $unit
  484.     }
  485.  
  486.     # Generate attributes
  487.  
  488.     foreach feature [$this dataAttrSet] {
  489.         $feature generate $unit
  490.     }
  491.  
  492.     # Generate methods
  493.  
  494.     foreach feature [$this operationSet] {
  495.         $feature generate $unit
  496.     }
  497.  
  498.     # Generate constructor
  499.  
  500.     if {[$this constructor] != ""} {
  501.         [$this constructor] generate $unit
  502.     }
  503.  
  504.     # Generate destructor
  505.  
  506.     set dtor [DPDestructor new]
  507.     $dtor isOverride 1
  508.     $dtor name "Destroy"
  509.     $dtor access "Public"
  510.     $dtor userCodeFirst 1
  511.     $dtor gencode [DPTextSection new]
  512.     $dtor gentypes [DPTextSection new]
  513.     $unit destructr $dtor
  514.  
  515.     # Generate associations
  516.  
  517.     foreach assoc [$this genAssocAttrSet] {
  518.         $assoc generate $unit
  519.     }
  520.  
  521.     # Old destructor is last thing to call in a destructor
  522.     [$dtor gencode] append "\ninherited Destroy;\n"
  523. }
  524.  
  525. method DPGClass::check {this} {
  526.  
  527.     set errornr [$this checkLocal]
  528.     set componentList ""
  529.  
  530.     # Form class components
  531.     if {[$this isForm]} {
  532.         set form [DPForm new [DPType new]]
  533.         foreach assoc [$this genAssocAttrSet] {
  534.             if {[$assoc hasGUIComponent]} {
  535.                 $assoc checkComponent $form
  536.             }
  537.         }
  538.     }
  539.     # Superclasses
  540.     foreach genNode [$this genNodeSet] {
  541.         incr errornr [$genNode check]
  542.     }
  543.     # Attributes
  544.     foreach feature [$this dataAttrSet] {
  545.         incr errornr [$feature check]
  546.     }
  547.     # Methods
  548.     foreach feature [$this operationSet] {
  549.         incr errornr [$feature check]
  550.     }
  551.     # Constructor
  552.     if {[$this constructor] != ""} {
  553.         incr errornr [[$this constructor] check]
  554.     }
  555.     # Associations
  556.     foreach assoc [$this genAssocAttrSet] {
  557.         incr errornr [$assoc check]
  558.     }
  559.  
  560.     return $errornr
  561. }
  562.  
  563. method DPGClass::checkComponent {this componentName form} {
  564.     set errornr [$this checkComponentLocal $componentName $form]
  565.     set tmpControl [DPControl new [DPType new]]
  566.     $form setControl $componentName $tmpControl
  567.  
  568.     # Check child components
  569.     $this doneComponent 1
  570.     foreach assoc [$this genAssocAttrSet] {
  571.         if {[$assoc hasGUIComponent]} {
  572.             incr errornr [$assoc checkComponent $form]
  573.         }
  574.     }
  575.     $this doneComponent 0
  576.  
  577.     # Check events
  578.     foreach operation [$this operationSet] {
  579.         if {[$operation isEvent]} {
  580.             incr errornr [$operation checkEvent $componentName]
  581.         }
  582.     }
  583.     return $errornr
  584. }
  585.  
  586. method DPGClass::checkComponentLocal {this componentName form} {
  587.     set errornr 0
  588.  
  589.     # Check for double defined components
  590.     #
  591.     if {![$this isForm]} {
  592.         if {[$form getControl $componentName] != ""} {
  593.             m4_error $E_COMPDBDEF $componentName
  594.             incr errornr 1
  595.         }
  596.     }
  597.  
  598.     # Check for component loop
  599.     #
  600.     if {[$this doneComponent] == 1} {
  601.         m4_error $E_COMPLOOP $componentName
  602.         incr errornr 1
  603.     }
  604.  
  605.     # Check if all methods are events for components
  606.     #
  607.     foreach operation [$this operationSet] {
  608.         if {![$operation isEvent]} {
  609.             if {![$this isForm]} {
  610.                 m4_error $E_CANTCONTMETH [$this getName]
  611.                 incr errornr 1
  612.             }
  613.         }
  614.     }
  615.  
  616.     # Check associations
  617.     #
  618.  
  619.     if {[$this isComponent]} {
  620.         foreach assoc [$this genAssocAttrSet] {
  621.             if {![$assoc hasGUIComponent]} {
  622.                 m4_error $E_CANTCONTASSOC $componentName
  623.                 incr errornr 1
  624.             }
  625.         }
  626.     }
  627.  
  628.     # Check that components only contain components and controls only contain controls (except TForm)
  629.     #
  630.  
  631.     if {[$this isComponent] || [$this isDataModule]} {
  632.         if {[$this isControl]} {
  633.             foreach assoc [$this genAssocAttrSet] {
  634.                 if {[$assoc hasGUIComponent] != "2"} {
  635.                     m4_error $E_CANTCONTCOMP [$this getName] [$assoc getName]
  636.                     incr errornr 1
  637.                 }
  638.             }
  639.         } else {
  640.             foreach assoc [$this genAssocAttrSet] {
  641.                 if {[$assoc hasGUIComponent] != "1"} {
  642.                     m4_error $E_CANTCONTCTRL $componentName [$assoc getName]
  643.                     incr errornr 1
  644.                 }
  645.             }
  646.         }
  647.     }
  648.  
  649.     # Check Attributes
  650.     #
  651.     if {![$this isForm]} {
  652.         if {[llength [$this dataAttrSet]] > 0}  {
  653.             m4_error $E_CANTCONTATTR $componentName
  654.             incr errornr 1
  655.         }
  656.     }
  657.  
  658.     return $errornr
  659. }
  660.  
  661. method DPGClass::checkLocal {this} {
  662.     set errornr 0
  663.  
  664.     # Check form name
  665.     #
  666.     if {[$this isForm]} {
  667.         if {[string length [$this getFormTypeName]] < 2} {
  668.             incr errornr
  669.             m4_error $E_FORMMINTWO [$this getFormTypeName]
  670.         }
  671.         if {[string index [string toupper [$this getFormTypeName]] 0] != "T"} {
  672.             incr errornr
  673.             m4_error $E_FORMFIRSTT [$this getFormTypeName]
  674.         }
  675.         set tmpchar [string index [$this getFormTypeName] 1]
  676.         if {![string match {[A-Za-z]} $tmpchar]} {
  677.             incr errornr
  678.             m4_error $E_FORMMINTWO [$this getFormTypeName]
  679.         }
  680.     }
  681.  
  682.     # Check if correct class type
  683.     #
  684.     set classtype [$this getClassType]
  685.     if {($classtype != "Class") && \
  686.         ($classtype != "Interface") && \
  687.         ($classtype != "Record")} {
  688.         incr errornr
  689.         m4_error $E_ILLCLASSTYPE [$this getName]
  690.     }
  691.  
  692.     # Check record class
  693.     #
  694.     if {$classtype == "Record"} {
  695.         if {[$this operationSet] != ""} {
  696.             incr errornr
  697.             m4_error $E_NOMETHODS [$this getName]
  698.         }
  699.     }
  700.  
  701.     # Check for GUI associations
  702.     #
  703.     foreach assoc [$this genAssocAttrSet] {
  704.         if {[$this baseType] == "Class"} {
  705.             # ToDo: Modify this when class declarations are possible
  706.             if {[[[$assoc ooplType] ooplClass] isComponentDummy]} {
  707.                 m4_error $E_CANTCONTGUI [$this getName] [[[$assoc ooplType] ooplClass] getName]
  708.                 incr errornr 1
  709.             } 
  710.         }
  711.     }
  712.  
  713.     # Check for multiple inheritance
  714.     #
  715.     if {[$this genNodeSet] != ""} {
  716.         set class_supers 0
  717.         set intface_supers 0
  718.         foreach node [$this genNodeSet] {
  719.             set ctype [[$node superClass] getClassType]
  720.             if {$ctype == "Class"} {
  721.                 incr class_supers
  722.             }
  723.             if {$ctype == "Interface"} {
  724.                 incr intface_supers
  725.             }
  726.         }
  727.         if {$class_supers > 1} {
  728.             m4_error $E_MULTINH [$this getName] 
  729.             incr errornr 1
  730.         }
  731.  
  732.         # Check super for interface classes
  733.         #
  734.         if {$classtype == "Interface"} {
  735.             if {($intface_supers > 1) || ($class_supers != 0)} {
  736.                 m4_error $E_INTFACEINH [$this getName]
  737.                 incr errornr 1
  738.             }
  739.         }
  740.         # Check super for classes with interface inheritance
  741.         #
  742.         if {$classtype == "Class"} {
  743.             if {($intface_supers > 0) && ($class_supers == 0)} {
  744.                 m4_error $E_INHNOCLASS [$this getName]
  745.                 incr errornr 1
  746.             }
  747.         }
  748.     }
  749.     # Check interface class
  750.     #
  751.     if {$classtype == "Interface"} {
  752.         # Attributes
  753.         foreach feature [$this dataAttrSet] {
  754.             if {![$feature isProperty]} {
  755.                 m4_error $E_ONLYPROPS [$this getName] [$feature getName]
  756.                 incr errornr 1
  757.             }
  758.         }
  759.         # Associations
  760.         if {[$this genAssocAttrSet] != ""} {
  761.             m4_error $E_NOASSOC [$this getName]
  762.             incr errornr 1
  763.         }
  764.     }
  765.  
  766.     # Check form components
  767.     #
  768.     if {[$this isForm]} {
  769.         $this checkComponentLocal [$this getName] ""
  770.     }
  771.  
  772.     return $errornr
  773. }
  774.  
  775. # Do not delete this line -- regeneration end marker
  776.  
  777. if [isCommand CMClass] {
  778.     Class  DPGClassD : {DPGClass CMClass} {
  779.     }
  780. } else {
  781.     Class DPGClassD : {DPGClass OPClass} {    
  782.     }
  783. }
  784.  
  785. global mostDerivedOOPL ; set mostDerivedOOPL(OPClass) DPGClassD
  786.  
  787. selfPromoter OPClass {this} {
  788.     DPGClassD promote $this
  789. }
  790.  
  791.  
  792. #---------------------------------------------------------------------------
  793. #      File:           @(#)dpgfeature.tcl    /main/titanic/3
  794.  
  795.  
  796. Class DPGFeature : {Object} {
  797.     constructor
  798.     method destructor
  799.     method check
  800.     method checkLocal
  801.     method generate
  802. }
  803.  
  804. constructor DPGFeature {class this name} {
  805.     set this [Object::constructor $class $this $name]
  806.     # Start constructor user section
  807.     # End constructor user section
  808.     return $this
  809. }
  810.  
  811. method DPGFeature::destructor {this} {
  812.     # Start destructor user section
  813.     # End destructor user section
  814. }
  815.  
  816. method DPGFeature::check {this} {
  817.     set errornr [$this checkLocal]
  818.     return $errornr
  819. }
  820.  
  821. method DPGFeature::checkLocal {this} {
  822.     set errornr 0
  823.     return $errornr
  824. }
  825.  
  826. method DPGFeature::generate {this} {
  827. }
  828.  
  829. # Do not delete this line -- regeneration end marker
  830.  
  831. if [isCommand CMFeature] {
  832.     Class  DPGFeatureD : {DPGFeature CMFeature} {
  833.     }
  834. } else {
  835.     Class DPGFeatureD : {DPGFeature OPFeature} {    
  836.     }
  837. }
  838.  
  839. global mostDerivedOOPL ; set mostDerivedOOPL(OPFeature) DPGFeatureD
  840.  
  841. selfPromoter OPFeature {this} {
  842.     DPGFeatureD promote $this
  843. }
  844.  
  845.  
  846. #---------------------------------------------------------------------------
  847. #      File:           @(#)dpginhgrou.tcl    /main/titanic/7
  848.  
  849.  
  850. Class DPGInhGroup : {Object} {
  851.     constructor
  852.     method destructor
  853.     method check
  854.     method checkLocal
  855.     method generate
  856. }
  857.  
  858. constructor DPGInhGroup {class this name} {
  859.     set this [Object::constructor $class $this $name]
  860.     # Start constructor user section
  861.     # End constructor user section
  862.     return $this
  863. }
  864.  
  865. method DPGInhGroup::destructor {this} {
  866.     # Start destructor user section
  867.     # End destructor user section
  868. }
  869.  
  870. method DPGInhGroup::check {this} {
  871.     set errornr [$this checkLocal]
  872.     return $errornr
  873. }
  874.  
  875. method DPGInhGroup::checkLocal {this} {
  876.     set errornr 0
  877.  
  878.     if {![[$this superClass] isDerivable]} {
  879.         m4_error $E_ILLSUPER [[$this superClass] getName]
  880.         incr errornr 1
  881.     }
  882.     return $errornr
  883. }
  884.  
  885. method DPGInhGroup::generate {this class} {
  886.     if {[$this checkLocal] > 0} {
  887.         return
  888.     }
  889.     set superclasstype [[$this superClass] getClassType]
  890.     set classtype [$class unitType]
  891.     if {($classtype == "class") || ($classtype == "formclass")} {
  892.         if {$superclasstype == "Class"} {
  893.             $class superclass [[$this superClass] generateType]
  894.         } else { 
  895.             if {$superclasstype == "Interface"} {
  896.                     $class addSuperinterface [[$this superClass] generateType]
  897.             }
  898.         }
  899.     } else {
  900.         if {$classtype == "interface"} {
  901.             if {$superclasstype == "Interface"} {
  902.                 $class super [[$this superClass] generateType]
  903.             }
  904.         }
  905.     }
  906. }
  907.  
  908. # Do not delete this line -- regeneration end marker
  909.  
  910. if [isCommand CMInhGroup] {
  911.     Class  DPGInhGroupD : {DPGInhGroup CMInhGroup} {
  912.     }
  913. } else {
  914.     Class DPGInhGroupD : {DPGInhGroup OPInhGroup} {    
  915.     }
  916. }
  917.  
  918. global mostDerivedOOPL ; set mostDerivedOOPL(OPInhGroup) DPGInhGroupD
  919.  
  920. selfPromoter OPInhGroup {this} {
  921.     DPGInhGroupD promote $this
  922. }
  923.  
  924.  
  925. #---------------------------------------------------------------------------
  926. #      File:           @(#)dpginitial.tcl    /main/titanic/3
  927.  
  928.  
  929. Class DPGInitializer : {Object} {
  930.     constructor
  931.     method destructor
  932.     method check
  933.     method checkLocal
  934.     method generate
  935. }
  936.  
  937. constructor DPGInitializer {class this name} {
  938.     set this [Object::constructor $class $this $name]
  939.     # Start constructor user section
  940.     # End constructor user section
  941.     return $this
  942. }
  943.  
  944. method DPGInitializer::destructor {this} {
  945.     # Start destructor user section
  946.     # End destructor user section
  947. }
  948.  
  949. method DPGInitializer::check {this} {
  950.     set errornr [$this checkLocal]
  951.     return $errornr
  952. }
  953.  
  954. method DPGInitializer::checkLocal {this} {
  955.     set errornr 0
  956.     return $errornr
  957. }
  958.  
  959. method DPGInitializer::generate {this ctor} {
  960. }
  961.  
  962. # Do not delete this line -- regeneration end marker
  963.  
  964. if [isCommand CMInitializer] {
  965.     Class  DPGInitializerD : {DPGInitializer CMInitializer} {
  966.     }
  967. } else {
  968.     Class DPGInitializerD : {DPGInitializer OPInitializer} {    
  969.     }
  970. }
  971.  
  972. global mostDerivedOOPL ; set mostDerivedOOPL(OPInitializer) DPGInitializerD
  973.  
  974. selfPromoter OPInitializer {this} {
  975.     DPGInitializerD promote $this
  976. }
  977.  
  978.  
  979. #---------------------------------------------------------------------------
  980. #      File:           @(#)dpgparamet.tcl    /main/titanic/4
  981.  
  982.  
  983. Class DPGParameter : {Object} {
  984.     constructor
  985.     method destructor
  986.     method check
  987.     method checkLocal
  988. }
  989.  
  990. constructor DPGParameter {class this name} {
  991.     set this [Object::constructor $class $this $name]
  992.     # Start constructor user section
  993.     # End constructor user section
  994.     return $this
  995. }
  996.  
  997. method DPGParameter::destructor {this} {
  998.     # Start destructor user section
  999.     # End destructor user section
  1000. }
  1001.  
  1002. method DPGParameter::check {this} {
  1003.     set errornr [$this checkLocal]
  1004.     incr errornr [[$this ooplType] check]
  1005.     return $errornr
  1006. }
  1007.  
  1008. method DPGParameter::checkLocal {this} {
  1009.     set errornr 0
  1010.     return $errornr
  1011. }
  1012.  
  1013. # Do not delete this line -- regeneration end marker
  1014.  
  1015. if [isCommand CMParameter] {
  1016.     Class  DPGParameterD : {DPGParameter CMParameter} {
  1017.     }
  1018. } else {
  1019.     Class DPGParameterD : {DPGParameter OPParameter} {    
  1020.     }
  1021. }
  1022.  
  1023. global mostDerivedOOPL ; set mostDerivedOOPL(OPParameter) DPGParameterD
  1024.  
  1025. selfPromoter OPParameter {this} {
  1026.     DPGParameterD promote $this
  1027. }
  1028.  
  1029.  
  1030. #---------------------------------------------------------------------------
  1031. #      File:           @(#)dpgtype.tcl    /main/titanic/6
  1032.  
  1033.  
  1034. Class DPGType : {Object Object} {
  1035.     constructor
  1036.     method destructor
  1037.     method check
  1038.     method checkLocal
  1039.     method generate
  1040.     method generateParamType
  1041.     method generateAttribType
  1042.     method getAttribTypeModifier
  1043.     method getParamTypeModifier
  1044. }
  1045.  
  1046. constructor DPGType {class this name} {
  1047.     set this [Object::constructor $class $this $name]
  1048.     set this [Object::constructor $class $this $name]
  1049.     # Start constructor user section
  1050.     # End constructor user section
  1051.     return $this
  1052. }
  1053.  
  1054. method DPGType::destructor {this} {
  1055.     # Start destructor user section
  1056.     # End destructor user section
  1057. }
  1058.  
  1059. method DPGType::check {this} {
  1060.     set errornr [$this checkLocal]
  1061.     return $errornr
  1062. }
  1063.  
  1064. method DPGType::checkLocal {this} {
  1065.     set errornr 0
  1066.     return $errornr
  1067. }
  1068.  
  1069. method DPGType::generate {this} {
  1070.  
  1071.     if {[$this ooplClass] != ""} {
  1072.         set type [[$this ooplClass] generateType]
  1073.     } else {
  1074.         set type [DPType new]
  1075.         $type includeType "user"
  1076.         $type includeName ""
  1077.         $type name ""
  1078.     }
  1079.     return $type
  1080. }
  1081.  
  1082. method DPGType::generateParamType {this} {
  1083.     set tgtType [$this generate]
  1084.     set modifier [$this getParamTypeModifier]
  1085.  
  1086.     if {$modifier == ""} {
  1087.         return $tgtType
  1088.     }
  1089.     switch $modifier {
  1090.         ""    {
  1091.         }
  1092.         "Untyped" {
  1093.             $tgtType name ""
  1094.             $tgtType includeType "none"
  1095.         }
  1096.         "Open-array" {
  1097.             $tgtType name "array of [$tgtType name]"
  1098.         }
  1099.         "Variant Open-array" {
  1100.             $tgtType name "array of const"
  1101.             $tgtType includeType "none"
  1102.         }
  1103.         default {
  1104.             $tgtType name $modifier
  1105.         }
  1106.     }
  1107.     return $tgtType
  1108. }
  1109.  
  1110. method DPGType::generateAttribType {this} {
  1111.     set tgtType [$this generate]
  1112.     set modifier [$this getAttribTypeModifier]
  1113.  
  1114.     if {$modifier == ""} {
  1115.         return $tgtType
  1116.     }
  1117.     switch $modifier {
  1118.         ""    {
  1119.         }
  1120.         "Pointer" {
  1121.             $tgtType name "^[$tgtType name]"
  1122.         }
  1123.         "File" {
  1124.             $tgtType name "file of [$tgtType name]"
  1125.         }
  1126.         "Untyped" {
  1127.             $tgtType name ""
  1128.             $tgtType includeType "none"
  1129.         }
  1130.         default {
  1131.             $tgtType name $modifier
  1132.         }
  1133.     }
  1134.     return $tgtType
  1135. }
  1136.  
  1137. method DPGType::getAttribTypeModifier {this} {
  1138.     set modifier [$this getPropertyValue "attrib_mod"]
  1139.  
  1140.     if {$modifier == "Default"} {
  1141.         return ""
  1142.     }
  1143.     if {$modifier == "Other"} {
  1144.         return [string trim [$this getPropertyValue "attrib_othermod"]]
  1145.     }
  1146.     return $modifier
  1147. }
  1148.  
  1149. method DPGType::getParamTypeModifier {this} {
  1150.     set modifier [$this getPropertyValue "param_mod"]
  1151.  
  1152.     if {$modifier == "Default"} {
  1153.         return ""
  1154.     }
  1155.     if {$modifier == "Other"} {
  1156.         return [string trim [$this getPropertyValue "param_othermod"]]
  1157.     }
  1158.     return $modifier
  1159. }
  1160.  
  1161. # Do not delete this line -- regeneration end marker
  1162.  
  1163. if [isCommand CMType] {
  1164.     Class  DPGTypeD : {DPGType CMType} {
  1165.     }
  1166. } else {
  1167.     Class DPGTypeD : {DPGType OPType} {    
  1168.     }
  1169. }
  1170.  
  1171. global mostDerivedOOPL ; set mostDerivedOOPL(OPType) DPGTypeD
  1172.  
  1173. selfPromoter OPType {this} {
  1174.     DPGTypeD promote $this
  1175. }
  1176.  
  1177.  
  1178. #---------------------------------------------------------------------------
  1179. #      File:           @(#)dpgassocge.tcl    /main/titanic/11
  1180.  
  1181.  
  1182. Class DPGAssocGen : {GCObject} {
  1183.     constructor
  1184.     method destructor
  1185.     method propRead
  1186.     method propWrite
  1187.     method propAccess
  1188.     method hasGet
  1189.     method checkLocal
  1190.     method check
  1191.     method generateType
  1192.     method castType
  1193.     method assocattr
  1194.     attribute varname
  1195.     attribute varref
  1196.     attribute varset
  1197.     attribute vardict
  1198.     attribute varqual
  1199.     attribute opvarname
  1200.     attribute opvarref
  1201.     attribute opvarset
  1202.     attribute opvardict
  1203.     attribute addWarning
  1204.     attribute setWarning
  1205.     attribute getWarning
  1206.     attribute removeWarning
  1207.     attribute dtorWarning
  1208.     attribute typename
  1209.     attribute _assocattr
  1210. }
  1211.  
  1212. constructor DPGAssocGen {class this assocattr} {
  1213.     set this [GCObject::constructor $class $this]
  1214.     $this addWarning 0
  1215.     $this setWarning 0
  1216.     $this getWarning 0
  1217.     $this removeWarning 0
  1218.     $this dtorWarning 0
  1219.     $this _assocattr $assocattr
  1220.     $assocattr _generator $this
  1221.     # Start constructor user section
  1222.  
  1223.     $this varname [[$this assocattr] getName]
  1224.     $this varref "[$this varname]Ref"
  1225.     $this varset "[$this varname]Set"
  1226.     $this vardict "[$this varname]Dict"
  1227.     $this typename [[[[$this assocattr] ooplType] ooplClass] getName]
  1228.  
  1229.     if {[[$this assocattr] get_obj_type] == "qual_assoc_attrib" || [[$this assocattr] get_obj_type] == "qual_link_attrib"} {
  1230.         $this varqual [[[$this assocattr] qualifier] getName]
  1231.     }
  1232.     if {[[$this assocattr] opposite] != ""} {
  1233.         $this opvarname [[[$this assocattr] opposite] getName]
  1234.         $this opvarref "[$this opvarname]Ref"
  1235.         $this opvarset "[$this opvarname]Set"
  1236.         $this opvardict "[$this opvarname]Dict"
  1237.     }
  1238.     # End constructor user section
  1239.     return $this
  1240. }
  1241.  
  1242. method DPGAssocGen::destructor {this} {
  1243.     # Start destructor user section
  1244.     # End destructor user section
  1245. }
  1246.  
  1247. method DPGAssocGen::propRead {this} {
  1248.     set accessList [split [[$this assocattr] getPropertyValue assoc_access] -]
  1249.     set accessStr [lindex $accessList 0]
  1250.     if {$accessStr == ""} {
  1251.         set accessStr "Public"
  1252.     }
  1253.     return $accessStr
  1254. }
  1255.  
  1256. method DPGAssocGen::propWrite {this} {
  1257.     set accessList [split [[$this assocattr] getPropertyValue assoc_access] -]
  1258.     set accessStr [lindex $accessList 1]
  1259.     if {$accessStr == ""} {
  1260.         set accessStr "Public"
  1261.     }
  1262.     return $accessStr
  1263. }
  1264.  
  1265. method DPGAssocGen::propAccess {this} {
  1266.     set access [[$this assocattr] getPropertyValue assoc_visibility]
  1267.     if {$access == ""} {
  1268.         set access "Private"
  1269.     }
  1270.     return $access
  1271. }
  1272.  
  1273. method DPGAssocGen::hasGet {this self} {
  1274.     set rd [$this propRead]
  1275.     if {$self} {
  1276.         if {$rd == "None"} {
  1277.             return 0
  1278.         } 
  1279.     } else {
  1280.         if {$rd == "None" || $rd == "Private" || $rd == "Protected"} {
  1281.             return 0
  1282.         } 
  1283.     }
  1284.     return 1
  1285. }
  1286.  
  1287. method DPGAssocGen::checkLocal {this} {
  1288.     set errornr 0
  1289.  
  1290.     # Check for mtory-mtory
  1291.     #
  1292.     set assoc [$this assocattr]
  1293.     set oppos [[$this assocattr] opposite]
  1294.     if {$oppos != ""} {
  1295.         if {[$assoc isMandatory] && [$assoc getMultiplicity] == "one" && ![$assoc isQualified]} {
  1296.             if {[$oppos isMandatory] && [$oppos getMultiplicity] == "one" && ![$oppos isQualified]} {
  1297.                 m4_error $E_MTORYMTORY [[[[$this assocattr] opposite] ooplClass] getName] [[[$this assocattr] ooplClass] getName]
  1298.                 incr errornr 1
  1299.             }
  1300.         }
  1301.         if {[$assoc getPropertyValue "assoc_implement"] == "Object reference"} {
  1302.             if {[$oppos getPropertyValue "assoc_implement"] == "Object reference"} {
  1303.                 m4_error $E_OBJREFASSIMP [$assoc getName]
  1304.             }
  1305.         }
  1306.     }
  1307.     if {[[[$assoc ooplType] ooplClass] getClassType] == "Interface"} {
  1308.         m4_error $E_NOCLASSASSOC [[[$assoc ooplType] ooplClass] getName]
  1309.         incr errornr 1
  1310.     }
  1311.  
  1312.     return $errornr
  1313. }
  1314.  
  1315. method DPGAssocGen::check {this} {
  1316.     set errornr [$this checkLocal]
  1317.  
  1318.     return $errornr
  1319. }
  1320.  
  1321. method DPGAssocGen::generateType {this cl} {
  1322.     if {[[$this assocattr] getPropertyValue "assoc_implement"] == "Object reference"} {
  1323.         set type [[[[$this assocattr] ooplType] ooplClass] generateType]
  1324.     } else {
  1325.         # To include the right unit
  1326.         [$this assocattr] generateAssocType $cl
  1327.         set type [DPType new]
  1328.         $type name "Pointer"
  1329.     }
  1330.     return $type
  1331. }
  1332.  
  1333. method DPGAssocGen::castType {this str} {
  1334.     if {[[$this assocattr] getPropertyValue "assoc_implement"] == "Object reference"} {
  1335.         return $str
  1336.     } else {
  1337.         return "[$this typename](${str})"
  1338.     }
  1339. }
  1340.  
  1341. # Do not delete this line -- regeneration end marker
  1342.  
  1343. method DPGAssocGen::assocattr {this args} {
  1344.     if {$args == ""} {
  1345.         return [$this _assocattr]
  1346.     }
  1347.     set ref [$this _assocattr]
  1348.     if {$ref != ""} {
  1349.         $ref _generator ""
  1350.     }
  1351.     set obj [lindex $args 0]
  1352.     if {$obj != ""} {
  1353.         $obj _generator $this
  1354.     }
  1355.     $this _assocattr $obj
  1356. }
  1357.  
  1358.  
  1359.  
  1360. #---------------------------------------------------------------------------
  1361. #      File:           @(#)dpgclassen.tcl    /main/titanic/9
  1362.  
  1363.  
  1364. Class DPGClassEnum : {DPGClass} {
  1365.     constructor
  1366.     method destructor
  1367.     method isDerivable
  1368.     method generate
  1369.     method checkLocal
  1370.     method check
  1371. }
  1372.  
  1373. constructor DPGClassEnum {class this name} {
  1374.     set this [DPGClass::constructor $class $this $name]
  1375.     # Start constructor user section
  1376.     # End constructor user section
  1377.     return $this
  1378. }
  1379.  
  1380. method DPGClassEnum::destructor {this} {
  1381.     # Start destructor user section
  1382.     # End destructor user section
  1383. }
  1384.  
  1385. method DPGClassEnum::isDerivable {this} {
  1386.     return 0
  1387. }
  1388.  
  1389. method DPGClassEnum::generate {this tgt} {
  1390.     if {[$this checkLocal] > 0} {
  1391.         return
  1392.     }
  1393.     set unit [DPEnumUnit new]
  1394.     set type [$this generateType]
  1395.     $unit name "[$type name]"
  1396.  
  1397.     $tgt setUnit [$this getName] $unit
  1398.     $unit unitName "[$this getUnitName]"
  1399.  
  1400.     set comment [DPComment new]
  1401.     $unit comment $comment
  1402.     $comment comment [$this getPropertyValue "freeText"]
  1403.  
  1404.     # Generate enum fields
  1405.     foreach feature [$this dataAttrSet] {
  1406.         set comp [DPEnumComponent new]
  1407.         $comp name [$feature getName]
  1408.         $unit addComponent $comp
  1409.     }
  1410.     if {[$this getClassType] == "Set"} {
  1411.         $unit isSet 1
  1412.     }
  1413. }
  1414.  
  1415. method DPGClassEnum::checkLocal {this} {
  1416.     set errornr 0
  1417.  
  1418.     # Check class type
  1419.     #
  1420.     set classtype [$this getPropertyValue "class_type"]
  1421.     if {($classtype != "") && ($classtype != "Class") && ($classtype != "Set")} {
  1422.         incr errornr
  1423.         m4_error $E_ILLCLASSTYPE [$this getName]
  1424.     }
  1425.  
  1426.     # Check data attributes
  1427.     #
  1428.     # Note: put here since it is no generate is called from the data attribute!
  1429.     foreach feature [$this dataAttrSet] {
  1430.         incr errornr [$feature check]
  1431.     }
  1432.  
  1433.     # Check initial values
  1434.     #
  1435.     foreach feature [$this dataAttrSet] {
  1436.         if {[$feature getInitialValue] != ""} {
  1437.             m4_warning $W_ENUMDEFAULT [$this getName]
  1438.             incr errornr 1
  1439.         }
  1440.     }
  1441.     return $errornr
  1442. }
  1443.  
  1444. method DPGClassEnum::check {this} {
  1445.     set errornr [$this checkLocal]
  1446.     return $errornr
  1447. }
  1448.  
  1449. # Do not delete this line -- regeneration end marker
  1450.  
  1451. if [isCommand CMClassEnum] {
  1452.     Class  DPGClassEnumD : {DPGClassEnum CMClassEnum} {
  1453.     }
  1454. } else {
  1455.     Class DPGClassEnumD : {DPGClassEnum OPClassEnum} {    
  1456.     }
  1457. }
  1458.  
  1459. global mostDerivedOOPL ; set mostDerivedOOPL(OPClassEnum) DPGClassEnumD
  1460.  
  1461. selfPromoter OPClassEnum {this} {
  1462.     DPGClassEnumD promote $this
  1463. }
  1464.  
  1465.  
  1466. #---------------------------------------------------------------------------
  1467. #      File:           @(#)dpgclassge.tcl    /main/titanic/7
  1468.  
  1469.  
  1470. Class DPGClassGenericTypeDef : {DPGClass} {
  1471.     constructor
  1472.     method destructor
  1473.     method isDerivable
  1474.     method generate
  1475.     method checkLocal
  1476.     method check
  1477. }
  1478.  
  1479. constructor DPGClassGenericTypeDef {class this name} {
  1480.     set this [DPGClass::constructor $class $this $name]
  1481.     # Start constructor user section
  1482.     # End constructor user section
  1483.     return $this
  1484. }
  1485.  
  1486. method DPGClassGenericTypeDef::destructor {this} {
  1487.     # Start destructor user section
  1488.     # End destructor user section
  1489. }
  1490.  
  1491. method DPGClassGenericTypeDef::isDerivable {this} {
  1492.     return 0
  1493. }
  1494.  
  1495. method DPGClassGenericTypeDef::generate {this tgt} {
  1496.  
  1497.     if {[$this checkLocal] > 0} {
  1498.         return
  1499.     }
  1500.  
  1501.     set unit [DPTypeDefUnit new]
  1502.     set type [$this generateType]
  1503.     $unit name "[$type name]"
  1504.  
  1505.     set assoc [lindex [$this genAssocAttrSet] 0]
  1506.     if {[$assoc isQualified]} {
  1507.         set typedefType [$assoc generateQualAssocType $unit]
  1508.     } else {
  1509.         if {[$assoc getMultiplicity] == "many"} {
  1510.             set typedefType [$assoc generateManyAssocType $unit]
  1511.         } else {
  1512.             set typedefType [[$assoc ooplType] generate]
  1513.         }
  1514.     }
  1515.  
  1516.     $unit unitName "[$this getUnitName]"
  1517.     $unit typedefType $typedefType
  1518.     $tgt setUnit [$this getName] $unit
  1519.  
  1520.     set comment [DPComment new]
  1521.     $unit comment $comment
  1522.     $comment comment [$this getPropertyValue "freeText"]
  1523. }
  1524.  
  1525. method DPGClassGenericTypeDef::checkLocal {this} {
  1526.     set errornr 0
  1527.  
  1528.     if {[lindex [$this genAssocAttrSet] 0] == ""} {
  1529.         m4_error $E_GENTDEFTYPE [$this getName]
  1530.         incr errornr
  1531.     }
  1532.     return $errornr
  1533. }
  1534.  
  1535. method DPGClassGenericTypeDef::check {this} {
  1536.     set errornr [$this checkLocal]
  1537.  
  1538.     return $errornr
  1539. }
  1540.  
  1541. # Do not delete this line -- regeneration end marker
  1542.  
  1543. if [isCommand CMClassGenericTypeDef] {
  1544.     Class  DPGClassGenericTypeDefD : {DPGClassGenericTypeDef CMClassGenericTypeDef} {
  1545.     }
  1546. } else {
  1547.     Class DPGClassGenericTypeDefD : {DPGClassGenericTypeDef OPClassGenericTypeDef} {    
  1548.     }
  1549. }
  1550.  
  1551. global mostDerivedOOPL ; set mostDerivedOOPL(OPClassGenericTypeDef) DPGClassGenericTypeDefD
  1552.  
  1553. selfPromoter OPClassGenericTypeDef {this} {
  1554.     DPGClassGenericTypeDefD promote $this
  1555. }
  1556.  
  1557.  
  1558. #---------------------------------------------------------------------------
  1559. #      File:           @(#)dpgclasstd.tcl    /main/titanic/13
  1560.  
  1561.  
  1562. Class DPGClassTDef : {DPGClass} {
  1563.     constructor
  1564.     method destructor
  1565.     method isDerivable
  1566.     method getFinalType
  1567.     method getType
  1568.     method generate
  1569.     method checkLocal
  1570.     method check
  1571.     attribute cid
  1572.     attribute finalType
  1573. }
  1574.  
  1575. global DPGClassTDef::gid
  1576. set DPGClassTDef::gid 0
  1577.  
  1578.  
  1579. constructor DPGClassTDef {class this name} {
  1580.     set this [DPGClass::constructor $class $this $name]
  1581.     $this finalType null
  1582.     # Start constructor user section
  1583.     # End constructor user section
  1584.     return $this
  1585. }
  1586.  
  1587. method DPGClassTDef::destructor {this} {
  1588.     # Start destructor user section
  1589.     # End destructor user section
  1590. }
  1591.  
  1592. method DPGClassTDef::isDerivable {this} {
  1593.     set type [$this getFinalType]
  1594.  
  1595.     if {$type != ""} {
  1596.         if {[$type isA OPBaseType] || [$type isA OPTypeDefType] || [$type isA OPEnumType]} {
  1597.             return 0
  1598.         }
  1599.         if {[$type isA OPClassType] && [[$type ooplClass] isComponentDummy]} {
  1600.             return 0
  1601.         }
  1602.     }
  1603.     return 1
  1604. }
  1605.  
  1606. method DPGClassTDef::getFinalType {this} {
  1607.     # return the (final) type to which this typedef really refers, i.e. resolve
  1608.     #  the typedef trail until a non-typedef is discovered
  1609.     # note: this func returns an OPTypeDefType in case of a typedef that refers
  1610.     #        to itself
  1611.     # currently, this is done non-recursively...
  1612.     #
  1613.     # note: copy from Forte generator
  1614.     #
  1615.  
  1616.     # Note! Constructor is not called so initialization is done in promotor!!
  1617.     #
  1618.     if {[$this finalType] != "null"} {
  1619.     return [$this finalType]
  1620.     }
  1621.  
  1622.     global DPGClassTDef::gid
  1623.     incr DPGClassTDef::gid
  1624.     set id ${DPGClassTDef::gid}
  1625.     $this cid $id
  1626.  
  1627.     set type [$this getType]
  1628.     while {1} {
  1629.         if {$type == ""} {
  1630.             $this finalType ""
  1631.             return ""
  1632.         }
  1633.         if {![$type isA OPTypeDefType]} {
  1634.             $this finalType $type
  1635.             return $type
  1636.         }
  1637.         set class [$type ooplClass]
  1638.         if {$class == ""} {
  1639.             $this finalType ""
  1640.             return ""
  1641.         }
  1642.         if {![$class isA OPClassTDef]} {
  1643.             $this finalType $type
  1644.             return $type
  1645.         }
  1646.         if {$id == [$class cid]} {
  1647.             # loop detected
  1648.             $this finalType $type
  1649.             return $type
  1650.         }
  1651.         if {[$class getName] == ""} {
  1652.             $this finalType ""
  1653.             return ""
  1654.         }
  1655.         $class cid $id
  1656.         set type [$class getType]
  1657.     }
  1658. }
  1659.  
  1660. method DPGClassTDef::getType {this} {
  1661.     # note: this method should have been a member of OPClassTDef
  1662.     #
  1663.     set attr [lindex [$this dataAttrSet] 0]
  1664.     if {$attr == ""} {
  1665.         return ""
  1666.     }
  1667.  
  1668.     # hack: if attr has no type, the OOPL model returns an OPClassType without
  1669.     #  an OPCLass... or an OPClass having no name... !!!
  1670.     #
  1671.     set type [$attr ooplType]
  1672.     if {[$type isA OPClassType]} {
  1673.         if {[$type ooplClass] == "" || [[$type ooplClass] getName] == ""} {
  1674.             return ""
  1675.         }
  1676.     }
  1677.     return $type
  1678. }
  1679.  
  1680. method DPGClassTDef::generate {this tgt} {
  1681.     set unit [DPTypeDefUnit new]
  1682.     set type [$this generateType]
  1683.     $unit typedefType [[[$this dataAttrSet] ooplType] generateAttribType]
  1684.     $unit name "[$type name]"
  1685.  
  1686.     $tgt setUnit [$this getName] $unit
  1687.     $unit unitName "[$this getUnitName]"
  1688.  
  1689.     set comment [DPComment new]
  1690.     $unit comment $comment
  1691.     $comment comment [$this getPropertyValue "freeText"]
  1692. }
  1693.  
  1694. method DPGClassTDef::checkLocal {this} {
  1695.     set errornr 0
  1696.  
  1697.     set classtype [$this getClassType]
  1698.     if {($classtype != "Class")} {
  1699.         incr errornr
  1700.         m4_error $E_ILLCLASSTYPE [$this getName]
  1701.     }
  1702.  
  1703.     return $errornr
  1704. }
  1705.  
  1706. method DPGClassTDef::check {this} {
  1707.     set errornr [$this checkLocal]
  1708.  
  1709.     foreach feature [$this dataAttrSet] {
  1710.         incr errornr [$feature check]
  1711.     }
  1712.     return $errornr
  1713. }
  1714.  
  1715. # Do not delete this line -- regeneration end marker
  1716.  
  1717. if [isCommand CMClassTDef] {
  1718.     Class  DPGClassTDefD : {DPGClassTDef CMClassTDef} {
  1719.     }
  1720. } else {
  1721.     Class DPGClassTDefD : {DPGClassTDef OPClassTDef} {    
  1722.     }
  1723. }
  1724.  
  1725. global mostDerivedOOPL ; set mostDerivedOOPL(OPClassTDef) DPGClassTDefD
  1726.  
  1727. selfPromoter OPClassTDef {this} {
  1728.     DPGClassTDefD promote $this
  1729. }
  1730.  
  1731.  
  1732. #---------------------------------------------------------------------------
  1733. #      File:           @(#)dpglinkcla.tcl    /main/titanic/5
  1734.  
  1735.  
  1736. Class DPGLinkClass : {DPGClass} {
  1737.     constructor
  1738.     method destructor
  1739.     method isDerivable
  1740. }
  1741.  
  1742. constructor DPGLinkClass {class this name} {
  1743.     set this [DPGClass::constructor $class $this $name]
  1744.     # Start constructor user section
  1745.     # End constructor user section
  1746.     return $this
  1747. }
  1748.  
  1749. method DPGLinkClass::destructor {this} {
  1750.     # Start destructor user section
  1751.     # End destructor user section
  1752. }
  1753.  
  1754. method DPGLinkClass::isDerivable {this} {
  1755.     return 0
  1756. }
  1757.  
  1758. # Do not delete this line -- regeneration end marker
  1759.  
  1760. if [isCommand CMLinkClass] {
  1761.     Class  DPGLinkClassD : {DPGLinkClass CMLinkClass} {
  1762.     }
  1763. } else {
  1764.     Class DPGLinkClassD : {DPGLinkClass OPLinkClass} {    
  1765.     }
  1766. }
  1767.  
  1768. global mostDerivedOOPL ; set mostDerivedOOPL(OPLinkClass) DPGLinkClassD
  1769.  
  1770. selfPromoter OPLinkClass {this} {
  1771.     DPGLinkClassD promote $this
  1772. }
  1773.  
  1774.  
  1775. #---------------------------------------------------------------------------
  1776. #      File:           @(#)dpgattribu.tcl    /main/titanic/3
  1777.  
  1778.  
  1779. Class DPGAttribute : {DPGFeature} {
  1780.     constructor
  1781.     method destructor
  1782. }
  1783.  
  1784. constructor DPGAttribute {class this name} {
  1785.     set this [DPGFeature::constructor $class $this $name]
  1786.     # Start constructor user section
  1787.     # End constructor user section
  1788.     return $this
  1789. }
  1790.  
  1791. method DPGAttribute::destructor {this} {
  1792.     # Start destructor user section
  1793.     # End destructor user section
  1794. }
  1795.  
  1796. # Do not delete this line -- regeneration end marker
  1797.  
  1798. if [isCommand CMAttribute] {
  1799.     Class  DPGAttributeD : {DPGAttribute CMAttribute} {
  1800.     }
  1801. } else {
  1802.     Class DPGAttributeD : {DPGAttribute OPAttribute} {    
  1803.     }
  1804. }
  1805.  
  1806. global mostDerivedOOPL ; set mostDerivedOOPL(OPAttribute) DPGAttributeD
  1807.  
  1808. selfPromoter OPAttribute {this} {
  1809.     DPGAttributeD promote $this
  1810. }
  1811.  
  1812.  
  1813. #---------------------------------------------------------------------------
  1814. #      File:           @(#)dpgconstru.tcl    /main/titanic/18
  1815.  
  1816.  
  1817. Class DPGConstructor : {DPGFeature} {
  1818.     constructor
  1819.     method destructor
  1820.     method check
  1821.     method generate
  1822.     attribute counted
  1823. }
  1824.  
  1825. constructor DPGConstructor {class this name} {
  1826.     set this [DPGFeature::constructor $class $this $name]
  1827.     $this counted 0
  1828.     # Start constructor user section
  1829.     # End constructor user section
  1830.     return $this
  1831. }
  1832.  
  1833. method DPGConstructor::destructor {this} {
  1834.     # Start destructor user section
  1835.     # End destructor user section
  1836. }
  1837.  
  1838. method DPGConstructor::check {this} {
  1839.     set errornr [$this checkLocal]
  1840.  
  1841.     # check initializers
  1842.     foreach initializer [$this initializerSet] {
  1843.         incr errornr [$initializer check]
  1844.     }
  1845.  
  1846.     # check parameters
  1847.     foreach param [[$this ooplClass] creationParamSet] {
  1848.         if {![$param isGUIComponent [$this ooplClass]]} {
  1849.             incr errornr [$param check]
  1850.         }
  1851.     }
  1852.  
  1853.     return $errornr
  1854. }
  1855.  
  1856. method DPGConstructor::generate {this class} {
  1857.     if {([$this counted] == "") || ([$this counted] == "0")} {
  1858.         $class userConstructors [expr [$class userConstructors] + 1]
  1859.         $this counted 1
  1860.     }
  1861.  
  1862.     set ctor [DPConstructor new]
  1863.     set comment [DPComment new]
  1864.     $ctor comment $comment
  1865.     $comment comment [$this getPropertyValue "freeText"]
  1866.  
  1867.     $ctor name "Create"
  1868.     $ctor access [$this getPropertyValue "method_access"]
  1869.  
  1870.     # ToDo: Check for automatic override generation?
  1871. #    $ctor isOverride 1
  1872.  
  1873.     # method calling
  1874.  
  1875.     $ctor methodCalling [$this getPropertyValue "method_calling"] 
  1876.  
  1877.     # method modifier
  1878.     set modif [$this getPropertyValue "method_modifier"]
  1879.  
  1880.     switch $modif {
  1881.         "Virtual"    {
  1882.             $ctor isVirtual 1
  1883.         }
  1884.         "Dynamic"    {
  1885.             $ctor isDynamic 1
  1886.         }
  1887.         "Virtual Abstract"    {
  1888.             $ctor isAbstract 1
  1889.             $ctor isVirtual 1
  1890.         }
  1891.         "Dynamic Abstract"    {
  1892.             $ctor isAbstract 1
  1893.             $ctor isDynamic 1
  1894.         }
  1895.         "Override"    {
  1896.             $ctor isOverride 1
  1897.         }
  1898.         default    {
  1899.         }
  1900.     }
  1901.  
  1902.     if {[$ctor access] == ""} {
  1903.         $ctor access "Public"
  1904.     }
  1905.     set gencode [DPTextSection new]
  1906.     set gentypes [DPTextSection new]
  1907.     $ctor gencode $gencode
  1908.     $ctor gentypes $gentypes
  1909.  
  1910.     # Generate default Delphi parameter for component constructor
  1911.     #
  1912.     if {[[$this ooplClass] isComponentClass] || [[$this ooplClass] isForm]} {
  1913.         set type [DPType new]
  1914.         $type name "TComponent"
  1915.         $type includeType "system"
  1916.         $type includeName "Classes"
  1917.         set param [DPArgument new $type]
  1918.         $param name "AOwner"
  1919.         $ctor addArg $param
  1920.     }
  1921.  
  1922.     # Generate initializers
  1923.     #
  1924.     set superctor [DPConstructor new]
  1925.     foreach initializer [$this superClassInitializerSet] {
  1926.         $initializer generate $superctor
  1927.     }
  1928.  
  1929.     # Generate key attribute initialization code
  1930.     #
  1931.     foreach initializer [$this attribInitializerSet] {
  1932.         $initializer generate $ctor
  1933.     }
  1934.  
  1935.     # Generate initialized data attribute values
  1936.     #
  1937.     foreach attrib [[$this ooplClass] dataAttrSet] {
  1938.         $attrib generateInitialValue $ctor $class
  1939.     }
  1940.     [$ctor gencode] append "\n"
  1941.  
  1942.     # Generate association initialization code
  1943.     #
  1944.     foreach initializer [$this assocInitializerSet] {
  1945.         $initializer generate $ctor
  1946.     }
  1947.  
  1948.     # Generate superclass call
  1949.     #
  1950.     $gencode append "inherited Create"
  1951.     if {[[$superctor argSet] contents] != "" || [[$this ooplClass] isForm] || [[$this ooplClass] isComponent] } {
  1952.         $gencode append "("
  1953.         set first 1
  1954.         if {[[$this ooplClass] isForm] || [[$this ooplClass] isComponent]} {
  1955.             $gencode append "AOwner"
  1956.             set first 0
  1957.         }
  1958.         [$superctor argSet] foreach arg {
  1959.             if {$first} {
  1960.                 set first 0
  1961.             } else {
  1962.                 $gencode append ", "
  1963.             }
  1964.             $gencode append [$arg name]
  1965.         }
  1966.         $gencode append ")"
  1967.     }
  1968.     $gencode append ";\n"
  1969.  
  1970.  
  1971.     # Generate parameters
  1972.     #
  1973.     foreach param [[$this ooplClass] creationParamSet] {
  1974.         if {![$param isGUIComponent [$this ooplClass]]} {
  1975.             $param generate $ctor
  1976.         }
  1977.     }
  1978.  
  1979.     $class constructr $ctor
  1980. }
  1981.  
  1982. # Do not delete this line -- regeneration end marker
  1983.  
  1984. if [isCommand CMConstructor] {
  1985.     Class  DPGConstructorD : {DPGConstructor CMConstructor} {
  1986.     }
  1987. } else {
  1988.     Class DPGConstructorD : {DPGConstructor OPConstructor} {    
  1989.     }
  1990. }
  1991.  
  1992. global mostDerivedOOPL ; set mostDerivedOOPL(OPConstructor) DPGConstructorD
  1993.  
  1994. selfPromoter OPConstructor {this} {
  1995.     DPGConstructorD promote $this
  1996. }
  1997.  
  1998.  
  1999. #---------------------------------------------------------------------------
  2000. #      File:           @(#)dpgoperati.tcl    /main/titanic/16
  2001.  
  2002.  
  2003. Class DPGOperation : {DPGFeature} {
  2004.     constructor
  2005.     method destructor
  2006.     method check
  2007.     method checkEvent
  2008.     method checkEventLocal
  2009.     method checkLocal
  2010.     method getBaseEvent
  2011.     method generateEvent
  2012.     method generate
  2013.     method findNrEvents
  2014.     method findNrMethods
  2015.     method isEvent
  2016.     attribute eventAccess
  2017. }
  2018.  
  2019. constructor DPGOperation {class this name} {
  2020.     set this [DPGFeature::constructor $class $this $name]
  2021.     # Start constructor user section
  2022.     # End constructor user section
  2023.     return $this
  2024. }
  2025.  
  2026. method DPGOperation::destructor {this} {
  2027.     # Start destructor user section
  2028.     # End destructor user section
  2029. }
  2030.  
  2031. method DPGOperation::check {this} {
  2032.     set errornr [$this checkLocal]
  2033.  
  2034.     # Return type
  2035.     incr errornr [[$this ooplType] check]
  2036.  
  2037.     # Parameters
  2038.     foreach param [$this parameterSet] {
  2039.         $param check
  2040.     }
  2041.  
  2042.     return $errornr
  2043. }
  2044.  
  2045. method DPGOperation::checkEvent {this componentName} {
  2046.     set errornr [$this checkEventLocal $componentName]
  2047.     
  2048.     if {[[$this ooplClass] isGUIComponent]} {
  2049.         set super [[$this ooplClass] getSuperClass]
  2050.         set baseEvent [$this getBaseEvent $super]
  2051.         if {$baseEvent != ""} {
  2052.             foreach param [$baseEvent parameterSet] {
  2053.                 incr errornr [$param check]
  2054.             }
  2055.         }
  2056.     }
  2057.  
  2058.     return $errornr
  2059. }
  2060.  
  2061. method DPGOperation::checkEventLocal {this componentName} {
  2062.     set errornr 0
  2063.  
  2064.     set eventname $componentName[$this getName]
  2065.  
  2066.     set tempmod [$this getPropertyValue "method_modifier"]
  2067.     if {[$this isClassFeature] || ( $tempmod != "" && $tempmod != "None" )} {
  2068.         m4_warning $W_EVTILLTYPE $eventname $componentName
  2069.     }
  2070.  
  2071.     if {[$this findNrEvents [string tolower $eventname]] > 1} {
  2072.         m4_error $E_EVTDBDEF $eventname $componentName
  2073.         incr errornr 1
  2074.     }
  2075.  
  2076.     # Check if event exists. For Dummy control classes, events only
  2077.     # exist if they have been declared Published
  2078.  
  2079.     if {[[$this ooplClass] isGUIComponent]} {
  2080.         set super [[$this ooplClass] getSuperClass]
  2081.         set baseEvent [$this getBaseEvent $super]
  2082.         if {$baseEvent == ""} {
  2083.             m4_error $E_EVTNOTEXIST [$this getName] $componentName
  2084.             incr errornr 1
  2085.         } else {
  2086.             if {[[$this ooplClass] isComponentDummy]} {
  2087.                 if {[$baseEvent eventAccess] != "Published"} {
  2088.                     m4_error $E_EVTNOTPUBL [$this getName] $componentName
  2089.                     incr errornr 1
  2090.                 }
  2091.             }
  2092.         }
  2093.     }
  2094.  
  2095.     return $errornr
  2096. }
  2097.  
  2098. method DPGOperation::checkLocal {this} {
  2099.     set errornr 0
  2100.  
  2101.     # No events for non-GUI classes
  2102.     #
  2103.     if {[$this isEvent]} {
  2104.         if {![[$this ooplClass] isGUIComponent]} {
  2105.             m4_error $E_CANTCONTEVENT [[$this ooplClass] getName] [$this getName]
  2106.             incr errornr 1
  2107.         }
  2108.     }
  2109.     # Check for duplicate names
  2110.     #
  2111.     # Note: exception for constructors, these are always named "create"
  2112.     #
  2113.     set opername [string tolower [$this getName]]
  2114.     if {!($opername == "create" && [$this isClassFeature])} {
  2115.         if {[$this findNrMethods $opername] > 1} {
  2116.             m4_error $E_METHDBDEF [$this getName] [[$this ooplClass] getName]
  2117.             incr errornr 1
  2118.         }
  2119.     }
  2120.     return $errornr
  2121. }
  2122.  
  2123. method DPGOperation::getBaseEvent {this class} {
  2124.  
  2125.     set event ""
  2126.     set eventAccess "None"
  2127.  
  2128.     # Find base Event with access "Published"
  2129.     set eventname [$this getName]
  2130.     while {[$class getSuperClass] != ""} {
  2131.         foreach operation [$class operationSet] {
  2132.             if {[$operation getName] == $eventname} {
  2133.                 set access [$operation getPropertyValue "method_access"]
  2134.                 if {$access == ""} {
  2135.                     set access "Public"
  2136.                 }
  2137.                 set event $operation
  2138.  
  2139.                 if {$eventAccess != "Published"} {
  2140.                     set eventAccess $access
  2141.                 }
  2142.  
  2143.                 if {[llength [$operation parameterSet]] > 0} {
  2144.                     $event eventAccess $eventAccess
  2145.                     return $event
  2146.                 }
  2147.             }
  2148.         }
  2149.         set class [$class getSuperClass]
  2150.     }
  2151.     if {$event != ""} {
  2152.         $event eventAccess $eventAccess
  2153.     }
  2154.     return $event
  2155. }
  2156.  
  2157. method DPGOperation::generateEvent {this class control} {
  2158.     
  2159.     if {[$this checkEventLocal [$control name]] > 0} {
  2160.         return ""
  2161.     }
  2162.  
  2163.     set event [DPEvent new]
  2164.     $event name [$control name][$this getName]
  2165.  
  2166.     $event component [$control name]
  2167.     $event compclass [[$this ooplClass] getName]
  2168.  
  2169.     # Add event to class
  2170.  
  2171.     $class addEvent $event
  2172.  
  2173.     # Search event
  2174.  
  2175.     if {[[$this ooplClass] isGUIComponent]} {
  2176.         set super [[$this ooplClass] getSuperClass]
  2177.         set baseEvent [$this getBaseEvent $super]
  2178.  
  2179.         # Generate parameters of base-event
  2180.  
  2181.         foreach param [$baseEvent parameterSet] {
  2182.             $param generate $event
  2183.         }
  2184.     }
  2185.  
  2186.     # Access
  2187.  
  2188.     $event access "Published"
  2189.  
  2190.     # Comment
  2191.  
  2192.     set comment [DPComment new]
  2193.     $event comment $comment
  2194.     $comment comment [$this getPropertyValue "freeText"]
  2195.  
  2196.     return $event
  2197. }
  2198.  
  2199. method DPGOperation::generate {this class} {
  2200.     if {[$this checkLocal] > 0} {
  2201.         return
  2202.     }
  2203.  
  2204.     # No events for non-GUI classes
  2205.  
  2206.     if {[$this isEvent]} {
  2207.         return
  2208.     }
  2209.  
  2210.     # Constructor
  2211.  
  2212.     if {[$this getName] == "create" && [$this isClassFeature]} {
  2213.         set oper [DPConstructor new]
  2214.         $oper name [$this getName]
  2215.  
  2216.         if {[[$this ooplClass] constructor] != ""} {
  2217.             set counted [[[$this ooplClass] constructor] counted]
  2218.             if {($counted == "") || ($counted == "0")} {
  2219.                 [[$this ooplClass] constructor] counted 1
  2220.                 $class userConstructors [expr [$class userConstructors] + 1]
  2221.             }
  2222.         }
  2223.         $class userConstructors [expr [$class userConstructors] + 1]
  2224.         if {[expr [$class userConstructors] > 1]} {
  2225.             $oper name [$oper name][$class userConstructors]
  2226.         }
  2227.     } else {
  2228.  
  2229.         # Procedure or function
  2230.  
  2231.         set returnType [[$this ooplType] generate]
  2232.         if {[$returnType name] != ""} {
  2233.             set oper [DPFunction new $returnType]
  2234.         } else {
  2235.             set oper [DPProcedure new]
  2236.         }
  2237.         $oper name [$this getName]
  2238.         $oper isClassFeature [$this isClassFeature]
  2239.     }
  2240.  
  2241.     # Add method to class
  2242.  
  2243.     $class addUsermethod $oper
  2244.  
  2245.     # Access
  2246.  
  2247.     $oper access [$this getPropertyValue "method_access"]
  2248.     if {[$oper access] == ""} {
  2249.         $oper access "Public"
  2250.     }
  2251.  
  2252.     # Comment
  2253.  
  2254.     set comment [DPComment new]
  2255.     $oper comment $comment
  2256.     $comment comment [$this getPropertyValue "freeText"]
  2257.  
  2258.     # Method calling
  2259.  
  2260.     $oper methodCalling [$this getPropertyValue "method_calling"] 
  2261.     
  2262.     # Method modifier
  2263.  
  2264.     set modif [$this getPropertyValue "method_modifier"]
  2265.  
  2266.     if {($modif == "") || ($modif == "None")} {
  2267.         if {[$this isAbstract]} {
  2268.             $oper isAbstract 1
  2269.             $oper isVirtual 1
  2270.         }
  2271.     }
  2272.  
  2273.     switch $modif {
  2274.         "Virtual"    {
  2275.             $oper isVirtual 1
  2276.         }
  2277.         "Dynamic"    {
  2278.             $oper isDynamic 1
  2279.         }
  2280.         "Virtual Abstract"    {
  2281.             $oper isAbstract 1
  2282.             $oper isVirtual 1
  2283.         }
  2284.         "Dynamic Abstract"    {
  2285.             $oper isAbstract 1
  2286.             $oper isDynamic 1
  2287.         }
  2288.         "Override"    {
  2289.             $oper isOverride 1
  2290.         }
  2291.         default    {
  2292.         }
  2293.     }
  2294.  
  2295.     # Parameters
  2296.  
  2297.     foreach param [$this parameterSet] {
  2298.         $param generate $oper
  2299.     }
  2300. }
  2301.  
  2302. method DPGOperation::findNrEvents {this name} {
  2303.     set nr 0
  2304.     foreach feature [[$this ooplClass] operationSet] {
  2305.         if {[string tolower [$feature getName]] == $name && [$feature isEvent]} {
  2306.             incr nr 1
  2307.         }
  2308.     }
  2309.     return $nr
  2310. }
  2311.  
  2312. method DPGOperation::findNrMethods {this name} {
  2313.     set nr 0
  2314.     foreach feature [[$this ooplClass] operationSet] {
  2315.         if {[string tolower [$feature getName]] == $name} {
  2316.             incr nr 1
  2317.         }
  2318.     }
  2319.     return $nr
  2320. }
  2321.  
  2322. method DPGOperation::isEvent {this} {
  2323.     if {[$this getPropertyValue "is_event"] == 1} {
  2324.         return 1
  2325.     } else {
  2326.         return 0
  2327.     }
  2328. }
  2329.  
  2330. # Do not delete this line -- regeneration end marker
  2331.  
  2332. if [isCommand CMOperation] {
  2333.     Class  DPGOperationD : {DPGOperation CMOperation} {
  2334.     }
  2335. } else {
  2336.     Class DPGOperationD : {DPGOperation OPOperation} {    
  2337.     }
  2338. }
  2339.  
  2340. global mostDerivedOOPL ; set mostDerivedOOPL(OPOperation) DPGOperationD
  2341.  
  2342. selfPromoter OPOperation {this} {
  2343.     DPGOperationD promote $this
  2344. }
  2345.  
  2346.  
  2347. #---------------------------------------------------------------------------
  2348. #      File:           @(#)dpgassocin.tcl    /main/titanic/12
  2349.  
  2350.  
  2351. Class DPGAssocInitializer : {DPGInitializer} {
  2352.     constructor
  2353.     method destructor
  2354.     method generate
  2355. }
  2356.  
  2357. constructor DPGAssocInitializer {class this name} {
  2358.     set this [DPGInitializer::constructor $class $this $name]
  2359.     # Start constructor user section
  2360.     # End constructor user section
  2361.     return $this
  2362. }
  2363.  
  2364. method DPGAssocInitializer::destructor {this} {
  2365.     # Start destructor user section
  2366.     # End destructor user section
  2367. }
  2368.  
  2369. method DPGAssocInitializer::generate {this ctor} {
  2370.     if {[[[$this assoc] ooplType] ooplClass] != ""} {
  2371.         if {[[[[$this assoc] ooplType] ooplClass] isComponent]} {
  2372.             return
  2373.         }
  2374.     }
  2375.  
  2376.     [$this assoc] setGenerator
  2377.  
  2378.     set typename [[[$this assoc] generator] typename]
  2379.     set varname [[[$this assoc] generator] varname]
  2380.     set varref [[[$this assoc] generator] varref]
  2381.     set varset [[[$this assoc] generator] varset]
  2382.     set vardict [[[$this assoc] generator] vardict]
  2383.     if {[[$this assoc] opposite] != ""} {
  2384.         set opvarname [[[$this assoc] generator] opvarname]
  2385.         set opvarref [[[$this assoc] generator] opvarref]
  2386.         set opvarset [[[$this assoc] generator] opvarset]
  2387.         set opvardict [[[$this assoc] generator] opvardict]
  2388.     }
  2389.     set varname "new${varname}"
  2390.     set castRefname [[[$this assoc] generator] castType $varref]
  2391.  
  2392.     # ToDo: Clean this up!!
  2393.     #
  2394.     set assoctype [[$this assoc] generateAssocType [[[$this constructor] ooplClass] target]]
  2395.  
  2396.  
  2397.     if {[[$this assoc] isMandatory]} {
  2398.         [$ctor gencode] append "if (${varname} <> NIL) then\nbegin\n"
  2399.         [$ctor gencode] indent +
  2400.     }
  2401.     if {[[$this assoc] getMultiplicity] == "one"} {
  2402.         if {[[$this assoc] isMandatory] &&
  2403.             [[$this assoc] opposite] != ""} {
  2404.             if {[[[$this assoc] opposite] isQualified]} {
  2405.                 if {[[[$this assoc] opposite] get_obj_type] == "qual_link_attrib"} {
  2406.                     [$ctor gencode] append "${varref} := ${varname};\n"
  2407.                     set key [[[$this constructor] qualInitializer] getName]
  2408.                     if {[[[$this assoc] opposite] getMultiplicity] == "one"} {
  2409.                         [$ctor gencode] append "${castRefname}.${opvardict}.Add(${key}, SELF);\n"
  2410.                     } else {
  2411.                         set tempset "temp${opvarset}"
  2412.                         set manytype [[$this assoc] generateManyAssocType [[[$this constructor] ooplClass] target]]
  2413.                         [$ctor gentypes] append "var\n"
  2414.                         [$ctor gentypes] indent +
  2415.                         [$ctor gentypes] append "${tempset}: [$manytype name];\n"
  2416.                         [$ctor gentypes] indent -
  2417.  
  2418.                         [$ctor gencode] append "if (${castRefname}.${opvardict}.Item(${key}) <> NIL) then\nbegin\n"
  2419.                         [$ctor gencode] indent +
  2420.                         [$ctor gencode] append "${tempset} := ${castRefname}.${opvardict}.Item(${key});\n"
  2421.                         [$ctor gencode] indent -
  2422.                         [$ctor gencode] append "end\n"
  2423.                         [$ctor gencode] append "else\n"
  2424.                         [$ctor gencode] append "begin\n"
  2425.                         [$ctor gencode] indent +
  2426.                         [$ctor gencode] append "${tempset} := [$manytype name].Create;\n"
  2427.                         [$ctor gencode] append "${castRefname}.${opvardict}.Add(${key}, ${tempset})\n"
  2428.                         [$ctor gencode] indent -
  2429.                         [$ctor gencode] append "end;\n"
  2430.                         [$ctor gencode] append "${tempset}.Add(SELF);\n"
  2431.                     }
  2432.                 } else {
  2433.                     m4_warning $W_NOCTORCODE [[[$this assoc] ooplClass] getName] [[[[$this assoc] opposite] ooplClass] getName]
  2434.                 }
  2435.             } else {
  2436.                 [$ctor gencode] append "${varref} := ${varname};\n"
  2437.                 if {[[[$this assoc] opposite] getMultiplicity] == "one"} {
  2438.                     [$ctor gencode] append "${castRefname}.${opvarref} := SELF;\n"
  2439.                 } else {
  2440.                     [$ctor gencode] append "${castRefname}.${opvarset}.Add(SELF);\n"
  2441.                 }
  2442.             }
  2443.         } else {
  2444.             [$ctor gencode] append "${varref} := ${varname};\n"
  2445.         }
  2446.     } else {
  2447.         set manytype [[$this assoc] generateManyAssocType [[[$this constructor] ooplClass] target]]
  2448.         [$ctor gencode] append "${varset} := [$manytype name].Create;\n";
  2449.         [$ctor gencode] append "add[cap ${varname}](${varname});\n"
  2450.     }
  2451.  
  2452.     if {[[$this assoc] isMandatory]} {
  2453.         set sysutilstype [DPType new]
  2454.         $sysutilstype includeName "SysUtils"
  2455.         $sysutilstype includeType "imp"
  2456.         $sysutilstype addAsInclude [[[$this constructor] ooplClass] target]
  2457.  
  2458.         [$ctor gencode] indent -
  2459.         [$ctor gencode] append "end\nelse\n"
  2460.         [$ctor gencode] indent +
  2461.         [$ctor gencode] append "raise EInvalidOp.Create('Object ${varname} has mandatory relation. NIL object reference not allowed.');\n"
  2462.         [$ctor gencode] indent -
  2463.     }
  2464. }
  2465.  
  2466. # Do not delete this line -- regeneration end marker
  2467.  
  2468. if [isCommand CMAssocInitializer] {
  2469.     Class  DPGAssocInitializerD : {DPGAssocInitializer CMAssocInitializer} {
  2470.     }
  2471. } else {
  2472.     Class DPGAssocInitializerD : {DPGAssocInitializer OPAssocInitializer} {    
  2473.     }
  2474. }
  2475.  
  2476. global mostDerivedOOPL ; set mostDerivedOOPL(OPAssocInitializer) DPGAssocInitializerD
  2477.  
  2478. selfPromoter OPAssocInitializer {this} {
  2479.     DPGAssocInitializerD promote $this
  2480. }
  2481.  
  2482.  
  2483. #---------------------------------------------------------------------------
  2484. #      File:           @(#)dpgattribi.tcl    /main/titanic/4
  2485.  
  2486.  
  2487. Class DPGAttribInitializer : {DPGInitializer} {
  2488.     constructor
  2489.     method destructor
  2490.     method checkLocal
  2491.     method generate
  2492. }
  2493.  
  2494. constructor DPGAttribInitializer {class this name} {
  2495.     set this [DPGInitializer::constructor $class $this $name]
  2496.     # Start constructor user section
  2497.     # End constructor user section
  2498.     return $this
  2499. }
  2500.  
  2501. method DPGAttribInitializer::destructor {this} {
  2502.     # Start destructor user section
  2503.     # End destructor user section
  2504. }
  2505.  
  2506. method DPGAttribInitializer::checkLocal {this} {
  2507.     set errornr 0
  2508.     if {[[$this attrib] isClassFeature]} {
  2509.         m4_warning $W_NOKEYFEAT [[$this attrib] getName] [[[$this attrib] ooplClass] getName]
  2510.         incr errornr 1
  2511.     }
  2512.     return $errornr
  2513. }
  2514.  
  2515. method DPGAttribInitializer::generate {this ctor} {
  2516.     if {[$this checkLocal] > 0} {
  2517.         return
  2518.     }
  2519.     [$ctor gencode] append "[[$this attrib] getName] := [$this getName];\n"
  2520. }
  2521.  
  2522. # Do not delete this line -- regeneration end marker
  2523.  
  2524. if [isCommand CMAttribInitializer] {
  2525.     Class  DPGAttribInitializerD : {DPGAttribInitializer CMAttribInitializer} {
  2526.     }
  2527. } else {
  2528.     Class DPGAttribInitializerD : {DPGAttribInitializer OPAttribInitializer} {    
  2529.     }
  2530. }
  2531.  
  2532. global mostDerivedOOPL ; set mostDerivedOOPL(OPAttribInitializer) DPGAttribInitializerD
  2533.  
  2534. selfPromoter OPAttribInitializer {this} {
  2535.     DPGAttribInitializerD promote $this
  2536. }
  2537.  
  2538.  
  2539. #---------------------------------------------------------------------------
  2540. #      File:           @(#)dpginhkeyi.tcl    /main/titanic/3
  2541.  
  2542.  
  2543. Class DPGInhKeyInitializer : {DPGInitializer} {
  2544.     constructor
  2545.     method destructor
  2546.     method generate
  2547. }
  2548.  
  2549. constructor DPGInhKeyInitializer {class this name} {
  2550.     set this [DPGInitializer::constructor $class $this $name]
  2551.     # Start constructor user section
  2552.     # End constructor user section
  2553.     return $this
  2554. }
  2555.  
  2556. method DPGInhKeyInitializer::destructor {this} {
  2557.     # Start destructor user section
  2558.     # End destructor user section
  2559. }
  2560.  
  2561. method DPGInhKeyInitializer::generate {this ctor} {
  2562.     # !! Implement this function !!
  2563. }
  2564.  
  2565. # Do not delete this line -- regeneration end marker
  2566.  
  2567. if [isCommand CMInhKeyInitializer] {
  2568.     Class  DPGInhKeyInitializerD : {DPGInhKeyInitializer CMInhKeyInitializer} {
  2569.     }
  2570. } else {
  2571.     Class DPGInhKeyInitializerD : {DPGInhKeyInitializer OPInhKeyInitializer} {    
  2572.     }
  2573. }
  2574.  
  2575. global mostDerivedOOPL ; set mostDerivedOOPL(OPInhKeyInitializer) DPGInhKeyInitializerD
  2576.  
  2577. selfPromoter OPInhKeyInitializer {this} {
  2578.     DPGInhKeyInitializerD promote $this
  2579. }
  2580.  
  2581.  
  2582. #---------------------------------------------------------------------------
  2583. #      File:           @(#)dpgqualini.tcl    /main/titanic/3
  2584.  
  2585.  
  2586. Class DPGQualInitializer : {DPGInitializer} {
  2587.     constructor
  2588.     method destructor
  2589.     method generate
  2590. }
  2591.  
  2592. constructor DPGQualInitializer {class this name} {
  2593.     set this [DPGInitializer::constructor $class $this $name]
  2594.     # Start constructor user section
  2595.     # End constructor user section
  2596.     return $this
  2597. }
  2598.  
  2599. method DPGQualInitializer::destructor {this} {
  2600.     # Start destructor user section
  2601.     # End destructor user section
  2602. }
  2603.  
  2604. method DPGQualInitializer::generate {this ctor} {
  2605.     # !! Implement this function !!
  2606. }
  2607.  
  2608. # Do not delete this line -- regeneration end marker
  2609.  
  2610. if [isCommand CMQualInitializer] {
  2611.     Class  DPGQualInitializerD : {DPGQualInitializer CMQualInitializer} {
  2612.     }
  2613. } else {
  2614.     Class DPGQualInitializerD : {DPGQualInitializer OPQualInitializer} {    
  2615.     }
  2616. }
  2617.  
  2618. global mostDerivedOOPL ; set mostDerivedOOPL(OPQualInitializer) DPGQualInitializerD
  2619.  
  2620. selfPromoter OPQualInitializer {this} {
  2621.     DPGQualInitializerD promote $this
  2622. }
  2623.  
  2624.  
  2625. #---------------------------------------------------------------------------
  2626. #      File:           @(#)dpgsupercl.tcl    /main/titanic/4
  2627.  
  2628.  
  2629. Class DPGSuperClassInitializer : {DPGInitializer} {
  2630.     constructor
  2631.     method destructor
  2632.     method generate
  2633. }
  2634.  
  2635. constructor DPGSuperClassInitializer {class this name} {
  2636.     set this [DPGInitializer::constructor $class $this $name]
  2637.     # Start constructor user section
  2638.     # End constructor user section
  2639.     return $this
  2640. }
  2641.  
  2642. method DPGSuperClassInitializer::destructor {this} {
  2643.     # Start destructor user section
  2644.     # End destructor user section
  2645. }
  2646.  
  2647. method DPGSuperClassInitializer::generate {this ctor} {
  2648.     foreach param [$this parameterSet] {
  2649.         if {![$param isGUIComponent [$this ooplClass]]} {
  2650.             $param generate $ctor
  2651.         }
  2652.     }
  2653. }
  2654.  
  2655. # Do not delete this line -- regeneration end marker
  2656.  
  2657. if [isCommand CMSuperClassInitializer] {
  2658.     Class  DPGSuperClassInitializerD : {DPGSuperClassInitializer CMSuperClassInitializer} {
  2659.     }
  2660. } else {
  2661.     Class DPGSuperClassInitializerD : {DPGSuperClassInitializer OPSuperClassInitializer} {    
  2662.     }
  2663. }
  2664.  
  2665. global mostDerivedOOPL ; set mostDerivedOOPL(OPSuperClassInitializer) DPGSuperClassInitializerD
  2666.  
  2667. selfPromoter OPSuperClassInitializer {this} {
  2668.     DPGSuperClassInitializerD promote $this
  2669. }
  2670.  
  2671.  
  2672. #---------------------------------------------------------------------------
  2673. #      File:           @(#)dpgctorpar.tcl    /main/titanic/9
  2674.  
  2675.  
  2676. Class DPGCtorParameter : {DPGParameter} {
  2677.     constructor
  2678.     method destructor
  2679.     method isGUIComponent
  2680.     method generate
  2681. }
  2682.  
  2683. constructor DPGCtorParameter {class this name} {
  2684.     set this [DPGParameter::constructor $class $this $name]
  2685.     # Start constructor user section
  2686.     # End constructor user section
  2687.     return $this
  2688. }
  2689.  
  2690. method DPGCtorParameter::destructor {this} {
  2691.     # Start destructor user section
  2692.     # End destructor user section
  2693. }
  2694.  
  2695. method DPGCtorParameter::isGUIComponent {this class} {
  2696.     if {![$class isForm] && ![$class isComponent]} {
  2697.         return 0
  2698.     }
  2699.     set done 0
  2700.     while {!$done} {
  2701.         foreach assoc [$class genAssocAttrSet] {
  2702.             if {[$assoc getName] == [$this getName]} {
  2703.                 if {[$assoc isAggregate]} {
  2704.                     if {[[$assoc ooplClass] isGUIComponent]} {
  2705.                         return 1
  2706.                     }
  2707.                 }
  2708.             }
  2709.         }
  2710.         set class [$class getSuperClass]
  2711.         if {[$class getName] == "TForm" ||
  2712.             [$class getName] == "TDataModule" ||
  2713.             [$class getName] == "TComponent" ||
  2714.             [$class getName] == "TControl"} {
  2715.             set done 1
  2716.         } 
  2717.     }
  2718.     return 0
  2719. }
  2720.  
  2721. method DPGCtorParameter::generate {this method} {
  2722.  
  2723.     if {[$this attrib] != ""} {
  2724.         if [[$this attrib] isClassFeature] {
  2725.             return
  2726.         }
  2727.     }
  2728.  
  2729.     # check if GUI association
  2730.     #
  2731.     if {[$this initializer] != ""} {
  2732.         if {[[$this initializer] isA OPAssocInitializer]} {
  2733.             if {[[[[$this initializer] assoc] ooplType] ooplClass] != ""} {
  2734.                 if {[[[[[$this initializer] assoc] ooplType] ooplClass] isComponent]} {
  2735.                     return
  2736.                 }
  2737.             }
  2738.         }
  2739.     }
  2740.     set param [DPArgument new [[$this ooplType] generateParamType]]
  2741.     $param name [$this getName]
  2742.  
  2743.     # check if association initializer parameter
  2744.     #
  2745.     if {[$this initializer] != ""} {
  2746.         if {[[$this initializer] isA OPAssocInitializer]} {
  2747.             $param name "new[$this getName]"
  2748.         } else {
  2749.             if {[[$this initializer] isA OPSuperClassInitializer]} {
  2750.                 $param name "sc_[$this getName]"
  2751.             }
  2752.         }
  2753.     }
  2754.  
  2755.     $param passedBy [$this getPropertyValue "pass_by"]
  2756.     $method addArg $param
  2757. }
  2758.  
  2759. # Do not delete this line -- regeneration end marker
  2760.  
  2761. if [isCommand CMCtorParameter] {
  2762.     Class  DPGCtorParameterD : {DPGCtorParameter CMCtorParameter} {
  2763.     }
  2764. } else {
  2765.     Class DPGCtorParameterD : {DPGCtorParameter OPCtorParameter} {    
  2766.     }
  2767. }
  2768.  
  2769. global mostDerivedOOPL ; set mostDerivedOOPL(OPCtorParameter) DPGCtorParameterD
  2770.  
  2771. selfPromoter OPCtorParameter {this} {
  2772.     DPGCtorParameterD promote $this
  2773. }
  2774.  
  2775.  
  2776. #---------------------------------------------------------------------------
  2777. #      File:           @(#)dpgoperpar.tcl    /main/titanic/4
  2778.  
  2779.  
  2780. Class DPGOperParameter : {DPGParameter} {
  2781.     constructor
  2782.     method destructor
  2783.     method generate
  2784. }
  2785.  
  2786. constructor DPGOperParameter {class this name} {
  2787.     set this [DPGParameter::constructor $class $this $name]
  2788.     # Start constructor user section
  2789.     # End constructor user section
  2790.     return $this
  2791. }
  2792.  
  2793. method DPGOperParameter::destructor {this} {
  2794.     # Start destructor user section
  2795.     # End destructor user section
  2796. }
  2797.  
  2798. method DPGOperParameter::generate {this method} {
  2799.     set param [DPArgument new [[$this ooplType] generateParamType]]
  2800.     $param name [$this getName]
  2801.     $param passedBy [$this getPropertyValue "pass_by"]
  2802.     $method addArg $param
  2803. }
  2804.  
  2805. # Do not delete this line -- regeneration end marker
  2806.  
  2807. if [isCommand CMOperParameter] {
  2808.     Class  DPGOperParameterD : {DPGOperParameter CMOperParameter} {
  2809.     }
  2810. } else {
  2811.     Class DPGOperParameterD : {DPGOperParameter OPOperParameter} {    
  2812.     }
  2813. }
  2814.  
  2815. global mostDerivedOOPL ; set mostDerivedOOPL(OPOperParameter) DPGOperParameterD
  2816.  
  2817. selfPromoter OPOperParameter {this} {
  2818.     DPGOperParameterD promote $this
  2819. }
  2820.  
  2821.  
  2822. #---------------------------------------------------------------------------
  2823. #      File:           @(#)dpgbasetyp.tcl    /main/titanic/5
  2824.  
  2825.  
  2826. Class DPGBaseType : {DPGType} {
  2827.     constructor
  2828.     method destructor
  2829.     method generate
  2830. }
  2831.  
  2832. constructor DPGBaseType {class this name} {
  2833.     set this [DPGType::constructor $class $this $name]
  2834.     # Start constructor user section
  2835.     # End constructor user section
  2836.     return $this
  2837. }
  2838.  
  2839. method DPGBaseType::destructor {this} {
  2840.     # Start destructor user section
  2841.     # End destructor user section
  2842. }
  2843.  
  2844. method DPGBaseType::generate {this} {
  2845.     set type [DPType new]
  2846.     $type name [$this getType3GL]
  2847.     $type includeType "none"
  2848.     $type includeName ""
  2849.     return $type
  2850. }
  2851.  
  2852. # Do not delete this line -- regeneration end marker
  2853.  
  2854. if [isCommand CMBaseType] {
  2855.     Class  DPGBaseTypeD : {DPGBaseType CMBaseType} {
  2856.     }
  2857. } else {
  2858.     Class DPGBaseTypeD : {DPGBaseType OPBaseType} {    
  2859.     }
  2860. }
  2861.  
  2862. global mostDerivedOOPL ; set mostDerivedOOPL(OPBaseType) DPGBaseTypeD
  2863.  
  2864. selfPromoter OPBaseType {this} {
  2865.     DPGBaseTypeD promote $this
  2866. }
  2867.  
  2868.  
  2869. #---------------------------------------------------------------------------
  2870. #      File:           @(#)dpgclassty.tcl    /main/titanic/3
  2871.  
  2872.  
  2873. Class DPGClassType : {DPGType} {
  2874.     constructor
  2875.     method destructor
  2876. }
  2877.  
  2878. constructor DPGClassType {class this name} {
  2879.     set this [DPGType::constructor $class $this $name]
  2880.     # Start constructor user section
  2881.     # End constructor user section
  2882.     return $this
  2883. }
  2884.  
  2885. method DPGClassType::destructor {this} {
  2886.     # Start destructor user section
  2887.     # End destructor user section
  2888. }
  2889.  
  2890. # Do not delete this line -- regeneration end marker
  2891.  
  2892. if [isCommand CMClassType] {
  2893.     Class  DPGClassTypeD : {DPGClassType CMClassType} {
  2894.     }
  2895. } else {
  2896.     Class DPGClassTypeD : {DPGClassType OPClassType} {    
  2897.     }
  2898. }
  2899.  
  2900. global mostDerivedOOPL ; set mostDerivedOOPL(OPClassType) DPGClassTypeD
  2901.  
  2902. selfPromoter OPClassType {this} {
  2903.     DPGClassTypeD promote $this
  2904. }
  2905.  
  2906.  
  2907. #---------------------------------------------------------------------------
  2908. #      File:           @(#)dpgenumtyp.tcl    /main/titanic/3
  2909.  
  2910.  
  2911. Class DPGEnumType : {DPGType} {
  2912.     constructor
  2913.     method destructor
  2914. }
  2915.  
  2916. constructor DPGEnumType {class this name} {
  2917.     set this [DPGType::constructor $class $this $name]
  2918.     # Start constructor user section
  2919.     # End constructor user section
  2920.     return $this
  2921. }
  2922.  
  2923. method DPGEnumType::destructor {this} {
  2924.     # Start destructor user section
  2925.     # End destructor user section
  2926. }
  2927.  
  2928. # Do not delete this line -- regeneration end marker
  2929.  
  2930. if [isCommand CMEnumType] {
  2931.     Class  DPGEnumTypeD : {DPGEnumType CMEnumType} {
  2932.     }
  2933. } else {
  2934.     Class DPGEnumTypeD : {DPGEnumType OPEnumType} {    
  2935.     }
  2936. }
  2937.  
  2938. global mostDerivedOOPL ; set mostDerivedOOPL(OPEnumType) DPGEnumTypeD
  2939.  
  2940. selfPromoter OPEnumType {this} {
  2941.     DPGEnumTypeD promote $this
  2942. }
  2943.  
  2944.  
  2945. #---------------------------------------------------------------------------
  2946. #      File:           @(#)dpgtypedef.tcl    /main/titanic/3
  2947.  
  2948.  
  2949. Class DPGTypeDefType : {DPGType} {
  2950.     constructor
  2951.     method destructor
  2952. }
  2953.  
  2954. constructor DPGTypeDefType {class this name} {
  2955.     set this [DPGType::constructor $class $this $name]
  2956.     # Start constructor user section
  2957.     # End constructor user section
  2958.     return $this
  2959. }
  2960.  
  2961. method DPGTypeDefType::destructor {this} {
  2962.     # Start destructor user section
  2963.     # End destructor user section
  2964. }
  2965.  
  2966. # Do not delete this line -- regeneration end marker
  2967.  
  2968. if [isCommand CMTypeDefType] {
  2969.     Class  DPGTypeDefTypeD : {DPGTypeDefType CMTypeDefType} {
  2970.     }
  2971. } else {
  2972.     Class DPGTypeDefTypeD : {DPGTypeDefType OPTypeDefType} {    
  2973.     }
  2974. }
  2975.  
  2976. global mostDerivedOOPL ; set mostDerivedOOPL(OPTypeDefType) DPGTypeDefTypeD
  2977.  
  2978. selfPromoter OPTypeDefType {this} {
  2979.     DPGTypeDefTypeD promote $this
  2980. }
  2981.  
  2982.  
  2983. #---------------------------------------------------------------------------
  2984. #      File:           @(#)dpgassocma.tcl    /main/titanic/14
  2985.  
  2986.  
  2987. Class DPGAssocMany : {DPGAssocGen} {
  2988.     constructor
  2989.     method destructor
  2990.     method hasAdd
  2991.     method hasDtor
  2992.     method hasRemove
  2993.     method generate
  2994.     method generateAdd
  2995.     method generateGet
  2996.     method generateRemove
  2997.     method generateDtor
  2998. }
  2999.  
  3000. constructor DPGAssocMany {class this assocattr} {
  3001.     set this [DPGAssocGen::constructor $class $this $assocattr]
  3002.     # Start constructor user section
  3003.     # End constructor user section
  3004.     return $this
  3005. }
  3006.  
  3007. method DPGAssocMany::destructor {this} {
  3008.     # Start destructor user section
  3009.     # End destructor user section
  3010.     $this DPGAssocGen::destructor
  3011. }
  3012.  
  3013. method DPGAssocMany::hasAdd {this self} {
  3014.     set wr [$this propWrite]
  3015.     if {$self} {
  3016.         if {$wr == "None"} {
  3017.             return 0
  3018.         }
  3019.     } else {
  3020.         if {$wr == "None" || $wr == "Private" || $wr == "Protected"} {
  3021.             return 0
  3022.         }
  3023.     }
  3024.     if {[[$this assocattr] opposite] != ""} {
  3025.         if {[[[$this assocattr] opposite] isQualified]} {
  3026.             if {![$this addWarning]} {
  3027.                 $this addWarning 1
  3028.                 m4_warning $W_NOADD [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
  3029.             }
  3030.             return 0
  3031.         }
  3032.     }
  3033.     return 1
  3034. }
  3035.  
  3036. method DPGAssocMany::hasDtor {this self} {
  3037.     if {[[$this assocattr] opposite] != ""} {
  3038.         if {[[[$this assocattr] opposite] isQualified]} {
  3039.             if {![$this dtorWarning]} {
  3040.                 $this dtorWarning 1
  3041.                 m4_warning $W_NODTOR [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
  3042.             }
  3043.             return 0
  3044.         }
  3045.     }
  3046.     return 1
  3047. }
  3048.  
  3049. method DPGAssocMany::hasRemove {this self} {
  3050.     set wr [$this propWrite]
  3051.     if {$self} {
  3052.         if {$wr == "None"} {
  3053.             return 0
  3054.         }
  3055.     } else {
  3056.         if {$wr == "None" || $wr == "Private" || $wr == "Protected"} {
  3057.             return 0
  3058.         }
  3059.     }
  3060.     if {[[$this assocattr] opposite] != ""} {
  3061.         if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
  3062.             return 0
  3063.         }
  3064.         if {[[[$this assocattr] opposite] isQualified]} {
  3065.             if {![$this removeWarning]} {
  3066.                 $this removeWarning 1
  3067.                 m4_warning $W_NOREMOVE [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
  3068.             }
  3069.             return 0
  3070.         }
  3071.     }
  3072.     return 1
  3073. }
  3074.  
  3075. method DPGAssocMany::generate {this cl} {
  3076.  
  3077.     if {[$this checkLocal] > 0} {
  3078.             return
  3079.                 }
  3080.     set manytype [[$this assocattr] generateManyAssocType $cl]
  3081.     set vari [DPVariable new $manytype]
  3082.     $vari name "[[$this assocattr] getName]Set"
  3083.     $cl addAssocvar $vari
  3084.     $vari access [$this propAccess]
  3085.     if {[$cl constructr] != ""} {
  3086.         [[$cl constructr] gencode] append "[$vari name] := [$manytype name].Create;\n"
  3087.     }
  3088.     if {[[$this assocattr] opposite] != ""} {
  3089.         [[$this assocattr] opposite] setGenerator
  3090.     }
  3091.     $this generateGet $vari $cl
  3092.     $this generateAdd $vari $cl
  3093.     $this generateRemove $vari $cl
  3094.     $this generateDtor $vari $cl
  3095. }
  3096.  
  3097. method DPGAssocMany::generateAdd {this vari cl} {
  3098.     # Check if Add method should be generated
  3099.     #
  3100.     if {![$this hasAdd 0]} {
  3101.         $vari access "Public"
  3102.     }
  3103.     if {![$this hasAdd 1]} {
  3104.         return
  3105.     }
  3106.  
  3107.     # Generate
  3108.     #
  3109.     set type [$this generateType $cl]
  3110.     set arg "new[$this typename]"
  3111.     set param [DPArgument new $type]
  3112.     $param name $arg
  3113.     set addproc [DPProcedure new]
  3114.     $addproc addArg $param
  3115.     set addcode [DPTextSection new]
  3116.  
  3117.     $addproc gencode $addcode
  3118.     $addproc hasUserSection 0
  3119.     $addproc access [$this propWrite]
  3120.     $addproc name "add[cap [$this varname]]"
  3121.  
  3122.     $addcode append "if ([$vari name].IndexOf(${arg}) = -1) then\nbegin\n"
  3123.     $addcode indent +
  3124.     $addcode append "[$vari name].Add(${arg});\n"
  3125.  
  3126.     if {[[$this assocattr] opposite] != ""} {
  3127.         if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  3128.             
  3129.             # many-many
  3130.             #
  3131.             if {[[[[$this assocattr] opposite] generator] hasAdd 0]} {
  3132.                 $addcode append "[$this castType $arg].add[cap [$this opvarname]](SELF);\n"
  3133.             } else {
  3134.                 $addcode append "[$this castType $arg].[$this opvarset].Add(SELF);\n"
  3135.             }
  3136.         } else {
  3137.             # one-many
  3138.             if {[[[[$this assocattr] opposite] generator] hasSet 0]} {
  3139.                 $addcode append "[$this castType $arg].set[cap [$this opvarname]](SELF);\n"
  3140.             } else {
  3141.                 $addcode append "[$this castType $arg].[$this opvarref] := SELF;\n"
  3142.             }
  3143.         }
  3144.     }
  3145.  
  3146.     $addcode indent -
  3147.     $addcode append "end;\n"
  3148.  
  3149.     $cl addAssocgenmethod $addproc
  3150. }
  3151.  
  3152. method DPGAssocMany::generateGet {this vari cl} {
  3153.     # Check if Get method should be generated
  3154.     #
  3155.     if {![$this hasGet 0]} {
  3156.         $vari access "Public"
  3157.     }
  3158.     if {![$this hasGet 1]} {
  3159.         return
  3160.     }
  3161.  
  3162.     # Generate
  3163.     #
  3164.     set type [[$this assocattr] generateManyAssocType $cl]
  3165.     set getproc [DPFunction new $type]
  3166.     set getcode [DPTextSection new]
  3167.     $getproc gencode $getcode
  3168.     $getproc hasUserSection 0
  3169.     $getproc access [$this propRead]
  3170.     $getproc name "get[cap [$this varname]]"
  3171.     $getcode append "[$getproc name] := "
  3172.     $getcode append "[$this varset];\n"
  3173.     $cl addAssocgenmethod $getproc
  3174. }
  3175.  
  3176. method DPGAssocMany::generateRemove {this vari cl} {
  3177.     # Check if Remove method should be generated
  3178.     #
  3179.     if {![$this hasRemove 0]} {
  3180.         $vari access "Public"
  3181.     }
  3182.     if {![$this hasRemove 1]} {
  3183.         return
  3184.     }
  3185.  
  3186.     # Generated
  3187.     #
  3188.     set removeproc [DPProcedure new]
  3189.     set type [$this generateType $cl]
  3190.     set arg "old[$this typename]"
  3191.     set param [DPArgument new $type]
  3192.     $param name $arg
  3193.     $removeproc addArg $param
  3194.  
  3195.     set removecode [DPTextSection new]
  3196.     $removeproc gencode $removecode
  3197.     $removeproc hasUserSection 0
  3198.     $removeproc access [$this propWrite]
  3199.     $removeproc name "remove[cap [$this varname]]"
  3200.  
  3201.     $removecode append "if ([$vari name].IndexOf(${arg}) <> -1) then\nbegin\n"
  3202.     $removecode indent +
  3203.     $removecode append "[$vari name].Remove(${arg});\n"
  3204.  
  3205.     if {[[$this assocattr] opposite] != ""} {
  3206.         if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
  3207.             $removecode append "[$this castType $arg].remove[cap [$this opvarname]]("
  3208.             if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  3209.                 $removecode append "SELF"
  3210.             }
  3211.             $removecode append ");\n"
  3212.         } else {
  3213.             if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  3214.                 $removecode append "[$this castType $arg].[$this opvarset].Remove(SELF);\n"
  3215.             } else {
  3216.                 $removecode append "[$this castType $arg].[$this opvarref] := NIL;\n"
  3217.             }
  3218.         }
  3219.     }
  3220.     $removecode indent -
  3221.     $removecode append "end;\n"
  3222.  
  3223.     $cl addAssocgenmethod $removeproc
  3224. }
  3225.  
  3226. method DPGAssocMany::generateDtor {this vari cl} {
  3227.  
  3228.     # Check if Destructor should be generated
  3229.     #
  3230.     if {![$this hasDtor 1]} {
  3231.         [[$cl destructr] gencode] append "[$this varset].Destroy;\n"
  3232.         return
  3233.     }
  3234.     # Generate
  3235.     #
  3236.  
  3237.     if {[[$this assocattr] opposite] != ""} {
  3238.         if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
  3239.             set sysutilstype [DPType new]
  3240.             $sysutilstype includeName "SysUtils"
  3241.             $sysutilstype includeType "imp"
  3242.             $sysutilstype addAsInclude [[[[[$this assocattr] opposite] ooplType] ooplClass] target]
  3243.             [[$cl destructr] gencode] append "if ([$this varset].Count <> 0) then\n"
  3244.             [[$cl destructr] gencode] indent +
  3245.             [[$cl destructr] gencode] append "raise EInvalidOp.Create('Illegal object destruction. Mandatory relation "
  3246.             [[$cl destructr] gencode] append "[$this varset] not empty.');\n"
  3247.             [[$cl destructr] gencode] indent -
  3248.             [[$cl destructr] gencode] append "[$this varset].Destroy;\n"
  3249.             return
  3250.         }
  3251.  
  3252.         [[$cl destructr] gencode] append "while ([$this varset].Count > 0) do\nbegin\n"
  3253.         [[$cl destructr] gencode] indent +
  3254.         if {[$this hasRemove 1]} {
  3255.             [[$cl destructr] gencode] append "remove[cap [$this varname]]([$this varset].First)\n"
  3256.         } else {
  3257.             set old "old[$this typename]"
  3258.  
  3259.             [[$cl destructr] gentypes] append "var\n"
  3260.             [[$cl destructr] gentypes] indent +
  3261.             [[$cl destructr] gentypes] append "${old}: [[$vari type] name];\n\n"
  3262.             [[$cl destructr] gentypes] indent -
  3263.             [[$cl destructr] gencode] append "${old} := [$this varset].First;\n"
  3264.             [[$cl destructr] gencode] append "[$this varset].Remove(${old});\n"
  3265.             if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
  3266.                 [[$cl destructr] gencode] append "${old}.remove[cap [$this varname]];\n"
  3267.             } else {
  3268.                 [[$cl destructr] gencode] append "${old}.[$this opvarname] := NIL;\n"
  3269.             }
  3270.         }
  3271.             
  3272.         [[$cl destructr] gencode] indent -
  3273.         [[$cl destructr] gencode] append "end;\n"
  3274.     }
  3275.  
  3276.     [[$cl destructr] gencode] append "[$this varset].Destroy;\n"
  3277. }
  3278.  
  3279. # Do not delete this line -- regeneration end marker
  3280.  
  3281.  
  3282.  
  3283. #---------------------------------------------------------------------------
  3284. #      File:           @(#)dpgassocon.tcl    /main/titanic/13
  3285.  
  3286.  
  3287. Class DPGAssocOne : {DPGAssocGen} {
  3288.     constructor
  3289.     method destructor
  3290.     method hasSet
  3291.     method hasDtor
  3292.     method hasRemove
  3293.     method generate
  3294.     method generateSet
  3295.     method generateGet
  3296.     method generateRemove
  3297.     method generateDtor
  3298. }
  3299.  
  3300. constructor DPGAssocOne {class this assocattr} {
  3301.     set this [DPGAssocGen::constructor $class $this $assocattr]
  3302.     # Start constructor user section
  3303.     # End constructor user section
  3304.     return $this
  3305. }
  3306.  
  3307. method DPGAssocOne::destructor {this} {
  3308.     # Start destructor user section
  3309.     # End destructor user section
  3310.     $this DPGAssocGen::destructor
  3311. }
  3312.  
  3313. method DPGAssocOne::hasSet {this self} {
  3314.     set wr [$this propWrite]
  3315.     if {$self} {
  3316.         if {$wr == "None"} {
  3317.                 return 0
  3318.         }
  3319.     } else {
  3320.         if {$wr == "None" || $wr == "Private" || $wr == "Protected"} {
  3321.                 return 0
  3322.         }
  3323.     }
  3324.     if {[[$this assocattr] opposite] != ""} {
  3325.         if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
  3326.             return 0
  3327.         }
  3328.         if {[[[$this assocattr] opposite] isQualified]} {
  3329.             if {![$this setWarning]} {
  3330.                 $this setWarning 1
  3331.                 m4_warning $W_NOSET [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
  3332.             }
  3333.             return 0
  3334.         }
  3335.     }
  3336.     return 1
  3337. }
  3338.  
  3339. method DPGAssocOne::hasDtor {this self} {
  3340.     if {[[$this assocattr] opposite] != ""} {
  3341.        if {[[[$this assocattr] opposite] isQualified] && [[[$this assocattr] opposite] getMultiplicity] != "one"} {
  3342.            if {![$this dtorWarning]} {
  3343.             $this dtorWarning 1
  3344.               m4_warning $W_NODTOR [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
  3345.           }
  3346.           return 0
  3347.        }
  3348.     }
  3349.     return 1
  3350. }
  3351.  
  3352. method DPGAssocOne::hasRemove {this self} {
  3353.     set wr [$this propWrite]
  3354.     if {$self} {
  3355.             if {$wr == "None"} {
  3356.                     return 0
  3357.             }
  3358.     } else {
  3359.             if {$wr == "None" || $wr == "Private" || $wr == "Protected"} {
  3360.                     return 0
  3361.             }
  3362.     }
  3363.     if {[[$this assocattr] opposite] != ""} {
  3364.        if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
  3365.           return 0
  3366.        }
  3367.        if {[[[$this assocattr] opposite] isQualified]} {
  3368.                if {![$this removeWarning]} {
  3369.                 $this removeWarning 1
  3370.               m4_warning $W_NOREMOVE [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
  3371.               }
  3372.           return 0
  3373.        }
  3374.     }
  3375.     if {[[$this assocattr] isMandatory]} {
  3376.        return 0
  3377.     }
  3378.     return 1
  3379. }
  3380.  
  3381.  
  3382.  
  3383. method DPGAssocOne::generate {this cl} {
  3384.  
  3385.     if {[$this checkLocal] > 0} {
  3386.         return
  3387.     }
  3388.  
  3389.     set type [$this generateType $cl]
  3390.     set vari [DPVariable new $type]
  3391.     $vari name [$this varref]
  3392.     $cl addAssocvar $vari
  3393.     $vari access [$this propAccess]
  3394.  
  3395.     if {[[$this assocattr] opposite] != ""} {
  3396.         [[$this assocattr] opposite] setGenerator
  3397.     }
  3398.     $this generateGet $vari $cl
  3399.     $this generateSet $vari $cl
  3400.     $this generateRemove $vari $cl
  3401.     $this generateDtor $vari $cl
  3402. }
  3403.  
  3404. method DPGAssocOne::generateSet {this vari cl} {
  3405.  
  3406.     # Check if Set method should be generated
  3407.     #
  3408.     if {![$this hasSet 0]} {
  3409.         $vari access "Public"
  3410.     }
  3411.     if {![$this hasSet 1]} {
  3412.         return
  3413.     }
  3414.  
  3415.     # Generate
  3416.     #
  3417.     set type [$this generateType $cl]
  3418.  
  3419.     set arg "new[$this typename]"
  3420.     set param [DPArgument new $type]
  3421.     $param name $arg
  3422.     set setproc [DPProcedure new]
  3423.     $setproc addArg $param
  3424.     set setcode [DPTextSection new]
  3425.  
  3426.     $setproc gencode $setcode
  3427.     $setproc hasUserSection 0
  3428.     $setproc access [$this propWrite]
  3429.     $setproc name "set[cap [$this varname]]"
  3430.     if {[[$this assocattr] opposite] != ""} {
  3431.         $setcode append "if (${arg} <> NIL) then\nbegin\n"
  3432.         $setcode indent +
  3433.  
  3434.         if {[[$this assocattr] isMandatory]} {
  3435.             if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
  3436.                 # one-mtory
  3437.                 #
  3438.                 if {[[[[$this assocattr] opposite] generator] hasGet 0]} {
  3439.                     $setcode append "if ([$this castType $arg].get[cap [$this opvarname]] = NIL) then\nbegin\n"
  3440.                 } else {
  3441.                     $setcode append "if ([$this castType $arg].[$this opvarref] = NIL) then\nbegin\n"
  3442.                 }
  3443.                 $setcode indent +
  3444.                 $setcode append "[$this castType [$vari name]].[$this opvarref] := NIL;\n"
  3445.             } else {
  3446.                 # many-mtory
  3447.                 #
  3448.                 $setcode append "if (${arg} <> [$vari name]) then\nbegin\n"
  3449.                 $setcode indent +
  3450.                 $setcode append "if ([$vari name] <> NIL) then\nbegin\n"
  3451.                 $setcode indent +
  3452.                 $setcode append "[$this castType [$vari name]].[$this opvarset].Remove(SELF);\n"
  3453.                 $setcode indent -
  3454.                 $setcode append "end;\n"
  3455.             }
  3456.         } else {
  3457.             
  3458.             # one/many - one
  3459.             #
  3460.             $setcode append "if (${arg} <> [$vari name]) then\nbegin\n"
  3461.             $setcode indent +
  3462.             $setcode append "if ([$vari name] <> NIL) then\nbegin\n"
  3463.             $setcode indent +
  3464.             if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
  3465.                 $setcode append "[$this castType [$vari name]].remove[cap [$this opvarname]]"
  3466.                 if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  3467.                     $setcode append "(SELF)"
  3468.                 }
  3469.             } else {
  3470.                 if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  3471.                     $setcode append "[$this castType [$vari name]].[$this opvarset].Remove(SELF)"
  3472.                 } else {
  3473.                     $setcode append "[$this castType [$vari name]].[$this opvarref] := NIL"
  3474.                 }
  3475.             }
  3476.                 
  3477.             $setcode append ";\n"
  3478.             $setcode indent -
  3479.             $setcode append "end;\n"
  3480.         }
  3481.  
  3482.         $setcode append "[$vari name] := ${arg};\n"
  3483.  
  3484.         if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  3485.  
  3486.             # many - one/mtory
  3487.             #
  3488.             if {[[[[$this assocattr] opposite] generator] hasAdd 0]} {
  3489.                 $setcode append "[$this castType $arg].add[cap [$this opvarname]](SELF);\n"
  3490.             } else {
  3491.                 $setcode append "[$this castType $arg].[$this opvarset].Add(SELF);\n"
  3492.             }
  3493.         } else {
  3494.             # one - one/mtory
  3495.             #
  3496.             if {[[[[$this assocattr] opposite] generator] hasSet 0]} {
  3497.                 $setcode append "[$this castType $arg].set[cap [$this opvarname]](SELF);\n"
  3498.             } else {
  3499.                 $setcode append "[$this castType $arg].[$this opvarref] := SELF;\n"
  3500.             }
  3501.         }
  3502.         $setcode indent -
  3503.         $setcode append "end;\n"
  3504.  
  3505.         if {[$this hasRemove 1]} {
  3506.             # one/many - one
  3507.             #
  3508.             $setcode indent -
  3509.             $setcode append "end\nelse\nbegin\n"
  3510.             $setcode indent +
  3511.             $setcode append "remove[cap [$this varname]];\n"
  3512.         }
  3513.         $setcode indent -
  3514.         $setcode append "end;\n"
  3515.  
  3516.     } else {
  3517.         if {[[$this assocattr] isMandatory]} {
  3518.             $setcode append "if (${arg} <> NIL) then\nbegin\n"
  3519.             $setcode indent +
  3520.             $setcode append "[$this varref] := ${arg};\n"
  3521.             $setcode indent -
  3522.             $setcode append "end;\n"
  3523.         } else {
  3524.             $setcode append "[$this varref] := ${arg};\n"
  3525.         }
  3526.     }
  3527.     $cl addAssocgenmethod $setproc
  3528. }
  3529.  
  3530. method DPGAssocOne::generateGet {this vari cl} {
  3531.     # Check if Get method should be generated
  3532.     #
  3533.     if {![$this hasGet 0]} {
  3534.         $vari access "Public"
  3535.     }
  3536.     if {![$this hasGet 1]} {
  3537.         return
  3538.     }
  3539.  
  3540.     # Generate
  3541.     #
  3542.     set type [$this generateType $cl]
  3543.     set getproc [DPFunction new $type]
  3544.     set getcode [DPTextSection new]
  3545.     $getproc gencode $getcode
  3546.     $getproc hasUserSection 0
  3547.     $getproc access [$this propRead]
  3548.     $getproc name  "get[cap [$this varname]]"
  3549.     $getcode append "[$getproc name] := [$vari name];\n"
  3550.     $cl addAssocgenmethod $getproc
  3551. }
  3552.  
  3553. method DPGAssocOne::generateRemove {this vari cl} {
  3554.     # Check if remove method should be generated
  3555.     #
  3556.     if {![$this hasRemove 0]} {
  3557.         $vari access "Public"
  3558.     }
  3559.     if {![$this hasRemove 1]} {
  3560.         return
  3561.     }
  3562.  
  3563.     # Generate
  3564.     #
  3565.     set removeproc [DPProcedure new]
  3566.     set removecode [DPTextSection new]
  3567.     set removetypes [DPTextSection new]
  3568.  
  3569.     set old "old[$this typename]"
  3570.     $removeproc gencode $removecode
  3571.     $removeproc gentypes $removetypes
  3572.     $removeproc hasUserSection 0
  3573.     $removeproc access [$this propWrite]
  3574.     $removeproc name "remove[cap [$this varname]]"
  3575.  
  3576.     if {[[$this assocattr] opposite] != ""} {
  3577.         $removecode append "if ([$vari name] <> NIL) then\nbegin\n"
  3578.         $removecode indent +
  3579.         $removetypes append "var\n"
  3580.         $removetypes indent +
  3581.         $removetypes append "${old}: [$this typename];\n\n"
  3582.         $removetypes indent -
  3583.         $removecode append "${old} := [$vari name];\n"
  3584.         $removecode append "[$vari name] := NIL;\n"
  3585.  
  3586.         if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
  3587.  
  3588.             # Use remove method
  3589.             #
  3590.             $removecode append "${old}.remove[cap [$this opvarname]]("
  3591.             if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  3592.                 $removecode append "SELF"
  3593.             }
  3594.             $removecode append ");\n"
  3595.         } else {
  3596.  
  3597.             # Use direct access
  3598.             #
  3599.             if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  3600.                 $removecode append "${old}.[$this opvarset].Remove(SELF);\n"
  3601.             } else {
  3602.                 $removecode append "${old}.[$this opvarref] := NIL;\n"
  3603.             }
  3604.         }
  3605.         $removecode indent -
  3606.         $removecode append "end;\n"
  3607.     } else {
  3608.         $removecode append "[$vari name] := NIL;\n"
  3609.     }
  3610.     $cl addAssocgenmethod $removeproc
  3611. }
  3612.  
  3613. method DPGAssocOne::generateDtor {this vari cl} {
  3614.  
  3615.     # Check if Destructor should be generated
  3616.     #
  3617.     if {![$this hasDtor 1]} {
  3618.         return
  3619.     }
  3620.  
  3621.     # Generate
  3622.     #
  3623.     if {[[$this assocattr] opposite] != ""} {
  3624.         if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
  3625.             set sysutilstype [DPType new]
  3626.             $sysutilstype includeName "SysUtils"
  3627.             $sysutilstype includeType "imp"
  3628.             $sysutilstype addAsInclude [[[[[$this assocattr] opposite] ooplType] ooplClass] target]
  3629.             [[$cl destructr] gencode] append "if ([$this varref] <> NIL) then\n"
  3630.             [[$cl destructr] gencode] indent +
  3631.             [[$cl destructr] gencode] append "raise EInvalidOp.Create('Illegal object destruction. Object [$this varname] "
  3632.             [[$cl destructr] gencode] append "with mandatory relation exists.');\n"
  3633.             [[$cl destructr] gencode] indent -
  3634.             return
  3635.         }
  3636.         if {[$this hasRemove 1]} {
  3637.             [[$cl destructr] gencode] append "remove[cap [$this varname]];\n"
  3638.         } else { 
  3639.             if {![[[$this assocattr] opposite] isQualified]} {
  3640.                 if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
  3641.                     if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
  3642.                         [[$cl destructr] gencode] append "[$this castType [$this varref]].remove[cap [$this opvarname]];\n"
  3643.                     } else {
  3644.                         [[$cl destructr] gencode] append "[$this castType [$this varset]].remove[cap [$this opvarname]](SELF);\n"
  3645.                     }
  3646.                 } else {
  3647.                     if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
  3648.                         [[$cl destructr] gencode] append "[$this castType [$this varref]].[$this opvarref] := NIL;\n"
  3649.                     } else {
  3650.                         [[$cl destructr] gencode] append "[$this castType [$this varref]].[$this opvarset].Remove(SELF);\n"
  3651.                     }
  3652.                 }
  3653.             }
  3654.         }
  3655.     }
  3656. }
  3657.  
  3658. # Do not delete this line -- regeneration end marker
  3659.  
  3660.  
  3661.  
  3662. #---------------------------------------------------------------------------
  3663. #      File:           @(#)dpgqual.tcl    /main/titanic/1
  3664.  
  3665.  
  3666. Class DPGQual : {DPGAssocGen} {
  3667.     constructor
  3668.     method destructor
  3669.     method hasAdd
  3670.     method hasDtor
  3671.     method hasRemove
  3672. }
  3673.  
  3674. constructor DPGQual {class this assocattr} {
  3675.     set this [DPGAssocGen::constructor $class $this $assocattr]
  3676.     # Start constructor user section
  3677.     # End constructor user section
  3678.     return $this
  3679. }
  3680.  
  3681. method DPGQual::destructor {this} {
  3682.     # Start destructor user section
  3683.     # End destructor user section
  3684.     $this DPGAssocGen::destructor
  3685. }
  3686.  
  3687. method DPGQual::hasAdd {this self} {
  3688.     set wr [$this propWrite]
  3689.     if {$self} {
  3690.         if {$wr == "None"} {
  3691.             return 0
  3692.         }
  3693.     } else {
  3694.         if {$wr == "None" || $wr == "Private" || $wr == "Protected"} {
  3695.             return 0
  3696.         }
  3697.     }
  3698.     return 1
  3699. }
  3700.  
  3701. method DPGQual::hasDtor {this self} {
  3702. #    if {[[$this assocattr] opposite] != ""} {
  3703. #        if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
  3704. #            return 0
  3705. #        }
  3706. #    }
  3707.     return 1
  3708. }
  3709.  
  3710. method DPGQual::hasRemove {this self} {
  3711.     set wr [$this propWrite]
  3712.     if {$self} {
  3713.     } else {
  3714.         if {$wr == "None" || $wr == "Private" || $wr == "Protected"} {
  3715.             return 0
  3716.         }
  3717.     }
  3718.     if {[[$this assocattr] opposite] != ""} {
  3719.         if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
  3720.             return 0
  3721.         }
  3722.     }
  3723.     return 1
  3724. }
  3725.  
  3726. # Do not delete this line -- regeneration end marker
  3727.  
  3728.  
  3729.  
  3730. #---------------------------------------------------------------------------
  3731. #      File:           @(#)dpgdataatt.tcl    /main/titanic/14
  3732.  
  3733.  
  3734. Class DPGDataAttr : {DPGAttribute} {
  3735.     constructor
  3736.     method destructor
  3737.     method check
  3738.     method checkLocal
  3739.     method findNrAttribs
  3740.     method generateInitialValue
  3741.     method generateAccessors
  3742.     method generate
  3743.     method isProperty
  3744. }
  3745.  
  3746. constructor DPGDataAttr {class this name} {
  3747.     set this [DPGAttribute::constructor $class $this $name]
  3748.     # Start constructor user section
  3749.     # End constructor user section
  3750.     return $this
  3751. }
  3752.  
  3753. method DPGDataAttr::destructor {this} {
  3754.     # Start destructor user section
  3755.     # End destructor user section
  3756. }
  3757.  
  3758. method DPGDataAttr::check {this} {
  3759.     set errornr [$this checkLocal]
  3760.  
  3761.     [$this ooplType] check
  3762.  
  3763.     return $errornr
  3764. }
  3765.  
  3766. method DPGDataAttr::checkLocal {this} {
  3767.     set errornr 0
  3768.     set classtype [[$this ooplClass] getClassType]
  3769.     set accessList [split [$this getPropertyValue "attrib_access"] -]
  3770.     set readAccess [lindex $accessList 0]
  3771.     set writeAccess [lindex $accessList 1]
  3772.  
  3773.     # Type modifiers only allowed for:
  3774.     # - Typedefs
  3775.     # - Records
  3776.     # - Classes without access methods to this attribute
  3777.     #
  3778.     set error 0
  3779.     if {[[$this ooplType] getAttribTypeModifier] != ""} {
  3780.         if {[[$this ooplClass] get_obj_type] != "class_typedef"} {
  3781.             if {$classtype != "Record"} {
  3782.                 if {$classtype == "Class"} {
  3783.                     if {$readAccess != "None" || $writeAccess != "None"} {
  3784.                         set error 1
  3785.                     }
  3786.                 } else {
  3787.                     set error 1
  3788.                 }
  3789.             }
  3790.         }
  3791.     }
  3792.     if {$error} {
  3793.         incr errornr 1
  3794.         m4_error $E_ATTRTYPEMOD [$this getName] [[$this ooplClass] getName]
  3795.     }
  3796.  
  3797.     # Check property
  3798.     #
  3799.     set error 0
  3800.     if {[$this isProperty]} {
  3801.         if {[[$this ooplClass] get_obj_type] != "class"} {
  3802.             set error 1
  3803.         } else {
  3804.             if {($classtype != "Class") && ($classtype != "Interface")} {
  3805.                 set error 1
  3806.             }
  3807.         }
  3808.     }
  3809.     if {$error} {
  3810.         incr errornr 1
  3811.         m4_error $E_NOPROPS [[$this ooplClass] getName]
  3812.     }
  3813.  
  3814.     # Check for double defined
  3815.     #
  3816.     set attrname [string tolower [$this getName]]
  3817.     if {[$this findNrAttribs $attrname] > 1} {
  3818.         m4_error $E_ATTRDBDEF [$this getName] [[$this ooplClass] getName]
  3819.         incr errornr 1
  3820.     }
  3821.  
  3822.     # Check for enum type
  3823.     #
  3824.     if {[[$this ooplClass] get_obj_type] != "class_enum"} {
  3825.         if {[[$this ooplType] getName] == "enum"} {
  3826.             m4_error $E_NOENUM [[$this ooplClass] getName] [$this getName]
  3827.             incr errornr 1
  3828.         }
  3829.     }
  3830.  
  3831.     # Check for typedef type
  3832.     #
  3833.     if {[[$this ooplClass] get_obj_type] != "class_typedef"} {
  3834.         if {[$this getName] == "_"} {
  3835.             m4_error $E_CANTCONTTDEF [[$this ooplClass] getName]
  3836.             incr errornr 1
  3837.         }
  3838.     }
  3839.  
  3840.     return $errornr
  3841. }
  3842.  
  3843. method DPGDataAttr::findNrAttribs {this name} {
  3844.     set nr 0
  3845.     foreach feature [[$this ooplClass] dataAttrSet] {
  3846.         if {[string tolower [$feature getName]] == $name} {
  3847.             incr nr 1
  3848.         }
  3849.     }
  3850.     return $nr
  3851. }
  3852.  
  3853. method DPGDataAttr::generateInitialValue {this method class} {
  3854.     if {[$this getInitialValue] == ""} {
  3855.         return
  3856.     }
  3857.     if {[$this isClassFeature]} {
  3858.         [$method gencode] append "[$class name]_[$this getName]"
  3859.     } else {
  3860.         [$method gencode] append "[$this getName]"
  3861.     }
  3862.     [$method gencode] append " := [$this getInitialValue];\n"
  3863. }
  3864.  
  3865. method DPGDataAttr::generateAccessors {this class var name} {
  3866.  
  3867.     # acquire access settings
  3868.  
  3869.     set accessTxt [$this getPropertyValue "attrib_access"]
  3870.     set accessList [split $accessTxt -]
  3871.     set readAccess [lindex $accessList 0]
  3872.     if {$readAccess == ""} {
  3873.         set readAccess "Public"
  3874.     }
  3875.     set writeAccess [lindex $accessList 1]
  3876.     if {$writeAccess == ""} {
  3877.         set writeAccess "Public"
  3878.     }
  3879.  
  3880.     # create get function
  3881.  
  3882.     if {$readAccess != "None"} {
  3883.         set getname "get[cap $name]"
  3884.         set getmethod [DPFunction new [[$this ooplType] generate]]
  3885.         set getcode [DPTextSection new]
  3886.  
  3887.         $getmethod gencode $getcode
  3888.         $getmethod access $readAccess
  3889.         $getmethod name $getname
  3890.  
  3891.         $getcode append "[$getmethod name] := [$var name];\n"
  3892.         $class addGenmethod $getmethod
  3893.     }
  3894.     
  3895.     #create set procedure
  3896.  
  3897.     if {$writeAccess != "None"} {
  3898.         set setname "set[cap $name]"
  3899.         set setmethod [DPProcedure new]
  3900.         set setcode [DPTextSection new]
  3901.         $setmethod gencode $setcode
  3902.         $setmethod access $writeAccess
  3903.         $setmethod name $setname
  3904.  
  3905.         set arg [DPArgument new [[$this ooplType] generate]]
  3906.         $arg name "new[cap $name]"
  3907.         $setmethod addArg $arg
  3908.  
  3909.         $setcode append "[$var name] := [$arg name];\n"
  3910.         $class addGenmethod $setmethod
  3911.     }
  3912. }
  3913.  
  3914. method DPGDataAttr::generate {this class} {
  3915.  
  3916.     if {[$this checkLocal] > 0} {
  3917.         return
  3918.     }
  3919.  
  3920.     #
  3921.     # Property?
  3922.     #
  3923.     if {[$this isProperty]} {
  3924.         set property [DPProperty new [[$this ooplType] generateAttribType]]
  3925.         set comment [DPComment new]
  3926.         $property comment $comment
  3927.         $property name [$this getName]
  3928.         $comment comment [$this getPropertyValue "freeText"]
  3929.  
  3930.         $property index [$this getPropertyValue "prop_index"]
  3931.         $property usedefault [$this getPropertyValue "prop_usedefault"]
  3932.         $property default [$this getPropertyValue "prop_default"]
  3933.         $property read [$this getPropertyValue "prop_read"]
  3934.         $property write [$this getPropertyValue "prop_write"]
  3935.         $property storage [$this getPropertyValue "prop_stored"]
  3936.         $class addProperty $property
  3937.         return
  3938.     }
  3939.  
  3940.     set variable [DPVariable new [[$this ooplType] generateAttribType]]
  3941.     set comment [DPComment new]
  3942.     $variable comment $comment
  3943.     $variable name [$this getName]
  3944.     $comment comment [$this getPropertyValue "freeText"]
  3945.  
  3946.     #
  3947.     # Record attribute?
  3948.     #
  3949.     if {[$class unitType] == "record"} {
  3950.         $class addField $variable
  3951.         return
  3952.     }
  3953.  
  3954.     $variable isClassFeature [$this isClassFeature]
  3955.     $variable initvalue [$this getInitialValue]
  3956.     if {[$this isClassFeature]} {
  3957.         $variable name "[$class name]_[$this getName]"
  3958.         $variable access "Public"
  3959.         $class addGlobvar $variable
  3960.     } else {
  3961.         $variable access [$this getPropertyValue "attrib_visibility"]
  3962.         if {[$variable access] == ""} {
  3963.             $variable access "Private"
  3964.         }
  3965.         $class addUservar $variable
  3966.     }
  3967.     $this generateAccessors $class $variable [$this getName]
  3968. }
  3969.  
  3970. method DPGDataAttr::isProperty {this} {
  3971.     if {[$this getPropertyValue "is_prop"] == "1"} {
  3972.         return 1
  3973.     } else {
  3974.         return 0
  3975.     }
  3976. }
  3977.  
  3978. # Do not delete this line -- regeneration end marker
  3979.  
  3980. if [isCommand CMDataAttr] {
  3981.     Class  DPGDataAttrD : {DPGDataAttr CMDataAttr} {
  3982.     }
  3983. } else {
  3984.     Class DPGDataAttrD : {DPGDataAttr OPDataAttr} {    
  3985.     }
  3986. }
  3987.  
  3988. global mostDerivedOOPL ; set mostDerivedOOPL(OPDataAttr) DPGDataAttrD
  3989.  
  3990. selfPromoter OPDataAttr {this} {
  3991.     DPGDataAttrD promote $this
  3992. }
  3993.  
  3994.  
  3995. #---------------------------------------------------------------------------
  3996. #      File:           @(#)dpggenasso.tcl    /main/titanic/13
  3997.  
  3998.  
  3999. Class DPGGenAssocAttr : {DPGAttribute} {
  4000.     constructor
  4001.     method destructor
  4002.     method getName
  4003.     method hasGUIComponent
  4004.     method generateAssocType
  4005.     method generateQualAssocType
  4006.     method generateManyAssocType
  4007.     method generateComponent
  4008.     method check
  4009.     method checkComponent
  4010.     method checkLocal
  4011.     method generator
  4012.     attribute _generator
  4013. }
  4014.  
  4015. constructor DPGGenAssocAttr {class this name} {
  4016.     set this [DPGAttribute::constructor $class $this $name]
  4017.     # Start constructor user section
  4018.     # End constructor user section
  4019.     return $this
  4020. }
  4021.  
  4022. method DPGGenAssocAttr::destructor {this} {
  4023.     set ref [$this _generator]
  4024.     if {$ref != ""} {
  4025.         $ref _assocattr ""
  4026.     }
  4027.     # Start destructor user section
  4028.     # End destructor user section
  4029. }
  4030.  
  4031. method DPGGenAssocAttr::getName {this} {
  4032.     if {[$this isLinkAttr]} {
  4033.         if {[$this opposite] != ""} {
  4034.             return "[uncap [[[$this opposite] ooplClass] getName]]of[$this OPGenAssocAttr::getName]"
  4035.         }
  4036.     }
  4037.     return [$this OPGenAssocAttr::getName]
  4038. }
  4039.  
  4040. method DPGGenAssocAttr::hasGUIComponent {this} {
  4041.     if {![$this isAggregate]} {
  4042.         return 0
  4043.     }
  4044.     if {[[[$this ooplType] ooplClass] isComponent] && 
  4045.             [[[$this ooplType] ooplClass] getPropertyValue "is_declaration"] != 1} {
  4046.         if {[[[$this ooplType] ooplClass] isControl]} {
  4047.             return 2
  4048.         } else {
  4049.             return 1
  4050.         }
  4051.     } else {
  4052.         return 0
  4053.     }
  4054. }
  4055.  
  4056. method DPGGenAssocAttr::generateAssocType {this unit} {
  4057.     set type [[[$this ooplType] ooplClass] generateType]
  4058.     $type includeType "imp"
  4059.     $type addAsInclude $unit
  4060.     return $type
  4061. }
  4062.  
  4063. method DPGGenAssocAttr::generateQualAssocType {this unit} {
  4064.     set type [DPType new]
  4065.     $type name "TClassDict"
  4066.     $type includeType "system"
  4067.     $type includeName "ClassDict"
  4068.     $type addAsInclude $unit
  4069.     return $type
  4070. }
  4071.  
  4072. method DPGGenAssocAttr::generateManyAssocType {this unit} {
  4073.     set type [DPType new]
  4074.     $type name "TList"
  4075.     $type includeType "system"
  4076.     $type includeName "Classes"
  4077.     $type addAsInclude $unit
  4078.     return $type
  4079. }
  4080.  
  4081. method DPGGenAssocAttr::generateComponent {this class control} {
  4082.     [[$this ooplType] ooplClass] generateComponent [$this getName] $class $control
  4083. }
  4084.  
  4085. method DPGGenAssocAttr::check {this} {
  4086.     set errornr [$this checkLocal]
  4087.  
  4088.     return $errornr
  4089. }
  4090.  
  4091. method DPGGenAssocAttr::checkComponent {this form} {
  4092.     set errornr 0
  4093.     incr errornr [[[$this ooplType] ooplClass] checkComponent [$this getName] $form]
  4094.     return $errornr
  4095. }
  4096.  
  4097. method DPGGenAssocAttr::checkLocal {this} {
  4098.     set errornr 0
  4099.  
  4100.     return $errornr
  4101. }
  4102.  
  4103. # Do not delete this line -- regeneration end marker
  4104.  
  4105. if [isCommand CMGenAssocAttr] {
  4106.     Class  DPGGenAssocAttrD : {DPGGenAssocAttr CMGenAssocAttr} {
  4107.     }
  4108. } else {
  4109.     Class DPGGenAssocAttrD : {DPGGenAssocAttr OPGenAssocAttr} {    
  4110.     }
  4111. }
  4112.  
  4113. global mostDerivedOOPL ; set mostDerivedOOPL(OPGenAssocAttr) DPGGenAssocAttrD
  4114.  
  4115. selfPromoter OPGenAssocAttr {this} {
  4116.     DPGGenAssocAttrD promote $this
  4117. }
  4118. method DPGGenAssocAttr::generator {this args} {
  4119.     if {$args == ""} {
  4120.         return [$this _generator]
  4121.     }
  4122.     set ref [$this _generator]
  4123.     if {$ref != ""} {
  4124.         $ref _assocattr ""
  4125.     }
  4126.     set obj [lindex $args 0]
  4127.     if {$obj != ""} {
  4128.         $obj _assocattr $this
  4129.     }
  4130.     $this _generator $obj
  4131. }
  4132.  
  4133.  
  4134.  
  4135. #---------------------------------------------------------------------------
  4136. #      File:           @(#)dpgmanyqua.tcl    /main/titanic/12
  4137.  
  4138.  
  4139. Class DPGManyQual : {DPGQual} {
  4140.     constructor
  4141.     method destructor
  4142.     method generate
  4143.     method generateAdd
  4144.     method generateGet
  4145.     method generateRemove
  4146.     method generateDtor
  4147. }
  4148.  
  4149. constructor DPGManyQual {class this assocattr} {
  4150.     set this [DPGQual::constructor $class $this $assocattr]
  4151.     # Start constructor user section
  4152.     # End constructor user section
  4153.     return $this
  4154. }
  4155.  
  4156. method DPGManyQual::destructor {this} {
  4157.     # Start destructor user section
  4158.     # End destructor user section
  4159.     $this DPGQual::destructor
  4160. }
  4161.  
  4162. method DPGManyQual::generate {this cl} {
  4163.  
  4164.     if {[$this checkLocal] > 0} {
  4165.             return
  4166.     }
  4167.     set qualtype [[$this assocattr] generateQualAssocType $cl]
  4168.     set vari [DPVariable new $qualtype]
  4169.     $vari name "[$this vardict]"
  4170.     $cl addAssocvar $vari
  4171.     $vari access [$this propAccess]
  4172.     if {[$cl constructr] != ""} {
  4173.         [[$cl constructr] gencode] append "[$vari name] := [$qualtype name].Create;\n"
  4174.     }
  4175.     if {[[$this assocattr] opposite] != ""} {
  4176.         [[$this assocattr] opposite] setGenerator
  4177.     }
  4178.     $this generateGet $vari $cl
  4179.     $this generateAdd $vari $cl
  4180.     $this generateRemove $vari $cl
  4181.     $this generateDtor $vari $cl
  4182. }
  4183.  
  4184. method DPGManyQual::generateAdd {this vari cl} {
  4185.     
  4186.     # Check if Add method should be generated
  4187.     #
  4188.     if {![$this hasAdd 0]} {
  4189.         $vari access "Public"
  4190.     }
  4191.     if {![$this hasAdd 1]} {
  4192.         return
  4193.     }
  4194.  
  4195.     # Generate
  4196.     #
  4197.     set argtype [$this generateType $cl]
  4198.     set manytype [[$this assocattr] generateManyAssocType $cl]
  4199.     set param [DPArgument new $argtype]
  4200.  
  4201.     set arg "new[$this typename]"
  4202.     $param name "${arg}"
  4203.     set addproc [DPProcedure new]
  4204.     set keyargtype [DPType new]
  4205.     $keyargtype name [[[[$this assocattr] qualifier] ooplType] getType3GL]
  4206.     set keyparam [DPArgument new $keyargtype]
  4207.     $keyparam name [$this varqual]
  4208.     $addproc addArg $keyparam
  4209.     $addproc addArg $param
  4210.     set addcode [DPTextSection new]
  4211.     set addtypes [DPTextSection new]
  4212.  
  4213.     $addproc gencode $addcode
  4214.     $addproc gentypes $addtypes
  4215.     $addproc hasUserSection 0
  4216.     $addproc access [$this propWrite]
  4217.     $addproc name "add[cap [$this varname]]"
  4218.  
  4219.     set tempset "temp[$this varset]"
  4220.     $addtypes append "var\n"
  4221.     $addtypes indent +
  4222.     $addtypes append "${tempset}: [$manytype name];\n"
  4223.     $addtypes indent -
  4224.  
  4225.     if {[[$this assocattr] opposite] != ""} {
  4226.         if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  4227.             $addcode append "[$this castType $arg].[$this opvarset].Add(SELF);\n"
  4228.         } else {
  4229.             $addcode append "[$this castType $arg].[$this opvarref] := SELF;\n"
  4230.         }
  4231.     } 
  4232.     $addcode append "if ([$vari name].Item([$this varqual]) <> NIL) then\nbegin\n"
  4233.     $addcode indent +
  4234.     $addcode append "${tempset} := [$vari name].Item([$this varqual]);\n"
  4235.     $addcode indent -
  4236.     $addcode append "end\n"
  4237.     $addcode append "else\n"
  4238.     $addcode append "begin\n"
  4239.     $addcode indent +
  4240.     $addcode append "${tempset} := [$manytype name].Create;\n"
  4241.     $addcode append "[$vari name].Add([$this varqual], ${tempset})\n"
  4242.     $addcode indent -
  4243.     $addcode append "end;\n"
  4244.     $addcode append "${tempset}.Add(${arg});\n"
  4245.  
  4246.     $cl addAssocgenmethod $addproc
  4247. }
  4248.  
  4249. method DPGManyQual::generateGet {this vari cl} {
  4250.     # Check if Get method should be generated
  4251.     #
  4252.     if {![$this hasGet 0]} {
  4253.         $vari access "Public"
  4254.     }
  4255.     if {![$this hasGet 1]} {
  4256.         return
  4257.     }
  4258.  
  4259.     # Generate
  4260.     #
  4261.     set manytype [[$this assocattr] generateManyAssocType $cl]
  4262.     set getproc [DPFunction new $manytype]
  4263.     set getcode [DPTextSection new]
  4264.     $getproc gencode $getcode
  4265.     $getproc hasUserSection 0
  4266.     $getproc access [$this propRead]
  4267.     $getproc name "get[cap [$this varname]]"
  4268.     $getcode append "[$getproc name] := [$this vardict].Item([$this varqual]);\n"
  4269.  
  4270.     set argtype [DPType new]
  4271.     $argtype name [[[[$this assocattr] qualifier] ooplType] getType3GL]
  4272.     set arg [DPArgument new $argtype]
  4273.     $arg name [$this varqual]
  4274.     $getproc addArg $arg
  4275.     $cl addAssocgenmethod $getproc
  4276. }
  4277.  
  4278. method DPGManyQual::generateRemove {this vari cl} {
  4279.     # Check if method should be generated
  4280.     #
  4281.     if {![$this hasRemove 0]} {
  4282.         $vari access "Public"
  4283.     }
  4284.     if {![$this hasRemove 1]} {
  4285.         return
  4286.     }
  4287.  
  4288.     # Generate
  4289.     #
  4290.     set removeproc [DPProcedure new]
  4291.     set keyargtype [DPType new]
  4292.     $keyargtype name [[[[$this assocattr] qualifier] ooplType] getType3GL]
  4293.     set param [DPArgument new $keyargtype]
  4294.     $param name [$this varqual]
  4295.     $removeproc addArg $param
  4296.  
  4297.     set argtype [$this generateType $cl]
  4298.     set manytype [[$this assocattr] generateManyAssocType $cl]
  4299.     set arg "old[$this typename]"
  4300.     set param [DPArgument new $argtype]
  4301.     $param name $arg
  4302.  
  4303.     $removeproc addArg $param
  4304.     set removecode [DPTextSection new]
  4305.     set removetypes [DPTextSection new]
  4306.     set tempset "temp[$this varset]"
  4307.     $removeproc gencode $removecode
  4308.     $removeproc gentypes $removetypes
  4309.     $removeproc hasUserSection 0
  4310.     $removeproc name "remove[cap [[$this assocattr] getName]]"
  4311.  
  4312.     if {[$this propWrite] == "None"} {
  4313.         $removeproc access "Private"
  4314.         m4_warning $W_CHANGEDREM [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
  4315.     } else {
  4316.         $removeproc access [$this propWrite]
  4317.     }
  4318.  
  4319.     $removetypes append "var\n"
  4320.     $removetypes indent +
  4321.     $removetypes append "${tempset}: [$manytype name];\n"
  4322.     $removetypes indent -
  4323.     $removecode append "${tempset} := [$vari name].Item([$this varqual]);\n"
  4324.  
  4325.     $removecode append "if ${tempset} <> NIL then\nbegin\n"
  4326.     $removecode indent +
  4327.  
  4328.     if {[[$this assocattr] opposite] != ""} {
  4329.         if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
  4330.             $removecode append "[$this castType $arg].[$this opvarref] := NIL;\n"
  4331.         } else {
  4332.             $removecode append "[$this castType $arg].[$this opvarset].Remove(SELF);\n"
  4333.         }
  4334.     }
  4335.  
  4336.     $removecode append "${tempset}.Remove(${arg});\n"
  4337.  
  4338.     if {![[$this assocattr] isMandatory]} {
  4339.        $removecode append "if (${tempset}.Count = 0) then\nbegin\n"
  4340.        $removecode indent +
  4341.        $removecode append "[$vari name].RemoveUsingKey([$this varqual]);\n"
  4342.        $removecode indent -
  4343.        $removecode append "end;\n"
  4344.     }
  4345.  
  4346.     $removecode indent -
  4347.     $removecode append "end;\n"
  4348.     $cl addAssocgenmethod $removeproc
  4349. }
  4350.  
  4351. method DPGManyQual::generateDtor {this vari cl} {
  4352.  
  4353.     # Check if Destructor should be generated
  4354.     #
  4355.     if {![$this hasDtor 1]} {
  4356.         [[$cl destructr] gencode] append "[$this vardict].Destroy;\n"
  4357.         return
  4358.     }
  4359.  
  4360.     # Generate
  4361.     #
  4362.     if {[[$this assocattr] opposite] != ""} {
  4363.         if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
  4364.             set sysutilstype [DPType new]
  4365.             $sysutilstype includeName "SysUtils"
  4366.             $sysutilstype includeType "imp"
  4367.             $sysutilstype addAsInclude [[[[[$this assocattr] opposite] ooplType] ooplClass] target]
  4368.                                             
  4369.             [[$cl destructr] gencode] append "if ([$this vardict].Count <> 0) then\n"
  4370.             [[$cl destructr] gencode] indent +
  4371.             [[$cl destructr] gencode] append "raise EInvalidOp.Create('Illegal object destruction. Mandatory relation "
  4372.             [[$cl destructr] gencode] append "[[$this assocattr] getName]Set not empty.');\n"
  4373.             [[$cl destructr] gencode] indent -
  4374.         } else {
  4375.             set manytype [[$this assocattr] generateManyAssocType $cl]
  4376.             [[$cl destructr] gentypes] append "var\n"
  4377.             [[$cl destructr] gentypes] indent +
  4378.             [[$cl destructr] gentypes] append "tmp[$this varset]: [$manytype name];\n"
  4379.             [[$cl destructr] gentypes] append "tmp[$this varname]: [$this typename];\n"
  4380.             [[$cl destructr] gentypes] indent -
  4381.             [[$cl destructr] gencode] append "while ([$this vardict].Count <> 0) do\nbegin\n"
  4382.             [[$cl destructr] gencode] indent +
  4383.             [[$cl destructr] gencode] append "tmp[$this varset] := [$this vardict].First;\n"
  4384.             [[$cl destructr] gencode] append "while (tmp[$this varset].Count > 0) do\nbegin\n"
  4385.             [[$cl destructr] gencode] indent +
  4386.             [[$cl destructr] gencode] append "tmp[$this varname] := tmp[$this varset].First;\n"
  4387.  
  4388.             if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  4389.                 [[$cl destructr] gencode] append "tmp[$this varname].[$this opvarset].Remove(SELF);\n"
  4390.             } else {
  4391.                 [[$cl destructr] gencode] append "tmp[$this varname].[$this opvarref] := NIL;\n"
  4392.             }
  4393.             [[$cl destructr] gencode] append "tmp[$this varset].Remove(tmp[$this varname]);\n"
  4394.             [[$cl destructr] gencode] indent -
  4395.             [[$cl destructr] gencode] append "end;\n"
  4396.             [[$cl destructr] gencode] append "[$this vardict].Remove(tmp[$this varset]);\n"
  4397.             [[$cl destructr] gencode] indent -
  4398.             [[$cl destructr] gencode] append "end;\n"
  4399.         }
  4400.     }
  4401.  
  4402.     [[$cl destructr] gencode] append "[$this vardict].Destroy;\n"
  4403. }
  4404.  
  4405. # Do not delete this line -- regeneration end marker
  4406.  
  4407.  
  4408.  
  4409. #---------------------------------------------------------------------------
  4410. #      File:           @(#)dpgonequal.tcl    /main/titanic/14
  4411.  
  4412.  
  4413. Class DPGOneQual : {DPGQual} {
  4414.     constructor
  4415.     method destructor
  4416.     method generate
  4417.     method generateSet
  4418.     method generateGet
  4419.     method generateRemove
  4420.     method generateDtor
  4421. }
  4422.  
  4423. constructor DPGOneQual {class this assocattr} {
  4424.     set this [DPGQual::constructor $class $this $assocattr]
  4425.     # Start constructor user section
  4426.     # End constructor user section
  4427.     return $this
  4428. }
  4429.  
  4430. method DPGOneQual::destructor {this} {
  4431.     # Start destructor user section
  4432.     # End destructor user section
  4433.     $this DPGQual::destructor
  4434. }
  4435.  
  4436. method DPGOneQual::generate {this cl} {
  4437.  
  4438.     if {[$this checkLocal] > 0} {
  4439.             return
  4440.     }
  4441.     set qualtype [[$this assocattr] generateQualAssocType $cl]
  4442.     set vari [DPVariable new $qualtype]
  4443.     $vari name "[$this vardict]"
  4444.     $cl addAssocvar $vari
  4445.     $vari access [$this propAccess]
  4446.     if {[$cl constructr] != ""} {
  4447.         [[$cl constructr] gencode] append "[$vari name] := [$qualtype name].Create;\n"
  4448.     }
  4449.     if {[[$this assocattr] opposite] != ""} {
  4450.         [[$this assocattr] opposite] setGenerator
  4451.     }
  4452.     $this generateGet $vari $cl
  4453.     $this generateSet $vari $cl
  4454.     $this generateRemove $vari $cl
  4455.     $this generateDtor $vari $cl
  4456. }
  4457.  
  4458. method DPGOneQual::generateSet {this vari cl} {
  4459.     # Check if Set method should be generated
  4460.     #
  4461.     if {![$this hasAdd 0]} {
  4462.         $vari access "Public"
  4463.     }
  4464.     if {![$this hasAdd 1]} {
  4465.         return
  4466.     }
  4467.  
  4468.     # Generate
  4469.     #
  4470.     set type [$this generateType $cl]
  4471.     set param [DPArgument new $type]
  4472.     set arg "new[$this typename]"
  4473.     $param name $arg
  4474.     set addproc [DPProcedure new]
  4475.  
  4476.     set type [DPType new]
  4477.     $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
  4478.     set keyparam [DPArgument new $type]
  4479.     $keyparam name  [$this varqual]
  4480.     $addproc addArg $keyparam
  4481.     $addproc addArg $param
  4482.     set addcode [DPTextSection new]
  4483.     set addtypes [DPTextSection new]
  4484.     set vartemp "old[$this typename]"
  4485.  
  4486.     $addproc gencode $addcode
  4487.     $addproc gentypes $addtypes
  4488.     $addproc hasUserSection 0
  4489.     $addproc access [$this propWrite]
  4490.     $addproc name "set[cap [$this varname]]"
  4491.  
  4492.     if {[[$this assocattr] opposite] != ""} {
  4493.         $addtypes append "var\n"
  4494.         $addtypes indent +
  4495.         $addtypes append "${vartemp}: [$this typename];\n"
  4496.         $addtypes indent -
  4497.     }
  4498.  
  4499.     $addcode append "if (${arg} <> NIL) then\nbegin\n"
  4500.     $addcode indent +
  4501.  
  4502.     if {[[$this assocattr] opposite] != ""} {
  4503.         $addcode append "${vartemp} := [$vari name].Item([$keyparam name]);\n"
  4504.         $addcode append "if (${vartemp} <> NIL) then\nbegin\n"
  4505.         $addcode indent +
  4506.         if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  4507.             $addcode append "[$this castType $vartemp].[$this opvarset].Remove(SELF);\n"
  4508.         } else {
  4509.             $addcode append "[$this castType $vartemp].[$this opvarref] := NIL;\n"
  4510.         }
  4511.         $addcode append "[$vari name].RemoveUsingKey([$keyparam name]);\n"
  4512.         $addcode indent -
  4513.         $addcode append "end;\n"
  4514.  
  4515.         if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  4516.             $addcode append "[$this castType $arg].[$this opvarset].Add(SELF);\n"
  4517.         } else {
  4518.             $addcode append "[$this castType $arg].[$this opvarref] := SELF;\n"
  4519.         }
  4520.     }
  4521.         
  4522.     $addcode append "[$vari name].Add([$keyparam name], ${arg});\n"
  4523.     $addcode indent -
  4524.     $addcode append "end;\n"
  4525.  
  4526.     $cl addAssocgenmethod $addproc
  4527. }
  4528.  
  4529. method DPGOneQual::generateGet {this vari cl} {
  4530.  
  4531.     # Check if Get method should be generated
  4532.     #
  4533.     if {![$this hasGet 0]} {
  4534.         $vari access "Public"
  4535.     }
  4536.     if {![$this hasGet 1]} {
  4537.         return
  4538.     }
  4539.  
  4540.     # Generate
  4541.     #
  4542.     set type [$this generateType $cl]
  4543.     set getproc [DPFunction new $type]
  4544.     set getcode [DPTextSection new]
  4545.     $getproc gencode $getcode
  4546.     $getproc hasUserSection 0
  4547.     $getproc access [$this propRead]
  4548.     $getproc name "get[cap [$this varname]]"
  4549.     $getcode append "[$getproc name] := [$this vardict].Item([$this varqual]);\n"
  4550.  
  4551.     set type [DPType new]
  4552.     $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
  4553.     set param [DPArgument new $type]
  4554.     $param name [$this varqual]
  4555.     $getproc addArg $param
  4556.     $cl addAssocgenmethod $getproc
  4557. }
  4558.  
  4559. method DPGOneQual::generateRemove {this vari cl} {
  4560.     if {![$this hasRemove 0]} {
  4561.         $vari access "Public"
  4562.     }
  4563.     if {![$this hasRemove 1]} {
  4564.         return
  4565.     }
  4566.  
  4567.     set removeproc [DPProcedure new]
  4568.     set type [DPType new]
  4569.     $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
  4570.     set param [DPArgument new $type]
  4571.     $param name [$this varqual]
  4572.     $removeproc addArg $param
  4573.     set removecode [DPTextSection new]
  4574.     set removetypes [DPTextSection new]
  4575.     $removeproc gencode $removecode
  4576.     $removeproc gentypes $removetypes
  4577.     $removeproc hasUserSection 0
  4578.     $removeproc name "remove[cap [$this varname]]"
  4579.     set vartemp "old[$this typename]"
  4580.  
  4581.     if {[$this propWrite] == "None"} {
  4582.         $removeproc access "Private"
  4583.         m4_warning $W_CHANGEDREM [[$this assocattr] getName] [[[$this assocattr] ooplClass] getName]
  4584.     } else {
  4585.         $removeproc access [$this propWrite]
  4586.     }
  4587.  
  4588.     if {[[$this assocattr] opposite] != ""} {
  4589.         $removetypes append "var\n"
  4590.         $removetypes indent +
  4591.         $removetypes append "${vartemp}: [$this typename];\n"
  4592.         $removetypes indent -
  4593.         $removecode append "${vartemp} := [$vari name].Item([$this varqual]);\n"
  4594.         $removecode append "if (${vartemp} <> NIL) then\nbegin\n"
  4595.         $removecode indent +
  4596.  
  4597.         if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] != "one"} {
  4598.            $removecode append "if (${vartemp}.[$this opvarset].Count > 1) then\nbegin\n"
  4599.            $removecode indent +
  4600.         }
  4601.         $removecode append "[$vari name].RemoveUsingKey([$this varqual]);\n"
  4602.         if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
  4603.             $removecode append "${vartemp}.[$this opvarset].Remove(SELF);\n"
  4604.         } else {
  4605.             $removecode append "${vartemp}.[$this opvarref] := NIL;\n"
  4606.         }
  4607.         if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] != "one"} {
  4608.            $removecode indent -
  4609.            $removecode append "end;\n"
  4610.         }
  4611.  
  4612.        $removecode indent -
  4613.        $removecode append "end;\n"
  4614.     } else {
  4615.         $removecode append "[$vari name].RemoveUsingKey([$this varqual])\n"
  4616.     }
  4617.  
  4618.     $cl addAssocgenmethod $removeproc
  4619. }
  4620.  
  4621. method DPGOneQual::generateDtor {this vari cl} {
  4622.  
  4623.     # Check if Destructor should be generated
  4624.     #
  4625.     if {![$this hasDtor 1]} {
  4626.         [[$cl destructr] gencode] append "[$this vardict].Destroy;\n"
  4627.         return
  4628.     }
  4629.  
  4630.     # Generate
  4631.     #
  4632.     if {[[$this assocattr] opposite] != ""} {
  4633.         if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
  4634.             set sysutilstype [DPType new]
  4635.             $sysutilstype includeName "SysUtils"
  4636.             $sysutilstype includeType "imp"
  4637.             $sysutilstype addAsInclude [[[[[$this assocattr] opposite] ooplType] ooplClass] target]
  4638.  
  4639.             [[$cl destructr] gencode] append "if ([$this vardict].Count <> 0) then\n"
  4640.             [[$cl destructr] gencode] indent +
  4641.             [[$cl destructr] gencode] append "raise EInvalidOp.Create('Illegal object destruction. Mandatory relation "
  4642.             [[$cl destructr] gencode] append "[$this vardict] not empty.');\n"
  4643.             [[$cl destructr] gencode] indent -
  4644.         } else {
  4645.             [[$cl destructr] gencode] append "while ([$this vardict].Count > 0) do\nbegin\n"
  4646.             [[$cl destructr] gencode] indent +
  4647.             [[$cl destructr] gencode] append "remove[cap [$this varname]]([$this vardict].FirstKey)\n"
  4648.             [[$cl destructr] gencode] indent -
  4649.             [[$cl destructr] gencode] append "end;\n"
  4650.         }
  4651.     }
  4652.     [[$cl destructr] gencode] append "[$this vardict].Destroy;\n"
  4653. }
  4654.  
  4655. # Do not delete this line -- regeneration end marker
  4656.  
  4657.  
  4658.  
  4659. #---------------------------------------------------------------------------
  4660. #      File:           @(#)dpgassocat.tcl    /main/titanic/9
  4661.  
  4662.  
  4663. Class DPGAssocAttr : {DPGGenAssocAttr} {
  4664.     constructor
  4665.     method destructor
  4666.     method check
  4667.     method checkLocal
  4668.     method setGenerator
  4669.     method generate
  4670. }
  4671.  
  4672. constructor DPGAssocAttr {class this name} {
  4673.     set this [DPGGenAssocAttr::constructor $class $this $name]
  4674.     # Start constructor user section
  4675.     # End constructor user section
  4676.     return $this
  4677. }
  4678.  
  4679. method DPGAssocAttr::destructor {this} {
  4680.     # Start destructor user section
  4681.     # End destructor user section
  4682. }
  4683.  
  4684. method DPGAssocAttr::check {this} {
  4685.     set errornr [$this checkLocal]
  4686.      
  4687.     $this setGenerator
  4688.     [$this generator] check
  4689.  
  4690.     return $errornr
  4691. }
  4692.  
  4693. method DPGAssocAttr::checkLocal {this} {
  4694.     set errornr 0
  4695.  
  4696.     return $errornr
  4697. }
  4698.  
  4699. method DPGAssocAttr::setGenerator {this} {
  4700.    if {[$this generator] == ""} {
  4701.         if {[$this getMultiplicity] == "one"} {
  4702.             $this generator [DPGAssocOne new $this]
  4703.         } else {
  4704.             $this generator [DPGAssocMany new $this]
  4705.         }
  4706.     }
  4707. }
  4708.  
  4709. method DPGAssocAttr::generate {this class} {
  4710.     if {[$this hasGUIComponent]} {
  4711.         return
  4712.     }
  4713.     if {[$this checkLocal] > 0} {
  4714.         return
  4715.     }
  4716.     $this setGenerator
  4717.     [$this generator] generate $class
  4718. }
  4719.  
  4720. # Do not delete this line -- regeneration end marker
  4721.  
  4722. if [isCommand CMAssocAttr] {
  4723.     Class  DPGAssocAttrD : {DPGAssocAttr CMAssocAttr} {
  4724.     }
  4725. } else {
  4726.     Class DPGAssocAttrD : {DPGAssocAttr OPAssocAttr} {    
  4727.     }
  4728. }
  4729.  
  4730. global mostDerivedOOPL ; set mostDerivedOOPL(OPAssocAttr) DPGAssocAttrD
  4731.  
  4732. selfPromoter OPAssocAttr {this} {
  4733.     DPGAssocAttrD promote $this
  4734. }
  4735.  
  4736.  
  4737. #---------------------------------------------------------------------------
  4738. #      File:           @(#)dpglinkatt.tcl    /main/titanic/9
  4739.  
  4740.  
  4741. Class DPGLinkAttr : {DPGGenAssocAttr} {
  4742.     constructor
  4743.     method destructor
  4744.     method check
  4745.     method checkLocal
  4746.     method setGenerator
  4747.     method generate
  4748. }
  4749.  
  4750. constructor DPGLinkAttr {class this name} {
  4751.     set this [DPGGenAssocAttr::constructor $class $this $name]
  4752.     # Start constructor user section
  4753.     # End constructor user section
  4754.     return $this
  4755. }
  4756.  
  4757. method DPGLinkAttr::destructor {this} {
  4758.     # Start destructor user section
  4759.     # End destructor user section
  4760. }
  4761.  
  4762. method DPGLinkAttr::check {this} {
  4763.     set errornr [$this checkLocal]
  4764.  
  4765.     $this setGenerator
  4766.     [$this generator] check
  4767.  
  4768.     return $errornr
  4769. }
  4770.  
  4771. method DPGLinkAttr::checkLocal {this} {
  4772.     set errornr 0
  4773.  
  4774.     if {[[$this ooplType] isA OPBaseType]} {
  4775.         m4_warning $W_ASSOCTYPEERR [$this getName] [[$this ooplType] getName]
  4776.         incr errornr 1
  4777.     }
  4778.  
  4779.     return $errornr
  4780. }
  4781.  
  4782. method DPGLinkAttr::setGenerator {this} {
  4783.     if {[$this generator] == ""} {
  4784.         if {[$this getMultiplicity] == "one"} {
  4785.             $this generator [DPGAssocOne new $this]
  4786.         } else {
  4787.             $this generator [DPGAssocMany new $this]
  4788.         }
  4789.     }
  4790. }
  4791.  
  4792. method DPGLinkAttr::generate {this class} {
  4793.     if {[$this checkLocal] > 0} {
  4794.         return
  4795.     }
  4796.  
  4797.     if {[$this hasGUIComponent]} {
  4798.         return
  4799.     }
  4800.  
  4801.     $this setGenerator
  4802.     [$this generator] generate $class
  4803. }
  4804.  
  4805. # Do not delete this line -- regeneration end marker
  4806.  
  4807. if [isCommand CMLinkAttr] {
  4808.     Class  DPGLinkAttrD : {DPGLinkAttr CMLinkAttr} {
  4809.     }
  4810. } else {
  4811.     Class DPGLinkAttrD : {DPGLinkAttr OPLinkAttr} {    
  4812.     }
  4813. }
  4814.  
  4815. global mostDerivedOOPL ; set mostDerivedOOPL(OPLinkAttr) DPGLinkAttrD
  4816.  
  4817. selfPromoter OPLinkAttr {this} {
  4818.     DPGLinkAttrD promote $this
  4819. }
  4820.  
  4821.  
  4822. #---------------------------------------------------------------------------
  4823. #      File:           @(#)dpgqualatt.tcl    /main/titanic/9
  4824.  
  4825.  
  4826. Class DPGQualAttr : {DPGGenAssocAttr} {
  4827.     constructor
  4828.     method destructor
  4829.     method check
  4830.     method checkLocal
  4831.     method setGenerator
  4832.     method generate
  4833. }
  4834.  
  4835. constructor DPGQualAttr {class this name} {
  4836.     set this [DPGGenAssocAttr::constructor $class $this $name]
  4837.     # Start constructor user section
  4838.     # End constructor user section
  4839.     return $this
  4840. }
  4841.  
  4842. method DPGQualAttr::destructor {this} {
  4843.     # Start destructor user section
  4844.     # End destructor user section
  4845. }
  4846.  
  4847. method DPGQualAttr::check {this} {
  4848.     set errornr [$this checkLocal]
  4849.  
  4850.     $this setGenerator
  4851.     [$this generator] check
  4852.  
  4853.     return $errornr
  4854. }
  4855.  
  4856. method DPGQualAttr::checkLocal {this} {
  4857.     set errornr 0
  4858.     if {![[[$this qualifier] ooplType] isA OPBaseType]} {
  4859.         m4_error $E_QUALTYPEWRONG [[$this qualifier] getName] [$this getName]
  4860.         incr errornr 1
  4861.     }
  4862.     return $errornr
  4863. }
  4864.  
  4865. method DPGQualAttr::setGenerator {this} {
  4866.     if {[$this generator] == ""} {
  4867.         if {[$this getMultiplicity] == "one"} {
  4868.             $this generator [DPGOneQual new $this]
  4869.         } else {
  4870.             $this generator [DPGManyQual new $this]
  4871.         }
  4872.     }
  4873. }
  4874.  
  4875. method DPGQualAttr::generate {this class} {
  4876.     if {[$this checkLocal] > 0} {
  4877.         return
  4878.     }
  4879.     if {[$this hasGUIComponent]} {
  4880.         return
  4881.     }
  4882.  
  4883.     $this setGenerator
  4884.     [$this generator] generate $class
  4885. }
  4886.  
  4887. # Do not delete this line -- regeneration end marker
  4888.  
  4889. if [isCommand CMQualAttr] {
  4890.     Class  DPGQualAttrD : {DPGQualAttr CMQualAttr} {
  4891.     }
  4892. } else {
  4893.     Class DPGQualAttrD : {DPGQualAttr OPQualAttr} {    
  4894.     }
  4895. }
  4896.  
  4897. global mostDerivedOOPL ; set mostDerivedOOPL(OPQualAttr) DPGQualAttrD
  4898.  
  4899. selfPromoter OPQualAttr {this} {
  4900.     DPGQualAttrD promote $this
  4901. }
  4902.  
  4903.  
  4904. #---------------------------------------------------------------------------
  4905. #      File:           @(#)dpgreverse.tcl    /main/titanic/8
  4906.  
  4907.  
  4908. Class DPGReverseLinkAttr : {DPGGenAssocAttr} {
  4909.     constructor
  4910.     method destructor
  4911.     method check
  4912.     method checkLocal
  4913.     method setGenerator
  4914.     method generate
  4915. }
  4916.  
  4917. constructor DPGReverseLinkAttr {class this name} {
  4918.     set this [DPGGenAssocAttr::constructor $class $this $name]
  4919.     # Start constructor user section
  4920.     # End constructor user section
  4921.     return $this
  4922. }
  4923.  
  4924. method DPGReverseLinkAttr::destructor {this} {
  4925.     # Start destructor user section
  4926.     # End destructor user section
  4927. }
  4928.  
  4929. method DPGReverseLinkAttr::check {this} {
  4930.     set errornr [$this checkLocal]
  4931.  
  4932.     $this setGenerator
  4933.     [$this generator] check
  4934.  
  4935.     return $errornr
  4936. }
  4937.  
  4938. method DPGReverseLinkAttr::checkLocal {this} {
  4939.     set errornr 0
  4940.  
  4941.     if {[[$this ooplType] isA OPBaseType]} {
  4942.         m4_warning $W_ASSOCTYPEERR [$this getName] [[$this ooplType] getName]
  4943.         incr errornr 1
  4944.     }
  4945.  
  4946.     return $errornr
  4947. }
  4948.  
  4949. method DPGReverseLinkAttr::setGenerator {this} {
  4950.     if {[$this generator] == ""} {
  4951.         if {[$this getMultiplicity] == "one"} {
  4952.             $this generator [DPGAssocOne new $this]
  4953.         } else {
  4954.             $this generator [DPGAssocMany new $this]
  4955.         }
  4956.     }
  4957. }
  4958.  
  4959. method DPGReverseLinkAttr::generate {this class} {
  4960.     if {[$this hasGUIComponent]} {
  4961.         return
  4962.     }
  4963.  
  4964.     $this setGenerator
  4965.     [$this generator] generate $class
  4966. }
  4967.  
  4968. # Do not delete this line -- regeneration end marker
  4969.  
  4970. if [isCommand CMReverseLinkAttr] {
  4971.     Class  DPGReverseLinkAttrD : {DPGReverseLinkAttr CMReverseLinkAttr} {
  4972.     }
  4973. } else {
  4974.     Class DPGReverseLinkAttrD : {DPGReverseLinkAttr OPReverseLinkAttr} {    
  4975.     }
  4976. }
  4977.  
  4978. global mostDerivedOOPL ; set mostDerivedOOPL(OPReverseLinkAttr) DPGReverseLinkAttrD
  4979.  
  4980. selfPromoter OPReverseLinkAttr {this} {
  4981.     DPGReverseLinkAttrD promote $this
  4982. }
  4983.  
  4984.  
  4985. #---------------------------------------------------------------------------
  4986. #      File:           @(#)dpgqualass.tcl    /main/titanic/4
  4987.  
  4988.  
  4989. Class DPGQualAssocAttr : {DPGQualAttr} {
  4990.     constructor
  4991.     method destructor
  4992. }
  4993.  
  4994. constructor DPGQualAssocAttr {class this name} {
  4995.     set this [DPGQualAttr::constructor $class $this $name]
  4996.     # Start constructor user section
  4997.     # End constructor user section
  4998.     return $this
  4999. }
  5000.  
  5001. method DPGQualAssocAttr::destructor {this} {
  5002.     # Start destructor user section
  5003.     # End destructor user section
  5004. }
  5005.  
  5006. # Do not delete this line -- regeneration end marker
  5007.  
  5008. if [isCommand CMQualAssocAttr] {
  5009.     Class  DPGQualAssocAttrD : {DPGQualAssocAttr CMQualAssocAttr} {
  5010.     }
  5011. } else {
  5012.     Class DPGQualAssocAttrD : {DPGQualAssocAttr OPQualAssocAttr} {    
  5013.     }
  5014. }
  5015.  
  5016. global mostDerivedOOPL ; set mostDerivedOOPL(OPQualAssocAttr) DPGQualAssocAttrD
  5017.  
  5018. selfPromoter OPQualAssocAttr {this} {
  5019.     DPGQualAssocAttrD promote $this
  5020. }
  5021.  
  5022.  
  5023. #---------------------------------------------------------------------------
  5024. #      File:           @(#)dpgquallin.tcl    /main/titanic/4
  5025.  
  5026.  
  5027. Class DPGQualLinkAttr : {DPGQualAttr} {
  5028.     constructor
  5029.     method destructor
  5030. }
  5031.  
  5032. constructor DPGQualLinkAttr {class this name} {
  5033.     set this [DPGQualAttr::constructor $class $this $name]
  5034.     # Start constructor user section
  5035.     # End constructor user section
  5036.     return $this
  5037. }
  5038.  
  5039. method DPGQualLinkAttr::destructor {this} {
  5040.     # Start destructor user section
  5041.     # End destructor user section
  5042. }
  5043.  
  5044. # Do not delete this line -- regeneration end marker
  5045.  
  5046. if [isCommand CMQualLinkAttr] {
  5047.     Class  DPGQualLinkAttrD : {DPGQualLinkAttr CMQualLinkAttr} {
  5048.     }
  5049. } else {
  5050.     Class DPGQualLinkAttrD : {DPGQualLinkAttr OPQualLinkAttr} {    
  5051.     }
  5052. }
  5053.  
  5054. global mostDerivedOOPL ; set mostDerivedOOPL(OPQualLinkAttr) DPGQualLinkAttrD
  5055.  
  5056. selfPromoter OPQualLinkAttr {this} {
  5057.     DPGQualLinkAttrD promote $this
  5058. }
  5059.