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