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
353
|
#!/usr/local/bin/tclsh
# $Id: pltclgen.tcl 12007 2011-10-28 12:02:58Z andrewross $
#
# Arjen Markus
# - translation of the original Perl script
#
# This script is used to automatically generate most of the functions needed
# to implement the PLplot Tcl API. It reads a file which specifies the
# PLplot API command arguments and return value (basically like a C
# prototype, but easier to parse) and generates a Tcl command procedure to
# call that function.
#
# Currently it can support arguments of type PLINT, PLFLT, char *, PLINT&
# and PLFLT& where the last two are used for the 'g' series functions which
# provide data to the caller.
#
# What is not supported at this time, but needs to be, is support for (those
# few) PLplot API functions with non-void return types, and (the many)
# PLplot API functions which accept arrays (PLFLT *, etc). The latter can
# in many cases be correctly treated as 1-d Tcl Matricies. The code for
# using these should be sufficiently perfunctory to be amenable to an
# approach like that used here. Automatic support for the 2-d API is
# probably unrealistic.
###############################################################################
# Process a function "prototype". Suck up the args, then perform the
# needed substitutions to the Tcl command procedure template.
# Generate the three outputs needed for use in tclAPI.c: the C
# function prototype, the CmdInfo structure initializer, and the
# actual function definition.
proc process_pltclcmd {cmd rtype} {
global verbose
global cmdfile
global GENHEAD
global GENSTRUCT
global GENFILE
global SPECFILE
if { $::verbose } {
puts "\nautogenerating Tcl command proc for $rtype $cmd ()"
}
puts $GENHEAD "static int ${cmd}Cmd( ClientData, Tcl_Interp *, int, const char **);"
puts $GENSTRUCT " {\"$cmd\", ${cmd}Cmd},"
set args ""
set nargs 0
set ndefs 0
set refargs 0
while { [gets $SPECFILE line] >= 0 } {
if { $line == "" } {
break
}
if { [regexp {^(\w+)\s+(.*)$} $line ==> vname vtype] > 0 } {
set defval ""
if { $verbose } {
puts "vname=$vname vtype=$vtype"
}
if { [regexp {(.*)\s+Def:\s+(.*)} $vtype ==> vtype defval] } {
if { $verbose } {
puts "default arg: vtype=$vtype defval=$defval"
}
}
set argname($nargs) $vname
set argtype($nargs) $vtype
set argdef($nargs) $defval
set argref($nargs) 0 ;# default.
# Check to see if this arg is for fetching something from PLplot.
if { [string first & $vtype] >= 0 || $vtype == "char *" } {
set refargs 1
set argref($nargs) 1
}
if { $nargs == 0 } {
set args "${args}$vname"
} else {
set args "$args $vname"
}
if { $defval != "" } {
incr ndefs
}
incr nargs
continue
}
# Unrecognized output.
puts "bogus: $line"
}
if { $verbose } {
puts "There are $nargs arguments, $ndefs are defaultable.";
for { set i 0 } { $i < $nargs } { incr i } {
puts "$argtype($i) $argname($i)";
}
if { $refargs > 0 } {
puts "return string required."
}
}
set TEMPLATE [open "$cmdfile"]
while { [gets $TEMPLATE tmpline] >= 0 } {
# Emit the argument declarations. Reference args require special
# handling, the others should be perfunctory.
switch -- $tmpline {
"<argdecls>" {
for { set i 0 } { $i < $nargs } { incr i } {
switch -- $argtype($i) {
"PLINT&" {
puts $GENFILE " PLINT $argname($i);"
}
"PLUNICODE&" {
puts $GENFILE " PLUNICODE $argname($i);"
}
"PLFLT&" {
puts $GENFILE " PLFLT $argname($i);"
}
"char&" {
puts $GENFILE " char $argname($i);"
}
"PLINT *" {
puts $GENFILE " PLINT *$argname($i);"
puts $GENFILE " tclMatrix *mat$argname($i);"
}
"PLUNICODE *" {
puts $GENFILE " PLUNICODE *$argname($i);"
puts $GENFILE " tclMatrix *mat$argname($i);"
}
"PLFLT *" {
puts $GENFILE " PLFLT *$argname($i);"
puts $GENFILE " tclMatrix *mat$argname($i);"
}
"const char *" {
puts $GENFILE " const char *$argname($i);"
}
"char *" {
puts $GENFILE " char $argname($i)\[200\];"
}
default {
if { $argdef($i) != "" } {
puts $GENFILE " $argtype($i) $argname($i) = $argdef($i);"
} else {
puts $GENFILE " $argtype($i) $argname($i);"
}
}
}
}
}
"<getargs>" {
# Obtain the arguments which we need to pass to the PLplot API call,
# from the argc/argv list passed to the Tcl command proc. Each
# supported argument type will need special handling here.
for { set i 0 } { $i < $nargs } { incr i } {
if { $ndefs > 0 } {
puts $GENFILE " if (argc > $i+1) \{ "
}
if { $argref($i) } {
puts $GENFILE "/* $argname($i) is for output. */"
continue
}
switch -- $argtype($i) {
"PLINT *" {
puts $GENFILE " mat$argname($i) = Tcl_GetMatrixPtr( interp, argv\[1+$i\] );"
puts $GENFILE " if (mat$argname($i) == NULL) return TCL_ERROR;"
puts $GENFILE " $argname($i) = mat$argname($i)-\>idata;"
}
"PLUNICODE *" {
puts $GENFILE " mat$argname($i) = Tcl_GetMatrixPtr( interp, argv\[1+$i\] );"
puts $GENFILE " if (mat$argname($i) == NULL) return TCL_ERROR;"
puts $GENFILE " $argname($i) = mat$argname($i)-\>idata;"
}
"PLFLT \*" {
puts $GENFILE " mat$argname($i) = Tcl_GetMatrixPtr( interp, argv\[1+$i\] );"
puts $GENFILE " if (mat$argname($i) == NULL) return TCL_ERROR;"
puts $GENFILE " $argname($i) = mat$argname($i)-\>fdata;"
}
"PLINT" {
puts $GENFILE " $argname($i) = atoi(argv\[1+$i\]);"
}
"PLUNICODE" {
puts $GENFILE " $argname($i) = (PLUNICODE) strtoul(argv\[1+$i\],NULL,10);"
}
"unsigned int" {
puts $GENFILE " $argname($i) = (unsigned int) strtoul(argv\[1+$i\],NULL,10);"
}
"PLFLT" {
puts $GENFILE " $argname($i) = atof(argv\[1+$i\]);"
}
"const char *" {
puts $GENFILE " $argname($i) = argv\[1+$i\];"
}
"char" {
puts $GENFILE " $argname($i) = argv\[1+$i\]\[0\];"
}
default {
puts "Unrecognized argtype : $argtype($i)"
}
}
if { $ndefs > 0 } {
puts $GENFILE " \}"
}
}
}
# Call the PLplot API function.
"<plcmd>" {
puts -nonewline $GENFILE " $cmd ( "
for { set i 0 } { $i < $nargs } { incr i } {
if { [string match "*&" $argtype($i)] } {
puts -nonewline $GENFILE "&$argname($i)"
} else {
puts -nonewline $GENFILE "$argname($i)"
}
if { $i < $nargs-1 } {
puts -nonewline $GENFILE ", "
}
}
puts $GENFILE " );"
}
# If there were reference arguments, fetch their contents and stuff them
# into their corresponding Tcl variables.
# NOTE: This should be improved so take into account the current value
# of tcl_precision.
"<fetch_result>" {
if { $refargs > 0 } {
for { set i 0 } { $i < $nargs } { incr i } {
if { ! $argref($i) } {
continue
}
if { $i > 0 } {
puts $GENFILE " if (argc == 1)"
puts $GENFILE " Tcl_AppendResult( interp, \" \", (char *) NULL );"
}
switch -- $argtype($i) {
"PLINT&" {
puts $GENFILE " sprintf( buf, \"%d\", $argname($i) );"
puts $GENFILE " if (argc > 1)"
puts $GENFILE " Tcl_SetVar( interp, argv\[1+$i\], buf, 0 );"
puts $GENFILE " else"
puts $GENFILE " Tcl_AppendResult( interp, buf, (char *) NULL );"
}
"PLUNICODE&" {
puts $GENFILE " sprintf( buf, \"%u\", $argname($i) );"
puts $GENFILE " if (argc > 1)"
puts $GENFILE " Tcl_SetVar( interp, argv\[1+$i\], buf, 0 );"
puts $GENFILE " else"
puts $GENFILE " Tcl_AppendResult( interp, buf, (char *) NULL );"
}
"char *" {
puts $GENFILE " if (argc > 1)"
puts $GENFILE " Tcl_SetVar( interp, argv\[1+$i\], $argname($i), 0 );"
puts $GENFILE " else"
puts $GENFILE " Tcl_AppendResult( interp, $argname($i), (char *) NULL );"
}
"char&" {
puts $GENFILE " sprintf( buf, \"%c\", $argname($i) );"
puts $GENFILE " if (argc > 1)"
puts $GENFILE " Tcl_SetVar( interp, argv\[1+$i\], buf, 0 );"
puts $GENFILE " else"
puts $GENFILE " Tcl_AppendResult( interp, buf, (char *) NULL );"
}
# The following needs to be corrected to work with the Tcl
# precision standard (global var tcl_precision).
"PLFLT&" {
puts $GENFILE " Tcl_PrintDouble( interp, $argname($i), buf );"
puts $GENFILE " if (argc > 1)"
puts $GENFILE " Tcl_SetVar( interp, argv\[1+$i\], buf, 0 );"
puts $GENFILE " else";
puts $GENFILE " Tcl_AppendResult( interp, buf, (char *) NULL );"
}
default {
puts $GENFILE "Unsupported arg type."
}
}
}
}
}
default {
# substitutions here...
set line [string map [list %cmd% $cmd %nargs% $nargs] $tmpline]
if { $refargs } {
set line [string map [list %args% \?$args\?] $line]
} else {
set line [string map [list %args% $args] $line]
}
set line [string map [list %ndefs% $ndefs %isref% $refargs] $line]
puts $GENFILE $line
}
}
}
close $TEMPLATE
}
# main code --
#
set verbose [expr {[lsearch $argv "-v"] >= 0}]
# Find the source tree directory that must be specified on the command line.
set sourcedir [lindex $argv 0] ;# Get the current source directory - for "out of source tree builds"
set specfile [file join $sourcedir "plapi.tpl"] ;# PLplot API template specification file.
set genfile "tclgen.c" ;# Generated functions go here.
set genhead "tclgen.h" ;# Prototypes for generated functions.
set genstruct "tclgen_s.h" ;# Initializers for CmdInfo struct.
set cmdfile [file join $sourcedir "tclcmd.tpl"] ;# Template file for generated functions.
set SPECFILE [open $specfile]
set GENFILE [open $genfile "w"]
set GENHEAD [open $genhead "w"]
set GENSTRUCT [open $genstruct "w"]
# Scan the PLplot API template specification file looking for function
# "prototypes". These are introduced with the token "pltclcmd". When
# we find one, go process it. Anything other than a comment or a
# valid function "prototype" is considered an error, and is printed to
# stdout.
while { [gets $SPECFILE line] >= 0 } {
regsub {#.*$} $line {} line
if { $line == "" } continue
if { [regexp {^pltclcmd (\w+) (.*)} $line ==> cmd rtype] } {
process_pltclcmd $cmd $rtype
continue
}
# Just print the unrecognized output to stdout.
puts "? $line"
}
|
