diff options
Diffstat (limited to 'tclxml/tools')
| -rw-r--r-- | tclxml/tools/genStubs.tcl | 894 |
1 files changed, 0 insertions, 894 deletions
diff --git a/tclxml/tools/genStubs.tcl b/tclxml/tools/genStubs.tcl deleted file mode 100644 index d4ef368..0000000 --- a/tclxml/tools/genStubs.tcl +++ /dev/null @@ -1,894 +0,0 @@ -# genStubs.tcl -- -# -# This script generates a set of stub files for a given -# interface. -# -# -# Copyright (c) 1998-1999 by Scriptics Corporation. -# 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.1.1.1 2009/01/16 22:11:49 joye Exp $ - -namespace eval genStubs { - # libraryName -- - # - # The name of the entire library. This value is used to compute - # the USE_*_STUB_PROCS 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 mac. -# decl The C function declaration, or {} for an undefined -# entry. -# -# Results: -# None. - -proc genStubs::declare {args} { - variable stubs - variable curName - - if {[llength $args] != 3} { - puts stderr "wrong # args: declare $args" - } - lassign $args index platformList decl - - # 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 "\[ \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::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 exist $file]} { - puts stderr "Cannot find file: $file" - return - } - set in [open ${file} r] - set out [open ${file}.new w] - - # Always write out the file with LF termination - fconfigure $out -translation lf - - 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 -} - -# 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 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" - } - } - 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} { - variable stubs - 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]} { - 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] -} - -# 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" - 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 -} - -# 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" - 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 -} - -# genStubs::makeStub -- -# -# Emits a stub function definition. -# -# Arguments: -# name The interface name. -# decl The function declaration. -# index The slot index for this function. -# -# Results: -# Returns the formatted stub function definition. - -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 -} - -# 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 " " - 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 -} - -# 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} { - 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 "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 {$emit == 0} { - 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] - } - } - append text [addPlatformGuard $plat $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} { - variable stubs - 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 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 -} - -# genStubs::emitHeader -- -# -# This function emits the body of the <name>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::emitStubs -- -# -# This function emits the body of the <name>Stubs.c file for -# the specified interface. -# -# Arguments: -# name The name of the interface being emitted. -# -# Results: -# None. - -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 -} - -# 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 <name>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. - -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 |