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