snit.tcl

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

# Defines a typemethod method.
proc ::snit::Comp.statement.typemethod {method arglist body} {
    variable compile
    variable typemethodInfo

    # FIRST, check the typemethod name against previously defined
    # typemethods.
    Comp.CheckMethodName $method 0 ::snit::typemethodInfo \
        "Error in \"typemethod [list $method]...\""

    CheckArgs "typemethod $method" $arglist

    # First, add magic reference to type.
    set arglist [concat type $arglist]

    # Next, add typevariable declarations to body:
    set body "%TVARDECS%\n$body"

    # Next, save the definition script
    if {[llength $method] == 1} {
        set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}

        Mappend compile(defs) {
            proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY%
        } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
    } else {
        set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}

        Mappend compile(defs) {
            proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY%
        } %JMETHOD% [join $method _] \
            %ARGLIST% [list $arglist] %BODY% [list $body]
    }
}


# Defines a type constructor.
proc ::snit::Comp.statement.typeconstructor {body} {
    variable compile

    if {"" != $compile(typeconstructor)} {
        error "too many typeconstructors"
    }

    set compile(typeconstructor) $body
}

# Defines a static proc in the type's namespace.
proc ::snit::Comp.statement.proc {proc arglist body} {
    variable compile

    # If "ns" is defined, the proc can see instance variables.
    if {[lsearch -exact $arglist selfns] != -1} {
        # Next, add instance variable declarations to body:
        set body "%IVARDECS%\n$body"
    }

    # The proc can always see typevariables.
    set body "%TVARDECS%\n$body"

    append compile(defs) "

        # Proc $proc
        proc [list %TYPE%::$proc $arglist $body]
    "
}

# Defines a static variable in the type's namespace.
proc ::snit::Comp.statement.typevariable {name args} {
    variable compile

    set errRoot "Error in \"typevariable $name...\""

    set len [llength $args]

    if {$len > 2 ||
        ($len == 2 && [lindex $args 0] ne "-array")} {
        error "$errRoot, too many initializers"
    }

    if {[lsearch -exact $compile(varnames) $name] != -1} {
        error "$errRoot, \"$name\" is already an instance variable"
    }

    lappend compile(typevarnames) $name

    if {$len == 1} {
        append compile(typevars) \
		"\n\t    [list ::variable $name [lindex $args 0]]"
    } elseif {$len == 2} {
        append compile(typevars) \
            "\n\t    [list ::variable $name]"
        append compile(typevars) \
            "\n\t    [list array set $name [lindex $args 1]]"
    } else {
        append compile(typevars) \
		"\n\t    [list ::variable $name]"
    }

    append compile(tvprocdec) "\n\t    typevariable ${name}"
}

# Defines an instance variable; the definition will go in the
# type's create typemethod.
proc ::snit::Comp.statement.variable {name args} {
    variable compile

    set errRoot "Error in \"variable $name...\""

    set len [llength $args]

    if {$len > 2 ||
        ($len == 2 && [lindex $args 0] ne "-array")} {
        error "$errRoot, too many initializers"
    }

    if {[lsearch -exact $compile(typevarnames) $name] != -1} {
        error "$errRoot, \"$name\" is already a typevariable"
    }

    lappend compile(varnames) $name

    if {$len == 1} {
        append compile(instancevars) \
            "\nset \${selfns}::$name [list [lindex $args 0]]\n"
    } elseif {$len == 2} {
        append compile(instancevars) \
            "\narray set \${selfns}::$name [list [lindex $args 1]]\n"
    }

    append  compile(ivprocdec) "\n\t    "
    Mappend compile(ivprocdec) {::variable ${selfns}::%N} %N $name
}

# Defines a typecomponent, and handles component options.
#
# component     The logical name of the delegate
# args          options.

proc ::snit::Comp.statement.typecomponent {component args} {
    variable compile

    set errRoot "Error in \"typecomponent $component...\""

    # FIRST, define the component
    Comp.DefineTypecomponent $component $errRoot

    # NEXT, handle the options.
    set publicMethod ""
    set inheritFlag 0

    foreach {opt val} $args {
        switch -exact -- $opt {
            -public {
                set publicMethod $val
            }
            -inherit {
                set inheritFlag $val
                if {![string is boolean $inheritFlag]} {
    error "typecomponent $component -inherit: expected boolean value, got \"$val\""
                }
            }
            default {
                error "typecomponent $component: Invalid option \"$opt\""
            }
        }
    }

    # NEXT, if -public specified, define the method.
    if {$publicMethod ne ""} {
        Comp.statement.delegate typemethod [list $publicMethod *] to $component
    }

    # NEXT, if "-inherit 1" is specified, delegate typemethod * to
    # this component.
    if {$inheritFlag} {
        Comp.statement.delegate typemethod "*" to $component
    }

}


# Defines a name to be a typecomponent
#
# The name becomes a typevariable; in addition, it gets a
# write trace so that when it is set, all of the component mechanisms
# get updated.
#
# component     The component name

proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} {
    variable compile

    if {[lsearch -exact $compile(varnames) $component] != -1} {
        error "$errRoot, \"$component\" is already an instance variable"
    }

    if {[lsearch -exact $compile(typecomponents) $component] == -1} {
        # Remember we've done this.
        lappend compile(typecomponents) $component

        # Make it a type variable with no initial value
        Comp.statement.typevariable $component ""

        # Add a write trace to do the component thing.
        Mappend compile(typevars) {
            trace add variable %COMP% write \
                [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%]
        } %TYPE% $compile(type) %COMP% $component
    }
}

# Defines a component, and handles component options.
#
# component     The logical name of the delegate
# args          options.
#
# TBD: Ideally, it should be possible to call this statement multiple
# times, possibly changing the option values.  To do that, I'd need
# to cache the option values and not act on them until *after* I'd
# read the entire type definition.

proc ::snit::Comp.statement.component {component args} {
    variable compile

    set errRoot "Error in \"component $component...\""

    # FIRST, define the component
    Comp.DefineComponent $component $errRoot

    # NEXT, handle the options.
    set publicMethod ""
    set inheritFlag 0

    foreach {opt val} $args {
        switch -exact -- $opt {
            -public {
                set publicMethod $val
            }
            -inherit {
                set inheritFlag $val
                if {![string is boolean $inheritFlag]} {
    error "component $component -inherit: expected boolean value, got \"$val\""
                }
            }
            default {
                error "component $component: Invalid option \"$opt\""
            }
        }
    }

    # NEXT, if -public specified, define the method.
    if {$publicMethod ne ""} {
        Comp.statement.delegate method [list $publicMethod *] to $component
    }

    # NEXT, if -inherit is specified, delegate method/option * to
    # this component.
    if {$inheritFlag} {
        Comp.statement.delegate method "*" to $component
        Comp.statement.delegate option "*" to $component
    }
}


# Defines a name to be a component
#
# The name becomes an instance variable; in addition, it gets a
# write trace so that when it is set, all of the component mechanisms
# get updated.
#
# component     The component name

proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} {
    variable compile

    if {[lsearch -exact $compile(typevarnames) $component] != -1} {
        error "$errRoot, \"$component\" is already a typevariable"
    }

    if {[lsearch -exact $compile(components) $component] == -1} {
        # Remember we've done this.
        lappend compile(components) $component

        # Make it an instance variable with no initial value
        Comp.statement.variable $component ""

        # Add a write trace to do the component thing.
        Mappend compile(instancevars) {
            trace add variable ${selfns}::%COMP% write \
                [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%]
        } %TYPE% $compile(type) %COMP% $component
    }
}

# Creates a delegated method, typemethod, or option.
proc ::snit::Comp.statement.delegate {what name args} {
    # FIRST, dispatch to correct handler.
    switch $what {
        typemethod { Comp.DelegatedTypemethod $name $args }
        method     { Comp.DelegatedMethod     $name $args }
        option     { Comp.DelegatedOption     $name $args }
        default {
            error "Error in \"delegate $what $name...\", \"$what\"?"
        }
    }

    if {([llength $args] % 2) != 0} {
        error "Error in \"delegate $what $name...\", invalid syntax"
    }
}

# Creates a delegated typemethod delegating it to a particular
# typecomponent or an arbitrary command.
#
# method    The name of the method
# arglist       Delegation options

proc ::snit::Comp.DelegatedTypemethod {method arglist} {
    variable compile
    variable typemethodInfo

    set errRoot "Error in \"delegate typemethod [list $method]...\""

    # Next, parse the delegation options.
    set component ""
    set target ""
    set exceptions {}
    set pattern ""
    set methodTail [lindex $method end]

    foreach {opt value} $arglist {
        switch -exact $opt {
            to     { set component $value  }
            as     { set target $value     }
            except { set exceptions $value }
            using  { set pattern $value    }
            default {
                error "$errRoot, unknown delegation option \"$opt\""
            }
        }
    }

    if {$component eq "" && $pattern eq ""} {
        error "$errRoot, missing \"to\""
    }

    if {$methodTail eq "*" && $target ne ""} {
        error "$errRoot, cannot specify \"as\" with \"*\""
    }

    if {$methodTail ne "*" && $exceptions ne ""} {
        error "$errRoot, can only specify \"except\" with \"*\""
    }

    if {$pattern ne "" && $target ne ""} {
        error "$errRoot, cannot specify both \"as\" and \"using\""
    }

    foreach token [lrange $method 1 end-1] {
        if {$token eq "*"} {
            error "$errRoot, \"*\" must be the last token."
        }
    }

    # NEXT, define the component
    if {$component ne ""} {
        Comp.DefineTypecomponent $component $errRoot
    }

    # NEXT, define the pattern.
    if {$pattern eq ""} {
        if {$methodTail eq "*"} {
            set pattern "%c %m"
        } elseif {$target ne ""} {
            set pattern "%c $target"
        } else {
            set pattern "%c %m"
        }
    }

    # Make sure the pattern is a valid list.
    if {[catch {lindex $pattern 0} result]} {
        error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
    }

    # NEXT, check the method name against previously defined
    # methods.
    Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot

    set typemethodInfo($method) [list 0 $pattern $component]

    if {[string equal $methodTail "*"]} {
        Mappend compile(defs) {
            set %TYPE%::Snit_info(excepttypemethods) %EXCEPT%
        } %EXCEPT% [list $exceptions]
    }
}