Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/tools/genStubs.tcl @ 42

Last change on this file since 42 was 25, checked in by landauf, 18 years ago

added tcl to libs
File size: 27.8 KB
Line 
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 2007/12/13 15:28:40 dgp 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] " " [lindex $arg 1] \
440                        [lindex $arg 2]
441                if {[string length $line] + [string length $next] \
442                        + $pad > 76} {
443                    append text $line \n
444                    set line "\t\t\t\t"
445                    set pad 28
446                }
447                append line $next
448                set sep ", "
449            }
450            append line ", ...)"
451        }
452        default {
453            set sep "("
454            foreach arg $args {
455                append line $sep
456                set next {}
457                append next [lindex $arg 0] " " [lindex $arg 1] \
458                        [lindex $arg 2]
459                if {[string length $line] + [string length $next] \
460                        + $pad > 76} {
461                    append text $line \n
462                    set line "\t\t\t\t"
463                    set pad 28
464                }
465                append line $next
466                set sep ", "
467            }
468            append line ")"
469        }
470    }
471    append text $line ";"
472    format "#ifndef %s_TCL_DECLARED\n#define %s_TCL_DECLARED\n%s\n#endif\n" \
473            $fname $fname $text
474}
475
476# genStubs::makeMacro --
477#
478#       Generate the inline macro for a function.
479#
480# Arguments:
481#       name    The interface name.
482#       decl    The function declaration.
483#       index   The slot index for this function.
484#
485# Results:
486#       Returns the formatted macro definition.
487
488proc genStubs::makeMacro {name decl index} {
489    lassign $decl rtype fname args
490
491    set lfname [string tolower [string index $fname 0]]
492    append lfname [string range $fname 1 end]
493
494    set text "#ifndef $fname\n#define $fname"
495    if {$args == ""} {
496        append text " \\\n\t(*${name}StubsPtr->$lfname)"
497        append text " /* $index */\n#endif\n"
498        return $text
499    }
500    append text " \\\n\t(${name}StubsPtr->$lfname)"
501    append text " /* $index */\n#endif\n"
502    return $text
503}
504
505# genStubs::makeStub --
506#
507#       Emits a stub function definition.
508#
509# Arguments:
510#       name    The interface name.
511#       decl    The function declaration.
512#       index   The slot index for this function.
513#
514# Results:
515#       Returns the formatted stub function definition.
516
517proc genStubs::makeStub {name decl index} {
518    lassign $decl rtype fname args
519
520    set lfname [string tolower [string index $fname 0]]
521    append lfname [string range $fname 1 end]
522
523    append text "/* Slot $index */\n" $rtype "\n" $fname
524
525    set arg1 [lindex $args 0]
526
527    if {![string compare $arg1 "TCL_VARARGS"]} {
528        lassign [lindex $args 1] type argName
529        append text " ($type$argName, ...)\n\{\n"
530        append text "    " $type " var;\n    va_list argList;\n"
531        if {[string compare $rtype "void"]} {
532            append text "    " $rtype " resultValue;\n"
533        }
534        append text "\n    var = (" $type ") (va_start(argList, " \
535                $argName "), " $argName ");\n\n    "
536        if {[string compare $rtype "void"]} {
537            append text "resultValue = "
538        }
539        append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n"
540        append text "    va_end(argList);\n"
541        if {[string compare $rtype "void"]} {
542            append text "return resultValue;\n"
543        }
544        append text "\}\n\n"
545        return $text
546    }
547
548    if {![string compare $arg1 "void"]} {
549        set argList "()"
550        set argDecls ""
551    } else {
552        set argList ""
553        set sep "("
554        foreach arg $args {
555            append argList $sep [lindex $arg 1]
556            append argDecls "    " [lindex $arg 0] " " \
557                    [lindex $arg 1] [lindex $arg 2] ";\n"
558            set sep ", "
559        }
560        append argList ")"
561    }
562    append text $argList "\n" $argDecls "{\n    "
563    if {[string compare $rtype "void"]} {
564        append text "return "
565    }
566    append text "(" $name "StubsPtr->" $lfname ")" $argList ";\n}\n\n"
567    return $text
568}
569
570# genStubs::makeSlot --
571#
572#       Generate the stub table entry for a function.
573#
574# Arguments:
575#       name    The interface name.
576#       decl    The function declaration.
577#       index   The slot index for this function.
578#
579# Results:
580#       Returns the formatted table entry.
581
582proc genStubs::makeSlot {name decl index} {
583    lassign $decl rtype fname args
584
585    set lfname [string tolower [string index $fname 0]]
586    append lfname [string range $fname 1 end]
587
588    set text "    "
589    if {$args == ""} {
590        append text $rtype " *" $lfname "; /* $index */\n"
591        return $text
592    }
593    append text $rtype " (*" $lfname ") "
594
595    set arg1 [lindex $args 0]
596    switch -exact $arg1 {
597        void {
598            append text "(void)"
599        }
600        TCL_VARARGS {
601            set sep "("
602            foreach arg [lrange $args 1 end] {
603                append text $sep [lindex $arg 0] " " [lindex $arg 1] \
604                        [lindex $arg 2]
605                set sep ", "
606            }
607            append text ", ...)"
608        }
609        default {
610            set sep "("
611            foreach arg $args {
612                append text $sep [lindex $arg 0] " " [lindex $arg 1] \
613                        [lindex $arg 2]
614                set sep ", "
615            }
616            append text ")"
617        }
618    }
619
620    append text "; /* $index */\n"
621    return $text
622}
623
624# genStubs::makeInit --
625#
626#       Generate the prototype for a function.
627#
628# Arguments:
629#       name    The interface name.
630#       decl    The function declaration.
631#       index   The slot index for this function.
632#
633# Results:
634#       Returns the formatted declaration string.
635
636proc genStubs::makeInit {name decl index} {
637    if {[lindex $decl 2] == ""} {
638        append text "    &" [lindex $decl 1] ", /* " $index " */\n"
639    } else {
640        append text "    " [lindex $decl 1] ", /* " $index " */\n"
641    }
642    return $text
643}
644
645# genStubs::forAllStubs --
646#
647#       This function iterates over all of the platforms and invokes
648#       a callback for each slot.  The result of the callback is then
649#       placed inside appropriate platform guards.
650#
651# Arguments:
652#       name            The interface name.
653#       slotProc        The proc to invoke to handle the slot.  It will
654#                       have the interface name, the declaration,  and
655#                       the index appended.
656#       onAll           If 1, emit the skip string even if there are
657#                       definitions for one or more platforms.
658#       textVar         The variable to use for output.
659#       skipString      The string to emit if a slot is skipped.  This
660#                       string will be subst'ed in the loop so "$i" can
661#                       be used to substitute the index value.
662#
663# Results:
664#       None.
665
666proc genStubs::forAllStubs {name slotProc onAll textVar \
667        {skipString {"/* Slot $i is reserved */\n"}}} {
668    variable stubs
669    upvar $textVar text
670
671    set plats [array names stubs $name,*,lastNum]
672    if {[info exists stubs($name,generic,lastNum)]} {
673        # Emit integrated stubs block
674        set lastNum -1
675        foreach plat [array names stubs $name,*,lastNum] {
676            if {$stubs($plat) > $lastNum} {
677                set lastNum $stubs($plat)
678            }
679        }
680        for {set i 0} {$i <= $lastNum} {incr i} {
681            set slots [array names stubs $name,*,$i]
682            set emit 0
683            if {[info exists stubs($name,generic,$i)]} {
684                if {[llength $slots] > 1} {
685                    puts stderr "conflicting generic and platform entries:\
686                            $name $i"
687                }
688                append text [$slotProc $name $stubs($name,generic,$i) $i]
689                set emit 1
690            } elseif {[llength $slots] > 0} {
691                array set slot {unix 0 x11 0 win 0 macosx 0 aqua 0}
692                foreach s $slots {
693                    set slot([lindex [split $s ,] 1]) 1
694                }
695                # "aqua", "macosx" and "x11" are special cases:
696                # "macosx" implies "unix", "aqua" implies "macosx" and "x11"
697                # implies "unix", so we need to be careful not to emit
698                # duplicate stubs entries:
699                if {($slot(unix) && $slot(macosx)) || (
700                        ($slot(unix) || $slot(macosx)) &&
701                        ($slot(x11)  || $slot(aqua)))} {
702                    puts stderr "conflicting platform entries: $name $i"
703                }
704                ## unix ##
705                set temp {}
706                set plat unix
707                if {!$slot(aqua) && !$slot(x11)} {
708                    if {$slot($plat)} {
709                        append temp [$slotProc $name $stubs($name,$plat,$i) $i]
710                    } elseif {$onAll} {
711                        eval {append temp} $skipString
712                    }
713                }
714                if {$temp ne ""} {
715                    append text [addPlatformGuard $plat $temp]
716                    set emit 1
717                }
718                ## x11 ##
719                set temp {}
720                set plat x11
721                if {!$slot(unix) && !$slot(macosx)} {
722                    if {$slot($plat)} {
723                        append temp [$slotProc $name $stubs($name,$plat,$i) $i]
724                    } elseif {$onAll} {
725                        eval {append temp} $skipString
726                    }
727                }
728                if {$temp ne ""} {
729                    append text [addPlatformGuard $plat $temp]
730                    set emit 1
731                }
732                ## win ##
733                set temp {}
734                set plat win
735                if {$slot($plat)} {
736                    append temp [$slotProc $name $stubs($name,$plat,$i) $i]
737                } elseif {$onAll} {
738                    eval {append temp} $skipString
739                }
740                if {$temp ne ""} {
741                    append text [addPlatformGuard $plat $temp]
742                    set emit 1
743                }
744                ## macosx ##
745                set temp {}
746                set plat macosx
747                if {!$slot(aqua) && !$slot(x11)} {
748                    if {$slot($plat)} {
749                        append temp [$slotProc $name $stubs($name,$plat,$i) $i]
750                    } elseif {$slot(unix)} {
751                        append temp [$slotProc $name $stubs($name,unix,$i) $i]
752                    } elseif {$onAll} {
753                        eval {append temp} $skipString
754                    }
755                }
756                if {$temp ne ""} {
757                    append text [addPlatformGuard $plat $temp]
758                    set emit 1
759                }
760                ## aqua ##
761                set temp {}
762                set plat aqua
763                if {!$slot(unix) && !$slot(macosx)} {
764                    if {[string range $skipString 1 2] ne "/*"} {
765                        # genStubs.tcl previously had a bug here causing it to
766                        # erroneously generate both a unix entry and an aqua
767                        # entry for a given stubs table slot. To preserve
768                        # backwards compatibility, generate a dummy stubs entry
769                        # before every aqua entry (note that this breaks the
770                        # correspondence between emitted entry number and
771                        # actual position of the entry in the stubs table, e.g.
772                        # TkIntStubs entry 113 for aqua is in fact at position
773                        # 114 in the table, entry 114 at position 116 etc).
774                        eval {append temp} $skipString
775                        set temp "[string range $temp 0 end-1] /*\
776                                Dummy entry for stubs table backwards\
777                                compatibility */\n"
778                    }
779                    if {$slot($plat)} {
780                        append temp [$slotProc $name $stubs($name,$plat,$i) $i]
781                    } elseif {$onAll} {
782                        eval {append temp} $skipString
783                    }
784                }
785                if {$temp ne ""} {
786                    append text [addPlatformGuard $plat $temp]
787                    set emit 1
788                }
789            }
790            if {!$emit} {
791                eval {append text} $skipString
792            }
793        }
794    } else {
795        # Emit separate stubs blocks per platform
796        array set block {unix 0 x11 0 win 0 macosx 0 aqua 0}
797        foreach s [array names stubs $name,*,lastNum] {
798            set block([lindex [split $s ,] 1]) 1
799        }
800        ## unix ##
801        if {$block(unix) && !$block(x11)} {
802            set temp {}
803            set plat unix
804            set lastNum $stubs($name,$plat,lastNum)
805            for {set i 0} {$i <= $lastNum} {incr i} {
806                if {[info exists stubs($name,$plat,$i)]} {
807                    append temp [$slotProc $name $stubs($name,$plat,$i) $i]
808                } else {
809                    eval {append temp} $skipString
810                }
811            }
812            append text [addPlatformGuard $plat $temp]
813        }
814        ## win ##
815        if {$block(win)} {
816            set temp {}
817            set plat win
818            set lastNum $stubs($name,$plat,lastNum)
819            for {set i 0} {$i <= $lastNum} {incr i} {
820                if {[info exists stubs($name,$plat,$i)]} {
821                    append temp [$slotProc $name $stubs($name,$plat,$i) $i]
822                } else {
823                    eval {append temp} $skipString
824                }
825            }
826            append text [addPlatformGuard $plat $temp]
827        }
828        ## macosx ##
829        if {$block(macosx) && !$block(aqua) && !$block(x11)} {
830            set temp {}
831            set lastNum -1
832            foreach plat {unix macosx} {
833                if {$block($plat)} {
834                    set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum)
835                            ? $lastNum : $stubs($name,$plat,lastNum)}]
836                }
837            }
838            for {set i 0} {$i <= $lastNum} {incr i} {
839                set emit 0
840                foreach plat {unix macosx} {
841                    if {[info exists stubs($name,$plat,$i)]} {
842                        append temp [$slotProc $name $stubs($name,$plat,$i) $i]
843                        set emit 1
844                        break
845                    }
846                }
847                if {!$emit} {
848                    eval {append temp} $skipString
849                }
850            }
851            append text [addPlatformGuard macosx $temp]
852        }
853        ## aqua ##
854        if {$block(aqua)} {
855            set temp {}
856            set lastNum -1
857            foreach plat {unix macosx aqua} {
858                if {$block($plat)} {
859                    set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum)
860                            ? $lastNum : $stubs($name,$plat,lastNum)}]
861                }
862            }
863            for {set i 0} {$i <= $lastNum} {incr i} {
864                set emit 0
865                foreach plat {unix macosx aqua} {
866                    if {[info exists stubs($name,$plat,$i)]} {
867                        append temp [$slotProc $name $stubs($name,$plat,$i) $i]
868                        set emit 1
869                        break
870                    }
871                }
872                if {!$emit} {
873                    eval {append temp} $skipString
874                }
875            }
876            append text [addPlatformGuard aqua $temp]
877        }
878        ## x11 ##
879        if {$block(x11)} {
880            set temp {}
881            set lastNum -1
882            foreach plat {unix macosx x11} {
883                if {$block($plat)} {
884                    set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum)
885                            ? $lastNum : $stubs($name,$plat,lastNum)}]
886                }
887            }
888            for {set i 0} {$i <= $lastNum} {incr i} {
889                set emit 0
890                foreach plat {unix macosx x11} {
891                    if {[info exists stubs($name,$plat,$i)]} {
892                        if {$plat ne "macosx"} {
893                            append temp [$slotProc $name \
894                                    $stubs($name,$plat,$i) $i]
895                        } else {
896                            eval {set etxt} $skipString
897                            append temp [addPlatformGuard $plat [$slotProc \
898                                    $name $stubs($name,$plat,$i) $i] $etxt]
899                        }
900                        set emit 1
901                        break
902                    }
903                }
904                if {!$emit} {
905                    eval {append temp} $skipString
906                }
907            }
908            append text [addPlatformGuard x11 $temp]
909        }
910    }
911}
912
913# genStubs::emitDeclarations --
914#
915#       This function emits the function declarations for this interface.
916#
917# Arguments:
918#       name    The interface name.
919#       textVar The variable to use for output.
920#
921# Results:
922#       None.
923
924proc genStubs::emitDeclarations {name textVar} {
925    variable stubs
926    upvar $textVar text
927
928    append text "\n/*\n * Exported function declarations:\n */\n\n"
929    forAllStubs $name makeDecl 0 text
930    return
931}
932
933# genStubs::emitMacros --
934#
935#       This function emits the inline macros for an interface.
936#
937# Arguments:
938#       name    The name of the interface being emitted.
939#       textVar The variable to use for output.
940#
941# Results:
942#       None.
943
944proc genStubs::emitMacros {name textVar} {
945    variable stubs
946    variable libraryName
947    upvar $textVar text
948
949    set upName [string toupper $libraryName]
950    append text "\n#if defined(USE_${upName}_STUBS) &&\
951            !defined(USE_${upName}_STUB_PROCS)\n"
952    append text "\n/*\n * Inline function declarations:\n */\n\n"
953
954    forAllStubs $name makeMacro 0 text
955
956    append text "\n#endif /* defined(USE_${upName}_STUBS) &&\
957            !defined(USE_${upName}_STUB_PROCS) */\n"
958    return
959}
960
961# genStubs::emitHeader --
962#
963#       This function emits the body of the <name>Decls.h file for
964#       the specified interface.
965#
966# Arguments:
967#       name    The name of the interface being emitted.
968#
969# Results:
970#       None.
971
972proc genStubs::emitHeader {name} {
973    variable outDir
974    variable hooks
975
976    set capName [string toupper [string index $name 0]]
977    append capName [string range $name 1 end]
978
979    emitDeclarations $name text
980
981    if {[info exists hooks($name)]} {
982        append text "\ntypedef struct ${capName}StubHooks {\n"
983        foreach hook $hooks($name) {
984            set capHook [string toupper [string index $hook 0]]
985            append capHook [string range $hook 1 end]
986            append text "    struct ${capHook}Stubs *${hook}Stubs;\n"
987        }
988        append text "} ${capName}StubHooks;\n"
989    }
990    append text "\ntypedef struct ${capName}Stubs {\n"
991    append text "    int magic;\n"
992    append text "    struct ${capName}StubHooks *hooks;\n\n"
993
994    emitSlots $name text
995
996    append text "} ${capName}Stubs;\n"
997
998    append text "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
999    append text "extern ${capName}Stubs *${name}StubsPtr;\n"
1000    append text "#ifdef __cplusplus\n}\n#endif\n"
1001
1002    emitMacros $name text
1003
1004    rewriteFile [file join $outDir ${name}Decls.h] $text
1005    return
1006}
1007
1008# genStubs::emitStubs --
1009#
1010#       This function emits the body of the <name>Stubs.c file for
1011#       the specified interface.
1012#
1013# Arguments:
1014#       name    The name of the interface being emitted.
1015#
1016# Results:
1017#       None.
1018
1019proc genStubs::emitStubs {name} {
1020    variable outDir
1021
1022    append text "\n/*\n * Exported stub functions:\n */\n\n"
1023    forAllStubs $name makeStub 0 text
1024
1025    rewriteFile [file join $outDir ${name}Stubs.c] $text
1026    return
1027}
1028
1029# genStubs::emitInit --
1030#
1031#       Generate the table initializers for an interface.
1032#
1033# Arguments:
1034#       name            The name of the interface to initialize.
1035#       textVar         The variable to use for output.
1036#
1037# Results:
1038#       Returns the formatted output.
1039
1040proc genStubs::emitInit {name textVar} {
1041    variable stubs
1042    variable hooks
1043    upvar $textVar text
1044
1045    set capName [string toupper [string index $name 0]]
1046    append capName [string range $name 1 end]
1047
1048    if {[info exists hooks($name)]} {
1049        append text "\nstatic ${capName}StubHooks ${name}StubHooks = \{\n"
1050        set sep "    "
1051        foreach sub $hooks($name) {
1052            append text $sep "&${sub}Stubs"
1053            set sep ",\n    "
1054        }
1055        append text "\n\};\n"
1056    }
1057    append text "\n${capName}Stubs ${name}Stubs = \{\n"
1058    append text "    TCL_STUB_MAGIC,\n"
1059    if {[info exists hooks($name)]} {
1060        append text "    &${name}StubHooks,\n"
1061    } else {
1062        append text "    NULL,\n"
1063    }
1064
1065    forAllStubs $name makeInit 1 text {"    NULL, /* $i */\n"}
1066
1067    append text "\};\n"
1068    return
1069}
1070
1071# genStubs::emitInits --
1072#
1073#       This function emits the body of the <name>StubInit.c file for
1074#       the specified interface.
1075#
1076# Arguments:
1077#       name    The name of the interface being emitted.
1078#
1079# Results:
1080#       None.
1081
1082proc genStubs::emitInits {} {
1083    variable hooks
1084    variable outDir
1085    variable libraryName
1086    variable interfaces
1087
1088    # Assuming that dependencies only go one level deep, we need to emit
1089    # all of the leaves first to avoid needing forward declarations.
1090
1091    set leaves {}
1092    set roots {}
1093    foreach name [lsort [array names interfaces]] {
1094        if {[info exists hooks($name)]} {
1095            lappend roots $name
1096        } else {
1097            lappend leaves $name
1098        }
1099    }
1100    foreach name $leaves {
1101        emitInit $name text
1102    }
1103    foreach name $roots {
1104        emitInit $name text
1105    }
1106
1107    rewriteFile [file join $outDir ${libraryName}StubInit.c] $text
1108}
1109
1110# genStubs::init --
1111#
1112#       This is the main entry point.
1113#
1114# Arguments:
1115#       None.
1116#
1117# Results:
1118#       None.
1119
1120proc genStubs::init {} {
1121    global argv argv0
1122    variable outDir
1123    variable interfaces
1124
1125    if {[llength $argv] < 2} {
1126        puts stderr "usage: $argv0 outDir declFile ?declFile...?"
1127        exit 1
1128    }
1129
1130    set outDir [lindex $argv 0]
1131
1132    foreach file [lrange $argv 1 end] {
1133        source $file
1134    }
1135
1136    foreach name [lsort [array names interfaces]] {
1137        puts "Emitting $name"
1138        emitHeader $name
1139    }
1140
1141    emitInits
1142}
1143
1144# lassign --
1145#
1146#       This function emulates the TclX lassign command.
1147#
1148# Arguments:
1149#       valueList       A list containing the values to be assigned.
1150#       args            The list of variables to be assigned.
1151#
1152# Results:
1153#       Returns any values that were not assigned to variables.
1154
1155if {[string length [namespace which lassign]] == 0} {
1156    proc lassign {valueList args} {
1157        if {[llength $args] == 0} {
1158            error "wrong # args: lassign list varname ?varname..?"
1159        }
1160        uplevel [list foreach $args $valueList {break}]
1161        return [lrange $valueList [llength $args] end]
1162    }
1163}
1164
1165genStubs::init
Note: See TracBrowser for help on using the repository browser.