- PWQ 28 Oct 2004 Feedback:
- If tcc is recompiled using tcc, loading the extension and calling tcc causes a segfault.
(not a great endorcement for tcc)
(but see below, it could be glibc/ld.so's bug)- running the test program causes an error:
tclsh: x¶ÿ¿}7*@ð: Bad font file formatand aborts tcl on executing:
catch {$tcc {moop}} resultLinux tcl8.4.3 gcc 3.3Yes, I've noticed that Elf .so files produced by tcc can cause segfaults - it can happen when you dlopen() a file and use dlsym() on it. I'm not entirely sure that it's tcc's fault, and not the fault of ld.so (which is where the segfault occurs.)I have absolutely no idea why it'd refer to font file formats ... I'll try this myself, thanks for the feedback. In the meanwhile, gcc compiles it properly. -- CMcCInstallation
- Obtain tcc source from http://fabrice.bellard.free.fr/tcc
- copy the following two files into the tcc directory
- make -f Makefile.tcltcc
- tclsh ./tcc.test
tcltcc.c
/* tcltcc.c -- tcc extension for tcl
*
* Colin McCormack 28th October 2004
*/
#include <tcl.h>
#include "libtcc.h"
#include <dlfcn.h>
/* clean up tcc state */
static void tcc_del (ClientData clientData)
{
tcc_delete((TCCState *)clientData);
}
/* struct to contain tcc environment-interp association */
struct tcc_augmented {
TCCState *tccp;
Tcl_Interp *interp;
Tcl_Obj *result;
};
/* record a tcc error in the interpreter result */
void tcc_err(void *opaque, const char *msg)
{
struct tcc_augmented *state = (struct tcc_augmented *)opaque;
/*fprintf(stderr, "err: %s\n", msg);*/
Tcl_ListObjAppendElement(
state->interp,
state->result,
Tcl_NewStringObj(msg, -1));
}
/* command to manipulate a tcc environment */
static int tcc(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
{
char *tcc_tmp[20];
Tcl_Obj *result = Tcl_NewListObj(0,NULL);
TCCState *tccp = (TCCState *)clientData;
int cnt = 1;
int err = 0;
char *file = NULL;
int disposition = 0;
int type = -1;
struct tcc_augmented state = {tccp, interp, result};
char *command = NULL;
char *cmdsym = NULL;
static CONST char *optionStrings[] = {
"--",
"-output",
"-run",
"-relocate",
"-file",
"-symbol",
"-library",
"-type",
"-libpath",
"-include",
"-sysinclude",
"-define",
"-undefine",
"-value",
"-command",
NULL
};
enum options {
TCC_DONE,
TCC_OUTPUT,
TCC_RUN,
TCC_RELOCATE,
TCC_FILE,
TCC_SYMBOL,
TCC_LIBRARY,
TCC_TYPE,
TCC_LIBPATH,
TCC_INCLUDE,
TCC_SYSINCLUDE,
TCC_DEFINE,
TCC_UNDEFINE,
TCC_VALUE,
TCC_COMMAND
};
/* set error/warning display callback */
tcc_set_error_func(tccp, (void *)&state, tcc_err);
while (!err && cnt < objc) {
int index;
/*fprintf(stderr, "tcc %d %s\n", cnt, Tcl_GetString(objv[cnt]));*/
if (Tcl_GetIndexFromObj(interp, objv[cnt], optionStrings, "option", 0,
&index) != TCL_OK) {
/* we're at the end of options */
break;
}
if ((enum options)index == TCC_DONE) {
/* -- signals end of options */
break;
}
switch ((enum options) index) {
case TCC_OUTPUT: {
if (cnt == objc) {
Tcl_WrongNumArgs(interp, cnt, objv+cnt, "filename");
return TCL_ERROR;
}
//err = tcc_output_file(tccp, Tcl_GetString(objv[cnt+1]));
file = Tcl_GetString(objv[cnt+1]);
disposition = TCC_OUTPUT;
cnt += 2;
break;
}
case TCC_RUN: {
disposition = TCC_RUN;
cnt ++;
break;
}
case TCC_RELOCATE: {
disposition = TCC_RELOCATE;
cnt ++;
break;
}
case TCC_VALUE: {
unsigned long value;
Tcl_Obj *val;
if (cnt == objc) {
Tcl_WrongNumArgs(interp, cnt, objv+cnt, "name");
return TCL_ERROR;
}
err = tcc_get_symbol(tccp, &value, Tcl_GetString(objv[cnt+1]));
if (err) {
/*fprintf(stderr, "get symbol err: %d\n", err);*/
val = Tcl_NewStringObj("No such symbol", -1);
} else {
val = Tcl_NewIntObj(value);
}
/* append name/value pair to result */
Tcl_ListObjAppendElement(interp, result, objv[cnt+1]);
Tcl_ListObjAppendElement(interp, result, val);
cnt += 2;
break;
}
case TCC_COMMAND: {
if (cnt +2 >= objc) {
Tcl_WrongNumArgs(interp, cnt, objv+cnt, "command symbol");
return TCL_ERROR;
}
disposition = TCC_COMMAND;
command = Tcl_GetString(objv[cnt+1]);
cmdsym = Tcl_GetString(objv[cnt+2]);
cnt += 3;
break;
}
case TCC_FILE: {
if (cnt == objc) {
Tcl_WrongNumArgs(interp, cnt, objv+cnt, "name");
return TCL_ERROR;
}
err = tcc_add_file(tccp, Tcl_GetString(objv[cnt+1]));
cnt += 2;
break;
}
case TCC_SYMBOL: {
int i;
if (cnt+2 >= objc) {
Tcl_WrongNumArgs(interp, cnt, objv+cnt, "symbol value");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[cnt+2], &i) != TCL_OK) {
Tcl_Obj *objPtr = Tcl_NewObj();
Tcl_SetObjResult(interp, objPtr);
Tcl_AppendToObj(objPtr,
"argument to -symbol must be an integer",
-1);
return TCL_ERROR;
}
err = tcc_add_symbol(tccp, Tcl_GetString(objv[cnt+1]), i);
cnt += 3;
break;
}
case TCC_LIBRARY: {
if (cnt == objc) {
Tcl_WrongNumArgs(interp, cnt, objv, "file");
return TCL_ERROR;
}
err = tcc_add_library(tccp, Tcl_GetString(objv[cnt+1]));
if (err) {
tcc_err((void *)&state,"can't find library.");
}
cnt += 2;
break;
}
case TCC_TYPE: {
static CONST char *typeStrings[] = {
"memory", "exe", "dll", "obj"
};
if (cnt == objc) {
Tcl_WrongNumArgs(interp, cnt, objv+cnt, "type");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[cnt+1], typeStrings, "type", 0,
&type) != TCL_OK) {
return TCL_ERROR;
}
tcc_set_output_type(tccp, type);
cnt += 2;
break;
}
case TCC_LIBPATH: {
if (cnt == objc) {
Tcl_WrongNumArgs(interp, cnt, objv, "filename");
return TCL_ERROR;
}
err = tcc_add_library_path(tccp, Tcl_GetString(objv[cnt+1]));
cnt += 2;
break;
}
case TCC_INCLUDE: {
if (cnt == objc) {
Tcl_WrongNumArgs(interp, cnt, objv, "filename");
return TCL_ERROR;
}
err = tcc_add_include_path(tccp, Tcl_GetString(objv[cnt+1]));
cnt += 2;
break;
}
case TCC_SYSINCLUDE: {
if (cnt == objc) {
Tcl_WrongNumArgs(interp, cnt, objv, "filename");
return TCL_ERROR;
}
err = tcc_add_sysinclude_path(tccp, Tcl_GetString(objv[cnt+1]));
cnt += 2;
break;
}
case TCC_DEFINE: {
if (cnt+2 > objc) {
Tcl_WrongNumArgs(interp, cnt, objv, "filename");
return TCL_ERROR;
}
tcc_define_symbol(
tccp,
Tcl_GetString(objv[cnt+1]),
Tcl_GetString(objv[cnt+2]));
cnt += 3;
break;
}
case TCC_UNDEFINE: {
if (cnt == objc) {
Tcl_WrongNumArgs(interp, cnt, objv, "filename");
return TCL_ERROR;
}
tcc_undefine_symbol(tccp, Tcl_GetString(objv[cnt+1]));
cnt += 2;
break;
}
default: {
return TCL_ERROR;
}
}
}
/* now compile whatever remains */
while (!err && cnt < objc) {
/*fprintf(stderr, "Compiling: %d - %s\n", cnt, Tcl_GetString(objv[cnt]));*/
err = tcc_compile_string(tccp, Tcl_GetString(objv[cnt]));
cnt++;
}
if (!err) {
/* decide what we want to do with the code */
switch (disposition) {
case TCC_COMMAND: {
long cmdval;
/*fprintf(stderr, "Command\n");*/
err = tcc_relocate(tccp);
if (err) {
/*fprintf(stderr, "relocate err: %d\n", err);*/
Tcl_ListObjAppendElement(
interp, result,
Tcl_NewStringObj("No such command symbol", -1));
break;
}
/*fprintf(stderr, "getting symbol: %s\n", cmdsym);*/
err = tcc_get_symbol(tccp, &cmdval, cmdsym);
/*fprintf(stderr, "got symbol: %s - %d\n", cmdsym, cmdval);*/
if (err) {
/*fprintf(stderr, "command err: %d\n", err);*/
Tcl_ListObjAppendElement(
interp, result,
Tcl_NewStringObj("No such command symbol", -1));
break;
} else {
/* construct the command */
/*fprintf(stderr, "command sym: %s\n", command);*/
Tcl_CreateObjCommand(
interp, command,
(void*)cmdval,
(ClientData) tccp,
NULL);
}
break;
}
case TCC_RUN:
err = tcc_run(tccp, 0, NULL);
break;
case TCC_OUTPUT: {
void *elf;
void *sym;
if (type == -1) {
err = 1;
Tcl_ListObjAppendElement(
interp, result,
Tcl_NewStringObj("-type must be specified with -output", -1));
} else {
err = tcc_output_file(tccp, file);
}
break;
}
case TCC_RELOCATE: {
err = tcc_relocate(tccp);
if (err) {
Tcl_ListObjAppendElement(
interp, result,
Tcl_NewStringObj("relocation failed", -1));
}
break;
}
default:
break;
}
}
Tcl_SetObjResult(interp, result);
if (err) {
return TCL_ERROR;
} else {
return TCL_OK;
}
}
static int tcc_create(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
{
Tcl_Obj *result;
char tcc_tmp[20];
TCCState *tccp = tcc_new();
static int counter = 0;
tcc_set_output_type(tccp, TCC_OUTPUT_MEMORY);
sprintf(tcc_tmp, "tcc_%d", counter++);
result = Tcl_NewStringObj(tcc_tmp, -1);
/* construct the command */
Tcl_CreateObjCommand(interp, tcc_tmp,
tcc,
(ClientData) tccp,
(Tcl_CmdDeleteProc *) tcc_del);
/* return the command name */
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
int Tcc_Init(Tcl_Interp *interp)
{
Tcl_PkgProvide(interp,"tcc","1.0");
Tcl_CreateObjCommand(interp, "tcc",
tcc_create,
(ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}Makefile.tcltcc - create the extension
CFLAGS += -fPIC -DLIBTCC -ggdb3 -Derror=tcc_error
libtcc.so: libtcc.o tcltcc.o
gcc -ggdb3 -pipe -shared -o $@ $^
libtcc.o: tcc.c i386-gen.c
$(CC) $(CFLAGS) -DLIBTCC -c -o $@ $<tcc.test - initial test for the extension
load ./libtcc.so
set code1 {
int fib(int n)
{
if (n <= 2)
return 1;
else
return fib(n-1) + fib(n-2);
}
int foo(int n)
{
printf("Hello World!\n");
printf("fib(%d) = %d\n", n, fib(n));
return 0;
}
}
set tcc [tcc]
$tcc -type memory -relocate $code1
rename $tcc ""
set tcc [tcc]
$tcc -type exe -output fred {
#include <stdio.h>
void main () {printf("Hello World\n");}
}
rename $tcc ""
set code {
#include <tcl.h>
int fred(ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *CONST objv[])
{
Tcl_SetObjResult(interp, Tcl_NewStringObj("moop", -1));
return TCL_OK;
}
int Fred_Init(Tcl_Interp *interp)
{
Tcl_CreateObjCommand(interp, "fred",
fred,
(ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
int Fred_SafeInit(Tcl_Interp *interp)
{
Tcl_CreateObjCommand(interp, "fred",
fred,
(ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
int Fred_Unload(Tcl_Interp *interp) {}
int Fred_SafeUnload(Tcl_Interp *interp) {}
}
set tcc [tcc]
$tcc -libpath /usr/lib -library tcl8.5 -command dofred fred $code
puts stderr [dofred]
puts stderr "DONE"
rename $tcc ""
set tcc [tcc]
catch {$tcc {moop}} result
puts stderr "Err: $result"
rename $tcc ""
set tcc [tcc]
$tcc -type dll -libpath /usr/lib -library tcl8.5 -output fred.so $code
load ./fred.so
puts stderr "Loaded ./fred.so"
puts [fred]
rename $tcc ""Wow! Phenometastic! Unbemazing! Congrats Colin, really neat! -jcw
