os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tools/genStubs.tcl
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tools/genStubs.tcl Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,967 @@
1.4 +# genStubs.tcl --
1.5 +#
1.6 +# This script generates a set of stub files for a given
1.7 +# interface.
1.8 +#
1.9 +#
1.10 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.11 +# See the file "license.terms" for information on usage and redistribution
1.12 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.13 +#
1.14 +# RCS: @(#) $Id: genStubs.tcl,v 1.13 2002/10/04 08:25:14 dkf Exp $
1.15 +
1.16 +package require Tcl 8
1.17 +
1.18 +namespace eval genStubs {
1.19 + # libraryName --
1.20 + #
1.21 + # The name of the entire library. This value is used to compute
1.22 + # the USE_*_STUB_PROCS macro and the name of the init file.
1.23 +
1.24 + variable libraryName "UNKNOWN"
1.25 +
1.26 + # interfaces --
1.27 + #
1.28 + # An array indexed by interface name that is used to maintain
1.29 + # the set of valid interfaces. The value is empty.
1.30 +
1.31 + array set interfaces {}
1.32 +
1.33 + # curName --
1.34 + #
1.35 + # The name of the interface currently being defined.
1.36 +
1.37 + variable curName "UNKNOWN"
1.38 +
1.39 + # hooks --
1.40 + #
1.41 + # An array indexed by interface name that contains the set of
1.42 + # subinterfaces that should be defined for a given interface.
1.43 +
1.44 + array set hooks {}
1.45 +
1.46 + # stubs --
1.47 + #
1.48 + # This three dimensional array is indexed first by interface name,
1.49 + # second by platform name, and third by a numeric offset or the
1.50 + # constant "lastNum". The lastNum entry contains the largest
1.51 + # numeric offset used for a given interface/platform combo. Each
1.52 + # numeric offset contains the C function specification that
1.53 + # should be used for the given entry in the stub table. The spec
1.54 + # consists of a list in the form returned by parseDecl.
1.55 +
1.56 + array set stubs {}
1.57 +
1.58 + # outDir --
1.59 + #
1.60 + # The directory where the generated files should be placed.
1.61 +
1.62 + variable outDir .
1.63 +}
1.64 +
1.65 +# genStubs::library --
1.66 +#
1.67 +# This function is used in the declarations file to set the name
1.68 +# of the library that the interfaces are associated with (e.g. "tcl").
1.69 +# This value will be used to define the inline conditional macro.
1.70 +#
1.71 +# Arguments:
1.72 +# name The library name.
1.73 +#
1.74 +# Results:
1.75 +# None.
1.76 +
1.77 +proc genStubs::library {name} {
1.78 + variable libraryName $name
1.79 +}
1.80 +
1.81 +# genStubs::interface --
1.82 +#
1.83 +# This function is used in the declarations file to set the name
1.84 +# of the interface currently being defined.
1.85 +#
1.86 +# Arguments:
1.87 +# name The name of the interface.
1.88 +#
1.89 +# Results:
1.90 +# None.
1.91 +
1.92 +proc genStubs::interface {name} {
1.93 + variable curName $name
1.94 + variable interfaces
1.95 +
1.96 + set interfaces($name) {}
1.97 + return
1.98 +}
1.99 +
1.100 +# genStubs::hooks --
1.101 +#
1.102 +# This function defines the subinterface hooks for the current
1.103 +# interface.
1.104 +#
1.105 +# Arguments:
1.106 +# names The ordered list of interfaces that are reachable through the
1.107 +# hook vector.
1.108 +#
1.109 +# Results:
1.110 +# None.
1.111 +
1.112 +proc genStubs::hooks {names} {
1.113 + variable curName
1.114 + variable hooks
1.115 +
1.116 + set hooks($curName) $names
1.117 + return
1.118 +}
1.119 +
1.120 +# genStubs::declare --
1.121 +#
1.122 +# This function is used in the declarations file to declare a new
1.123 +# interface entry.
1.124 +#
1.125 +# Arguments:
1.126 +# index The index number of the interface.
1.127 +# platform The platform the interface belongs to. Should be one
1.128 +# of generic, win, unix, or mac, or macosx or aqua or x11.
1.129 +# decl The C function declaration, or {} for an undefined
1.130 +# entry.
1.131 +#
1.132 +# Results:
1.133 +# None.
1.134 +
1.135 +proc genStubs::declare {args} {
1.136 + variable stubs
1.137 + variable curName
1.138 +
1.139 + if {[llength $args] != 3} {
1.140 + puts stderr "wrong # args: declare $args"
1.141 + }
1.142 + lassign $args index platformList decl
1.143 +
1.144 + # Check for duplicate declarations, then add the declaration and
1.145 + # bump the lastNum counter if necessary.
1.146 +
1.147 + foreach platform $platformList {
1.148 + if {[info exists stubs($curName,$platform,$index)]} {
1.149 + puts stderr "Duplicate entry: declare $args"
1.150 + }
1.151 + }
1.152 + regsub -all "\[ \t\n\]+" [string trim $decl] " " decl
1.153 + set decl [parseDecl $decl]
1.154 +
1.155 + foreach platform $platformList {
1.156 + if {$decl != ""} {
1.157 + set stubs($curName,$platform,$index) $decl
1.158 + if {![info exists stubs($curName,$platform,lastNum)] \
1.159 + || ($index > $stubs($curName,$platform,lastNum))} {
1.160 + set stubs($curName,$platform,lastNum) $index
1.161 + }
1.162 + }
1.163 + }
1.164 + return
1.165 +}
1.166 +
1.167 +# genStubs::rewriteFile --
1.168 +#
1.169 +# This function replaces the machine generated portion of the
1.170 +# specified file with new contents. It looks for the !BEGIN! and
1.171 +# !END! comments to determine where to place the new text.
1.172 +#
1.173 +# Arguments:
1.174 +# file The name of the file to modify.
1.175 +# text The new text to place in the file.
1.176 +#
1.177 +# Results:
1.178 +# None.
1.179 +
1.180 +proc genStubs::rewriteFile {file text} {
1.181 + if {![file exists $file]} {
1.182 + puts stderr "Cannot find file: $file"
1.183 + return
1.184 + }
1.185 + set in [open ${file} r]
1.186 + set out [open ${file}.new w]
1.187 +
1.188 + while {![eof $in]} {
1.189 + set line [gets $in]
1.190 + if {[regexp {!BEGIN!} $line]} {
1.191 + break
1.192 + }
1.193 + puts $out $line
1.194 + }
1.195 + puts $out "/* !BEGIN!: Do not edit below this line. */"
1.196 + puts $out $text
1.197 + while {![eof $in]} {
1.198 + set line [gets $in]
1.199 + if {[regexp {!END!} $line]} {
1.200 + break
1.201 + }
1.202 + }
1.203 + puts $out "/* !END!: Do not edit above this line. */"
1.204 + puts -nonewline $out [read $in]
1.205 + close $in
1.206 + close $out
1.207 + file rename -force ${file}.new ${file}
1.208 + return
1.209 +}
1.210 +
1.211 +# genStubs::addPlatformGuard --
1.212 +#
1.213 +# Wrap a string inside a platform #ifdef.
1.214 +#
1.215 +# Arguments:
1.216 +# plat Platform to test.
1.217 +#
1.218 +# Results:
1.219 +# Returns the original text inside an appropriate #ifdef.
1.220 +
1.221 +proc genStubs::addPlatformGuard {plat text} {
1.222 + switch $plat {
1.223 + win {
1.224 + return "#ifdef __WIN32__\n${text}#endif /* __WIN32__ */\n"
1.225 + }
1.226 + unix {
1.227 + return "#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */\n${text}#endif /* UNIX */\n"
1.228 + }
1.229 + mac {
1.230 + return "#ifdef MAC_TCL\n${text}#endif /* MAC_TCL */\n"
1.231 + }
1.232 + macosx {
1.233 + return "#ifdef MAC_OSX_TCL\n${text}#endif /* MAC_OSX_TCL */\n"
1.234 + }
1.235 + aqua {
1.236 + return "#ifdef MAC_OSX_TK\n${text}#endif /* MAC_OSX_TK */\n"
1.237 + }
1.238 + x11 {
1.239 + return "#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) /* X11 */\n${text}#endif /* X11 */\n"
1.240 + }
1.241 + }
1.242 + return "$text"
1.243 +}
1.244 +
1.245 +# genStubs::emitSlots --
1.246 +#
1.247 +# Generate the stub table slots for the given interface. If there
1.248 +# are no generic slots, then one table is generated for each
1.249 +# platform, otherwise one table is generated for all platforms.
1.250 +#
1.251 +# Arguments:
1.252 +# name The name of the interface being emitted.
1.253 +# textVar The variable to use for output.
1.254 +#
1.255 +# Results:
1.256 +# None.
1.257 +
1.258 +proc genStubs::emitSlots {name textVar} {
1.259 + variable stubs
1.260 + upvar $textVar text
1.261 +
1.262 + forAllStubs $name makeSlot 1 text {" void *reserved$i;\n"}
1.263 + return
1.264 +}
1.265 +
1.266 +# genStubs::parseDecl --
1.267 +#
1.268 +# Parse a C function declaration into its component parts.
1.269 +#
1.270 +# Arguments:
1.271 +# decl The function declaration.
1.272 +#
1.273 +# Results:
1.274 +# Returns a list of the form {returnType name args}. The args
1.275 +# element consists of a list of type/name pairs, or a single
1.276 +# element "void". If the function declaration is malformed
1.277 +# then an error is displayed and the return value is {}.
1.278 +
1.279 +proc genStubs::parseDecl {decl} {
1.280 + if {![regexp {^(.*)\((.*)\)$} $decl all prefix args]} {
1.281 + puts stderr "Malformed declaration: $decl"
1.282 + return
1.283 + }
1.284 + set prefix [string trim $prefix]
1.285 + if {![regexp {^(.+[ ][*]*)([^ *]+)$} $prefix all rtype fname]} {
1.286 + puts stderr "Bad return type: $decl"
1.287 + return
1.288 + }
1.289 + set rtype [string trim $rtype]
1.290 + foreach arg [split $args ,] {
1.291 + lappend argList [string trim $arg]
1.292 + }
1.293 + if {![string compare [lindex $argList end] "..."]} {
1.294 + if {[llength $argList] != 2} {
1.295 + puts stderr "Only one argument is allowed in varargs form: $decl"
1.296 + }
1.297 + set arg [parseArg [lindex $argList 0]]
1.298 + if {$arg == "" || ([llength $arg] != 2)} {
1.299 + puts stderr "Bad argument: '[lindex $argList 0]' in '$decl'"
1.300 + return
1.301 + }
1.302 + set args [list TCL_VARARGS $arg]
1.303 + } else {
1.304 + set args {}
1.305 + foreach arg $argList {
1.306 + set argInfo [parseArg $arg]
1.307 + if {![string compare $argInfo "void"]} {
1.308 + lappend args "void"
1.309 + break
1.310 + } elseif {[llength $argInfo] == 2 || [llength $argInfo] == 3} {
1.311 + lappend args $argInfo
1.312 + } else {
1.313 + puts stderr "Bad argument: '$arg' in '$decl'"
1.314 + return
1.315 + }
1.316 + }
1.317 + }
1.318 + return [list $rtype $fname $args]
1.319 +}
1.320 +
1.321 +# genStubs::parseArg --
1.322 +#
1.323 +# This function parses a function argument into a type and name.
1.324 +#
1.325 +# Arguments:
1.326 +# arg The argument to parse.
1.327 +#
1.328 +# Results:
1.329 +# Returns a list of type and name with an optional third array
1.330 +# indicator. If the argument is malformed, returns "".
1.331 +
1.332 +proc genStubs::parseArg {arg} {
1.333 + if {![regexp {^(.+[ ][*]*)([^][ *]+)(\[\])?$} $arg all type name array]} {
1.334 + if {$arg == "void"} {
1.335 + return $arg
1.336 + } else {
1.337 + return
1.338 + }
1.339 + }
1.340 + set result [list [string trim $type] $name]
1.341 + if {$array != ""} {
1.342 + lappend result $array
1.343 + }
1.344 + return $result
1.345 +}
1.346 +
1.347 +# genStubs::makeDecl --
1.348 +#
1.349 +# Generate the prototype for a function.
1.350 +#
1.351 +# Arguments:
1.352 +# name The interface name.
1.353 +# decl The function declaration.
1.354 +# index The slot index for this function.
1.355 +#
1.356 +# Results:
1.357 +# Returns the formatted declaration string.
1.358 +
1.359 +proc genStubs::makeDecl {name decl index} {
1.360 + lassign $decl rtype fname args
1.361 +
1.362 + append text "/* $index */\n"
1.363 + set line "EXTERN $rtype"
1.364 + set count [expr {2 - ([string length $line] / 8)}]
1.365 + append line [string range "\t\t\t" 0 $count]
1.366 + set pad [expr {24 - [string length $line]}]
1.367 + if {$pad <= 0} {
1.368 + append line " "
1.369 + set pad 0
1.370 + }
1.371 + append line "$fname _ANSI_ARGS_("
1.372 +
1.373 + set arg1 [lindex $args 0]
1.374 + switch -exact $arg1 {
1.375 + void {
1.376 + append line "(void)"
1.377 + }
1.378 + TCL_VARARGS {
1.379 + set arg [lindex $args 1]
1.380 + append line "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
1.381 + }
1.382 + default {
1.383 + set sep "("
1.384 + foreach arg $args {
1.385 + append line $sep
1.386 + set next {}
1.387 + append next [lindex $arg 0] " " [lindex $arg 1] \
1.388 + [lindex $arg 2]
1.389 + if {[string length $line] + [string length $next] \
1.390 + + $pad > 76} {
1.391 + append text $line \n
1.392 + set line "\t\t\t\t"
1.393 + set pad 28
1.394 + }
1.395 + append line $next
1.396 + set sep ", "
1.397 + }
1.398 + append line ")"
1.399 + }
1.400 + }
1.401 + append text $line
1.402 +
1.403 + append text ");\n"
1.404 + return $text
1.405 +}
1.406 +
1.407 +# genStubs::makeMacro --
1.408 +#
1.409 +# Generate the inline macro for a function.
1.410 +#
1.411 +# Arguments:
1.412 +# name The interface name.
1.413 +# decl The function declaration.
1.414 +# index The slot index for this function.
1.415 +#
1.416 +# Results:
1.417 +# Returns the formatted macro definition.
1.418 +
1.419 +proc genStubs::makeMacro {name decl index} {
1.420 + lassign $decl rtype fname args
1.421 +
1.422 + set lfname [string tolower [string index $fname 0]]
1.423 + append lfname [string range $fname 1 end]
1.424 +
1.425 + set text "#ifndef $fname\n#define $fname"
1.426 + set arg1 [lindex $args 0]
1.427 + set argList ""
1.428 + switch -exact $arg1 {
1.429 + void {
1.430 + set argList "()"
1.431 + }
1.432 + TCL_VARARGS {
1.433 + }
1.434 + default {
1.435 + set sep "("
1.436 + foreach arg $args {
1.437 + append argList $sep [lindex $arg 1]
1.438 + set sep ", "
1.439 + }
1.440 + append argList ")"
1.441 + }
1.442 + }
1.443 + append text " \\\n\t(${name}StubsPtr->$lfname)"
1.444 + append text " /* $index */\n#endif\n"
1.445 + return $text
1.446 +}
1.447 +
1.448 +# genStubs::makeStub --
1.449 +#
1.450 +# Emits a stub function definition.
1.451 +#
1.452 +# Arguments:
1.453 +# name The interface name.
1.454 +# decl The function declaration.
1.455 +# index The slot index for this function.
1.456 +#
1.457 +# Results:
1.458 +# Returns the formatted stub function definition.
1.459 +
1.460 +proc genStubs::makeStub {name decl index} {
1.461 + lassign $decl rtype fname args
1.462 +
1.463 + set lfname [string tolower [string index $fname 0]]
1.464 + append lfname [string range $fname 1 end]
1.465 +
1.466 + append text "/* Slot $index */\n" $rtype "\n" $fname
1.467 +
1.468 + set arg1 [lindex $args 0]
1.469 +
1.470 + if {![string compare $arg1 "TCL_VARARGS"]} {
1.471 + lassign [lindex $args 1] type argName
1.472 + append text " TCL_VARARGS_DEF($type,$argName)\n\{\n"
1.473 + append text " " $type " var;\n va_list argList;\n"
1.474 + if {[string compare $rtype "void"]} {
1.475 + append text " " $rtype " resultValue;\n"
1.476 + }
1.477 + append text "\n var = (" $type ") TCL_VARARGS_START(" \
1.478 + $type "," $argName ",argList);\n\n "
1.479 + if {[string compare $rtype "void"]} {
1.480 + append text "resultValue = "
1.481 + }
1.482 + append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n"
1.483 + append text " va_end(argList);\n"
1.484 + if {[string compare $rtype "void"]} {
1.485 + append text "return resultValue;\n"
1.486 + }
1.487 + append text "\}\n\n"
1.488 + return $text
1.489 + }
1.490 +
1.491 + if {![string compare $arg1 "void"]} {
1.492 + set argList "()"
1.493 + set argDecls ""
1.494 + } else {
1.495 + set argList ""
1.496 + set sep "("
1.497 + foreach arg $args {
1.498 + append argList $sep [lindex $arg 1]
1.499 + append argDecls " " [lindex $arg 0] " " \
1.500 + [lindex $arg 1] [lindex $arg 2] ";\n"
1.501 + set sep ", "
1.502 + }
1.503 + append argList ")"
1.504 + }
1.505 + append text $argList "\n" $argDecls "{\n "
1.506 + if {[string compare $rtype "void"]} {
1.507 + append text "return "
1.508 + }
1.509 + append text "(" $name "StubsPtr->" $lfname ")" $argList ";\n}\n\n"
1.510 + return $text
1.511 +}
1.512 +
1.513 +# genStubs::makeSlot --
1.514 +#
1.515 +# Generate the stub table entry for a function.
1.516 +#
1.517 +# Arguments:
1.518 +# name The interface name.
1.519 +# decl The function declaration.
1.520 +# index The slot index for this function.
1.521 +#
1.522 +# Results:
1.523 +# Returns the formatted table entry.
1.524 +
1.525 +proc genStubs::makeSlot {name decl index} {
1.526 + lassign $decl rtype fname args
1.527 +
1.528 + set lfname [string tolower [string index $fname 0]]
1.529 + append lfname [string range $fname 1 end]
1.530 +
1.531 + set text " "
1.532 + append text $rtype " (*" $lfname ") _ANSI_ARGS_("
1.533 +
1.534 + set arg1 [lindex $args 0]
1.535 + switch -exact $arg1 {
1.536 + void {
1.537 + append text "(void)"
1.538 + }
1.539 + TCL_VARARGS {
1.540 + set arg [lindex $args 1]
1.541 + append text "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])"
1.542 + }
1.543 + default {
1.544 + set sep "("
1.545 + foreach arg $args {
1.546 + append text $sep [lindex $arg 0] " " [lindex $arg 1] \
1.547 + [lindex $arg 2]
1.548 + set sep ", "
1.549 + }
1.550 + append text ")"
1.551 + }
1.552 + }
1.553 +
1.554 + append text "); /* $index */\n"
1.555 + return $text
1.556 +}
1.557 +
1.558 +# genStubs::makeInit --
1.559 +#
1.560 +# Generate the prototype for a function.
1.561 +#
1.562 +# Arguments:
1.563 +# name The interface name.
1.564 +# decl The function declaration.
1.565 +# index The slot index for this function.
1.566 +#
1.567 +# Results:
1.568 +# Returns the formatted declaration string.
1.569 +
1.570 +proc genStubs::makeInit {name decl index} {
1.571 + append text " " [lindex $decl 1] ", /* " $index " */\n"
1.572 + return $text
1.573 +}
1.574 +
1.575 +# genStubs::forAllStubs --
1.576 +#
1.577 +# This function iterates over all of the platforms and invokes
1.578 +# a callback for each slot. The result of the callback is then
1.579 +# placed inside appropriate platform guards.
1.580 +#
1.581 +# Arguments:
1.582 +# name The interface name.
1.583 +# slotProc The proc to invoke to handle the slot. It will
1.584 +# have the interface name, the declaration, and
1.585 +# the index appended.
1.586 +# onAll If 1, emit the skip string even if there are
1.587 +# definitions for one or more platforms.
1.588 +# textVar The variable to use for output.
1.589 +# skipString The string to emit if a slot is skipped. This
1.590 +# string will be subst'ed in the loop so "$i" can
1.591 +# be used to substitute the index value.
1.592 +#
1.593 +# Results:
1.594 +# None.
1.595 +
1.596 +proc genStubs::forAllStubs {name slotProc onAll textVar \
1.597 + {skipString {"/* Slot $i is reserved */\n"}}} {
1.598 + variable stubs
1.599 + upvar $textVar text
1.600 +
1.601 + set plats [array names stubs $name,*,lastNum]
1.602 + if {[info exists stubs($name,generic,lastNum)]} {
1.603 + # Emit integrated stubs block
1.604 + set lastNum -1
1.605 + foreach plat [array names stubs $name,*,lastNum] {
1.606 + if {$stubs($plat) > $lastNum} {
1.607 + set lastNum $stubs($plat)
1.608 + }
1.609 + }
1.610 + for {set i 0} {$i <= $lastNum} {incr i} {
1.611 + set slots [array names stubs $name,*,$i]
1.612 + set emit 0
1.613 + if {[info exists stubs($name,generic,$i)]} {
1.614 + if {[llength $slots] > 1} {
1.615 + puts stderr "platform entry duplicates generic entry: $i"
1.616 + }
1.617 + append text [$slotProc $name $stubs($name,generic,$i) $i]
1.618 + set emit 1
1.619 + } elseif {[llength $slots] > 0} {
1.620 + foreach plat {unix win mac} {
1.621 + if {[info exists stubs($name,$plat,$i)]} {
1.622 + append text [addPlatformGuard $plat \
1.623 + [$slotProc $name $stubs($name,$plat,$i) $i]]
1.624 + set emit 1
1.625 + } elseif {$onAll} {
1.626 + append text [eval {addPlatformGuard $plat} $skipString]
1.627 + set emit 1
1.628 + }
1.629 + }
1.630 + #
1.631 + # "aqua" and "macosx" and "x11" are special cases,
1.632 + # since "macosx" always implies "unix" and "aqua",
1.633 + # "macosx", so we need to be careful not to
1.634 + # emit duplicate stubs entries for the two.
1.635 + #
1.636 + if {[info exists stubs($name,aqua,$i)]
1.637 + && ![info exists stubs($name,macosx,$i)]} {
1.638 + append text [addPlatformGuard aqua \
1.639 + [$slotProc $name $stubs($name,aqua,$i) $i]]
1.640 + set emit 1
1.641 + }
1.642 + if {[info exists stubs($name,macosx,$i)]
1.643 + && ![info exists stubs($name,unix,$i)]} {
1.644 + append text [addPlatformGuard macosx \
1.645 + [$slotProc $name $stubs($name,macosx,$i) $i]]
1.646 + set emit 1
1.647 + }
1.648 + if {[info exists stubs($name,x11,$i)]
1.649 + && ![info exists stubs($name,unix,$i)]} {
1.650 + append text [addPlatformGuard x11 \
1.651 + [$slotProc $name $stubs($name,x11,$i) $i]]
1.652 + set emit 1
1.653 + }
1.654 + }
1.655 + if {$emit == 0} {
1.656 + eval {append text} $skipString
1.657 + }
1.658 + }
1.659 +
1.660 + } else {
1.661 + # Emit separate stubs blocks per platform
1.662 + foreach plat {unix win mac} {
1.663 + if {[info exists stubs($name,$plat,lastNum)]} {
1.664 + set lastNum $stubs($name,$plat,lastNum)
1.665 + set temp {}
1.666 + for {set i 0} {$i <= $lastNum} {incr i} {
1.667 + if {![info exists stubs($name,$plat,$i)]} {
1.668 + eval {append temp} $skipString
1.669 + } else {
1.670 + append temp [$slotProc $name $stubs($name,$plat,$i) $i]
1.671 + }
1.672 + }
1.673 + append text [addPlatformGuard $plat $temp]
1.674 + }
1.675 + }
1.676 + # Again, make sure you don't duplicate entries for macosx & aqua.
1.677 + if {[info exists stubs($name,aqua,lastNum)]
1.678 + && ![info exists stubs($name,macosx,lastNum)]} {
1.679 + set lastNum $stubs($name,aqua,lastNum)
1.680 + set temp {}
1.681 + for {set i 0} {$i <= $lastNum} {incr i} {
1.682 + if {![info exists stubs($name,aqua,$i)]} {
1.683 + eval {append temp} $skipString
1.684 + } else {
1.685 + append temp [$slotProc $name $stubs($name,aqua,$i) $i]
1.686 + }
1.687 + }
1.688 + append text [addPlatformGuard aqua $temp]
1.689 + }
1.690 + # Again, make sure you don't duplicate entries for macosx & unix.
1.691 + if {[info exists stubs($name,macosx,lastNum)]
1.692 + && ![info exists stubs($name,unix,lastNum)]} {
1.693 + set lastNum $stubs($name,macosx,lastNum)
1.694 + set temp {}
1.695 + for {set i 0} {$i <= $lastNum} {incr i} {
1.696 + if {![info exists stubs($name,macosx,$i)]} {
1.697 + eval {append temp} $skipString
1.698 + } else {
1.699 + append temp [$slotProc $name $stubs($name,macosx,$i) $i]
1.700 + }
1.701 + }
1.702 + append text [addPlatformGuard macosx $temp]
1.703 + }
1.704 + # Again, make sure you don't duplicate entries for x11 & unix.
1.705 + if {[info exists stubs($name,x11,lastNum)]
1.706 + && ![info exists stubs($name,unix,lastNum)]} {
1.707 + set lastNum $stubs($name,x11,lastNum)
1.708 + set temp {}
1.709 + for {set i 0} {$i <= $lastNum} {incr i} {
1.710 + if {![info exists stubs($name,x11,$i)]} {
1.711 + eval {append temp} $skipString
1.712 + } else {
1.713 + append temp [$slotProc $name $stubs($name,x11,$i) $i]
1.714 + }
1.715 + }
1.716 + append text [addPlatformGuard x11 $temp]
1.717 + }
1.718 + }
1.719 +}
1.720 +
1.721 +# genStubs::emitDeclarations --
1.722 +#
1.723 +# This function emits the function declarations for this interface.
1.724 +#
1.725 +# Arguments:
1.726 +# name The interface name.
1.727 +# textVar The variable to use for output.
1.728 +#
1.729 +# Results:
1.730 +# None.
1.731 +
1.732 +proc genStubs::emitDeclarations {name textVar} {
1.733 + variable stubs
1.734 + upvar $textVar text
1.735 +
1.736 + append text "\n/*\n * Exported function declarations:\n */\n\n"
1.737 + forAllStubs $name makeDecl 0 text
1.738 + return
1.739 +}
1.740 +
1.741 +# genStubs::emitMacros --
1.742 +#
1.743 +# This function emits the inline macros for an interface.
1.744 +#
1.745 +# Arguments:
1.746 +# name The name of the interface being emitted.
1.747 +# textVar The variable to use for output.
1.748 +#
1.749 +# Results:
1.750 +# None.
1.751 +
1.752 +proc genStubs::emitMacros {name textVar} {
1.753 + variable stubs
1.754 + variable libraryName
1.755 + upvar $textVar text
1.756 +
1.757 + set upName [string toupper $libraryName]
1.758 + append text "\n#if defined(USE_${upName}_STUBS) && !defined(USE_${upName}_STUB_PROCS)\n"
1.759 + append text "\n/*\n * Inline function declarations:\n */\n\n"
1.760 +
1.761 + forAllStubs $name makeMacro 0 text
1.762 +
1.763 + append text "\n#endif /* defined(USE_${upName}_STUBS) && !defined(USE_${upName}_STUB_PROCS) */\n"
1.764 + return
1.765 +}
1.766 +
1.767 +# genStubs::emitHeader --
1.768 +#
1.769 +# This function emits the body of the <name>Decls.h file for
1.770 +# the specified interface.
1.771 +#
1.772 +# Arguments:
1.773 +# name The name of the interface being emitted.
1.774 +#
1.775 +# Results:
1.776 +# None.
1.777 +
1.778 +proc genStubs::emitHeader {name} {
1.779 + variable outDir
1.780 + variable hooks
1.781 +
1.782 + set capName [string toupper [string index $name 0]]
1.783 + append capName [string range $name 1 end]
1.784 +
1.785 + emitDeclarations $name text
1.786 +
1.787 + if {[info exists hooks($name)]} {
1.788 + append text "\ntypedef struct ${capName}StubHooks {\n"
1.789 + foreach hook $hooks($name) {
1.790 + set capHook [string toupper [string index $hook 0]]
1.791 + append capHook [string range $hook 1 end]
1.792 + append text " struct ${capHook}Stubs *${hook}Stubs;\n"
1.793 + }
1.794 + append text "} ${capName}StubHooks;\n"
1.795 + }
1.796 + append text "\ntypedef struct ${capName}Stubs {\n"
1.797 + append text " int magic;\n"
1.798 + append text " struct ${capName}StubHooks *hooks;\n\n"
1.799 +
1.800 + emitSlots $name text
1.801 +
1.802 + append text "} ${capName}Stubs;\n"
1.803 +
1.804 + append text "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
1.805 + append text "extern ${capName}Stubs *${name}StubsPtr;\n"
1.806 + append text "#ifdef __cplusplus\n}\n#endif\n"
1.807 +
1.808 + emitMacros $name text
1.809 +
1.810 + rewriteFile [file join $outDir ${name}Decls.h] $text
1.811 + return
1.812 +}
1.813 +
1.814 +# genStubs::emitStubs --
1.815 +#
1.816 +# This function emits the body of the <name>Stubs.c file for
1.817 +# the specified interface.
1.818 +#
1.819 +# Arguments:
1.820 +# name The name of the interface being emitted.
1.821 +#
1.822 +# Results:
1.823 +# None.
1.824 +
1.825 +proc genStubs::emitStubs {name} {
1.826 + variable outDir
1.827 +
1.828 + append text "\n/*\n * Exported stub functions:\n */\n\n"
1.829 + forAllStubs $name makeStub 0 text
1.830 +
1.831 + rewriteFile [file join $outDir ${name}Stubs.c] $text
1.832 + return
1.833 +}
1.834 +
1.835 +# genStubs::emitInit --
1.836 +#
1.837 +# Generate the table initializers for an interface.
1.838 +#
1.839 +# Arguments:
1.840 +# name The name of the interface to initialize.
1.841 +# textVar The variable to use for output.
1.842 +#
1.843 +# Results:
1.844 +# Returns the formatted output.
1.845 +
1.846 +proc genStubs::emitInit {name textVar} {
1.847 + variable stubs
1.848 + variable hooks
1.849 + upvar $textVar text
1.850 +
1.851 + set capName [string toupper [string index $name 0]]
1.852 + append capName [string range $name 1 end]
1.853 +
1.854 + if {[info exists hooks($name)]} {
1.855 + append text "\nstatic ${capName}StubHooks ${name}StubHooks = \{\n"
1.856 + set sep " "
1.857 + foreach sub $hooks($name) {
1.858 + append text $sep "&${sub}Stubs"
1.859 + set sep ",\n "
1.860 + }
1.861 + append text "\n\};\n"
1.862 + }
1.863 + append text "\n${capName}Stubs ${name}Stubs = \{\n"
1.864 + append text " TCL_STUB_MAGIC,\n"
1.865 + if {[info exists hooks($name)]} {
1.866 + append text " &${name}StubHooks,\n"
1.867 + } else {
1.868 + append text " NULL,\n"
1.869 + }
1.870 +
1.871 + forAllStubs $name makeInit 1 text {" NULL, /* $i */\n"}
1.872 +
1.873 + append text "\};\n"
1.874 + return
1.875 +}
1.876 +
1.877 +# genStubs::emitInits --
1.878 +#
1.879 +# This function emits the body of the <name>StubInit.c file for
1.880 +# the specified interface.
1.881 +#
1.882 +# Arguments:
1.883 +# name The name of the interface being emitted.
1.884 +#
1.885 +# Results:
1.886 +# None.
1.887 +
1.888 +proc genStubs::emitInits {} {
1.889 + variable hooks
1.890 + variable outDir
1.891 + variable libraryName
1.892 + variable interfaces
1.893 +
1.894 + # Assuming that dependencies only go one level deep, we need to emit
1.895 + # all of the leaves first to avoid needing forward declarations.
1.896 +
1.897 + set leaves {}
1.898 + set roots {}
1.899 + foreach name [lsort [array names interfaces]] {
1.900 + if {[info exists hooks($name)]} {
1.901 + lappend roots $name
1.902 + } else {
1.903 + lappend leaves $name
1.904 + }
1.905 + }
1.906 + foreach name $leaves {
1.907 + emitInit $name text
1.908 + }
1.909 + foreach name $roots {
1.910 + emitInit $name text
1.911 + }
1.912 +
1.913 + rewriteFile [file join $outDir ${libraryName}StubInit.c] $text
1.914 +}
1.915 +
1.916 +# genStubs::init --
1.917 +#
1.918 +# This is the main entry point.
1.919 +#
1.920 +# Arguments:
1.921 +# None.
1.922 +#
1.923 +# Results:
1.924 +# None.
1.925 +
1.926 +proc genStubs::init {} {
1.927 + global argv argv0
1.928 + variable outDir
1.929 + variable interfaces
1.930 +
1.931 + if {[llength $argv] < 2} {
1.932 + puts stderr "usage: $argv0 outDir declFile ?declFile...?"
1.933 + exit 1
1.934 + }
1.935 +
1.936 + set outDir [lindex $argv 0]
1.937 +
1.938 + foreach file [lrange $argv 1 end] {
1.939 + source $file
1.940 + }
1.941 +
1.942 + foreach name [lsort [array names interfaces]] {
1.943 + puts "Emitting $name"
1.944 + emitHeader $name
1.945 + }
1.946 +
1.947 + emitInits
1.948 +}
1.949 +
1.950 +# lassign --
1.951 +#
1.952 +# This function emulates the TclX lassign command.
1.953 +#
1.954 +# Arguments:
1.955 +# valueList A list containing the values to be assigned.
1.956 +# args The list of variables to be assigned.
1.957 +#
1.958 +# Results:
1.959 +# Returns any values that were not assigned to variables.
1.960 +
1.961 +proc lassign {valueList args} {
1.962 + if {[llength $args] == 0} {
1.963 + error "wrong # args: lassign list varname ?varname..?"
1.964 + }
1.965 +
1.966 + uplevel [list foreach $args $valueList {break}]
1.967 + return [lrange $valueList [llength $args] end]
1.968 +}
1.969 +
1.970 +genStubs::init