home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / ne_funcs.tcl < prev    next >
Text File  |  1997-06-04  |  55KB  |  1,829 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1994-1995 by Cadre Technologies 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 Cadre Technologies Inc.
  13. #
  14. #---------------------------------------------------------------------------
  15. #
  16. #    File        : @(#)ne_funcs.tcl    /main/hindenburg/5
  17. #    Original date    : 25-10-1994
  18. #    Description    : NewEra generator functions
  19. #
  20. #---------------------------------------------------------------------------
  21. #
  22.  
  23. proc oopl_model::generate {model} {
  24.     set selectedOoplClasses [getSelectedOoplClasses $model]
  25.     check_unique_file_names $selectedOoplClasses
  26.     foreach class $selectedOoplClasses {
  27.         if [$class isExternal] {
  28.             continue
  29.         }
  30.         if {[$class getName] == ""} {
  31.             puts stderr "Class without name skipped"
  32.             continue
  33.         }
  34.         class2tgtfiles $class nts nth
  35.         class2wiftgtfile $class ntw
  36.         global skip_file
  37.         global gen_file
  38.         global import_new
  39.         if [info exists gen_file($nth)] {
  40.             set gen_file($nts) 1
  41.         }
  42.         if {[$class getPropertyValue class_source] != "" &&
  43.             ![is_gui_class $class] } {
  44.             process_external_class_source $class
  45.             continue
  46.         }
  47.         if {( $import_new &&
  48.             ([is_special_class $class] || 
  49.             [info exists skip_file($nts)]) &&
  50.             [info exists skip_file($nth)] &&
  51.             ([is_gui_class $class] || [info exists skip_file($ntw)]))
  52.             ||
  53.             ( !$import_new &&
  54.             ![info exists gen_file($nts)] &&
  55.             ![info exists gen_file($nth)] &&
  56.             ![info exists gen_file($ntw)])} {
  57.             continue
  58.         }
  59.  
  60.         global ne_error_state
  61.         set ne_error_state 0
  62.         generate $class
  63.     }
  64. }
  65.  
  66. # Check uniqueness of filenames
  67. #
  68. proc check_unique_file_names {selectedOoplClasses} {
  69.     foreach class $selectedOoplClasses {
  70.         set cl_name [$class getName]
  71.         set file_name [class2file $cl_name]
  72.         if [$class isExternal] {
  73.             continue
  74.         }
  75.         if [info exists names($file_name)] {
  76.             error "Classes '$cl_name' and '$names($file_name)' map to the same file name" "" ERR_UNIQUE_FILENAME
  77.         }
  78.         set names($file_name) $cl_name
  79.     }
  80. }
  81.  
  82. proc class::generate {class} {
  83.     if {[is_gui_class $class]} {
  84.         class::generate_wif $class
  85.         return
  86.     }
  87.     if [catch {prepare_regeneration $class} result] {
  88.         # something went wrong, find out what
  89.         switch $errorCode {
  90.             ERR_REGEN {puts stderr $result}
  91.             default {error $result $errorInfo $errorCode}
  92.         }
  93.         class2tgtfiles $class src_file h_file
  94.         global gen_file
  95.         catch {unset gen_file($src_file)}
  96.         if {! [info exists gen_file($h_file)]} {
  97.             return
  98.         }
  99.     }
  100.     create_ne_sections [concat $ne_hdr_sections $ne_src_sections]
  101.     init_ne_sections $class
  102.     puts stdout "Generating for class '[$class getName]'"
  103.     set obj_type [$class get_obj_type]
  104.     if {$obj_type == "class_generic_typedef" || $obj_type == "class_typedef"
  105.             } {
  106.         puts "WARNING: No constructor generated for this special class;\
  107.              add operation \$create to get the constructor generated"
  108.     }
  109.     class::gen_description $class $ne_sections(h_class_nm_sect)
  110.     set is_db [is_db_class $class]
  111.     if {$is_db} {
  112.         db_class_before $class
  113.     }
  114.     gen_user_added_include
  115.     add_src_inc $class
  116.     gen_class_decl $class
  117.     set sect $ne_sections(h_pub_func_sect)
  118.     foreach feat [$class featureSet] {
  119.         generate $feat $class
  120.     }
  121.     if {$is_db} {
  122.         db_class_after $class
  123.     }
  124.     gen_delayed_code
  125.     gen_user_added_ctor
  126.     gen_user_added_dtor
  127.     gen_user_added_source
  128.     append_obsolete_code $class
  129.     exit_ne_sections $class
  130.     write_ne_sections $class $ne_hdr_sections $ne_src_sections
  131. }
  132.  
  133. proc class::gen_description {class sect} {
  134.     set ftext [$class getFreeText]
  135.     if {$ftext != ""} {
  136.         $sect append "\n"
  137.         string_to_oopl_comment $sect $ftext
  138.         $sect append "\n"
  139.     }
  140. }
  141.  
  142. proc class_enum::generate {class} {
  143.     # No enum class in NewEra
  144.     puts "ERROR: NewEra does not support enumerations: no code \
  145.         generated for class '[$class getName]'"
  146.     global ne_error_state
  147.     set ne_error_state 1
  148. }
  149.  
  150. proc class_enum::gen_class_decl {class} {
  151.     # No enum class in NewEra
  152. }
  153.  
  154. proc class_typedef::generate {class} {
  155.     # No typedef class in NewEra
  156.     class::generate $class
  157. }
  158.  
  159. proc class_typedef::gen_class_decl {class} {
  160.     # No typedef class in NewEra
  161.     class::gen_class_decl $class
  162. }
  163.  
  164. proc class_generic_typedef::generate {class} {
  165.     # No generic typedef class in NewEra
  166.     class::generate $class
  167. }
  168.  
  169. proc class_generic_typedef::gen_class_decl {class} {
  170.     # No generic typedef class in NewEra
  171.     class::gen_class_decl $class
  172. }
  173.  
  174. # look in global 're_user_includes' for previous user includes
  175. #
  176. proc gen_user_added_include {} {
  177.     set sect $ne_sections(c_hdr_sect)
  178.  
  179.     global re_user_includes
  180.     $sect append "$START_INCLUDE_MESSAGE\n"
  181.     $sect append $re_user_includes
  182.     $sect append "$END_INCLUDE_MESSAGE\n\n"
  183. }
  184.  
  185. # look in global 're_ctor' for previous user additions to constructor
  186. #
  187. proc gen_user_added_ctor {} {
  188.     set sect $ne_sections(c_ctor_body_iv_sect)
  189.     global re_ctor
  190.     set old_ind [$sect indent]
  191.     $sect append "$START_CTOR_MESSAGE\n"
  192.     $sect indent 0
  193.     $sect append $re_ctor
  194.     $sect indent $old_ind
  195.     $sect append "$END_CTOR_MESSAGE\n"
  196. }
  197.  
  198. # look in global 're_dtor' for previous user additions to destructor
  199. #
  200. proc gen_user_added_dtor {} {
  201.     set sect $ne_sections(c_dtor_sect)
  202.     global re_dtor
  203.     set old_ind [$sect indent]
  204.     $sect append "$START_DTOR_MESSAGE\n"
  205.     $sect indent 0
  206.     $sect append $re_dtor
  207.     $sect indent $old_ind
  208.     $sect append "$END_DTOR_MESSAGE\n"
  209. }
  210.  
  211. #look in global 're_user_source' for previous user source code
  212. #
  213. proc gen_user_added_source {} {
  214.     global re_user_source
  215.     set sect $ne_sections(c_src_sect)
  216.     $sect append "$START_SOURCE_MESSAGE\n"
  217.     $sect append $re_user_source
  218.     $sect append "$END_SOURCE_MESSAGE\n\n"
  219. }
  220. proc class::gen_class_decl {class} {
  221.     set sect $ne_sections(h_class_nm_sect)
  222.     $sect append "CLASS [$class getName]"
  223.     set first 1
  224.     foreach super [$class genNodeSet] {
  225.         generate $super first
  226.     }
  227.     $sect append "\n"
  228. }
  229.  
  230. proc link_class::generate {class} {
  231.     puts stdout "Generating for link class '[$class getName]'"
  232.     if {[$class getName] == ""} {
  233.         puts stderr "Link class without name skipped"
  234.         return
  235.     }
  236.     class::generate $class
  237. }
  238.  
  239. proc link_class::gen_class_decl {class} {
  240.     class::gen_class_decl $class
  241. }
  242.  
  243. proc inher_group::generate {group f} {
  244.     upvar $f first
  245.     set sect $ne_sections(h_class_nm_sect)
  246.     if {$first} {
  247.         $sect append " DERIVED FROM "
  248.         set first 0
  249.     } else {
  250.         # no MI in NewEra
  251.         puts "ERROR: NewEra does not support multiple inheritance:\
  252.             no code generated"
  253.         global ne_error_state
  254.         set ne_error_state 1
  255.     }
  256.     if {[$group isOverlapping] == "1"} {
  257.         puts "WARNING: Overlapping inheritance ignored; use normal\
  258.             inheritance instead"
  259.     }
  260.     add_hdr_inc [$group superClass]
  261.     $sect append "[$group getSuperClassName] "
  262. }
  263.  
  264. proc feature::gen_description {feature sect} {
  265.     set ftext [$feature getFreeText]
  266.     if {$ftext != ""} {
  267.         string_to_oopl_comment $sect $ftext
  268.     }
  269. }
  270.  
  271. proc data_attrib::generate {attrib class} {
  272.     if {[$attrib isClassFeature] == "1"} {
  273.         set shared_string "SHARED "
  274.     } else {
  275.         set shared_string ""
  276.     }
  277.     if {[[$attrib ooplType] get_obj_type] == "base_type"} {
  278.         set is_base_type 1
  279.     } else {
  280.         set is_base_type 0
  281.     }
  282.     set is_const_attrib [$attrib getPropertyValue is_const_attrib]
  283.     set is_constant [expr {$is_const_attrib == "1" && $is_base_type}]
  284.     set attrib_access [$attrib  getPropertyValue attrib_access]
  285.     if {$is_constant} {
  286.         set shared_string ""
  287.         set constvar_string "CONSTANT"
  288.         set access_string \
  289.             [access2string [split_access_mode $attrib_access r]]
  290.         set sect $ne_sections(h_const_data_sect)
  291.     } else {
  292.         set constvar_string "VARIABLE"
  293.         set access_string "PRIVATE "
  294.         set sect $ne_sections(h_priv_data_sect)
  295.     }
  296.     if {$is_base_type} {
  297.         set copy_string ""
  298.     } else {
  299.         set copy_qualif [$attrib getPropertyValue copy_qualif]
  300.         set copy_string [copy_qualif2string $copy_qualif]
  301.     }
  302.  
  303.     feature::gen_description $attrib $sect
  304.     set type_name [gen_var_decl [$attrib ooplType] [$attrib getName]]
  305.     $sect append "$access_string$shared_string$constvar_string\
  306.         $type_name $copy_string"
  307.  
  308.     data_attrib_initial_value $attrib $class $is_constant
  309.     $sect append "\n"
  310.     if {$is_constant == "1"} {
  311.         return
  312.     }
  313.     set name [cap [$attrib getName]]
  314.     set type [generate [$attrib ooplType] fwd]
  315.     set sect [get_attrib_hdr_sect $attrib r]
  316.     set access_string [access2string [split_access_mode $attrib_access r]]
  317.     expand_text $sect {
  318.         ~$access_string~${shared_string}FUNCTION get~${name}()\
  319.             RETURNING ~${type}
  320.     }
  321.     set sect [get_attrib_hdr_sect $attrib w]
  322.     set access_string [access2string [split_access_mode $attrib_access w]]
  323.     expand_text $sect {
  324.         ~$access_string~${shared_string}FUNCTION\
  325.             set~${name}(new~${name} ~${type}) RETURNING VOID
  326.     }
  327.     set sect [get_attrib_src_sect $attrib r]
  328.     expand_text $sect {
  329.         FUNCTION ~[$class getName]::get~${name}() RETURNING ~${type}
  330.             RETURN ~[$attrib getName]
  331.         END FUNCTION
  332.     
  333.     }
  334.     set sect [get_attrib_src_sect $attrib w]
  335.     expand_text $sect {
  336.         FUNCTION ~[$class getName]::set~${name}(new~${name} ~${type})\
  337.             RETURNING VOID
  338.             ~[assign_var [$attrib getName] new${name} \
  339.                      [$attrib ooplType]]
  340.         END FUNCTION
  341.  
  342.     }
  343. }
  344.  
  345. # generate an initial value line
  346.  
  347. proc data_attrib_initial_value {attrib class {is_constant 0}} {
  348.     if {[$attrib isClassFeature] == "1"} {
  349.         set is_shared 1
  350.     } else {
  351.         set is_shared 0
  352.     }
  353.     set iv [$attrib getPropertyValue initial_value]
  354.     set a_name [$attrib getName]
  355.     set c_name [$class getName]
  356.     if $is_constant {
  357.         set sect $ne_sections(h_const_data_sect)
  358.         if {$iv == ""} {
  359.             set iv "NULL"
  360.         }
  361.         $sect append " = $iv"
  362.         return
  363.     } elseif $is_shared {
  364.         set sect $ne_sections(c_static_sect)
  365.         set type [generate [$attrib ooplType] fwd]
  366.         $sect append "VARIABLE $c_name::$a_name $type"
  367.         if {$iv != ""} {
  368.             $sect append " = $iv"
  369.         } else {
  370.             gen_def_init_val $attrib $sect
  371.         }
  372.         $sect append "\n"
  373.         return
  374.     }
  375.     if {$iv == ""} {
  376.         return
  377.     }
  378.     
  379.     set type [$attrib ooplType]
  380.  
  381.     set sect $ne_sections(c_ctor_body_iv_sect)
  382.     $sect append "[assign_var $a_name $iv $type]\n"
  383. }
  384.  
  385. # Returns the default initial value for $attrib
  386. #
  387. proc gen_def_init_val {attrib sect} {
  388.     if {[$attrib get_obj_type] != "qual_assoc_attrib"} {
  389.         return
  390.     }
  391.     set key [[$attrib qualifier] ooplType]
  392.     set value [$attrib ooplType]
  393.     if {[$attrib getMultiplicity] == "one"} {
  394.         set result [dict::initializer "" $key $value]
  395.     } else {
  396.         set setpfx [set_prefix $attrib]
  397.         set result [${setpfx}rsdict::initializer "" $key $value]
  398.     }
  399.     $sect append $result
  400. }
  401.  
  402.  
  403. # produces 'mem(value)' in ctor initializers section
  404.  
  405. proc append_ctor_init {mem value} {
  406.     set sect $ne_sections(c_ctor_init_sect)
  407.     gen_ctor_sep $sect
  408.     $sect append "${mem}($value)"
  409. }
  410.  
  411.  
  412. # produce correct separator for constructor initializer part
  413.  
  414. proc gen_ctor_sep {sect} {
  415.     global ctor_init_sep
  416.     if $ctor_init_sep {
  417.         set ctor_init_sep 0
  418.         $sect append " :\n"
  419.     } else {
  420.         $sect append ",\n"
  421.     }
  422. }
  423.  
  424. # Common generate dispatch function for associations
  425. #
  426. proc gen_for_assoc {attrib class} {
  427.     set prefix "[$attrib get_obj_type]::[$attrib getMultiplicity]"
  428.     ${prefix}_data $attrib
  429.     ${prefix}_get $attrib $class
  430.     ${prefix}_set_self $attrib $class
  431.     ${prefix}_rm_self $attrib $class
  432.     ${prefix}_dtor $attrib $class
  433.     set type [$attrib ooplType]
  434.     add_src_inc $type
  435.     add_forward $type
  436. }
  437.  
  438. # Common generate dispatch function for database associations
  439. #
  440. proc gen_for_db_assoc {attrib class} {
  441.     set prefix "[$attrib get_obj_type]::[$attrib getMultiplicity]"
  442.     ${prefix}_get $attrib $class
  443.     ${prefix}_set $attrib $class
  444.     ${prefix}_remove $attrib $class
  445.     set type [$attrib ooplType]
  446.     add_src_inc $type
  447.     add_forward $type
  448. }
  449.  
  450. # Common generate dispatch function for links
  451. #
  452. proc gen_for_link {attrib class} {
  453.     set prefix "[$attrib get_obj_type]::[$attrib getMultiplicity]"
  454.     ${prefix}_data $attrib
  455.     ${prefix}_get $attrib $class
  456.     set type [$attrib ooplType]
  457.     add_src_inc $type
  458.     add_forward $type
  459. }
  460.  
  461. # Common generate dispatch function for reverse links
  462. #
  463. proc gen_for_rv_link {attrib class} {
  464.     set prefix "[$attrib get_obj_type]::[$attrib getMultiplicity]"
  465.     ${prefix}_data $attrib
  466.     ${prefix}_get $attrib $class
  467.     ${prefix}_dtor $attrib $class
  468.     set type [$attrib ooplType]
  469.     add_forward $type
  470. }
  471.  
  472. # Dispatch functions for rm/set other
  473. #
  474. proc rm_other {attrib sect ptr} {
  475.     set prefix "[$attrib get_obj_type]::[$attrib getMultiplicity]"
  476.     ${prefix}_rm_other $attrib $sect $ptr
  477. }
  478.  
  479. proc set_other {attrib decl_sect sect ptr} {
  480.     set prefix "[$attrib get_obj_type]::[$attrib getMultiplicity]"
  481.     ${prefix}_set_other $attrib $decl_sect $sect $ptr
  482. }
  483.  
  484. proc assoc_attrib::generate {attrib class} {
  485.     gen_for_assoc $attrib $class
  486. }
  487.  
  488. proc assign_var {to from type_obj} {
  489.     return "LET $to = $from"
  490. }
  491.  
  492. proc assoc_attrib::one_typedef {attrib class} {
  493.     puts "assoc_attrib::one_typedef CALLED"
  494. }
  495.  
  496. proc assoc_attrib::one_data {attrib} {
  497.     set sect $ne_sections(h_pub_data_sect)
  498.     set type [[$attrib ooplType] getName]
  499.     set name [uncap [reference_name [$attrib getName]]]
  500.     $sect append "PUBLIC VARIABLE $name $type\n"
  501.     if [$attrib isMandatory] {
  502.         return
  503.     }
  504.     set sect $ne_sections(c_ctor_body_iv_sect)
  505.     $sect append "LET $name = NULL\n"
  506. }
  507.  
  508. proc assoc_attrib::one_set_self {attrib class} {
  509.     set type [[$attrib ooplType] getName]
  510.     set name [cap [$attrib getName]]
  511.     set cl_name [$class getName]
  512.     set sect [get_assoc_hdr_sect $attrib w]
  513.     set access [get_access_mode [$attrib getPropertyValue assoc_access] w]
  514.     $sect append "${access}FUNCTION set${name}(new${name} $type)\
  515.                 RETURNING VOID\n"
  516.     set sect [get_assoc_src_sect $attrib w]
  517.     $sect append "FUNCTION $cl_name::set${name}(new${name} $type)\
  518.                 RETURNING VOID\n"
  519.     $sect indent +
  520.     set opposite [$attrib opposite]
  521.     set ref_name [uncap [reference_name $name]]
  522.     set decl_sect [TextSection new]
  523.     set impl_sect [TextSection new]
  524.     $decl_sect indent 0 "\t"
  525.     $impl_sect indent 0 "\t"
  526.     if {$opposite != ""} {
  527.         $impl_sect append "IF $ref_name IS NOT NULL THEN\n"
  528.         $impl_sect indent +
  529.         rm_other $opposite $impl_sect $ref_name
  530.         $impl_sect indent -
  531.         $impl_sect append "END IF\n"
  532.         set_other $opposite $decl_sect $impl_sect new${name}
  533.     }
  534.     set decl_sect [removeDoubleLinesFromSection $decl_sect]
  535.     $sect appendSect $decl_sect
  536.     $sect appendSect $impl_sect
  537.     $sect append "LET $ref_name = new${name}\n"
  538.     $sect indent -
  539.     $sect append "END FUNCTION\n\n"
  540. }
  541.  
  542. proc assoc_attrib::one_rm_self {attrib class} {
  543.     if [$attrib isMandatory] {
  544.         return
  545.     }
  546.     set type [[$attrib ooplType] getName]
  547.     set name [cap [$attrib getName]]
  548.     set cl_name [$class getName]
  549.     set sect [get_assoc_hdr_sect $attrib w]
  550.     set access [get_access_mode [$attrib getPropertyValue assoc_access] w]
  551.     $sect append "${access}FUNCTION remove${name}()\
  552.                 RETURNING VOID\n"
  553.     set sect [get_assoc_src_sect $attrib w]
  554.     $sect append "FUNCTION $cl_name::remove${name}()\
  555.                 RETURNING VOID\n"
  556.     $sect indent +
  557.     set opposite [$attrib opposite]
  558.     set ref_name [uncap [reference_name $name]]
  559.     if {$opposite != ""} {
  560.         $sect append "IF $ref_name IS NOT NULL THEN\n"
  561.         $sect indent +
  562.         rm_other $opposite $sect $ref_name
  563.         $sect indent -
  564.         $sect append "END IF\n"
  565.     }
  566.     $sect append "LET $ref_name = NULL\n"
  567.     $sect indent -
  568.     $sect append "END FUNCTION\n\n"
  569. }
  570.  
  571. proc assoc_attrib::one_set_other {attrib decl_sect impl_sect ref} {
  572.     set name [$attrib getName]
  573.     set refname [uncap [reference_name $name]]
  574.     $impl_sect append "LET ${ref}.$refname = SELF\n"
  575. }
  576.  
  577. proc assoc_attrib::one_rm_other {attrib sect ref} {
  578.     set name [$attrib getName]
  579.     set ref_name [uncap [reference_name $name]]
  580.     $sect append "LET ${ref}.$ref_name = NULL\n"
  581. }
  582.  
  583. proc assoc_attrib::one_dtor {attrib class} {
  584.     set opposite [$attrib opposite]
  585.     if {$opposite != ""} {
  586.         set ref [uncap [reference_name [$attrib getName]]]
  587.         set sect $ne_sections(c_dtor_sect)
  588.         set decl_sect $ne_sections(c_dtor_decl_sect)
  589.         $sect append "IF $ref IS NOT NULL THEN\n"
  590.         $sect indent +
  591.         rm_other $opposite $sect $ref
  592.         $sect indent -
  593.         $sect append "END IF\n"
  594.     }
  595. }
  596.  
  597. proc assoc_attrib::one_get {attrib class} {
  598.     set type [[$attrib ooplType] getName]
  599.     set name [cap [$attrib getName]]
  600.     set cl_name [$class getName]
  601.     set sect [get_assoc_hdr_sect $attrib r]
  602.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  603.     $sect append "${access}FUNCTION get${name}() RETURNING $type\n"
  604.     set sect $ne_sections(c_impl_no_regen_sect)
  605.     $sect append "FUNCTION $cl_name::get${name}() RETURNING $type\n"
  606.     set ref_name [uncap [reference_name $name]]
  607.     $sect indent +
  608.     $sect append "RETURN $ref_name\n"
  609.     $sect indent -
  610.     $sect append "END FUNCTION\n\n"
  611. }
  612.  
  613. proc assoc_attrib::many_typedef {attrib class} {
  614.     puts "assoc_attrib::many_typedef CALLED"
  615. }
  616.  
  617. proc assoc_attrib::many_data {attrib} {
  618.     set sect $ne_sections(h_pub_data_sect)
  619.     set setpfx [set_prefix $attrib]
  620.     set type [${setpfx}set_type_name [$attrib ooplType]]
  621.     set name [uncap [${setpfx}set_name [$attrib getName]]]
  622.     $sect append "PUBLIC VARIABLE $name $type\n"
  623.     set sect $ne_sections(c_ctor_body_iv_sect)
  624.     $sect append "LET $name = NEW ${type}()\n"
  625. }
  626.  
  627. proc assoc_attrib::many_set_self {attrib class} {
  628.     set type [[$attrib ooplType] getName]
  629.     set name [cap [$attrib getName]]
  630.     set cl_name [$class getName]
  631.     set sect [get_assoc_hdr_sect $attrib w]
  632.     set access [get_access_mode [$attrib getPropertyValue assoc_access] w]
  633.     $sect append "${access}FUNCTION add${name}(new${name} $type)\
  634.                 RETURNING VOID\n"
  635.     set sect [get_assoc_src_sect $attrib w]
  636.     $sect append "FUNCTION $cl_name::add${name}(new${name} $type)\
  637.                 RETURNING VOID\n"
  638.     $sect indent +
  639.     set decl_sect [TextSection new]
  640.     set impl_sect [TextSection new]
  641.     $decl_sect indent 0 "\t"
  642.     $impl_sect indent 0 "\t"
  643.     set opposite [$attrib opposite]
  644.     set setpfx [set_prefix $attrib]
  645.     set set_name [uncap [${setpfx}set_name $name]]
  646.     set add_func [set ${setpfx}set::add]
  647.     set retval [set ${setpfx}set::add_retval]
  648.     set retvar ${add_func}RetVal
  649.     if {$retval != "VOID"} {
  650.         $decl_sect append "VARIABLE $retvar $retval\n"
  651.         set ret_clause "RETURNING $retvar"
  652.     } else {
  653.         set ret_clause ""
  654.     }
  655.     $impl_sect append "CALL $set_name.${add_func}(new${name})\
  656.             $ret_clause\n"
  657.     if {$opposite != ""} {
  658.         set_other $opposite $decl_sect $impl_sect new${name}
  659.     }
  660.     set decl_sect [removeDoubleLinesFromSection $decl_sect]
  661.     $sect appendSect $decl_sect
  662.     $sect appendSect $impl_sect
  663.     $sect indent -
  664.     $sect append "END FUNCTION\n\n"
  665. }
  666.  
  667. proc assoc_attrib::many_rm_self {attrib class} {
  668.     set type [[$attrib ooplType] getName]
  669.     set name [cap [$attrib getName]]
  670.     set cl_name [$class getName]
  671.     set sect [get_assoc_hdr_sect $attrib w]
  672.     set access [get_access_mode [$attrib getPropertyValue assoc_access] w]
  673.     $sect append "${access}FUNCTION remove${name}(old${name} $type)\
  674.                 RETURNING VOID\n"
  675.     set sect [get_assoc_src_sect $attrib w]
  676.     $sect append "FUNCTION $cl_name::remove${name}(old${name}\
  677.                 $type) RETURNING VOID\n"
  678.     $sect indent +
  679.     set opposite [$attrib opposite]
  680.     set setpfx [set_prefix $attrib]
  681.     set set_name [uncap [${setpfx}set_name $name]]
  682.     set remove_func [set ${setpfx}set::remove]
  683.     if [$attrib isMandatory] {
  684.         # mandatory aspect is compelled only by testing on size > 1
  685.         set size_func [set ${setpfx}set::size]
  686.         $sect append "IF $set_name.${size_func}() > 1 THEN\n"
  687.         $sect indent +
  688.     }
  689.     $sect append "CALL $set_name.${remove_func}(old${name})\n"
  690.     if {$opposite != ""} {
  691.         rm_other $opposite $sect old${name}
  692.     }
  693.     if [$attrib isMandatory] {
  694.         $sect indent -
  695.         $sect append "END IF\n"
  696.     }
  697.     $sect indent -
  698.     $sect append "END FUNCTION\n\n"
  699. }
  700.  
  701. proc assoc_attrib::many_set_other {attrib decl_sect impl_sect ref} {
  702.     set setpfx [set_prefix $attrib]
  703.     set name [uncap [${setpfx}set_name [$attrib getName]]]
  704.     set add_func [set ${setpfx}set::add]
  705.     set retval [set ${setpfx}set::add_retval]
  706.     set retvar ${add_func}RetVal
  707.     if {$retval != "VOID"} {
  708.         set ret_clause "RETURNING $retvar"
  709.         $decl_sect append "VARIABLE $retvar $retval\n"
  710.     } else {
  711.         set ret_clause ""
  712.     }
  713.     $impl_sect append "CALL $ref.$name.${add_func}(SELF)\
  714.         $ret_clause\n"
  715. }
  716.  
  717. proc assoc_attrib::many_rm_other {attrib sect ref} {
  718.     set setpfx [set_prefix $attrib]
  719.     set name [uncap [${setpfx}set_name [$attrib getName]]]
  720.     set remove_func [set ${setpfx}set::remove]
  721.     $sect append "CALL $ref.$name.${remove_func}(SELF)\n"
  722. }
  723.  
  724. proc assoc_attrib::many_dtor {attrib class} {
  725.     set opposite [$attrib opposite]
  726.     if {$opposite != ""} {
  727.         set sect $ne_sections(c_dtor_sect)
  728.         set decl_sect $ne_sections(c_dtor_decl_sect)
  729.         set type [[$attrib ooplType] getName]
  730.         set name [$attrib getName]
  731.         set action "rm_other $opposite $sect"
  732.         set setpfx [set_prefix $attrib]
  733.         ${setpfx}set::iter $decl_sect $sect $name $type $action
  734.     }
  735. }
  736.  
  737. proc assoc_attrib::many_get {attrib class} {
  738.     set setpfx [set_prefix $attrib]
  739.     set type [${setpfx}set_type_name [$attrib ooplType]]
  740.     set name [cap [${setpfx}set_name [$attrib getName]]]
  741.     set cl_name [$class getName]
  742.     set sect [get_assoc_hdr_sect $attrib r]
  743.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  744.     $sect append "${access}FUNCTION get${name}() RETURNING $type\n"
  745.     set sect $ne_sections(c_impl_no_regen_sect)
  746.     $sect append "FUNCTION $cl_name::get${name}()\
  747.                 RETURNING $type\n"
  748.     $sect indent +
  749.     $sect append "RETURN [uncap $name]\n"
  750.     $sect indent -
  751.     $sect append "END FUNCTION\n\n"
  752. }
  753.  
  754. proc get_qualifier_type {assoc} {
  755.     return [generate [[$assoc qualifier] ooplType] fwd]
  756. }
  757.  
  758. proc get_qualifier_name {assoc} {
  759.     return [[$assoc qualifier] getName]
  760. }
  761.  
  762. proc qual_assoc_attrib::generate {attrib class} {
  763.     gen_for_assoc $attrib $class
  764. }
  765.  
  766. proc qual_assoc_attrib::one_typedef {attrib class} {
  767.     puts "qual_assoc_attrib::one_typedef CALLED"
  768. }
  769.  
  770. proc qual_assoc_attrib::one_data {attrib} {
  771.     set sect $ne_sections(h_pub_data_sect)
  772.     set type [dict_type_name [[$attrib qualifier] ooplType] \
  773.                  [$attrib ooplType]]
  774.     set name [uncap [dict_name [$attrib getName]]]
  775.     $sect append "PUBLIC VARIABLE $name $type\n"
  776.  
  777.     set sect $ne_sections(c_ctor_body_sect)
  778.     set key [[$attrib qualifier] ooplType]
  779.     set value [$attrib ooplType]
  780.     set result [dict::initializer $name $key $value]
  781.     if {$result == ""} {
  782.         return
  783.     }
  784.     $sect append $result
  785. }
  786.  
  787. proc qual_assoc_attrib::one_set_self {attrib class} {
  788.     set type [[$attrib ooplType] getName]
  789.     set name [cap [$attrib getName]]
  790.     set cl_name [$class getName]
  791.     set key [get_qualifier_name $attrib]
  792.     set q_type [get_qualifier_type $attrib]
  793.     set sect [get_assoc_hdr_sect $attrib w]
  794.     set access [get_access_mode [$attrib getPropertyValue assoc_access] w]
  795.     $sect append "${access}FUNCTION set${name}($key $q_type,\
  796.                 new${name} $type) RETURNING VOID\n"
  797.     set sect [get_assoc_src_sect $attrib w]
  798.     $sect append "FUNCTION $cl_name::set${name}($key $q_type,\
  799.                 new${name} $type) RETURNING VOID\n"
  800.     $sect indent +
  801.     set decl_sect [TextSection new]
  802.     set impl_sect [TextSection new]
  803.     $decl_sect indent 0 "\t"
  804.     $impl_sect indent 0 "\t"
  805.     set opposite [$attrib opposite]
  806.     set dct_name [uncap [dict_name $name]]
  807.     if {$opposite != ""} {
  808.         set action "rm_other $opposite $decl_sect $impl_sect"
  809.         dict::get_test_and_act $impl_sect $name $key $type $action
  810.         set_other $opposite $decl_sect $impl_sect new${name}
  811.     }
  812.     set decl_sect [removeDoubleLinesFromSection $decl_sect]
  813.     $sect appendSect $decl_sect
  814.     $sect appendSect $impl_sect
  815.     $sect append "CALL $dct_name.${dict::set}($key, new${name})\n"
  816.     $sect indent -
  817.     $sect append "END FUNCTION\n\n"
  818. }
  819.  
  820. proc qual_assoc_attrib::one_rm_self {attrib class} {
  821.     set type [[$attrib ooplType] getName]
  822.     set name [cap [$attrib getName]]
  823.     set cl_name [$class getName]
  824.     set key [get_qualifier_name $attrib]
  825.     set q_type [get_qualifier_type $attrib]
  826.     set sect [get_assoc_hdr_sect $attrib w]
  827.     set access [get_access_mode [$attrib getPropertyValue assoc_access] w]
  828.     $sect append "${access}FUNCTION remove${name}($key $q_type)\
  829.                 RETURNING VOID\n"
  830.     set sect [get_assoc_src_sect $attrib w]
  831.     $sect append "FUNCTION $cl_name::remove${name}($key $q_type)\
  832.                 RETURNING VOID\n"
  833.     $sect indent +
  834.     set opposite [$attrib opposite]
  835.     set dct_name [uncap [dict_name $name]]
  836.     if {$opposite != ""} {
  837.         set action "rm_other $opposite $sect"
  838.         dict::get_test_and_act $sect $name $key $type $action
  839.     }
  840.     $sect append "CALL $dct_name.${dict::remove}($key)\n"
  841.     $sect indent -
  842.     $sect append "END FUNCTION\n\n"
  843. }
  844.  
  845. proc qual_assoc_attrib::one_set_other {attrib decl_sect impl_sect ref} {
  846.     set name [uncap [dict_name [$attrib getName]]]
  847.     $impl_sect append \
  848.         "CALL $ref.$name.${dict::set}(\{ supply key here \}, SELF)\n"
  849. }
  850.  
  851. proc qual_assoc_attrib::one_rm_other {attrib sect ref} {
  852.     set name [uncap [dict_name [$attrib getName]]]
  853.     $sect append \
  854.         "CALL $ref.$name.${dict::remove}(\{ supply key here \})\n"
  855. }
  856.  
  857. proc qual_assoc_attrib::one_dtor {attrib class} {
  858.     set opposite [$attrib opposite]
  859.     if {$opposite != ""} {
  860.         set sect $ne_sections(c_dtor_sect)
  861.         set decl_sect $ne_sections(c_dtor_decl_sect)
  862.         set type [[$attrib ooplType] getName]
  863.         set qual_type [[[$attrib qualifier] ooplType] getName]
  864.         set name [$attrib getName]
  865.         set action "rm_other $opposite $sect"
  866.         dict::iter $decl_sect $sect $name $type $qual_type $action
  867.     }
  868. }
  869.  
  870. proc qual_assoc_attrib::one_get {attrib class} {
  871.     set type [[$attrib ooplType] getName]
  872.     set name [cap [$attrib getName]]
  873.     set key [get_qualifier_name $attrib]
  874.     set q_type [get_qualifier_type $attrib]
  875.     set cl_name [$class getName]
  876.     set sect [get_assoc_hdr_sect $attrib r]
  877.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  878.     $sect append "${access}FUNCTION get${name}($key $q_type)\
  879.                 RETURNING $type\n"
  880.     set sect $ne_sections(c_impl_no_regen_sect)
  881.     $sect append "FUNCTION $cl_name::get${name}($key $q_type)\
  882.                 RETURNING $type\n"
  883.     set dct_name [uncap [dict_name $name]]
  884.     $sect indent +
  885.     dict::get_and_return $sect $dct_name $key $type
  886.     $sect indent -
  887.     $sect append "END FUNCTION\n\n"
  888. }
  889.  
  890. proc qual_assoc_attrib::many_typedef {attrib class} {
  891.     puts "qual_assoc_attrib::many_typedef CALLED"
  892. }
  893.  
  894. proc qual_assoc_attrib::many_data {attrib} {
  895.     set sect $ne_sections(h_pub_data_sect)
  896.     set setpfx [set_prefix $attrib]
  897.     set type [${setpfx}set_dict_type_name \
  898.         [[$attrib qualifier] ooplType] [$attrib ooplType]]
  899.     set name [uncap [${setpfx}set_dict_name [$attrib getName]]]
  900.     $sect append "PUBLIC VARIABLE $name $type\n"
  901.  
  902.     set sect $ne_sections(c_ctor_body_sect)
  903.     set key [[$attrib qualifier] ooplType]
  904.     set value [$attrib ooplType]
  905.     set result [${setpfx}rsdict::initializer $name $key $value]
  906.     if {$result == ""} {
  907.         return
  908.     }
  909.     $sect append $result
  910. }
  911.  
  912. proc qual_assoc_attrib::many_set_self {attrib class} {
  913.     set type [[$attrib ooplType] getName]
  914.     set name [cap [$attrib getName]]
  915.     set cl_name [$class getName]
  916.     set key [get_qualifier_name $attrib]
  917.     set q_type [get_qualifier_type $attrib]
  918.     set sect [get_assoc_hdr_sect $attrib w]
  919.     set access [get_access_mode [$attrib getPropertyValue assoc_access] w]
  920.     $sect append "${access}FUNCTION add${name}($key $q_type,\
  921.                 new${name} $type) RETURNING VOID\n"
  922.     set sect [get_assoc_src_sect $attrib w]
  923.     $sect append "FUNCTION $cl_name::add${name}($key $q_type,\
  924.                 new${name} $type) RETURNING VOID\n"
  925.     $sect indent +
  926.     set decl_sect [TextSection new]
  927.     set impl_sect [TextSection new]
  928.     $decl_sect indent 0 "\t"
  929.     $impl_sect indent 0 "\t"
  930.     set setpfx [set_prefix $attrib]
  931.     set sdct_name [uncap [${setpfx}set_dict_name [$attrib getName]]]
  932.     set add_func [set ${setpfx}rsdict::add]
  933.     set retval [set ${setpfx}rsdict::add_retval]
  934.     set retvar ${add_func}RetVal
  935.     if {$retval != "VOID"} {
  936.         $decl_sect append "VARIABLE $retvar $retval\n"
  937.         set ret_clause "RETURNING $retvar"
  938.     } else {
  939.         set ret_clause ""
  940.     }
  941.     $impl_sect append "CALL $sdct_name.${add_func}($key,\
  942.         new${name}) $ret_clause\n"
  943.  
  944.     set opposite [$attrib opposite]
  945.     if {$opposite != ""} {
  946.         set_other $opposite $decl_sect $impl_sect new${name}
  947.     }
  948.     set decl_sect [removeDoubleLinesFromSection $decl_sect]
  949.     $sect appendSect $decl_sect
  950.     $sect appendSect $impl_sect
  951.     $sect indent -
  952.     $sect append "END FUNCTION\n\n"
  953. }
  954.  
  955. proc qual_assoc_attrib::many_rm_self {attrib class} {
  956.     set type [[$attrib ooplType] getName]
  957.     set name [cap [$attrib getName]]
  958.     set cl_name [$class getName]
  959.     set key [get_qualifier_name $attrib]
  960.     set q_type [get_qualifier_type $attrib]
  961.     set sect [get_assoc_hdr_sect $attrib w]
  962.     set access [get_access_mode [$attrib getPropertyValue assoc_access] w]
  963.     $sect append "${access}FUNCTION remove${name}($key $q_type,\
  964.                 old${name} $type) RETURNING VOID\n"
  965.     set sect [get_assoc_src_sect $attrib w]
  966.     $sect append "FUNCTION $cl_name::remove${name}($key $q_type,\
  967.                 old${name} $type) RETURNING VOID\n"
  968.     $sect indent +
  969.     set opposite [$attrib opposite]
  970.     if {$opposite != ""} {
  971.         rm_other $opposite $sect old${name}
  972.     }
  973.     set setpfx [set_prefix $attrib]
  974.     set sdct_name [uncap [${setpfx}set_dict_name [$attrib getName]]]
  975.     set remove_func [set ${setpfx}rsdict::remove]
  976.     $sect append \
  977.             "CALL $sdct_name.${remove_func}($key, old${name})\n"
  978.     $sect indent -
  979.     $sect append "END FUNCTION\n\n"
  980. }
  981.  
  982. proc qual_assoc_attrib::many_set_other {attrib decl_sect impl_sect ref} {
  983.     set type [[$attrib ooplType] getName]
  984.         set name [cap [$attrib getName]]
  985.     set setpfx [set_prefix $attrib]
  986.     set sdct_name [uncap [${setpfx}set_dict_name $name]]
  987.     set add_func [set ${setpfx}rsdict::add]
  988.     set retval [set ${setpfx}rsdict::add_retval]
  989.     set retvar ${add_func}RetVal
  990.     if {$retval != "VOID"} {
  991.         set ret_clause "RETURNING $retvar"
  992.         $decl_sect append "VARIABLE $retvar $retval\n"
  993.     } else {
  994.         set ret_clause ""
  995.     }
  996.     $impl_sect append "CALL $ref.$sdct_name.${add_func}(\
  997.             \{ supply key here \}, SELF) $ret_clause\n"
  998. }
  999.  
  1000. proc qual_assoc_attrib::many_rm_other {attrib sect ref} {
  1001.     set type [[$attrib ooplType] getName]
  1002.     set name [cap [$attrib getName]]
  1003.     set setpfx [set_prefix $attrib]
  1004.     set sdct_name [uncap [${setpfx}set_dict_name $name]]
  1005.     set remove_func [set ${setpfx}rsdict::remove]
  1006.     $sect append "CALL $ref.$sdct_name.${remove_func}(\
  1007.                 \{ supply key here \}, SELF)\n"
  1008. }
  1009.  
  1010. proc qual_assoc_attrib::many_dtor {attrib class} {
  1011.     set opposite [$attrib opposite]
  1012.     if {$opposite != ""} {
  1013.         set sect $ne_sections(c_dtor_sect)
  1014.         set decl_sect $ne_sections(c_dtor_decl_sect)
  1015.         set type [$attrib ooplType]
  1016.         set q_type [string trimright [generate [[$attrib qualifier] \
  1017.                         ooplType] inc]]
  1018.         set name [cap [$attrib getName]]
  1019.         set action "rm_other $opposite $sect"
  1020.         set setpfx [set_prefix $attrib]
  1021.         ${setpfx}rsdict::iter $decl_sect $sect $name $type $q_type $action
  1022.     }
  1023. }
  1024.  
  1025. proc qual_assoc_attrib::many_get {attrib class} {
  1026.     set setpfx [set_prefix $attrib]
  1027.     set type [${setpfx}set_type_name [$attrib ooplType]]
  1028.     set name [cap [$attrib getName]]
  1029.     set key [get_qualifier_name $attrib]
  1030.     set q_type [get_qualifier_type $attrib]
  1031.     set cl_name [$class getName]
  1032.     set sect [get_assoc_hdr_sect $attrib r]
  1033.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  1034.     $sect append "${access}FUNCTION get${name}($key $q_type)\
  1035.                 RETURNING $type\n"
  1036.     set sect $ne_sections(c_impl_no_regen_sect)
  1037.     $sect append "FUNCTION $cl_name::get${name}($key $q_type)\
  1038.                 RETURNING $type\n"
  1039.     set sdct_name [uncap [${setpfx}set_dict_name $name]]
  1040.     $sect indent +
  1041.     ${setpfx}rsdict::get_and_return $sect $name $key $type
  1042.     $sect indent -
  1043.     $sect append "END FUNCTION\n\n"
  1044. }
  1045.  
  1046. proc operation::generate {oper class} {
  1047.     global ne_error_state
  1048.     set name [$oper getName]
  1049.     set is_ctor [expr {$name == "create" && [$oper isClassFeature]== "1"}]
  1050.     if {$is_ctor && [is_db_class $class]} {
  1051.         puts "ERROR: constructor function \$create not allowed in database class '$name'"
  1052.         set ne_error_state 1
  1053.         return
  1054.     }
  1055.     set h_sect [get_hdr_sect [$oper getPropertyValue method_access]]
  1056.     feature::gen_description $oper $h_sect
  1057.     set c_sect $ne_sections(c_impl_sect)
  1058.     set is_abstract [expr {[$oper isAbstract] == "1"}]
  1059.     if $is_ctor {
  1060.         set type ""
  1061.         set name [$class getName]
  1062.     } else {
  1063.         set type [generate [$oper ooplType] fwd]
  1064.     }
  1065.     set method_access [$oper getPropertyValue method_access]
  1066.     if {$is_ctor && $is_abstract && $method_access == "Public"} {
  1067.         set access [access2string "Protected"]
  1068.     } else {
  1069.         set access [get_access_mode $method_access]
  1070.     }
  1071.     set is_shared [expr {[$oper isClassFeature] == "1"} && !$is_ctor]
  1072.     $h_sect append "$access"
  1073.     if $is_shared {
  1074.         $h_sect append "SHARED "
  1075.     }
  1076.     if {[$oper getPropertyValue is_event] == "1"} {
  1077.         $h_sect append "EVENT "
  1078.     } else {
  1079.         $h_sect append "FUNCTION "
  1080.     }
  1081.     $h_sect append "${name}("
  1082.     set first 1
  1083.     foreach param [$oper parameterSet] {
  1084.         set default [$param getPropertyValue default_value]
  1085.         set decl fwd
  1086.         if {$default != ""} {
  1087.             set decl inc
  1088.         }
  1089.         generate $param $h_sect first $decl
  1090.         if {$default != ""} {
  1091.             $h_sect append " : $default"
  1092.         }
  1093.     }
  1094.     $h_sect append ")"
  1095.     if {$type != ""} {
  1096.         $h_sect append " RETURNING $type"
  1097.     }
  1098.     $h_sect append "\n"
  1099.     if {[$oper getPropertyValue is_event] == "1"} {
  1100.         return
  1101.     }
  1102.  
  1103.     set tmp_c_sect [TextSection new]
  1104.     $c_sect append "FUNCTION [$class getName]::${name}"
  1105.     $tmp_c_sect append "("
  1106.     set first 1
  1107.     foreach param [$oper parameterSet] {
  1108.         generate $param $tmp_c_sect first fwd
  1109.     }
  1110.     $tmp_c_sect append ")"
  1111.     set method_type [$tmp_c_sect contents]
  1112.     if {$type != ""} {
  1113.         $tmp_c_sect append " RETURNING $type"
  1114.     }
  1115.  
  1116.     $c_sect appendSect $tmp_c_sect
  1117.  
  1118.     set impl_proc [string trim [$oper getPropertyValue method_impl]]
  1119.     if {$impl_proc == ""} {
  1120.         # get previously prepared body
  1121.         get_method_body $name $method_type $c_sect
  1122.         $c_sect append "END FUNCTION\n\n"
  1123.     } else {
  1124.         set impl_proc operation::$impl_proc
  1125.         if {[info procs $impl_proc] != ""} {
  1126.             $c_sect append "\n"
  1127.             $c_sect indent +
  1128.             $c_sect append [$impl_proc $oper $class $c_sect]
  1129.             $c_sect indent -
  1130.             $c_sect append "END FUNCTION\n\n"
  1131.             regen_unset $name $method_type
  1132.         } else {
  1133.             puts stderr "WARNING: Tcl procedure " nonewline
  1134.             puts stderr "'$impl_proc' not found"
  1135.             # fall back to regeneration
  1136.             get_method_body $name $method_type $c_sect
  1137.             $c_sect append "END FUNCTION\n\n"
  1138.         }
  1139.     }
  1140. }
  1141.  
  1142. proc parameter::generate {param sect f decl {is_db 0} {with_types 1}} {
  1143.     upvar $f first
  1144.  
  1145.     if $first {
  1146.         set first 0
  1147.     } else {
  1148.         $sect append ", "
  1149.     }
  1150.     if !$with_types {
  1151.         $sect append "[$param getName]"
  1152.         return
  1153.     }
  1154.     set type_str [generate [$param ooplType] $decl]
  1155.     if {$is_db && [[$param ooplType] get_obj_type] == "base_type"} {
  1156.         set type_str [map_fgl2ixval $type_str]
  1157.     }
  1158.     $sect append \
  1159.         "[$param getName] $type_str"
  1160. }
  1161.  
  1162. proc base_type::generate {type decl} {
  1163.     set result [$type getType3GL]
  1164.     if [regexp {(VAR)?CHAR\([0-9][0-9]*\)} $result] {
  1165.         regsub {\([0-9][0-9]*\)} $result "\(*\)" result
  1166.     }
  1167.     return $result
  1168. }
  1169.  
  1170. proc base_type::gen_var_decl {type name} {
  1171.     set type [$type getType3GL]
  1172.     return "$name $type"
  1173. }
  1174.  
  1175. proc class_type::generate {type decl}  {
  1176.     set name [$type getName]
  1177.     if {$name == ""} {
  1178.         return "VOID"
  1179.     }
  1180.     if {$decl == "fwd"} {
  1181.         add_forward $type
  1182.         add_src_inc $type
  1183.     } else {
  1184.         add_hdr_inc $type
  1185.     }
  1186.     return $name
  1187. }
  1188.  
  1189. proc class_type::gen_var_decl {type name} {
  1190.     add_forward $type
  1191.     return "$name [$type getName]"
  1192. }
  1193.  
  1194. proc typedef_type::generate {type decl} {
  1195.     return [class_type::generate $type $decl]
  1196. }
  1197.  
  1198. proc typedef_type::gen_var_decl {type name} {
  1199.     return [class_type::gen_var_decl $type $name]
  1200. }
  1201.  
  1202. proc enum_type::generate {type decl} {
  1203.     return [class_type::generate $type $decl]
  1204. }
  1205.  
  1206. proc enum_type::gen_var_decl {type name} {
  1207.     return [class_type::gen_var_decl $type $name]
  1208. }
  1209.  
  1210. proc generic_typedef_type::generate {type decl} {
  1211.     return [class_type::generate $type $decl]
  1212. }
  1213.  
  1214. proc generic_typedef_type::gen_var_decl {type name} {
  1215.     return [class_type::gen_var_decl $type $name]
  1216. }
  1217.  
  1218. proc copy_qualif2string {copy_qualif} {
  1219.     case $copy_qualif in {
  1220.         {Shallow ""} {return ""}
  1221.         {Null} {return "NULL COPY "}
  1222.         {Deep} {return "DEEP COPY "}
  1223.     }
  1224. }
  1225.  
  1226. proc access2string {access} {
  1227.     case $access in {
  1228.         {Public ""} {return "PUBLIC "}
  1229.         {Protected} {return "PROTECTED "}
  1230.         {Private} {return "PRIVATE "}
  1231.     }
  1232. }
  1233.  
  1234. proc get_access_mode {access {mode ""}} {
  1235.     return [access2string [split_access_mode $access $mode]]
  1236. }
  1237.  
  1238. # Determine if all initializers for a class refer to a part of the key
  1239. # This is done by comparing the signature of all keys with that of all
  1240. # creation parameters
  1241. #
  1242. proc all_inits_are_keys {class} {
  1243.     set ctor_list ""
  1244.     foreach ct_param [$class creationParamSet] {
  1245.         lappend ctor_list [[$ct_param ooplType] getType3GL]
  1246.     }
  1247.     set key_list ""
  1248.     foreach key [get_col_list [$class table] KEYS] {
  1249.         if {[$key getUniqueName] != $TYPE_ID_NM} {
  1250.             lappend key_list [$key getType3GL]
  1251.         }
  1252.     }
  1253.     return [expr {$ctor_list == $key_list}]
  1254. }
  1255.  
  1256. # test if a operation signature equals the 
  1257. # database-runtime-constructor
  1258. #
  1259. proc is_eq_db_ctor {oper class} {
  1260.     set is_db [is_db_class $class]
  1261.     # easy tests first
  1262.     if {! $is_db || [$oper getName] != "create"}  {
  1263.         return 0
  1264.     }
  1265.     if {[$oper get_obj_type] == "constructor"} {
  1266.         set params [$class creationParamSet]
  1267.     } else {
  1268.         set params [$oper parameterSet]
  1269.     }
  1270.     set keys [get_col_list [$class table] KEYS]
  1271.     # number of parameters must be equal
  1272.     # correct for extra key
  1273.     set lp [llength $params]
  1274.     incr lp
  1275.     if {$lp != [llength $keys]} {
  1276.         return 0
  1277.     }
  1278.     foreach param $params {
  1279.         set key [lvarpop keys]
  1280.         if {[$key getUniqueName] == $TYPE_ID_NM} {
  1281.             set key [lvarpop keys]
  1282.         }
  1283.         set key_t [string trim [$key getType3GL]]
  1284.         if [regexp {(VAR)?CHAR\([0-9][0-9]*\)} $key_t] {
  1285.             regsub {\([0-9][0-9]*\)} $key_t "\(*\)" key_t
  1286.         }
  1287.         set par_t [string trim [generate [$param ooplType] fwd]]
  1288.         if {$key_t != $par_t} {
  1289.             return 0
  1290.         }
  1291.         # OK, continue
  1292.     }
  1293.     return 1
  1294. }
  1295.  
  1296. proc constructor::generate {ctor class} {
  1297.     global exists_ctor
  1298.     set exists_ctor 1
  1299.     set is_db [is_db_class $class]
  1300.     if $is_db {
  1301.         db_constructor::generate $ctor $class
  1302.         return
  1303.     }
  1304.     set class_nm [$class getName]
  1305.     set ctor_nm $class_nm
  1306.     set sect $ne_sections(h_ctor_sect)
  1307.     $sect append "FUNCTION "
  1308.     set with_default 1
  1309.     gen_ctor_decl $class $sect $ctor_nm $with_default
  1310.     $sect append "\n"
  1311.     set sect $ne_sections(c_ctor_init_sect)
  1312.     $sect append "FUNCTION $class_nm::"
  1313.     set with_default 0
  1314.     gen_ctor_decl $class $sect $ctor_nm $with_default
  1315. #    $sect append "\n"
  1316.     $sect indent +
  1317.     set decl_sect $ne_sections(c_ctor_decl_sect)
  1318.     set body $ne_sections(c_ctor_body_sect)
  1319.     foreach init [$ctor initializerSet] {
  1320.         generate $init $sect $decl_sect $body $class
  1321.     }
  1322. }
  1323.  
  1324. proc gen_ctor_decl {class sect ctor_nm with_default} {
  1325.     $sect append "${ctor_nm}"
  1326.     set tmp_sect [TextSection new]
  1327.     $tmp_sect append "("
  1328.     set first 1
  1329.     foreach param [$class creationParamSet] {
  1330.         set default ""
  1331.         set decl fwd
  1332.         if {$with_default} {
  1333.             set default [$param getPropertyValue default_value]
  1334.             if {$default != ""} { 
  1335.                 set decl inc
  1336.             }
  1337.         }
  1338.         parameter::generate $param $tmp_sect first $decl
  1339.         if {$default != ""} {
  1340.             $tmp_sect append " : $default"
  1341.         }
  1342.     }
  1343.     $tmp_sect append ")"
  1344.     $sect appendSect $tmp_sect
  1345.     set method_type [$tmp_sect contents]
  1346.     ### quick hack
  1347.     global re_found_ctor
  1348.     if {$with_default && $re_found_ctor} {
  1349.         regen_unset $ctor_nm $method_type
  1350.     }
  1351. }
  1352.  
  1353. proc attrib_init::generate {init init_sect decl_sect body_sect class} {
  1354.     set attrib [$init attrib]
  1355.     if {[$attrib get_obj_type] == "db_data_attrib"} {
  1356.         set class_data [uncap [$class getName]]Data
  1357.         set col [$attrib column]
  1358.         set col_nr [get_column_nr $col]
  1359.         $body_sect append "LET retVal =\
  1360.             $class_data.setVal(COPY [$init getName], $col_nr)\n"
  1361.     } else {
  1362.         $body_sect append \
  1363.             "LET [$attrib getName] = [$init getName]\n"
  1364.     }
  1365. }
  1366.  
  1367. proc assoc_init::generate {init init_sect decl_sect body_sect class} {
  1368.     gen_initializer [$init assoc] $init $decl_sect $body_sect $class
  1369. }
  1370.  
  1371. proc qual_init::generate {init init_sect decl_sect body_sect class} {
  1372.     set qual [$init qualifier]
  1373.     if {[$qual get_obj_type] == "db_qualifier"} {
  1374.         set class_data [uncap [$class getName]]Data
  1375.         set col [$qual column]
  1376.         set col_nr [get_column_nr $col]
  1377.         $body_sect append "LET retVal =\
  1378.             $class_data.setVal(COPY [$init getName], $col_nr)\n"
  1379.     }
  1380.     # non-db qualifier does not need initialization
  1381. }
  1382.  
  1383. proc sc_init::generate {init init_sect decl_sect body_sect class} {
  1384.     set nm_list ""
  1385.     foreach param [$init parameterSet] {
  1386.         lappend nm_list [$param getName]
  1387.     }
  1388.     set superClass [$init ooplClass]
  1389.     if {[$superClass get_obj_type] == "class"} {
  1390.         gen_ctor_sep $init_sect
  1391.         $init_sect append \
  1392.             "[$superClass getName]([join $nm_list ", "])"
  1393.     } else {
  1394.         # Here: [$superClass get_obj_type] == "db_class"
  1395.         expand_text $init_sect {
  1396.             IF init~[cap [$superClass getName]](~[\
  1397.                     join $nm_list ", "]) < 0 THEN
  1398.                 RETURN -1
  1399.             END IF
  1400.         }
  1401.     }
  1402. }
  1403.  
  1404. proc inher_key_init::generate {init init_sect decl_sect body_sect class} {
  1405.     set col [$init key]
  1406.     set name [$col getUniqueName]
  1407.     if {$name == $TYPE_ID_NM} {
  1408.         return
  1409.     }
  1410.     set col_nr [get_column_nr $col]
  1411.     set fcolnr [get_foreign_column_nr $col]
  1412.     set class_nm [[$init ooplClass] getName]
  1413.     set super_data [uncap $class_nm]Data
  1414.     set class_data [uncap [$class getName]]Data
  1415.     $body_sect append "LET retVal = $class_data.setVal(COPY\
  1416.         $super_data.getVal($fcolnr), $col_nr)\n"
  1417. }
  1418.  
  1419.  
  1420. # Generate code to call func for all bases
  1421. #
  1422. proc call_for_all_bases {class sect func} {
  1423.     set supers [$class genNodeSet]
  1424.     if [lempty $supers] {
  1425.         return
  1426.     }
  1427.     $sect append "\n"
  1428.     $sect indent +
  1429.     foreach super $supers {
  1430.         set name [$super getSuperClassName]
  1431.         expand_text $sect {
  1432.             IF ~$name::~${func}() < 0 THEN
  1433.                 RETURN -1
  1434.             END IF
  1435.         }
  1436.     }
  1437.     $sect indent -
  1438. }
  1439.  
  1440. proc get_root_class {class} {
  1441.     set supers [$class genNodeSet]
  1442.     if [lempty $supers] {
  1443.         return $class
  1444.     }
  1445.     return [get_root_class [[lindex $supers 0] superClass]]
  1446. }
  1447.  
  1448. proc rv_link_attrib::generate {attrib class} {
  1449.     # multiplicity should always be 'one' here
  1450.     gen_for_rv_link $attrib $class
  1451. }
  1452.  
  1453. proc rv_link_attrib::one_data {attrib} {
  1454.     set sect $ne_sections(h_pub_data_sect)
  1455.     set type [[$attrib ooplType] getName]
  1456.     set name [reference_name [$attrib getName]]
  1457.     $sect append "PUBLIC VARIABLE $name $type\n"
  1458. }
  1459.  
  1460. proc rv_link_attrib::one_get {attrib class} {
  1461.     set type [[$attrib ooplType] getName]
  1462.     set name [$attrib getName]
  1463.     set cl_name [$class getName]
  1464.     set sect [get_assoc_hdr_sect $attrib r]
  1465.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  1466.     $sect append "${access}FUNCTION get[cap $name]()\
  1467.                 RETURNING $type\n"
  1468.     set sect $ne_sections(c_impl_no_regen_sect)
  1469.     $sect append "FUNCTION $cl_name::get[cap $name]()\
  1470.                 RETURNING $type\n"
  1471.     set ref_name [reference_name $name]
  1472.     $sect indent +
  1473.     $sect append "RETURN $ref_name\n"
  1474.     $sect indent -
  1475.     $sect append "END FUNCTION\n\n"
  1476. }
  1477.  
  1478. proc rv_link_attrib::one_dtor {attrib class} {
  1479.     set opposite [$attrib opposite]
  1480.     if {$opposite != ""} {
  1481.         set ref [reference_name [$attrib getName]]
  1482.         set sect $ne_sections(c_dtor_sect)
  1483.         set decl_sect $ne_sections(c_dtor_decl_sect)
  1484.         rm_other $opposite $sect $ref
  1485.     }
  1486. }
  1487.  
  1488. proc qual_link_attrib::generate {attrib class} {
  1489.     gen_for_link $attrib $class
  1490. }
  1491.  
  1492. proc qual_link_attrib::one_data {attrib} {
  1493.     set sect $ne_sections(h_pub_data_sect)
  1494.     set type [dict_type_name [[$attrib qualifier] ooplType] \
  1495.                  [$attrib ooplType]]
  1496.     set name [uncap [dict_name \
  1497.         "[[$attrib ooplType] getName]Of[cap [$attrib getName]]"]]
  1498.     $sect append "PUBLIC VARIABLE $name $type\n"
  1499.     set sect $ne_sections(c_ctor_body_sect)
  1500.     set key [[$attrib qualifier] ooplType]
  1501.     set value [$attrib ooplType]
  1502.     set result [dict::initializer $name $key $value]
  1503.     if {$result == ""} {
  1504.         return
  1505.     }
  1506.     $sect append $result
  1507. }
  1508.  
  1509. proc qual_link_attrib::one_rm_other {attrib sect ref} {
  1510.     set name [uncap [dict_name \
  1511.         [[$attrib ooplType] getName]Of[cap [$attrib getName]]]]
  1512.     $sect append "CALL $ref.$name.${dict::remove}(\
  1513.                 \{ supply key here \})\n"
  1514. }
  1515.  
  1516. proc qual_link_attrib::one_set_other {attrib decl_sect impl_sect ref} {
  1517.     set name [uncap [dict_name \
  1518.         [[$attrib ooplType] getName]Of[cap [$attrib getName]]]]
  1519.     set qual [[$attrib qualifier] getName]
  1520.     $impl_sect append "CALL $ref.$name.${dict::set}($qual, SELF)\n"
  1521. }
  1522.  
  1523. proc qual_link_attrib::one_get {attrib class} {
  1524.     set type [[$attrib ooplType] getName]
  1525.     set name [cap [[$attrib ooplType] getName]Of[cap [$attrib getName]]]
  1526.     set key [get_qualifier_name $attrib]
  1527.     set q_type [get_qualifier_type $attrib]
  1528.     set cl_name [$class getName]
  1529.     set sect [get_assoc_hdr_sect $attrib r]
  1530.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  1531.     $sect append "${access}FUNCTION get${name}($key $q_type)\
  1532.                 RETURNING $type\n"
  1533.     set sect [get_assoc_src_sect $attrib r]
  1534.     $sect append "FUNCTION $cl_name::get${name}($key $q_type)\
  1535.                 RETURNING $type\n"
  1536.     set dct_name [uncap [dict_name $name]]
  1537.     $sect indent +
  1538.     dict::get_and_return $sect $dct_name $key $type
  1539.     $sect indent -
  1540.     $sect append "END FUNCTION\n\n"
  1541. }
  1542.  
  1543. proc qual_link_attrib::many_data {attrib} {
  1544.     set sect $ne_sections(h_pub_data_sect)
  1545.     set setpfx [set_prefix $attrib]
  1546.     set type [${setpfx}set_dict_type_name \
  1547.         [[$attrib qualifier] ooplType] [$attrib ooplType]]
  1548.     set name [uncap [${setpfx}set_dict_name \
  1549.         [[$attrib ooplType] getName]Of[cap [$attrib getName]]]]
  1550.     $sect append "PUBLIC VARIABLE $name $type\n"
  1551.     set sect $ne_sections(c_ctor_body_sect)
  1552.     set key [[$attrib qualifier] ooplType]
  1553.     set value [$attrib ooplType]
  1554.     set result [${setpfx}rsdict::initializer $name $key $value]
  1555.     if {$result == ""} {
  1556.         return
  1557.     }
  1558.     $sect append $result
  1559. }
  1560.  
  1561. proc qual_link_attrib::many_get {attrib class} {
  1562.     set setpfx [set_prefix $attrib]
  1563.     set type [${setpfx}set_type_name [$attrib ooplType]]
  1564.     set name [cap [[$attrib ooplType] getName]Of[cap [$attrib getName]]]
  1565.     set key [get_qualifier_name $attrib]
  1566.     set q_type [get_qualifier_type $attrib]
  1567.     set cl_name [$class getName]
  1568.     set sect [get_assoc_hdr_sect $attrib r]
  1569.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  1570.     $sect append "${access}FUNCTION get${name}($key $q_type)\
  1571.                 RETURNING $type\n"
  1572.     set sect $ne_sections(c_impl_no_regen_sect)
  1573.     $sect append "FUNCTION $cl_name::get${name}($key $q_type)\
  1574.                 RETURNING $type\n"
  1575.     $sect indent +
  1576.     ${setpfx}rsdict::get_and_return $sect $name $key $type
  1577.     $sect indent -
  1578.     $sect append "END FUNCTION\n\n"
  1579. }
  1580.  
  1581. proc qual_link_attrib::many_set_other {attrib decl_sect impl_sect ref} {
  1582.     set type [[$attrib ooplType] getName]
  1583.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1584.     set qual [[$attrib qualifier] getName]
  1585.     set setpfx [set_prefix $attrib]
  1586.     set s_name [uncap [${setpfx}set_dict_name $name]]
  1587.     set add_func [set ${setpfx}rsdict::add]
  1588.     set retval [set ${setpfx}rsdict::add_retval]
  1589.     set retvar ${add_func}RetVal
  1590.     if {$retval != "VOID"} {
  1591.         set ret_clause "RETURNING $retvar"
  1592.         $decl_sect append "VARIABLE $retvar $retval\n"
  1593.     } else {
  1594.         set ret_clause ""
  1595.     }
  1596.     $impl_sect append "CALL $ref.$s_name.${add_func}($qual, SELF)\
  1597.         $ret_clause\n"
  1598. }
  1599.  
  1600. proc qual_link_attrib::many_rm_other {attrib sect ref} {
  1601.     set type [[$attrib ooplType] getName]
  1602.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1603.     set setpfx [set_prefix $attrib]
  1604.     set s_name [uncap [${setpfx}set_dict_name $name]]
  1605.     set remove_func [set ${setpfx}rsdict::remove]
  1606.     $sect append "CALL $ref.$s_name.${remove_func}(\
  1607.                 \{ supply key here \}, SELF)\n"
  1608. }
  1609.  
  1610. proc link_attrib::generate {attrib class} {
  1611.     gen_for_link $attrib $class
  1612. }
  1613.  
  1614. proc link_attrib::one_data {attrib} {
  1615.     set sect $ne_sections(h_pub_data_sect)
  1616.     set type [[$attrib ooplType] getName]
  1617.     set name [uncap [reference_name "${type}Of[cap [$attrib getName]]"]]
  1618.     $sect append "PUBLIC VARIABLE $name $type\n"
  1619. }
  1620.  
  1621. proc link_attrib::one_get {attrib class} {
  1622.     set type [[$attrib ooplType] getName]
  1623.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1624.     set cl_name [$class getName]
  1625.     set sect [get_assoc_hdr_sect $attrib r]
  1626.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  1627.     $sect append "${access}FUNCTION get${name}() RETURNING $type\n"
  1628.     set sect $ne_sections(c_impl_no_regen_sect)
  1629.     $sect append "FUNCTION $cl_name::get${name}() RETURNING $type\n"
  1630.     set ref_name [uncap [reference_name $name]]
  1631.     $sect indent +
  1632.     $sect append "RETURN $ref_name\n"
  1633.     $sect indent -
  1634.     $sect append "END FUNCTION\n\n"
  1635. }
  1636.  
  1637. proc link_attrib::one_rm_other {attrib sect ref} {
  1638.     set type [[$attrib ooplType] getName]
  1639.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1640.     set ref_name [uncap [reference_name $name]]
  1641.     $sect append "LET $ref.$ref_name = NULL\n"
  1642. }
  1643.  
  1644. proc link_attrib::one_set_other {attrib decl_sect impl_sect ref} {
  1645.     set type [[$attrib ooplType] getName]
  1646.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1647.     set ref_name [uncap [reference_name $name]]
  1648.     $impl_sect append "LET $ref.$ref_name = SELF\n"
  1649. }
  1650.  
  1651. proc link_attrib::many_data {attrib} {
  1652.     set sect $ne_sections(h_pub_data_sect)
  1653.     set setpfx [set_prefix $attrib]
  1654.     set type [${setpfx}set_type_name [$attrib ooplType]]
  1655.     set name [uncap [${setpfx}set_name "[[$attrib ooplType] getName]Of[cap [$attrib getName]]"]]
  1656.     $sect append "PUBLIC VARIABLE $name $type\n"
  1657.     set sect $ne_sections(c_ctor_body_iv_sect)
  1658.     $sect append "LET $name = NEW ${type}()\n"
  1659. }
  1660.  
  1661. proc link_attrib::many_get {attrib class} {
  1662.     set setpfx [set_prefix $attrib]
  1663.     set type [${setpfx}set_type_name [$attrib ooplType]]
  1664.     set name [cap [${setpfx}set_name "[[$attrib ooplType] getName]Of[cap [$attrib getName]]"]]
  1665.     set cl_name [$class getName]
  1666.     set sect [get_assoc_hdr_sect $attrib r]
  1667.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  1668.     $sect append "${access}FUNCTION get${name}() RETURNING $type\n"
  1669.     set sect $ne_sections(c_impl_no_regen_sect)
  1670.     $sect append "FUNCTION $cl_name::get${name}() RETURNING $type\n"
  1671.     $sect indent +
  1672.     $sect append "RETURN [uncap $name]\n"
  1673.     $sect indent -
  1674.     $sect append "END FUNCTION\n\n"
  1675. }
  1676.  
  1677. proc link_attrib::many_set_other {attrib decl_sect impl_sect ref} {
  1678.     set type [[$attrib ooplType] getName]
  1679.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1680.     set setpfx [set_prefix $attrib]
  1681.     set s_name [uncap [${setpfx}set_name $name]]
  1682.     set add_func [set ${setpfx}set::add]
  1683.     set retval [set ${setpfx}set::add_retval]
  1684.     set retvar ${add_func}RetVal
  1685.     if {$retval != "VOID"} {
  1686.         set ret_clause "RETURNING $retvar"
  1687.         $decl_sect append "VARIABLE $retvar $retval\n"
  1688.     } else {
  1689.         set ret_clause ""
  1690.     }
  1691.     $impl_sect append "CALL $ref.$s_name.${add_func}(SELF)\
  1692.         $ret_clause\n"
  1693. }
  1694.  
  1695. proc link_attrib::many_rm_other {attrib sect ref} {
  1696.     set type [[$attrib ooplType] getName]
  1697.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1698.     set setpfx [set_prefix $attrib]
  1699.     set s_name [uncap [${setpfx}set_name $name]]
  1700.     set remove_func [set ${setpfx}set::remove]
  1701.     $sect append "CALL $ref.$s_name.${remove_func}(SELF)\n"
  1702. }
  1703.  
  1704. proc assoc_attrib::gen_initializer {attrib init decl_s body_s class} {
  1705.     set refname [uncap [reference_name [$attrib getName]]]
  1706.     $body_s append "LET $refname = [$attrib getName]\n"
  1707.     set opposite [$attrib opposite]
  1708.     if {$opposite != ""} {
  1709.         set_other $opposite $decl_s $body_s $refname
  1710.     }
  1711. }
  1712.  
  1713. proc rv_link_attrib::gen_initializer {attrib init decl_s body_s class} {
  1714.     set refname [uncap [reference_name [$attrib getName]]]
  1715.     $body_s append "LET $refname = [$init getName]\n"
  1716.     set opposite [$attrib opposite]
  1717.     if {$opposite != ""} {
  1718.         set_other $opposite $decl_s $body_s $refname
  1719.         add_src_inc [$attrib ooplType]
  1720.     }
  1721. }
  1722.  
  1723. # Generate a NewEra parameter declaration
  1724. #
  1725. proc gen_param_decl_ne {section object selector decl {separator ", "}
  1726.                {newline ""}} {
  1727.  
  1728.     set columns [get_col_list $object $selector]
  1729.     if [lempty $columns] {
  1730.         return
  1731.     }
  1732.     set col [lvarpop columns]
  1733.     $section pushIndent
  1734.     set t_par [base_type::generate $col fwd]
  1735.     set t_par_ixval [map_fgl2ixval ${t_par}]
  1736.     if {$decl == "fwd"} {
  1737.         add_forward_name $t_par_ixval
  1738.         add_src_sys_inc_name [ixval2hdr $t_par_ixval]
  1739.     } else {
  1740.         add_hdr_sys_inc_name [ixval2hdr $t_par_ixval]
  1741.     }
  1742.     $section append \
  1743.          "[$col getUniqueName] $t_par_ixval"
  1744.     set newpf $separator$newline
  1745.     foreach col $columns {
  1746.         set t_par [base_type::generate $col fwd]
  1747.         set t_par_ixval [map_fgl2ixval ${t_par}]
  1748.         if {$decl == "fwd"} {
  1749.             add_forward_name $t_par_ixval
  1750.             add_src_sys_inc_name [ixval2hdr $t_par_ixval]
  1751.         } else {
  1752.             add_hdr_sys_inc_name [ixval2hdr $t_par_ixval]
  1753.         }
  1754.         $section append \
  1755.             "$newpf[$col getUniqueName] $t_par_ixval"
  1756.     }
  1757.     $section popIndent
  1758.     $section append $newline
  1759. }
  1760.  
  1761. # Generate a check for the nullability of the columns of a link.  These columns
  1762. # are either ALL null or ALL not null, so it suffices to check only the
  1763. # first column.
  1764. #
  1765. proc gen_null_check {sect link row_name {ret_val 0} {valvar val} } {
  1766.     set col [lindex [$link columnSet] 0]
  1767.     if {$ret_val == ""} {
  1768.         set space ""
  1769.     } else {
  1770.         set space " "
  1771.     }
  1772.     expand_text $sect {
  1773.         LET ~$valvar = ~${row_name}.getVal(~[get_column_nr $col])
  1774.         IF ~$valvar IS NULL THEN
  1775.             RETURN~${space}~$ret_val
  1776.         END IF
  1777.         IF ~$valvar.isNull() THEN
  1778.             RETURN~${space}~$ret_val
  1779.         END IF
  1780.     }
  1781. }
  1782.  
  1783. proc is_db_class {class} {
  1784.     return [string match {db_*} [$class get_obj_type]]
  1785. }
  1786.  
  1787. proc class2tgtfiles {class src inc} {
  1788.     upvar $src src_f
  1789.     upvar $inc inc_f
  1790.  
  1791.     set class_name [class2file [$class getName]]
  1792.     set src_f $class_name.$fourgl_type
  1793.     set inc_f $class_name.$fourgh_type
  1794. }
  1795.  
  1796. proc class2wiftgtfile {class wif} {
  1797.     upvar $wif wif_f
  1798.  
  1799.     set wif_name [class2file [$class getName]]
  1800.     set wif_f $wif_name.$wif_tmpl_type
  1801. }
  1802.  
  1803. # we want    'class_typedef'
  1804. #      or    'class_enum'
  1805. #      or    'class_generic_typedef'
  1806. proc is_special_class {class} {
  1807.     return [string match {*class_*} [$class get_obj_type]]
  1808. }
  1809.  
  1810. #
  1811. #
  1812. proc is_gui_class {class} {
  1813.     if {[$class getPropertyValue "referred_class"] == "" ||
  1814.             [$class getPropertyValue "persistent"] == "1"} {
  1815.         return 0
  1816.     }
  1817.     return 1
  1818. }
  1819.  
  1820. # return set prefix "o" in case ordered sets are needed
  1821. #
  1822. proc set_prefix {attrib} {
  1823.     if [$attrib isOrdered] {
  1824.         return o
  1825.     } else {
  1826.         return
  1827.     }
  1828. }
  1829.