summaryrefslogtreecommitdiffstats
path: root/tools
diff options
context:
space:
mode:
Diffstat (limited to 'tools')
-rw-r--r--tools/genStubs.tcl176
1 files changed, 155 insertions, 21 deletions
diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl
index 009db07..00888c9 100644
--- a/tools/genStubs.tcl
+++ b/tools/genStubs.tcl
@@ -31,6 +31,22 @@ namespace eval genStubs {
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
@@ -92,6 +108,27 @@ proc genStubs::interface {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
@@ -130,7 +167,9 @@ proc genStubs::hooks {names} {
proc genStubs::declare {args} {
variable stubs
variable curName
+ variable revision
+ incr revision
if {[llength $args] == 2} {
lassign $args index decl
set platformList generic
@@ -166,6 +205,25 @@ proc genStubs::declare {args} {
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
@@ -221,25 +279,55 @@ proc genStubs::rewriteFile {file text} {
# Results:
# Returns the original text inside an appropriate #ifdef.
-proc genStubs::addPlatformGuard {plat text} {
+proc genStubs::addPlatformGuard {plat iftxt {eltxt {}}} {
+ set text ""
switch $plat {
win {
- return "#ifdef __WIN32__\n${text}#endif /* __WIN32__ */\n"
+ append text "#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */\n${iftxt}"
+ if {$eltxt != ""} {
+ append text "#else /* WIN */\n${eltxt}"
+ }
+ append text "#endif /* WIN */\n"
}
unix {
- return "#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */\n${text}#endif /* UNIX */\n"
+ append text "#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_TCL)\
+ /* UNIX */\n${iftxt}"
+ if {$eltxt != ""} {
+ append text "#else /* UNIX */\n${eltxt}"
+ }
+ append text "#endif /* UNIX */\n"
}
mac {
- return "#ifdef MAC_TCL\n${text}#endif /* MAC_TCL */\n"
+ append text "#ifdef MAC_TCL\n${iftxt}"
+ if {$eltxt != ""} {
+ append text "#else /* MAC_TCL */\n${eltxt}"
+ }
+ append text "#endif /* MAC_TCL */\n"
}
macosx {
- return "#ifdef MAC_OSX_TCL\n${text}#endif /* MAC_OSX_TCL */\n"
+ append text "#ifdef MAC_OSX_TCL /* MACOSX */\n${iftxt}"
+ if {$eltxt != ""} {
+ append text "#else /* MACOSX */\n${eltxt}"
+ }
+ append text "#endif /* MACOSX */\n"
}
aqua {
- return "#ifdef MAC_OSX_TK\n${text}#endif /* MAC_OSX_TK */\n"
+ append text "#ifdef MAC_OSX_TK /* AQUA */\n${iftxt}"
+ if {$eltxt != ""} {
+ append text "#else /* AQUA */\n${eltxt}"
+ }
+ append text "#endif /* AQUA */\n"
}
x11 {
- return "#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) /* X11 */\n${text}#endif /* X11 */\n"
+ append text "#if !(defined(__WIN32__) || defined(__CYGWIN__) || defined(MAC_TCL) || defined(MAC_OSX_TK))\
+ /* X11 */\n${iftxt}"
+ if {$eltxt != ""} {
+ append text "#else /* X11 */\n${eltxt}"
+ }
+ append text "#endif /* X11 */\n"
+ }
+ default {
+ append text "${iftxt}${eltxt}"
}
}
return $text
@@ -280,8 +368,8 @@ proc genStubs::emitSlots {name textVar} {
proc genStubs::parseDecl {decl} {
if {![regexp {^(.*)\((.*)\)$} $decl all prefix args]} {
- puts stderr "Malformed declaration: $decl"
- return
+ set prefix $decl
+ set args {}
}
set prefix [string trim $prefix]
if {![regexp {^(.+[ ][*]*)([^ *]+)$} $prefix all rtype fname]} {
@@ -289,19 +377,23 @@ proc genStubs::parseDecl {decl} {
return
}
set rtype [string trim $rtype]
+ if {$args == ""} {
+ return [list $rtype $fname {}]
+ }
foreach arg [split $args ,] {
lappend argList [string trim $arg]
}
if {![string compare [lindex $argList end] "..."]} {
- if {[llength $argList] != 2} {
- puts stderr "Only one argument is allowed in varargs form: $decl"
- }
- set arg [parseArg [lindex $argList 0]]
- if {$arg == "" || ([llength $arg] != 2)} {
- puts stderr "Bad argument: '[lindex $argList 0]' in '$decl'"
- return
+ set args 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
+ }
}
- set args [list TCL_VARARGS $arg]
} else {
set args {}
foreach arg $argList {
@@ -359,13 +451,14 @@ proc genStubs::parseArg {arg} {
# Returns the formatted declaration string.
proc genStubs::makeDecl {name decl index} {
+ variable scspec
lassign $decl rtype fname args
append text "/* $index */\n"
if {($rtype != "void") && ($rtype != "pascal void")} {
regsub -all void $rtype VOID rtype
}
- set line "EXTERN $rtype"
+ 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]}]
@@ -373,6 +466,12 @@ proc genStubs::makeDecl {name decl index} {
append line " "
set pad 0
}
+ if {$args eq ""} {
+ append line $fname
+ append text $line
+ append text ";\n"
+ return $text
+ }
append line "$fname _ANSI_ARGS_("
regsub -all void $args VOID args
@@ -470,6 +569,10 @@ proc genStubs::makeSlot {name decl index} {
append lfname [string range $fname 1 end]
set text " "
+ if {$args == ""} {
+ append text $rtype " *" $lfname "; /* $index */\n"
+ return $text
+ }
if {($rtype != "void") && ($rtype != "pascal void")} {
regsub -all void $rtype VOID rtype
}
@@ -485,8 +588,16 @@ proc genStubs::makeSlot {name decl index} {
append text "(void)"
}
TCL_VARARGS {
- set arg [lindex $args 1]
- append text "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
+ set sep "("
+ foreach arg [lrange $args 1 end] {
+ append text $sep [lindex $arg 0]
+ if {[string index $text end] != "*"} {
+ append text " "
+ }
+ append text [lindex $arg 1] [lindex $arg 2]
+ set sep ", "
+ }
+ append text ", ...)"
}
default {
set sep "("
@@ -519,7 +630,11 @@ proc genStubs::makeSlot {name decl index} {
# Returns the formatted declaration string.
proc genStubs::makeInit {name decl index} {
- append text " " [lindex $decl 1] ", /* " $index " */\n"
+ if {[lindex $decl 2] eq ""} {
+ append text " &" [lindex $decl 1] ", /* " $index " */\n"
+ } else {
+ append text " " [lindex $decl 1] ", /* " $index " */\n"
+ }
return $text
}
@@ -728,10 +843,19 @@ proc genStubs::emitMacros {name textVar} {
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 != ""} {
+ set CAPName [string toupper $name]
+ append text "\n"
+ append text "#define ${CAPName}_STUBS_EPOCH $epoch\n"
+ append text "#define ${CAPName}_STUBS_REVISION $revision\n"
+ }
+
emitDeclarations $name text
if {[info exists hooks($name)]} {
@@ -745,6 +869,10 @@ proc genStubs::emitHeader {name} {
}
append text "\ntypedef struct ${capName}Stubs {\n"
append text " int magic;\n"
+ if {$epoch != ""} {
+ append text " int epoch;\n"
+ append text " int revision;\n"
+ }
append text " struct ${capName}StubHooks *hooks;\n\n"
emitSlots $name text
@@ -774,6 +902,7 @@ proc genStubs::emitHeader {name} {
proc genStubs::emitInit {name textVar} {
variable hooks
+ variable epoch
upvar $textVar text
set capName [string toupper [string index $name 0]]
@@ -790,6 +919,11 @@ proc genStubs::emitInit {name textVar} {
}
append text "\n${capName}Stubs ${name}Stubs = \{\n"
append text " TCL_STUB_MAGIC,\n"
+ if {$epoch != ""} {
+ 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 {