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.

[LES]: Are you sure it's for i386 only? What about this? [http://sdcc.sourceforge.net/snap.php]

- [CMcC] 20041028 (I am so happy :)

----
'''Installation'''

   1. Obtain tcc source
   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]