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