summaryrefslogtreecommitdiffstats
path: root/tools/genStubs.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tools/genStubs.tcl')
-rw-r--r--tools/genStubs.tcl432
1 files changed, 315 insertions, 117 deletions
diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl
index 009db07..93a3669 100644
--- a/tools/genStubs.tcl
+++ b/tools/genStubs.tcl
@@ -5,10 +5,12 @@
#
#
# 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
+package require Tcl 8.4
namespace eval genStubs {
# libraryName --
@@ -120,7 +122,7 @@ proc genStubs::hooks {names} {
# Arguments:
# index The index number of the interface.
# platform The platform the interface belongs to. Should be one
-# of generic, win, unix, or mac, or macosx or aqua or x11.
+# of generic, win, unix, or macosx or aqua or x11.
# decl The C function declaration, or {} for an undefined
# entry.
#
@@ -166,6 +168,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
@@ -190,7 +211,7 @@ proc genStubs::rewriteFile {file text} {
while {![eof $in]} {
set line [gets $in]
- if {[regexp {!BEGIN!} $line]} {
+ if {[string match "*!BEGIN!*" $line]} {
break
}
puts $out $line
@@ -199,7 +220,7 @@ proc genStubs::rewriteFile {file text} {
puts $out $text
while {![eof $in]} {
set line [gets $in]
- if {[regexp {!END!} $line]} {
+ if {[string match "*!END!*" $line]} {
break
}
}
@@ -221,25 +242,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__) && !defined(MAC_TCL) /* UNIX */\n${text}#endif /* UNIX */\n"
- }
- mac {
- return "#ifdef MAC_TCL\n${text}#endif /* MAC_TCL */\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_TCL) || 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
@@ -280,8 +324,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 +333,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 {
@@ -362,7 +410,7 @@ proc genStubs::makeDecl {name decl index} {
lassign $decl rtype fname args
append text "/* $index */\n"
- if {($rtype != "void") && ($rtype != "pascal void")} {
+ if {$rtype != "void"} {
regsub -all void $rtype VOID rtype
}
set line "EXTERN $rtype"
@@ -373,7 +421,13 @@ proc genStubs::makeDecl {name decl index} {
append line " "
set pad 0
}
- append line "$fname _ANSI_ARGS_("
+ if {$args == ""} {
+ append line $fname
+ append text $line
+ append text ";\n"
+ return $text
+ }
+ append line $fname
regsub -all void $args VOID args
set arg1 [lindex $args 0]
@@ -382,8 +436,25 @@ proc genStubs::makeDecl {name decl index} {
append line "(void)"
}
TCL_VARARGS {
- set arg [lindex $args 1]
- append line "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
+ 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 ", ...)"
}
default {
set sep "("
@@ -407,7 +478,9 @@ proc genStubs::makeDecl {name decl index} {
append line ")"
}
}
- return "$text$line);\n"
+ append text $line ";"
+ format "#ifndef %s_TCL_DECLARED\n#define %s_TCL_DECLARED\n%s\n#endif\n" \
+ $fname $fname $text
}
# genStubs::makeMacro --
@@ -428,25 +501,11 @@ proc genStubs::makeMacro {name decl index} {
set lfname [string tolower [string index $fname 0]]
append lfname [string range $fname 1 end]
- set text "#ifndef $fname\n#define $fname"
- set arg1 [lindex $args 0]
- set argList ""
- switch -exact $arg1 {
- void {
- set argList "()"
- }
- TCL_VARARGS {
- }
- default {
- set sep "("
- foreach arg $args {
- append argList $sep [lindex $arg 1]
- set sep ", "
- }
- append argList ")"
- }
+ set text "#ifndef $fname\n#define $fname \\\n\t("
+ if {$args == ""} {
+ append text "*"
}
- append text " \\\n\t(${name}StubsPtr->$lfname)"
+ append text "${name}StubsPtr->$lfname)"
append text " /* $index */\n#endif\n"
return $text
}
@@ -470,13 +529,17 @@ proc genStubs::makeSlot {name decl index} {
append lfname [string range $fname 1 end]
set text " "
- if {($rtype != "void") && ($rtype != "pascal void")} {
+ 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] == "__stdcall"} {
- append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") _ANSI_ARGS_("
+ append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") "
} else {
- append text $rtype " (*" $lfname ") _ANSI_ARGS_("
+ append text $rtype " (*" $lfname ") "
}
regsub -all void $args VOID args
set arg1 [lindex $args 0]
@@ -485,8 +548,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] ne "*"} {
+ append text " "
+ }
+ append text [lindex $arg 1] [lindex $arg 2]
+ set sep ", "
+ }
+ append text ", ...)"
}
default {
set sep "("
@@ -502,7 +573,7 @@ proc genStubs::makeSlot {name decl index} {
}
}
- append text "); /* $index */\n"
+ append text "; /* $index */\n"
return $text
}
@@ -519,7 +590,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] == ""} {
+ append text " &" [lindex $decl 1] ", /* " $index " */\n"
+ } else {
+ append text " " [lindex $decl 1] ", /* " $index " */\n"
+ }
return $text
}
@@ -569,100 +644,221 @@ proc genStubs::forAllStubs {name slotProc onAll textVar
append text [$slotProc $name $stubs($name,generic,$i) $i]
set emit 1
} elseif {[llength $slots] > 0} {
- foreach plat {unix win mac} {
- if {[info exists stubs($name,$plat,$i)]} {
- append text [addPlatformGuard $plat \
- [$slotProc $name $stubs($name,$plat,$i) $i]]
- set emit 1
+ 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} {
- append text [eval {addPlatformGuard $plat} $skipString]
- set emit 1
+ eval {append temp} $skipString
}
}
- #
- # "aqua" and "macosx" and "x11" are special cases,
- # since "macosx" always implies "unix" and "aqua",
- # "macosx", so we need to be careful not to
- # emit duplicate stubs entries for the two.
- #
- if {[info exists stubs($name,aqua,$i)]
- && ![info exists stubs($name,macosx,$i)]} {
- append text [addPlatformGuard aqua \
- [$slotProc $name $stubs($name,aqua,$i) $i]]
+ if {$temp ne ""} {
+ append text [addPlatformGuard $plat $temp]
set emit 1
}
- if {[info exists stubs($name,macosx,$i)]
- && ![info exists stubs($name,unix,$i)]} {
- append text [addPlatformGuard macosx \
- [$slotProc $name $stubs($name,macosx,$i) $i]]
+ ## 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
}
- if {[info exists stubs($name,x11,$i)]
- && ![info exists stubs($name,unix,$i)]} {
- append text [addPlatformGuard x11 \
- [$slotProc $name $stubs($name,x11,$i) $i]]
+ ## 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 == 0} {
+ if {!$emit} {
eval {append text} $skipString
}
}
-
} else {
# Emit separate stubs blocks per platform
- foreach plat {unix win mac} {
- if {[info exists stubs($name,$plat,lastNum)]} {
- set lastNum $stubs($name,$plat,lastNum)
- set temp {}
- for {set i 0} {$i <= $lastNum} {incr i} {
- if {![info exists stubs($name,$plat,$i)]} {
- eval {append temp} $skipString
- } else {
- append temp [$slotProc $name $stubs($name,$plat,$i) $i]
- }
+ 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]
}
+ append text [addPlatformGuard $plat $temp]
}
- # Again, make sure you don't duplicate entries for macosx & aqua.
- if {[info exists stubs($name,aqua,lastNum)]
- && ![info exists stubs($name,macosx,lastNum)]} {
- set lastNum $stubs($name,aqua,lastNum)
+ ## 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,aqua,$i)]} {
- eval {append temp} $skipString
+ if {[info exists stubs($name,$plat,$i)]} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
} else {
- append temp [$slotProc $name $stubs($name,aqua,$i) $i]
- }
+ eval {append temp} $skipString
}
- append text [addPlatformGuard aqua $temp]
}
- # Again, make sure you don't duplicate entries for macosx & unix.
- if {[info exists stubs($name,macosx,lastNum)]
- && ![info exists stubs($name,unix,lastNum)]} {
- set lastNum $stubs($name,macosx,lastNum)
+ append text [addPlatformGuard $plat $temp]
+ }
+ ## macosx ##
+ if {$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} {
- if {![info exists stubs($name,macosx,$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
- } else {
- append temp [$slotProc $name $stubs($name,macosx,$i) $i]
+ }
+ }
+ 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
}
}
- append text [addPlatformGuard macosx $temp]
+ if {!$emit} {
+ eval {append temp} $skipString
+ }
}
- # Again, make sure you don't duplicate entries for x11 & unix.
- if {[info exists stubs($name,x11,lastNum)]
- && ![info exists stubs($name,unix,lastNum)]} {
- set lastNum $stubs($name,x11,lastNum)
+ 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} {
- if {![info exists stubs($name,x11,$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]
+ }
+ set emit 1
+ break
+ }
+ }
+ if {!$emit} {
eval {append temp} $skipString
- } else {
- append temp [$slotProc $name $stubs($name,x11,$i) $i]
}
}
append text [addPlatformGuard x11 $temp]
@@ -705,12 +901,14 @@ proc genStubs::emitMacros {name textVar} {
upvar $textVar text
set upName [string toupper $libraryName]
- append text "\n#if defined(USE_${upName}_STUBS) && !defined(USE_${upName}_STUB_PROCS)\n"
+ append text "\n#if defined(USE_${upName}_STUBS) &&\
+ !defined(USE_${upName}_STUB_PROCS)\n"
append text "\n/*\n * Inline function declarations:\n */\n\n"
forAllStubs $name makeMacro 0 text
- append text "\n#endif /* defined(USE_${upName}_STUBS) && !defined(USE_${upName}_STUB_PROCS) */\n"
+ append text "\n#endif /* defined(USE_${upName}_STUBS) &&\
+ !defined(USE_${upName}_STUB_PROCS) */\n"
return
}