home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / ne_class.tcl < prev    next >
Text File  |  1997-02-06  |  16KB  |  641 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_class.tcl    /main/hindenburg/3
  17. #    Original date    : 20-10-1994
  18. #    Description    : Class-level functions for NewEra generation
  19. #
  20. #---------------------------------------------------------------------------
  21. #
  22.  
  23. # Needed for E_FILE_OPEN_WRITE
  24. #
  25. require cgen_msg.tcl
  26.  
  27. global ne_hdr_sections
  28. set ne_hdr_sections {
  29.     h_incl_sect
  30.     h_fwd_decl_sect
  31.     h_help_class_sect
  32.     h_class_nm_sect
  33.     h_const_data_sect
  34.     h_ctor_sect
  35.     h_pub_func_sect
  36.     h_pub_data_sect
  37.     h_prot_func_sect
  38.     h_priv_func_sect
  39.     h_priv_data_sect
  40. }
  41.  
  42. global ne_src_sections
  43. set ne_src_sections {
  44.     c_hdr_sect
  45.     c_incl_sect
  46.     c_static_sect
  47.     c_ctor_init_sect
  48.     c_ctor_init_iv_sect
  49.     c_ctor_decl_sect
  50.     c_ctor_body_sect
  51.     c_ctor_body_iv_sect
  52.     c_dtor_decl_sect
  53.     c_dtor_sect
  54.     c_impl_sect
  55.     c_src_sect
  56.     c_impl_no_regen_sect
  57. }
  58.  
  59. # Global section array
  60. #
  61. global ne_sections
  62.  
  63.  
  64. # Determine the right section based on the accessibility specification and
  65. # whether it is for reading or writing
  66. #
  67. proc get_hdr_sect {access {mode ""}} {
  68.     case [split_access_mode $access $mode] in {
  69.     {Public} {
  70.         return $ne_sections(h_pub_func_sect)
  71.     }
  72.     {Protected} {
  73.         return $ne_sections(h_prot_func_sect)
  74.     }
  75.     {Private} {
  76.         return $ne_sections(h_priv_func_sect)
  77.     }
  78.     {None} {
  79.         return $ne_sections(dev_null_sect)
  80.     }}
  81. }
  82.  
  83. proc get_src_sect {access {mode ""}} {
  84.     if {[split_access_mode $access $mode] == "None"} {
  85.         return $ne_sections(dev_null_sect)
  86.     }
  87.     return $ne_sections(c_impl_no_regen_sect)
  88. }
  89.  
  90. # Split up the access mode and return the right part of it
  91. #
  92. proc split_access_mode {access mode} {
  93.     if {$access == ""} {
  94.         return Public
  95.     }
  96.     set rw_ac_list [split $access -]
  97.     if {[llength $rw_ac_list] == 2} {
  98.         if {$mode == "r"} {
  99.             return [lindex $rw_ac_list 0]
  100.         }
  101.         return [lindex $rw_ac_list 1]
  102.     }
  103.     return $access
  104. }
  105.  
  106. # Determine the section for an assoc accesser function based on
  107. # the attribute "assoc_access"
  108. #
  109. proc get_assoc_hdr_sect {assoc {mode ""}} {
  110.     return [get_hdr_sect [$assoc getPropertyValue assoc_access] $mode]
  111. }
  112.  
  113. proc get_assoc_src_sect {assoc {mode ""}} {
  114.     return [get_src_sect [$assoc getPropertyValue assoc_access] $mode]
  115. }
  116.  
  117. # Determine the section for an attribute accesser function based on
  118. # the attribute "attrib_access"
  119. #
  120. proc get_attrib_hdr_sect {attrib {mode ""}} {
  121.     return [get_hdr_sect [$attrib getPropertyValue attrib_access] $mode]
  122. }
  123.  
  124. proc get_attrib_src_sect {attrib {mode ""}} {
  125.     return [get_src_sect [$attrib getPropertyValue attrib_access] $mode]
  126. }
  127.  
  128. # Create NewEra sections
  129. #
  130. proc create_ne_sections {sects} {
  131.     global ne_sections
  132.     foreach sect $sects {
  133.         set ne_sections($sect) [TextSection new]
  134.         $ne_sections($sect) indent 0 "\t"
  135.     }
  136.     set ne_sections(dev_null_sect) [TextSection new]
  137.     global ctor_init_sep ctor_init_iv_sep exists_ctor db_ctor_is_unique
  138.     set ctor_init_sep 1
  139.     set ctor_init_iv_sep 1
  140.     set exists_ctor 0
  141.     set db_ctor_is_unique 0
  142. }
  143.  
  144. # give sections their initial contents
  145.  
  146. proc init_ne_sections {class} {
  147.     set name [$class getName]
  148.     $ne_sections(h_const_data_sect) indent +
  149.     $ne_sections(h_ctor_sect) indent +
  150.     $ne_sections(h_pub_func_sect) indent +
  151.     $ne_sections(h_pub_func_sect) append "FUNCTION !destroy()\n\n"
  152.     $ne_sections(h_prot_func_sect) append "\n"
  153.     $ne_sections(h_prot_func_sect) indent +
  154.     $ne_sections(h_pub_data_sect) indent +
  155.     $ne_sections(h_priv_func_sect) append "\n"
  156.     $ne_sections(h_priv_func_sect) indent +
  157.     $ne_sections(h_priv_data_sect) indent +
  158.     $ne_sections(c_ctor_decl_sect) indent +
  159.     $ne_sections(c_ctor_decl_sect) append "\n"
  160.     $ne_sections(c_ctor_body_sect) indent +
  161.     $ne_sections(c_ctor_body_iv_sect) indent +
  162.     $ne_sections(c_dtor_decl_sect) append "FUNCTION $name::!destroy()\n"
  163.     regen_unset "!destroy" "()"
  164.     $ne_sections(c_dtor_decl_sect) indent +
  165.     $ne_sections(c_dtor_sect) indent +
  166.     $ne_sections(c_impl_no_regen_sect) append "$REGEN_END\n\n"
  167. }
  168.  
  169. # give sections their terminal contents
  170.  
  171. proc exit_ne_sections {class} {
  172.     if {[$ne_sections(h_incl_sect) contents] != ""} {
  173.         $ne_sections(h_incl_sect) append "\n"
  174.     }
  175.     if {[$ne_sections(h_const_data_sect) contents] != ""} {
  176.         $ne_sections(h_const_data_sect) append "\n"
  177.     }
  178.     $ne_sections(h_priv_data_sect) indent -
  179.     $ne_sections(h_priv_data_sect) append "END CLASS\n\n"
  180.     if {[$ne_sections(c_hdr_sect) contents] != ""} {
  181.         $ne_sections(c_hdr_sect) append "\n"
  182.     }
  183.     set $ne_sections(c_ctor_decl_sect) [removeDoubleLinesFromSection \
  184.         $ne_sections(c_ctor_decl_sect)]
  185.     if {[$ne_sections(c_ctor_decl_sect) contents] != "\n"} {
  186.         $ne_sections(c_ctor_decl_sect) append "\n"
  187.     }
  188.     $ne_sections(c_ctor_body_iv_sect) indent -
  189.     $ne_sections(c_ctor_body_iv_sect) append "END FUNCTION\n\n"
  190.     set $ne_sections(c_dtor_decl_sect) [removeDoubleLinesFromSection \
  191.         $ne_sections(c_dtor_decl_sect)]
  192.     $ne_sections(c_dtor_sect) indent -
  193.     $ne_sections(c_dtor_sect) append "END FUNCTION\n\n"
  194.     if {[$ne_sections(c_static_sect) contents] != ""} {
  195.         $ne_sections(c_static_sect) append "\n"
  196.     }
  197. }
  198.  
  199. # Write the sections to the right file and deallocate them
  200. #
  201. proc write_ne_sections {class hsects csects} {
  202.     class2tgtfiles $class src_file h_file
  203.     set class_name [$class getName]
  204.     do_write_ne_sections $class_name $h_file $hsects 
  205.     do_write_ne_sections $class_name $src_file $csects
  206.     unset ne_sections(dev_null_sect)
  207. }
  208.  
  209. proc do_write_ne_sections {class_name file_name sects} {
  210.     global ne_error_state
  211.     set did_save_file 0
  212.     if {[llength $sects] == 0 || $ne_error_state} {
  213.         return $did_save_file
  214.     }
  215.     set nt $file_name
  216.     global skip_file
  217.     global gen_file
  218.     if {[info exists gen_file($nt)] ||
  219.         ($import_new && ![info exists skip_file($nt)])} {
  220.         set cmp_sect [TextSection new]
  221.         foreach sect $sects {
  222.             set ctor_sect_mtch [string match c_ctor_* $sect]
  223.             if {!$ctor_sect_mtch || $exists_ctor} {
  224.                 $cmp_sect appendSect $ne_sections($sect)
  225.             }
  226.             unset ne_sections($sect)
  227.         }
  228.         if [section_equals_file $cmp_sect $nt] {
  229.             puts "$nt has not changed: file not written"
  230.             return 0
  231.         }
  232.         if {[M4CheckManager::getErrorCount] > 0} {
  233.             puts "Not saving $nt because of previous errors"
  234.             return 0
  235.         }
  236.         puts stdout "Creating $nt"
  237.         if {[catch {set fd [fstorage::open $nt w]} reason]} {
  238.             puts stderr $reason
  239.             m4_error $E_FILE_OPEN_WRITE $nt
  240.         } else {
  241.             if { [catch {fstorage::set_imp_from $nt $class_name} \
  242.                   reason] } {
  243.                 puts stderr $reason
  244.             }
  245.             $cmp_sect write $fd
  246.             fstorage::close $fd
  247.             set did_save_file 1
  248.         }
  249.     }
  250.     return $did_save_file
  251. }
  252.  
  253. proc process_external_class_source {class} {
  254.     set class_name [$class getName]
  255.     set tmp_sect [TextSection new]
  256.     expand_text $tmp_sect [$class getPropertyValue class_source]
  257.     set files [string trim [$tmp_sect contents]]
  258.  
  259.     set first 1
  260.     foreach entry [split $files ,] {
  261.         set entry [string trim $entry]
  262.         # first one is fourgh_type
  263.         # all others are fourgl_type
  264.         if $first {
  265.             set first 0
  266.             set ftype $fourgh_type
  267.         } else {
  268.             set ftype $fourgl_type
  269.         }
  270.         set file_name [class2file $class_name]
  271.         set nt ${file_name}.$ftype
  272.         global skip_file
  273.         global gen_file
  274.         if {[info exists gen_file($nt)] ||
  275.             ($import_new && ![info exists skip_file($nt)])} {
  276.             set fullpath [find_file $entry]
  277.             if {$fullpath == ""} {
  278.                 puts -nonewline "ERROR: class '[$class getName]': "
  279.                 puts "external class source file '$entry' not found"
  280.                 continue
  281.             }
  282.             puts "Importing external '$fullpath'"
  283.             puts "Creating $nt"
  284.             if {[catch {set out [fstorage::open $nt w]} reason]} {
  285.                 puts stderr $reason
  286.                 m4_error $E_FILE_OPEN_WRITE $nt
  287.             } else {
  288.                 set label [[$class smNode] getLabel]
  289.                 set real_name [$class getName]
  290.                 if {![$label isNil]} {
  291.                     set real_name [$label value]
  292.                 }
  293.                 if { [catch {fstorage::set_imp_from $nt \
  294.                     $real_name} reason] } {
  295.                     puts stderr $reason
  296.                 }
  297.                 set max 8092
  298.                 set in [open $fullpath r]
  299.                 while {[set result [read $in $max]] != ""} {
  300.                     puts -nonewline $out $result 
  301.                 }
  302.                 close $in
  303.                 fstorage::close $out
  304.             }
  305.         }
  306.     }
  307. }
  308.  
  309. # find file using global 'exsrc_searchpath'
  310.  
  311. proc find_file {file} {
  312.     if [file exists $file] {
  313.         return $file
  314.     }
  315.     global exsrc_searchpath
  316.     if {! [info exists exsrc_searchpath]} {
  317.         return ""
  318.     }
  319.     set sep [searchPathSeparator]
  320.     foreach dir [split $exsrc_searchpath $sep] {
  321.         set fullpath [path_name concat $dir $file]
  322.         if [file exists $fullpath] {
  323.             return $fullpath
  324.         }
  325.     }
  326.     return ""
  327. }
  328.  
  329. # read status arrays and generate 'only-once' code
  330.  
  331. proc gen_delayed_code {} {
  332.     gen_hdr_incs
  333.     gen_forwards
  334.     gen_src_incs
  335.     gen_sets
  336.     gen_osets
  337.     gen_dicts
  338.     gen_set_dicts
  339.     gen_oset_dicts
  340.  
  341.     global ne_hdr_incs
  342.     catch {unset ne_hdr_incs}
  343.     global ne_hdr_files
  344.     catch {unset ne_hdr_files}
  345. }
  346.  
  347. #
  348. # forward declaration / class header inclusion management functions
  349. #
  350.  
  351. # Global arrays to store the information
  352. #
  353. global ne_forwards
  354. global ne_hdr_incs ne_hdr_incs_name
  355. global ne_src_incs ne_src_incs_name
  356.  
  357. proc add_forward {class} {
  358.     global ne_forwards
  359.     set ne_forwards([$class getName]) $class
  360. }
  361.  
  362. proc add_forward_name {name} {
  363.     global ne_forwards
  364.     set ne_forwards($name) 1
  365. }
  366.  
  367. proc add_hdr_inc {class} {
  368.     global ne_hdr_incs
  369.     set ne_hdr_incs([$class getName]) $class
  370. }
  371.  
  372. proc add_hdr_inc_name {class_name} {
  373.     global ne_hdr_incs_name
  374.     set ne_hdr_incs_name($class_name) 1
  375. }
  376.  
  377. proc add_hdr_sys_inc_name {inc_name} {
  378.     add_hdr_inc_name $inc_name
  379. }
  380.  
  381. proc add_src_inc {class} {
  382.     global ne_src_incs
  383.     set ne_src_incs([$class getName]) $class
  384. }
  385.  
  386. proc add_src_inc_name {class_name} {
  387.     global ne_src_incs_name
  388.     set ne_src_incs_name($class_name) 1
  389. }
  390.  
  391. proc add_src_sys_inc_name {inc_name} {
  392.     add_src_inc_name $inc_name
  393. }
  394.  
  395. # Generate forwards. If the class definition is also included, the forward
  396. # is not generated.
  397. # If the forward name start with "ix", then first map it to the
  398. # corresponding ix include file
  399. proc gen_forwards {} {
  400.     global ne_forwards ne_hdr_files
  401.     if {![info exists ne_forwards]} {
  402.         return
  403.     }
  404.     set sect $ne_sections(h_fwd_decl_sect)
  405.     foreach class [lsort [array names ne_forwards]] {
  406.         if [string match ix* $class] {
  407.             set hdrnm [ixval2hdr $class]
  408.         } else {
  409.             set hdrnm $class
  410.         }
  411.         set hdrfile [h_class2file $hdrnm]
  412.         if [info exists ne_hdr_files($hdrfile)] {
  413.             continue
  414.         }
  415.         $sect append "FORWARD $class\n"
  416.     }
  417.     unset ne_forwards
  418. }
  419.  
  420. proc gen_hdr_incs {} {
  421.     global ne_hdr_incs ne_hdr_incs_name ne_hdr_files
  422.     set gen_include_list ""
  423.     set user_include_list ""
  424.     if [info exists ne_hdr_incs] {
  425.         foreach class [array names ne_hdr_incs] {
  426.             set hdl $ne_hdr_incs($class)
  427.             set incls [$hdl getPropertyValue include_list]
  428.             if {$incls == ""} {
  429.                 lappend gen_include_list [$hdl getName]
  430.                 set ne_hdr_files([h_class2file $class]) 1
  431.             } else {
  432.                 foreach incl [split $incls ,] {
  433.                     lappend user_include_list $incl
  434.                     set ne_hdr_files($incl) 1
  435.                 }
  436.             }
  437.         }
  438.     }
  439.     if [info exists ne_hdr_incs_name] {
  440.         foreach entry [array names ne_hdr_incs_name] {
  441.             set file [h_class2file $entry]
  442.             if [info exists ne_hdr_files($file)] {
  443.                 continue
  444.             }
  445.             lappend gen_include_list $entry
  446.             set ne_hdr_files($file) 1
  447.         }
  448.     }
  449.     foreach entry [lsort $gen_include_list] {
  450.         # prefer user includes 
  451.         set idx [lsearch -exact user_include_list [h_class2file $entry]]
  452.         if {$idx == -1} {
  453.             gen_include $entry $ne_sections(h_incl_sect)
  454.         }
  455.     }
  456.     # do not sort ! remove duplicates
  457.     foreach entry $user_include_list {
  458.         if [info exists dup($entry)] {
  459.             continue;
  460.         }
  461.         set dup($entry) 1
  462.         gen_include_filename $entry $ne_sections(h_incl_sect)
  463.     }
  464.     catch {unset ne_hdr_incs_name}
  465. }
  466.  
  467. # Generate includes for source file. Don't generate if the file is already
  468. # included in the header file.
  469. #
  470. proc gen_src_incs {} {
  471.     if {! [info exists ne_sections(c_hdr_sect)]} {
  472.         return
  473.     }
  474.     global ne_src_incs ne_src_incs_name ne_hdr_files
  475.     set gen_include_list ""
  476.     set user_include_list ""
  477.     if [info exists ne_src_incs] {
  478.         foreach class [array names ne_src_incs] {
  479.             if [info exists ne_hdr_incs($class)] {
  480.                 continue
  481.             }
  482.             set hdl $ne_src_incs($class)
  483.             set incls [$hdl getPropertyValue include_list]
  484.             if {$incls == ""} {
  485.                 lappend gen_include_list [$hdl getName]
  486.                 set src_files([h_class2file $class]) 1
  487.             } else {
  488.                 foreach incl [split $incls ,] {
  489.                     if [info exists ne_hdr_files($incl)] {
  490.                         continue
  491.                     }
  492.                     lappend user_include_list $incl
  493.                     set src_files($incl) 1
  494.                 }
  495.             }
  496.         }
  497.     }
  498.     if [info exists ne_src_incs_name] {
  499.         foreach entry [array names ne_src_incs_name] {
  500.             set file [h_class2file $entry]
  501.             if [info exists ne_hdr_files($file)] {
  502.                 continue
  503.             }
  504.             if [info exists src_files($file)] {
  505.                 continue
  506.             }
  507.             lappend gen_include_list $entry
  508.         }
  509.     }
  510.     foreach entry [lsort $gen_include_list] {
  511.         # prefer user includes
  512.         set idx [lsearch -exact user_include_list [h_class2file $entry]]
  513.         if {$idx == -1} {
  514.             gen_include $entry $ne_sections(c_hdr_sect)
  515.         }
  516.     }
  517.     # do not sort ! remove duplicates
  518.     foreach entry $user_include_list {
  519.         if [info exists dup($entry)] {
  520.             continue;
  521.         }
  522.         set dup($entry) 1
  523.         gen_include_filename $entry $ne_sections(c_hdr_sect)
  524.     }
  525.     catch {unset ne_src_incs}
  526.     catch {unset ne_src_incs_name}
  527.     catch {unset src_files}
  528. }
  529.  
  530.  
  531. # Sets to be instantiated
  532. #
  533. global ne_sets
  534.  
  535. proc instantiate_set {class} {
  536.     global ne_sets
  537.     set ne_sets($class) 1
  538. }
  539.  
  540. proc gen_sets {} {
  541.     global ne_sets
  542.     if {![info exists ne_sets]} {
  543.         return
  544.     }
  545. #    set sect $cpp_sections(h_incl_sect)
  546. #    foreach class [lsort [array names cpp_sets]] {
  547. #        gen_set_type_def $class $sect
  548. #    }
  549.     unset ne_sets
  550. }
  551.  
  552. # Ordered Sets to be instantiated
  553. #
  554. global ne_osets
  555.  
  556. proc instantiate_oset {class} {
  557.     global ne_osets
  558.     set ne_osets($class) 1
  559. }
  560.  
  561. proc gen_osets {} {
  562.     global ne_osets
  563.     if {![info exists ne_osets]} {
  564.         return
  565.     }
  566. #    set sect $cpp_sections(h_incl_sect)
  567. #    foreach class [lsort [array names cpp_osets]] {
  568. #        gen_oset_type_def $class $sect
  569. #    }
  570.     unset ne_osets
  571. }
  572.  
  573. # Dicts to be instantiated
  574. #
  575. global ne_dicts
  576.  
  577. proc instantiate_dict {key value} {
  578.     global ne_dicts
  579.     set ne_dicts($key,$value) 1
  580. }
  581.  
  582. proc gen_dicts {} {
  583.     global ne_dicts
  584.     if {![info exists ne_dicts]} {
  585.         return
  586.     }
  587. #    set sect $cpp_sections(h_incl_sect)
  588. #    foreach keyval [lsort [array names cpp_dicts]] {
  589. #        set kv_list [split $keyval ,]
  590. #        gen_dict_type_def [lindex $kv_list 0] [lindex $kv_list 1] $sect
  591. #    }
  592.     unset ne_dicts
  593. }
  594.  
  595. # Set Dicts to be instantiated
  596. #
  597. global ne_set_dicts
  598.  
  599. proc instantiate_set_dict {key value} {
  600.     global ne_set_dicts
  601.     set ne_set_dicts($key,$value) 1
  602. }
  603.  
  604. proc gen_set_dicts {} {
  605.     global ne_set_dicts
  606.     if {![info exists ne_set_dicts]} {
  607.         return
  608.     }
  609. #    set sect $cpp_sections(h_incl_sect)
  610. #    foreach keyval [lsort [array names cpp_set_dicts]] {
  611. #        set kv_list [split $keyval ,]
  612. #        gen_set_dict_type_def [lindex $kv_list 0] \
  613. #                [lindex $kv_list 1] $sect
  614. #    }
  615.     unset ne_set_dicts
  616. }
  617.  
  618. # Ordered Set Dicts to be instantiated
  619. #
  620. global ne_oset_dicts
  621.  
  622. proc instantiate_oset_dict {key value} {
  623.     global ne_oset_dicts
  624.     set ne_oset_dicts($key,$value) 1
  625. }
  626.  
  627. proc gen_oset_dicts {} {
  628.     global ne_oset_dicts
  629.     if {![info exists ne_oset_dicts]} {
  630.         return
  631.     }
  632. #    set sect $cpp_sections(h_incl_sect)
  633. #    foreach keyval [lsort [array names cpp_oset_dicts]] {
  634. #        set kv_list [split $keyval ,]
  635. #        gen_oset_dict_type_def [lindex $kv_list 0] \
  636. #                [lindex $kv_list 1] $sect
  637. #    }
  638.     unset ne_oset_dicts
  639. }
  640.  
  641.