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