← Back to branch summary

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

« back to all changes in this revision

Viewing changes to lib/stubs/container.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/container.tcl
 
1
# -*- tcl -*-
 
2
# STUBS handling -- Container.
 
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 container is a variable holding a stubs table value.
 
8
 
 
9
# stubs table dictionary keys
 
10
#
 
11
# library --
 
12
#
 
13
#       The name of the entire library.  This value is used to compute
 
14
#       the USE_*_STUB_PROCS macro and the name of the init file.
 
15
#
 
16
# interfaces --
 
17
#
 
18
#       A dictionary indexed by interface name that is used to maintain
 
19
#       the set of valid interfaces. The value is empty.
 
20
#
 
21
# scspec --
 
22
#
 
23
#       Storage class specifier for external function declarations.
 
24
#       Normally "EXTERN", may be set to something like XYZAPI
 
25
#
 
26
# epoch, revision --
 
27
#
 
28
#       The epoch and revision numbers of the interface currently being defined.
 
29
#   (@@@TODO: should be an array mapping interface names -> numbers)
 
30
#
 
31
# hooks --
 
32
#
 
33
#       A dictionary indexed by interface name that contains the set of
 
34
#       subinterfaces that should be defined for a given interface.
 
35
#
 
36
# stubs --
 
37
#
 
38
#       This three dimensional dictionary is indexed first by interface
 
39
#       name, second by platform name, and third by a numeric
 
40
#       offset. Each numeric offset contains the C function
 
41
#       specification that should be used for the given entry in the
 
42
#       table. The specification consists of a list in the form returned
 
43
#       by ParseDecl in the stubs reader package, i.e.
 
44
#
 
45
#       decl      = list (return-type fun-name arguments)
 
46
#       arguments = void | list (arg-info ...)
 
47
#       arg-info  = list (type name ?array?)
 
48
#       array = '[]'
 
49
#
 
50
# last --
 
51
#
 
52
#       This two dimensional dictionary is indexed first by interface name,
 
53
#       and second by platform name. The associated entry contains the
 
54
#       largest numeric offset used for a given interface/platform
 
55
#       combo.
 
56
 
 
57
# # ## ### ##### ######## #############
 
58
## Requisites
 
59
 
 
60
package require Tcl 8.4
 
61
package require dict84 ; # Ensure presence of a dict command.
 
62
 
 
63
namespace eval ::stubs::container {}
 
64
 
 
65
# # ## ### ##### ######## #############
 
66
## Implementation.
 
67
 
 
68
proc ::stubs::container::new {} {
 
69
    return {
 
70
        library    "UNKNOWN"
 
71
        interfaces {}
 
72
        hooks      {}
 
73
        stubs      {}
 
74
        last       {}
 
75
        scspec     "EXTERN"
 
76
        epoch      {}
 
77
        revision   0
 
78
    }
 
79
}
 
80
 
 
81
# Methods to incrementally fill the container with data. Strongly
 
82
# related to the API commands of the stubs reader package.
 
83
 
 
84
proc ::stubs::container::library {tablevar name} {
 
85
    upvar 1 $tablevar t
 
86
    dict set t library $name
 
87
    return
 
88
}
 
89
 
 
90
proc ::stubs::container::interface {tablevar name} {
 
91
    upvar 1 $tablevar t
 
92
    if {[dict exists $t interfaces $name]} {
 
93
        return -code error "Duplicate declaration of interface \"$name\""
 
94
    }
 
95
    dict set t interfaces $name {}
 
96
    return
 
97
}
 
98
 
 
99
proc ::stubs::container::scspec {tablevar value} {
 
100
    upvar 1 $tablevar t
 
101
    dict set t scspec $value
 
102
    return
 
103
}
 
104
 
 
105
proc ::stubs::container::epoch {tablevar value} {
 
106
    upvar 1 $tablevar t
 
107
 
 
108
    if {![string is integer -strict $value]} {
 
109
        return -code error "Expected integer for epoch, but got \"$value\""
 
110
    }
 
111
 
 
112
    dict set t epoch $value
 
113
    return
 
114
}
 
115
 
 
116
proc ::stubs::container::hooks {tablevar interface names} {
 
117
    upvar 1 $tablevar t
 
118
    dict set t hooks $interface $names
 
119
    return
 
120
}
 
121
 
 
122
proc ::stubs::container::declare {tablevar interface index platforms decl} {
 
123
    variable legalplatforms
 
124
    upvar 1 $tablevar t
 
125
 
 
126
    #puts "DECLARE ($interface $index) \[$platforms\] =\n\t'[join $decl "'\n\t'"]'"
 
127
 
 
128
    if {![dict exists $t interfaces $interface]} {
 
129
        return -code error "Unknown interface \"$interface\""
 
130
    }
 
131
    if {![string is integer -strict $index]} {
 
132
        return -code error "Bad index \"$index\", expected integer"
 
133
    }
 
134
 
 
135
    # legal platform codes
 
136
    # - unix, win, macosx, x11, aqua
 
137
 
 
138
    # Check for duplicate declarations, then add the declaration and
 
139
    # bump the lastNum counter if necessary.
 
140
 
 
141
    foreach platform $platforms {
 
142
        if {![dict exists $legalplatforms $platform]} {
 
143
            set expected [linsert [join [lsort -dict [dict keys $legalplatforms]] {, }] end-1 or]
 
144
            return -code error "Bad platform \"$platform\", expected one of $expected"
 
145
        }
 
146
 
 
147
        set key $interface,$platform,$index
 
148
        if {[dict exists $t stubs $key]} {
 
149
            return -code error \
 
150
                "Duplicate entry: declare $interface $index $platforms $decl"
 
151
        }
 
152
    }
 
153
 
 
154
    if {![llength $decl]} return
 
155
 
 
156
    dict incr t revision
 
157
 
 
158
    foreach platform $platforms {
 
159
        set group $interface,$platform
 
160
        set key   $interface,$platform,$index
 
161
 
 
162
        dict set t stubs $key $decl
 
163
        if {![dict exists $t last $group] ||
 
164
            ($index > [dict get $t last $group])} {
 
165
            dict set t last $group $index
 
166
        }
 
167
    }
 
168
    return
 
169
}
 
170
 
 
171
# # ## ### ##### ######## #############
 
172
# Testing methods.
 
173
 
 
174
proc ::stubs::container::library? {table} {
 
175
    return [dict get $table library]
 
176
}
 
177
 
 
178
proc ::stubs::container::hooks? {table interface} {
 
179
    if {![dict exists $table interfaces $interface]} {
 
180
        return -code error "Unknown interface \"$interface\""
 
181
    }
 
182
    return [dict exists $table hooks $interface]
 
183
}
 
184
 
 
185
proc ::stubs::container::slot? {table interface platform at} {
 
186
    if {![dict exists $table interfaces $interface]} {
 
187
        return -code error "Unknown interface \"$interface\""
 
188
    }
 
189
    return [dict exists $table stubs $interface,$platform,$at]
 
190
}
 
191
 
 
192
proc ::stubs::container::scspec? {table} {
 
193
    return [dict get $table scspec]
 
194
}
 
195
 
 
196
proc ::stubs::container::revision? {table} {
 
197
    return [dict get $table revision]
 
198
}
 
199
 
 
200
proc ::stubs::container::epoch? {table} {
 
201
    return [dict get $table epoch]
 
202
}
 
203
 
 
204
# # ## ### ##### ######## #############
 
205
# Accessor methods.
 
206
 
 
207
proc ::stubs::container::interfaces {table} {
 
208
    return [dict keys [dict get $table interfaces]]
 
209
}
 
210
 
 
211
proc ::stubs::container::hooksof {table interface} {
 
212
    if {![dict exists $table interfaces $interface]} {
 
213
        return -code error "Unknown interface \"$interface\""
 
214
    }
 
215
    if {![dict exists $table hooks $interface]} {
 
216
        return {}
 
217
    }
 
218
    return [dict get $table hooks $interface]
 
219
}
 
220
 
 
221
proc ::stubs::container::platforms {table interface} {
 
222
    if {![dict exists $table interfaces $interface]} {
 
223
        return -code error "Unknown interface \"$interface\""
 
224
    }
 
225
    set res {}
 
226
    #checker exclude warnArgWrite
 
227
    dict with table {
 
228
        #checker -scope block exclude warnUndefinedVar
 
229
        # 'last' is dict element.
 
230
        foreach k [dict keys $last $interface,*] {
 
231
            lappend res [lindex [split $k ,] end]
 
232
        }
 
233
    }
 
234
    return $res
 
235
}
 
236
 
 
237
proc ::stubs::container::lastof {table interface {platform {}}} {
 
238
    if {![dict exists $table interfaces $interface]} {
 
239
        return -code error "Unknown interface \"$interface\""
 
240
    }
 
241
    if {[llength [info level 0]] == 4} {
 
242
        set key $interface,$platform
 
243
        if {![dict exists $table last $key]} {
 
244
            return -1
 
245
        }
 
246
        return [dict get $table last $key]
 
247
    }
 
248
 
 
249
    set res {}
 
250
    #checker exclude warnArgWrite
 
251
    dict with table {
 
252
        #checker -scope block exclude warnUndefinedVar
 
253
        # 'last' is dict element.
 
254
        foreach k [dict keys $last $interface,*] {
 
255
            lappend res [dict get $last $k]
 
256
        }
 
257
    }
 
258
    return $res
 
259
}
 
260
 
 
261
proc ::stubs::container::slotplatforms {table interface at} {
 
262
    if {![dict exists $table interfaces $interface]} {
 
263
        return -code error "Unknown interface \"$interface\""
 
264
    }
 
265
    set res {}
 
266
    #checker exclude warnArgWrite
 
267
    dict with table {
 
268
        #checker -scope block exclude warnUndefinedVar
 
269
        # 'stubs' is dict element.
 
270
        foreach k [dict keys $stubs $interface,*,$at] {
 
271
            lappend res [lindex [split $k ,] 1]
 
272
        }
 
273
    }
 
274
    return $res
 
275
}
 
276
 
 
277
proc ::stubs::container::slot {table interface platform at} {
 
278
    if {![dict exists $table interfaces $interface]} {
 
279
        return -code error "Unknown interface \"$interface\""
 
280
    }
 
281
    if {![dict exists $table stubs $interface,$platform,$at]} {
 
282
        return -code error "Unknown slot \"$platform,$at\""
 
283
    }
 
284
    return [dict get $table stubs $interface,$platform,$at]
 
285
}
 
286
 
 
287
# # ## ### ##### ######## #############
 
288
## Serialize, also nicely formatted for readability.
 
289
 
 
290
proc ::stubs::container::print {table} {
 
291
 
 
292
    lappend lines "stubs [list [library? $table]] \{"
 
293
    lappend lines "    scspec   [list [scspec? $table]]"
 
294
    lappend lines "    epoch    [list [epoch? $table]]"
 
295
    lappend lines "    revision [list [revision? $table]]"
 
296
 
 
297
    foreach if [interfaces $table] {
 
298
        lappend lines "    interface [list $if] \{"
 
299
        lappend lines "        hooks [list [hooksof $table $if]]"
 
300
 
 
301
        set n -1
 
302
        foreach l [lastof $table $if] {
 
303
            if {$l > $n} { set n $l }
 
304
        }
 
305
        # n = max lastof for the interface.
 
306
 
 
307
        for {set at 0} {$at <= $n} {incr at} {
 
308
 
 
309
            set pl [slotplatforms $table $if $at]
 
310
            if {![llength $pl]} continue
 
311
 
 
312
            foreach p $pl {
 
313
                lappend d $p [slot $table $if $p $at]
 
314
                #puts  |[lindex $d end-1]|[lindex $d end]|
 
315
            }
 
316
            # d = list of decls for the slot, per platform.
 
317
            # invert and collapse...
 
318
 
 
319
            foreach {d plist} [Invert $d] {
 
320
                #puts |$d|
 
321
                #puts <$plist>
 
322
 
 
323
                # d = list (rtype fname arguments)
 
324
                # arguments = list (argdef)
 
325
                # argdef = list (atype aname arrayflag)
 
326
                #        | list (atype aname)
 
327
                #        | list (atype)
 
328
 
 
329
                lassign $d rtype fname fargs
 
330
 
 
331
                lappend lines "        declare $at [list $plist] \{"
 
332
                lappend lines "            function [list $fname]"
 
333
                lappend lines "            return [list $rtype]"
 
334
                foreach a $fargs {
 
335
                    lappend lines "            argument [list $a]"
 
336
                }
 
337
                lappend lines "        \}"
 
338
            }
 
339
        }
 
340
 
 
341
        lappend lines "    \}"
 
342
    }
 
343
 
 
344
    lappend lines "\}"
 
345
 
 
346
    return [join $lines \n]
 
347
}
 
348
 
 
349
proc ::stubs::container::Invert {dict} {
 
350
    # input       dict : key -> list(value)
 
351
    # result is a dict : value -> list(key)
 
352
 
 
353
    array set res {}
 
354
    foreach {k v} $dict {
 
355
        lappend res($v) $k
 
356
    }
 
357
    #parray res
 
358
    set final {}
 
359
    foreach k [lsort -dict [array names res]] {
 
360
        lappend final $k [lsort -dict $res($k)]
 
361
    }
 
362
    return $final
 
363
}
 
364
 
 
365
# # ## ### ##### ######## #############
 
366
## API
 
367
 
 
368
namespace eval ::stubs::container {
 
369
    variable legalplatforms {
 
370
        generic .
 
371
        unix    .
 
372
        win     .
 
373
        macosx  .
 
374
        x11     .
 
375
        aqua    .
 
376
    }
 
377
 
 
378
    namespace export \
 
379
        new library interface scspec epoch hooks declare \
 
380
        library? hooks? slot? scspec? revision? epoch? \
 
381
        interfaces hooksof platforms lastof slotplatforms slot
 
382
}
 
383
 
 
384
# # ## ### #####
 
385
package provide stubs::container 1
 
386
return