Check-in [7572a36e73]
Overview
Comment:Added support for a Tcl_Obj* for ClientData in linktclcommand
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:7572a36e73005f872349d0504bc2d491d73b5c14
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
35
36
37
38
39
40
41
42
43
44
45












46
47
48
49
50
51
52
...
132
133
134
135
136
137
138
139
140
141
142

143
144
145
146
147
148
149
...
150
151
152
153
154
155
156
157








158
159

160
161
162
163
164
165
166
	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 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;
................................................................................
            }

            val_p = (void *) val;

            tcc_add_symbol(s,Tcl_GetString(objv[2]), val_p); 
            return TCL_OK; 
        case TCC4TCL_COMMAND:
            if (objc != 4) {
                Tcl_WrongNumArgs(interp, 2, objv, "tclname cname");
                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;
	    }









            /*printf("symbol: %x\n",val); */
            Tcl_CreateObjCommand(interp,Tcl_GetString(objv[2]),val_p,NULL,NULL);

            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) {







|










>
>
>
>
>
>
>
>
>
>
>
>







 







|
|


>







 








>
>
>
>
>
>
>
>

<
>







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
...
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
	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;
................................................................................
            }

            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
60
61



62

63
64
65
66
67
68
69
70
..
89
90
91
92
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
...
402
403
404
405
406
407
408
409








410
411
412
413
414
415
416
417
418
419






420
421
422
423
424
425
426
...
434
435
436
437
438
439
440
441






442
443
444
445
446
447
448
...
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497

			uplevel 1 [list $callcmd $handle {*}$args]
		}]

		return $handle
	}

	proc _linktclcommand {handle cSymbol tclCommand} {
		upvar #0 $handle state





		lappend state(procs) $cSymbol $tclCommand
	}

	proc _add_include_path {handle args} {
		upvar #0 $handle state

		lappend state(add_inc_path) {*}$args
	}
................................................................................
		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 $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 $tclname
	}

	proc _ccode {handle code} {
		upvar #0 $handle state

		append state(code) $code "\n"
	}
................................................................................

		# 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} $state(procs) {








							append code "/* Immediate: Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL); */\n"
						}
					}
				}
			}
			"exe" - "dll" {
				if {[info exists state(procs)] && [llength $state(procs)] > 0} {
					append code "int _initProcs(Tcl_Interp *interp) \{\n"
					
					foreach {procname cname} $state(procs) {






						append code "  Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);\n"
					}

					append code "\}"
				}
			}
			"package" {
................................................................................
				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} $state(procs) {






						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 "\}"
................................................................................
		}

		switch -- $state(type) {
			"memory" {
				tcc compile $code

				if {[info exists state(procs)] && [llength $state(procs)] > 0} {
					foreach {procname cname} $state(procs) {
						tcc command $procname $cname
					}
				}
			}

			"package" - "dll" - "exe" {
				switch -glob -- $::tcl_platform(os)-$::tcl_platform(pointerSize) {
					"Linux-8" {







|

>
>
>
|
>
|







 







|







 







|







 







|
>
>
>
>
>
>
>
>
|








|
>
>
>
>
>
>







 







|
>
>
>
>
>
>







 







|
|







53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
..
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
...
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
...
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
...
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521

			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
	}
................................................................................
		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"
	}
................................................................................

		# 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" {
................................................................................
				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 "\}"
................................................................................
		}

		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" {