[Richard Suchenwirth] 2007-10-13 - In the [Tcl chatroom], [Gerald Lester] asked for the functionality to wrap Tcl code into a C function that relieves the user of explicit [Tcl_Eval]. After all, it's just a matter of string manipulation, I thought: the call
  cfunc tcl_mul {int a int b} int {expr {$a*$b}}}
should return a string which looks about like the following:
 #ifndef HAVE_TCC_INTERP
	Tcl_Interp* _interp_ = NULL;
	static Tcl_Interp* tcc_Interp(void) {
        if(_interp_ == NULL) {
            Tcl_FindExecutable(NULL /*argv[0]*/);
            _interp_ = Tcl_CreateInterp();
        }
        return _interp_;
	}
 #define HAVE_TCC_INTERP
 #endif
	DLL_EXPORT int tcl_mul(int a, int b) {
        Tcl_Interp* interp = tcc_Interp();
        Tcl_Obj* aname = Tcl_NewStringObj("a",-1);
        Tcl_Obj* bname = Tcl_NewStringObj("b",-1);
        int result = 99999;
        Tcl_ObjSetVar2(interp,aname,NULL,Tcl_NewIntObj(a),0);
        Tcl_ObjSetVar2(interp,bname,NULL,Tcl_NewIntObj(b),0);
	    if(Tcl_Eval(interp,"expr {$a*$b}") == TCL_OK) {
    	    Tcl_GetIntFromObj(interp,Tcl_GetObjResult(interp), &result);
    	}
	    return result;
	}

Here's what I coded:
 proc cfunc {cname argl rtype tclbody} {
    set cbody {
        #ifndef HAVE_TCC_INTERP
	        Tcl_Interp* global_interp = NULL;
	        static Tcl_Interp* tcc_Interp(void) {
                if(global_interp == NULL) {
                    Tcl_FindExecutable(NULL /*argv[0]*/);
                    global_interp = Tcl_CreateInterp();
                }
                return global_interp;
	        }
        #define HAVE_TCC_INTERP
        #endif
    }
    set cargs ""
    foreach {type var} $argl {lappend cargs [list $type $var]}
    append cbody "DLL_EXPORT $rtype ${cname}([join $cargs ,]) \{" \n
    append cbody "  Tcl_Interp* interp = tcc_Interp();" \n
    foreach {type var} $argl {
        append cbody "  Tcl_Obj* ${var}name =\
            Tcl_NewStringObj(\"$var\",-1);\n"
    }
    append cbody "  $rtype result;" \n
    foreach {type var} $argl {
        switch -- $type {
            int {append cbody \
                "  Tcl_ObjSetVar2(interp,${var}name,NULL,\
                Tcl_NewIntObj($var),0);\n"
            }
            char* {append cbody \
                "  Tcl_ObjSetVar2(interp,${var}name,NULL,\
                Tcl_NewStringObj($var,-1),0);\n"
            }
            double {append cbody \
                "  Tcl_ObjSetVar2(interp,${var}name,NULL,\
                Tcl_NewDoubleObj($var),0);\n"
            }
            default {error "type $type not yet supported"}
        }
    }
    append cbody "  if(Tcl_Eval(interp,\""
    append cbody [string map {\" \\\" \n \\n\\\n} $tclbody]
    append cbody "\") == TCL_OK) \{\n"
    switch -- $rtype {
        int {append cbody \
    	        "    Tcl_GetIntFromObj(interp,\
    	        Tcl_GetObjResult(interp), &result);\n"
    	}
        char* {append cbody \
    	        "    result = Tcl_GetString(\
    	        Tcl_GetObjResult(interp));\n"
    	}
        double {append cbody \
    	        "    Tcl_GetDoubleFromObj(interp,\
    	        Tcl_GetObjResult(interp), &result);\n"
    	}
    	default {error "type $rtype not yet supported"}
    }
	append cbody "  \}\n  return result;\n\}\n"
    return $cbody
 }

Testing with [tcltcc] (but the generated code should also be usable in [Critcl] or [Odyce], with maybe a few tweaks):
 set d [tcc::dll]

 $d ccode [cfunc tcl_mul {int a int b} int {expr {$a*$b}}]
 $d ccode [cfunc tcl_up {char* str} char* {string toupper "$str"}]
#-- right now, the callers sit in the same DLL:
 $d cproc try {int a int b} int {tcl_mul(a,b);}
 $d cproc up {char* s} char* {tcl_up(s);}
 if [catch {$d write -name ping}] {
    puts [set tcc::dll::${d}::code]
    puts \n$errorInfo
    exit
 }
 load ping.dll
 puts [try 7 6]/[up hello]
Of course, it took me a few iterations until this short but sweet result came on stdout:
 42/HELLO
----
But of course, we really need that code in other libs can call our functions. This took me a while to get right, and is windows-specific (write a .DEF file to describe the library):
 set d [tcc::dll]
 $d ccode [cfunc tcl_mul {int a int b} int {expr {$a*$b}}]
 $d ccode [cfunc tcl_up {char* str} char* {string toupper "$str"}]
 $d write -name ping
#-- semi-manually making a .def file...
 set f [open ping.def w]
 puts $f "LIBRARY ping.dll\n\nEXPORTS\ntcl_mul\ntcl_up"
 close $f
 load ping.dll

 set d [tcc::dll]
 $d cproc try {int a int b} int {tcl_mul(a,b);}
 $d cproc up {char* s} char* {tcl_up(s);}
 $d write -name pong -libs ping
 load pong.dll
 puts [try 7 6]/[up hello]
It also required that I modified the function tcc::to_dll in tcc.tcl to do
    tcc_1 add_library_path .
which may not be the most general solution... but at least it's getting forward
----
| [Category Example] |