Overview
| Comment: | Added support for a Tcl_Obj* for ClientData in linktclcommand |
|---|---|
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: |
7572a36e73005f872349d0504bc2d491 |
| User & Date: | auriocus on 2014-11-14 22:03:12 |
| Original Comment: | Added support for a Tcl_Obj* for ClientData in linktclcommand |
| Original User & Date: | rkeene on 2014-11-14 22:03:12 |
| Other Links: | manifest | tags |
Context
|
2015-02-02
| ||
| 13:44 | Updated to not add the "tclStubsPtr" symbol unless we are compiling to memory check-in: fb2a14e7f1 user: rkeene tags: trunk | |
|
2014-11-14
| ||
| 22:03 | Added support for a Tcl_Obj* for ClientData in linktclcommand check-in: 7572a36e73 user: auriocus tags: trunk | |
|
2014-08-31
| ||
| 19:44 | tcc4tcl 0.23 check-in: e5a7a25b38 user: rkeene tags: trunk, 0.23 | |
Changes
Modified tcc4tcl.c from [a2a733650e] to [c43c105480].
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
int relocated;
};
static void Tcc4tclErrorFunc(Tcl_Interp * interp, char * msg) {
Tcl_AppendResult(interp, msg, "\n", NULL);
}
| | > > > > > > > > > > > > | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
int relocated;
};
static void Tcc4tclErrorFunc(Tcl_Interp * interp, char * msg) {
Tcl_AppendResult(interp, msg, "\n", NULL);
}
static void Tcc4tclCCommandDeleteProc(ClientData cdata) {
struct TclTCCState *ts;
TCCState *s ;
ts = (struct TclTCCState *) cdata;
s = ts->s;
ts->s = NULL;
ckfree((void *) ts);
}
static void Tcc4tclDeleteClientData(ClientData cdata) {
/*
* ClientData is a Tcl_Obj*, that was passed in
* at command creation
*/
Tcl_Obj *cdata_o = (Tcl_Obj *)cdata;
if (cdata_o != NULL) {
Tcl_DecrRefCount(cdata_o);
}
}
static int Tcc4tclHandleCmd ( ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]){
Tcl_WideInt val;
Tcl_Obj *val_o;
void *val_p;
int index;
int res;
|
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
}
val_p = (void *) val;
tcc_add_symbol(s,Tcl_GetString(objv[2]), val_p);
return TCL_OK;
case TCC4TCL_COMMAND:
| | | > > > > > > > > > | | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 |
}
val_p = (void *) val;
tcc_add_symbol(s,Tcl_GetString(objv[2]), val_p);
return TCL_OK;
case TCC4TCL_COMMAND:
if (objc != 4 && objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "tclname cname ?clientData?");
return TCL_ERROR;
}
if (!ts->relocated) {
if(tcc_relocate(s, TCC_RELOCATE_AUTO)!=0) {
Tcl_AppendResult(interp, "relocating failed", NULL);
return TCL_ERROR;
} else {
ts->relocated=1;
}
}
val_p = tcc_get_symbol(s, Tcl_GetString(objv[3]));
if (val_p == NULL) {
Tcl_AppendResult(interp, "symbol '", Tcl_GetString(objv[3]),"' not found", NULL);
return TCL_ERROR;
}
/* the ClientData */
if (objc == 5) {
val_o = objv[4];
Tcl_IncrRefCount(val_o);
} else {
val_o = NULL;
}
/*printf("symbol: %x\n",val); */
Tcl_CreateObjCommand(interp, Tcl_GetString(objv[2]), val_p, val_o, Tcc4tclDeleteClientData);
return TCL_OK;
case TCC4TCL_COMPILE:
if(ts->relocated == 1) {
Tcl_AppendResult(interp, "code already relocated, cannot compile more",NULL);
return TCL_ERROR;
}
if (objc != 3) {
|
| ︙ | ︙ |
Modified tcc4tcl.tcl from [1d42614e04] to [779467e01e].
| ︙ | ︙ | |||
53 54 55 56 57 58 59 |
uplevel 1 [list $callcmd $handle {*}$args]
}]
return $handle
}
| | > > > | > | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
uplevel 1 [list $callcmd $handle {*}$args]
}]
return $handle
}
proc _linktclcommand {handle cSymbol args} {
upvar #0 $handle state
set argc [llength $args]
if {$argc != 1 && $argc != 2} {
return -code error "_linktclcommand handle cSymbol tclCommand ?clientData?"
}
lappend state(procs) $cSymbol $args
}
proc _add_include_path {handle args} {
upvar #0 $handle state
lappend state(add_inc_path) {*}$args
}
|
| ︙ | ︙ | |||
89 90 91 92 93 94 95 | set wrapped [lindex $wrap 0] set wrapper [lindex $wrap 1] set tclname [lindex $wrap 2] append state(code) $wrapped "\n" append state(code) $wrapper "\n" | | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 |
set wrapped [lindex $wrap 0]
set wrapper [lindex $wrap 1]
set tclname [lindex $wrap 2]
append state(code) $wrapped "\n"
append state(code) $wrapper "\n"
lappend state(procs) $name [list $tclname]
}
proc _cproc {handle name adefs rtype {body "#"}} {
upvar #0 $handle state
set wrap [uplevel 1 [list ::tcc4tcl::wrap $name $adefs $rtype $body]]
set wrapped [lindex $wrap 0]
set wrapper [lindex $wrap 1]
set tclname [lindex $wrap 2]
append state(code) $wrapped "\n"
append state(code) $wrapper "\n"
lappend state(procs) $name [list $tclname]
}
proc _ccode {handle code} {
upvar #0 $handle state
append state(code) $code "\n"
}
|
| ︙ | ︙ | |||
402 403 404 405 406 407 408 |
# Append additional generated code to support the output type
switch -- $state(type) {
"memory" {
# No additional code needed
if {$outputOnly} {
if {[info exists state(procs)] && [llength $state(procs)] > 0} {
| | > > > > > > > > | | > > > > > > | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
# Append additional generated code to support the output type
switch -- $state(type) {
"memory" {
# No additional code needed
if {$outputOnly} {
if {[info exists state(procs)] && [llength $state(procs)] > 0} {
foreach {procname cname_obj} $state(procs) {
set cname [lindex $cname_obj 0]
if {[llength $cname_obj] > 1} {
set obj [lindex $cname_obj 1]
} else {
set obj "NULL"
}
append code "/* Immediate: Tcl_CreateObjCommand(interp, \"$procname\", $cname, $obj, Tcc4tclDeleteClientData); */\n"
}
}
}
}
"exe" - "dll" {
if {[info exists state(procs)] && [llength $state(procs)] > 0} {
append code "int _initProcs(Tcl_Interp *interp) \{\n"
foreach {procname cname_obj} $state(procs) {
set cname [lindex $cname_obj 0]
if {[llength $cname_obj] != 1} {
error "ClientData not supported in exe / dll mode"
}
append code " Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);\n"
}
append code "\}"
}
}
"package" {
|
| ︙ | ︙ | |||
434 435 436 437 438 439 440 |
append code "#ifdef USE_TCL_STUBS\n"
append code " if (Tcl_InitStubs(interp, TCL_VERSION, 0) == 0L) \{\n"
append code " return TCL_ERROR;\n"
append code " \}\n"
append code "#endif\n"
if {[info exists state(procs)] && [llength $state(procs)] > 0} {
| | > > > > > > | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
append code "#ifdef USE_TCL_STUBS\n"
append code " if (Tcl_InitStubs(interp, TCL_VERSION, 0) == 0L) \{\n"
append code " return TCL_ERROR;\n"
append code " \}\n"
append code "#endif\n"
if {[info exists state(procs)] && [llength $state(procs)] > 0} {
foreach {procname cname_obj} $state(procs) {
set cname [lindex $cname_obj 0]
if {[llength $cname_obj] != 1} {
error "ClientData not supported in exe / dll mode"
}
append code " Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);\n"
}
}
append code " Tcl_PkgProvide(interp, \"$packageName\", \"$packageVersion\");\n"
append code " return(TCL_OK);\n"
append code "\}"
|
| ︙ | ︙ | |||
482 483 484 485 486 487 488 |
}
switch -- $state(type) {
"memory" {
tcc compile $code
if {[info exists state(procs)] && [llength $state(procs)] > 0} {
| | | | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
}
switch -- $state(type) {
"memory" {
tcc compile $code
if {[info exists state(procs)] && [llength $state(procs)] > 0} {
foreach {procname cname_obj} $state(procs) {
tcc command $procname {*}$cname_obj
}
}
}
"package" - "dll" - "exe" {
switch -glob -- $::tcl_platform(os)-$::tcl_platform(pointerSize) {
"Linux-8" {
|
| ︙ | ︙ |