Check-in [e9115a162e]
Overview
Comment:Added a "proc" sub-command to generate C stubs to call Tcl code
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:e9115a162e86d27f4c65422f17a8846f63a913a8
User & Date: rkeene on 2014-07-16 03:37:56
Other Links: manifest | tags
Context
2014-07-16
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
2014-06-24
21:32
Fixed patch based on testing from Andreas check-in: 6e18ecd7b2 user: rkeene tags: trunk
Changes

Modified tcc4tcl.tcl from [d7bddf2d39] to [54f1e6802f].

   123    123   		set state(tk) 1
   124    124   	}
   125    125   
   126    126   	proc _delete {handle} {
   127    127   		rename $handle ""
   128    128   		unset $handle
   129    129   	}
          130  +
          131  +	proc _proc {handle cname adefs rtype body args} {
          132  +		# Convert body into a C-style string
          133  +		binary scan $body H* cbody
          134  +		set cbody [regsub -all {..} $cbody {\\x&}]
          135  +
          136  +		# Parse optional arguments
          137  +		foreach {argname argval} $args {
          138  +			switch -- $argname {
          139  +				"-error" {
          140  +					set returnErrorValue $argval
          141  +				}
          142  +			}
          143  +		}
          144  +
          145  +		# Argument definitions (in C style) initialization
          146  +		set adefs_c [list]
          147  +
          148  +		# Names of all arguments initialization
          149  +		set args [list]
          150  +
          151  +		# If we aren't creating a new interp, it must be the first argument
          152  +		# If the definition of this proc already includes the interp
          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]
          159  +		}
          160  +
          161  +		# Create the C-style argument definition
          162  +		foreach {type var} $adefs {
          163  +			lappend adefs_c [list $type $var]
          164  +			set types($var) $type
          165  +			lappend args $var
          166  +		}
          167  +
          168  +		set adefs_c [join $adefs_c {, }]
          169  +
          170  +		# Determine how to return in failure
          171  +		if {$rtype != "void"} {
          172  +			if {[info exists returnErrorValue]} {
          173  +				set return_failure "return(${returnErrorValue})"
          174  +			} else {
          175  +				switch -- $rtype {
          176  +					int - long - Tcl_WideInt {
          177  +						set return_failure "return(-1)"
          178  +					}
          179  +					ok {
          180  +						set return_failure "return(TCL_ERROR)"
          181  +					}
          182  +					double - float {
          183  +						set return_failure "return(NaN)"
          184  +					}
          185  +					default {
          186  +						set return_failure "return(NULL)"
          187  +					}
          188  +				}
          189  +			}
          190  +		} else {
          191  +			set return_failure "return"
          192  +		}
          193  +
          194  +		# Define the C function
          195  +		_ccode $handle "$rtype $cname\($adefs_c) \{"
          196  +
          197  +		## Define the Tcl return value checking variable
          198  +		_ccode $handle "    int tclrv;"
          199  +
          200  +		## If the interpreters return value is relevant, create a variable to store it
          201  +		if {$rtype != "ok" && $rtype != "void"} {
          202  +			_ccode $handle "    Tcl_Obj *rv_interp;"
          203  +		}
          204  +
          205  +		## If we are returning a value, declare a variable for that
          206  +		if {$rtype != "void"} {
          207  +			_ccode $handle "    $rtype rv;"
          208  +		}
          209  +
          210  +		## If we need to create a new interpreter, do so
          211  +		if {$newInterp} {
          212  +			set interp_name "ip"
          213  +			_ccode $handle "    Tcl_Interp *${interp_name};"
          214  +
          215  +			set args_nointerp $args
          216  +		} else {
          217  +			set args_nointerp [lrange $args 1 end]
          218  +		}
          219  +
          220  +		# Declare Tcl_Obj variables
          221  +		_ccode $handle "    Tcl_Obj *_[join $args_nointerp {, *_}];"
          222  +
          223  +		_ccode $handle ""
          224  +
          225  +		if {$newInterp} {
          226  +			_ccode $handle "    ${interp_name}  = Tcl_CreateInterp();"
          227  +			_ccode $handle "    if (!${interp_name}) $return_failure;"
          228  +			_ccode $handle ""
          229  +		}
          230  +
          231  +		# Process all arguments
          232  +		foreach arg $args_nointerp {
          233  +			set type $types($arg)
          234  +			switch -- $type {
          235  +				int - long - Tcl_WideInt - float - double {
          236  +					switch -- $type {
          237  +						float {
          238  +							set convCmd Double
          239  +						}
          240  +						Tcl_WideInt {
          241  +							set convCmd WideInt
          242  +						}
          243  +						default {
          244  +							set convCmd [string totitle $type]
          245  +						}
          246  +					}
          247  +
          248  +					_ccode $handle "    _$arg = Tcl_New${convCmd}Obj($arg);"
          249  +					_ccode $handle "    if (!_$arg) $return_failure;"
          250  +				}
          251  +				char* {
          252  +					_ccode $handle "    _$arg = Tcl_NewStringObj($arg, -1);"
          253  +				}
          254  +				Tcl_Obj* {
          255  +					_ccode $handle "    _$arg = $arg;"
          256  +				}
          257  +				default {
          258  +					return -code error "Unknown type: $type"
          259  +				}
          260  +			}
          261  +			_ccode $handle "    if (!Tcl_ObjSetVar2(${interp_name}, Tcl_NewStringObj(\"${arg}\", -1), NULL, _$arg, 0)) $return_failure;"
          262  +		}
          263  +
          264  +		_ccode $handle ""
          265  +		_ccode $handle "    tclrv = Tcl_Eval($interp_name, \"$cbody\");"
          266  +		_ccode $handle "    if (tclrv != TCL_OK) $return_failure;"
          267  +		_ccode $handle ""
          268  +
          269  +		if {$rtype != "ok" && $rtype != "void"} {
          270  +			_ccode $handle "    rv_interp = Tcl_GetObjResult(${interp_name});"
          271  +		}
          272  +
          273  +		switch -- $rtype {
          274  +			void { }
          275  +			ok {
          276  +				_ccode $handle "    rv = 0;"
          277  +			}
          278  +			int {
          279  +				_ccode $handle "    if (Tcl_GetIntFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
          280  +			}
          281  +			long {
          282  +				_ccode $handle "    if (Tcl_GetLongFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
          283  +			}
          284  +			Tcl_WideInt {
          285  +				_ccode $handle "    if (Tcl_GetWideIntFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
          286  +			}
          287  +			float {
          288  +				_ccode $handle "    {"
          289  +				_ccode $handle "        double t;"
          290  +				_ccode $handle "        if (Tcl_GetDoubleFromObj(ip, rv_interp, &t) != TCL_OK) $return_failure;"
          291  +				_ccode $handle "        rv = (float) t;"
          292  +				_ccode $handle "    }"
          293  +			}
          294  +			double {
          295  +				_ccode $handle "    if (Tcl_GetDoubleFromObj(ip, rv_interp, &rv) != TCL_OK) $return_failure;"
          296  +			}
          297  +			char* {
          298  +				_ccode $handle "    rv = Tcl_GetString(rv_interp);"
          299  +			}
          300  +			char* {
          301  +				_ccode $handle "    rv = Tcl_GetString(rv_interp);"
          302  +			}
          303  +		}
          304  +
          305  +		_ccode $handle ""
          306  +		if {$rtype != "void"} {
          307  +			_ccode $handle "    return(rv);"
          308  +		} else {
          309  +			_ccode $handle "    return;"
          310  +		}
          311  +		_ccode $handle "\}"
          312  +	}
   130    313   
   131    314   	proc _go {handle {outputOnly 0}} {
   132    315   		variable dir
   133    316   
   134    317   		upvar #0 $handle state
   135    318   
   136    319   		set code $state(code)

Modified test.tcl from [c0aa27fcc2] to [6f71a6b9f8].

   141    141   	$handle add_library_path /usr/lib
   142    142   	$handle add_library_path /usr/lib32
   143    143   	$handle add_library curl
   144    144   	$handle go
   145    145       
   146    146   	curl_fetch http://rkeene.org/
   147    147   }
          148  +
          149  +set handle [tcc4tcl::new]
          150  +$handle proc callToTcl {int a int b} int {
          151  +	set retval [expr {$a + $b}]
          152  +
          153  +	return $retval
          154  +}
          155  +$handle cwrap callToTcl {int a int b} int
          156  +$handle go
          157  +if {[callToTcl 3 5] != 8} {
          158  +	error "3 + 5 is 8"
          159  +}