package require Tcl 8
namespace eval genStubs {
variable libraryName "UNKNOWN"
array set interfaces {}
variable curName "UNKNOWN"
array set hooks {}
array set stubs {}
variable outDir .
}
proc genStubs::library {name} {
variable libraryName $name
}
proc genStubs::interface {name} {
variable curName $name
variable interfaces
set interfaces($name) {}
return
}
proc genStubs::hooks {names} {
variable curName
variable hooks
set hooks($curName) $names
return
}
proc genStubs::declare {args} {
variable stubs
variable curName
if {[llength $args] != 3} {
puts stderr "wrong # args: declare $args"
}
lassign $args index platformList decl
foreach platform $platformList {
if {[info exists stubs($curName,$platform,$index)]} {
puts stderr "Duplicate entry: declare $args"
}
}
regsub -all "\[ \t\n\]+" [string trim $decl] " " decl
set decl [parseDecl $decl]
foreach platform $platformList {
if {$decl != ""} {
set stubs($curName,$platform,$index) $decl
if {![info exists stubs($curName,$platform,lastNum)] \
|| ($index > $stubs($curName,$platform,lastNum))} {
set stubs($curName,$platform,lastNum) $index
}
}
}
return
}
proc genStubs::rewriteFile {file text} {
if {![file exists $file]} {
puts stderr "Cannot find file: $file"
return
}
set in [open ${file} r]
set out [open ${file}.new w]
while {![eof $in]} {
set line [gets $in]
if {[regexp {!BEGIN!} $line]} {
break
}
puts $out $line
}
puts $out "/* !BEGIN!: Do not edit below this line. */"
puts $out $text
while {![eof $in]} {
set line [gets $in]
if {[regexp {!END!} $line]} {
break
}
}
puts $out "/* !END!: Do not edit above this line. */"
puts -nonewline $out [read $in]
close $in
close $out
file rename -force ${file}.new ${file}
return
}
proc genStubs::addPlatformGuard {plat text} {
switch $plat {
win {
return "#ifdef __WIN32__\n${text}#endif /* __WIN32__ */\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"
}
macosx {
return "#ifdef MAC_OSX_TCL\n${text}#endif /* MAC_OSX_TCL */\n"
}
aqua {
return "#ifdef MAC_OSX_TK\n${text}#endif /* MAC_OSX_TK */\n"
}
x11 {
return "#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) /* X11 */\n${text}#endif /* X11 */\n"
}
}
return "$text"
}
proc genStubs::emitSlots {name textVar} {
variable stubs
upvar $textVar text
forAllStubs $name makeSlot 1 text {" void *reserved$i;\n"}
return
}
proc genStubs::parseDecl {decl} {
if {![regexp {^(.*)\((.*)\)$} $decl all prefix args]} {
puts stderr "Malformed declaration: $decl"
return
}
set prefix [string trim $prefix]
if {![regexp {^(.+[ ][*]*)([^ *]+)$} $prefix all rtype fname]} {
puts stderr "Bad return type: $decl"
return
}
set rtype [string trim $rtype]
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 [list TCL_VARARGS $arg]
} else {
set args {}
foreach arg $argList {
set argInfo [parseArg $arg]
if {![string compare $argInfo "void"]} {
lappend args "void"
break
} elseif {[llength $argInfo] == 2 || [llength $argInfo] == 3} {
lappend args $argInfo
} else {
puts stderr "Bad argument: '$arg' in '$decl'"
return
}
}
}
return [list $rtype $fname $args]
}
proc genStubs::parseArg {arg} {
if {![regexp {^(.+[ ][*]*)([^][ *]+)(\[\])?$} $arg all type name array]} {
if {$arg == "void"} {
return $arg
} else {
return
}
}
set result [list [string trim $type] $name]
if {$array != ""} {
lappend result $array
}
return $result
}
proc genStubs::makeDecl {name decl index} {
lassign $decl rtype fname args
append text "/* $index */\n"
set line "EXTERN $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]}]
if {$pad <= 0} {
append line " "
set pad 0
}
append line "$fname _ANSI_ARGS_("
set arg1 [lindex $args 0]
switch -exact $arg1 {
void {
append line "(void)"
}
TCL_VARARGS {
set arg [lindex $args 1]
append line "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
}
default {
set sep "("
foreach arg $args {
append line $sep
set next {}
append next [lindex $arg 0] " " [lindex $arg 1] \
[lindex $arg 2]
if {[string length $line] + [string length $next] \
+ $pad > 76} {
append text $line \n
set line "\t\t\t\t"
set pad 28
}
append line $next
set sep ", "
}
append line ")"
}
}
append text $line
append text ");\n"
return $text
}
proc genStubs::makeMacro {name decl index} {
lassign $decl rtype fname args
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 ")"
}
}
append text " \\\n\t(${name}StubsPtr->$lfname)"
append text " /* $index */\n#endif\n"
return $text
}
proc genStubs::makeStub {name decl index} {
lassign $decl rtype fname args
set lfname [string tolower [string index $fname 0]]
append lfname [string range $fname 1 end]
append text "/* Slot $index */\n" $rtype "\n" $fname
set arg1 [lindex $args 0]
if {![string compare $arg1 "TCL_VARARGS"]} {
lassign [lindex $args 1] type argName
append text " TCL_VARARGS_DEF($type,$argName)\n\{\n"
append text " " $type " var;\n va_list argList;\n"
if {[string compare $rtype "void"]} {
append text " " $rtype " resultValue;\n"
}
append text "\n var = (" $type ") TCL_VARARGS_START(" \
$type "," $argName ",argList);\n\n "
if {[string compare $rtype "void"]} {
append text "resultValue = "
}
append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n"
append text " va_end(argList);\n"
if {[string compare $rtype "void"]} {
append text "return resultValue;\n"
}
append text "\}\n\n"
return $text
}
if {![string compare $arg1 "void"]} {
set argList "()"
set argDecls ""
} else {
set argList ""
set sep "("
foreach arg $args {
append argList $sep [lindex $arg 1]
append argDecls " " [lindex $arg 0] " " \
[lindex $arg 1] [lindex $arg 2] ";\n"
set sep ", "
}
append argList ")"
}
append text $argList "\n" $argDecls "{\n "
if {[string compare $rtype "void"]} {
append text "return "
}
append text "(" $name "StubsPtr->" $lfname ")" $argList ";\n}\n\n"
return $text
}
proc genStubs::makeSlot {name decl index} {
lassign $decl rtype fname args
set lfname [string tolower [string index $fname 0]]
append lfname [string range $fname 1 end]
set text " "
append text $rtype " (*" $lfname ") _ANSI_ARGS_("
set arg1 [lindex $args 0]
switch -exact $arg1 {
void {
append text "(void)"
}
TCL_VARARGS {
set arg [lindex $args 1]
append text "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
}
default {
set sep "("
foreach arg $args {
append text $sep [lindex $arg 0] " " [lindex $arg 1] \
[lindex $arg 2]
set sep ", "
}
append text ")"
}
}
append text "); /* $index */\n"
return $text
}
proc genStubs::makeInit {name decl index} {
append text " " [lindex $decl 1] ", /* " $index " */\n"
return $text
}
proc genStubs::forAllStubs {name slotProc onAll textVar \
{skipString {"/* Slot $i is reserved */\n"}}} {
variable stubs
upvar $textVar text
set plats [array names stubs $name,*,lastNum]
if {[info exists stubs($name,generic,lastNum)]} {
set lastNum -1
foreach plat [array names stubs $name,*,lastNum] {
if {$stubs($plat) > $lastNum} {
set lastNum $stubs($plat)
}
}
for {set i 0} {$i <= $lastNum} {incr i} {
set slots [array names stubs $name,*,$i]
set emit 0
if {[info exists stubs($name,generic,$i)]} {
if {[llength $slots] > 1} {
puts stderr "platform entry duplicates generic entry: $i"
}
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
} elseif {$onAll} {
append text [eval {addPlatformGuard $plat} $skipString]
set emit 1
}
}
if {[info exists stubs($name,aqua,$i)]
&& ![info exists stubs($name,macosx,$i)]} {
append text [addPlatformGuard aqua \
[$slotProc $name $stubs($name,aqua,$i) $i]]
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]]
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]]
set emit 1
}
}
if {$emit == 0} {
eval {append text} $skipString
}
}
} else {
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]
}
}
append text [addPlatformGuard $plat $temp]
}
}
if {[info exists stubs($name,aqua,lastNum)]
&& ![info exists stubs($name,macosx,lastNum)]} {
set lastNum $stubs($name,aqua,lastNum)
set temp {}
for {set i 0} {$i <= $lastNum} {incr i} {
if {![info exists stubs($name,aqua,$i)]} {
eval {append temp} $skipString
} else {
append temp [$slotProc $name $stubs($name,aqua,$i) $i]
}
}
append text [addPlatformGuard aqua $temp]
}
if {[info exists stubs($name,macosx,lastNum)]
&& ![info exists stubs($name,unix,lastNum)]} {
set lastNum $stubs($name,macosx,lastNum)
set temp {}
for {set i 0} {$i <= $lastNum} {incr i} {
if {![info exists stubs($name,macosx,$i)]} {
eval {append temp} $skipString
} else {
append temp [$slotProc $name $stubs($name,macosx,$i) $i]
}
}
append text [addPlatformGuard macosx $temp]
}
if {[info exists stubs($name,x11,lastNum)]
&& ![info exists stubs($name,unix,lastNum)]} {
set lastNum $stubs($name,x11,lastNum)
set temp {}
for {set i 0} {$i <= $lastNum} {incr i} {
if {![info exists stubs($name,x11,$i)]} {
eval {append temp} $skipString
} else {
append temp [$slotProc $name $stubs($name,x11,$i) $i]
}
}
append text [addPlatformGuard x11 $temp]
}
}
}
proc genStubs::emitDeclarations {name textVar} {
variable stubs
upvar $textVar text
append text "\n/*\n * Exported function declarations:\n */\n\n"
forAllStubs $name makeDecl 0 text
return
}
proc genStubs::emitMacros {name textVar} {
variable stubs
variable libraryName
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/*\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"
return
}
proc genStubs::emitHeader {name} {
variable outDir
variable hooks
set capName [string toupper [string index $name 0]]
append capName [string range $name 1 end]
emitDeclarations $name text
if {[info exists hooks($name)]} {
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]
append text " struct ${capHook}Stubs *${hook}Stubs;\n"
}
append text "} ${capName}StubHooks;\n"
}
append text "\ntypedef struct ${capName}Stubs {\n"
append text " int magic;\n"
append text " struct ${capName}StubHooks *hooks;\n\n"
emitSlots $name text
append text "} ${capName}Stubs;\n"
append text "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
append text "extern ${capName}Stubs *${name}StubsPtr;\n"
append text "#ifdef __cplusplus\n}\n#endif\n"
emitMacros $name text
rewriteFile [file join $outDir ${name}Decls.h] $text
return
}
proc genStubs::emitStubs {name} {
variable outDir
append text "\n/*\n * Exported stub functions:\n */\n\n"
forAllStubs $name makeStub 0 text
rewriteFile [file join $outDir ${name}Stubs.c] $text
return
}
proc genStubs::emitInit {name textVar} {
variable stubs
variable hooks
upvar $textVar text
set capName [string toupper [string index $name 0]]
append capName [string range $name 1 end]
if {[info exists hooks($name)]} {
append text "\nstatic ${capName}StubHooks ${name}StubHooks = \{\n"
set sep " "
foreach sub $hooks($name) {
append text $sep "&${sub}Stubs"
set sep ",\n "
}
append text "\n\};\n"
}
append text "\n${capName}Stubs ${name}Stubs = \{\n"
append text " TCL_STUB_MAGIC,\n"
if {[info exists hooks($name)]} {
append text " &${name}StubHooks,\n"
} else {
append text " NULL,\n"
}
forAllStubs $name makeInit 1 text {" NULL, /* $i */\n"}
append text "\};\n"
return
}
proc genStubs::emitInits {} {
variable hooks
variable outDir
variable libraryName
variable interfaces
set leaves {}
set roots {}
foreach name [lsort [array names interfaces]] {
if {[info exists hooks($name)]} {
lappend roots $name
} else {
lappend leaves $name
}
}
foreach name $leaves {
emitInit $name text
}
foreach name $roots {
emitInit $name text
}
rewriteFile [file join $outDir ${libraryName}StubInit.c] $text
}
proc genStubs::init {} {
global argv argv0
variable outDir
variable interfaces
if {[llength $argv] < 2} {
puts stderr "usage: $argv0 outDir declFile ?declFile...?"
exit 1
}
set outDir [lindex $argv 0]
foreach file [lrange $argv 1 end] {
source $file
}
foreach name [lsort [array names interfaces]] {
puts "Emitting $name"
emitHeader $name
}
emitInits
}
proc lassign {valueList args} {
if {[llength $args] == 0} {
error "wrong # args: lassign list varname ?varname..?"
}
uplevel [list foreach $args $valueList {break}]
return [lrange $valueList [llength $args] end]
}
genStubs::init