summaryrefslogtreecommitdiffstats
path: root/tkblt/tools/genStubs.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tkblt/tools/genStubs.tcl')
-rw-r--r--tkblt/tools/genStubs.tcl1179
1 files changed, 1179 insertions, 0 deletions
diff --git a/tkblt/tools/genStubs.tcl b/tkblt/tools/genStubs.tcl
new file mode 100644
index 0000000..7a75dc6
--- /dev/null
+++ b/tkblt/tools/genStubs.tcl
@@ -0,0 +1,1179 @@
+# genStubs.tcl --
+#
+# This script generates a set of stub files for a given
+# interface.
+#
+#
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.4
+
+namespace eval genStubs {
+ # libraryName --
+ #
+ # The name of the entire library. This value is used to compute
+ # the USE_*_STUBS 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"
+
+ # scspec --
+ #
+ # Storage class specifier for external function declarations.
+ # Normally "EXTERN", may be set to something like XYZAPI
+ #
+ variable scspec "EXTERN"
+
+ # epoch, revision --
+ #
+ # The epoch and revision numbers of the interface currently being defined.
+ # (@@@TODO: should be an array mapping interface names -> numbers)
+ #
+
+ variable epoch {}
+ variable revision 0
+
+ # 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::scspec --
+#
+# Define the storage class macro used for external function declarations.
+# Typically, this will be a macro like XYZAPI or EXTERN that
+# expands to either DLLIMPORT or DLLEXPORT, depending on whether
+# -DBUILD_XYZ has been set.
+#
+proc genStubs::scspec {value} {
+ variable scspec $value
+}
+
+# genStubs::epoch --
+#
+# Define the epoch number for this library. The epoch
+# should be incrememented when a release is made that
+# contains incompatible changes to the public API.
+#
+proc genStubs::epoch {value} {
+ variable epoch $value
+}
+
+# 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 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
+ variable revision
+
+ incr revision
+ if {[llength $args] == 2} {
+ lassign $args index decl
+ set platformList generic
+ } elseif {[llength $args] == 3} {
+ lassign $args index platformList decl
+ } else {
+ puts stderr "wrong # args: declare $args"
+ return
+ }
+
+ # 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 "\[ \t\n\]+" [string trim $decl] " " decl
+ set decl [parseDecl $decl]
+
+ foreach platform $platformList {
+ if {$decl ne ""} {
+ 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::export --
+#
+# This function is used in the declarations file to declare a symbol
+# that is exported from the library but is not in the stubs table.
+#
+# Arguments:
+# decl The C function declaration, or {} for an undefined
+# entry.
+#
+# Results:
+# None.
+
+proc genStubs::export {args} {
+ if {[llength $args] != 1} {
+ puts stderr "wrong # args: export $args"
+ }
+ 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]
+ fconfigure $out -translation lf
+
+ while {![eof $in]} {
+ set line [gets $in]
+ if {[string match "*!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 {[string match "*!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 iftxt {eltxt {}} {withCygwin 0}} {
+ set text ""
+ switch $plat {
+ win {
+ append text "#if defined(_WIN32)"
+ if {$withCygwin} {
+ append text " || defined(__CYGWIN__)"
+ }
+ append text " /* WIN */\n${iftxt}"
+ if {$eltxt ne ""} {
+ append text "#else /* WIN */\n${eltxt}"
+ }
+ append text "#endif /* WIN */\n"
+ }
+ unix {
+ append text "#if !defined(_WIN32)"
+ if {$withCygwin} {
+ append text " && !defined(__CYGWIN__)"
+ }
+ append text " && !defined(MAC_OSX_TCL)\
+ /* UNIX */\n${iftxt}"
+ if {$eltxt ne ""} {
+ append text "#else /* UNIX */\n${eltxt}"
+ }
+ append text "#endif /* UNIX */\n"
+ }
+ macosx {
+ append text "#ifdef MAC_OSX_TCL /* MACOSX */\n${iftxt}"
+ if {$eltxt ne ""} {
+ append text "#else /* MACOSX */\n${eltxt}"
+ }
+ append text "#endif /* MACOSX */\n"
+ }
+ aqua {
+ append text "#ifdef MAC_OSX_TK /* AQUA */\n${iftxt}"
+ if {$eltxt ne ""} {
+ append text "#else /* AQUA */\n${eltxt}"
+ }
+ append text "#endif /* AQUA */\n"
+ }
+ x11 {
+ append text "#if !(defined(_WIN32)"
+ if {$withCygwin} {
+ append text " || defined(__CYGWIN__)"
+ }
+ append text " || defined(MAC_OSX_TK))\
+ /* X11 */\n${iftxt}"
+ if {$eltxt ne ""} {
+ append text "#else /* X11 */\n${eltxt}"
+ }
+ append text "#endif /* X11 */\n"
+ }
+ default {
+ append text "${iftxt}${eltxt}"
+ }
+ }
+ 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} {
+ upvar $textVar text
+
+ forAllStubs $name makeSlot 1 text {" void (*reserved$i)(void);\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]} {
+ set prefix $decl
+ set args {}
+ }
+ set prefix [string trim $prefix]
+ if {![regexp {^(.+[ ][*]*)([^ *]+)$} $prefix all rtype fname]} {
+ puts stderr "Bad return type: $decl"
+ return
+ }
+ set rtype [string trim $rtype]
+ if {$args eq ""} {
+ return [list $rtype $fname {}]
+ }
+ foreach arg [split $args ,] {
+ lappend argList [string trim $arg]
+ }
+ if {![string compare [lindex $argList end] "..."]} {
+ set args TCL_VARARGS
+ foreach arg [lrange $argList 0 end-1] {
+ set argInfo [parseArg $arg]
+ if {[llength $argInfo] == 2 || [llength $argInfo] == 3} {
+ lappend args $argInfo
+ } else {
+ puts stderr "Bad argument: '$arg' in '$decl'"
+ return
+ }
+ }
+ } 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 eq "void"} {
+ return $arg
+ } else {
+ return
+ }
+ }
+ set result [list [string trim $type] $name]
+ if {$array ne ""} {
+ 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} {
+ variable scspec
+ lassign $decl rtype fname args
+
+ append text "/* $index */\n"
+ set line "$scspec $rtype"
+ set count [expr {2 - ([string length $line] / 8)}]
+ append line [string range "\t\t\t" 0 $count]
+ set pad [expr {24 - [string length $line]}]
+ if {$pad <= 0} {
+ append line " "
+ set pad 0
+ }
+ if {$args eq ""} {
+ append line $fname
+ append text $line
+ append text ";\n"
+ return $text
+ }
+ append line $fname
+
+ set arg1 [lindex $args 0]
+ switch -exact $arg1 {
+ void {
+ append line "(void)"
+ }
+ TCL_VARARGS {
+ set sep "("
+ foreach arg [lrange $args 1 end] {
+ append line $sep
+ set next {}
+ append next [lindex $arg 0]
+ if {[string index $next end] ne "*"} {
+ append next " "
+ }
+ append next [lindex $arg 1] [lindex $arg 2]
+ if {[string length $line] + [string length $next] \
+ + $pad > 76} {
+ append text [string trimright $line] \n
+ set line "\t\t\t\t"
+ set pad 28
+ }
+ append line $next
+ set sep ", "
+ }
+ append line ", ...)"
+ if {[lindex $args end] eq "{const char *} format"} {
+ append line " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")"
+ }
+ }
+ default {
+ set sep "("
+ foreach arg $args {
+ append line $sep
+ set next {}
+ append next [lindex $arg 0]
+ if {[string index $next end] ne "*"} {
+ append next " "
+ }
+ append next [lindex $arg 1] [lindex $arg 2]
+ if {[string length $line] + [string length $next] \
+ + $pad > 76} {
+ append text [string trimright $line] \n
+ set line "\t\t\t\t"
+ set pad 28
+ }
+ append line $next
+ set sep ", "
+ }
+ append line ")"
+ }
+ }
+ return "$text$line;\n"
+}
+
+# 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 "#define $fname \\\n\t("
+ if {$args eq ""} {
+ append text "*"
+ }
+ append text "${name}StubsPtr->$lfname)"
+ append text " /* $index */\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 " "
+ if {$args eq ""} {
+ append text $rtype " *" $lfname "; /* $index */\n"
+ return $text
+ }
+ if {[string range $rtype end-8 end] eq "__stdcall"} {
+ append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") "
+ } else {
+ append text $rtype " (*" $lfname ") "
+ }
+ set arg1 [lindex $args 0]
+ switch -exact $arg1 {
+ void {
+ append text "(void)"
+ }
+ TCL_VARARGS {
+ set sep "("
+ foreach arg [lrange $args 1 end] {
+ append text $sep [lindex $arg 0]
+ if {[string index $text end] ne "*"} {
+ append text " "
+ }
+ append text [lindex $arg 1] [lindex $arg 2]
+ set sep ", "
+ }
+ append text ", ...)"
+ if {[lindex $args end] eq "{const char *} format"} {
+ append text " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")"
+ }
+ }
+ default {
+ set sep "("
+ foreach arg $args {
+ append text $sep [lindex $arg 0]
+ if {[string index $text end] ne "*"} {
+ append text " "
+ }
+ append text [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} {
+ if {[lindex $decl 2] eq ""} {
+ append text " &" [lindex $decl 1] ", /* " $index " */\n"
+ } else {
+ 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 "conflicting generic and platform entries:\
+ $name $i"
+ }
+ append text [$slotProc $name $stubs($name,generic,$i) $i]
+ set emit 1
+ } elseif {[llength $slots] > 0} {
+ array set slot {unix 0 x11 0 win 0 macosx 0 aqua 0}
+ foreach s $slots {
+ set slot([lindex [split $s ,] 1]) 1
+ }
+ # "aqua", "macosx" and "x11" are special cases:
+ # "macosx" implies "unix", "aqua" implies "macosx" and "x11"
+ # implies "unix", so we need to be careful not to emit
+ # duplicate stubs entries:
+ if {($slot(unix) && $slot(macosx)) || (
+ ($slot(unix) || $slot(macosx)) &&
+ ($slot(x11) || $slot(aqua)))} {
+ puts stderr "conflicting platform entries: $name $i"
+ }
+ ## unix ##
+ set temp {}
+ set plat unix
+ if {!$slot(aqua) && !$slot(x11)} {
+ if {$slot($plat)} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } elseif {$onAll} {
+ eval {append temp} $skipString
+ }
+ }
+ if {$temp ne ""} {
+ append text [addPlatformGuard $plat $temp]
+ set emit 1
+ }
+ ## x11 ##
+ set temp {}
+ set plat x11
+ if {!$slot(unix) && !$slot(macosx)} {
+ if {$slot($plat)} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } elseif {$onAll} {
+ eval {append temp} $skipString
+ }
+ }
+ if {$temp ne ""} {
+ append text [addPlatformGuard $plat $temp]
+ set emit 1
+ }
+ ## win ##
+ set temp {}
+ set plat win
+ if {$slot($plat)} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } elseif {$onAll} {
+ eval {append temp} $skipString
+ }
+ if {$temp ne ""} {
+ append text [addPlatformGuard $plat $temp]
+ set emit 1
+ }
+ ## macosx ##
+ set temp {}
+ set plat macosx
+ if {!$slot(aqua) && !$slot(x11)} {
+ if {$slot($plat)} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } elseif {$slot(unix)} {
+ append temp [$slotProc $name $stubs($name,unix,$i) $i]
+ } elseif {$onAll} {
+ eval {append temp} $skipString
+ }
+ }
+ if {$temp ne ""} {
+ append text [addPlatformGuard $plat $temp]
+ set emit 1
+ }
+ ## aqua ##
+ set temp {}
+ set plat aqua
+ if {!$slot(unix) && !$slot(macosx)} {
+ if {[string range $skipString 1 2] ne "/*"} {
+ # genStubs.tcl previously had a bug here causing it to
+ # erroneously generate both a unix entry and an aqua
+ # entry for a given stubs table slot. To preserve
+ # backwards compatibility, generate a dummy stubs entry
+ # before every aqua entry (note that this breaks the
+ # correspondence between emitted entry number and
+ # actual position of the entry in the stubs table, e.g.
+ # TkIntStubs entry 113 for aqua is in fact at position
+ # 114 in the table, entry 114 at position 116 etc).
+ eval {append temp} $skipString
+ set temp "[string range $temp 0 end-1] /*\
+ Dummy entry for stubs table backwards\
+ compatibility */\n"
+ }
+ if {$slot($plat)} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } elseif {$onAll} {
+ eval {append temp} $skipString
+ }
+ }
+ if {$temp ne ""} {
+ append text [addPlatformGuard $plat $temp]
+ set emit 1
+ }
+ }
+ if {!$emit} {
+ eval {append text} $skipString
+ }
+ }
+ } else {
+ # Emit separate stubs blocks per platform
+ array set block {unix 0 x11 0 win 0 macosx 0 aqua 0}
+ foreach s [array names stubs $name,*,lastNum] {
+ set block([lindex [split $s ,] 1]) 1
+ }
+ ## unix ##
+ if {$block(unix) && !$block(x11)} {
+ set temp {}
+ set plat unix
+ set lastNum $stubs($name,$plat,lastNum)
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ if {[info exists stubs($name,$plat,$i)]} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } else {
+ eval {append temp} $skipString
+ }
+ }
+ append text [addPlatformGuard $plat $temp {} true]
+ }
+ ## win ##
+ if {$block(win)} {
+ set temp {}
+ set plat win
+ set lastNum $stubs($name,$plat,lastNum)
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ if {[info exists stubs($name,$plat,$i)]} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } else {
+ eval {append temp} $skipString
+ }
+ }
+ append text [addPlatformGuard $plat $temp {} true]
+ }
+ ## macosx ##
+ if {($block(unix) || $block(macosx)) && !$block(aqua) && !$block(x11)} {
+ set temp {}
+ set lastNum -1
+ foreach plat {unix macosx} {
+ if {$block($plat)} {
+ set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum)
+ ? $lastNum : $stubs($name,$plat,lastNum)}]
+ }
+ }
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ set emit 0
+ foreach plat {unix macosx} {
+ if {[info exists stubs($name,$plat,$i)]} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ set emit 1
+ break
+ }
+ }
+ if {!$emit} {
+ eval {append temp} $skipString
+ }
+ }
+ append text [addPlatformGuard macosx $temp]
+ }
+ ## aqua ##
+ if {$block(aqua)} {
+ set temp {}
+ set lastNum -1
+ foreach plat {unix macosx aqua} {
+ if {$block($plat)} {
+ set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum)
+ ? $lastNum : $stubs($name,$plat,lastNum)}]
+ }
+ }
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ set emit 0
+ foreach plat {unix macosx aqua} {
+ if {[info exists stubs($name,$plat,$i)]} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ set emit 1
+ break
+ }
+ }
+ if {!$emit} {
+ eval {append temp} $skipString
+ }
+ }
+ append text [addPlatformGuard aqua $temp]
+ }
+ ## x11 ##
+ if {$block(x11)} {
+ set temp {}
+ set lastNum -1
+ foreach plat {unix macosx x11} {
+ if {$block($plat)} {
+ set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum)
+ ? $lastNum : $stubs($name,$plat,lastNum)}]
+ }
+ }
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ set emit 0
+ foreach plat {unix macosx x11} {
+ if {[info exists stubs($name,$plat,$i)]} {
+ if {$plat ne "macosx"} {
+ append temp [$slotProc $name \
+ $stubs($name,$plat,$i) $i]
+ } else {
+ eval {set etxt} $skipString
+ append temp [addPlatformGuard $plat [$slotProc \
+ $name $stubs($name,$plat,$i) $i] $etxt true]
+ }
+ set emit 1
+ break
+ }
+ }
+ if {!$emit} {
+ eval {append temp} $skipString
+ }
+ }
+ append text [addPlatformGuard x11 $temp {} true]
+ }
+ }
+}
+
+# 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} {
+ 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 libraryName
+ upvar $textVar text
+
+ set upName [string toupper $libraryName]
+ append text "\n#if defined(USE_${upName}_STUBS)\n"
+ append text "\n/*\n * Inline function declarations:\n */\n\n"
+
+ forAllStubs $name makeMacro 0 text
+
+ append text "\n#endif /* defined(USE_${upName}_STUBS) */\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
+ variable epoch
+ variable revision
+
+ set capName [string toupper [string index $name 0]]
+ append capName [string range $name 1 end]
+
+ if {$epoch ne ""} {
+ set CAPName [string toupper $name]
+ append text "\n"
+ append text "#define ${CAPName}_STUBS_EPOCH $epoch\n"
+ append text "#define ${CAPName}_STUBS_REVISION $revision\n"
+ }
+
+ append text "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
+
+ emitDeclarations $name text
+
+ if {[info exists hooks($name)]} {
+ append text "\ntypedef struct {\n"
+ foreach hook $hooks($name) {
+ set capHook [string toupper [string index $hook 0]]
+ append capHook [string range $hook 1 end]
+ append text " const struct ${capHook}Stubs *${hook}Stubs;\n"
+ }
+ append text "} ${capName}StubHooks;\n"
+ }
+ append text "\ntypedef struct ${capName}Stubs {\n"
+ append text " int magic;\n"
+ if {$epoch ne ""} {
+ append text " int epoch;\n"
+ append text " int revision;\n"
+ }
+ if {[info exists hooks($name)]} {
+ append text " const ${capName}StubHooks *hooks;\n\n"
+ } else {
+ append text " void *hooks;\n\n"
+ }
+
+ emitSlots $name text
+
+ append text "} ${capName}Stubs;\n\n"
+
+ append text "extern const ${capName}Stubs *${name}StubsPtr;\n\n"
+ append text "#ifdef __cplusplus\n}\n#endif\n"
+
+ emitMacros $name text
+
+ rewriteFile [file join $outDir ${name}Decls.h] $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 hooks
+ variable interfaces
+ variable epoch
+ upvar $textVar text
+ set root 1
+
+ set capName [string toupper [string index $name 0]]
+ append capName [string range $name 1 end]
+
+ if {[info exists hooks($name)]} {
+ append text "\nstatic const ${capName}StubHooks ${name}StubHooks = \{\n"
+ set sep " "
+ foreach sub $hooks($name) {
+ append text $sep "&${sub}Stubs"
+ set sep ",\n "
+ }
+ append text "\n\};\n"
+ }
+ foreach intf [array names interfaces] {
+ if {[info exists hooks($intf)]} {
+ if {[lsearch -exact $hooks($intf) $name] >= 0} {
+ set root 0
+ break
+ }
+ }
+ }
+
+ append text "\n"
+ if {!$root} {
+ append text "static "
+ }
+ append text "const ${capName}Stubs ${name}Stubs = \{\n TCL_STUB_MAGIC,\n"
+ if {$epoch ne ""} {
+ set CAPName [string toupper $name]
+ append text " ${CAPName}_STUBS_EPOCH,\n"
+ append text " ${CAPName}_STUBS_REVISION,\n"
+ }
+ if {[info exists hooks($name)]} {
+ append text " &${name}StubHooks,\n"
+ } else {
+ append text " 0,\n"
+ }
+
+ forAllStubs $name makeInit 1 text {" 0, /* $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.
+
+if {[string length [namespace which lassign]] == 0} {
+ proc lassign {valueList args} {
+ if {[llength $args] == 0} {
+ error "wrong # args: should be \"lassign list varName ?varName ...?\""
+ }
+ uplevel [list foreach $args $valueList {break}]
+ return [lrange $valueList [llength $args] end]
+ }
+}
+
+genStubs::init
generated by cgit v0.12 at 2024-11-10 05:15:11 (GMT)