通讯编程

开发平台：
Visual C++

genStubs.tcl：源码内容
							# genStubs.tcl --
#
#	This script generates a set of stub files for a given
#	interface.  
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: genStubs.tcl,v 1.13 2002/10/04 08:25:14 dkf Exp $
package require Tcl 8
namespace eval genStubs {
    # libraryName --
    #
    #	The name of the entire library.  This value is used to compute
    #	the USE_*_STUB_PROCS macro and the name of the init file.
    variable libraryName "UNKNOWN"
    # interfaces --
    #
    #	An array indexed by interface name that is used to maintain
    #   the set of valid interfaces.  The value is empty.
    array set interfaces {}
    # curName --
    #
    #	The name of the interface currently being defined.
    variable curName "UNKNOWN"
    # hooks --
    #
    #	An array indexed by interface name that contains the set of
    #	subinterfaces that should be defined for a given interface.
    array set hooks {}
    # stubs --
    #
    #	This three dimensional array is indexed first by interface name,
    #	second by platform name, and third by a numeric offset or the
    #	constant "lastNum".  The lastNum entry contains the largest
    #	numeric offset used for a given interface/platform combo.  Each
    #	numeric offset contains the C function specification that
    #	should be used for the given entry in the stub table.  The spec
    #	consists of a list in the form returned by parseDecl.
    array set stubs {}
    # outDir --
    #
    #	The directory where the generated files should be placed.
    variable outDir .
}
# genStubs::library --
#
#	This function is used in the declarations file to set the name
#	of the library that the interfaces are associated with (e.g. "tcl").
#	This value will be used to define the inline conditional macro.
#
# Arguments:
#	name	The library name.
#
# Results:
#	None.
proc genStubs::library {name} {
    variable libraryName $name
}
# genStubs::interface --
#
#	This function is used in the declarations file to set the name
#	of the interface currently being defined.
#
# Arguments:
#	name	The name of the interface.
#
# Results:
#	None.
proc genStubs::interface {name} {
    variable curName $name
    variable interfaces
    set interfaces($name) {}
    return
}
# genStubs::hooks --
#
#	This function defines the subinterface hooks for the current
#	interface.
#
# Arguments:
#	names	The ordered list of interfaces that are reachable through the
#		hook vector.
#
# Results:
#	None.
proc genStubs::hooks {names} {
    variable curName
    variable hooks
    set hooks($curName) $names
    return
}
# genStubs::declare --
#
#	This function is used in the declarations file to declare a new
#	interface entry.
#
# Arguments:
#	index		The index number of the interface.
#	platform	The platform the interface belongs to.  Should be one
#			of generic, win, unix, or mac, or macosx or aqua or x11.
#	decl		The C function declaration, or {} for an undefined
#			entry.
#
# Results:
#	None.
proc genStubs::declare {args} {
    variable stubs
    variable curName
    if {[llength $args] != 3} {
	puts stderr "wrong # args: declare $args"
    }
    lassign $args index platformList decl
    # Check for duplicate declarations, then add the declaration and
    # bump the lastNum counter if necessary.
    foreach platform $platformList {
	if {[info exists stubs($curName,$platform,$index)]} {
	    puts stderr "Duplicate entry: declare $args"
	}
    }
    regsub -all "[ tn]+" [string trim $decl] " " decl
    set decl [parseDecl $decl]
    foreach platform $platformList {
	if {$decl != ""} {
	    set stubs($curName,$platform,$index) $decl
	    if {![info exists stubs($curName,$platform,lastNum)] 
		    || ($index > $stubs($curName,$platform,lastNum))} {
		set stubs($curName,$platform,lastNum) $index
	    }
	}
    }
    return
}
# genStubs::rewriteFile --
#
#	This function replaces the machine generated portion of the
#	specified file with new contents.  It looks for the !BEGIN! and
#	!END! comments to determine where to place the new text.
#
# Arguments:
#	file	The name of the file to modify.
#	text	The new text to place in the file.
#
# Results:
#	None.
proc genStubs::rewriteFile {file text} {
    if {![file exists $file]} {
	puts stderr "Cannot find file: $file"
	return
    }
    set in [open ${file} r]
    set out [open ${file}.new w]
    while {![eof $in]} {
	set line [gets $in]
	if {[regexp {!BEGIN!} $line]} {
	    break
	}
	puts $out $line
    }
    puts $out "/* !BEGIN!: Do not edit below this line. */"
    puts $out $text
    while {![eof $in]} {
	set line [gets $in]
	if {[regexp {!END!} $line]} {
	    break
	}
    }
    puts $out "/* !END!: Do not edit above this line. */"
    puts -nonewline $out [read $in]
    close $in
    close $out
    file rename -force ${file}.new ${file}
    return
}
# genStubs::addPlatformGuard --
#
#	Wrap a string inside a platform #ifdef.
#
# Arguments:
#	plat	Platform to test.
#
# Results:
#	Returns the original text inside an appropriate #ifdef.
proc genStubs::addPlatformGuard {plat text} {
    switch $plat {
	win {
	    return "#ifdef __WIN32__n${text}#endif /* __WIN32__ */n"
	}
	unix {
	    return "#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */n${text}#endif /* UNIX */n"
	}		    
	mac {
	    return "#ifdef MAC_TCLn${text}#endif /* MAC_TCL */n"
	}
	macosx {
	    return "#ifdef MAC_OSX_TCLn${text}#endif /* MAC_OSX_TCL */n"
	}
	aqua {
	    return "#ifdef MAC_OSX_TKn${text}#endif /* MAC_OSX_TK */n"
	}
	x11 {
	    return "#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) /* X11 */n${text}#endif /* X11 */n"
	}
    }
    return "$text"
}
# genStubs::emitSlots --
#
#	Generate the stub table slots for the given interface.  If there
#	are no generic slots, then one table is generated for each
#	platform, otherwise one table is generated for all platforms.
#
# Arguments:
#	name	The name of the interface being emitted.
#	textVar	The variable to use for output.
#
# Results:
#	None.
proc genStubs::emitSlots {name textVar} {
    variable stubs
    upvar $textVar text
    forAllStubs $name makeSlot 1 text {"    void *reserved$i;n"}
    return
}
# genStubs::parseDecl --
#
#	Parse a C function declaration into its component parts.
#
# Arguments:
#	decl	The function declaration.
#
# Results:
#	Returns a list of the form {returnType name args}.  The args
#	element consists of a list of type/name pairs, or a single
#	element "void".  If the function declaration is malformed
#	then an error is displayed and the return value is {}.
proc genStubs::parseDecl {decl} {
    if {![regexp {^(.*)((.*))$} $decl all prefix args]} {
	puts stderr "Malformed declaration: $decl"
	return
    }
    set prefix [string trim $prefix]
    if {![regexp {^(.+[ ][*]*)([^ *]+)$} $prefix all rtype fname]} {
	puts stderr "Bad return type: $decl"
	return
    }
    set rtype [string trim $rtype]
    foreach arg [split $args ,] {
	lappend argList [string trim $arg]
    }
    if {![string compare [lindex $argList end] "..."]} {
	if {[llength $argList] != 2} {
	    puts stderr "Only one argument is allowed in varargs form: $decl"
	}
	set arg [parseArg [lindex $argList 0]]
	if {$arg == "" || ([llength $arg] != 2)} {
	    puts stderr "Bad argument: '[lindex $argList 0]' in '$decl'"
	    return
	}
	set args [list TCL_VARARGS $arg]
    } else {
	set args {}
	foreach arg $argList {
	    set argInfo [parseArg $arg]
	    if {![string compare $argInfo "void"]} {
		lappend args "void"
		break
	    } elseif {[llength $argInfo] == 2 || [llength $argInfo] == 3} {
		lappend args $argInfo
	    } else {
		puts stderr "Bad argument: '$arg' in '$decl'"
		return
	    }
	}
    }
    return [list $rtype $fname $args]
}
# genStubs::parseArg --
#
#	This function parses a function argument into a type and name.
#
# Arguments:
#	arg	The argument to parse.
#
# Results:
#	Returns a list of type and name with an optional third array
#	indicator.  If the argument is malformed, returns "".
proc genStubs::parseArg {arg} {
    if {![regexp {^(.+[ ][*]*)([^][ *]+)([])?$} $arg all type name array]} {
	if {$arg == "void"} {
	    return $arg
	} else {
	    return
	}
    }
    set result [list [string trim $type] $name]
    if {$array != ""} {
	lappend result $array
    }
    return $result
}
# genStubs::makeDecl --
#
#	Generate the prototype for a function.
#
# Arguments:
#	name	The interface name.
#	decl	The function declaration.
#	index	The slot index for this function.
#
# Results:
#	Returns the formatted declaration string.
proc genStubs::makeDecl {name decl index} {
    lassign $decl rtype fname args
    append text "/* $index */n"
    set line "EXTERN $rtype"
    set count [expr {2 - ([string length $line] / 8)}]
    append line [string range "ttt" 0 $count]
    set pad [expr {24 - [string length $line]}]
    if {$pad <= 0} {
	append line " "
	set pad 0
    }
    append line "$fname _ANSI_ARGS_("
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append line "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append line "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append line $sep
		set next {}
		append next [lindex $arg 0] " " [lindex $arg 1] 
			[lindex $arg 2]
		if {[string length $line] + [string length $next] 
			+ $pad > 76} {
		    append text $line n
		    set line "tttt"
		    set pad 28
		}
		append line $next
		set sep ", "
	    }
	    append line ")"
	}
    }
    append text $line
    
    append text ");n"
    return $text
}
# genStubs::makeMacro --
#
#	Generate the inline macro for a function.
#
# Arguments:
#	name	The interface name.
#	decl	The function declaration.
#	index	The slot index for this function.
#
# Results:
#	Returns the formatted macro definition.
proc genStubs::makeMacro {name decl index} {
    lassign $decl rtype fname args
    set lfname [string tolower [string index $fname 0]]
    append lfname [string range $fname 1 end]
    set text "#ifndef $fnamen#define $fname"
    set arg1 [lindex $args 0]
    set argList ""
    switch -exact $arg1 {
	void {
	    set argList "()"
	}
	TCL_VARARGS {
	}
	default {
	    set sep "("
	    foreach arg $args {
		append argList $sep [lindex $arg 1]
		set sep ", "
	    }
	    append argList ")"
	}
    }
    append text " \nt(${name}StubsPtr->$lfname)"
    append text " /* $index */n#endifn"
    return $text
}
# genStubs::makeStub --
#
#	Emits a stub function definition.
#
# Arguments:
#	name	The interface name.
#	decl	The function declaration.
#	index	The slot index for this function.
#
# Results:
#	Returns the formatted stub function definition.
proc genStubs::makeStub {name decl index} {
    lassign $decl rtype fname args
    set lfname [string tolower [string index $fname 0]]
    append lfname [string range $fname 1 end]
    append text "/* Slot $index */n" $rtype "n" $fname
    set arg1 [lindex $args 0]
    if {![string compare $arg1 "TCL_VARARGS"]} {
	lassign [lindex $args 1] type argName 
	append text " TCL_VARARGS_DEF($type,$argName)n{n"
	append text "    " $type " var;n    va_list argList;n"
	if {[string compare $rtype "void"]} {
	    append text "    " $rtype " resultValue;n"
	}
	append text "n    var = (" $type ") TCL_VARARGS_START(" 
		$type "," $argName ",argList);nn    "
	if {[string compare $rtype "void"]} {
	    append text "resultValue = "
	}
	append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);n"
	append text "    va_end(argList);n"
	if {[string compare $rtype "void"]} {
	    append text "return resultValue;n"
	}
	append text "}nn"
	return $text
    }
    if {![string compare $arg1 "void"]} {
	set argList "()"
	set argDecls ""
    } else {
	set argList ""
	set sep "("
	foreach arg $args {
	    append argList $sep [lindex $arg 1]
	    append argDecls "    " [lindex $arg 0] " " 
		    [lindex $arg 1] [lindex $arg 2] ";n"
	    set sep ", "
	}
	append argList ")"
    }
    append text $argList "n" $argDecls "{n    "
    if {[string compare $rtype "void"]} {
	append text "return "
    }
    append text "(" $name "StubsPtr->" $lfname ")" $argList ";n}nn"
    return $text
}
# genStubs::makeSlot --
#
#	Generate the stub table entry for a function.
#
# Arguments:
#	name	The interface name.
#	decl	The function declaration.
#	index	The slot index for this function.
#
# Results:
#	Returns the formatted table entry.
proc genStubs::makeSlot {name decl index} {
    lassign $decl rtype fname args
    set lfname [string tolower [string index $fname 0]]
    append lfname [string range $fname 1 end]
    set text "    "
    append text $rtype " (*" $lfname ") _ANSI_ARGS_("
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append text "(void)"
	}
	TCL_VARARGS {
	    set arg [lindex $args 1]
	    append text "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
	}
	default {
	    set sep "("
	    foreach arg $args {
		append text $sep [lindex $arg 0] " " [lindex $arg 1] 
			[lindex $arg 2]
		set sep ", "
	    }
	    append text ")"
	}
    }
    
    append text "); /* $index */n"
    return $text
}
# genStubs::makeInit --
#
#	Generate the prototype for a function.
#
# Arguments:
#	name	The interface name.
#	decl	The function declaration.
#	index	The slot index for this function.
#
# Results:
#	Returns the formatted declaration string.
proc genStubs::makeInit {name decl index} {
    append text "    " [lindex $decl 1] ", /* " $index " */n"
    return $text
}
# genStubs::forAllStubs --
#
#	This function iterates over all of the platforms and invokes
#	a callback for each slot.  The result of the callback is then
#	placed inside appropriate platform guards.
#
# Arguments:
#	name		The interface name.
#	slotProc	The proc to invoke to handle the slot.  It will
#			have the interface name, the declaration,  and
#			the index appended.
#	onAll		If 1, emit the skip string even if there are
#			definitions for one or more platforms.
#	textVar		The variable to use for output.
#	skipString	The string to emit if a slot is skipped.  This
#			string will be subst'ed in the loop so "$i" can
#			be used to substitute the index value.
#
# Results:
#	None.
proc genStubs::forAllStubs {name slotProc onAll textVar 
	{skipString {"/* Slot $i is reserved */n"}}} {
    variable stubs
    upvar $textVar text
    set plats [array names stubs $name,*,lastNum]
    if {[info exists stubs($name,generic,lastNum)]} {
	# Emit integrated stubs block
	set lastNum -1
	foreach plat [array names stubs $name,*,lastNum] {
	    if {$stubs($plat) > $lastNum} {
		set lastNum $stubs($plat)
	    }
	}
	for {set i 0} {$i <= $lastNum} {incr i} {
	    set slots [array names stubs $name,*,$i]
	    set emit 0
	    if {[info exists stubs($name,generic,$i)]} {
		if {[llength $slots] > 1} {
		    puts stderr "platform entry duplicates generic entry: $i"
		}
		append text [$slotProc $name $stubs($name,generic,$i) $i]
		set emit 1
	    } elseif {[llength $slots] > 0} {
		foreach plat {unix win mac} {
		    if {[info exists stubs($name,$plat,$i)]} {
			append text [addPlatformGuard $plat 
				[$slotProc $name $stubs($name,$plat,$i) $i]]
			set emit 1
		    } elseif {$onAll} {
			append text [eval {addPlatformGuard $plat} $skipString]
			set emit 1
		    }
		}
                #
                # "aqua" and "macosx" and "x11" are special cases, 
                # since "macosx" always implies "unix" and "aqua", 
                # "macosx", so we need to be careful not to 
                # emit duplicate stubs entries for the two.
                #
		if {[info exists stubs($name,aqua,$i)]
                        && ![info exists stubs($name,macosx,$i)]} {
		    append text [addPlatformGuard aqua 
			    [$slotProc $name $stubs($name,aqua,$i) $i]]
		    set emit 1
		}
		if {[info exists stubs($name,macosx,$i)]
                        && ![info exists stubs($name,unix,$i)]} {
		    append text [addPlatformGuard macosx 
			    [$slotProc $name $stubs($name,macosx,$i) $i]]
		    set emit 1
		}
		if {[info exists stubs($name,x11,$i)]
                        && ![info exists stubs($name,unix,$i)]} {
		    append text [addPlatformGuard x11 
			    [$slotProc $name $stubs($name,x11,$i) $i]]
		    set emit 1
		}
	    }
	    if {$emit == 0} {
		eval {append text} $skipString
	    }
	}
	
    } else {
	# Emit separate stubs blocks per platform
	foreach plat {unix win mac} {
	    if {[info exists stubs($name,$plat,lastNum)]} {
		set lastNum $stubs($name,$plat,lastNum)
		set temp {}
		for {set i 0} {$i <= $lastNum} {incr i} {
		    if {![info exists stubs($name,$plat,$i)]} {
			eval {append temp} $skipString
		    } else {
			append temp [$slotProc $name $stubs($name,$plat,$i) $i]
		    }
		}
		append text [addPlatformGuard $plat $temp]
	    }
	}
        # Again, make sure you don't duplicate entries for macosx & aqua.
	if {[info exists stubs($name,aqua,lastNum)]
                && ![info exists stubs($name,macosx,lastNum)]} {
	    set lastNum $stubs($name,aqua,lastNum)
	    set temp {}
	    for {set i 0} {$i <= $lastNum} {incr i} {
		if {![info exists stubs($name,aqua,$i)]} {
		    eval {append temp} $skipString
		} else {
			append temp [$slotProc $name $stubs($name,aqua,$i) $i]
		    }
		}
		append text [addPlatformGuard aqua $temp]
	    }
        # Again, make sure you don't duplicate entries for macosx & unix.
	if {[info exists stubs($name,macosx,lastNum)]
                && ![info exists stubs($name,unix,lastNum)]} {
	    set lastNum $stubs($name,macosx,lastNum)
	    set temp {}
	    for {set i 0} {$i <= $lastNum} {incr i} {
		if {![info exists stubs($name,macosx,$i)]} {
		    eval {append temp} $skipString
		} else {
			append temp [$slotProc $name $stubs($name,macosx,$i) $i]
		    }
		}
		append text [addPlatformGuard macosx $temp]
	    }
        # Again, make sure you don't duplicate entries for x11 & unix.
	if {[info exists stubs($name,x11,lastNum)]
                && ![info exists stubs($name,unix,lastNum)]} {
	    set lastNum $stubs($name,x11,lastNum)
	    set temp {}
	    for {set i 0} {$i <= $lastNum} {incr i} {
		if {![info exists stubs($name,x11,$i)]} {
		    eval {append temp} $skipString
		} else {
			append temp [$slotProc $name $stubs($name,x11,$i) $i]
		    }
		}
		append text [addPlatformGuard x11 $temp]
	    }
    }
}
# genStubs::emitDeclarations --
#
#	This function emits the function declarations for this interface.
#
# Arguments:
#	name	The interface name.
#	textVar	The variable to use for output.
#
# Results:
#	None.
proc genStubs::emitDeclarations {name textVar} {
    variable stubs
    upvar $textVar text
    append text "n/*n * Exported function declarations:n */nn"
    forAllStubs $name makeDecl 0 text
    return
}
# genStubs::emitMacros --
#
#	This function emits the inline macros for an interface.
#
# Arguments:
#	name	The name of the interface being emitted.
#	textVar	The variable to use for output.
#
# Results:
#	None.
proc genStubs::emitMacros {name textVar} {
    variable stubs
    variable libraryName
    upvar $textVar text
    set upName [string toupper $libraryName]
    append text "n#if defined(USE_${upName}_STUBS) && !defined(USE_${upName}_STUB_PROCS)n"
    append text "n/*n * Inline function declarations:n */nn"
    
    forAllStubs $name makeMacro 0 text
    append text "n#endif /* defined(USE_${upName}_STUBS) && !defined(USE_${upName}_STUB_PROCS) */n"
    return
}
# genStubs::emitHeader --
#
#	This function emits the body of the <name>Decls.h file for
#	the specified interface.
#
# Arguments:
#	name	The name of the interface being emitted.
#
# Results:
#	None.
proc genStubs::emitHeader {name} {
    variable outDir
    variable hooks
    set capName [string toupper [string index $name 0]]
    append capName [string range $name 1 end]
    emitDeclarations $name text
    if {[info exists hooks($name)]} {
	append text "ntypedef struct ${capName}StubHooks {n"
	foreach hook $hooks($name) {
	    set capHook [string toupper [string index $hook 0]]
	    append capHook [string range $hook 1 end]
	    append text "    struct ${capHook}Stubs *${hook}Stubs;n"
	}
	append text "} ${capName}StubHooks;n"
    }
    append text "ntypedef struct ${capName}Stubs {n"
    append text "    int magic;n"
    append text "    struct ${capName}StubHooks *hooks;nn"
    emitSlots $name text
    append text "} ${capName}Stubs;n"
    append text "n#ifdef __cplusplusnextern "C" {n#endifn"
    append text "extern ${capName}Stubs *${name}StubsPtr;n"
    append text "#ifdef __cplusplusn}n#endifn"
    emitMacros $name text
    rewriteFile [file join $outDir ${name}Decls.h] $text
    return
}
# genStubs::emitStubs --
#
#	This function emits the body of the <name>Stubs.c file for
#	the specified interface.
#
# Arguments:
#	name	The name of the interface being emitted.
#
# Results:
#	None.
proc genStubs::emitStubs {name} {
    variable outDir
    append text "n/*n * Exported stub functions:n */nn"
    forAllStubs $name makeStub 0 text
    rewriteFile [file join $outDir ${name}Stubs.c] $text
    return    
}
# genStubs::emitInit --
#
#	Generate the table initializers for an interface.
#
# Arguments:
#	name		The name of the interface to initialize.
#	textVar		The variable to use for output.
#
# Results:
#	Returns the formatted output.
proc genStubs::emitInit {name textVar} {
    variable stubs
    variable hooks
    upvar $textVar text
    set capName [string toupper [string index $name 0]]
    append capName [string range $name 1 end]
    if {[info exists hooks($name)]} {
 	append text "nstatic ${capName}StubHooks ${name}StubHooks = {n"
	set sep "    "
	foreach sub $hooks($name) {
	    append text $sep "&${sub}Stubs"
	    set sep ",n    "
	}
	append text "n};n"
    }
    append text "n${capName}Stubs ${name}Stubs = {n"
    append text "    TCL_STUB_MAGIC,n"
    if {[info exists hooks($name)]} {
	append text "    &${name}StubHooks,n"
    } else {
	append text "    NULL,n"
    }
    
    forAllStubs $name makeInit 1 text {"    NULL, /* $i */n"}
    append text "};n"
    return
}
# genStubs::emitInits --
#
#	This function emits the body of the <name>StubInit.c file for
#	the specified interface.
#
# Arguments:
#	name	The name of the interface being emitted.
#
# Results:
#	None.
proc genStubs::emitInits {} {
    variable hooks
    variable outDir
    variable libraryName
    variable interfaces
    # Assuming that dependencies only go one level deep, we need to emit
    # all of the leaves first to avoid needing forward declarations.
    set leaves {}
    set roots {}
    foreach name [lsort [array names interfaces]] {
	if {[info exists hooks($name)]} {
	    lappend roots $name
	} else {
	    lappend leaves $name
	}
    }
    foreach name $leaves {
	emitInit $name text
    }
    foreach name $roots {
	emitInit $name text
    }
    rewriteFile [file join $outDir ${libraryName}StubInit.c] $text
}
# genStubs::init --
#
#	This is the main entry point.
#
# Arguments:
#	None.
#
# Results:
#	None.
proc genStubs::init {} {
    global argv argv0
    variable outDir
    variable interfaces
    if {[llength $argv] < 2} {
	puts stderr "usage: $argv0 outDir declFile ?declFile...?"
	exit 1
    }
    set outDir [lindex $argv 0]
    foreach file [lrange $argv 1 end] {
	source $file
    }
    foreach name [lsort [array names interfaces]] {
	puts "Emitting $name"
	emitHeader $name
    }
    emitInits
}
# lassign --
#
#	This function emulates the TclX lassign command.
#
# Arguments:
#	valueList	A list containing the values to be assigned.
#	args		The list of variables to be assigned.
#
# Results:
#	Returns any values that were not assigned to variables.
proc lassign {valueList args} {
  if {[llength $args] == 0} {
      error "wrong # args: lassign list varname ?varname..?"
  }
  uplevel [list foreach $args $valueList {break}]
  return [lrange $valueList [llength $args] end]
}
genStubs::init

						