genstubs.tcl

tcl是工具命令语言

	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}\n\n"
    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 */\n\n"
    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 */\n\n"
    
    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;\n\n"

    emitSlots $name text

    append text "} ${capName}Stubs;\n"

    append text "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
    append text "extern ${capName}Stubs *${name}StubsPtr;\n"
    append text "#ifdef __cplusplus\n}\n#endif\n"

    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 */\n\n"
    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