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, 0 insertions, 1179 deletions
diff --git a/tkblt/tools/genStubs.tcl b/tkblt/tools/genStubs.tcl
deleted file mode 100644
index 7a75dc6..0000000
--- a/tkblt/tools/genStubs.tcl
+++ /dev/null
@@ -1,1179 +0,0 @@
-# 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-06-01 20:20:28 (GMT)