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 Scriptics Corporation. 8# Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> 9# 10# See the file "license.terms" for information on usage and redistribution 11# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 13namespace eval genStubs { 14 # libraryName -- 15 # 16 # The name of the entire library. This value is used to compute 17 # the USE_*_STUBS macro and the name of the init file. 18 19 variable libraryName "UNKNOWN" 20 21 # interfaces -- 22 # 23 # An array indexed by interface name that is used to maintain 24 # the set of valid interfaces. The value is empty. 25 26 array set interfaces {} 27 28 # curName -- 29 # 30 # The name of the interface currently being defined. 31 32 variable curName "UNKNOWN" 33 34 # scspec -- 35 # 36 # Storage class specifier for external function declarations. 37 # Normally "EXTERN", may be set to something like XYZAPI 38 # 39 variable scspec "EXTERN" 40 41 # epoch, revision -- 42 # 43 # The epoch and revision numbers of the interface currently being defined. 44 # (@@@TODO: should be an array mapping interface names -> numbers) 45 # 46 47 variable epoch {} 48 variable revision 0 49 50 # hooks -- 51 # 52 # An array indexed by interface name that contains the set of 53 # subinterfaces that should be defined for a given interface. 54 55 array set hooks {} 56 57 # stubs -- 58 # 59 # This three dimensional array is indexed first by interface name, 60 # second by platform name, and third by a numeric offset or the 61 # constant "lastNum". The lastNum entry contains the largest 62 # numeric offset used for a given interface/platform combo. Each 63 # numeric offset contains the C function specification that 64 # should be used for the given entry in the stub table. The spec 65 # consists of a list in the form returned by parseDecl. 66 67 array set stubs {} 68 69 # outDir -- 70 # 71 # The directory where the generated files should be placed. 72 73 variable outDir . 74} 75 76# genStubs::library -- 77# 78# This function is used in the declarations file to set the name 79# of the library that the interfaces are associated with (e.g. "tcl"). 80# This value will be used to define the inline conditional macro. 81# 82# Arguments: 83# name The library name. 84# 85# Results: 86# None. 87 88proc genStubs::library {name} { 89 variable libraryName $name 90} 91 92# genStubs::interface -- 93# 94# This function is used in the declarations file to set the name 95# of the interface currently being defined. 96# 97# Arguments: 98# name The name of the interface. 99# 100# Results: 101# None. 102 103proc genStubs::interface {name} { 104 variable curName $name 105 variable interfaces 106 107 set interfaces($name) {} 108 return 109} 110 111# genStubs::scspec -- 112# 113# Define the storage class macro used for external function declarations. 114# Typically, this will be a macro like XYZAPI or EXTERN that 115# expands to either DLLIMPORT or DLLEXPORT, depending on whether 116# -DBUILD_XYZ has been set. 117# 118proc genStubs::scspec {value} { 119 variable scspec $value 120} 121 122# genStubs::epoch -- 123# 124# Define the epoch number for this library. The epoch 125# should be incrememented when a release is made that 126# contains incompatible changes to the public API. 127# 128proc genStubs::epoch {value} { 129 variable epoch $value 130} 131 132# genStubs::hooks -- 133# 134# This function defines the subinterface hooks for the current 135# interface. 136# 137# Arguments: 138# names The ordered list of interfaces that are reachable through the 139# hook vector. 140# 141# Results: 142# None. 143 144proc genStubs::hooks {names} { 145 variable curName 146 variable hooks 147 148 set hooks($curName) $names 149 return 150} 151 152# genStubs::declare -- 153# 154# This function is used in the declarations file to declare a new 155# interface entry. 156# 157# Arguments: 158# index The index number of the interface. 159# platform The platform the interface belongs to. Should be one 160# of generic, win, unix, or macosx or aqua or x11. 161# decl The C function declaration, or {} for an undefined 162# entry. 163# 164# Results: 165# None. 166 167proc genStubs::declare {args} { 168 variable stubs 169 variable curName 170 variable revision 171 172 incr revision 173 if {[llength $args] == 2} { 174 lassign $args index decl 175 set platformList generic 176 } elseif {[llength $args] == 3} { 177 lassign $args index platformList decl 178 } else { 179 puts stderr "wrong # args: declare $args" 180 return 181 } 182 183 # Check for duplicate declarations, then add the declaration and 184 # bump the lastNum counter if necessary. 185 186 foreach platform $platformList { 187 if {[info exists stubs($curName,$platform,$index)]} { 188 puts stderr "Duplicate entry: declare $args" 189 } 190 } 191 regsub -all "\[ \t\n\]+" [string trim $decl] " " decl 192 set decl [parseDecl $decl] 193 194 if {([lindex $platformList 0] eq "deprecated")} { 195 set stubs($curName,deprecated,$index) [lindex $platformList 1] 196 set stubs($curName,generic,$index) $decl 197 if {![info exists stubs($curName,generic,lastNum)] \ 198 || ($index > $stubs($curName,generic,lastNum))} { 199 set stubs($curName,generic,lastNum) $index 200 } 201 } elseif {([lindex $platformList 0] eq "nostub")} { 202 set stubs($curName,nostub,$index) [lindex $platformList 1] 203 set stubs($curName,generic,$index) $decl 204 if {![info exists stubs($curName,generic,lastNum)] \ 205 || ($index > $stubs($curName,generic,lastNum))} { 206 set stubs($curName,generic,lastNum) $index 207 } 208 } else { 209 foreach platform $platformList { 210 if {$decl ne ""} { 211 set stubs($curName,$platform,$index) $decl 212 if {![info exists stubs($curName,$platform,lastNum)] \ 213 || ($index > $stubs($curName,$platform,lastNum))} { 214 set stubs($curName,$platform,lastNum) $index 215 } 216 } 217 } 218 } 219 return 220} 221 222# genStubs::export -- 223# 224# This function is used in the declarations file to declare a symbol 225# that is exported from the library but is not in the stubs table. 226# 227# Arguments: 228# decl The C function declaration, or {} for an undefined 229# entry. 230# 231# Results: 232# None. 233 234proc genStubs::export {args} { 235 if {[llength $args] != 1} { 236 puts stderr "wrong # args: export $args" 237 } 238 return 239} 240 241# genStubs::rewriteFile -- 242# 243# This function replaces the machine generated portion of the 244# specified file with new contents. It looks for the !BEGIN! and 245# !END! comments to determine where to place the new text. 246# 247# Arguments: 248# file The name of the file to modify. 249# text The new text to place in the file. 250# 251# Results: 252# None. 253 254proc genStubs::rewriteFile {file text} { 255 if {![file exists $file]} { 256 puts stderr "Cannot find file: $file" 257 return 258 } 259 set in [open ${file} r] 260 fconfigure $in -eofchar "\032 {}" -encoding utf-8 261 set out [open ${file}.new w] 262 fconfigure $out -translation lf -encoding utf-8 263 264 while {![eof $in]} { 265 set line [gets $in] 266 if {[string match "*!BEGIN!*" $line]} { 267 break 268 } 269 puts $out $line 270 } 271 puts $out "/* !BEGIN!: Do not edit below this line. */" 272 puts $out $text 273 while {![eof $in]} { 274 set line [gets $in] 275 if {[string match "*!END!*" $line]} { 276 break 277 } 278 } 279 puts $out "/* !END!: Do not edit above this line. */" 280 puts -nonewline $out [read $in] 281 close $in 282 close $out 283 file rename -force ${file}.new ${file} 284 return 285} 286 287# genStubs::addPlatformGuard -- 288# 289# Wrap a string inside a platform #ifdef. 290# 291# Arguments: 292# plat Platform to test. 293# 294# Results: 295# Returns the original text inside an appropriate #ifdef. 296 297proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { 298 set text "" 299 switch $plat { 300 win { 301 append text "#if defined(_WIN32)" 302 if {$withCygwin} { 303 append text " || defined(__CYGWIN__)" 304 } 305 append text " /* WIN */\n${iftxt}" 306 if {$eltxt ne ""} { 307 append text "#else /* WIN */\n${eltxt}" 308 } 309 append text "#endif /* WIN */\n" 310 } 311 unix { 312 append text "#if !defined(_WIN32)" 313 if {$withCygwin} { 314 append text " && !defined(__CYGWIN__)" 315 } 316 append text " && !defined(MAC_OSX_TCL)\ 317 /* UNIX */\n${iftxt}" 318 if {$eltxt ne ""} { 319 append text "#else /* UNIX */\n${eltxt}" 320 } 321 append text "#endif /* UNIX */\n" 322 } 323 macosx { 324 append text "#ifdef MAC_OSX_TCL /* MACOSX */\n${iftxt}" 325 if {$eltxt ne ""} { 326 append text "#else /* MACOSX */\n${eltxt}" 327 } 328 append text "#endif /* MACOSX */\n" 329 } 330 aqua { 331 append text "#ifdef MAC_OSX_TK /* AQUA */\n${iftxt}" 332 if {$eltxt ne ""} { 333 append text "#else /* AQUA */\n${eltxt}" 334 } 335 append text "#endif /* AQUA */\n" 336 } 337 x11 { 338 append text "#if !(defined(_WIN32)" 339 if {$withCygwin} { 340 append text " || defined(__CYGWIN__)" 341 } 342 append text " || defined(MAC_OSX_TK))\ 343 /* X11 */\n${iftxt}" 344 if {$eltxt ne ""} { 345 append text "#else /* X11 */\n${eltxt}" 346 } 347 append text "#endif /* X11 */\n" 348 } 349 default { 350 append text "${iftxt}${eltxt}" 351 } 352 } 353 return $text 354} 355 356# genStubs::emitSlots -- 357# 358# Generate the stub table slots for the given interface. If there 359# are no generic slots, then one table is generated for each 360# platform, otherwise one table is generated for all platforms. 361# 362# Arguments: 363# name The name of the interface being emitted. 364# textVar The variable to use for output. 365# 366# Results: 367# None. 368 369proc genStubs::emitSlots {name textVar} { 370 upvar $textVar text 371 372 forAllStubs $name makeSlot 1 text {" void (*reserved$i)(void);\n"} 373 return 374} 375 376# genStubs::parseDecl -- 377# 378# Parse a C function declaration into its component parts. 379# 380# Arguments: 381# decl The function declaration. 382# 383# Results: 384# Returns a list of the form {returnType name args}. The args 385# element consists of a list of type/name pairs, or a single 386# element "void". If the function declaration is malformed 387# then an error is displayed and the return value is {}. 388 389proc genStubs::parseDecl {decl} { 390 if {![regexp {^(.*)\((.*)\)$} $decl all prefix args]} { 391 set prefix $decl 392 set args {} 393 } 394 set prefix [string trim $prefix] 395 if {![regexp {^(.+[ ][*]*)([^ *]+)$} $prefix all rtype fname]} { 396 puts stderr "Bad return type: $decl" 397 return 398 } 399 set rtype [string trim $rtype] 400 if {$args eq ""} { 401 return [list $rtype $fname {}] 402 } 403 foreach arg [split $args ,] { 404 lappend argList [string trim $arg] 405 } 406 if {![string compare [lindex $argList end] "..."]} { 407 set args TCL_VARARGS 408 foreach arg [lrange $argList 0 end-1] { 409 set argInfo [parseArg $arg] 410 if {[llength $argInfo] == 2 || [llength $argInfo] == 3} { 411 lappend args $argInfo 412 } else { 413 puts stderr "Bad argument: '$arg' in '$decl'" 414 return 415 } 416 } 417 } else { 418 set args {} 419 foreach arg $argList { 420 set argInfo [parseArg $arg] 421 if {![string compare $argInfo "void"]} { 422 lappend args "void" 423 break 424 } elseif {[llength $argInfo] == 2 || [llength $argInfo] == 3} { 425 lappend args $argInfo 426 } else { 427 puts stderr "Bad argument: '$arg' in '$decl'" 428 return 429 } 430 } 431 } 432 return [list $rtype $fname $args] 433} 434 435# genStubs::parseArg -- 436# 437# This function parses a function argument into a type and name. 438# 439# Arguments: 440# arg The argument to parse. 441# 442# Results: 443# Returns a list of type and name with an optional third array 444# indicator. If the argument is malformed, returns "". 445 446proc genStubs::parseArg {arg} { 447 if {![regexp {^(.+[ ][*]*)([^][ *]+)(\[\])?$} $arg all type name array]} { 448 if {$arg eq "void"} { 449 return $arg 450 } else { 451 return 452 } 453 } 454 set result [list [string trim $type] $name] 455 if {$array ne ""} { 456 lappend result $array 457 } 458 return $result 459} 460 461# genStubs::makeDecl -- 462# 463# Generate the prototype for a function. 464# 465# Arguments: 466# name The interface name. 467# decl The function declaration. 468# index The slot index for this function. 469# 470# Results: 471# Returns the formatted declaration string. 472 473proc genStubs::makeDecl {name decl index} { 474 variable scspec 475 variable stubs 476 variable libraryName 477 lassign $decl rtype fname args 478 479 append text "/* $index */\n" 480 if {[info exists stubs($name,deprecated,$index)]} { 481 append text "[string toupper $libraryName]_DEPRECATED(\"$stubs($name,deprecated,$index)\")\n" 482 set line "$rtype" 483 } elseif {[string range $rtype end-5 end] eq "MP_WUR"} { 484 set line "$scspec [string trim [string range $rtype 0 end-6]]" 485 } else { 486 set line "$scspec $rtype" 487 } 488 set count [expr {2 - ([string length $line] / 8)}] 489 if {$count >= 0} { 490 append line [string range "\t\t\t" 0 $count] 491 } 492 set pad [expr {24 - [string length $line]}] 493 if {$pad <= 0} { 494 append line " " 495 set pad 0 496 } 497 if {$args eq ""} { 498 append line $fname 499 append text $line 500 append text ";\n" 501 return $text 502 } 503 append line $fname 504 505 set arg1 [lindex $args 0] 506 switch -exact $arg1 { 507 void { 508 append line "(void)" 509 } 510 TCL_VARARGS { 511 set sep "(" 512 foreach arg [lrange $args 1 end] { 513 append line $sep 514 set next {} 515 append next [lindex $arg 0] 516 if {[string index $next end] ne "*"} { 517 append next " " 518 } 519 append next [lindex $arg 1] [lindex $arg 2] 520 if {[string length $line] + [string length $next] \ 521 + $pad > 76} { 522 append text [string trimright $line] \n 523 set line "\t\t\t\t" 524 set pad 28 525 } 526 append line $next 527 set sep ", " 528 } 529 append line ", ...)" 530 if {[lindex $args end] eq "{const char *} format"} { 531 append line " TCL_FORMAT_PRINTF(" [expr {[llength $args] - 1}] ", " [llength $args] ")" 532 } 533 } 534 default { 535 set sep "(" 536 foreach arg $args { 537 append line $sep 538 set next {} 539 append next [lindex $arg 0] 540 if {[string index $next end] ne "*"} { 541 append next " " 542 } 543 append next [lindex $arg 1] [lindex $arg 2] 544 if {[string length $line] + [string length $next] \ 545 + $pad > 76} { 546 append text [string trimright $line] \n 547 set line "\t\t\t\t" 548 set pad 28 549 } 550 append line $next 551 set sep ", " 552 } 553 append line ")" 554 } 555 } 556 if {[string range $rtype end-5 end] eq "MP_WUR"} { 557 append line " MP_WUR" 558 } 559 return "$text$line;\n" 560} 561 562# genStubs::makeMacro -- 563# 564# Generate the inline macro for a function. 565# 566# Arguments: 567# name The interface name. 568# decl The function declaration. 569# index The slot index for this function. 570# 571# Results: 572# Returns the formatted macro definition. 573 574proc genStubs::makeMacro {name decl index} { 575 lassign $decl rtype fname args 576 577 set lfname [string tolower [string index $fname 0]] 578 append lfname [string range $fname 1 end] 579 580 set text "#define $fname \\\n\t(" 581 if {$args eq ""} { 582 append text "*" 583 } 584 append text "${name}StubsPtr->$lfname)" 585 append text " /* $index */\n" 586 return $text 587} 588 589# genStubs::makeSlot -- 590# 591# Generate the stub table entry for a function. 592# 593# Arguments: 594# name The interface name. 595# decl The function declaration. 596# index The slot index for this function. 597# 598# Results: 599# Returns the formatted table entry. 600 601proc genStubs::makeSlot {name decl index} { 602 lassign $decl rtype fname args 603 variable stubs 604 605 set lfname [string tolower [string index $fname 0]] 606 append lfname [string range $fname 1 end] 607 608 set text " " 609 if {[info exists stubs($name,deprecated,$index)]} { 610 append text "TCL_DEPRECATED_API(\"$stubs($name,deprecated,$index)\") " 611 } elseif {[info exists stubs($name,nostub,$index)]} { 612 append text "TCL_DEPRECATED_API(\"$stubs($name,nostub,$index)\") " 613 } 614 if {$args eq ""} { 615 append text $rtype " *" $lfname "; /* $index */\n" 616 return $text 617 } 618 if {[string range $rtype end-8 end] eq "__stdcall"} { 619 append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") " 620 } elseif {[string range $rtype 0 11] eq "TCL_NORETURN"} { 621 append text "TCL_NORETURN1 " [string trim [string range $rtype 12 end]] " (*" $lfname ") " 622 } elseif {[string range $rtype end-5 end] eq "MP_WUR"} { 623 append text [string trim [string range $rtype 0 end-6]] " (*" $lfname ") " 624 } else { 625 append text $rtype " (*" $lfname ") " 626 } 627 set arg1 [lindex $args 0] 628 switch -exact $arg1 { 629 void { 630 append text "(void)" 631 } 632 TCL_VARARGS { 633 set sep "(" 634 foreach arg [lrange $args 1 end] { 635 append text $sep [lindex $arg 0] 636 if {[string index $text end] ne "*"} { 637 append text " " 638 } 639 append text [lindex $arg 1] [lindex $arg 2] 640 set sep ", " 641 } 642 append text ", ...)" 643 if {[lindex $args end] eq "{const char *} format"} { 644 append text " TCL_FORMAT_PRINTF(" [expr {[llength $args] - 1}] ", " [llength $args] ")" 645 } 646 } 647 default { 648 set sep "(" 649 foreach arg $args { 650 append text $sep [lindex $arg 0] 651 if {[string index $text end] ne "*"} { 652 append text " " 653 } 654 append text [lindex $arg 1] [lindex $arg 2] 655 set sep ", " 656 } 657 append text ")" 658 } 659 } 660 661 if {[string range $rtype end-5 end] eq "MP_WUR"} { 662 append text " MP_WUR" 663 } 664 append text "; /* $index */\n" 665 return $text 666} 667 668# genStubs::makeInit -- 669# 670# Generate the prototype for a function. 671# 672# Arguments: 673# name The interface name. 674# decl The function declaration. 675# index The slot index for this function. 676# 677# Results: 678# Returns the formatted declaration string. 679 680proc genStubs::makeInit {name decl index} { 681 if {[lindex $decl 2] eq ""} { 682 append text " &" [lindex $decl 1] ", /* " $index " */\n" 683 } else { 684 append text " " [lindex $decl 1] ", /* " $index " */\n" 685 } 686 return $text 687} 688 689# genStubs::forAllStubs -- 690# 691# This function iterates over all of the platforms and invokes 692# a callback for each slot. The result of the callback is then 693# placed inside appropriate platform guards. 694# 695# Arguments: 696# name The interface name. 697# slotProc The proc to invoke to handle the slot. It will 698# have the interface name, the declaration, and 699# the index appended. 700# onAll If 1, emit the skip string even if there are 701# definitions for one or more platforms. 702# textVar The variable to use for output. 703# skipString The string to emit if a slot is skipped. This 704# string will be subst'ed in the loop so "$i" can 705# be used to substitute the index value. 706# 707# Results: 708# None. 709 710proc genStubs::forAllStubs {name slotProc onAll textVar 711 {skipString {"/* Slot $i is reserved */\n"}}} { 712 variable stubs 713 upvar $textVar text 714 715 set plats [array names stubs $name,*,lastNum] 716 if {[info exists stubs($name,generic,lastNum)]} { 717 # Emit integrated stubs block 718 set lastNum -1 719 foreach plat [array names stubs $name,*,lastNum] { 720 if {$stubs($plat) > $lastNum} { 721 set lastNum $stubs($plat) 722 } 723 } 724 for {set i 0} {$i <= $lastNum} {incr i} { 725 set slots [array names stubs $name,*,$i] 726 set emit 0 727 if {[info exists stubs($name,deprecated,$i)]} { 728 append text [$slotProc $name $stubs($name,generic,$i) $i] 729 set emit 1 730 } elseif {[info exists stubs($name,nostub,$i)]} { 731 append text [$slotProc $name $stubs($name,generic,$i) $i] 732 set emit 1 733 } elseif {[info exists stubs($name,generic,$i)]} { 734 if {[llength $slots] > 1} { 735 puts stderr "conflicting generic and platform entries:\ 736 $name $i" 737 } 738 append text [$slotProc $name $stubs($name,generic,$i) $i] 739 set emit 1 740 } elseif {[llength $slots] > 0} { 741 array set slot {unix 0 x11 0 win 0 macosx 0 aqua 0} 742 foreach s $slots { 743 set slot([lindex [split $s ,] 1]) 1 744 } 745 # "aqua", "macosx" and "x11" are special cases: 746 # "macosx" implies "unix", "aqua" implies "macosx" and "x11" 747 # implies "unix", so we need to be careful not to emit 748 # duplicate stubs entries: 749 if {($slot(unix) && $slot(macosx)) || ( 750 ($slot(unix) || $slot(macosx)) && 751 ($slot(x11) || $slot(aqua)))} { 752 puts stderr "conflicting platform entries: $name $i" 753 } 754 ## unix ## 755 set temp {} 756 set plat unix 757 if {!$slot(aqua) && !$slot(x11)} { 758 if {$slot($plat)} { 759 append temp [$slotProc $name $stubs($name,$plat,$i) $i] 760 } elseif {$onAll} { 761 eval {append temp} $skipString 762 } 763 } 764 if {$temp ne ""} { 765 append text [addPlatformGuard $plat $temp] 766 set emit 1 767 } 768 ## x11 ## 769 set temp {} 770 set plat x11 771 if {!$slot(unix) && !$slot(macosx)} { 772 if {$slot($plat)} { 773 append temp [$slotProc $name $stubs($name,$plat,$i) $i] 774 } elseif {$onAll} { 775 eval {append temp} $skipString 776 } 777 } 778 if {$temp ne ""} { 779 append text [addPlatformGuard $plat $temp] 780 set emit 1 781 } 782 ## win ## 783 set temp {} 784 set plat win 785 if {$slot($plat)} { 786 append temp [$slotProc $name $stubs($name,$plat,$i) $i] 787 } elseif {$onAll} { 788 eval {append temp} $skipString 789 } 790 if {$temp ne ""} { 791 append text [addPlatformGuard $plat $temp] 792 set emit 1 793 } 794 ## macosx ## 795 set temp {} 796 set plat macosx 797 if {!$slot(aqua) && !$slot(x11)} { 798 if {$slot($plat)} { 799 append temp [$slotProc $name $stubs($name,$plat,$i) $i] 800 } elseif {$slot(unix)} { 801 append temp [$slotProc $name $stubs($name,unix,$i) $i] 802 } elseif {$onAll} { 803 eval {append temp} $skipString 804 } 805 } 806 if {$temp ne ""} { 807 append text [addPlatformGuard $plat $temp] 808 set emit 1 809 } 810 ## aqua ## 811 set temp {} 812 set plat aqua 813 if {!$slot(unix) && !$slot(macosx)} { 814 if {[string range $skipString 1 2] ne "/*"} { 815 # genStubs.tcl previously had a bug here causing it to 816 # erroneously generate both a unix entry and an aqua 817 # entry for a given stubs table slot. To preserve 818 # backwards compatibility, generate a dummy stubs entry 819 # before every aqua entry (note that this breaks the 820 # correspondence between emitted entry number and 821 # actual position of the entry in the stubs table, e.g. 822 # TkIntStubs entry 113 for aqua is in fact at position 823 # 114 in the table, entry 114 at position 116 etc). 824 eval {append temp} $skipString 825 set temp "[string range $temp 0 end-1] /*\ 826 Dummy entry for stubs table backwards\ 827 compatibility */\n" 828 } 829 if {$slot($plat)} { 830 append temp [$slotProc $name $stubs($name,$plat,$i) $i] 831 } elseif {$onAll} { 832 eval {append temp} $skipString 833 } 834 } 835 if {$temp ne ""} { 836 append text [addPlatformGuard $plat $temp] 837 set emit 1 838 } 839 } 840 if {!$emit} { 841 eval {append text} $skipString 842 } 843 } 844 } else { 845 # Emit separate stubs blocks per platform 846 array set block {unix 0 x11 0 win 0 macosx 0 aqua 0} 847 foreach s [array names stubs $name,*,lastNum] { 848 set block([lindex [split $s ,] 1]) 1 849 } 850 ## unix ## 851 if {$block(unix) && !$block(x11)} { 852 set temp {} 853 set plat unix 854 set lastNum $stubs($name,$plat,lastNum) 855 for {set i 0} {$i <= $lastNum} {incr i} { 856 if {[info exists stubs($name,$plat,$i)]} { 857 append temp [$slotProc $name $stubs($name,$plat,$i) $i] 858 } else { 859 eval {append temp} $skipString 860 } 861 } 862 append text [addPlatformGuard $plat $temp {} true] 863 } 864 ## win ## 865 if {$block(win)} { 866 set temp {} 867 set plat win 868 set lastNum $stubs($name,$plat,lastNum) 869 for {set i 0} {$i <= $lastNum} {incr i} { 870 if {[info exists stubs($name,$plat,$i)]} { 871 append temp [$slotProc $name $stubs($name,$plat,$i) $i] 872 } else { 873 eval {append temp} $skipString 874 } 875 } 876 append text [addPlatformGuard $plat $temp {} true] 877 } 878 ## macosx ## 879 if {($block(unix) || $block(macosx)) && !$block(aqua) && !$block(x11)} { 880 set temp {} 881 set lastNum -1 882 foreach plat {unix macosx} { 883 if {$block($plat)} { 884 set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum) 885 ? $lastNum : $stubs($name,$plat,lastNum)}] 886 } 887 } 888 for {set i 0} {$i <= $lastNum} {incr i} { 889 set emit 0 890 foreach plat {unix macosx} { 891 if {[info exists stubs($name,$plat,$i)]} { 892 append temp [$slotProc $name $stubs($name,$plat,$i) $i] 893 set emit 1 894 break 895 } 896 } 897 if {!$emit} { 898 eval {append temp} $skipString 899 } 900 } 901 append text [addPlatformGuard macosx $temp] 902 } 903 ## aqua ## 904 if {$block(aqua)} { 905 set temp {} 906 set lastNum -1 907 foreach plat {unix macosx aqua} { 908 if {$block($plat)} { 909 set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum) 910 ? $lastNum : $stubs($name,$plat,lastNum)}] 911 } 912 } 913 for {set i 0} {$i <= $lastNum} {incr i} { 914 set emit 0 915 foreach plat {unix macosx aqua} { 916 if {[info exists stubs($name,$plat,$i)]} { 917 append temp [$slotProc $name $stubs($name,$plat,$i) $i] 918 set emit 1 919 break 920 } 921 } 922 if {!$emit} { 923 eval {append temp} $skipString 924 } 925 } 926 append text [addPlatformGuard aqua $temp] 927 } 928 ## x11 ## 929 if {$block(x11)} { 930 set temp {} 931 set lastNum -1 932 foreach plat {unix macosx x11} { 933 if {$block($plat)} { 934 set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum) 935 ? $lastNum : $stubs($name,$plat,lastNum)}] 936 } 937 } 938 for {set i 0} {$i <= $lastNum} {incr i} { 939 set emit 0 940 foreach plat {unix macosx x11} { 941 if {[info exists stubs($name,$plat,$i)]} { 942 if {$plat ne "macosx"} { 943 append temp [$slotProc $name \ 944 $stubs($name,$plat,$i) $i] 945 } else { 946 eval {set etxt} $skipString 947 append temp [addPlatformGuard $plat [$slotProc \ 948 $name $stubs($name,$plat,$i) $i] $etxt true] 949 } 950 set emit 1 951 break 952 } 953 } 954 if {!$emit} { 955 eval {append temp} $skipString 956 } 957 } 958 append text [addPlatformGuard x11 $temp {} true] 959 } 960 } 961} 962 963# genStubs::emitDeclarations -- 964# 965# This function emits the function declarations for this interface. 966# 967# Arguments: 968# name The interface name. 969# textVar The variable to use for output. 970# 971# Results: 972# None. 973 974proc genStubs::emitDeclarations {name textVar} { 975 upvar $textVar text 976 977 append text "\n/*\n * Exported function declarations:\n */\n\n" 978 forAllStubs $name makeDecl 0 text 979 return 980} 981 982# genStubs::emitMacros -- 983# 984# This function emits the inline macros for an interface. 985# 986# Arguments: 987# name The name of the interface being emitted. 988# textVar The variable to use for output. 989# 990# Results: 991# None. 992 993proc genStubs::emitMacros {name textVar} { 994 variable libraryName 995 upvar $textVar text 996 997 set upName [string toupper $libraryName] 998 append text "\n#if defined(USE_${upName}_STUBS)\n" 999 append text "\n/*\n * Inline function declarations:\n */\n\n" 1000 1001 forAllStubs $name makeMacro 0 text 1002 1003 append text "\n#endif /* defined(USE_${upName}_STUBS) */\n" 1004 return 1005} 1006 1007# genStubs::emitHeader -- 1008# 1009# This function emits the body of the <name>Decls.h file for 1010# the specified interface. 1011# 1012# Arguments: 1013# name The name of the interface being emitted. 1014# 1015# Results: 1016# None. 1017 1018proc genStubs::emitHeader {name} { 1019 variable outDir 1020 variable hooks 1021 variable epoch 1022 variable revision 1023 1024 set capName [string toupper [string index $name 0]] 1025 append capName [string range $name 1 end] 1026 1027 if {$epoch ne ""} { 1028 set CAPName [string toupper $name] 1029 append text "\n" 1030 append text "#define ${CAPName}_STUBS_EPOCH $epoch\n" 1031 append text "#define ${CAPName}_STUBS_REVISION $revision\n" 1032 } 1033 1034 append text "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n" 1035 1036 emitDeclarations $name text 1037 1038 if {[info exists hooks($name)]} { 1039 append text "\ntypedef struct {\n" 1040 foreach hook $hooks($name) { 1041 set capHook [string toupper [string index $hook 0]] 1042 append capHook [string range $hook 1 end] 1043 append text " const struct ${capHook}Stubs *${hook}Stubs;\n" 1044 } 1045 append text "} ${capName}StubHooks;\n" 1046 } 1047 append text "\ntypedef struct ${capName}Stubs {\n" 1048 append text " int magic;\n" 1049 if {$epoch ne ""} { 1050 append text " int epoch;\n" 1051 append text " int revision;\n" 1052 } 1053 if {[info exists hooks($name)]} { 1054 append text " const ${capName}StubHooks *hooks;\n\n" 1055 } else { 1056 append text " void *hooks;\n\n" 1057 } 1058 1059 emitSlots $name text 1060 1061 append text "} ${capName}Stubs;\n\n" 1062 1063 append text "extern const ${capName}Stubs *${name}StubsPtr;\n\n" 1064 append text "#ifdef __cplusplus\n}\n#endif\n" 1065 1066 emitMacros $name text 1067 1068 rewriteFile [file join $outDir ${name}Decls.h] $text 1069 return 1070} 1071 1072# genStubs::emitInit -- 1073# 1074# Generate the table initializers for an interface. 1075# 1076# Arguments: 1077# name The name of the interface to initialize. 1078# textVar The variable to use for output. 1079# 1080# Results: 1081# Returns the formatted output. 1082 1083proc genStubs::emitInit {name textVar} { 1084 variable hooks 1085 variable interfaces 1086 variable epoch 1087 upvar $textVar text 1088 set root 1 1089 1090 set capName [string toupper [string index $name 0]] 1091 append capName [string range $name 1 end] 1092 1093 if {[info exists hooks($name)]} { 1094 append text "\nstatic const ${capName}StubHooks ${name}StubHooks = \{\n" 1095 set sep " " 1096 foreach sub $hooks($name) { 1097 append text $sep "&${sub}Stubs" 1098 set sep ",\n " 1099 } 1100 append text "\n\};\n" 1101 } 1102 foreach intf [array names interfaces] { 1103 if {[info exists hooks($intf)]} { 1104 if {$name in $hooks($intf)} { 1105 set root 0 1106 break 1107 } 1108 } 1109 } 1110 1111 append text "\n" 1112 if {!$root} { 1113 append text "static " 1114 } 1115 append text "const ${capName}Stubs ${name}Stubs = \{\n TCL_STUB_MAGIC,\n" 1116 if {$epoch ne ""} { 1117 set CAPName [string toupper $name] 1118 append text " ${CAPName}_STUBS_EPOCH,\n" 1119 append text " ${CAPName}_STUBS_REVISION,\n" 1120 } 1121 if {[info exists hooks($name)]} { 1122 append text " &${name}StubHooks,\n" 1123 } else { 1124 append text " 0,\n" 1125 } 1126 1127 forAllStubs $name makeInit 1 text {" 0, /* $i */\n"} 1128 1129 append text "\};\n" 1130 return 1131} 1132 1133# genStubs::emitInits -- 1134# 1135# This function emits the body of the <name>StubInit.c file for 1136# the specified interface. 1137# 1138# Arguments: 1139# name The name of the interface being emitted. 1140# 1141# Results: 1142# None. 1143 1144proc genStubs::emitInits {} { 1145 variable hooks 1146 variable outDir 1147 variable libraryName 1148 variable interfaces 1149 1150 # Assuming that dependencies only go one level deep, we need to emit 1151 # all of the leaves first to avoid needing forward declarations. 1152 1153 set leaves {} 1154 set roots {} 1155 foreach name [lsort [array names interfaces]] { 1156 if {[info exists hooks($name)]} { 1157 lappend roots $name 1158 } else { 1159 lappend leaves $name 1160 } 1161 } 1162 foreach name $leaves { 1163 emitInit $name text 1164 } 1165 foreach name $roots { 1166 emitInit $name text 1167 } 1168 1169 rewriteFile [file join $outDir ${libraryName}StubInit.c] $text 1170} 1171 1172# genStubs::init -- 1173# 1174# This is the main entry point. 1175# 1176# Arguments: 1177# None. 1178# 1179# Results: 1180# None. 1181 1182proc genStubs::init {} { 1183 global argv argv0 1184 variable outDir 1185 variable interfaces 1186 1187 if {[llength $argv] < 2} { 1188 puts stderr "usage: $argv0 outDir declFile ?declFile...?" 1189 exit 1 1190 } 1191 1192 set outDir [lindex $argv 0] 1193 1194 foreach file [lrange $argv 1 end] { 1195 source -encoding utf-8 $file 1196 } 1197 1198 foreach name [lsort [array names interfaces]] { 1199 puts "Emitting $name" 1200 emitHeader $name 1201 } 1202 1203 emitInits 1204} 1205 1206# lassign -- 1207# 1208# This function emulates the TclX lassign command. 1209# 1210# Arguments: 1211# valueList A list containing the values to be assigned. 1212# args The list of variables to be assigned. 1213# 1214# Results: 1215# Returns any values that were not assigned to variables. 1216 1217if {[namespace which lassign] ne ""} { 1218 proc lassign {valueList args} { 1219 if {[llength $args] == 0} { 1220 error "wrong # args: should be \"lassign list varName ?varName ...?\"" 1221 } 1222 uplevel [list foreach $args $valueList {break}] 1223 return [lrange $valueList [llength $args] end] 1224 } 1225} 1226 1227genStubs::init 1228