Check-in [1c563bb769]
Overview
Comment:Cleaned up some return code handling, and added test for binary blobs
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:1c563bb7690b6c1186ac4959e64c8be1d6cc278e
User & Date: rkeene on 2014-07-16 16:26:00
Other Links: manifest | tags
Context
2014-07-16
18:02
Updated comments check-in: bb7a68b1e7 user: rkeene tags: trunk
16:26
Cleaned up some return code handling, and added test for binary blobs check-in: 1c563bb769 user: rkeene tags: trunk
16:15
Corrected issue with checking for variables check-in: 37f218e272 user: rkeene tags: trunk
Changes

Modified tcc4tcl.tcl from [f995e1562e] to [5e15b1175b].

174
175
176
177
178
179
180










181
182
183
184
185
186
187
...
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
...
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
		}

		if {[llength $adefs_c] == 0} {
			set adefs_c "void"
		} else {
			set adefs_c [join $adefs_c {, }]
		}











		# Determine how to return in failure
		if {$rtype != "void"} {
			if {[info exists returnErrorValue]} {
				set return_failure "return(${returnErrorValue})"
			} else {
				switch -- $rtype {
................................................................................
				}
			}
		} else {
			set return_failure "return"
		}

		# Define the C function
		_ccode $handle "$rtype $cname\($adefs_c) \{"

		## Define the Tcl return value checking variable
		_ccode $handle "    int tclrv;"

		## If the interpreters return value is relevant, create a variable to store it
		if {$rtype != "ok" && $rtype != "void"} {
			_ccode $handle "    Tcl_Obj *rv_interp;"
		}

		## If we are returning a value, declare a variable for that
		if {$rtype != "void"} {
			_ccode $handle "    $rtype rv;"
		}

		## If we need to create a new interpreter, do so
		if {$newInterp} {
			set interp_name "ip"
			_ccode $handle "    Tcl_Interp *${interp_name};"
		}
................................................................................
		if {$rtype != "ok" && $rtype != "void"} {
			_ccode $handle "    rv_interp = Tcl_GetObjResult(${interp_name});"
		}

		switch -- $rtype {
			void { }
			ok {
				_ccode $handle "    rv = 0;"
			}
			int {
				_ccode $handle "    if (Tcl_GetIntFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
			}
			long {
				_ccode $handle "    if (Tcl_GetLongFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
			}







>
>
>
>
>
>
>
>
>
>







 







|











|







 







|







174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
...
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
...
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
		}

		if {[llength $adefs_c] == 0} {
			set adefs_c "void"
		} else {
			set adefs_c [join $adefs_c {, }]
		}

		# Determine actual C return type:
		switch -- $rtype {
			"ok" {
				set rtype_c "int"
			}
			default {
				set rtype_c $rtype
			}
		}

		# Determine how to return in failure
		if {$rtype != "void"} {
			if {[info exists returnErrorValue]} {
				set return_failure "return(${returnErrorValue})"
			} else {
				switch -- $rtype {
................................................................................
				}
			}
		} else {
			set return_failure "return"
		}

		# Define the C function
		_ccode $handle "$rtype_c $cname\($adefs_c) \{"

		## Define the Tcl return value checking variable
		_ccode $handle "    int tclrv;"

		## If the interpreters return value is relevant, create a variable to store it
		if {$rtype != "ok" && $rtype != "void"} {
			_ccode $handle "    Tcl_Obj *rv_interp;"
		}

		## If we are returning a value, declare a variable for that
		if {$rtype != "void"} {
			_ccode $handle "    $rtype_c rv;"
		}

		## If we need to create a new interpreter, do so
		if {$newInterp} {
			set interp_name "ip"
			_ccode $handle "    Tcl_Interp *${interp_name};"
		}
................................................................................
		if {$rtype != "ok" && $rtype != "void"} {
			_ccode $handle "    rv_interp = Tcl_GetObjResult(${interp_name});"
		}

		switch -- $rtype {
			void { }
			ok {
				_ccode $handle "    rv = TCL_OK;"
			}
			int {
				_ccode $handle "    if (Tcl_GetIntFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
			}
			long {
				_ccode $handle "    if (Tcl_GetLongFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
			}

Modified test.tcl from [635afa0e0c] to [6b2efca164].

167
168
169
170
171
172
173
174
175






}
$handle cwrap callToTcl1 {int x} float
$handle go
puts [callToTcl1 3]

set handle [tcc4tcl::new]
$handle proc callToTclBinary {char* blob int blob_Length} ok {
	puts "Blob: $blob"
}













|

>
>
>
>
>
>
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
}
$handle cwrap callToTcl1 {int x} float
$handle go
puts [callToTcl1 3]

set handle [tcc4tcl::new]
$handle proc callToTclBinary {char* blob int blob_Length} ok {
	puts "Blob: $blob ([string length $blob])"
}
$handle cproc callToTclBinaryWrapper {} void {
	callToTclBinary("test\x00test", 9);
}
puts [$handle code]
$handle go
callToTclBinaryWrapper