util/src/TclTk/tcl8.6.12/pkgs/tdbc1.1.3/tools/genStubs.tcl

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