← Back to branch summary

~ubuntu-branches/ubuntu/raring/tcl8.5/raring

« back to all changes in this revision

Viewing changes to tools/genStubs.tcl

  • Committer: Bazaar Package Importer
  • Author(s): Sergei Golovan
  • Date: 2011-06-26 11:47:14 UTC
  • mfrom: (11.2.2 sid)
  • Revision ID: james.westby@ubuntu.com-20110626114714-mdw95b180f00mm08
Tags: 8.5.10-1
http://bugs.debian.org/617628
* New upstream release (closes: #617628).
* Changed tclsh8.5 alternative priority to 850 to make it higher than
  tclsh8.4 one.
* Bumped standards version to 3.9.2.

Show diffs side-by-side

added added

removed removed

Lines of Context:
tools/genStubs.tcl
9
9
#
10
10
# See the file "license.terms" for information on usage and redistribution
11
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
12
 
15
13
package require Tcl 8.4
16
14
 
18
16
    # libraryName --
19
17
    #
20
18
    #   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.
 
19
    #   the USE_*_STUBS macro and the name of the init file.
22
20
 
23
21
    variable libraryName "UNKNOWN"
24
22
 
135
133
    variable stubs
136
134
    variable curName
137
135
 
138
 
    if {[llength $args] != 3} {
 
136
    if {[llength $args] == 2} {
 
137
        lassign $args index decl
 
138
        set platformList generic
 
139
    } elseif {[llength $args] == 3} {
 
140
        lassign $args index platformList decl
 
141
    } else {
139
142
        puts stderr "wrong # args: declare $args"
 
143
        return
140
144
    }
141
 
    lassign $args index platformList decl
142
145
 
143
146
    # Check for duplicate declarations, then add the declaration and
144
147
    # bump the lastNum counter if necessary.
148
151
            puts stderr "Duplicate entry: declare $args"
149
152
        }
150
153
    }
 
154
    regsub -all const $decl CONST decl
 
155
    regsub -all _XCONST $decl _Xconst decl
151
156
    regsub -all "\[ \t\n\]+" [string trim $decl] " " decl
152
157
    set decl [parseDecl $decl]
153
158
 
176
181
#       None.
177
182
 
178
183
proc genStubs::export {args} {
179
 
    variable stubs
180
 
    variable curName
181
 
 
182
184
    if {[llength $args] != 1} {
183
185
        puts stderr "wrong # args: export $args"
184
186
    }
185
 
    lassign $args decl
186
 
 
187
187
    return
188
188
}
189
189
 
302
302
#       None.
303
303
 
304
304
proc genStubs::emitSlots {name textVar} {
305
 
    variable stubs
306
305
    upvar $textVar text
307
306
 
308
 
    forAllStubs $name makeSlot 1 text {"    void *reserved$i;\n"}
 
307
    forAllStubs $name makeSlot 1 text {"    VOID *reserved$i;\n"}
309
308
    return
310
309
}
311
310
 
410
409
    lassign $decl rtype fname args
411
410
 
412
411
    append text "/* $index */\n"
 
412
    if {$rtype != "void"} {
 
413
        regsub -all void $rtype VOID rtype
 
414
    }
413
415
    set line "EXTERN $rtype"
414
416
    set count [expr {2 - ([string length $line] / 8)}]
415
417
    append line [string range "\t\t\t" 0 $count]
426
428
    }
427
429
    append line $fname
428
430
 
 
431
    regsub -all void $args VOID args
429
432
    set arg1 [lindex $args 0]
430
433
    switch -exact $arg1 {
431
 
        void {
 
434
        VOID {
432
435
            append line "(void)"
433
436
        }
434
437
        TCL_VARARGS {
497
500
    set lfname [string tolower [string index $fname 0]]
498
501
    append lfname [string range $fname 1 end]
499
502
 
500
 
    set text "#ifndef $fname\n#define $fname"
 
503
    set text "#ifndef $fname\n#define $fname \\\n\t("
501
504
    if {$args == ""} {
502
 
        append text " \\\n\t(*${name}StubsPtr->$lfname)"
503
 
        append text " /* $index */\n#endif\n"
504
 
        return $text
 
505
        append text "*"
505
506
    }
506
 
    append text " \\\n\t(${name}StubsPtr->$lfname)"
 
507
    append text "${name}StubsPtr->$lfname)"
507
508
    append text " /* $index */\n#endif\n"
508
509
    return $text
509
510
}
510
511
 
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
 
 
523
 
proc 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
512
# genStubs::makeSlot --
577
513
#
578
514
#       Generate the stub table entry for a function.
592
528
    append lfname [string range $fname 1 end]
593
529
 
594
530
    set text "    "
 
531
    if {$rtype != "void"} {
 
532
        regsub -all void $rtype VOID rtype
 
533
    }
595
534
    if {$args == ""} {
596
535
        append text $rtype " *" $lfname "; /* $index */\n"
597
536
        return $text
601
540
    } else {
602
541
        append text $rtype " (*" $lfname ") "
603
542
    }
 
543
    regsub -all void $args VOID args
604
544
    set arg1 [lindex $args 0]
605
545
    switch -exact $arg1 {
606
 
        void {
 
546
        VOID {
607
547
            append text "(void)"
608
548
        }
609
549
        TCL_VARARGS {
678
618
# Results:
679
619
#       None.
680
620
 
681
 
proc genStubs::forAllStubs {name slotProc onAll textVar \
 
621
proc genStubs::forAllStubs {name slotProc onAll textVar
682
622
        {skipString {"/* Slot $i is reserved */\n"}}} {
683
623
    variable stubs
684
624
    upvar $textVar text
937
877
#       None.
938
878
 
939
879
proc genStubs::emitDeclarations {name textVar} {
940
 
    variable stubs
941
880
    upvar $textVar text
942
881
 
943
882
    append text "\n/*\n * Exported function declarations:\n */\n\n"
957
896
#       None.
958
897
 
959
898
proc genStubs::emitMacros {name textVar} {
960
 
    variable stubs
961
899
    variable libraryName
962
900
    upvar $textVar text
963
901
 
1020
958
    return
1021
959
}
1022
960
 
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
 
 
1034
 
proc 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
961
# genStubs::emitInit --
1045
962
#
1046
963
#       Generate the table initializers for an interface.