← Back to branch summary

~ubuntu-branches/ubuntu/utopic/critcl/utopic

« back to all changes in this revision

Viewing changes to lib/stubs/gen_lib.tcl

  • Committer: Package Import Robot
  • Author(s): Andrew Shadura
  • Date: 2013-05-11 00:08:06 UTC
  • Revision ID: package-import@ubuntu.com-20130511000806-7hq1zc3fnn0gat79
Tags: upstream-3.1.9
Import upstream version 3.1.9

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/stubs/gen_lib.tcl
 
1
# -*- tcl -*-
 
2
# STUBS handling -- Code generation: Writing the initialization code for IMPORTers.
 
3
#
 
4
# (c) 2011 Andreas Kupries http://wiki.tcl.tk/andreas%20kupries
 
5
 
 
6
# A stubs table is represented by a dictionary value.
 
7
# A gen is a variable holding a stubs table value.
 
8
 
 
9
# # ## ### ##### ######## #############
 
10
## Requisites
 
11
 
 
12
package require Tcl 8.4
 
13
package require stubs::gen
 
14
package require stubs::container
 
15
package require lassign84
 
16
 
 
17
namespace eval ::stubs::gen::lib::g {
 
18
    namespace import ::stubs::gen::*
 
19
}
 
20
 
 
21
namespace eval ::stubs::gen::lib::c {
 
22
    namespace import ::stubs::container::*
 
23
}
 
24
 
 
25
# # ## ### ##### ######## #############
 
26
## Implementation.
 
27
 
 
28
proc ::stubs::gen::lib::gen {table} {
 
29
    # Assuming that dependencies only go one level deep, we need to
 
30
    # emit all of the leaves first to avoid needing forward
 
31
    # declarations.
 
32
 
 
33
    variable template
 
34
 
 
35
    # Assuming that dependencies only go one level deep, we emit all
 
36
    # of the leaves first to avoid needing forward declarations.
 
37
 
 
38
    set leaves {}
 
39
    set roots  {}
 
40
 
 
41
    foreach name [lsort [c::interfaces $table]] {
 
42
        if {[c::hooks? $table $name]} {
 
43
            lappend roots $name
 
44
        } else {
 
45
            lappend leaves $name
 
46
        }
 
47
    }
 
48
 
 
49
    set headers   {}
 
50
    set variables {}
 
51
    set hooks     {}
 
52
 
 
53
    foreach name [concat $leaves $roots] {
 
54
        set capName [g::cap $name]
 
55
 
 
56
        # POLISH - format the variables code block aligned using
 
57
        # maxlength of interface names.
 
58
        lappend headers   "\#include \"${name}Decls.h\""
 
59
        lappend variables "const ${capName}Stubs* ${name}StubsPtr;"
 
60
 
 
61
        # Check if this is a hook. If yes it needs additional setup.
 
62
        set parent [Parent $table $name]
 
63
        if {$parent eq ""} continue
 
64
        lappend hooks "    ${name}StubsPtr = ${parent}StubsPtr->hooks->${name}Stubs;"
 
65
    }
 
66
 
 
67
    set pname   [c::library? $table] ; # FUTURE: May be separate from the library
 
68
    #                                    namespaces!
 
69
    set name    [string map {:: _} [c::library? $table]]
 
70
    set capName [g::cap $name]
 
71
    set upName  [string toupper $name]
 
72
 
 
73
    set headers   [Block $headers]
 
74
    set variables [Block $variables]
 
75
    set hooks     [Block $hooks]
 
76
 
 
77
    return [string map \
 
78
                [list \
 
79
                     @PKG@     $pname \
 
80
                     @@        $name  \
 
81
                     @UP@      $upName \
 
82
                     @CAP@     $capName \
 
83
                     @HEADERS@ $headers  \
 
84
                     @VARS@    $variables \
 
85
                     @HOOKS@   $hooks    \
 
86
                    ] $template]
 
87
    return $text
 
88
}
 
89
 
 
90
proc ::stubs::gen::lib::Block {list} {
 
91
    if {![llength $list]} { return "" }
 
92
    return \n[join $list \n]\n
 
93
}
 
94
 
 
95
proc ::stubs::gen::lib::make@ {basedir table} {
 
96
    make [path $basedir [c::library? $table]] $table    
 
97
}
 
98
 
 
99
proc ::stubs::gen::lib::make {path table} {
 
100
    set c [open $path w]
 
101
    puts -nonewline $c [gen $table]
 
102
    close $c
 
103
    return
 
104
}
 
105
 
 
106
proc ::stubs::gen::lib::path {basedir name} {
 
107
    return [file join $basedir ${name}StubLib.c]
 
108
}
 
109
 
 
110
# # ## ### #####
 
111
## Internal helpers.
 
112
 
 
113
proc ::stubs::gen::lib::Parent {table name} {
 
114
    # Check if this interface is a hook for some other interface.
 
115
    # TODO: Make this a container API command.
 
116
    foreach intf [c::interfaces $table] {
 
117
        if {[c::hooks? $table $intf] &&
 
118
            ([lsearch -exact [c::hooksof $table $intf] $name] >= 0)} {
 
119
            return $intf
 
120
        }
 
121
    }
 
122
    return ""
 
123
}
 
124
 
 
125
# # ## ### #####
 
126
namespace eval ::stubs::gen::lib {
 
127
    #checker exclude warnShadowVar
 
128
    variable template [string map {{
 
129
        } {
 
130
}} {
 
131
        /* 
 
132
         * @@StubLib.c --
 
133
         *
 
134
         * Stub object that will be statically linked into extensions that wish
 
135
         * to access @@.
 
136
         */
 
137
 
 
138
        /*
 
139
         * We need to ensure that we use the stub macros so that this file contains
 
140
         * no references to any of the stub functions.  This will make it possible
 
141
         * to build an extension that references @CAP@_InitStubs but doesn't end up
 
142
         * including the rest of the stub functions.
 
143
         */
 
144
 
 
145
        #ifndef USE_TCL_STUBS
 
146
        #define USE_TCL_STUBS
 
147
        #endif
 
148
        #undef  USE_TCL_STUB_PROCS
 
149
 
 
150
        #include <tcl.h>
 
151
 
 
152
        #ifndef USE_@UP@_STUBS
 
153
        #define USE_@UP@_STUBS
 
154
        #endif
 
155
        #undef  USE_@UP@_STUB_PROCS
 
156
        @HEADERS@
 
157
        /*
 
158
         * Ensure that @CAP@_InitStubs is built as an exported symbol.  The other stub
 
159
         * functions should be built as non-exported symbols.
 
160
         */
 
161
 
 
162
        #undef  TCL_STORAGE_CLASS
 
163
        #define TCL_STORAGE_CLASS DLLEXPORT
 
164
        @VARS@
 
165
        
 
166
        /*
 
167
         *----------------------------------------------------------------------
 
168
         *
 
169
         * @CAP@_InitStubs --
 
170
         *
 
171
         * Checks that the correct version of @CAP@ is loaded and that it
 
172
         * supports stubs. It then initialises the stub table pointers.
 
173
         *
 
174
         * Results:
 
175
         *  The actual version of @CAP@ that satisfies the request, or
 
176
         *  NULL to indicate that an error occurred.
 
177
         *
 
178
         * Side effects:
 
179
         *  Sets the stub table pointers.
 
180
         *
 
181
         *----------------------------------------------------------------------
 
182
         */
 
183
 
 
184
        #ifdef @CAP@_InitStubs
 
185
        #undef @CAP@_InitStubs
 
186
        #endif
 
187
 
 
188
        char *
 
189
        @CAP@_InitStubs(Tcl_Interp *interp, CONST char *version, int exact)
 
190
        {
 
191
            CONST char *actualVersion;
 
192
 
 
193
            actualVersion = Tcl_PkgRequireEx(interp, "@PKG@", version,
 
194
                                             exact, (ClientData *) &@@StubsPtr);
 
195
            if (!actualVersion) {
 
196
                return NULL;
 
197
            }
 
198
 
 
199
            if (!@@StubsPtr) {
 
200
                Tcl_SetResult(interp,
 
201
                              "This implementation of @CAP@ does not support stubs",
 
202
                              TCL_STATIC);
 
203
                return NULL;
 
204
            }
 
205
            @HOOKS@
 
206
            return (char*) actualVersion;
 
207
        }
 
208
    }]
 
209
 
 
210
    namespace export gen make@ make rewrite@ rewrite path
 
211
}
 
212
 
 
213
# # ## ### ##### ######## #############
 
214
package provide stubs::gen::lib 1
 
215
return