Updated 2011-03-17 03:45:01 by RLE

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 :)

RS2007-10-14: This later evolved into Odyce (credited at [1])

lm 2009/12/07 : As Odyce is not distributed as a Tcl extension (only available in the eTcl distribution), maybe it could be a good idea to restart the TclTcc development ?

- 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 format

and aborts tcl on executing:
        catch {$tcc {moop}} result

Linux 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

  1. Obtain tcc source from http://fabrice.bellard.free.fr/tcc
  2. copy the following two files into the tcc directory
  3. make -f Makefile.tcltcc
  4. 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