summaryrefslogtreecommitdiffstats
path: root/tools/genStubs.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tools/genStubs.tcl')
-rw-r--r--tools/genStubs.tcl176
1 files changed, 59 insertions, 117 deletions
diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl
index 89e4ccc..37205b2 100644
--- a/tools/genStubs.tcl
+++ b/tools/genStubs.tcl
@@ -4,12 +4,14 @@
# interface.
#
#
-# Copyright © 1998-1999 Scriptics Corporation.
-# Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
+# 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.4
+
namespace eval genStubs {
# libraryName --
#
@@ -188,31 +190,17 @@ proc genStubs::declare {args} {
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]
- if {([lindex $platformList 0] eq "deprecated")} {
- set stubs($curName,deprecated,$index) [lindex $platformList 1]
- set stubs($curName,generic,$index) $decl
- if {![info exists stubs($curName,generic,lastNum)] \
- || ($index > $stubs($curName,generic,lastNum))} {
- set stubs($curName,generic,lastNum) $index
- }
- } elseif {([lindex $platformList 0] eq "nostub")} {
- set stubs($curName,nostub,$index) [lindex $platformList 1]
- set stubs($curName,generic,$index) $decl
- if {![info exists stubs($curName,generic,lastNum)] \
- || ($index > $stubs($curName,generic,lastNum))} {
- set stubs($curName,generic,lastNum) $index
- }
- } else {
- foreach platform $platformList {
- if {$decl ne ""} {
- set stubs($curName,$platform,$index) $decl
- if {![info exists stubs($curName,$platform,lastNum)] \
- || ($index > $stubs($curName,$platform,lastNum))} {
- set stubs($curName,$platform,lastNum) $index
- }
+ 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
}
}
}
@@ -257,9 +245,8 @@ proc genStubs::rewriteFile {file text} {
return
}
set in [open ${file} r]
- fconfigure $in -eofchar "\x1A {}" -encoding utf-8
set out [open ${file}.new w]
- fconfigure $out -translation lf -encoding utf-8
+ fconfigure $out -translation lf
while {![eof $in]} {
set line [gets $in]
@@ -298,7 +285,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} {
set text ""
switch $plat {
win {
- append text "#if defined(_WIN32)"
+ append text "#if defined(__WIN32__)"
if {$withCygwin} {
append text " || defined(__CYGWIN__)"
}
@@ -309,7 +296,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} {
append text "#endif /* WIN */\n"
}
unix {
- append text "#if !defined(_WIN32)"
+ append text "#if !defined(__WIN32__)"
if {$withCygwin} {
append text " && !defined(__CYGWIN__)"
}
@@ -335,7 +322,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} {
append text "#endif /* AQUA */\n"
}
x11 {
- append text "#if !(defined(_WIN32)"
+ append text "#if !(defined(__WIN32__)"
if {$withCygwin} {
append text " || defined(__CYGWIN__)"
}
@@ -369,7 +356,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} {
proc genStubs::emitSlots {name textVar} {
upvar $textVar text
- forAllStubs $name makeSlot 1 text {" void (*reserved$i)(void);\n"}
+ forAllStubs $name makeSlot 1 text {" VOID *reserved$i;\n"}
return
}
@@ -397,7 +384,7 @@ proc genStubs::parseDecl {decl} {
return
}
set rtype [string trim $rtype]
- if {$args eq ""} {
+ if {$args == ""} {
return [list $rtype $fname {}]
}
foreach arg [split $args ,] {
@@ -445,14 +432,14 @@ proc genStubs::parseDecl {decl} {
proc genStubs::parseArg {arg} {
if {![regexp {^(.+[ ][*]*)([^][ *]+)(\[\])?$} $arg all type name array]} {
- if {$arg eq "void"} {
+ if {$arg == "void"} {
return $arg
} else {
return
}
}
set result [list [string trim $type] $name]
- if {$array ne ""} {
+ if {$array != ""} {
lappend result $array
}
return $result
@@ -472,23 +459,15 @@ proc genStubs::parseArg {arg} {
proc genStubs::makeDecl {name decl index} {
variable scspec
- variable stubs
- variable libraryName
lassign $decl rtype fname args
append text "/* $index */\n"
- if {[info exists stubs($name,deprecated,$index)]} {
- append text "[string toupper $libraryName]_DEPRECATED(\"$stubs($name,deprecated,$index)\")\n"
- set line "$rtype"
- } elseif {[string range $rtype end-5 end] eq "MP_WUR"} {
- set line "$scspec [string trim [string range $rtype 0 end-6]]"
- } else {
- set line "$scspec $rtype"
+ if {$rtype != "void"} {
+ regsub -all void $rtype VOID rtype
}
+ set line "$scspec $rtype"
set count [expr {2 - ([string length $line] / 8)}]
- if {$count >= 0} {
- append line [string range "\t\t\t" 0 $count]
- }
+ append line [string range "\t\t\t" 0 $count]
set pad [expr {24 - [string length $line]}]
if {$pad <= 0} {
append line " "
@@ -502,9 +481,10 @@ proc genStubs::makeDecl {name decl index} {
}
append line $fname
+ regsub -all void $args VOID args
set arg1 [lindex $args 0]
switch -exact $arg1 {
- void {
+ VOID {
append line "(void)"
}
TCL_VARARGS {
@@ -527,9 +507,6 @@ proc genStubs::makeDecl {name decl index} {
set sep ", "
}
append line ", ...)"
- if {[lindex $args end] eq "{const char *} format"} {
- append line " TCL_FORMAT_PRINTF(" [expr {[llength $args] - 1}] ", " [llength $args] ")"
- }
}
default {
set sep "("
@@ -553,10 +530,9 @@ proc genStubs::makeDecl {name decl index} {
append line ")"
}
}
- if {[string range $rtype end-5 end] eq "MP_WUR"} {
- append line " MP_WUR"
- }
- 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 --
@@ -577,12 +553,12 @@ proc genStubs::makeMacro {name decl index} {
set lfname [string tolower [string index $fname 0]]
append lfname [string range $fname 1 end]
- set text "#define $fname \\\n\t("
- if {$args eq ""} {
+ set text "#ifndef $fname\n#define $fname \\\n\t("
+ if {$args == ""} {
append text "*"
}
append text "${name}StubsPtr->$lfname)"
- append text " /* $index */\n"
+ append text " /* $index */\n#endif\n"
return $text
}
@@ -600,33 +576,27 @@ proc genStubs::makeMacro {name decl index} {
proc genStubs::makeSlot {name decl index} {
lassign $decl rtype fname args
- variable stubs
set lfname [string tolower [string index $fname 0]]
append lfname [string range $fname 1 end]
set text " "
- if {[info exists stubs($name,deprecated,$index)]} {
- append text "TCL_DEPRECATED_API(\"$stubs($name,deprecated,$index)\") "
- } elseif {[info exists stubs($name,nostub,$index)]} {
- append text "TCL_DEPRECATED_API(\"$stubs($name,nostub,$index)\") "
- }
- if {$args eq ""} {
+ if {$args == ""} {
append text $rtype " *" $lfname "; /* $index */\n"
return $text
}
- if {[string range $rtype end-8 end] eq "__stdcall"} {
+ if {$rtype ne "void"} {
+ regsub -all void $rtype VOID rtype
+ }
+ if {[string range $rtype end-8 end] == "__stdcall"} {
append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") "
- } elseif {[string range $rtype 0 11] eq "TCL_NORETURN"} {
- append text "TCL_NORETURN1 " [string trim [string range $rtype 12 end]] " (*" $lfname ") "
- } elseif {[string range $rtype end-5 end] eq "MP_WUR"} {
- append text [string trim [string range $rtype 0 end-6]] " (*" $lfname ") "
} else {
append text $rtype " (*" $lfname ") "
}
+ regsub -all void $args VOID args
set arg1 [lindex $args 0]
switch -exact $arg1 {
- void {
+ VOID {
append text "(void)"
}
TCL_VARARGS {
@@ -640,9 +610,6 @@ proc genStubs::makeSlot {name decl index} {
set sep ", "
}
append text ", ...)"
- if {[lindex $args end] eq "{const char *} format"} {
- append text " TCL_FORMAT_PRINTF(" [expr {[llength $args] - 1}] ", " [llength $args] ")"
- }
}
default {
set sep "("
@@ -658,9 +625,6 @@ proc genStubs::makeSlot {name decl index} {
}
}
- if {[string range $rtype end-5 end] eq "MP_WUR"} {
- append text " MP_WUR"
- }
append text "; /* $index */\n"
return $text
}
@@ -678,7 +642,7 @@ proc genStubs::makeSlot {name decl index} {
# Returns the formatted declaration string.
proc genStubs::makeInit {name decl index} {
- if {[lindex $decl 2] eq ""} {
+ if {[lindex $decl 2] == ""} {
append text " &" [lindex $decl 1] ", /* " $index " */\n"
} else {
append text " " [lindex $decl 1] ", /* " $index " */\n"
@@ -724,13 +688,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar
for {set i 0} {$i <= $lastNum} {incr i} {
set slots [array names stubs $name,*,$i]
set emit 0
- if {[info exists stubs($name,deprecated,$i)]} {
- append text [$slotProc $name $stubs($name,generic,$i) $i]
- set emit 1
- } elseif {[info exists stubs($name,nostub,$i)]} {
- append text [$slotProc $name $stubs($name,generic,$i) $i]
- set emit 1
- } elseif {[info exists stubs($name,generic,$i)]} {
+ if {[info exists stubs($name,generic,$i)]} {
if {[llength $slots] > 1} {
puts stderr "conflicting generic and platform entries:\
$name $i"
@@ -995,12 +953,14 @@ proc genStubs::emitMacros {name textVar} {
upvar $textVar text
set upName [string toupper $libraryName]
- append text "\n#if defined(USE_${upName}_STUBS)\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) */\n"
+ append text "\n#endif /* defined(USE_${upName}_STUBS) &&\
+ !defined(USE_${upName}_STUB_PROCS) */\n"
return
}
@@ -1024,7 +984,7 @@ proc genStubs::emitHeader {name} {
set capName [string toupper [string index $name 0]]
append capName [string range $name 1 end]
- if {$epoch ne ""} {
+ if {$epoch != ""} {
set CAPName [string toupper $name]
append text "\n"
append text "#define ${CAPName}_STUBS_EPOCH $epoch\n"
@@ -1036,31 +996,27 @@ proc genStubs::emitHeader {name} {
emitDeclarations $name text
if {[info exists hooks($name)]} {
- append text "\ntypedef struct {\n"
+ 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 " const struct ${capHook}Stubs *${hook}Stubs;\n"
+ 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"
- if {$epoch ne ""} {
+ if {$epoch != ""} {
append text " int epoch;\n"
append text " int revision;\n"
}
- if {[info exists hooks($name)]} {
- append text " const ${capName}StubHooks *hooks;\n\n"
- } else {
- append text " void *hooks;\n\n"
- }
+ append text " struct ${capName}StubHooks *hooks;\n\n"
emitSlots $name text
append text "} ${capName}Stubs;\n\n"
- append text "extern const ${capName}Stubs *${name}StubsPtr;\n\n"
+ append text "extern ${capName}Stubs *${name}StubsPtr;\n\n"
append text "#ifdef __cplusplus\n}\n#endif\n"
emitMacros $name text
@@ -1082,16 +1038,14 @@ proc genStubs::emitHeader {name} {
proc genStubs::emitInit {name textVar} {
variable hooks
- variable interfaces
variable epoch
upvar $textVar text
- set root 1
set capName [string toupper [string index $name 0]]
append capName [string range $name 1 end]
if {[info exists hooks($name)]} {
- append text "\nstatic const ${capName}StubHooks ${name}StubHooks = \{\n"
+ append text "\nstatic ${capName}StubHooks ${name}StubHooks = \{\n"
set sep " "
foreach sub $hooks($name) {
append text $sep "&${sub}Stubs"
@@ -1099,21 +1053,9 @@ proc genStubs::emitInit {name textVar} {
}
append text "\n\};\n"
}
- foreach intf [array names interfaces] {
- if {[info exists hooks($intf)]} {
- if {$name in $hooks($intf)} {
- set root 0
- break
- }
- }
- }
-
- append text "\n"
- if {!$root} {
- append text "static "
- }
- append text "const ${capName}Stubs ${name}Stubs = \{\n TCL_STUB_MAGIC,\n"
- if {$epoch ne ""} {
+ append text "\n${capName}Stubs ${name}Stubs = \{\n"
+ append text " TCL_STUB_MAGIC,\n"
+ if {$epoch != ""} {
set CAPName [string toupper $name]
append text " ${CAPName}_STUBS_EPOCH,\n"
append text " ${CAPName}_STUBS_REVISION,\n"
@@ -1121,10 +1063,10 @@ proc genStubs::emitInit {name textVar} {
if {[info exists hooks($name)]} {
append text " &${name}StubHooks,\n"
} else {
- append text " 0,\n"
+ append text " NULL,\n"
}
- forAllStubs $name makeInit 1 text {" 0, /* $i */\n"}
+ forAllStubs $name makeInit 1 text {" NULL, /* $i */\n"}
append text "\};\n"
return
@@ -1192,7 +1134,7 @@ proc genStubs::init {} {
set outDir [lindex $argv 0]
foreach file [lrange $argv 1 end] {
- source -encoding utf-8 $file
+ source $file
}
foreach name [lsort [array names interfaces]] {
@@ -1214,7 +1156,7 @@ proc genStubs::init {} {
# Results:
# Returns any values that were not assigned to variables.
-if {[namespace which lassign] ne ""} {
+if {[string length [namespace which lassign]] == 0} {
proc lassign {valueList args} {
if {[llength $args] == 0} {
error "wrong # args: should be \"lassign list varName ?varName ...?\""
generated by cgit v0.12 at 2025-12-24 14:20:34 (GMT)