︙ | | | ︙ | |
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]
}
|
︙ | | | ︙ | |