home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / ne_funcs.tcl < prev    next >
Text File  |  1997-10-02  |  55KB  |  1,830 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/titanic/4
  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.         set action "rm_other $opposite $impl_sect"
  810.         dict::get_test_and_act $impl_sect $name $key $type $action
  811.         set_other $opposite $decl_sect $impl_sect new${name}
  812.     }
  813.     set decl_sect [removeDoubleLinesFromSection $decl_sect]
  814.     $sect appendSect $decl_sect
  815.     $sect appendSect $impl_sect
  816.     $sect append "CALL $dct_name.${dict::set}($key, new${name})\n"
  817.     $sect indent -
  818.     $sect append "END FUNCTION\n\n"
  819. }
  820.  
  821. proc qual_assoc_attrib::one_rm_self {attrib class} {
  822.     set type [[$attrib ooplType] getName]
  823.     set name [cap [$attrib getName]]
  824.     set cl_name [$class getName]
  825.     set key [get_qualifier_name $attrib]
  826.     set q_type [get_qualifier_type $attrib]
  827.     set sect [get_assoc_hdr_sect $attrib w]
  828.     set access [get_access_mode [$attrib getPropertyValue assoc_access] w]
  829.     $sect append "${access}FUNCTION remove${name}($key $q_type)\
  830.                 RETURNING VOID\n"
  831.     set sect [get_assoc_src_sect $attrib w]
  832.     $sect append "FUNCTION $cl_name::remove${name}($key $q_type)\
  833.                 RETURNING VOID\n"
  834.     $sect indent +
  835.     set opposite [$attrib opposite]
  836.     set dct_name [uncap [dict_name $name]]
  837.     if {$opposite != ""} {
  838.         set action "rm_other $opposite $sect"
  839.         dict::get_test_and_act $sect $name $key $type $action
  840.     }
  841.     $sect append "CALL $dct_name.${dict::remove}($key)\n"
  842.     $sect indent -
  843.     $sect append "END FUNCTION\n\n"
  844. }
  845.  
  846. proc qual_assoc_attrib::one_set_other {attrib decl_sect impl_sect ref} {
  847.     set name [uncap [dict_name [$attrib getName]]]
  848.     $impl_sect append \
  849.         "CALL $ref.$name.${dict::set}(\{ supply key here \}, SELF)\n"
  850. }
  851.  
  852. proc qual_assoc_attrib::one_rm_other {attrib sect ref} {
  853.     set name [uncap [dict_name [$attrib getName]]]
  854.     $sect append \
  855.         "CALL $ref.$name.${dict::remove}(\{ supply key here \})\n"
  856. }
  857.  
  858. proc qual_assoc_attrib::one_dtor {attrib class} {
  859.     set opposite [$attrib opposite]
  860.     if {$opposite != ""} {
  861.         set sect $ne_sections(c_dtor_sect)
  862.         set decl_sect $ne_sections(c_dtor_decl_sect)
  863.         set type [[$attrib ooplType] getName]
  864.         set qual_type [[[$attrib qualifier] ooplType] getName]
  865.         set name [$attrib getName]
  866.         set action "rm_other $opposite $sect"
  867.         dict::iter $decl_sect $sect $name $type $qual_type $action
  868.     }
  869. }
  870.  
  871. proc qual_assoc_attrib::one_get {attrib class} {
  872.     set type [[$attrib ooplType] getName]
  873.     set name [cap [$attrib getName]]
  874.     set key [get_qualifier_name $attrib]
  875.     set q_type [get_qualifier_type $attrib]
  876.     set cl_name [$class getName]
  877.     set sect [get_assoc_hdr_sect $attrib r]
  878.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  879.     $sect append "${access}FUNCTION get${name}($key $q_type)\
  880.                 RETURNING $type\n"
  881.     set sect $ne_sections(c_impl_no_regen_sect)
  882.     $sect append "FUNCTION $cl_name::get${name}($key $q_type)\
  883.                 RETURNING $type\n"
  884.     set dct_name [uncap [dict_name $name]]
  885.     $sect indent +
  886.     dict::get_and_return $sect $dct_name $key $type
  887.     $sect indent -
  888.     $sect append "END FUNCTION\n\n"
  889. }
  890.  
  891. proc qual_assoc_attrib::many_typedef {attrib class} {
  892.     puts "qual_assoc_attrib::many_typedef CALLED"
  893. }
  894.  
  895. proc qual_assoc_attrib::many_data {attrib} {
  896.     set sect $ne_sections(h_pub_data_sect)
  897.     set setpfx [set_prefix $attrib]
  898.     set type [${setpfx}set_dict_type_name \
  899.         [[$attrib qualifier] ooplType] [$attrib ooplType]]
  900.     set name [uncap [${setpfx}set_dict_name [$attrib getName]]]
  901.     $sect append "PUBLIC VARIABLE $name $type\n"
  902.  
  903.     set sect $ne_sections(c_ctor_body_sect)
  904.     set key [[$attrib qualifier] ooplType]
  905.     set value [$attrib ooplType]
  906.     set result [${setpfx}rsdict::initializer $name $key $value]
  907.     if {$result == ""} {
  908.         return
  909.     }
  910.     $sect append $result
  911. }
  912.  
  913. proc qual_assoc_attrib::many_set_self {attrib class} {
  914.     set type [[$attrib ooplType] getName]
  915.     set name [cap [$attrib getName]]
  916.     set cl_name [$class getName]
  917.     set key [get_qualifier_name $attrib]
  918.     set q_type [get_qualifier_type $attrib]
  919.     set sect [get_assoc_hdr_sect $attrib w]
  920.     set access [get_access_mode [$attrib getPropertyValue assoc_access] w]
  921.     $sect append "${access}FUNCTION add${name}($key $q_type,\
  922.                 new${name} $type) RETURNING VOID\n"
  923.     set sect [get_assoc_src_sect $attrib w]
  924.     $sect append "FUNCTION $cl_name::add${name}($key $q_type,\
  925.                 new${name} $type) RETURNING VOID\n"
  926.     $sect indent +
  927.     set decl_sect [TextSection new]
  928.     set impl_sect [TextSection new]
  929.     $decl_sect indent 0 "\t"
  930.     $impl_sect indent 0 "\t"
  931.     set setpfx [set_prefix $attrib]
  932.     set sdct_name [uncap [${setpfx}set_dict_name [$attrib getName]]]
  933.     set add_func [set ${setpfx}rsdict::add]
  934.     set retval [set ${setpfx}rsdict::add_retval]
  935.     set retvar ${add_func}RetVal
  936.     if {$retval != "VOID"} {
  937.         $decl_sect append "VARIABLE $retvar $retval\n"
  938.         set ret_clause "RETURNING $retvar"
  939.     } else {
  940.         set ret_clause ""
  941.     }
  942.     $impl_sect append "CALL $sdct_name.${add_func}($key,\
  943.         new${name}) $ret_clause\n"
  944.  
  945.     set opposite [$attrib opposite]
  946.     if {$opposite != ""} {
  947.         set_other $opposite $decl_sect $impl_sect new${name}
  948.     }
  949.     set decl_sect [removeDoubleLinesFromSection $decl_sect]
  950.     $sect appendSect $decl_sect
  951.     $sect appendSect $impl_sect
  952.     $sect indent -
  953.     $sect append "END FUNCTION\n\n"
  954. }
  955.  
  956. proc qual_assoc_attrib::many_rm_self {attrib class} {
  957.     set type [[$attrib ooplType] getName]
  958.     set name [cap [$attrib getName]]
  959.     set cl_name [$class getName]
  960.     set key [get_qualifier_name $attrib]
  961.     set q_type [get_qualifier_type $attrib]
  962.     set sect [get_assoc_hdr_sect $attrib w]
  963.     set access [get_access_mode [$attrib getPropertyValue assoc_access] w]
  964.     $sect append "${access}FUNCTION remove${name}($key $q_type,\
  965.                 old${name} $type) RETURNING VOID\n"
  966.     set sect [get_assoc_src_sect $attrib w]
  967.     $sect append "FUNCTION $cl_name::remove${name}($key $q_type,\
  968.                 old${name} $type) RETURNING VOID\n"
  969.     $sect indent +
  970.     set opposite [$attrib opposite]
  971.     if {$opposite != ""} {
  972.         rm_other $opposite $sect old${name}
  973.     }
  974.     set setpfx [set_prefix $attrib]
  975.     set sdct_name [uncap [${setpfx}set_dict_name [$attrib getName]]]
  976.     set remove_func [set ${setpfx}rsdict::remove]
  977.     $sect append \
  978.             "CALL $sdct_name.${remove_func}($key, old${name})\n"
  979.     $sect indent -
  980.     $sect append "END FUNCTION\n\n"
  981. }
  982.  
  983. proc qual_assoc_attrib::many_set_other {attrib decl_sect impl_sect ref} {
  984.     set type [[$attrib ooplType] getName]
  985.         set name [cap [$attrib getName]]
  986.     set setpfx [set_prefix $attrib]
  987.     set sdct_name [uncap [${setpfx}set_dict_name $name]]
  988.     set add_func [set ${setpfx}rsdict::add]
  989.     set retval [set ${setpfx}rsdict::add_retval]
  990.     set retvar ${add_func}RetVal
  991.     if {$retval != "VOID"} {
  992.         set ret_clause "RETURNING $retvar"
  993.         $decl_sect append "VARIABLE $retvar $retval\n"
  994.     } else {
  995.         set ret_clause ""
  996.     }
  997.     $impl_sect append "CALL $ref.$sdct_name.${add_func}(\
  998.             \{ supply key here \}, SELF) $ret_clause\n"
  999. }
  1000.  
  1001. proc qual_assoc_attrib::many_rm_other {attrib sect ref} {
  1002.     set type [[$attrib ooplType] getName]
  1003.     set name [cap [$attrib getName]]
  1004.     set setpfx [set_prefix $attrib]
  1005.     set sdct_name [uncap [${setpfx}set_dict_name $name]]
  1006.     set remove_func [set ${setpfx}rsdict::remove]
  1007.     $sect append "CALL $ref.$sdct_name.${remove_func}(\
  1008.                 \{ supply key here \}, SELF)\n"
  1009. }
  1010.  
  1011. proc qual_assoc_attrib::many_dtor {attrib class} {
  1012.     set opposite [$attrib opposite]
  1013.     if {$opposite != ""} {
  1014.         set sect $ne_sections(c_dtor_sect)
  1015.         set decl_sect $ne_sections(c_dtor_decl_sect)
  1016.         set type [$attrib ooplType]
  1017.         set q_type [string trimright [generate [[$attrib qualifier] \
  1018.                         ooplType] inc]]
  1019.         set name [cap [$attrib getName]]
  1020.         set action "rm_other $opposite $sect"
  1021.         set setpfx [set_prefix $attrib]
  1022.         ${setpfx}rsdict::iter $decl_sect $sect $name $type $q_type $action
  1023.     }
  1024. }
  1025.  
  1026. proc qual_assoc_attrib::many_get {attrib class} {
  1027.     set setpfx [set_prefix $attrib]
  1028.     set type [${setpfx}set_type_name [$attrib ooplType]]
  1029.     set name [cap [$attrib getName]]
  1030.     set key [get_qualifier_name $attrib]
  1031.     set q_type [get_qualifier_type $attrib]
  1032.     set cl_name [$class getName]
  1033.     set sect [get_assoc_hdr_sect $attrib r]
  1034.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  1035.     $sect append "${access}FUNCTION get${name}($key $q_type)\
  1036.                 RETURNING $type\n"
  1037.     set sect $ne_sections(c_impl_no_regen_sect)
  1038.     $sect append "FUNCTION $cl_name::get${name}($key $q_type)\
  1039.                 RETURNING $type\n"
  1040.     set sdct_name [uncap [${setpfx}set_dict_name $name]]
  1041.     $sect indent +
  1042.     ${setpfx}rsdict::get_and_return $sect $name $key $type
  1043.     $sect indent -
  1044.     $sect append "END FUNCTION\n\n"
  1045. }
  1046.  
  1047. proc operation::generate {oper class} {
  1048.     global ne_error_state
  1049.     set name [$oper getName]
  1050.     set is_ctor [expr {$name == "create" && [$oper isClassFeature]== "1"}]
  1051.     if {$is_ctor && [is_db_class $class]} {
  1052.         puts "ERROR: constructor function \$create not allowed in database class '$name'"
  1053.         set ne_error_state 1
  1054.         return
  1055.     }
  1056.     set h_sect [get_hdr_sect [$oper getPropertyValue method_access]]
  1057.     feature::gen_description $oper $h_sect
  1058.     set c_sect $ne_sections(c_impl_sect)
  1059.     set is_abstract [expr {[$oper isAbstract] == "1"}]
  1060.     if $is_ctor {
  1061.         set type ""
  1062.         set name [$class getName]
  1063.     } else {
  1064.         set type [generate [$oper ooplType] fwd]
  1065.     }
  1066.     set method_access [$oper getPropertyValue method_access]
  1067.     if {$is_ctor && $is_abstract && $method_access == "Public"} {
  1068.         set access [access2string "Protected"]
  1069.     } else {
  1070.         set access [get_access_mode $method_access]
  1071.     }
  1072.     set is_shared [expr {[$oper isClassFeature] == "1"} && !$is_ctor]
  1073.     $h_sect append "$access"
  1074.     if $is_shared {
  1075.         $h_sect append "SHARED "
  1076.     }
  1077.     if {[$oper getPropertyValue is_event] == "1"} {
  1078.         $h_sect append "EVENT "
  1079.     } else {
  1080.         $h_sect append "FUNCTION "
  1081.     }
  1082.     $h_sect append "${name}("
  1083.     set first 1
  1084.     foreach param [$oper parameterSet] {
  1085.         set default [$param getPropertyValue default_value]
  1086.         set decl fwd
  1087.         if {$default != ""} {
  1088.             set decl inc
  1089.         }
  1090.         generate $param $h_sect first $decl
  1091.         if {$default != ""} {
  1092.             $h_sect append " : $default"
  1093.         }
  1094.     }
  1095.     $h_sect append ")"
  1096.     if {$type != ""} {
  1097.         $h_sect append " RETURNING $type"
  1098.     }
  1099.     $h_sect append "\n"
  1100.     if {[$oper getPropertyValue is_event] == "1"} {
  1101.         return
  1102.     }
  1103.  
  1104.     set tmp_c_sect [TextSection new]
  1105.     $c_sect append "FUNCTION [$class getName]::${name}"
  1106.     $tmp_c_sect append "("
  1107.     set first 1
  1108.     foreach param [$oper parameterSet] {
  1109.         generate $param $tmp_c_sect first fwd
  1110.     }
  1111.     $tmp_c_sect append ")"
  1112.     set method_type [$tmp_c_sect contents]
  1113.     if {$type != ""} {
  1114.         $tmp_c_sect append " RETURNING $type"
  1115.     }
  1116.  
  1117.     $c_sect appendSect $tmp_c_sect
  1118.  
  1119.     set impl_proc [string trim [$oper getPropertyValue method_impl]]
  1120.     if {$impl_proc == ""} {
  1121.         # get previously prepared body
  1122.         get_method_body $name $method_type $c_sect
  1123.         $c_sect append "END FUNCTION\n\n"
  1124.     } else {
  1125.         set impl_proc operation::$impl_proc
  1126.         if {[info procs $impl_proc] != ""} {
  1127.             $c_sect append "\n"
  1128.             $c_sect indent +
  1129.             $c_sect append [$impl_proc $oper $class $c_sect]
  1130.             $c_sect indent -
  1131.             $c_sect append "END FUNCTION\n\n"
  1132.             regen_unset $name $method_type
  1133.         } else {
  1134.             puts stderr "WARNING: Tcl procedure " nonewline
  1135.             puts stderr "'$impl_proc' not found"
  1136.             # fall back to regeneration
  1137.             get_method_body $name $method_type $c_sect
  1138.             $c_sect append "END FUNCTION\n\n"
  1139.         }
  1140.     }
  1141. }
  1142.  
  1143. proc parameter::generate {param sect f decl {is_db 0} {with_types 1}} {
  1144.     upvar $f first
  1145.  
  1146.     if $first {
  1147.         set first 0
  1148.     } else {
  1149.         $sect append ", "
  1150.     }
  1151.     if !$with_types {
  1152.         $sect append "[$param getName]"
  1153.         return
  1154.     }
  1155.     set type_str [generate [$param ooplType] $decl]
  1156.     if {$is_db && [[$param ooplType] get_obj_type] == "base_type"} {
  1157.         set type_str [map_fgl2ixval $type_str]
  1158.     }
  1159.     $sect append \
  1160.         "[$param getName] $type_str"
  1161. }
  1162.  
  1163. proc base_type::generate {type decl} {
  1164.     set result [$type getType3GL]
  1165.     if [regexp {(VAR)?CHAR\([0-9][0-9]*\)} $result] {
  1166.         regsub {\([0-9][0-9]*\)} $result "\(*\)" result
  1167.     }
  1168.     return $result
  1169. }
  1170.  
  1171. proc base_type::gen_var_decl {type name} {
  1172.     set type [$type getType3GL]
  1173.     return "$name $type"
  1174. }
  1175.  
  1176. proc class_type::generate {type decl}  {
  1177.     set name [$type getName]
  1178.     if {$name == ""} {
  1179.         return "VOID"
  1180.     }
  1181.     if {$decl == "fwd"} {
  1182.         add_forward $type
  1183.         add_src_inc $type
  1184.     } else {
  1185.         add_hdr_inc $type
  1186.     }
  1187.     return $name
  1188. }
  1189.  
  1190. proc class_type::gen_var_decl {type name} {
  1191.     add_forward $type
  1192.     return "$name [$type getName]"
  1193. }
  1194.  
  1195. proc typedef_type::generate {type decl} {
  1196.     return [class_type::generate $type $decl]
  1197. }
  1198.  
  1199. proc typedef_type::gen_var_decl {type name} {
  1200.     return [class_type::gen_var_decl $type $name]
  1201. }
  1202.  
  1203. proc enum_type::generate {type decl} {
  1204.     return [class_type::generate $type $decl]
  1205. }
  1206.  
  1207. proc enum_type::gen_var_decl {type name} {
  1208.     return [class_type::gen_var_decl $type $name]
  1209. }
  1210.  
  1211. proc generic_typedef_type::generate {type decl} {
  1212.     return [class_type::generate $type $decl]
  1213. }
  1214.  
  1215. proc generic_typedef_type::gen_var_decl {type name} {
  1216.     return [class_type::gen_var_decl $type $name]
  1217. }
  1218.  
  1219. proc copy_qualif2string {copy_qualif} {
  1220.     case $copy_qualif in {
  1221.         {Shallow ""} {return ""}
  1222.         {Null} {return "NULL COPY "}
  1223.         {Deep} {return "DEEP COPY "}
  1224.     }
  1225. }
  1226.  
  1227. proc access2string {access} {
  1228.     case $access in {
  1229.         {Public ""} {return "PUBLIC "}
  1230.         {Protected} {return "PROTECTED "}
  1231.         {Private} {return "PRIVATE "}
  1232.     }
  1233. }
  1234.  
  1235. proc get_access_mode {access {mode ""}} {
  1236.     return [access2string [split_access_mode $access $mode]]
  1237. }
  1238.  
  1239. # Determine if all initializers for a class refer to a part of the key
  1240. # This is done by comparing the signature of all keys with that of all
  1241. # creation parameters
  1242. #
  1243. proc all_inits_are_keys {class} {
  1244.     set ctor_list ""
  1245.     foreach ct_param [$class creationParamSet] {
  1246.         lappend ctor_list [[$ct_param ooplType] getType3GL]
  1247.     }
  1248.     set key_list ""
  1249.     foreach key [get_col_list [$class table] KEYS] {
  1250.         if {[$key getUniqueName] != $TYPE_ID_NM} {
  1251.             lappend key_list [$key getType3GL]
  1252.         }
  1253.     }
  1254.     return [expr {$ctor_list == $key_list}]
  1255. }
  1256.  
  1257. # test if a operation signature equals the 
  1258. # database-runtime-constructor
  1259. #
  1260. proc is_eq_db_ctor {oper class} {
  1261.     set is_db [is_db_class $class]
  1262.     # easy tests first
  1263.     if {! $is_db || [$oper getName] != "create"}  {
  1264.         return 0
  1265.     }
  1266.     if {[$oper get_obj_type] == "constructor"} {
  1267.         set params [$class creationParamSet]
  1268.     } else {
  1269.         set params [$oper parameterSet]
  1270.     }
  1271.     set keys [get_col_list [$class table] KEYS]
  1272.     # number of parameters must be equal
  1273.     # correct for extra key
  1274.     set lp [llength $params]
  1275.     incr lp
  1276.     if {$lp != [llength $keys]} {
  1277.         return 0
  1278.     }
  1279.     foreach param $params {
  1280.         set key [lvarpop keys]
  1281.         if {[$key getUniqueName] == $TYPE_ID_NM} {
  1282.             set key [lvarpop keys]
  1283.         }
  1284.         set key_t [string trim [$key getType3GL]]
  1285.         if [regexp {(VAR)?CHAR\([0-9][0-9]*\)} $key_t] {
  1286.             regsub {\([0-9][0-9]*\)} $key_t "\(*\)" key_t
  1287.         }
  1288.         set par_t [string trim [generate [$param ooplType] fwd]]
  1289.         if {$key_t != $par_t} {
  1290.             return 0
  1291.         }
  1292.         # OK, continue
  1293.     }
  1294.     return 1
  1295. }
  1296.  
  1297. proc constructor::generate {ctor class} {
  1298.     global exists_ctor
  1299.     set exists_ctor 1
  1300.     set is_db [is_db_class $class]
  1301.     if $is_db {
  1302.         db_constructor::generate $ctor $class
  1303.         return
  1304.     }
  1305.     set class_nm [$class getName]
  1306.     set ctor_nm $class_nm
  1307.     set sect $ne_sections(h_ctor_sect)
  1308.     $sect append "FUNCTION "
  1309.     set with_default 1
  1310.     gen_ctor_decl $class $sect $ctor_nm $with_default
  1311.     $sect append "\n"
  1312.     set sect $ne_sections(c_ctor_init_sect)
  1313.     $sect append "FUNCTION $class_nm::"
  1314.     set with_default 0
  1315.     gen_ctor_decl $class $sect $ctor_nm $with_default
  1316. #    $sect append "\n"
  1317.     $sect indent +
  1318.     set decl_sect $ne_sections(c_ctor_decl_sect)
  1319.     set body $ne_sections(c_ctor_body_sect)
  1320.     foreach init [$ctor initializerSet] {
  1321.         generate $init $sect $decl_sect $body $class
  1322.     }
  1323. }
  1324.  
  1325. proc gen_ctor_decl {class sect ctor_nm with_default} {
  1326.     $sect append "${ctor_nm}"
  1327.     set tmp_sect [TextSection new]
  1328.     $tmp_sect append "("
  1329.     set first 1
  1330.     foreach param [$class creationParamSet] {
  1331.         set default ""
  1332.         set decl fwd
  1333.         if {$with_default} {
  1334.             set default [$param getPropertyValue default_value]
  1335.             if {$default != ""} { 
  1336.                 set decl inc
  1337.             }
  1338.         }
  1339.         parameter::generate $param $tmp_sect first $decl
  1340.         if {$default != ""} {
  1341.             $tmp_sect append " : $default"
  1342.         }
  1343.     }
  1344.     $tmp_sect append ")"
  1345.     $sect appendSect $tmp_sect
  1346.     set method_type [$tmp_sect contents]
  1347.     ### quick hack
  1348.     global re_found_ctor
  1349.     if {$with_default && $re_found_ctor} {
  1350.         regen_unset $ctor_nm $method_type
  1351.     }
  1352. }
  1353.  
  1354. proc attrib_init::generate {init init_sect decl_sect body_sect class} {
  1355.     set attrib [$init attrib]
  1356.     if {[$attrib get_obj_type] == "db_data_attrib"} {
  1357.         set class_data [uncap [$class getName]]Data
  1358.         set col [$attrib column]
  1359.         set col_nr [get_column_nr $col]
  1360.         $body_sect append "LET retVal =\
  1361.             $class_data.setVal(COPY [$init getName], $col_nr)\n"
  1362.     } else {
  1363.         $body_sect append \
  1364.             "LET [$attrib getName] = [$init getName]\n"
  1365.     }
  1366. }
  1367.  
  1368. proc assoc_init::generate {init init_sect decl_sect body_sect class} {
  1369.     gen_initializer [$init assoc] $init $decl_sect $body_sect $class
  1370. }
  1371.  
  1372. proc qual_init::generate {init init_sect decl_sect body_sect class} {
  1373.     set qual [$init qualifier]
  1374.     if {[$qual get_obj_type] == "db_qualifier"} {
  1375.         set class_data [uncap [$class getName]]Data
  1376.         set col [$qual column]
  1377.         set col_nr [get_column_nr $col]
  1378.         $body_sect append "LET retVal =\
  1379.             $class_data.setVal(COPY [$init getName], $col_nr)\n"
  1380.     }
  1381.     # non-db qualifier does not need initialization
  1382. }
  1383.  
  1384. proc sc_init::generate {init init_sect decl_sect body_sect class} {
  1385.     set nm_list ""
  1386.     foreach param [$init parameterSet] {
  1387.         lappend nm_list [$param getName]
  1388.     }
  1389.     set superClass [$init ooplClass]
  1390.     if {[$superClass get_obj_type] == "class"} {
  1391.         gen_ctor_sep $init_sect
  1392.         $init_sect append \
  1393.             "[$superClass getName]([join $nm_list ", "])"
  1394.     } else {
  1395.         # Here: [$superClass get_obj_type] == "db_class"
  1396.         expand_text $init_sect {
  1397.             IF init~[cap [$superClass getName]](~[\
  1398.                     join $nm_list ", "]) < 0 THEN
  1399.                 RETURN -1
  1400.             END IF
  1401.         }
  1402.     }
  1403. }
  1404.  
  1405. proc inher_key_init::generate {init init_sect decl_sect body_sect class} {
  1406.     set col [$init key]
  1407.     set name [$col getUniqueName]
  1408.     if {$name == $TYPE_ID_NM} {
  1409.         return
  1410.     }
  1411.     set col_nr [get_column_nr $col]
  1412.     set fcolnr [get_foreign_column_nr $col]
  1413.     set class_nm [[$init ooplClass] getName]
  1414.     set super_data [uncap $class_nm]Data
  1415.     set class_data [uncap [$class getName]]Data
  1416.     $body_sect append "LET retVal = $class_data.setVal(COPY\
  1417.         $super_data.getVal($fcolnr), $col_nr)\n"
  1418. }
  1419.  
  1420.  
  1421. # Generate code to call func for all bases
  1422. #
  1423. proc call_for_all_bases {class sect func} {
  1424.     set supers [$class genNodeSet]
  1425.     if [lempty $supers] {
  1426.         return
  1427.     }
  1428.     $sect append "\n"
  1429.     $sect indent +
  1430.     foreach super $supers {
  1431.         set name [$super getSuperClassName]
  1432.         expand_text $sect {
  1433.             IF ~$name::~${func}() < 0 THEN
  1434.                 RETURN -1
  1435.             END IF
  1436.         }
  1437.     }
  1438.     $sect indent -
  1439. }
  1440.  
  1441. proc get_root_class {class} {
  1442.     set supers [$class genNodeSet]
  1443.     if [lempty $supers] {
  1444.         return $class
  1445.     }
  1446.     return [get_root_class [[lindex $supers 0] superClass]]
  1447. }
  1448.  
  1449. proc rv_link_attrib::generate {attrib class} {
  1450.     # multiplicity should always be 'one' here
  1451.     gen_for_rv_link $attrib $class
  1452. }
  1453.  
  1454. proc rv_link_attrib::one_data {attrib} {
  1455.     set sect $ne_sections(h_pub_data_sect)
  1456.     set type [[$attrib ooplType] getName]
  1457.     set name [reference_name [$attrib getName]]
  1458.     $sect append "PUBLIC VARIABLE $name $type\n"
  1459. }
  1460.  
  1461. proc rv_link_attrib::one_get {attrib class} {
  1462.     set type [[$attrib ooplType] getName]
  1463.     set name [$attrib getName]
  1464.     set cl_name [$class getName]
  1465.     set sect [get_assoc_hdr_sect $attrib r]
  1466.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  1467.     $sect append "${access}FUNCTION get[cap $name]()\
  1468.                 RETURNING $type\n"
  1469.     set sect $ne_sections(c_impl_no_regen_sect)
  1470.     $sect append "FUNCTION $cl_name::get[cap $name]()\
  1471.                 RETURNING $type\n"
  1472.     set ref_name [reference_name $name]
  1473.     $sect indent +
  1474.     $sect append "RETURN $ref_name\n"
  1475.     $sect indent -
  1476.     $sect append "END FUNCTION\n\n"
  1477. }
  1478.  
  1479. proc rv_link_attrib::one_dtor {attrib class} {
  1480.     set opposite [$attrib opposite]
  1481.     if {$opposite != ""} {
  1482.         set ref [reference_name [$attrib getName]]
  1483.         set sect $ne_sections(c_dtor_sect)
  1484.         set decl_sect $ne_sections(c_dtor_decl_sect)
  1485.         rm_other $opposite $sect $ref
  1486.     }
  1487. }
  1488.  
  1489. proc qual_link_attrib::generate {attrib class} {
  1490.     gen_for_link $attrib $class
  1491. }
  1492.  
  1493. proc qual_link_attrib::one_data {attrib} {
  1494.     set sect $ne_sections(h_pub_data_sect)
  1495.     set type [dict_type_name [[$attrib qualifier] ooplType] \
  1496.                  [$attrib ooplType]]
  1497.     set name [uncap [dict_name \
  1498.         "[[$attrib ooplType] getName]Of[cap [$attrib getName]]"]]
  1499.     $sect append "PUBLIC VARIABLE $name $type\n"
  1500.     set sect $ne_sections(c_ctor_body_sect)
  1501.     set key [[$attrib qualifier] ooplType]
  1502.     set value [$attrib ooplType]
  1503.     set result [dict::initializer $name $key $value]
  1504.     if {$result == ""} {
  1505.         return
  1506.     }
  1507.     $sect append $result
  1508. }
  1509.  
  1510. proc qual_link_attrib::one_rm_other {attrib sect ref} {
  1511.     set name [uncap [dict_name \
  1512.         [[$attrib ooplType] getName]Of[cap [$attrib getName]]]]
  1513.     $sect append "CALL $ref.$name.${dict::remove}(\
  1514.                 \{ supply key here \})\n"
  1515. }
  1516.  
  1517. proc qual_link_attrib::one_set_other {attrib decl_sect impl_sect ref} {
  1518.     set name [uncap [dict_name \
  1519.         [[$attrib ooplType] getName]Of[cap [$attrib getName]]]]
  1520.     set qual [[$attrib qualifier] getName]
  1521.     $impl_sect append "CALL $ref.$name.${dict::set}($qual, SELF)\n"
  1522. }
  1523.  
  1524. proc qual_link_attrib::one_get {attrib class} {
  1525.     set type [[$attrib ooplType] getName]
  1526.     set name [cap [[$attrib ooplType] getName]Of[cap [$attrib getName]]]
  1527.     set key [get_qualifier_name $attrib]
  1528.     set q_type [get_qualifier_type $attrib]
  1529.     set cl_name [$class getName]
  1530.     set sect [get_assoc_hdr_sect $attrib r]
  1531.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  1532.     $sect append "${access}FUNCTION get${name}($key $q_type)\
  1533.                 RETURNING $type\n"
  1534.     set sect [get_assoc_src_sect $attrib r]
  1535.     $sect append "FUNCTION $cl_name::get${name}($key $q_type)\
  1536.                 RETURNING $type\n"
  1537.     set dct_name [uncap [dict_name $name]]
  1538.     $sect indent +
  1539.     dict::get_and_return $sect $dct_name $key $type
  1540.     $sect indent -
  1541.     $sect append "END FUNCTION\n\n"
  1542. }
  1543.  
  1544. proc qual_link_attrib::many_data {attrib} {
  1545.     set sect $ne_sections(h_pub_data_sect)
  1546.     set setpfx [set_prefix $attrib]
  1547.     set type [${setpfx}set_dict_type_name \
  1548.         [[$attrib qualifier] ooplType] [$attrib ooplType]]
  1549.     set name [uncap [${setpfx}set_dict_name \
  1550.         [[$attrib ooplType] getName]Of[cap [$attrib getName]]]]
  1551.     $sect append "PUBLIC VARIABLE $name $type\n"
  1552.     set sect $ne_sections(c_ctor_body_sect)
  1553.     set key [[$attrib qualifier] ooplType]
  1554.     set value [$attrib ooplType]
  1555.     set result [${setpfx}rsdict::initializer $name $key $value]
  1556.     if {$result == ""} {
  1557.         return
  1558.     }
  1559.     $sect append $result
  1560. }
  1561.  
  1562. proc qual_link_attrib::many_get {attrib class} {
  1563.     set setpfx [set_prefix $attrib]
  1564.     set type [${setpfx}set_type_name [$attrib ooplType]]
  1565.     set name [cap [[$attrib ooplType] getName]Of[cap [$attrib getName]]]
  1566.     set key [get_qualifier_name $attrib]
  1567.     set q_type [get_qualifier_type $attrib]
  1568.     set cl_name [$class getName]
  1569.     set sect [get_assoc_hdr_sect $attrib r]
  1570.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  1571.     $sect append "${access}FUNCTION get${name}($key $q_type)\
  1572.                 RETURNING $type\n"
  1573.     set sect $ne_sections(c_impl_no_regen_sect)
  1574.     $sect append "FUNCTION $cl_name::get${name}($key $q_type)\
  1575.                 RETURNING $type\n"
  1576.     $sect indent +
  1577.     ${setpfx}rsdict::get_and_return $sect $name $key $type
  1578.     $sect indent -
  1579.     $sect append "END FUNCTION\n\n"
  1580. }
  1581.  
  1582. proc qual_link_attrib::many_set_other {attrib decl_sect impl_sect ref} {
  1583.     set type [[$attrib ooplType] getName]
  1584.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1585.     set qual [[$attrib qualifier] getName]
  1586.     set setpfx [set_prefix $attrib]
  1587.     set s_name [uncap [${setpfx}set_dict_name $name]]
  1588.     set add_func [set ${setpfx}rsdict::add]
  1589.     set retval [set ${setpfx}rsdict::add_retval]
  1590.     set retvar ${add_func}RetVal
  1591.     if {$retval != "VOID"} {
  1592.         set ret_clause "RETURNING $retvar"
  1593.         $decl_sect append "VARIABLE $retvar $retval\n"
  1594.     } else {
  1595.         set ret_clause ""
  1596.     }
  1597.     $impl_sect append "CALL $ref.$s_name.${add_func}($qual, SELF)\
  1598.         $ret_clause\n"
  1599. }
  1600.  
  1601. proc qual_link_attrib::many_rm_other {attrib sect ref} {
  1602.     set type [[$attrib ooplType] getName]
  1603.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1604.     set setpfx [set_prefix $attrib]
  1605.     set s_name [uncap [${setpfx}set_dict_name $name]]
  1606.     set remove_func [set ${setpfx}rsdict::remove]
  1607.     $sect append "CALL $ref.$s_name.${remove_func}(\
  1608.                 \{ supply key here \}, SELF)\n"
  1609. }
  1610.  
  1611. proc link_attrib::generate {attrib class} {
  1612.     gen_for_link $attrib $class
  1613. }
  1614.  
  1615. proc link_attrib::one_data {attrib} {
  1616.     set sect $ne_sections(h_pub_data_sect)
  1617.     set type [[$attrib ooplType] getName]
  1618.     set name [uncap [reference_name "${type}Of[cap [$attrib getName]]"]]
  1619.     $sect append "PUBLIC VARIABLE $name $type\n"
  1620. }
  1621.  
  1622. proc link_attrib::one_get {attrib class} {
  1623.     set type [[$attrib ooplType] getName]
  1624.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1625.     set cl_name [$class getName]
  1626.     set sect [get_assoc_hdr_sect $attrib r]
  1627.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  1628.     $sect append "${access}FUNCTION get${name}() RETURNING $type\n"
  1629.     set sect $ne_sections(c_impl_no_regen_sect)
  1630.     $sect append "FUNCTION $cl_name::get${name}() RETURNING $type\n"
  1631.     set ref_name [uncap [reference_name $name]]
  1632.     $sect indent +
  1633.     $sect append "RETURN $ref_name\n"
  1634.     $sect indent -
  1635.     $sect append "END FUNCTION\n\n"
  1636. }
  1637.  
  1638. proc link_attrib::one_rm_other {attrib sect ref} {
  1639.     set type [[$attrib ooplType] getName]
  1640.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1641.     set ref_name [uncap [reference_name $name]]
  1642.     $sect append "LET $ref.$ref_name = NULL\n"
  1643. }
  1644.  
  1645. proc link_attrib::one_set_other {attrib decl_sect impl_sect ref} {
  1646.     set type [[$attrib ooplType] getName]
  1647.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1648.     set ref_name [uncap [reference_name $name]]
  1649.     $impl_sect append "LET $ref.$ref_name = SELF\n"
  1650. }
  1651.  
  1652. proc link_attrib::many_data {attrib} {
  1653.     set sect $ne_sections(h_pub_data_sect)
  1654.     set setpfx [set_prefix $attrib]
  1655.     set type [${setpfx}set_type_name [$attrib ooplType]]
  1656.     set name [uncap [${setpfx}set_name "[[$attrib ooplType] getName]Of[cap [$attrib getName]]"]]
  1657.     $sect append "PUBLIC VARIABLE $name $type\n"
  1658.     set sect $ne_sections(c_ctor_body_iv_sect)
  1659.     $sect append "LET $name = NEW ${type}()\n"
  1660. }
  1661.  
  1662. proc link_attrib::many_get {attrib class} {
  1663.     set setpfx [set_prefix $attrib]
  1664.     set type [${setpfx}set_type_name [$attrib ooplType]]
  1665.     set name [cap [${setpfx}set_name "[[$attrib ooplType] getName]Of[cap [$attrib getName]]"]]
  1666.     set cl_name [$class getName]
  1667.     set sect [get_assoc_hdr_sect $attrib r]
  1668.     set access [get_access_mode [$attrib getPropertyValue assoc_access] r]
  1669.     $sect append "${access}FUNCTION get${name}() RETURNING $type\n"
  1670.     set sect $ne_sections(c_impl_no_regen_sect)
  1671.     $sect append "FUNCTION $cl_name::get${name}() RETURNING $type\n"
  1672.     $sect indent +
  1673.     $sect append "RETURN [uncap $name]\n"
  1674.     $sect indent -
  1675.     $sect append "END FUNCTION\n\n"
  1676. }
  1677.  
  1678. proc link_attrib::many_set_other {attrib decl_sect impl_sect ref} {
  1679.     set type [[$attrib ooplType] getName]
  1680.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1681.     set setpfx [set_prefix $attrib]
  1682.     set s_name [uncap [${setpfx}set_name $name]]
  1683.     set add_func [set ${setpfx}set::add]
  1684.     set retval [set ${setpfx}set::add_retval]
  1685.     set retvar ${add_func}RetVal
  1686.     if {$retval != "VOID"} {
  1687.         set ret_clause "RETURNING $retvar"
  1688.         $decl_sect append "VARIABLE $retvar $retval\n"
  1689.     } else {
  1690.         set ret_clause ""
  1691.     }
  1692.     $impl_sect append "CALL $ref.$s_name.${add_func}(SELF)\
  1693.         $ret_clause\n"
  1694. }
  1695.  
  1696. proc link_attrib::many_rm_other {attrib sect ref} {
  1697.     set type [[$attrib ooplType] getName]
  1698.     set name [cap "${type}Of[cap [$attrib getName]]"]
  1699.     set setpfx [set_prefix $attrib]
  1700.     set s_name [uncap [${setpfx}set_name $name]]
  1701.     set remove_func [set ${setpfx}set::remove]
  1702.     $sect append "CALL $ref.$s_name.${remove_func}(SELF)\n"
  1703. }
  1704.  
  1705. proc assoc_attrib::gen_initializer {attrib init decl_s body_s class} {
  1706.     set refname [uncap [reference_name [$attrib getName]]]
  1707.     $body_s append "LET $refname = [$attrib getName]\n"
  1708.     set opposite [$attrib opposite]
  1709.     if {$opposite != ""} {
  1710.         set_other $opposite $decl_s $body_s $refname
  1711.     }
  1712. }
  1713.  
  1714. proc rv_link_attrib::gen_initializer {attrib init decl_s body_s class} {
  1715.     set refname [uncap [reference_name [$attrib getName]]]
  1716.     $body_s append "LET $refname = [$init getName]\n"
  1717.     set opposite [$attrib opposite]
  1718.     if {$opposite != ""} {
  1719.         set_other $opposite $decl_s $body_s $refname
  1720.         add_src_inc [$attrib ooplType]
  1721.     }
  1722. }
  1723.  
  1724. # Generate a NewEra parameter declaration
  1725. #
  1726. proc gen_param_decl_ne {section object selector decl {separator ", "}
  1727.                {newline ""}} {
  1728.  
  1729.     set columns [get_col_list $object $selector]
  1730.     if [lempty $columns] {
  1731.         return
  1732.     }
  1733.     set col [lvarpop columns]
  1734.     $section pushIndent
  1735.     set t_par [base_type::generate $col fwd]
  1736.     set t_par_ixval [map_fgl2ixval ${t_par}]
  1737.     if {$decl == "fwd"} {
  1738.         add_forward_name $t_par_ixval
  1739.         add_src_sys_inc_name [ixval2hdr $t_par_ixval]
  1740.     } else {
  1741.         add_hdr_sys_inc_name [ixval2hdr $t_par_ixval]
  1742.     }
  1743.     $section append \
  1744.          "[$col getUniqueName] $t_par_ixval"
  1745.     set newpf $separator$newline
  1746.     foreach col $columns {
  1747.         set t_par [base_type::generate $col fwd]
  1748.         set t_par_ixval [map_fgl2ixval ${t_par}]
  1749.         if {$decl == "fwd"} {
  1750.             add_forward_name $t_par_ixval
  1751.             add_src_sys_inc_name [ixval2hdr $t_par_ixval]
  1752.         } else {
  1753.             add_hdr_sys_inc_name [ixval2hdr $t_par_ixval]
  1754.         }
  1755.         $section append \
  1756.             "$newpf[$col getUniqueName] $t_par_ixval"
  1757.     }
  1758.     $section popIndent
  1759.     $section append $newline
  1760. }
  1761.  
  1762. # Generate a check for the nullability of the columns of a link.  These columns
  1763. # are either ALL null or ALL not null, so it suffices to check only the
  1764. # first column.
  1765. #
  1766. proc gen_null_check {sect link row_name {ret_val 0} {valvar val} } {
  1767.     set col [lindex [$link columnSet] 0]
  1768.     if {$ret_val == ""} {
  1769.         set space ""
  1770.     } else {
  1771.         set space " "
  1772.     }
  1773.     expand_text $sect {
  1774.         LET ~$valvar = ~${row_name}.getVal(~[get_column_nr $col])
  1775.         IF ~$valvar IS NULL THEN
  1776.             RETURN~${space}~$ret_val
  1777.         END IF
  1778.         IF ~$valvar.isNull() THEN
  1779.             RETURN~${space}~$ret_val
  1780.         END IF
  1781.     }
  1782. }
  1783.  
  1784. proc is_db_class {class} {
  1785.     return [string match {db_*} [$class get_obj_type]]
  1786. }
  1787.  
  1788. proc class2tgtfiles {class src inc} {
  1789.     upvar $src src_f
  1790.     upvar $inc inc_f
  1791.  
  1792.     set class_name [class2file [$class getName]]
  1793.     set src_f $class_name.$fourgl_type
  1794.     set inc_f $class_name.$fourgh_type
  1795. }
  1796.  
  1797. proc class2wiftgtfile {class wif} {
  1798.     upvar $wif wif_f
  1799.  
  1800.     set wif_name [class2file [$class getName]]
  1801.     set wif_f $wif_name.$wif_tmpl_type
  1802. }
  1803.  
  1804. # we want    'class_typedef'
  1805. #      or    'class_enum'
  1806. #      or    'class_generic_typedef'
  1807. proc is_special_class {class} {
  1808.     return [string match {*class_*} [$class get_obj_type]]
  1809. }
  1810.  
  1811. #
  1812. #
  1813. proc is_gui_class {class} {
  1814.     if {[$class getPropertyValue "referred_class"] == "" ||
  1815.             [$class getPropertyValue "persistent"] == "1"} {
  1816.         return 0
  1817.     }
  1818.     return 1
  1819. }
  1820.  
  1821. # return set prefix "o" in case ordered sets are needed
  1822. #
  1823. proc set_prefix {attrib} {
  1824.     if [$attrib isOrdered] {
  1825.         return o
  1826.     } else {
  1827.         return
  1828.     }
  1829. }
  1830.