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