snit2.tcl

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

#-----------------------------------------------------------------------
# TITLE:
#	snit.tcl
#
# AUTHOR:
#	Will Duquette
#
# DESCRIPTION:
#       Snit's Not Incr Tcl, a simple object system in Pure Tcl.
#
#       Copyright (C) 2003-2005 by William H. Duquette
#       This code is licensed as described in license.txt.
#
#-----------------------------------------------------------------------

package provide snit 2.0

#-----------------------------------------------------------------------
# Namespace

namespace eval ::snit:: {
    namespace export \
        compile type widget widgetadaptor typemethod method macro
}

#-----------------------------------------------------------------------
# Some Snit variables

namespace eval ::snit:: {
    variable reservedArgs {type selfns win self}

    # Widget classes which can be hulls (must have -class)
    variable hulltypes {
	toplevel tk::toplevel
	frame tk::frame ttk::frame
	labelframe tk::labelframe ttk::labelframe
    }
}

#-----------------------------------------------------------------------
# Snit Type Implementation template

namespace eval ::snit:: {
    # Template type definition: All internal and user-visible Snit
    # implementation code.
    #
    # The following placeholders will automatically be replaced with
    # the client's code, in two passes:
    #
    # First pass:
    # %COMPILEDDEFS%  The compiled type definition.
    #
    # Second pass:
    # %TYPE%          The fully qualified type name.
    # %IVARDECS%      Instance variable declarations
    # %TVARDECS%      Type variable declarations
    # %TCONSTBODY%    Type constructor body
    # %INSTANCEVARS%  The compiled instance variable initialization code.
    # %TYPEVARS%      The compiled type variable initialization code.

    # This is the overall type template.
    variable typeTemplate

    # This is the normal type proc
    variable nominalTypeProc

    # This is the "-hastypemethods no" type proc
    variable simpleTypeProc
}

set ::snit::typeTemplate {

    #-------------------------------------------------------------------
    # The type's namespace definition and the user's type variables

    namespace eval %TYPE% {%TYPEVARS%
    }

    #----------------------------------------------------------------
    # Commands for use in methods, typemethods, etc.
    #
    # These are implemented as aliases into the Snit runtime library.

    interp alias {} %TYPE%::installhull  {} ::snit::RT.installhull %TYPE%
    interp alias {} %TYPE%::install      {} ::snit::RT.install %TYPE%
    interp alias {} %TYPE%::typevariable {} ::variable
    interp alias {} %TYPE%::variable     {} ::snit::RT.variable
    interp alias {} %TYPE%::mytypevar    {} ::snit::RT.mytypevar %TYPE%
    interp alias {} %TYPE%::typevarname  {} ::snit::RT.mytypevar %TYPE%
    interp alias {} %TYPE%::myvar        {} ::snit::RT.myvar
    interp alias {} %TYPE%::varname      {} ::snit::RT.myvar
    interp alias {} %TYPE%::codename     {} ::snit::RT.codename %TYPE%
    interp alias {} %TYPE%::myproc       {} ::snit::RT.myproc %TYPE%
    interp alias {} %TYPE%::mymethod     {} ::snit::RT.mymethod 
    interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE%
    interp alias {} %TYPE%::from         {} ::snit::RT.from %TYPE%

    #-------------------------------------------------------------------
    # Snit's internal variables

    namespace eval %TYPE% {
        # Array: General Snit Info
        #
        # ns:                The type's namespace
        # hasinstances:      T or F, from pragma -hasinstances.
        # simpledispatch:    T or F, from pragma -hasinstances.
        # canreplace:        T or F, from pragma -canreplace.
        # counter:           Count of instances created so far.
        # widgetclass:       Set by widgetclass statement.
        # hulltype:          Hull type (frame or toplevel) for widgets only.
        # exceptmethods:     Methods explicitly not delegated to *
        # excepttypemethods: Methods explicitly not delegated to *
        # tvardecs:          Type variable declarations--for dynamic methods
        # ivardecs:          Instance variable declarations--for dyn. methods
        typevariable Snit_info
        set Snit_info(ns)      %TYPE%::
        set Snit_info(hasinstances) 1
        set Snit_info(simpledispatch) 0
        set Snit_info(canreplace) 0
        set Snit_info(counter) 0
        set Snit_info(widgetclass) {}
        set Snit_info(hulltype) frame
        set Snit_info(exceptmethods) {}
        set Snit_info(excepttypemethods) {}
        set Snit_info(tvardecs) {%TVARDECS%}
        set Snit_info(ivardecs) {%IVARDECS%}

        # Array: Public methods of this type.
        # The index is the method name, or "*".
        # The value is [list $pattern $componentName], where
        # $componentName is "" for normal methods.
        typevariable Snit_typemethodInfo
        array unset Snit_typemethodInfo

        # Array: Public methods of instances of this type.
        # The index is the method name, or "*".
        # The value is [list $pattern $componentName], where
        # $componentName is "" for normal methods.
        typevariable Snit_methodInfo
        array unset Snit_methodInfo

        # Array: option information.  See dictionary.txt.
        typevariable Snit_optionInfo
        array unset Snit_optionInfo
        set Snit_optionInfo(local)     {}
        set Snit_optionInfo(delegated) {}
        set Snit_optionInfo(starcomp)  {}
        set Snit_optionInfo(except)    {}
    }

    #----------------------------------------------------------------
    # Compiled Procs
    #
    # These commands are created or replaced during compilation:


    # Snit_instanceVars selfns
    #
    # Initializes the instance variables, if any.  Called during
    # instance creation.
    
    proc %TYPE%::Snit_instanceVars {selfns} {
        %INSTANCEVARS%
    }

    # Type Constructor
    proc %TYPE%::Snit_typeconstructor {type} {
        %TVARDECS%
        %TCONSTBODY%
    }

    #----------------------------------------------------------------
    # Default Procs
    #
    # These commands might be replaced during compilation:

    # Snit_destructor type selfns win self
    #
    # Default destructor for the type.  By default, it does
    # nothing.  It's replaced by any user destructor.
    # For types, it's called by method destroy; for widgettypes,
    # it's called by a destroy event handler.

    proc %TYPE%::Snit_destructor {type selfns win self} { }

    #----------------------------------------------------------
    # Compiled Definitions

    %COMPILEDDEFS%

    #----------------------------------------------------------
    # Finally, call the Type Constructor

    %TYPE%::Snit_typeconstructor %TYPE%
}

#-----------------------------------------------------------------------
# Type procs
#
# These procs expect the fully-qualified type name to be 
# substituted in for %TYPE%.

# This is the nominal type proc.  It supports typemethods and
# delegated typemethods.
set ::snit::nominalTypeProc {
    # WHD: Code for creating the type ensemble
    namespace eval %TYPE% {
        namespace ensemble create \
            -unknown [list ::snit::RT.UnknownTypemethod %TYPE% ""] \
            -prefixes 0
    }
}

# This is the simplified type proc for when there are no typemethods
# except create.  In this case, it doesn't take a method argument;
# the method is always "create".
set ::snit::simpleTypeProc {
    # Type dispatcher function.  Note: This function lives
    # in the parent of the %TYPE% namespace!  All accesses to 
    # %TYPE% variables and methods must be qualified!
    proc %TYPE% {args} {
        ::variable %TYPE%::Snit_info

        # FIRST, if the are no args, the single arg is %AUTO%
        if {[llength $args] == 0} {
            if {$Snit_info(isWidget)} {
                error "wrong \# args: should be \"%TYPE% name args\""
            }
            
            lappend args %AUTO%
        }

        # NEXT, we're going to call the create method.
        # Pass along the return code unchanged.
        if {$Snit_info(isWidget)} {
            set command [list ::snit::RT.widget.typemethod.create %TYPE%]
        } else {
            set command [list ::snit::RT.type.typemethod.create %TYPE%]
        }

        set retval [catch {uplevel 1 $command $args} result]

        if {$retval} {
            if {$retval == 1} {
                global errorInfo
                global errorCode
                return -code error -errorinfo $errorInfo \
                    -errorcode $errorCode $result
            } else {
                return -code $retval $result
            }
        }

        return $result
    }
}

#=======================================================================
# 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 WHD: OBSOLETE
    # -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 {$compiler eq ""} {
        # 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