Check-in [c808df56cc]
Overview
Comment:Many improvements, especially for critcl compatibility
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: c808df56cc707dc4d7275565a182906ba514147d
User & Date: rkeene on 2019-06-05 00:32:13
Other Links: manifest | tags
Context
2019-06-05
00:33
Added example script which converts Tcl script using Critcl to C files check-in: e5ddd6aaff user: rkeene tags: trunk
00:32
Many improvements, especially for critcl compatibility check-in: c808df56cc user: rkeene tags: trunk
2017-10-17
03:33
Added support for calling "add_file" (undocumented for now) check-in: cd4a58d22b user: rkeene tags: trunk
Changes

Modified tcc4critcl.tcl from [f455727caf] to [142a73cffa].

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
106
107
108
109
110
111
112
113
114

		tailcall $command {*}$args
	}

	proc $command args [list apply [list {handle command} $body] $handle $command]
}

proc ::critcl::cheaders {header} {
	set handle [::critcl::_allocateHandle]



























	$handle ccode "#include \"$header\""
}



proc ::critcl::csources {file} {
	set handle [::critcl::_allocateHandle]





	# Locate file relative to current script


	set file [file join $::critcl::dir $file]




	set fd [open $file]
	$handle ccode [read $fd]
	close $fd
}


proc ::critcl::cflags args {
	set handle [::critcl::_allocateHandle]
	$handle process_command_line [join $args " "]
}

proc ::critcl::ldflags args {
	set handle [::critcl::_allocateHandle]
	$handle process_command_line [join $args " "]
}

package provide critcl 0







|


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


>
>




>
>
>
>

>
>
|
>
>
>





>












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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152

		tailcall $command {*}$args
	}

	proc $command args [list apply [list {handle command} $body] $handle $command]
}

proc ::critcl::cheaders {args} {
	set handle [::critcl::_allocateHandle]

	foreach arg $args {
		unset -nocomplain includeDir

		if {[info exists nextArg]} {
			set thisArg $nextArg
			unset nextArg
			set $thisArg $arg
		}

		switch -glob -- $arg {
			"-I" {
				set nextArg "includeDir"
			}
			"-I*" {
				set includeDir [string trim [string range $arg 2 end]]
			}
		}

		if {[info exists includeDir]} {
			$handle add_include_path [file join $::critcl::dir $includeDir]
			unset includeDir
			continue
		}

		foreach header [glob -tails -nocomplain -directory $::critcl::dir -- $arg] {
			$handle add_include_path [file join $::critcl::dir [file dirname $header]]
	$handle ccode "#include \"$header\""
}
	}
}

proc ::critcl::csources {file} {
	set handle [::critcl::_allocateHandle]

	if {![info exists ::critcl::csources]} {
		set ::critcl::csources [list]
	}

	# Locate file relative to current script
	foreach file [glob -nocomplain -directory $::critcl::dir -- $file] {
		set fullFile [file normalize $file]
		if {$fullFile in $::critcl::csources} {
			continue
		}
		lappend ::critcl::csources $fullFile

	set fd [open $file]
	$handle ccode [read $fd]
	close $fd
}
}

proc ::critcl::cflags args {
	set handle [::critcl::_allocateHandle]
	$handle process_command_line [join $args " "]
}

proc ::critcl::ldflags args {
	set handle [::critcl::_allocateHandle]
	$handle process_command_line [join $args " "]
}

package provide critcl 0

Modified tcc4tcl.tcl from [a663422b2a] to [13347466c1].

84
85
86
87
88
89
90

91
92
93
94
95
96
97

	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"







>







84
85
86
87
88
89
90
91
92
93
94
95
96
97
98

	proc _ccommand {handle tclCommand argList body} {
		upvar #0 $handle state

		set tclCommand [lookupNamespace $tclCommand]

		set cSymbol [cleanname [namespace tail $tclCommand]]
		set cSymbol [cleanname $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"
465
466
467
468
469
470
471

























472
473
474
475
476
477
478

	proc _go {handle {outputOnly 0}} {
		variable dir

		upvar #0 $handle state

		set code ""


























		foreach {macroName macroVal} $state(add_macros) {
			append code "#define [string trim "$macroName $macroVal"]\n"
		}

		append code $state(code) "\n"








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







466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504

	proc _go {handle {outputOnly 0}} {
		variable dir

		upvar #0 $handle state

		set code ""

		if {$outputOnly} {
			append code "#if 0\n"
			set seenCLIPaths [list]
			foreach path $state(add_inc_path) {
				if {$path in $seenCLIPaths} {
					continue
				}
				lappend seenCLIPaths $path
				append code "CLI:-I${path}\n"
			}
			set seenCLIPaths [list]
			foreach path $state(add_lib_path) {
				if {$path in $seenCLIPaths} {
					continue
				}
				lappend seenCLIPaths $path
				append code "CLI:-L${path}\n"
			}
			unset seenCLIPaths
			foreach path $state(add_lib) {
				append code "CLI:-l${path}\n"
			}
			append code "#endif\n"
		}

		foreach {macroName macroVal} $state(add_macros) {
			append code "#define [string trim "$macroName $macroVal"]\n"
		}

		append code $state(code) "\n"

529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
				set packageVersion [lindex $state(package) 1]
				if {$packageVersion == ""} {
					set packageVersion "0"
				}

				append code "int [string totitle $packageName]_Init(Tcl_Interp *interp) \{\n"
				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]







|







555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
				set packageVersion [lindex $state(package) 1]
				if {$packageVersion == ""} {
					set packageVersion "0"
				}

				append code "int [string totitle $packageName]_Init(Tcl_Interp *interp) \{\n"
				append code "#ifdef USE_TCL_STUBS\n"
				append code "  if (Tcl_InitStubs(interp, TCL_PATCH_LEVEL, 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]
640
641
642
643
644
645
646
647







648
649
650
651
652
653
654
		# Cleanup
		rename $handle ""
		unset $handle
	}
}

proc ::tcc4tcl::checkname {n} {expr {[regexp {^[a-zA-Z0-9_]+$} $n] > 0}}
proc ::tcc4tcl::cleanname {n} {regsub -all {[^a-zA-Z0-9_]+} $n _}








proc ::tcc4tcl::cproc {name adefs rtype {body "#"}} {
	set handle [::tcc4tcl::new]
	$handle cproc $name $adefs $rtype $body
	return [$handle go]
}








|
>
>
>
>
>
>
>







666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
		# Cleanup
		rename $handle ""
		unset $handle
	}
}

proc ::tcc4tcl::checkname {n} {expr {[regexp {^[a-zA-Z0-9_]+$} $n] > 0}}
proc ::tcc4tcl::cleanname {n} {
	set n [regsub -all {[^a-zA-Z0-9_]+} $n _]
	if {[string index $n 0] eq "_"} {
		set n "tcc4tcl${n}"
	}

	return $n
}

proc ::tcc4tcl::cproc {name adefs rtype {body "#"}} {
	set handle [::tcc4tcl::new]
	$handle cproc $name $adefs $rtype $body
	return [$handle go]
}