Overview
| Comment: | Updated to create a proc if we are operating in an existing interpreter, to avoid setting local variables |
|---|---|
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: |
500057b0ea0d39a1ec6f552748682d45 |
| User & Date: | rkeene on 2014-07-16 14:44:38 |
| Other Links: | manifest | tags |
Context
|
2014-07-16
| ||
| 16:09 | Added syntaxes for byte arrays check-in: 17b2b81a02 user: rkeene tags: trunk | |
| 14:44 | Updated to create a proc if we are operating in an existing interpreter, to avoid setting local variables check-in: 500057b0ea user: rkeene tags: trunk | |
| 14:32 | Updated to include Tcl runtime in lib search path check-in: 9d947ddc1d user: rkeene tags: trunk | |
Changes
Modified tcc4tcl.tcl from [ee6fa4b450] to [e6c673ebab].
| ︙ | ︙ | |||
226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 |
}
# Declare Tcl_Obj variables
_ccode $handle " Tcl_Obj *_[join $args {, *_}];"
_ccode $handle ""
if {$newInterp} {
_ccode $handle " ${interp_name} = Tcl_CreateInterp();"
_ccode $handle " if (!${interp_name}) $return_failure;"
_ccode $handle ""
}
# Process all arguments
foreach arg $args {
set type $types($arg)
switch -- $type {
int - long - Tcl_WideInt - float - double {
| > > > > > > | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 |
}
# Declare Tcl_Obj variables
_ccode $handle " Tcl_Obj *_[join $args {, *_}];"
_ccode $handle ""
# Create a new interp if needed, otherwise create a temporary procedure
if {$newInterp} {
_ccode $handle " ${interp_name} = Tcl_CreateInterp();"
_ccode $handle " if (!${interp_name}) $return_failure;"
_ccode $handle ""
set procname ""
} else {
set procname "::tcc4tcl::tmp::proc[clock clicks]"
set cbody "namespace eval ::tcc4tcl {}; namespace eval ::tcc4tcl::tmp {}; proc ${procname} {$args} { $cbody }"
}
# Process all arguments
foreach arg $args {
set type $types($arg)
switch -- $type {
int - long - Tcl_WideInt - float - double {
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
Tcl_Obj* {
_ccode $handle " _$arg = $arg;"
}
default {
return -code error "Unknown type: $type"
}
}
| > > | > > > > > > > > > > > > > > | > > > > > > > > > | 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 |
Tcl_Obj* {
_ccode $handle " _$arg = $arg;"
}
default {
return -code error "Unknown type: $type"
}
}
if {$procname == ""} {
_ccode $handle " if (!Tcl_ObjSetVar2(${interp_name}, Tcl_NewStringObj(\"${arg}\", -1), NULL, _$arg, 0)) $return_failure;"
}
}
_ccode $handle ""
# Evaluate script
if {$procname != ""} {
_ccode $handle " static int proc_defined = 0;"
_ccode $handle " if (proc_defined == 0) \{"
_ccode $handle " proc_defined = 1;"
set extra_space " "
} else {
set extra_space ""
}
_ccode $handle "${extra_space} tclrv = Tcl_Eval($interp_name, \"$cbody\");"
_ccode $handle "${extra_space} if (tclrv != TCL_OK && tclrv != TCL_RETURN) $return_failure;"
if {$procname != ""} {
_ccode $handle " \}"
set i 0
_ccode $handle " Tcl_Obj *objv\[[expr {[llength $args] + 1}]\];"
_ccode $handle " objv\[$i\] = Tcl_NewStringObj(\"$procname\", -1);"
foreach arg $args {
incr i
_ccode $handle " objv\[$i\] = _$arg;"
}
_ccode $handle " tclrv = Tcl_EvalObjv($interp_name, [expr {[llength $args] + 1}], objv, 0);"
}
_ccode $handle " if (tclrv != TCL_OK && tclrv != TCL_RETURN) $return_failure;"
_ccode $handle ""
# Handle return value
if {$rtype != "ok" && $rtype != "void"} {
_ccode $handle " rv_interp = Tcl_GetObjResult(${interp_name});"
}
|
| ︙ | ︙ | |||
307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
char* {
_ccode $handle " rv = Tcl_GetString(rv_interp);"
}
Tcl_Obj* {
_ccode $handle " rv = rv_interp;"
}
}
# Return value
_ccode $handle ""
if {$rtype != "void"} {
_ccode $handle " return(rv);"
} else {
_ccode $handle " return;"
| > > > > > | 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 |
char* {
_ccode $handle " rv = Tcl_GetString(rv_interp);"
}
Tcl_Obj* {
_ccode $handle " rv = rv_interp;"
}
}
# Cleanup created interp if needed
if {$newInterp} {
_ccode $handle " Tcl_DeleteInterp(${interp_name});"
}
# Return value
_ccode $handle ""
if {$rtype != "void"} {
_ccode $handle " return(rv);"
} else {
_ccode $handle " return;"
|
| ︙ | ︙ |