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

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

10
11
12
13
14
15
16













17
18
19
20
21
22
23
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36







+
+
+
+
+
+
+
+
+
+
+
+
+







		catch { load {} tcc4tcl }
	}
	if {[info command ::tcc4tcl] == ""} {
		load [file join $dir tcc4tcl[info sharedlibextension]] tcc4tcl
	}

	set count 0

	proc lookupNamespace {name} {
		if {![string match "::*" $name]} {
			set nsfrom [uplevel 2 {namespace current}]    
			if {$nsfrom eq "::"} {
				set nsfrom ""
			}

			set name "${nsfrom}::${name}"
		}

		return $name
	}

	proc new {{output ""} {pkgName ""}} {
		variable dir
		variable count

		set handle ::tcc4tcl::tcc_[incr count]

44
45
46
47
48
49
50
51

52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68

















69
70
71
72
73
74
75
57
58
59
60
61
62
63

64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105







-
+

















+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







				set cmd "go"
				set args [list 1 {*}$args]
			}

			set callcmd ::tcc4tcl::_$cmd

			if {[info command $callcmd] == ""} {
				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"
				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"
			}

			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 _ccommand {handle tclCommand argList body} {
		upvar #0 $handle state

		set tclCommand [lookupNamespace $tclCommand]

		set cSymbol [cleanname [namespace tail $tclCommand]]

		lappend state(procs) $tclCommand [list $cSymbol]

		foreach {clientData interp objc objv} $argList {}
		set cArgList "ClientData $clientData, Tcl_Interp *$interp, int $objc, Tcl_Obj *CONST $objv\[\]"

		append state(code) "int $cSymbol\($cArgList) {\n$body\n}\n"

		return
	}

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

		lappend state(add_inc_path) {*}$args
	}

569
570
571
572
573
574
575
576
577
578
579
580
581

582
583
584
585
586
587
588
589
590
599
600
601
602
603
604
605






606


607
608
609
610
611
612
613







-
-
-
-
-
-
+
-
-







	if {$cname == ""} {
		set cname c_[tcc4tcl::cleanname $name]
	}

	set wname tcl_[tcc4tcl::cleanname $name]

	# Fully qualified proc name
	if {![string match "::*" $name]} {
		set nsfrom [uplevel 1 {namespace current}]    
		if {$nsfrom eq "::"} {
			set nsfrom ""
		}

	set name [lookupNamespace $name]
		set name "${nsfrom}::${name}"
	}

	array set types {}
	set varnames {}
	set cargs {}
	set cnames {}  
	set cbody {}
	set code {}

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

202
203
204
205
206
207
208
209











210
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221








+
+
+
+
+
+
+
+
+
+
+


	return(x + y);
}
set testVal [testClientData 1]
if {$testVal != "4"} {
	error "\[ClientData\] Invalid value: $testVal, should have been 4"
}

set handle [tcc4tcl::new]
$handle ccommand testCCommand {dummy ip objc objv} {
	Tcl_SetObjResult(ip, Tcl_NewStringObj("OKAY", 4));

	return(TCL_OK);
}
$handle go
if {[testCCommand] ne "OKAY"} {
	error "\[testCCommand\] Invalid result"
}

exit 0