1# genStubs.tcl -- 2# 3# This script generates a set of stub files for a given 4# interface. 5# 6# 7# Copyright (c) 1998-1999 by Scriptics Corporation. 8# See the file "license.terms" for information on usage and redistribution 9# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10# 11# $Id: genStubs.tcl,v 1.1 2007/05/18 13:35:56 dkf Exp $ 12# 13# SOURCE: tcl/tools/genStubs.tcl, revision 1.17 14# 15# CHANGES: 16# + Don't use _ANSI_ARGS_ macro 17# + Remove xxx_TCL_DECLARED #ifdeffery 18# + Use application-defined storage class specifier instead of "EXTERN" 19# + Add "epoch" and "revision" fields to stubs table record 20# + Remove dead code related to USE_*_STUB_PROCS (emitStubs, makeStub) 21# + Second argument to "declare" is used as a status guard 22# instead of a platform guard. 23# + Use void (*reserved$i)(void) = 0 instead of void *reserved$i = NULL 24# for unused stub entries, in case pointer-to-function and 25# pointer-to-object are different sizes. 26# + Allow trailing semicolon in function declarations 27# + stubs table is const-qualified 28# 29 30package require Tcl 8.5- 31 32namespace eval genStubs { 33 # libraryName -- 34 # 35 # The name of the entire library. This value is used to compute 36 # the USE_*_STUBS macro, the name of the init file, and others. 37 38 variable libraryName "UNKNOWN" 39 40 # interfaces -- 41 # 42 # An array indexed by interface name that is used to maintain 43 # the set of valid interfaces. The value is empty. 44 45 array set interfaces {} 46 47 # curName -- 48 # 49 # The name of the interface currently being defined. 50 51 variable curName "UNKNOWN" 52 53 # scspec -- 54 # 55 # Storage class specifier for external function declarations. 56 # Normally "extern", may be set to something like XYZAPI 57 # 58 variable scspec "extern" 59 60 # epoch, revision -- 61 # 62 # The epoch and revision numbers of the interface currently being defined. 63 # (@@@TODO: should be an array mapping interface names -> numbers) 64 # 65 66 variable epoch 0 67 variable revision 0 68 69 # hooks -- 70 # 71 # An array indexed by interface name that contains the set of 72 # subinterfaces that should be defined for a given interface. 73 74 array set hooks {} 75 76 # stubs -- 77 # 78 # This three dimensional array is indexed first by interface name, 79 # second by field name, and third by a numeric offset or the 80 # constant "lastNum". The lastNum entry contains the largest 81 # numeric offset used for a given interface. 82 # 83 # Field "decl,$i" contains the C function specification that 84 # should be used for the given entry in the stub table. The spec 85 # consists of a list in the form returned by parseDecl. 86 # Other fields TBD later. 87 88 array set stubs {} 89 90 # outDir -- 91 # 92 # The directory where the generated files should be placed. 93 94 variable outDir . 95} 96 97# genStubs::library -- 98# 99# This function is used in the declarations file to set the name 100# of the library that the interfaces are associated with (e.g. "tcl"). 101# This value will be used to define the inline conditional macro. 102# 103# Arguments: 104# name The library name. 105# 106# Results: 107# None. 108 109proc genStubs::library {name} { 110 variable libraryName $name 111} 112 113# genStubs::interface -- 114# 115# This function is used in the declarations file to set the name 116# of the interface currently being defined. 117# 118# Arguments: 119# name The name of the interface. 120# 121# Results: 122# None. 123 124proc genStubs::interface {name} { 125 variable curName $name 126 variable interfaces 127 variable stubs 128 129 set interfaces($name) {} 130 set stubs($name,lastNum) 0 131 return 132} 133 134# genStubs::scspec -- 135# 136# Define the storage class macro used for external function declarations. 137# Typically, this will be a macro like XYZAPI or EXTERN that 138# expands to either DLLIMPORT or DLLEXPORT, depending on whether 139# -DBUILD_XYZ has been set. 140# 141proc genStubs::scspec {value} { 142 variable scspec $value 143} 144 145# genStubs::epoch -- 146# 147# Define the epoch number for this library. The epoch 148# should be incrememented when a release is made that 149# contains incompatible changes to the public API. 150# 151proc genStubs::epoch {value} { 152 variable epoch $value 153} 154 155# genStubs::hooks -- 156# 157# This function defines the subinterface hooks for the current 158# interface. 159# 160# Arguments: 161# names The ordered list of interfaces that are reachable through the 162# hook vector. 163# 164# Results: 165# None. 166 167proc genStubs::hooks {names} { 168 variable curName 169 variable hooks 170 171 set hooks($curName) $names 172 return 173} 174 175# genStubs::declare -- 176# 177# This function is used in the declarations file to declare a new 178# interface entry. 179# 180# Arguments: 181# index The index number of the interface. 182# status Status of the interface: one of "current", 183# "deprecated", or "obsolete". 184# decl The C function declaration, or {} for an undefined 185# entry. 186# 187proc genStubs::declare {index status decl} { 188 variable stubs 189 variable curName 190 variable revision 191 192 incr revision 193 194 # Check for duplicate declarations, then add the declaration and 195 # bump the lastNum counter if necessary. 196 197 if {[info exists stubs($curName,decl,$index)]} { 198 puts stderr "Duplicate entry: $index" 199 } 200 regsub -all "\[ \t\n\]+" [string trim $decl] " " decl 201 set decl [parseDecl $decl] 202 203 set stubs($curName,status,$index) $status 204 set stubs($curName,decl,$index) $decl 205 206 if {$index > $stubs($curName,lastNum)} { 207 set stubs($curName,lastNum) $index 208 } 209 210 return 211} 212 213# genStubs::rewriteFile -- 214# 215# This function replaces the machine generated portion of the 216# specified file with new contents. It looks for the !BEGIN! and 217# !END! comments to determine where to place the new text. 218# 219# Arguments: 220# file The name of the file to modify. 221# text The new text to place in the file. 222# 223# Results: 224# None. 225 226proc genStubs::rewriteFile {file text} { 227 if {![file exists $file]} { 228 puts stderr "Cannot find file: $file" 229 return 230 } 231 set in [open ${file} r] 232 set out [open ${file}.new w] 233 fconfigure $out -translation lf 234 235 while {![eof $in]} { 236 set line [gets $in] 237 if {[string match "*!BEGIN!*" $line]} { 238 break 239 } 240 puts $out $line 241 } 242 puts $out "/* !BEGIN!: Do not edit below this line. */" 243 puts $out $text 244 while {![eof $in]} { 245 set line [gets $in] 246 if {[string match "*!END!*" $line]} { 247 break 248 } 249 } 250 puts $out "/* !END!: Do not edit above this line. */" 251 puts -nonewline $out [read $in] 252 close $in 253 close $out 254 file rename -force ${file}.new ${file} 255 return 256} 257 258# genStubs::addPlatformGuard -- 259# 260# Wrap a string inside a platform #ifdef. 261# 262# Arguments: 263# plat Platform to test. 264# 265# Results: 266# Returns the original text inside an appropriate #ifdef. 267 268proc genStubs::addPlatformGuard {plat text} { 269 switch $plat { 270 win { 271 return "#ifdef _WIN32\n${text}#endif /* _WIN32 */\n" 272 } 273 unix { 274 return "#if !defined(_WIN32) /* UNIX */\n${text}#endif /* UNIX */\n" 275 } 276 macosx { 277 return "#ifdef MAC_OSX_TCL\n${text}#endif /* MAC_OSX_TCL */\n" 278 } 279 aqua { 280 return "#ifdef MAC_OSX_TK\n${text}#endif /* MAC_OSX_TK */\n" 281 } 282 x11 { 283 return "#if !(defined(_WIN32) || defined(MAC_OSX_TK)) /* X11 */\n${text}#endif /* X11 */\n" 284 } 285 } 286 return "$text" 287} 288 289# genStubs::emitSlots -- 290# 291# Generate the stub table slots for the given interface. 292# 293# Arguments: 294# name The name of the interface being emitted. 295# textVar The variable to use for output. 296# 297# Results: 298# None. 299 300proc genStubs::emitSlots {name textVar} { 301 upvar $textVar text 302 303 forAllStubs $name makeSlot noGuard text {" void (*reserved$i)(void);\n"} 304 return 305} 306 307# genStubs::parseDecl -- 308# 309# Parse a C function declaration into its component parts. 310# 311# Arguments: 312# decl The function declaration. 313# 314# Results: 315# Returns a list of the form {returnType name args}. The args 316# element consists of a list of type/name pairs, or a single 317# element "void". If the function declaration is malformed 318# then an error is displayed and the return value is {}. 319 320proc genStubs::parseDecl {decl} { 321 if {![regexp {^(.*)\((.*)\);?$} $decl all prefix args]} { 322 puts stderr "Malformed declaration: $decl" 323 return 324 } 325 set prefix [string trim $prefix] 326 if {![regexp {^(.+[ ][*]*)([^ *]+)$} $prefix all rtype fname]} { 327 puts stderr "Bad return type: $decl" 328 return 329 } 330 set rtype [string trim $rtype] 331 foreach arg [split $args ,] { 332 lappend argList [string trim $arg] 333 } 334 if {![string compare [lindex $argList end] "..."]} { 335 if {[llength $argList] != 2} { 336 puts stderr "Only one argument is allowed in varargs form: $decl" 337 } 338 set arg [parseArg [lindex $argList 0]] 339 if {$arg == "" || ([llength $arg] != 2)} { 340 puts stderr "Bad argument: '[lindex $argList 0]' in '$decl'" 341 return 342 } 343 set args [list TCL_VARARGS $arg] 344 } else { 345 set args {} 346 foreach arg $argList { 347 set argInfo [parseArg $arg] 348 if {![string compare $argInfo "void"]} { 349 lappend args "void" 350 break 351 } elseif {[llength $argInfo] == 2 || [llength $argInfo] == 3} { 352 lappend args $argInfo 353 } else { 354 puts stderr "Bad argument: '$arg' in '$decl'" 355 return 356 } 357 } 358 } 359 return [list $rtype $fname $args] 360} 361 362# genStubs::parseArg -- 363# 364# This function parses a function argument into a type and name. 365# 366# Arguments: 367# arg The argument to parse. 368# 369# Results: 370# Returns a list of type and name with an optional third array 371# indicator. If the argument is malformed, returns "". 372 373proc genStubs::parseArg {arg} { 374 if {![regexp {^(.+[ ][*]*)([^][ *]+)(\[\])?$} $arg all type name array]} { 375 if {$arg == "void"} { 376 return $arg 377 } else { 378 return 379 } 380 } 381 set result [list [string trim $type] $name] 382 if {$array != ""} { 383 lappend result $array 384 } 385 return $result 386} 387 388# genStubs::makeDecl -- 389# 390# Generate the prototype for a function. 391# 392# Arguments: 393# name The interface name. 394# decl The function declaration. 395# index The slot index for this function. 396# 397# Results: 398# Returns the formatted declaration string. 399 400proc genStubs::makeDecl {name decl index} { 401 variable scspec 402 lassign $decl rtype fname args 403 404 append text "/* $index */\n" 405 set line "$scspec $rtype" 406 set count [expr {2 - ([string length $line] / 8)}] 407 append line [string range "\t\t\t" 0 $count] 408 set pad [expr {24 - [string length $line]}] 409 if {$pad <= 0} { 410 append line " " 411 set pad 0 412 } 413 append line "$fname " 414 415 set arg1 [lindex $args 0] 416 switch -exact $arg1 { 417 void { 418 append line "(void)" 419 } 420 TCL_VARARGS { 421 set arg [lindex $args 1] 422 append line "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])" 423 } 424 default { 425 set sep "(" 426 foreach arg $args { 427 append line $sep 428 set next {} 429 append next [lindex $arg 0] " " [lindex $arg 1] \ 430 [lindex $arg 2] 431 if {[string length $line] + [string length $next] \ 432 + $pad > 76} { 433 append text [string trimright $line] \n 434 set line "\t\t\t\t" 435 set pad 28 436 } 437 append line $next 438 set sep ", " 439 } 440 append line ")" 441 } 442 } 443 append text $line 444 445 append text ";\n" 446 return $text 447} 448 449# genStubs::makeMacro -- 450# 451# Generate the inline macro for a function. 452# 453# Arguments: 454# name The interface name. 455# decl The function declaration. 456# index The slot index for this function. 457# 458# Results: 459# Returns the formatted macro definition. 460 461proc genStubs::makeMacro {name decl index} { 462 lassign $decl rtype fname args 463 464 set lfname [string tolower [string index $fname 0]] 465 append lfname [string range $fname 1 end] 466 467 set text "#define $fname" 468 set arg1 [lindex $args 0] 469 set argList "" 470 switch -exact $arg1 { 471 void { 472 set argList "()" 473 } 474 TCL_VARARGS { 475 } 476 default { 477 set sep "(" 478 foreach arg $args { 479 append argList $sep [lindex $arg 1] 480 set sep ", " 481 } 482 append argList ")" 483 } 484 } 485 append text " \\\n\t(${name}StubsPtr->$lfname)" 486 append text " /* $index */\n" 487 return $text 488} 489 490# genStubs::makeSlot -- 491# 492# Generate the stub table entry for a function. 493# 494# Arguments: 495# name The interface name. 496# decl The function declaration. 497# index The slot index for this function. 498# 499# Results: 500# Returns the formatted table entry. 501 502proc genStubs::makeSlot {name decl index} { 503 lassign $decl rtype fname args 504 505 set lfname [string tolower [string index $fname 0]] 506 append lfname [string range $fname 1 end] 507 508 set text " " 509 append text $rtype " (*" $lfname ") " 510 511 set arg1 [lindex $args 0] 512 switch -exact $arg1 { 513 void { 514 append text "(void)" 515 } 516 TCL_VARARGS { 517 set arg [lindex $args 1] 518 append text "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])" 519 } 520 default { 521 set sep "(" 522 foreach arg $args { 523 append text $sep [lindex $arg 0] " " [lindex $arg 1] \ 524 [lindex $arg 2] 525 set sep ", " 526 } 527 append text ")" 528 } 529 } 530 531 append text "; /* $index */\n" 532 return $text 533} 534 535# genStubs::makeInit -- 536# 537# Generate the prototype for a function. 538# 539# Arguments: 540# name The interface name. 541# decl The function declaration. 542# index The slot index for this function. 543# 544# Results: 545# Returns the formatted declaration string. 546 547proc genStubs::makeInit {name decl index} { 548 append text " " [lindex $decl 1] ", /* " $index " */\n" 549 return $text 550} 551 552# genStubs::forAllStubs -- 553# 554# This function iterates over all of the slots and invokes 555# a callback for each slot. The result of the callback is then 556# placed inside appropriate guards. 557# 558# Arguments: 559# name The interface name. 560# slotProc The proc to invoke to handle the slot. It will 561# have the interface name, the declaration, and 562# the index appended. 563# guardProc The proc to invoke to add guards. It will have 564# the slot status and text appended. 565# textVar The variable to use for output. 566# skipString The string to emit if a slot is skipped. This 567# string will be subst'ed in the loop so "$i" can 568# be used to substitute the index value. 569# 570# Results: 571# None. 572 573proc genStubs::forAllStubs {name slotProc guardProc textVar 574 {skipString {"/* Slot $i is reserved */\n"}}} { 575 variable stubs 576 upvar $textVar text 577 578 set lastNum $stubs($name,lastNum) 579 580 for {set i 0} {$i <= $lastNum} {incr i} { 581 if {[info exists stubs($name,decl,$i)]} { 582 append text [$guardProc $stubs($name,status,$i) \ 583 [$slotProc $name $stubs($name,decl,$i) $i]] 584 } else { 585 eval {append text} $skipString 586 } 587 } 588} 589 590proc genStubs::noGuard {status text} { return $text } 591 592proc genStubs::addGuard {status text} { 593 variable libraryName 594 set upName [string toupper $libraryName] 595 596 switch -- $status { 597 current { 598 # No change 599 } 600 deprecated { 601 set text [ifdeffed "${upName}_DEPRECATED" $text] 602 } 603 obsolete { 604 set text "" 605 } 606 default { 607 puts stderr "Unrecognized status code $status" 608 } 609 } 610 return $text 611} 612 613proc genStubs::ifdeffed {macro text} { 614 join [list "#ifdef $macro" $text "#endif" ""] \n 615} 616 617# genStubs::emitDeclarations -- 618# 619# This function emits the function declarations for this interface. 620# 621# Arguments: 622# name The interface name. 623# textVar The variable to use for output. 624# 625# Results: 626# None. 627 628proc genStubs::emitDeclarations {name textVar} { 629 upvar $textVar text 630 631 append text "\n/*\n * Exported function declarations:\n */\n\n" 632 forAllStubs $name makeDecl noGuard text 633 return 634} 635 636# genStubs::emitMacros -- 637# 638# This function emits the inline macros for an interface. 639# 640# Arguments: 641# name The name of the interface being emitted. 642# textVar The variable to use for output. 643# 644# Results: 645# None. 646 647proc genStubs::emitMacros {name textVar} { 648 variable libraryName 649 upvar $textVar text 650 651 set upName [string toupper $libraryName] 652 append text "\n#if defined(USE_${upName}_STUBS)\n" 653 append text "\n/*\n * Inline function declarations:\n */\n\n" 654 655 forAllStubs $name makeMacro addGuard text 656 657 append text "\n#endif /* defined(USE_${upName}_STUBS) */\n" 658 return 659} 660 661# genStubs::emitHeader -- 662# 663# This function emits the body of the <name>Decls.h file for 664# the specified interface. 665# 666# Arguments: 667# name The name of the interface being emitted. 668# 669# Results: 670# None. 671 672proc genStubs::emitHeader {name} { 673 variable outDir 674 variable hooks 675 variable epoch 676 variable revision 677 678 set capName [string toupper [string index $name 0]] 679 append capName [string range $name 1 end] 680 681 set CAPName [string toupper $name] 682 append text "\n" 683 append text "#define ${CAPName}_STUBS_EPOCH $epoch\n" 684 append text "#define ${CAPName}_STUBS_REVISION $revision\n" 685 686 append text "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n" 687 688 emitDeclarations $name text 689 690 if {[info exists hooks($name)]} { 691 append text "\ntypedef struct {\n" 692 foreach hook $hooks($name) { 693 set capHook [string toupper [string index $hook 0]] 694 append capHook [string range $hook 1 end] 695 append text " const struct ${capHook}Stubs *${hook}Stubs;\n" 696 } 697 append text "} ${capName}StubHooks;\n" 698 } 699 append text "\ntypedef struct ${capName}Stubs {\n" 700 append text " int magic;\n" 701 append text " int epoch;\n" 702 append text " int revision;\n" 703 if {[info exists hooks($name)]} { 704 append text " const ${capName}StubHooks *hooks;\n\n" 705 } else { 706 append text " void *hooks;\n\n" 707 } 708 709 emitSlots $name text 710 711 append text "} ${capName}Stubs;\n\n" 712 713 append text "extern const ${capName}Stubs *${name}StubsPtr;\n\n" 714 append text "#ifdef __cplusplus\n}\n#endif\n" 715 716 emitMacros $name text 717 718 rewriteFile [file join $outDir ${name}Decls.h] $text 719 return 720} 721 722# genStubs::emitInit -- 723# 724# Generate the table initializers for an interface. 725# 726# Arguments: 727# name The name of the interface to initialize. 728# textVar The variable to use for output. 729# 730# Results: 731# Returns the formatted output. 732 733proc genStubs::emitInit {name textVar} { 734 variable hooks 735 variable interfaces 736 variable epoch 737 upvar $textVar text 738 set root 1 739 740 set capName [string toupper [string index $name 0]] 741 append capName [string range $name 1 end] 742 set CAPName [string toupper $name] 743 744 if {[info exists hooks($name)]} { 745 append text "\nstatic const ${capName}StubHooks ${name}StubHooks = \{\n" 746 set sep " " 747 foreach sub $hooks($name) { 748 append text $sep "&${sub}Stubs" 749 set sep ",\n " 750 } 751 append text "\n\};\n" 752 } 753 foreach intf [array names interfaces] { 754 if {[info exists hooks($intf)]} { 755 if {[lsearch -exact $hooks($intf) $name] >= 0} { 756 set root 0 757 break 758 } 759 } 760 } 761 762 append text "\n" 763 if {!$root} { 764 append text "static " 765 } 766 append text "const ${capName}Stubs ${name}Stubs = \{\n" 767 append text " TCL_STUB_MAGIC,\n" 768 append text " ${CAPName}_STUBS_EPOCH,\n" 769 append text " ${CAPName}_STUBS_REVISION,\n" 770 if {[info exists hooks($name)]} { 771 append text " &${name}StubHooks,\n" 772 } else { 773 append text " 0,\n" 774 } 775 776 forAllStubs $name makeInit noGuard text {" 0, /* $i */\n"} 777 778 append text "\};\n" 779 return 780} 781 782# genStubs::emitInits -- 783# 784# This function emits the body of the <name>StubInit.c file for 785# the specified interface. 786# 787# Arguments: 788# name The name of the interface being emitted. 789# 790# Results: 791# None. 792 793proc genStubs::emitInits {} { 794 variable hooks 795 variable outDir 796 variable libraryName 797 variable interfaces 798 799 # Assuming that dependencies only go one level deep, we need to emit 800 # all of the leaves first to avoid needing forward declarations. 801 802 set leaves {} 803 set roots {} 804 foreach name [lsort [array names interfaces]] { 805 if {[info exists hooks($name)]} { 806 lappend roots $name 807 } else { 808 lappend leaves $name 809 } 810 } 811 foreach name $leaves { 812 emitInit $name text 813 } 814 foreach name $roots { 815 emitInit $name text 816 } 817 818 rewriteFile [file join $outDir ${libraryName}StubInit.c] $text 819} 820 821# genStubs::init -- 822# 823# This is the main entry point. 824# 825# Arguments: 826# None. 827# 828# Results: 829# None. 830 831proc genStubs::init {} { 832 global argv argv0 833 variable outDir 834 variable interfaces 835 836 if {[llength $argv] < 2} { 837 puts stderr "usage: $argv0 outDir declFile ?declFile...?" 838 exit 1 839 } 840 841 set outDir [lindex $argv 0] 842 843 foreach file [lrange $argv 1 end] { 844 source $file 845 } 846 847 foreach name [lsort [array names interfaces]] { 848 puts "Emitting $name" 849 emitHeader $name 850 } 851 852 emitInits 853} 854 855# lassign -- 856# 857# This function emulates the TclX lassign command. 858# 859# Arguments: 860# valueList A list containing the values to be assigned. 861# args The list of variables to be assigned. 862# 863# Results: 864# Returns any values that were not assigned to variables. 865 866proc lassign {valueList args} { 867 if {[llength $args] == 0} { 868 error "wrong # args: lassign list varname ?varname..?" 869 } 870 871 uplevel [list foreach $args $valueList {break}] 872 return [lrange $valueList [llength $args] end] 873} 874 875genStubs::init 876