tcc4tcl
Check-in [d02f5fd83e]
Login
HomeTimelineFilesBranchesTagsTicketsWiki
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
Hide Diffs Unified Diffs Ignore Whitespace Patch

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

︙︙
10
11
12
13
14
15
16













17
18
19
20
21
22
23

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

	set count 0














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

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









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








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

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

			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
	}









|

















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








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, 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

	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 "${nsfrom}::${name}"
	}

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








<
<
<
<
<
|
<
<








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





	set name [lookupNamespace $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


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












exit 0








>
>
>
>
>
>
>
>
>
>
>



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

Powered by Fossil · RSS