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