tcc4tcl
Check-in [7572a36e73]
Login
HomeTimelineFilesBranchesTagsTicketsWiki
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
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

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

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

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) {
                Tcl_WrongNumArgs(interp, 2, objv, "tclname cname");
            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,NULL,NULL);
            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

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 tclCommand} {
	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 $tclCommand
		}

		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
96

97
98
99
100
101
102
103
104
105
106
107
108
109
110
111

112
113
114
115
116
117
118

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 $tclname
		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 $tclname
		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
409
410










411
412
413
414
415
416
417
418
419







420
421
422
423
424
425
426

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} $state(procs) {
							append code "/* Immediate: Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL); */\n"
						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} $state(procs) {
					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
441







442
443
444
445
446
447
448

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


491
492
493
494
495
496
497

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} $state(procs) {
						tcc command $procname $cname
					foreach {procname cname_obj} $state(procs) {
						tcc command $procname {*}$cname_obj
					}
				}
			}

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

Powered by Fossil · RSS