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