# genStubs.tcl -- # # This script generates a set of stub files for a given # interface. # # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2007 Daniel A. Steffen # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: genStubs.tcl,v 1.22.2.7 2011/01/19 14:02:19 nijtmans Exp $ package require Tcl 8.4 namespace eval genStubs { # libraryName -- # # The name of the entire library. This value is used to compute # the USE_*_STUBS macro and the name of the init file. variable libraryName "UNKNOWN" # interfaces -- # # An array indexed by interface name that is used to maintain # the set of valid interfaces. The value is empty. array set interfaces {} # curName -- # # The name of the interface currently being defined. variable curName "UNKNOWN" # hooks -- # # An array indexed by interface name that contains the set of # subinterfaces that should be defined for a given interface. array set hooks {} # stubs -- # # This three dimensional array is indexed first by interface name, # second by platform name, and third by a numeric offset or the # constant "lastNum". The lastNum entry contains the largest # numeric offset used for a given interface/platform combo. Each # numeric offset contains the C function specification that # should be used for the given entry in the stub table. The spec # consists of a list in the form returned by parseDecl. array set stubs {} # outDir -- # # The directory where the generated files should be placed. variable outDir . } # genStubs::library -- # # This function is used in the declarations file to set the name # of the library that the interfaces are associated with (e.g. "tcl"). # This value will be used to define the inline conditional macro. # # Arguments: # name The library name. # # Results: # None. proc genStubs::library {name} { variable libraryName $name } # genStubs::interface -- # # This function is used in the declarations file to set the name # of the interface currently being defined. # # Arguments: # name The name of the interface. # # Results: # None. proc genStubs::interface {name} { variable curName $name variable interfaces set interfaces($name) {} return } # genStubs::hooks -- # # This function defines the subinterface hooks for the current # interface. # # Arguments: # names The ordered list of interfaces that are reachable through the # hook vector. # # Results: # None. proc genStubs::hooks {names} { variable curName variable hooks set hooks($curName) $names return } # genStubs::declare -- # # This function is used in the declarations file to declare a new # interface entry. # # Arguments: # index The index number of the interface. # platform The platform the interface belongs to. Should be one # of generic, win, unix, or macosx or aqua or x11. # decl The C function declaration, or {} for an undefined # entry. # # Results: # None. proc genStubs::declare {args} { variable stubs variable curName if {[llength $args] == 2} { lassign $args index decl set platformList generic } elseif {[llength $args] == 3} { lassign $args index platformList decl } else { puts stderr "wrong # args: declare $args" return } # Check for duplicate declarations, then add the declaration and # bump the lastNum counter if necessary. foreach platform $platformList { if {[info exists stubs($curName,$platform,$index)]} { puts stderr "Duplicate entry: declare $args" } } regsub -all const $decl CONST decl regsub -all _XCONST $decl _Xconst decl 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 } # 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 # specified file with new contents. It looks for the !BEGIN! and # !END! comments to determine where to place the new text. # # Arguments: # file The name of the file to modify. # text The new text to place in the file. # # Results: # None. 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 {[string match "*!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 {[string match "*!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 } # genStubs::addPlatformGuard -- # # Wrap a string inside a platform #ifdef. # # Arguments: # plat Platform to test. # # Results: # Returns the original text inside an appropriate #ifdef. proc genStubs::addPlatformGuard {plat iftxt {eltxt {}}} { set 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" } 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" } macosx { append text "#ifdef MAC_OSX_TCL /* MACOSX */\n${iftxt}" if {$eltxt ne ""} { append text "#else /* MACOSX */\n${eltxt}" } append text "#endif /* MACOSX */\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" } 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 $text } # 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. # # Arguments: # name The name of the interface being emitted. # textVar The variable to use for output. # # Results: # None. proc genStubs::emitSlots {name textVar} { upvar $textVar text forAllStubs $name makeSlot 1 text {" void *reserved$i;\n"} return } # genStubs::parseDecl -- # # Parse a C function declaration into its component parts. # # Arguments: # decl The function declaration. # # Results: # Returns a list of the form {returnType name args}. The args # element consists of a list of type/name pairs, or a single # element "void". If the function declaration is malformed # then an error is displayed and the return value is {}. proc genStubs::parseDecl {decl} { if {![regexp {^(.*)\((.*)\)$} $decl all prefix args]} { set prefix $decl set args {} } set prefix [string trim $prefix] if {![regexp {^(.+[ ][*]*)([^ *]+)$} $prefix all rtype fname]} { puts stderr "Bad return type: $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] "..."]} { 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 } } } 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] } # genStubs::parseArg -- # # This function parses a function argument into a type and name. # # Arguments: # arg The argument to parse. # # Results: # Returns a list of type and name with an optional third array # indicator. If the argument is malformed, returns "". 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 } # genStubs::makeDecl -- # # Generate the prototype for a function. # # Arguments: # name The interface name. # decl The function declaration. # index The slot index for this function. # # Results: # Returns the formatted declaration string. proc genStubs::makeDecl {name decl index} { lassign $decl rtype fname args append text "/* $index */\n" if {$rtype != "void"} { regsub -all void $rtype VOID rtype } 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 } 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] switch -exact $arg1 { VOID { append line "(void)" } TCL_VARARGS { 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 "(" foreach arg $args { 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 ")" } } append text $line ";" format "#ifndef %s_TCL_DECLARED\n#define %s_TCL_DECLARED\n%s\n#endif\n" \ $fname $fname $text } # genStubs::makeMacro -- # # Generate the inline macro for a function. # # Arguments: # name The interface name. # decl The function declaration. # index The slot index for this function. # # Results: # Returns the formatted macro definition. 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 \\\n\t(" if {$args == ""} { append text "*" } append text "${name}StubsPtr->$lfname)" append text " /* $index */\n#endif\n" return $text } # genStubs::makeSlot -- # # Generate the stub table entry for a function. # # Arguments: # name The interface name. # decl The function declaration. # index The slot index for this function. # # Results: # Returns the formatted table entry. 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 " " if {$rtype != "void"} { regsub -all void $rtype VOID rtype } if {$args == ""} { append text $rtype " *" $lfname "; /* $index */\n" return $text } if {[string range $rtype end-7 end] == "CALLBACK"} { append text [string trim [string range $rtype 0 end-8]] " (CALLBACK *" $lfname ") " } else { append text $rtype " (*" $lfname ") " } regsub -all void $args VOID args set arg1 [lindex $args 0] switch -exact $arg1 { VOID { append text "(void)" } TCL_VARARGS { 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 "(" foreach arg $args { 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 ")" } } append text "; /* $index */\n" return $text } # genStubs::makeInit -- # # Generate the prototype for a function. # # Arguments: # name The interface name. # decl The function declaration. # index The slot index for this function. # # Results: # Returns the formatted declaration string. proc genStubs::makeInit {name decl index} { if {[lindex $decl 2] == ""} { append text " &" [lindex $decl 1] ", /* " $index " */\n" } else { append text " " [lindex $decl 1] ", /* " $index " */\n" } return $text } # genStubs::forAllStubs -- # # This function iterates over all of the platforms and invokes # a callback for each slot. The result of the callback is then # placed inside appropriate platform guards. # # Arguments: # name The interface name. # slotProc The proc to invoke to handle the slot. It will # have the interface name, the declaration, and # the index appended. # onAll If 1, emit the skip string even if there are # definitions for one or more platforms. # textVar The variable to use for output. # skipString The string to emit if a slot is skipped. This # string will be subst'ed in the loop so "$i" can # be used to substitute the index value. # # Results: # None. 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)]} { # Emit integrated stubs block 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 "conflicting generic and platform entries:\ $name $i" } append text [$slotProc $name $stubs($name,generic,$i) $i] set emit 1 } elseif {[llength $slots] > 0} { 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} { eval {append temp} $skipString } } if {$temp ne ""} { append text [addPlatformGuard $plat $temp] set emit 1 } ## 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 } ## 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} { eval {append text} $skipString } } } else { # Emit separate stubs blocks per platform 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] } ## 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,$plat,$i)]} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } else { eval {append temp} $skipString } } 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} { 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 } } 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 } } if {!$emit} { eval {append temp} $skipString } } 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} { 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 } } append text [addPlatformGuard x11 $temp] } } } # genStubs::emitDeclarations -- # # This function emits the function declarations for this interface. # # Arguments: # name The interface name. # textVar The variable to use for output. # # Results: # None. proc genStubs::emitDeclarations {name textVar} { upvar $textVar text append text "\n/*\n * Exported function declarations:\n */\n\n" forAllStubs $name makeDecl 0 text return } # genStubs::emitMacros -- # # This function emits the inline macros for an interface. # # Arguments: # name The name of the interface being emitted. # textVar The variable to use for output. # # Results: # None. proc genStubs::emitMacros {name textVar} { 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 } # genStubs::emitHeader -- # # This function emits the body of the Decls.h file for # the specified interface. # # Arguments: # name The name of the interface being emitted. # # Results: # None. 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 } # genStubs::emitInit -- # # Generate the table initializers for an interface. # # Arguments: # name The name of the interface to initialize. # textVar The variable to use for output. # # Results: # Returns the formatted output. 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 } # genStubs::emitInits -- # # This function emits the body of the StubInit.c file for # the specified interface. # # Arguments: # name The name of the interface being emitted. # # Results: # None. proc genStubs::emitInits {} { variable hooks variable outDir variable libraryName variable interfaces # Assuming that dependencies only go one level deep, we need to emit # all of the leaves first to avoid needing forward declarations. 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 } # genStubs::init -- # # This is the main entry point. # # Arguments: # None. # # Results: # None. 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 } # lassign -- # # This function emulates the TclX lassign command. # # Arguments: # valueList A list containing the values to be assigned. # args The list of variables to be assigned. # # Results: # Returns any values that were not assigned to variables. if {[string length [namespace which lassign]] == 0} { proc lassign {valueList args} { if {[llength $args] == 0} { error "wrong # args: should be \"lassign list varName ?varName ...?\"" } uplevel [list foreach $args $valueList {break}] return [lrange $valueList [llength $args] end] } } genStubs::init