Tcl to C functions

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"}]
#-- for 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

Category Critcl