diff options
Diffstat (limited to 'tools')
| -rw-r--r-- | tools/genStubs.tcl | 176 |
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 { |