Check-in [d02f5fd83e]
Overview
SHA1:d02f5fd83ee81267f094b940f0d9024bd8ae5ae4
Date: 2017-01-08 06:13:28
User: rkeene
Comment:Added a "tcc4tcl::ccommand" command similar to Critcl
Timelines: family | ancestors | descendants | both | trunk
Downloads: Tarball | ZIP archive
Other Links: files | file ages | folders | manifest
Tags And Properties
Context
2017-01-08
06:13
[5de78d18ca] Unexport generic "new" command (user: rkeene, tags: trunk)
06:13
[d02f5fd83e] Added a "tcc4tcl::ccommand" command similar to Critcl (user: rkeene, tags: trunk)
2016-12-09
14:48
[a86f876ef8] tcc4tcl 0.28 (user: rkeene, tags: trunk, 0.28)
Changes

Modified tcc4tcl.tcl from [200fc77793] to [a64acdd994].

    10     10   		catch { load {} tcc4tcl }
    11     11   	}
    12     12   	if {[info command ::tcc4tcl] == ""} {
    13     13   		load [file join $dir tcc4tcl[info sharedlibextension]] tcc4tcl
    14     14   	}
    15     15   
    16     16   	set count 0
           17  +
           18  +	proc lookupNamespace {name} {
           19  +		if {![string match "::*" $name]} {
           20  +			set nsfrom [uplevel 2 {namespace current}]    
           21  +			if {$nsfrom eq "::"} {
           22  +				set nsfrom ""
           23  +			}
           24  +
           25  +			set name "${nsfrom}::${name}"
           26  +		}
           27  +
           28  +		return $name
           29  +	}
    17     30   
    18     31   	proc new {{output ""} {pkgName ""}} {
    19     32   		variable dir
    20     33   		variable count
    21     34   
    22     35   		set handle ::tcc4tcl::tcc_[incr count]
    23     36   
................................................................................
    44     57   				set cmd "go"
    45     58   				set args [list 1 {*}$args]
    46     59   			}
    47     60   
    48     61   			set callcmd ::tcc4tcl::_$cmd
    49     62   
    50     63   			if {[info command $callcmd] == ""} {
    51         -				return -code error "unknown or ambiguous subcommand \"$cmd\": must be cwrap, ccode, cproc, delete, linktclcommand, code, tk, add_include_path, add_library_path, add_library, or go"
           64  +				return -code error "unknown or ambiguous subcommand \"$cmd\": must be cwrap, ccode, cproc, ccommand, delete, linktclcommand, code, tk, add_include_path, add_library_path, add_library, or go"
    52     65   			}
    53     66   
    54     67   			uplevel 1 [list $callcmd $handle {*}$args]
    55     68   		}]
    56     69   
    57     70   		return $handle
    58     71   	}
................................................................................
    62     75   		set argc [llength $args]
    63     76   		if {$argc != 1 && $argc != 2} {
    64     77   			return -code error "_linktclcommand handle cSymbol tclCommand ?clientData?"
    65     78   		}
    66     79   
    67     80   		lappend state(procs) $cSymbol $args
    68     81   	}
           82  +
           83  +	proc _ccommand {handle tclCommand argList body} {
           84  +		upvar #0 $handle state
           85  +
           86  +		set tclCommand [lookupNamespace $tclCommand]
           87  +
           88  +		set cSymbol [cleanname [namespace tail $tclCommand]]
           89  +
           90  +		lappend state(procs) $tclCommand [list $cSymbol]
           91  +
           92  +		foreach {clientData interp objc objv} $argList {}
           93  +		set cArgList "ClientData $clientData, Tcl_Interp *$interp, int $objc, Tcl_Obj *CONST $objv\[\]"
           94  +
           95  +		append state(code) "int $cSymbol\($cArgList) {\n$body\n}\n"
           96  +
           97  +		return
           98  +	}
    69     99   
    70    100   	proc _add_include_path {handle args} {
    71    101   		upvar #0 $handle state
    72    102   
    73    103   		lappend state(add_inc_path) {*}$args
    74    104   	}
    75    105   
................................................................................
   569    599   	if {$cname == ""} {
   570    600   		set cname c_[tcc4tcl::cleanname $name]
   571    601   	}
   572    602   
   573    603   	set wname tcl_[tcc4tcl::cleanname $name]
   574    604   
   575    605   	# Fully qualified proc name
   576         -	if {![string match "::*" $name]} {
   577         -		set nsfrom [uplevel 1 {namespace current}]    
   578         -		if {$nsfrom eq "::"} {
   579         -			set nsfrom ""
   580         -		}
   581         -
   582         -		set name "${nsfrom}::${name}"
   583         -	}
          606  +	set name [lookupNamespace $name]
   584    607   
   585    608   	array set types {}
   586    609   	set varnames {}
   587    610   	set cargs {}
   588    611   	set cnames {}  
   589    612   	set cbody {}
   590    613   	set code {}

Modified test.tcl from [da5a97590a] to [bf545477a0].

   202    202   
   203    203   	return(x + y);
   204    204   }
   205    205   set testVal [testClientData 1]
   206    206   if {$testVal != "4"} {
   207    207   	error "\[ClientData\] Invalid value: $testVal, should have been 4"
   208    208   }
          209  +
          210  +set handle [tcc4tcl::new]
          211  +$handle ccommand testCCommand {dummy ip objc objv} {
          212  +	Tcl_SetObjResult(ip, Tcl_NewStringObj("OKAY", 4));
          213  +
          214  +	return(TCL_OK);
          215  +}
          216  +$handle go
          217  +if {[testCCommand] ne "OKAY"} {
          218  +	error "\[testCCommand\] Invalid result"
          219  +}
   209    220   
   210    221   exit 0