Check-in [500057b0ea]
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: 500057b0ea0d39a1ec6f552748682d45eb3eb616
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    226   		}
   227    227   
   228    228   		# Declare Tcl_Obj variables
   229    229   		_ccode $handle "    Tcl_Obj *_[join $args {, *_}];"
   230    230   
   231    231   		_ccode $handle ""
   232    232   
          233  +		# Create a new interp if needed, otherwise create a temporary procedure
   233    234   		if {$newInterp} {
   234    235   			_ccode $handle "    ${interp_name}  = Tcl_CreateInterp();"
   235    236   			_ccode $handle "    if (!${interp_name}) $return_failure;"
   236    237   			_ccode $handle ""
          238  +
          239  +			set procname ""
          240  +		} else {
          241  +			set procname "::tcc4tcl::tmp::proc[clock clicks]"
          242  +			set cbody "namespace eval ::tcc4tcl {}; namespace eval ::tcc4tcl::tmp {}; proc ${procname} {$args} { $cbody }"
   237    243   		}
   238    244   
   239    245   		# Process all arguments
   240    246   		foreach arg $args {
   241    247   			set type $types($arg)
   242    248   			switch -- $type {
   243    249   				int - long - Tcl_WideInt - float - double {
................................................................................
   262    268   				Tcl_Obj* {
   263    269   					_ccode $handle "    _$arg = $arg;"
   264    270   				}
   265    271   				default {
   266    272   					return -code error "Unknown type: $type"
   267    273   				}
   268    274   			}
   269         -			_ccode $handle "    if (!Tcl_ObjSetVar2(${interp_name}, Tcl_NewStringObj(\"${arg}\", -1), NULL, _$arg, 0)) $return_failure;"
          275  +
          276  +			if {$procname == ""} {
          277  +				_ccode $handle "    if (!Tcl_ObjSetVar2(${interp_name}, Tcl_NewStringObj(\"${arg}\", -1), NULL, _$arg, 0)) $return_failure;"
          278  +			}
   270    279   		}
   271    280   		_ccode $handle ""
   272    281   
   273    282   		# Evaluate script
   274         -		_ccode $handle "    tclrv = Tcl_Eval($interp_name, \"$cbody\");"
          283  +		if {$procname != ""} {
          284  +			_ccode $handle "    static int proc_defined = 0;"
          285  +			_ccode $handle "    if (proc_defined == 0) \{"
          286  +			_ccode $handle "        proc_defined = 1;"
          287  +			set extra_space "    "
          288  +		} else {
          289  +			set extra_space ""
          290  +		}
          291  +
          292  +		_ccode $handle "${extra_space}    tclrv = Tcl_Eval($interp_name, \"$cbody\");"
          293  +		_ccode $handle "${extra_space}    if (tclrv != TCL_OK && tclrv != TCL_RETURN) $return_failure;"
          294  +
          295  +		if {$procname != ""} {
          296  +			_ccode $handle "    \}"
          297  +			set i 0
          298  +			_ccode $handle "    Tcl_Obj *objv\[[expr {[llength $args] + 1}]\];"
          299  +			_ccode $handle "    objv\[$i\] = Tcl_NewStringObj(\"$procname\", -1);"
          300  +			foreach arg $args {
          301  +				incr i
          302  +				_ccode $handle "    objv\[$i\] = _$arg;"
          303  +			}
          304  +			_ccode $handle "    tclrv = Tcl_EvalObjv($interp_name, [expr {[llength $args] + 1}], objv, 0);"
          305  +		}
   275    306   		_ccode $handle "    if (tclrv != TCL_OK && tclrv != TCL_RETURN) $return_failure;"
   276    307   		_ccode $handle ""
   277    308   
   278    309   		# Handle return value
   279    310   		if {$rtype != "ok" && $rtype != "void"} {
   280    311   			_ccode $handle "    rv_interp = Tcl_GetObjResult(${interp_name});"
   281    312   		}
................................................................................
   307    338   			char* {
   308    339   				_ccode $handle "    rv = Tcl_GetString(rv_interp);"
   309    340   			}
   310    341   			Tcl_Obj* {
   311    342   				_ccode $handle "    rv = rv_interp;"
   312    343   			}
   313    344   		}
          345  +
          346  +		# Cleanup created interp if needed
          347  +		if {$newInterp} {
          348  +			_ccode $handle "    Tcl_DeleteInterp(${interp_name});"
          349  +		}
   314    350   
   315    351   		# Return value
   316    352   		_ccode $handle ""
   317    353   		if {$rtype != "void"} {
   318    354   			_ccode $handle "    return(rv);"
   319    355   		} else {
   320    356   			_ccode $handle "    return;"