PC World 1998 October/PCWorld_1998-10_cd.bin/software/prehled/komix/DATA.Z/ne_class.tcl

Text File | 1997-06-06 | 16.1 KB | 648 lines

#---------------------------------------------------------------------------
#
# Copyright (c) 1994-1995 by Cadre Technologies Inc.
#
# This software is furnished under a license and may be used only in
# accordance with the terms of such license and with the inclusion of
# the above copyright notice. This software or any other copies thereof
# may not be provided or otherwise made available to any other person.
# No title to and ownership of the software is hereby transferred.
#
# The information in this software is subject to change without notice
# and should not be construed as a commitment by Cadre Technologies Inc.
#
#---------------------------------------------------------------------------
#
#    File        : @(#)ne_class.tcl    /main/titanic/4
#    Original date    : 20-10-1994
#    Description    : Class-level functions for NewEra generation
#
#---------------------------------------------------------------------------
#

# Needed for E_FILE_OPEN_WRITE
#
require cgen_msg.tcl

global ne_hdr_sections
set ne_hdr_sections {
    h_incl_sect
    h_fwd_decl_sect
    h_help_class_sect
    h_class_nm_sect
    h_const_data_sect
    h_ctor_sect
    h_pub_func_sect
    h_pub_data_sect
    h_prot_func_sect
    h_priv_func_sect
    h_priv_data_sect
}

global ne_src_sections
set ne_src_sections {
    c_hdr_sect
    c_incl_sect
    c_static_sect
    c_ctor_init_sect
    c_ctor_init_iv_sect
    c_ctor_decl_sect
    c_ctor_body_sect
    c_ctor_body_iv_sect
    c_dtor_decl_sect
    c_dtor_sect
    c_impl_sect
    c_src_sect
    c_impl_no_regen_sect
}

# Global section array
#
global ne_sections


# Determine the right section based on the accessibility specification and
# whether it is for reading or writing
#
proc get_hdr_sect {access {mode ""}} {
    case [split_access_mode $access $mode] in {
    {Public} {
        return $ne_sections(h_pub_func_sect)
    }
    {Protected} {
        return $ne_sections(h_prot_func_sect)
    }
    {Private} {
        return $ne_sections(h_priv_func_sect)
    }
    {None} {
        return $ne_sections(dev_null_sect)
    }}
}

proc get_src_sect {access {mode ""}} {
    if {[split_access_mode $access $mode] == "None"} {
        return $ne_sections(dev_null_sect)
    }
    return $ne_sections(c_impl_no_regen_sect)
}

# Split up the access mode and return the right part of it
#
proc split_access_mode {access mode} {
    if {$access == ""} {
        return Public
    }
    set rw_ac_list [split $access -]
    if {[llength $rw_ac_list] == 2} {
        if {$mode == "r"} {
            return [lindex $rw_ac_list 0]
        }
        return [lindex $rw_ac_list 1]
    }
    return $access
}

# Determine the section for an assoc accesser function based on
# the attribute "assoc_access"
#
proc get_assoc_hdr_sect {assoc {mode ""}} {
    return [get_hdr_sect [$assoc getPropertyValue assoc_access] $mode]
}

proc get_assoc_src_sect {assoc {mode ""}} {
    return [get_src_sect [$assoc getPropertyValue assoc_access] $mode]
}

# Determine the section for an attribute accesser function based on
# the attribute "attrib_access"
#
proc get_attrib_hdr_sect {attrib {mode ""}} {
    return [get_hdr_sect [$attrib getPropertyValue attrib_access] $mode]
}

proc get_attrib_src_sect {attrib {mode ""}} {
    return [get_src_sect [$attrib getPropertyValue attrib_access] $mode]
}

# Create NewEra sections
#
proc create_ne_sections {sects} {
    global ne_sections
    foreach sect $sects {
        set ne_sections($sect) [TextSection new]
        $ne_sections($sect) indent 0 "\t"
    }
    set ne_sections(dev_null_sect) [TextSection new]
    global ctor_init_sep ctor_init_iv_sep exists_ctor db_ctor_is_unique
    set ctor_init_sep 1
    set ctor_init_iv_sep 1
    set exists_ctor 0
    set db_ctor_is_unique 0
}

# give sections their initial contents

proc init_ne_sections {class} {
    set name [$class getName]
    class2tgtfiles $class srcFile hdrFile

    expandHeaderIntoSection $hdrFile $fourgh_type $ne_sections(h_incl_sect)
    $ne_sections(h_incl_sect) append "\n"
    $ne_sections(h_const_data_sect) indent +
    $ne_sections(h_ctor_sect) indent +
    $ne_sections(h_pub_func_sect) indent +
    $ne_sections(h_pub_func_sect) append "FUNCTION !destroy()\n\n"
    $ne_sections(h_prot_func_sect) append "\n"
    $ne_sections(h_prot_func_sect) indent +
    $ne_sections(h_pub_data_sect) indent +
    $ne_sections(h_priv_func_sect) append "\n"
    $ne_sections(h_priv_func_sect) indent +
    $ne_sections(h_priv_data_sect) indent +

    expandHeaderIntoSection $srcFile $fourgl_type $ne_sections(c_hdr_sect)
    $ne_sections(c_hdr_sect) append "\n"
    $ne_sections(c_ctor_decl_sect) indent +
    $ne_sections(c_ctor_decl_sect) append "\n"
    $ne_sections(c_ctor_body_sect) indent +
    $ne_sections(c_ctor_body_iv_sect) indent +
    $ne_sections(c_dtor_decl_sect) append "FUNCTION $name::!destroy()\n"
    regen_unset "!destroy" "()"
    $ne_sections(c_dtor_decl_sect) indent +
    $ne_sections(c_dtor_sect) indent +
    $ne_sections(c_impl_no_regen_sect) append "$REGEN_END\n\n"
}

# give sections their terminal contents

proc exit_ne_sections {class} {
    if {[$ne_sections(h_incl_sect) contents] != ""} {
        $ne_sections(h_incl_sect) append "\n"
    }
    if {[$ne_sections(h_const_data_sect) contents] != ""} {
        $ne_sections(h_const_data_sect) append "\n"
    }
    $ne_sections(h_priv_data_sect) indent -
    $ne_sections(h_priv_data_sect) append "END CLASS\n\n"
    if {[$ne_sections(c_hdr_sect) contents] != ""} {
        $ne_sections(c_hdr_sect) append "\n"
    }
    set $ne_sections(c_ctor_decl_sect) [removeDoubleLinesFromSection \
        $ne_sections(c_ctor_decl_sect)]
    if {[$ne_sections(c_ctor_decl_sect) contents] != "\n"} {
        $ne_sections(c_ctor_decl_sect) append "\n"
    }
    $ne_sections(c_ctor_body_iv_sect) indent -
    $ne_sections(c_ctor_body_iv_sect) append "END FUNCTION\n\n"
    set $ne_sections(c_dtor_decl_sect) [removeDoubleLinesFromSection \
        $ne_sections(c_dtor_decl_sect)]
    $ne_sections(c_dtor_sect) indent -
    $ne_sections(c_dtor_sect) append "END FUNCTION\n\n"
    if {[$ne_sections(c_static_sect) contents] != ""} {
        $ne_sections(c_static_sect) append "\n"
    }
}

# Write the sections to the right file and deallocate them
#
proc write_ne_sections {class hsects csects} {
    class2tgtfiles $class src_file h_file
    set class_name [$class getName]
    do_write_ne_sections $class_name $h_file $hsects
    do_write_ne_sections $class_name $src_file $csects
    unset ne_sections(dev_null_sect)
}

proc do_write_ne_sections {class_name file_name sects} {
    global ne_error_state
    set did_save_file 0
    if {[llength $sects] == 0 || $ne_error_state} {
        return $did_save_file
    }
    set nt $file_name
    global skip_file
    global gen_file
    if {[info exists gen_file($nt)] ||
        ($import_new && ![info exists skip_file($nt)])} {
        set cmp_sect [TextSection new]
        foreach sect $sects {
            set ctor_sect_mtch [string match c_ctor_* $sect]
            if {!$ctor_sect_mtch || $exists_ctor} {
                $cmp_sect appendSect $ne_sections($sect)
            }
            unset ne_sections($sect)
        }
        if [section_equals_file $cmp_sect $nt] {
            puts "$nt has not changed: file not written"
            return 0
        }
        if {[M4CheckManager::getErrorCount] > 0} {
            puts "Not saving $nt because of previous errors"
            return 0
        }
        puts stdout "Creating $nt"
        if {[catch {set fd [fstorage::open $nt w]} reason]} {
            puts stderr $reason
            m4_error $E_FILE_OPEN_WRITE $nt
        } else {
            if { [catch {fstorage::set_imp_from $nt $class_name} \
                  reason] } {
                puts stderr $reason
            }
            $cmp_sect write $fd
            fstorage::close $fd
            set did_save_file 1
        }
    }
    return $did_save_file
}

proc process_external_class_source {class} {
    set class_name [$class getName]
    set tmp_sect [TextSection new]
    expand_text $tmp_sect [$class getPropertyValue class_source]
    set files [string trim [$tmp_sect contents]]

    set first 1
    foreach entry [split $files ,] {
        set entry [string trim $entry]
        # first one is fourgh_type
        # all others are fourgl_type
        if $first {
            set first 0
            set ftype $fourgh_type
        } else {
            set ftype $fourgl_type
        }
        set file_name [class2file $class_name]
        set nt ${file_name}.$ftype
        global skip_file
        global gen_file
        if {[info exists gen_file($nt)] ||
            ($import_new && ![info exists skip_file($nt)])} {
            set fullpath [find_file $entry]
            if {$fullpath == ""} {
                puts -nonewline "ERROR: class '[$class getName]': "
                puts "external class source file '$entry' not found"
                continue
            }
            puts "Importing external '$fullpath'"
            puts "Creating $nt"
            if {[catch {set out [fstorage::open $nt w]} reason]} {
                puts stderr $reason
                m4_error $E_FILE_OPEN_WRITE $nt
            } else {
                set label [[$class smNode] getLabel]
                set real_name [$class getName]
                if {![$label isNil]} {
                    set real_name [$label value]
                }
                if { [catch {fstorage::set_imp_from $nt \
                    $real_name} reason] } {
                    puts stderr $reason
                }
                set max 8092
                set in [open $fullpath r]
                while {[set result [read $in $max]] != ""} {
                    puts -nonewline $out $result
                }
                close $in
                fstorage::close $out
            }
        }
    }
}

# find file using global 'exsrc_searchpath'

proc find_file {file} {
    if [file exists $file] {
        return $file
    }
    global exsrc_searchpath
    if {! [info exists exsrc_searchpath]} {
        return ""
    }
    set sep [searchPathSeparator]
    foreach dir [split $exsrc_searchpath $sep] {
        set fullpath [path_name concat $dir $file]
        if [file exists $fullpath] {
            return $fullpath
        }
    }
    return ""
}

# read status arrays and generate 'only-once' code

proc gen_delayed_code {} {
    gen_hdr_incs
    gen_forwards
    gen_src_incs
    gen_sets
    gen_osets
    gen_dicts
    gen_set_dicts
    gen_oset_dicts

    global ne_hdr_incs
    catch {unset ne_hdr_incs}
    global ne_hdr_files
    catch {unset ne_hdr_files}
}

#
# forward declaration / class header inclusion management functions
#

# Global arrays to store the information
#
global ne_forwards
global ne_hdr_incs ne_hdr_incs_name
global ne_src_incs ne_src_incs_name

proc add_forward {class} {
    global ne_forwards
    set ne_forwards([$class getName]) $class
}

proc add_forward_name {name} {
    global ne_forwards
    set ne_forwards($name) 1
}

proc add_hdr_inc {class} {
    global ne_hdr_incs
    set ne_hdr_incs([$class getName]) $class
}

proc add_hdr_inc_name {class_name} {
    global ne_hdr_incs_name
    set ne_hdr_incs_name($class_name) 1
}

proc add_hdr_sys_inc_name {inc_name} {
    add_hdr_inc_name $inc_name
}

proc add_src_inc {class} {
    global ne_src_incs
    set ne_src_incs([$class getName]) $class
}

proc add_src_inc_name {class_name} {
    global ne_src_incs_name
    set ne_src_incs_name($class_name) 1
}

proc add_src_sys_inc_name {inc_name} {
    add_src_inc_name $inc_name
}

# Generate forwards. If the class definition is also included, the forward
# is not generated.
# If the forward name start with "ix", then first map it to the
# corresponding ix include file
proc gen_forwards {} {
    global ne_forwards ne_hdr_files
    if {![info exists ne_forwards]} {
        return
    }
    set sect $ne_sections(h_fwd_decl_sect)
    foreach class [lsort [array names ne_forwards]] {
        if [string match ix* $class] {
            set hdrnm [ixval2hdr $class]
        } else {
            set hdrnm $class
        }
        set hdrfile [h_class2file $hdrnm]
        if [info exists ne_hdr_files($hdrfile)] {
            continue
        }
        $sect append "FORWARD $class\n"
    }
    unset ne_forwards
}

proc gen_hdr_incs {} {
    global ne_hdr_incs ne_hdr_incs_name ne_hdr_files
    set gen_include_list ""
    set user_include_list ""
    if [info exists ne_hdr_incs] {
        foreach class [array names ne_hdr_incs] {
            set hdl $ne_hdr_incs($class)
            set incls [$hdl getPropertyValue include_list]
            if {$incls == ""} {
                lappend gen_include_list [$hdl getName]
                set ne_hdr_files([h_class2file $class]) 1
            } else {
                foreach incl [split $incls ,] {
                    lappend user_include_list $incl
                    set ne_hdr_files($incl) 1
                }
            }
        }
    }
    if [info exists ne_hdr_incs_name] {
        foreach entry [array names ne_hdr_incs_name] {
            set file [h_class2file $entry]
            if [info exists ne_hdr_files($file)] {
                continue
            }
            lappend gen_include_list $entry
            set ne_hdr_files($file) 1
        }
    }
    foreach entry [lsort $gen_include_list] {
        # prefer user includes
        set idx [lsearch -exact user_include_list [h_class2file $entry]]
        if {$idx == -1} {
            gen_include $entry $ne_sections(h_incl_sect)
        }
    }
    # do not sort ! remove duplicates
    foreach entry $user_include_list {
        if [info exists dup($entry)] {
            continue;
        }
        set dup($entry) 1
        gen_include_filename $entry $ne_sections(h_incl_sect)
    }
    catch {unset ne_hdr_incs_name}
}

# Generate includes for source file. Don't generate if the file is already
# included in the header file.
#
proc gen_src_incs {} {
    if {! [info exists ne_sections(c_hdr_sect)]} {
        return
    }
    global ne_src_incs ne_src_incs_name ne_hdr_files
    set gen_include_list ""
    set user_include_list ""
    if [info exists ne_src_incs] {
        foreach class [array names ne_src_incs] {
            if [info exists ne_hdr_incs($class)] {
                continue
            }
            set hdl $ne_src_incs($class)
            set incls [$hdl getPropertyValue include_list]
            if {$incls == ""} {
                lappend gen_include_list [$hdl getName]
                set src_files([h_class2file $class]) 1
            } else {
                foreach incl [split $incls ,] {
                    if [info exists ne_hdr_files($incl)] {
                        continue
                    }
                    lappend user_include_list $incl
                    set src_files($incl) 1
                }
            }
        }
    }
    if [info exists ne_src_incs_name] {
        foreach entry [array names ne_src_incs_name] {
            set file [h_class2file $entry]
            if [info exists ne_hdr_files($file)] {
                continue
            }
            if [info exists src_files($file)] {
                continue
            }
            lappend gen_include_list $entry
        }
    }
    foreach entry [lsort $gen_include_list] {
        # prefer user includes
        set idx [lsearch -exact user_include_list [h_class2file $entry]]
        if {$idx == -1} {
            gen_include $entry $ne_sections(c_hdr_sect)
        }
    }
    # do not sort ! remove duplicates
    foreach entry $user_include_list {
        if [info exists dup($entry)] {
            continue;
        }
        set dup($entry) 1
        gen_include_filename $entry $ne_sections(c_hdr_sect)
    }
    catch {unset ne_src_incs}
    catch {unset ne_src_incs_name}
    catch {unset src_files}
}


# Sets to be instantiated
#
global ne_sets

proc instantiate_set {class} {
    global ne_sets
    set ne_sets($class) 1
}

proc gen_sets {} {
    global ne_sets
    if {![info exists ne_sets]} {
        return
    }
#    set sect $cpp_sections(h_incl_sect)
#    foreach class [lsort [array names cpp_sets]] {
#        gen_set_type_def $class $sect
#    }
    unset ne_sets
}

# Ordered Sets to be instantiated
#
global ne_osets

proc instantiate_oset {class} {
    global ne_osets
    set ne_osets($class) 1
}

proc gen_osets {} {
    global ne_osets
    if {![info exists ne_osets]} {
        return
    }
#    set sect $cpp_sections(h_incl_sect)
#    foreach class [lsort [array names cpp_osets]] {
#        gen_oset_type_def $class $sect
#    }
    unset ne_osets
}

# Dicts to be instantiated
#
global ne_dicts

proc instantiate_dict {key value} {
    global ne_dicts
    set ne_dicts($key,$value) 1
}

proc gen_dicts {} {
    global ne_dicts
    if {![info exists ne_dicts]} {
        return
    }
#    set sect $cpp_sections(h_incl_sect)
#    foreach keyval [lsort [array names cpp_dicts]] {
#        set kv_list [split $keyval ,]
#        gen_dict_type_def [lindex $kv_list 0] [lindex $kv_list 1] $sect
#    }
    unset ne_dicts
}

# Set Dicts to be instantiated
#
global ne_set_dicts

proc instantiate_set_dict {key value} {
    global ne_set_dicts
    set ne_set_dicts($key,$value) 1
}

proc gen_set_dicts {} {
    global ne_set_dicts
    if {![info exists ne_set_dicts]} {
        return
    }
#    set sect $cpp_sections(h_incl_sect)
#    foreach keyval [lsort [array names cpp_set_dicts]] {
#        set kv_list [split $keyval ,]
#        gen_set_dict_type_def [lindex $kv_list 0] \
#                [lindex $kv_list 1] $sect
#    }
    unset ne_set_dicts
}

# Ordered Set Dicts to be instantiated
#
global ne_oset_dicts

proc instantiate_oset_dict {key value} {
    global ne_oset_dicts
    set ne_oset_dicts($key,$value) 1
}

proc gen_oset_dicts {} {
    global ne_oset_dicts
    if {![info exists ne_oset_dicts]} {
        return
    }
#    set sect $cpp_sections(h_incl_sect)
#    foreach keyval [lsort [array names cpp_oset_dicts]] {
#        set kv_list [split $keyval ,]
#        gen_oset_dict_type_def [lindex $kv_list 0] \
#                [lindex $kv_list 1] $sect
#    }
    unset ne_oset_dicts
}