diff options
Diffstat (limited to 'generic/ttk/ttkGenStubs.tcl')
| -rw-r--r-- | generic/ttk/ttkGenStubs.tcl | 168 |
1 files changed, 104 insertions, 64 deletions
diff --git a/generic/ttk/ttkGenStubs.tcl b/generic/ttk/ttkGenStubs.tcl index fb9c018..269d3ef 100644 --- a/generic/ttk/ttkGenStubs.tcl +++ b/generic/ttk/ttkGenStubs.tcl @@ -5,26 +5,20 @@ # # # 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.20 +# SOURCE: tcl/tools/genStubs.tcl, revision 1.44 # -# 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) +# CHANGES: # + 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 +package require Tcl 8.4 namespace eval genStubs { # libraryName -- @@ -50,9 +44,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 -- # @@ -60,7 +54,7 @@ namespace eval genStubs { # (@@@TODO: should be an array mapping interface names -> numbers) # - variable epoch 0 + variable epoch {} variable revision 0 # hooks -- @@ -181,13 +175,15 @@ 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 @@ -204,7 +200,6 @@ 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] @@ -214,7 +209,25 @@ 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 } @@ -238,6 +251,7 @@ proc genStubs::rewriteFile {file text} { } set in [open ${file} r] set out [open ${file}.new w] + fconfigure $out -translation lf while {![eof $in]} { set line [gets $in] @@ -272,22 +286,48 @@ 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 "#ifdef __WIN32__ /* WIN */\n${iftxt}" + if {$eltxt ne ""} { + append text "#else /* WIN */\n${eltxt}" + } + append text "#endif /* WIN */\n" } unix { - return "#if !defined(__WIN32__) /* UNIX */\n${text}#endif /* UNIX */\n" + 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" } macosx { - return "#ifdef MAC_OSX_TCL\n${text}#endif /* MAC_OSX_TCL */\n" + append text "#ifdef MAC_OSX_TCL /* MACOSX */\n${iftxt}" + if {$eltxt ne ""} { + 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 ne ""} { + append text "#else /* AQUA */\n${eltxt}" + } + append text "#endif /* AQUA */\n" } x11 { - return "#if !(defined(__WIN32__) || defined(MAC_OSX_TK)) /* X11 */\n${text}#endif /* X11 */\n" + 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 $text @@ -295,7 +335,9 @@ proc genStubs::addPlatformGuard {plat text} { # genStubs::emitSlots -- # -# Generate the stub table slots for the given interface. +# 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. @@ -306,6 +348,7 @@ proc genStubs::addPlatformGuard {plat text} { proc genStubs::emitSlots {name textVar} { upvar $textVar text + forAllStubs $name makeSlot noGuard text {" void (*reserved$i)(void);\n"} return } @@ -334,7 +377,7 @@ proc genStubs::parseDecl {decl} { return } set rtype [string trim $rtype] - if {$args == ""} { + if {$args eq ""} { return [list $rtype $fname {}] } foreach arg [split $args ,] { @@ -382,14 +425,14 @@ proc genStubs::parseDecl {decl} { proc genStubs::parseArg {arg} { if {![regexp {^(.+[ ][*]*)([^][ *]+)(\[\])?$} $arg all type name array]} { - if {$arg == "void"} { + if {$arg eq "void"} { return $arg } else { return } } set result [list [string trim $type] $name] - if {$array != ""} { + if {$array ne ""} { lappend result $array } return $result @@ -409,13 +452,9 @@ 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] @@ -424,7 +463,7 @@ proc genStubs::makeDecl {name decl index} { append line " " set pad 0 } - if {$args == ""} { + if {$args eq ""} { append line $fname append text $line append text ";\n" @@ -432,10 +471,9 @@ 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 { @@ -503,7 +541,7 @@ proc genStubs::makeMacro {name decl index} { append lfname [string range $fname 1 end] set text "#define $fname \\\n\t(" - if {$args == ""} { + if {$args eq ""} { append text "*" } append text "${name}StubsPtr->$lfname)" @@ -530,19 +568,18 @@ proc genStubs::makeSlot {name decl index} { append lfname [string range $fname 1 end] set text " " - if {$rtype != "void"} { - regsub -all void $rtype VOID rtype - } - if {$args == ""} { + if {$args eq ""} { append text $rtype " *" $lfname "; /* $index */\n" return $text } - append text $rtype " (*" $lfname ") " - - regsub -all void $args VOID args + if {[string range $rtype end-7 end] eq "CALLBACK"} { + append text [string trim [string range $rtype 0 end-8]] " (CALLBACK *" $lfname ") " + } else { + append text $rtype " (*" $lfname ") " + } set arg1 [lindex $args 0] switch -exact $arg1 { - VOID { + void { append text "(void)" } TCL_VARARGS { @@ -588,7 +625,7 @@ proc genStubs::makeSlot {name decl index} { # Returns the formatted declaration string. proc genStubs::makeInit {name decl index} { - if {[lindex $decl 2] == ""} { + if {[lindex $decl 2] eq ""} { append text " &" [lindex $decl 1] ", /* " $index " */\n" } else { append text " " [lindex $decl 1] ", /* " $index " */\n" @@ -618,7 +655,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 @@ -641,7 +678,7 @@ proc genStubs::addGuard {status text} { set upName [string toupper $libraryName] switch -- $status { - current { + current { # No change } deprecated { @@ -654,7 +691,7 @@ proc genStubs::addGuard {status text} { puts stderr "Unrecognized status code $status" } } - return $text + return $text } proc genStubs::ifdeffed {macro text} { @@ -725,10 +762,12 @@ proc genStubs::emitHeader {name} { set capName [string toupper [string index $name 0]] append capName [string range $name 1 end] - set CAPName [string toupper $name] - append text "\n" - append text "#define ${CAPName}_STUBS_EPOCH $epoch\n" - append text "#define ${CAPName}_STUBS_REVISION $revision\n" + 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" + } emitDeclarations $name text @@ -743,8 +782,10 @@ proc genStubs::emitHeader {name} { } append text "\ntypedef struct ${capName}Stubs {\n" append text " int magic;\n" - append text " int epoch;\n" - append text " int revision;\n" + if {$epoch ne ""} { + append text " int epoch;\n" + append text " int revision;\n" + } append text " const struct ${capName}StubHooks *hooks;\n\n" emitSlots $name text @@ -776,14 +817,11 @@ 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" @@ -796,21 +834,23 @@ proc genStubs::emitInit {name textVar} { } foreach intf [array names interfaces] { if {[info exists hooks($intf)]} { - if {0<=[lsearch -exact $hooks($intf) $name]} { + if {[lsearch -exact $hooks($intf) $name] >= 0} { set root 0 - break; + break } } } - if {$root} { - append text "\nconst ${capName}Stubs ${name}Stubs = \{\n" - } else { - append text "\nstatic const ${capName}Stubs ${name}Stubs = \{\n" + 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" } - 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 { |