Check-in [af858c331d]
Overview
Comment:Updated to support a Tcl_Interp* argument in any position for "proc"
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: af858c331db7a2f716adbf34ddcbe3a97bc60b5f
User & Date: rkeene on 2014-07-16 04:05:11
Other Links: manifest | tags
Context
2014-07-16
04:09
Corrected floating point error value check-in: 56023a368d user: rkeene tags: trunk
04:05
Updated to support a Tcl_Interp* argument in any position for "proc" check-in: af858c331d user: rkeene tags: trunk
03:37
Added a "proc" sub-command to generate C stubs to call Tcl code check-in: e9115a162e user: rkeene tags: trunk
Changes

Modified tcc4tcl.tcl from [54f1e6802f] to [675d06bcbb].

   147    147   
   148    148   		# Names of all arguments initialization
   149    149   		set args [list]
   150    150   
   151    151   		# If we aren't creating a new interp, it must be the first argument
   152    152   		# If the definition of this proc already includes the interp
   153    153   		# argument, use it -- otherwise add one
   154         -		if {[lindex $adefs 0] != "Tcl_Interp*"} {
   155         -			set newInterp 1
   156         -		} else {
   157         -			set newInterp 0
   158         -			set interp_name [lindex $adefs 1]
          154  +		set newInterp 1
          155  +		foreach {type var} $adefs {
          156  +			if {$type == "Tcl_Interp*"} {
          157  +				set newInterp 0
          158  +				set interp_name $var
          159  +
          160  +				break
          161  +			}
   159    162   		}
   160    163   
   161    164   		# Create the C-style argument definition
   162    165   		foreach {type var} $adefs {
   163    166   			lappend adefs_c [list $type $var]
   164    167   			set types($var) $type
          168  +
          169  +			if {$type == "Tcl_Interp*"} {
          170  +				continue
          171  +			}
          172  +
   165    173   			lappend args $var
   166    174   		}
   167    175   
   168    176   		set adefs_c [join $adefs_c {, }]
   169    177   
   170    178   		# Determine how to return in failure
   171    179   		if {$rtype != "void"} {
................................................................................
   207    215   			_ccode $handle "    $rtype rv;"
   208    216   		}
   209    217   
   210    218   		## If we need to create a new interpreter, do so
   211    219   		if {$newInterp} {
   212    220   			set interp_name "ip"
   213    221   			_ccode $handle "    Tcl_Interp *${interp_name};"
   214         -
   215         -			set args_nointerp $args
   216         -		} else {
   217         -			set args_nointerp [lrange $args 1 end]
   218    222   		}
   219    223   
   220    224   		# Declare Tcl_Obj variables
   221         -		_ccode $handle "    Tcl_Obj *_[join $args_nointerp {, *_}];"
          225  +		_ccode $handle "    Tcl_Obj *_[join $args {, *_}];"
   222    226   
   223    227   		_ccode $handle ""
   224    228   
   225    229   		if {$newInterp} {
   226    230   			_ccode $handle "    ${interp_name}  = Tcl_CreateInterp();"
   227    231   			_ccode $handle "    if (!${interp_name}) $return_failure;"
   228    232   			_ccode $handle ""
   229    233   		}
   230    234   
   231    235   		# Process all arguments
   232         -		foreach arg $args_nointerp {
          236  +		foreach arg $args {
   233    237   			set type $types($arg)
   234    238   			switch -- $type {
   235    239   				int - long - Tcl_WideInt - float - double {
   236    240   					switch -- $type {
   237    241   						float {
   238    242   							set convCmd Double
   239    243   						}
................................................................................
   259    263   				}
   260    264   			}
   261    265   			_ccode $handle "    if (!Tcl_ObjSetVar2(${interp_name}, Tcl_NewStringObj(\"${arg}\", -1), NULL, _$arg, 0)) $return_failure;"
   262    266   		}
   263    267   
   264    268   		_ccode $handle ""
   265    269   		_ccode $handle "    tclrv = Tcl_Eval($interp_name, \"$cbody\");"
   266         -		_ccode $handle "    if (tclrv != TCL_OK) $return_failure;"
          270  +		_ccode $handle "    if (tclrv != TCL_OK && tclrv != TCL_RETURN) $return_failure;"
   267    271   		_ccode $handle ""
   268    272   
   269    273   		if {$rtype != "ok" && $rtype != "void"} {
   270    274   			_ccode $handle "    rv_interp = Tcl_GetObjResult(${interp_name});"
   271    275   		}
   272    276   
   273    277   		switch -- $rtype {
................................................................................
   293    297   			}
   294    298   			double {
   295    299   				_ccode $handle "    if (Tcl_GetDoubleFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
   296    300   			}
   297    301   			char* {
   298    302   				_ccode $handle "    rv = Tcl_GetString(rv_interp);"
   299    303   			}
   300         -			char* {
   301         -				_ccode $handle "    rv = Tcl_GetString(rv_interp);"
          304  +			Tcl_Obj* {
          305  +				_ccode $handle "    rv = rv_interp;"
   302    306   			}
   303    307   		}
   304    308   
   305    309   		_ccode $handle ""
   306    310   		if {$rtype != "void"} {
   307    311   			_ccode $handle "    return(rv);"
   308    312   		} else {

Modified test.tcl from [6f71a6b9f8] to [98300662c0].

   143    143   	$handle add_library curl
   144    144   	$handle go
   145    145       
   146    146   	curl_fetch http://rkeene.org/
   147    147   }
   148    148   
   149    149   set handle [tcc4tcl::new]
   150         -$handle proc callToTcl {int a int b} int {
          150  +$handle proc callToTcl {Tcl_Interp* ip int a int b} int {
   151    151   	set retval [expr {$a + $b}]
   152    152   
   153    153   	return $retval
   154    154   }
   155         -$handle cwrap callToTcl {int a int b} int
          155  +$handle cwrap callToTcl {Tcl_Interp* ip int a int b} int
          156  +puts [$handle code]
   156    157   $handle go
   157    158   if {[callToTcl 3 5] != 8} {
   158         -	error "3 + 5 is 8"
          159  +	error "3 + 5 is 8, not [callToTcl 3 5]"
   159    160   }