snit83.tcl

来自「Linux下的MSN聊天程序源码」· TCL 代码 · 共 1,971 行 · 第 1/5 页

set ::snit::simpleInstanceProc {
    set self [set %SELFNS%::Snit_instance]

    if {[lsearch -exact ${%TYPE%::Snit_methods} $method] == -1} {
	set optlist [join ${%TYPE%::Snit_methods} ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$method\": must be $optlist"
    }

    eval [linsert $args 0 \
              %TYPE%::Snit_method$method %TYPE% %SELFNS% %WIN% $self]
}


#=======================================================================
# Snit Type Definition
#
# These are the procs used to define Snit types, widgets, and
# widgetadaptors.


#-----------------------------------------------------------------------
# Snit Compilation Variables
#
# The following variables are used while Snit is compiling a type,
# and are disposed afterwards.

namespace eval ::snit:: {
    # The compiler variable contains the name of the slave interpreter
    # used to compile type definitions.
    variable compiler ""

    # The compile array accumulates information about the type or
    # widgettype being compiled.  It is cleared before and after each
    # compilation.  It has these indices:
    #
    # type:                  The name of the type being compiled, for use
    #                        in compilation procs.
    # defs:                  Compiled definitions, both standard and client.
    # which:                 type, widget, widgetadaptor
    # instancevars:          Instance variable definitions and initializations.
    # ivprocdec:             Instance variable proc declarations.
    # tvprocdec:             Type variable proc declarations.
    # typeconstructor:       Type constructor body.
    # widgetclass:           The widgetclass, for snit::widgets, only
    # hasoptions:            False, initially; set to true when first
    #                        option is defined.
    # localoptions:          Names of local options.
    # delegatedoptions:      Names of delegated options.
    # localmethods:          Names of locally defined methods.
    # delegatesmethods:      no if no delegated methods, yes otherwise.
    # hashierarchic       :  no if no hierarchic methods, yes otherwise.
    # components:            Names of defined components.
    # typecomponents:        Names of defined typecomponents.
    # typevars:              Typevariable definitions and initializations.
    # varnames:              Names of instance variables
    # typevarnames           Names of type variables
    # hasconstructor         False, initially; true when constructor is
    #                        defined.
    # resource-$opt          The option's resource name
    # class-$opt             The option's class
    # -default-$opt          The option's default value
    # -validatemethod-$opt   The option's validate method
    # -configuremethod-$opt  The option's configure method
    # -cgetmethod-$opt       The option's cget method.
    # -hastypeinfo           The -hastypeinfo pragma
    # -hastypedestroy        The -hastypedestroy pragma
    # -hastypemethods        The -hastypemethods pragma
    # -hasinfo               The -hasinfo pragma
    # -hasinstances          The -hasinstances pragma
    # -simpledispatch        The -simpledispatch pragma
    # -canreplace            The -canreplace pragma
    variable compile

    # This variable accumulates method dispatch information; it has
    # the same structure as the %TYPE%::Snit_methodInfo array, and is
    # used to initialize it.
    variable methodInfo

    # This variable accumulates typemethod dispatch information; it has
    # the same structure as the %TYPE%::Snit_typemethodInfo array, and is
    # used to initialize it.
    variable typemethodInfo

    # The following variable lists the reserved type definition statement
    # names, e.g., the names you can't use as macros.  It's built at
    # compiler definition time using "info commands".
    variable reservedwords {}
}

#-----------------------------------------------------------------------
# type compilation commands
#
# The type and widgettype commands use a slave interpreter to compile
# the type definition.  These are the procs
# that are aliased into it.

# Initialize the compiler
proc ::snit::Comp.Init {} {
    variable compiler
    variable reservedwords

    if {[string equal $compiler ""]} {
        # Create the compiler's interpreter
        set compiler [interp create]

        # Initialize the interpreter
	$compiler eval {
            # Load package information
            # TBD: see if this can be moved outside.
            catch {package require ::snit::__does_not_exist__}

            # Protect some Tcl commands our type definitions
            # will shadow.
            rename proc _proc
            rename variable _variable
        }

        # Define compilation aliases.
        $compiler alias pragma          ::snit::Comp.statement.pragma
        $compiler alias widgetclass     ::snit::Comp.statement.widgetclass
        $compiler alias hulltype        ::snit::Comp.statement.hulltype
        $compiler alias constructor     ::snit::Comp.statement.constructor
        $compiler alias destructor      ::snit::Comp.statement.destructor
        $compiler alias option          ::snit::Comp.statement.option
        $compiler alias oncget          ::snit::Comp.statement.oncget
        $compiler alias onconfigure     ::snit::Comp.statement.onconfigure
        $compiler alias method          ::snit::Comp.statement.method
        $compiler alias typemethod      ::snit::Comp.statement.typemethod
        $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor
        $compiler alias proc            ::snit::Comp.statement.proc
        $compiler alias typevariable    ::snit::Comp.statement.typevariable
        $compiler alias variable        ::snit::Comp.statement.variable
        $compiler alias typecomponent   ::snit::Comp.statement.typecomponent
        $compiler alias component       ::snit::Comp.statement.component
        $compiler alias delegate        ::snit::Comp.statement.delegate
        $compiler alias expose          ::snit::Comp.statement.expose

        # Get the list of reserved words
        set reservedwords [$compiler eval {info commands}]
    }
}

# Compile a type definition, and return the results as a list of two
# items: the fully-qualified type name, and a script that will define
# the type when executed.
#
# which		type, widget, or widgetadaptor
# type          the type name
# body          the type definition
proc ::snit::Comp.Compile {which type body} {
    variable typeTemplate
    variable nominalTypeProc
    variable simpleTypeProc
    variable compile
    variable compiler
    variable methodInfo
    variable typemethodInfo

    # FIRST, qualify the name.
    if {![string match "::*" $type]} {
        # Get caller's namespace;
        # append :: if not global namespace.
        set ns [uplevel 2 [list namespace current]]
        if {"::" != $ns} {
            append ns "::"
        }

        set type "$ns$type"
    }

    # NEXT, create and initialize the compiler, if needed.
    Comp.Init

    # NEXT, initialize the class data
    array unset methodInfo
    array unset typemethodInfo

    array unset compile
    set compile(type) $type
    set compile(defs) {}
    set compile(which) $which
    set compile(hasoptions) no
    set compile(localoptions) {}
    set compile(instancevars) {}
    set compile(typevars) {}
    set compile(delegatedoptions) {}
    set compile(ivprocdec) {}
    set compile(tvprocdec) {}
    set compile(typeconstructor) {}
    set compile(widgetclass) {}
    set compile(hulltype) {}
    set compile(localmethods) {}
    set compile(delegatesmethods) no
    set compile(hashierarchic) no
    set compile(components) {}
    set compile(typecomponents) {}
    set compile(varnames) {}
    set compile(typevarnames) {}
    set compile(hasconstructor) no
    set compile(-hastypedestroy) yes
    set compile(-hastypeinfo) yes
    set compile(-hastypemethods) yes
    set compile(-hasinfo) yes
    set compile(-hasinstances) yes
    set compile(-simpledispatch) no
    set compile(-canreplace) no

    set isWidget [string match widget* $which]
    set isWidgetAdaptor [string match widgetadaptor $which]

    # NEXT, Evaluate the type's definition in the class interpreter.
    $compiler eval $body

    # NEXT, Add the standard definitions
    append compile(defs) \
        "\nset %TYPE%::Snit_info(isWidget) $isWidget\n"

    append compile(defs) \
        "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n"

    # Indicate whether the type can create instances that replace
    # existing commands.
    append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n"


    # Check pragmas for conflict.

    if {!$compile(-hastypemethods) && !$compile(-hasinstances)} {
        error "$which $type has neither typemethods nor instances"
    }

    if {$compile(-simpledispatch) && $compile(delegatesmethods)} {
        error "$which $type requests -simpledispatch but delegates methods."
    }

    if {$compile(-simpledispatch) && $compile(hashierarchic)} {
        error "$which $type requests -simpledispatch but defines hierarchical methods."
    }

    # If there are typemethods, define the standard typemethods and
    # the nominal type proc.  Otherwise define the simple type proc.
    if {$compile(-hastypemethods)} {
        # Add the info typemethod unless the pragma forbids it.
        if {$compile(-hastypeinfo)} {
            Comp.statement.delegate typemethod info \
                using {::snit::RT.typemethod.info %t}
        }

        # Add the destroy typemethod unless the pragma forbids it.
        if {$compile(-hastypedestroy)} {
            Comp.statement.delegate typemethod destroy \
                using {::snit::RT.typemethod.destroy %t}
        }

        # Add the nominal type proc.
        append compile(defs) $nominalTypeProc
    } else {
        # Add the simple type proc.
        append compile(defs) $simpleTypeProc
    }

    # Add standard methods/typemethods that only make sense if the
    # type has instances.
    if {$compile(-hasinstances)} {
        # If we're using simple dispatch, remember that.
        if {$compile(-simpledispatch)} {
            append compile(defs) "\nset %TYPE%::Snit_info(simpledispatch) 1\n"
        }

        # Add the info method unless the pragma forbids it.
        if {$compile(-hasinfo)} {
            if {!$compile(-simpledispatch)} {
                Comp.statement.delegate method info \
                    using {::snit::RT.method.info %t %n %w %s}
            } else {
                Comp.statement.method info {args} {
                    eval [linsert $args 0 \
                              ::snit::RT.method.info $type $selfns $win $self]
                }
            }
        }

        # Add the option handling stuff if there are any options.
        if {$compile(hasoptions)} {
            Comp.statement.variable options

            if {!$compile(-simpledispatch)} {
                Comp.statement.delegate method cget \
                    using {::snit::RT.method.cget %t %n %w %s}
                Comp.statement.delegate method configurelist \
                    using {::snit::RT.method.configurelist %t %n %w %s}
                Comp.statement.delegate method configure \
                    using {::snit::RT.method.configure %t %n %w %s}
            } else {
                Comp.statement.method cget {args} {
                    eval [linsert $args 0 \
                              ::snit::RT.method.cget $type $selfns $win $self]
                }
                Comp.statement.method configurelist {args} {
                    eval [linsert $args 0 \
                              ::snit::RT.method.configurelist $type $selfns $win $self]
                }
                Comp.statement.method configure {args} {
                    eval [linsert $args 0 \
                              ::snit::RT.method.configure $type $selfns $win $self]
                }
            }
        }

        # Add a default constructor, if they haven't already defined one.
        # If there are options, it will configure args; otherwise it
        # will do nothing.
        if {!$compile(hasconstructor)} {
            if {$compile(hasoptions)} {
                Comp.statement.constructor {args} {
                    $self configurelist $args
                }
            } else {
                Comp.statement.constructor {} {}
            }
        }

        if {!$isWidget} {
            if {!$compile(-simpledispatch)} {
                Comp.statement.delegate method destroy \
                    using {::snit::RT.method.destroy %t %n %w %s}
            } else {
                Comp.statement.method destroy {args} {
                    eval [linsert $args 0 \
                              ::snit::RT.method.destroy $type $selfns $win $self]
                }
            }

            Comp.statement.delegate typemethod create \
                using {::snit::RT.type.typemethod.create %t}
        } else {
            Comp.statement.delegate typemethod create \
                using {::snit::RT.widget.typemethod.create %t}
        }

        # Save the list of method names, for -simpledispatch; otherwise,
        # save the method info.
        if {$compile(-simpledispatch)} {
            append compile(defs) \
                "\nset %TYPE%::Snit_methods [list $compile(localmethods)]\n"
        } else {
            append compile(defs) \
                "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n"
        }

    } else {
        append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n"
    }

    # NEXT, compiling the type definition built up a set of information
    # about the type's locally defined options; add this information to
    # the compiled definition.
    Comp.SaveOptionInfo

    # NEXT, compiling the type definition built up a set of information
    # about the typemethods; save the typemethod info.
    append compile(defs) \
        "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n"

    # NEXT, if this is a widget define the hull component if it isn't
    # already defined.
    if {$isWidget} {
        Comp.DefineComponent hull
    }

    # NEXT, substitute the compiled definition into the type template
    # to get the type definition script.
    set defscript [Expand $typeTemplate \
                       %COMPILEDDEFS% $compile(defs)]

    # NEXT, substitute the defined macros into the type definition script.
    # This is done as a separate step so that the compile(defs) can
    # contain the macros defined below.

    set defscript [Expand $defscript \
                       %TYPE%         $type \
                       %IVARDECS%     $compile(ivprocdec) \
                       %TVARDECS%     $compile(tvprocdec) \
                       %TCONSTBODY%   $compile(typeconstructor) \
                       %INSTANCEVARS% $compile(instancevars) \
                       %TYPEVARS%     $compile(typevars) \
		       ]

    array unset compile

    return [list $type $defscript]
}

# Information about locally-defined options is accumulated during