352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
|
append code $body
append code "\nreturn TCL_OK;\n\}"
return $code
}
#---------------------------------------------------------------------
proc ::tcc4tcl::cproc {name adefs rtype {body "#"}} {
foreach {code cbody} [wrap $name $adefs $rtype $body] break
::tcc4tcl::ccode $code
uplevel 1 [list ::tcc4tcl::ccommand $name {dummy ip objc objv} $cbody]
}
#---------------------------------------------------------------------
proc ::tcc4tcl::cdata {name data} {
# Extract bytes from data
binary scan $data c* bytes
|
|
|
|
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
|
append code $body
append code "\nreturn TCL_OK;\n\}"
return $code
}
#---------------------------------------------------------------------
proc ::tcc4tcl::cproc {name adefs rtype {body "#"} {addfuncs ""}} {
foreach {code cbody} [wrap $name $adefs $rtype $body] break
::tcc4tcl::ccode $code
uplevel 1 [list ::tcc4tcl::ccommand $name {dummy ip objc objv} $cbody $addfuncs]
}
#---------------------------------------------------------------------
proc ::tcc4tcl::cdata {name data} {
# Extract bytes from data
binary scan $data c* bytes
|
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
|
uplevel 1 [list tcc4tcl::ccommand $name {dummy ip objc objv} $cbody]
return $name
}
#-------------------------------------------------------------------
proc ::tcc4tcl::ccommand {procname anames args} {
variable tcc
# Fully qualified proc name
if {[string match "::*" $procname]} {
# procname is already absolute
} else {
set nsfrom [uplevel 1 {namespace current}]
|
|
|
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
|
uplevel 1 [list tcc4tcl::ccommand $name {dummy ip objc objv} $cbody]
return $name
}
#-------------------------------------------------------------------
proc ::tcc4tcl::ccommand {procname anames body {addfuncs ""}} {
variable tcc
# Fully qualified proc name
if {[string match "::*" $procname]} {
# procname is already absolute
} else {
set nsfrom [uplevel 1 {namespace current}]
|
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
|
append code $tcc(code)
append code "\n"
}
set tcc(code) ""
append code "int $cname (ClientData $v(clientdata),Tcl_Interp *$v(interp),"
append code "int $v(objc),Tcl_Obj *CONST $v(objv)\[\]) {" "\n"
append code [lindex $args end] "\n"
append code "}" "\n"
if {[catch {
uplevel 1 [list tcc4tcl::cc $code]
} err]} {
unset tcc(cc)
tcc4tcl::reset
|
|
>
>
>
>
>
>
>
>
|
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
|
append code $tcc(code)
append code "\n"
}
set tcc(code) ""
append code "int $cname (ClientData $v(clientdata),Tcl_Interp *$v(interp),"
append code "int $v(objc),Tcl_Obj *CONST $v(objv)\[\]) {" "\n"
append code $body "\n"
append code "}" "\n"
if {[llength $addfuncs] > 0} {
set tcc(cc) [tcc4tcl::new]
foreach addfunc $addfuncs {
$tcc(cc) add_runtime_sym $addfunc
}
}
if {[catch {
uplevel 1 [list tcc4tcl::cc $code]
} err]} {
unset tcc(cc)
tcc4tcl::reset
|