diff options
Diffstat (limited to 'generic/ttk/ttkGenStubs.tcl')
| -rw-r--r-- | generic/ttk/ttkGenStubs.tcl | 175 |
1 files changed, 66 insertions, 109 deletions
diff --git a/generic/ttk/ttkGenStubs.tcl b/generic/ttk/ttkGenStubs.tcl index d8e9a8a..90dea25 100644 --- a/generic/ttk/ttkGenStubs.tcl +++ b/generic/ttk/ttkGenStubs.tcl @@ -5,20 +5,26 @@ # # # 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. # -# SOURCE: tcl/tools/genStubs.tcl, revision 1.44 +# SOURCE: tcl/tools/genStubs.tcl, revision 1.20 # -# CHANGES: +# CHANGES: +# + Remove xxx_TCL_DECLARED #ifdeffery +# + Use application-defined storage class specifier instead of "EXTERN" +# + Add "epoch" and "revision" fields to stubs table record +# + Remove dead code related to USE_*_STUB_PROCS (emitStubs, makeStub) # + Second argument to "declare" is used as a status guard # instead of a platform guard. +# + Use void (*reserved$i)(void) = 0 instead of void *reserved$i = NULL +# for unused stub entries, in case pointer-to-function and +# pointer-to-object are different sizes. # + Allow trailing semicolon in function declarations +# + stubs table is const-qualified # -package require Tcl 8.4 +package require Tcl 8 namespace eval genStubs { # libraryName -- @@ -44,9 +50,9 @@ namespace eval genStubs { # scspec -- # # Storage class specifier for external function declarations. - # Normally "EXTERN", may be set to something like XYZAPI + # Normally "extern", may be set to something like XYZAPI # - variable scspec "EXTERN" + variable scspec "extern" # epoch, revision -- # @@ -54,7 +60,7 @@ namespace eval genStubs { # (@@@TODO: should be an array mapping interface names -> numbers) # - variable epoch {} + variable epoch 0 variable revision 0 # hooks -- @@ -175,15 +181,13 @@ proc genStubs::hooks {names} { # 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 status current @@ -200,6 +204,7 @@ proc genStubs::declare {args} { if {[info exists stubs($curName,decl,$index)]} { puts stderr "Duplicate entry: $index" } + regsub -all const $decl CONST decl regsub -all "\[ \t\n\]+" [string trim $decl] " " decl set decl [parseDecl $decl] @@ -209,25 +214,7 @@ proc genStubs::declare {args} { if {$index > $stubs($curName,lastNum)} { set stubs($curName,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 } @@ -286,48 +273,22 @@ proc genStubs::rewriteFile {file text} { # Results: # Returns the original text inside an appropriate #ifdef. -proc genStubs::addPlatformGuard {plat iftxt {eltxt {}}} { - set text "" +proc genStubs::addPlatformGuard {plat text} { switch $plat { win { - append text "#ifdef __WIN32__ /* WIN */\n${iftxt}" - if {$eltxt ne ""} { - append text "#else /* WIN */\n${eltxt}" - } - append text "#endif /* WIN */\n" + return "#ifdef __WIN32__\n${text}#endif /* __WIN32__ */\n" } unix { - append text "#if !defined(__WIN32__) && !defined(MAC_OSX_TCL)\ - /* UNIX */\n${iftxt}" - if {$eltxt ne ""} { - append text "#else /* UNIX */\n${eltxt}" - } - append text "#endif /* UNIX */\n" + return "#if !defined(__WIN32__) /* UNIX */\n${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" + return "#ifdef MAC_OSX_TCL\n${text}#endif /* MAC_OSX_TCL */\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" + return "#ifdef MAC_OSX_TK\n${text}#endif /* MAC_OSX_TK */\n" } x11 { - append text "#if !(defined(__WIN32__) || 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 "#if !(defined(__WIN32__) || defined(MAC_OSX_TK)) /* X11 */\n${text}#endif /* X11 */\n" } } return $text @@ -335,9 +296,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}}} { # 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. +# Generate the stub table slots for the given interface. # # Arguments: # name The name of the interface being emitted. @@ -348,7 +307,6 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}}} { proc genStubs::emitSlots {name textVar} { upvar $textVar text - forAllStubs $name makeSlot noGuard text {" void (*reserved$i)(void);\n"} return } @@ -377,7 +335,7 @@ proc genStubs::parseDecl {decl} { return } set rtype [string trim $rtype] - if {$args eq ""} { + if {$args == ""} { return [list $rtype $fname {}] } foreach arg [split $args ,] { @@ -425,14 +383,14 @@ proc genStubs::parseDecl {decl} { proc genStubs::parseArg {arg} { if {![regexp {^(.+[ ][*]*)([^][ *]+)(\[\])?$} $arg all type name array]} { - if {$arg eq "void"} { + if {$arg == "void"} { return $arg } else { return } } set result [list [string trim $type] $name] - if {$array ne ""} { + if {$array != ""} { lappend result $array } return $result @@ -452,9 +410,13 @@ proc genStubs::parseArg {arg} { proc genStubs::makeDecl {name decl index} { variable scspec + lassign $decl rtype fname args append text "/* $index */\n" + if {$rtype != "void"} { + regsub -all void $rtype VOID rtype + } set line "$scspec $rtype" set count [expr {2 - ([string length $line] / 8)}] append line [string range "\t\t\t" 0 $count] @@ -463,7 +425,7 @@ proc genStubs::makeDecl {name decl index} { append line " " set pad 0 } - if {$args eq ""} { + if {$args == ""} { append line $fname append text $line append text ";\n" @@ -471,9 +433,10 @@ proc genStubs::makeDecl {name decl index} { } append line $fname + regsub -all void $args VOID args set arg1 [lindex $args 0] switch -exact $arg1 { - void { + VOID { append line "(void)" } TCL_VARARGS { @@ -541,7 +504,7 @@ proc genStubs::makeMacro {name decl index} { append lfname [string range $fname 1 end] set text "#define $fname \\\n\t(" - if {$args eq ""} { + if {$args == ""} { append text "*" } append text "${name}StubsPtr->$lfname)" @@ -568,18 +531,19 @@ proc genStubs::makeSlot {name decl index} { append lfname [string range $fname 1 end] set text " " - if {$args eq ""} { + if {$rtype != "void"} { + regsub -all void $rtype VOID rtype + } + if {$args == ""} { 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 ") " - } + append text $rtype " (*" $lfname ") " + + regsub -all void $args VOID args set arg1 [lindex $args 0] switch -exact $arg1 { - void { + VOID { append text "(void)" } TCL_VARARGS { @@ -625,7 +589,7 @@ proc genStubs::makeSlot {name decl index} { # Returns the formatted declaration string. proc genStubs::makeInit {name decl index} { - if {[lindex $decl 2] eq ""} { + if {[lindex $decl 2] == ""} { append text " &" [lindex $decl 1] ", /* " $index " */\n" } else { append text " " [lindex $decl 1] ", /* " $index " */\n" @@ -655,7 +619,7 @@ proc genStubs::makeInit {name decl index} { # None. proc genStubs::forAllStubs {name slotProc guardProc textVar - {skipString {"/* Slot $i is reserved */\n"}}} { + {skipString {"/* Slot $i is reserved */\n"}}} { variable stubs upvar $textVar text @@ -678,7 +642,7 @@ proc genStubs::addGuard {status text} { set upName [string toupper $libraryName] switch -- $status { - current { + current { # No change } deprecated { @@ -691,7 +655,7 @@ proc genStubs::addGuard {status text} { puts stderr "Unrecognized status code $status" } } - return $text + return $text } proc genStubs::ifdeffed {macro text} { @@ -762,17 +726,15 @@ proc genStubs::emitHeader {name} { 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" - } + 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)]} { - append text "\ntypedef struct {\n" + 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] @@ -782,15 +744,9 @@ proc genStubs::emitHeader {name} { } 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" - } + append text " int epoch;\n" + append text " int revision;\n" + append text " const struct ${capName}StubHooks *hooks;\n\n" emitSlots $name text @@ -821,11 +777,14 @@ proc genStubs::emitInit {name textVar} { variable hooks variable interfaces variable epoch + variable revision + upvar $textVar text set root 1 set capName [string toupper [string index $name 0]] append capName [string range $name 1 end] + set CAPName [string toupper $name] if {[info exists hooks($name)]} { append text "\nstatic const ${capName}StubHooks ${name}StubHooks = \{\n" @@ -838,23 +797,21 @@ proc genStubs::emitInit {name textVar} { } foreach intf [array names interfaces] { if {[info exists hooks($intf)]} { - if {[lsearch -exact $hooks($intf) $name] >= 0} { + if {0<=[lsearch -exact $hooks($intf) $name]} { set root 0 - break + 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 {$root} { + append text "\nconst ${capName}Stubs ${name}Stubs = \{\n" + } else { + append text "\nstatic const ${capName}Stubs ${name}Stubs = \{\n" } + append text " TCL_STUB_MAGIC,\n" + append text " ${CAPName}_STUBS_EPOCH,\n" + append text " ${CAPName}_STUBS_REVISION,\n" if {[info exists hooks($name)]} { append text " &${name}StubHooks,\n" } else { |