File: genExtStubs.tcl

package info (click to toggle)
tdbc 1.1.1-1
  • links: PTS
  • area: main
  • in suites: bullseye
  • size: 928 kB
  • sloc: sh: 2,256; tcl: 1,146; ansic: 886; makefile: 61
file content (352 lines) | stat: -rw-r--r-- 9,129 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
# genExtStubs.tcl --
#
#	Generates an import table for one or more external dynamic
#	link libraries.
#
# Usage:
#
#	tclsh genExtStubs.tcl stubDefs.txt stubStruct.h stubInit.c
#
# Parameters:
#
#	stubsDefs.txt --
#		Name of a file containing declarations of functions
#		to be stubbed. The functions are expected to be in
#		stylized C where exach appears on a single line, and
#		has the form 'returnType name(param,param,...);'
#		In addition, comments of the following forms
#		are expected to precede the function declarations.
#			/* LIBRARY: name1 name2... */
#		These comments give the rootnames of dynamic link
#		libraries that are expected to contain the functions,
#		in order of preference.
#			/* STUBSTRUCT: prefix */
#		String to be prepended to the function name that translates
#		to its reference in the stub table.
#	stubStruct.h --
#		Name of a file that will contain (a) the declaration
#		of a structure that contains pointers to the stubbed
#		functions, and (b) #defines replacing the function name
#		with references into the stub table

# parseImports --
#
#	Parse the import declarations in a given file
#
# Parameters:
#	stubDefs -- Name of the file to parse
#
# Results:
#
#	Returns a list of tuples. The possible tuples are:
#
#	    libraries NAME NAME...
#		Sets the names of the
#	    prefix NAME
#	        Sets the name of the stub structure to NAME and prefixes
#		all the definitions of the stubbed routines with NAME
#	    import TYPE NAME PARAMS
#		Declares the imported routine NAME to return data of type
#		TYPE and accept parmeters PARAMS.

proc parseImports {stubDefs} {

    set defsFile [open $stubDefs r]
    set imports {}
    set lineNo 0
    while {[gets $defsFile line] >= 0} {
	incr lineNo
	if {[string is space $line]} {
	    # do nothing
	} elseif {[regexp -expanded -- {
	    ^\s*\*\s*LIBRARY:\s+
	    ([a-zA-Z0-9_]+(?:\s+[a-zA-Z0-9_]+)*) # List of library names
	} $line -> m]} {
	    set libNames $m
	    lappend imports [linsert $libNames 0 libraries]
	} elseif {[regexp {^\s*\*\s*STUBSTRUCT:\s*(.*)} $line -> m]} {
	    set stubPrefix $m
	    lappend imports [list prefix $m]
	} elseif {[regexp {^\s*\*\s*CONVENTION:\s*(.*)} $line -> c]} {
	    lappend imports [list convention $c]
	} elseif {[regexp -nocase -- {^\s*#} $line]} {
	    # do nothing
	} elseif {[regexp -nocase -expanded -- {
	    \s*(.*)\s+			# Return type
	    ([[:alpha:]_][[:alnum:]_]+)	# Function name
	    \s*\((.*)\);		# Parameters
	} $line -> type name params]} {
	    lappend imports [list import $type $name $params]
	} else {
	    puts stderr "$stubDefs:$lineNo: unrecognized syntax"
	}
    }
    close $defsFile

    return $imports
}

# writeStructHeader --
#
#	Writes the header of the stubs structure to the '.h' file
#
# Parameters:
#	stubDefs   -- Name of the input file from which stubs are being
#		      generated
#	stubStruct -- Name of the file .h being written
#	structFile -- Channel ID of the .h file being written
#
# Results:
#	None.
#
# Side effects:
#	Writes the 'struct' header to the .h file

proc writeStructHeader {stubDefs stubStruct structFile} {

    chan puts $structFile "/*"
    chan puts $structFile " *[string repeat - 77]"
    chan puts $structFile " *"
    chan puts $structFile " * $stubStruct --"
    chan puts $structFile " *"
    chan puts $structFile " *\tStubs for procedures in [file tail $stubDefs]"
    chan puts $structFile " *"
    chan puts $structFile " * Generated by [file tail $::argv0]: DO NOT EDIT"
    chan puts $structFile " * [clock format [clock seconds] \
				-format {%Y-%m-%d %H:%M:%SZ} -gmt true]"
    chan puts $structFile " *"
    chan puts $structFile " *[string repeat - 77]"
    chan puts $structFile " */"
    chan puts $structFile ""
    chan puts $structFile "typedef struct [file rootname [file tail $stubDefs]] \{"

    return
}

# writeStubDeclarations --
#
#	Writes the declarations of the stubs in the table to the .h file.
#
# Parameters:
#	structFile -- Channel ID of the .h file
#	imports -- List of tuples returned from 'parseImports'
#
# Results:
#	None.
#
# Side effects:
#	C pointer-to-function declarations are written to the given file.

proc writeStubDeclarations {structFile imports} {

    set convention {}
    foreach i $imports {
	set key [lindex $i 0]
	switch -exact -- $key {
	    convention {
		set convention [lindex $i 1]
	    }
	    import {
		lassign $i key type name params
		chan puts $structFile \
		    "    $type (${convention}*${name}Ptr)($params);"
	    }
	    libraries {
		chan puts $structFile {}
		chan puts $structFile \
		    "    /* Functions from libraries: [lrange $i 1 end] */"
		chan puts $structFile {}
	    }
	    default {
	    }
	}
    }

    return
}

# writeStructFooter --
#
#	Writes the close of the 'struct' declaration to the .h file
#
# Parameters:
#	stubDefs   -- Name of the struct
#	structFile -- Channel handle of the .h file
#
# Results:
#	None
#
# Side effects:
#	Structure declaration is closed.

proc writeStructFooter {stubDefs structFile} {
    chan puts $structFile "\} [file rootname [file tail $stubDefs]]\;"
    return
}

# writeStubDefines --
#
#	Write the #define directives that replace stub function calls with
#	indirections through the stubs table.
#
# Parameters:
#	structFile -- Channel id of the .h file
#	imports    -- Table of imports from parseImports

proc writeStubDefines {structFile imports} {

    set stubPrefix {}
    foreach i $imports {
	switch -exact -- [lindex $i 0] {
	    prefix {
		lassign $i -> stubPrefix
	    }
	    import {
		lassign $i -> type name params
		chan puts $structFile "#define $name ($stubPrefix->${name}Ptr)"
	    }
	}
    }
    return $stubPrefix
}

# accumulateLibNames --
#
#	Accumulates the list of library names into the Stub initialization
#
# Parameters:
#	codeVar - Name of variable in caller's scope containing the code
#		  under construction
#	imports - Import definitions from 'parseImports'
#
# Results:
#	Returns the code burst for the initialization file.

proc accumulateLibNames {codeVar imports} {
    upvar 1 $codeVar code
    set sep "\n    "
    foreach i $imports {
	if {[lindex $i 0] eq {libraries}} {
	    foreach lib [lrange $i 1 end] {
		append code $sep \" $lib \"
		set sep ", "
	    }
	}
    }
    append code $sep "NULL"
}

# accumulateSymNames --
#
#	Accumulates the list of import symbols into the Stub initialization
#
# Parameters:
#	codeVar - Name of variable in caller's scope containing the code
#		  under construction
#	imports - Import definitions from 'parseImports'
#
# Results:
#	Returns the code burst for the initialization file.

proc accumulateSymNames {codeVar imports} {
    upvar 1 $codeVar code
    set inLibrary 0
    set sep {}
    foreach i $imports {
	switch -exact -- [lindex $i 0] {
	    import {
		lassign $i key type name args
		append code $sep \n {    } \" $name \"
		set sep ,
	    }
	}
    }
    append code $sep \n {    NULL}
}

# rewriteInitProgram --
#
#	Rewrite the 'stubInit.c' program to contain new definitions
#	of imported routines
#
# Parameters:
#	oldProgram -- Previous content of the 'stubInit.c' file
#	imports    -- Import definitions from 'parseImports'
#
# Results:
#	Returns the new import program

proc rewriteInitProgram {stubDefs oldProgram imports} {
    set newProgram {}
    set sep {}
    set state {}
    foreach piece [split $oldProgram \n] {
	switch -exact -- $state {
	    {} {
		switch -regexp -- $piece {
		    @CREATED@ {
			regsub @CREATED@.* $piece {@CREATED@ } piece
			append piece [clock format [clock seconds] \
					  -format {%Y-%m-%d %H:%M:%SZ} \
					  -gmt 1]
			append piece " by " [file tail $::argv0]
			append piece " from " $stubDefs
		    }
		    @LIBNAMES@ {
			set state ignoring
			accumulateLibNames piece $imports
		    }
		    @SYMNAMES@ {
			set state ignoring
			accumulateSymNames piece $imports
		    }
		}
		append newProgram $sep $piece
		set sep \n

	    }
	    ignoring {
		if {[regexp -- @END@ $piece]} {
		    set state {}
		    append newProgram $sep $piece
		    set sep \n
		}
	    }
	}
    }
    return $newProgram
}

# MAIN PROGRAM - see file header for calling sequence

proc main {stubDefs stubStruct stubInit} {

    # Parse the import definitions

    set imports [parseImports $stubDefs]

    # Write the Stub structure declarations

    set structFile [open $stubStruct w]
    chan configure $structFile -translation lf
    writeStructHeader $stubDefs $stubStruct $structFile
    writeStubDeclarations $structFile $imports
    writeStructFooter $stubDefs $structFile
    set stubPrefix [writeStubDefines $structFile $imports]
    chan puts $structFile "MODULE_SCOPE const [file rootname [file tail $stubDefs]]\
                           *${stubPrefix};"
    close $structFile

    # Write the initializations of the function names to import

    set initFile [open $stubInit r+]
    set initProgram [chan read $initFile]
    set initProgram [rewriteInitProgram $stubDefs $initProgram $imports]
    chan seek $initFile 0
    chan truncate $initFile
    chan configure $initFile -translation lf
    chan puts -nonewline $initFile $initProgram
    close $initFile

}
main {*}$argv