home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / ne_class.tcl < prev    next >
Text File  |  1997-06-06  |  16KB  |  648 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/titanic/4
  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.     class2tgtfiles $class srcFile hdrFile
  149.  
  150.     expandHeaderIntoSection $hdrFile $fourgh_type $ne_sections(h_incl_sect)
  151.     $ne_sections(h_incl_sect) append "\n"
  152.     $ne_sections(h_const_data_sect) indent +
  153.     $ne_sections(h_ctor_sect) indent +
  154.     $ne_sections(h_pub_func_sect) indent +
  155.     $ne_sections(h_pub_func_sect) append "FUNCTION !destroy()\n\n"
  156.     $ne_sections(h_prot_func_sect) append "\n"
  157.     $ne_sections(h_prot_func_sect) indent +
  158.     $ne_sections(h_pub_data_sect) indent +
  159.     $ne_sections(h_priv_func_sect) append "\n"
  160.     $ne_sections(h_priv_func_sect) indent +
  161.     $ne_sections(h_priv_data_sect) indent +
  162.  
  163.     expandHeaderIntoSection $srcFile $fourgl_type $ne_sections(c_hdr_sect)
  164.     $ne_sections(c_hdr_sect) append "\n"
  165.     $ne_sections(c_ctor_decl_sect) indent +
  166.     $ne_sections(c_ctor_decl_sect) append "\n"
  167.     $ne_sections(c_ctor_body_sect) indent +
  168.     $ne_sections(c_ctor_body_iv_sect) indent +
  169.     $ne_sections(c_dtor_decl_sect) append "FUNCTION $name::!destroy()\n"
  170.     regen_unset "!destroy" "()"
  171.     $ne_sections(c_dtor_decl_sect) indent +
  172.     $ne_sections(c_dtor_sect) indent +
  173.     $ne_sections(c_impl_no_regen_sect) append "$REGEN_END\n\n"
  174. }
  175.  
  176. # give sections their terminal contents
  177.  
  178. proc exit_ne_sections {class} {
  179.     if {[$ne_sections(h_incl_sect) contents] != ""} {
  180.         $ne_sections(h_incl_sect) append "\n"
  181.     }
  182.     if {[$ne_sections(h_const_data_sect) contents] != ""} {
  183.         $ne_sections(h_const_data_sect) append "\n"
  184.     }
  185.     $ne_sections(h_priv_data_sect) indent -
  186.     $ne_sections(h_priv_data_sect) append "END CLASS\n\n"
  187.     if {[$ne_sections(c_hdr_sect) contents] != ""} {
  188.         $ne_sections(c_hdr_sect) append "\n"
  189.     }
  190.     set $ne_sections(c_ctor_decl_sect) [removeDoubleLinesFromSection \
  191.         $ne_sections(c_ctor_decl_sect)]
  192.     if {[$ne_sections(c_ctor_decl_sect) contents] != "\n"} {
  193.         $ne_sections(c_ctor_decl_sect) append "\n"
  194.     }
  195.     $ne_sections(c_ctor_body_iv_sect) indent -
  196.     $ne_sections(c_ctor_body_iv_sect) append "END FUNCTION\n\n"
  197.     set $ne_sections(c_dtor_decl_sect) [removeDoubleLinesFromSection \
  198.         $ne_sections(c_dtor_decl_sect)]
  199.     $ne_sections(c_dtor_sect) indent -
  200.     $ne_sections(c_dtor_sect) append "END FUNCTION\n\n"
  201.     if {[$ne_sections(c_static_sect) contents] != ""} {
  202.         $ne_sections(c_static_sect) append "\n"
  203.     }
  204. }
  205.  
  206. # Write the sections to the right file and deallocate them
  207. #
  208. proc write_ne_sections {class hsects csects} {
  209.     class2tgtfiles $class src_file h_file
  210.     set class_name [$class getName]
  211.     do_write_ne_sections $class_name $h_file $hsects 
  212.     do_write_ne_sections $class_name $src_file $csects
  213.     unset ne_sections(dev_null_sect)
  214. }
  215.  
  216. proc do_write_ne_sections {class_name file_name sects} {
  217.     global ne_error_state
  218.     set did_save_file 0
  219.     if {[llength $sects] == 0 || $ne_error_state} {
  220.         return $did_save_file
  221.     }
  222.     set nt $file_name
  223.     global skip_file
  224.     global gen_file
  225.     if {[info exists gen_file($nt)] ||
  226.         ($import_new && ![info exists skip_file($nt)])} {
  227.         set cmp_sect [TextSection new]
  228.         foreach sect $sects {
  229.             set ctor_sect_mtch [string match c_ctor_* $sect]
  230.             if {!$ctor_sect_mtch || $exists_ctor} {
  231.                 $cmp_sect appendSect $ne_sections($sect)
  232.             }
  233.             unset ne_sections($sect)
  234.         }
  235.         if [section_equals_file $cmp_sect $nt] {
  236.             puts "$nt has not changed: file not written"
  237.             return 0
  238.         }
  239.         if {[M4CheckManager::getErrorCount] > 0} {
  240.             puts "Not saving $nt because of previous errors"
  241.             return 0
  242.         }
  243.         puts stdout "Creating $nt"
  244.         if {[catch {set fd [fstorage::open $nt w]} reason]} {
  245.             puts stderr $reason
  246.             m4_error $E_FILE_OPEN_WRITE $nt
  247.         } else {
  248.             if { [catch {fstorage::set_imp_from $nt $class_name} \
  249.                   reason] } {
  250.                 puts stderr $reason
  251.             }
  252.             $cmp_sect write $fd
  253.             fstorage::close $fd
  254.             set did_save_file 1
  255.         }
  256.     }
  257.     return $did_save_file
  258. }
  259.  
  260. proc process_external_class_source {class} {
  261.     set class_name [$class getName]
  262.     set tmp_sect [TextSection new]
  263.     expand_text $tmp_sect [$class getPropertyValue class_source]
  264.     set files [string trim [$tmp_sect contents]]
  265.  
  266.     set first 1
  267.     foreach entry [split $files ,] {
  268.         set entry [string trim $entry]
  269.         # first one is fourgh_type
  270.         # all others are fourgl_type
  271.         if $first {
  272.             set first 0
  273.             set ftype $fourgh_type
  274.         } else {
  275.             set ftype $fourgl_type
  276.         }
  277.         set file_name [class2file $class_name]
  278.         set nt ${file_name}.$ftype
  279.         global skip_file
  280.         global gen_file
  281.         if {[info exists gen_file($nt)] ||
  282.             ($import_new && ![info exists skip_file($nt)])} {
  283.             set fullpath [find_file $entry]
  284.             if {$fullpath == ""} {
  285.                 puts -nonewline "ERROR: class '[$class getName]': "
  286.                 puts "external class source file '$entry' not found"
  287.                 continue
  288.             }
  289.             puts "Importing external '$fullpath'"
  290.             puts "Creating $nt"
  291.             if {[catch {set out [fstorage::open $nt w]} reason]} {
  292.                 puts stderr $reason
  293.                 m4_error $E_FILE_OPEN_WRITE $nt
  294.             } else {
  295.                 set label [[$class smNode] getLabel]
  296.                 set real_name [$class getName]
  297.                 if {![$label isNil]} {
  298.                     set real_name [$label value]
  299.                 }
  300.                 if { [catch {fstorage::set_imp_from $nt \
  301.                     $real_name} reason] } {
  302.                     puts stderr $reason
  303.                 }
  304.                 set max 8092
  305.                 set in [open $fullpath r]
  306.                 while {[set result [read $in $max]] != ""} {
  307.                     puts -nonewline $out $result 
  308.                 }
  309.                 close $in
  310.                 fstorage::close $out
  311.             }
  312.         }
  313.     }
  314. }
  315.  
  316. # find file using global 'exsrc_searchpath'
  317.  
  318. proc find_file {file} {
  319.     if [file exists $file] {
  320.         return $file
  321.     }
  322.     global exsrc_searchpath
  323.     if {! [info exists exsrc_searchpath]} {
  324.         return ""
  325.     }
  326.     set sep [searchPathSeparator]
  327.     foreach dir [split $exsrc_searchpath $sep] {
  328.         set fullpath [path_name concat $dir $file]
  329.         if [file exists $fullpath] {
  330.             return $fullpath
  331.         }
  332.     }
  333.     return ""
  334. }
  335.  
  336. # read status arrays and generate 'only-once' code
  337.  
  338. proc gen_delayed_code {} {
  339.     gen_hdr_incs
  340.     gen_forwards
  341.     gen_src_incs
  342.     gen_sets
  343.     gen_osets
  344.     gen_dicts
  345.     gen_set_dicts
  346.     gen_oset_dicts
  347.  
  348.     global ne_hdr_incs
  349.     catch {unset ne_hdr_incs}
  350.     global ne_hdr_files
  351.     catch {unset ne_hdr_files}
  352. }
  353.  
  354. #
  355. # forward declaration / class header inclusion management functions
  356. #
  357.  
  358. # Global arrays to store the information
  359. #
  360. global ne_forwards
  361. global ne_hdr_incs ne_hdr_incs_name
  362. global ne_src_incs ne_src_incs_name
  363.  
  364. proc add_forward {class} {
  365.     global ne_forwards
  366.     set ne_forwards([$class getName]) $class
  367. }
  368.  
  369. proc add_forward_name {name} {
  370.     global ne_forwards
  371.     set ne_forwards($name) 1
  372. }
  373.  
  374. proc add_hdr_inc {class} {
  375.     global ne_hdr_incs
  376.     set ne_hdr_incs([$class getName]) $class
  377. }
  378.  
  379. proc add_hdr_inc_name {class_name} {
  380.     global ne_hdr_incs_name
  381.     set ne_hdr_incs_name($class_name) 1
  382. }
  383.  
  384. proc add_hdr_sys_inc_name {inc_name} {
  385.     add_hdr_inc_name $inc_name
  386. }
  387.  
  388. proc add_src_inc {class} {
  389.     global ne_src_incs
  390.     set ne_src_incs([$class getName]) $class
  391. }
  392.  
  393. proc add_src_inc_name {class_name} {
  394.     global ne_src_incs_name
  395.     set ne_src_incs_name($class_name) 1
  396. }
  397.  
  398. proc add_src_sys_inc_name {inc_name} {
  399.     add_src_inc_name $inc_name
  400. }
  401.  
  402. # Generate forwards. If the class definition is also included, the forward
  403. # is not generated.
  404. # If the forward name start with "ix", then first map it to the
  405. # corresponding ix include file
  406. proc gen_forwards {} {
  407.     global ne_forwards ne_hdr_files
  408.     if {![info exists ne_forwards]} {
  409.         return
  410.     }
  411.     set sect $ne_sections(h_fwd_decl_sect)
  412.     foreach class [lsort [array names ne_forwards]] {
  413.         if [string match ix* $class] {
  414.             set hdrnm [ixval2hdr $class]
  415.         } else {
  416.             set hdrnm $class
  417.         }
  418.         set hdrfile [h_class2file $hdrnm]
  419.         if [info exists ne_hdr_files($hdrfile)] {
  420.             continue
  421.         }
  422.         $sect append "FORWARD $class\n"
  423.     }
  424.     unset ne_forwards
  425. }
  426.  
  427. proc gen_hdr_incs {} {
  428.     global ne_hdr_incs ne_hdr_incs_name ne_hdr_files
  429.     set gen_include_list ""
  430.     set user_include_list ""
  431.     if [info exists ne_hdr_incs] {
  432.         foreach class [array names ne_hdr_incs] {
  433.             set hdl $ne_hdr_incs($class)
  434.             set incls [$hdl getPropertyValue include_list]
  435.             if {$incls == ""} {
  436.                 lappend gen_include_list [$hdl getName]
  437.                 set ne_hdr_files([h_class2file $class]) 1
  438.             } else {
  439.                 foreach incl [split $incls ,] {
  440.                     lappend user_include_list $incl
  441.                     set ne_hdr_files($incl) 1
  442.                 }
  443.             }
  444.         }
  445.     }
  446.     if [info exists ne_hdr_incs_name] {
  447.         foreach entry [array names ne_hdr_incs_name] {
  448.             set file [h_class2file $entry]
  449.             if [info exists ne_hdr_files($file)] {
  450.                 continue
  451.             }
  452.             lappend gen_include_list $entry
  453.             set ne_hdr_files($file) 1
  454.         }
  455.     }
  456.     foreach entry [lsort $gen_include_list] {
  457.         # prefer user includes 
  458.         set idx [lsearch -exact user_include_list [h_class2file $entry]]
  459.         if {$idx == -1} {
  460.             gen_include $entry $ne_sections(h_incl_sect)
  461.         }
  462.     }
  463.     # do not sort ! remove duplicates
  464.     foreach entry $user_include_list {
  465.         if [info exists dup($entry)] {
  466.             continue;
  467.         }
  468.         set dup($entry) 1
  469.         gen_include_filename $entry $ne_sections(h_incl_sect)
  470.     }
  471.     catch {unset ne_hdr_incs_name}
  472. }
  473.  
  474. # Generate includes for source file. Don't generate if the file is already
  475. # included in the header file.
  476. #
  477. proc gen_src_incs {} {
  478.     if {! [info exists ne_sections(c_hdr_sect)]} {
  479.         return
  480.     }
  481.     global ne_src_incs ne_src_incs_name ne_hdr_files
  482.     set gen_include_list ""
  483.     set user_include_list ""
  484.     if [info exists ne_src_incs] {
  485.         foreach class [array names ne_src_incs] {
  486.             if [info exists ne_hdr_incs($class)] {
  487.                 continue
  488.             }
  489.             set hdl $ne_src_incs($class)
  490.             set incls [$hdl getPropertyValue include_list]
  491.             if {$incls == ""} {
  492.                 lappend gen_include_list [$hdl getName]
  493.                 set src_files([h_class2file $class]) 1
  494.             } else {
  495.                 foreach incl [split $incls ,] {
  496.                     if [info exists ne_hdr_files($incl)] {
  497.                         continue
  498.                     }
  499.                     lappend user_include_list $incl
  500.                     set src_files($incl) 1
  501.                 }
  502.             }
  503.         }
  504.     }
  505.     if [info exists ne_src_incs_name] {
  506.         foreach entry [array names ne_src_incs_name] {
  507.             set file [h_class2file $entry]
  508.             if [info exists ne_hdr_files($file)] {
  509.                 continue
  510.             }
  511.             if [info exists src_files($file)] {
  512.                 continue
  513.             }
  514.             lappend gen_include_list $entry
  515.         }
  516.     }
  517.     foreach entry [lsort $gen_include_list] {
  518.         # prefer user includes
  519.         set idx [lsearch -exact user_include_list [h_class2file $entry]]
  520.         if {$idx == -1} {
  521.             gen_include $entry $ne_sections(c_hdr_sect)
  522.         }
  523.     }
  524.     # do not sort ! remove duplicates
  525.     foreach entry $user_include_list {
  526.         if [info exists dup($entry)] {
  527.             continue;
  528.         }
  529.         set dup($entry) 1
  530.         gen_include_filename $entry $ne_sections(c_hdr_sect)
  531.     }
  532.     catch {unset ne_src_incs}
  533.     catch {unset ne_src_incs_name}
  534.     catch {unset src_files}
  535. }
  536.  
  537.  
  538. # Sets to be instantiated
  539. #
  540. global ne_sets
  541.  
  542. proc instantiate_set {class} {
  543.     global ne_sets
  544.     set ne_sets($class) 1
  545. }
  546.  
  547. proc gen_sets {} {
  548.     global ne_sets
  549.     if {![info exists ne_sets]} {
  550.         return
  551.     }
  552. #    set sect $cpp_sections(h_incl_sect)
  553. #    foreach class [lsort [array names cpp_sets]] {
  554. #        gen_set_type_def $class $sect
  555. #    }
  556.     unset ne_sets
  557. }
  558.  
  559. # Ordered Sets to be instantiated
  560. #
  561. global ne_osets
  562.  
  563. proc instantiate_oset {class} {
  564.     global ne_osets
  565.     set ne_osets($class) 1
  566. }
  567.  
  568. proc gen_osets {} {
  569.     global ne_osets
  570.     if {![info exists ne_osets]} {
  571.         return
  572.     }
  573. #    set sect $cpp_sections(h_incl_sect)
  574. #    foreach class [lsort [array names cpp_osets]] {
  575. #        gen_oset_type_def $class $sect
  576. #    }
  577.     unset ne_osets
  578. }
  579.  
  580. # Dicts to be instantiated
  581. #
  582. global ne_dicts
  583.  
  584. proc instantiate_dict {key value} {
  585.     global ne_dicts
  586.     set ne_dicts($key,$value) 1
  587. }
  588.  
  589. proc gen_dicts {} {
  590.     global ne_dicts
  591.     if {![info exists ne_dicts]} {
  592.         return
  593.     }
  594. #    set sect $cpp_sections(h_incl_sect)
  595. #    foreach keyval [lsort [array names cpp_dicts]] {
  596. #        set kv_list [split $keyval ,]
  597. #        gen_dict_type_def [lindex $kv_list 0] [lindex $kv_list 1] $sect
  598. #    }
  599.     unset ne_dicts
  600. }
  601.  
  602. # Set Dicts to be instantiated
  603. #
  604. global ne_set_dicts
  605.  
  606. proc instantiate_set_dict {key value} {
  607.     global ne_set_dicts
  608.     set ne_set_dicts($key,$value) 1
  609. }
  610.  
  611. proc gen_set_dicts {} {
  612.     global ne_set_dicts
  613.     if {![info exists ne_set_dicts]} {
  614.         return
  615.     }
  616. #    set sect $cpp_sections(h_incl_sect)
  617. #    foreach keyval [lsort [array names cpp_set_dicts]] {
  618. #        set kv_list [split $keyval ,]
  619. #        gen_set_dict_type_def [lindex $kv_list 0] \
  620. #                [lindex $kv_list 1] $sect
  621. #    }
  622.     unset ne_set_dicts
  623. }
  624.  
  625. # Ordered Set Dicts to be instantiated
  626. #
  627. global ne_oset_dicts
  628.  
  629. proc instantiate_oset_dict {key value} {
  630.     global ne_oset_dicts
  631.     set ne_oset_dicts($key,$value) 1
  632. }
  633.  
  634. proc gen_oset_dicts {} {
  635.     global ne_oset_dicts
  636.     if {![info exists ne_oset_dicts]} {
  637.         return
  638.     }
  639. #    set sect $cpp_sections(h_incl_sect)
  640. #    foreach keyval [lsort [array names cpp_oset_dicts]] {
  641. #        set kv_list [split $keyval ,]
  642. #        gen_oset_dict_type_def [lindex $kv_list 0] \
  643. #                [lindex $kv_list 1] $sect
  644. #    }
  645.     unset ne_oset_dicts
  646. }
  647.  
  648.