This extension embeds tcc inside tcl by means of a loadable extension.
The [tcc] command generates a command which encapsulates a tcc C compiler environment - you can feed it C code, generate .so or .dll files, even compile C into memory and run it there. It's like a prototypic critcl without the external dependencies.
tcc is only around 100Kb long, and it's fast as blazes, so this is a realistic technique. Sadly, though, it only works for i386 architectures.
- CMcC 20041028 (I am so happy :)
- PWQ 28 Oct 2004 Feedback:
(not a great endorcement for tcc)
tclsh: x¶ÿ¿}7*@ð: Bad font file format
and aborts tcl on executing:
catch {$tcc {moop}} resultLinux tcl8.4.3 gcc 3.3
Yes, 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. -- CMcC
Installation
tcltcc.c
/* tcltcc.c -- tcc extension for tcl
* */
#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