Tsp4tcc

native/clang/TSP_util.c

@@ -1,7 +1,38 @@
 #ifndef _TCL
 #include <tcl.h>
 #endif
-
+int TSP_debug(Tcl_Interp* interp, char const *format, ...) {
+    /* Helper for Debugging*/
+    char __buf [4096];
+    va_list aptr;
+    int ret;
+    va_start(aptr, format);
+    ret = vsnprintf(__buf, 4096, format, aptr);
+    va_end(aptr);
+    // compensate for surplus linebreaks, sincs puts will already write one
+    if(ret<0) return EOF;
+    if(ret>4096) ret=4096;
+    if(__buf[ret-1]=='\n') __buf[ret-1]=0;
+    Tcl_Interp* ip =  interp; 
+    if (ip==NULL) Tcl_Panic("No interp found to call tcl routine!");
+    mod_Tcl_errorCode=0;
+    Tcl_Obj*  argObjvArray [2];
+    Tcl_Obj* funcname = Tcl_NewStringObj("puts",-1);
+    Tcl_IncrRefCount(funcname);
+    argObjvArray[0] = funcname;
+    Tcl_Obj* target_1 = Tcl_NewStringObj(__buf,-1);
+    Tcl_IncrRefCount(target_1);
+    argObjvArray[1] = target_1;
+    int rs = Tcl_EvalObjv(ip, 2, argObjvArray, 0);
+    if(funcname!=NULL) Tcl_DecrRefCount(funcname);
+    if(target_1 != NULL) Tcl_DecrRefCount(target_1);
+    if(rs !=TCL_OK) {
+        Tcl_Eval (ip, "puts {Error evaluating TCL-Function puts}; puts $errorInfo; flush stdout;");
+        return EOF;
+    }
+    Tcl_DoOneEvent(TCL_DONT_WAIT|TCL_ALL_EVENTS);
+    return 1; 
+}
 
 /*********************************************************************************************/
 /* convert to an int from a string */
@@ -224,9 +255,12 @@ TSP_Util_lang_assign_var_var(Tcl_Obj* targetVarName, Tcl_Obj* sourceVarName) {
 
 /*********************************************************************************************/
 /* assign an array & element from a var */
+
 TSP_REMOVABLE int
 TSP_Util_lang_assign_array_var(Tcl_Interp* interp, Tcl_Obj* targetArrayVar, Tcl_Obj* targetIdxVar, Tcl_Obj* var) {
     Tcl_Obj* obj;
+    if (var==NULL) {return TCL_ERROR;};
+    //debug(interp,"TSP_Util_lang_assign_array_var %p %p %p\n",targetArrayVar,targetIdxVar,var);
     obj = Tcl_ObjSetVar2(interp, targetArrayVar, targetIdxVar, var, TCL_LEAVE_ERR_MSG);
     if (obj == NULL) {
         return TCL_ERROR;

tcc4tcl_helper.tcl

@@ -1,6 +1,6 @@
 package provide tcc4tcl_helper 0.1
 
-namespace eval tccenv {
+namespace eval ::tccenv {
     # some common envelope vars for our ide
     # this tries to analyze the surrounding dirs
     # to find a suitable external compiler
@@ -26,10 +26,29 @@ namespace eval tccenv {
     variable projectincludedir  ${projectdir}/include
     variable projectlibdir      ${projectdir}/lib
 
+    variable compiletime ""
+
     variable includes_missing ""
 
     variable EXTERNAL_COMPILERS ""
     variable CC_DIRECTIVES ""
+    variable DLEXPORTMAKRO "
+/***************** DLL EXPORT MAKRO FOR TCC AND GCC ************/
+#if (defined(_WIN32) && (defined(_MSC_VER)|| defined(__TINYC__)  || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec))))
+#undef DLLIMPORT
+#undef DLLEXPORT
+#   define DLLIMPORT __declspec(dllimport)
+#   define DLLEXPORT __declspec(dllexport)
+#else
+#   define DLLIMPORT 
+#   if defined(__GNUC__) && __GNUC__ > 3
+#       define DLLEXPORT __attribute__ ((visibility(\"default\")))
+#   else
+#       define DLLEXPORT
+#   endif
+#endif
+/***************************************************************/
+"        
 
     # the following routines try to find tcc.exe and gcc.exe under win32 and set the tccenv vars accordingly
 
@@ -163,7 +182,7 @@ proc ::tcc4tcl::analyse_includes {handle {prefix ""}} {
         set prefix $::tccenv::pathprefix/
     }
     set prefix1 ${prefix}lib/
-    set prefix2 ${prefix}lib/tcc4tcl-0.30/
+    set prefix2 ${prefix}lib/tcc4tcl/
 
     foreach path $usedpath {
         set shortpath [string map [list $prefix ""] $path]
@@ -264,23 +283,24 @@ proc ::tcc4tcl::prepare_compilerdirectives {filepath handle} {
     # $exeFile          cc to execute
     # $compilertype      can be gccwin32/gcclin64/tccwin32/tcclin64/user   and defines prebuilt ccOptions to use; set to user to have no predefined options
     puts "Making Directives for $filepath ($::tccenv::tccmaindir)" 
-    set pathway [::tcc4tcl::analyse_includes $handle]
+    set pathway ""
+    catch {set pathway [::tcc4tcl::analyse_includes $handle]}
     set includestccwin32 "-Iinclude -Iinclude/stdinc -Iinclude/generic -Iinclude/generic/win -Iinclude/xlib -Iwin32 -Iwin32/winapi "
     set includesgccwin32 "-Iinclude -Iinclude/generic -Iinclude/generic/win -Iinclude/xlib"
     set includestcclin64 "-Iinclude -Iinclude/stdinc -Iinclude/generic -Iinclude/generic/unix -Iinclude/xlib "
     set includesgcclin64 "-Iinclude -Iinclude/generic -Iinclude/generic/unix -Iinclude/xlib"
     set includesuser ""
 
     set librariestccwin32 "-ltclstub86elf -ltkstub86elf"
-    set librariestcclin64 "-ltclstub86elf -ltkstub86elf"
+    set librariestcclin64 "-ltclstub86_64 -ltkstub86_64"
     set librariesgccwin32 "-Llib -ltclstub86 -ltkstub86"
     set librariesgcclin64 "-Llib -ltclstub86_64 -ltkstub86_64"
     set librariesuser ""
 
     set ccoptionstccwin32 "-m32 -D_WIN32 "
     set ccoptionsgccwin32 "-s -m32 -D_WIN32 -static-libgcc "
-    set ccoptionstcclin64 ""
-    set ccoptionsgcclin64 "-s -fPIC -D_GNU_SOURCE "
+    set ccoptionstcclin64 {-Wl,-rpath=.}
+    set ccoptionsgcclin64 {-s -fPIC -D_GNU_SOURCE -Wl,-rpath=. }
 
     set ccoptionstccuser ""
 
@@ -296,8 +316,14 @@ proc ::tcc4tcl::prepare_compilerdirectives {filepath handle} {
 
     set libraries_addon ""
     lappend libraries_addon "-Llib"
+    set libps ""
+    set libs ""
+    set opts ""
+    catch {
     set libps [$handle add_library_path]
     set libs [$handle add_library]
+    set opts [$handle add_options]
+    }
     foreach inclib $libs {
         lappend libraries_addon "-l$inclib"
     }
@@ -342,14 +368,64 @@ proc ::tcc4tcl::prepare_compilerdirectives {filepath handle} {
         set ccpath [file join $exeDir $exeFile]
         append ccoptions " -shared -DUSE_TCL_STUBS -O2"
         append ccOptions " $ccoptions"
+        append ccOptions " [join $opts { }]"
 
-        puts "Directive for $compiler"
-        puts "$ccpath $ccOptions $includes $includes_generic $cfile -o$ofile $libraries"
+        #puts "Directive for $compiler"
+        #puts "$ccpath $ccOptions $includes $includes_generic $cfile -o$ofile $libraries"
         lappend ccdirectives $compiler "$ccpath $ccOptions $includes $includes_generic $cfile -o$ofile $libraries"
     }
     return $ccdirectives
 }
 
+proc lstride {L n} {
+   set t [list]; set res [list]
+   foreach i $L {
+      lappend t $i
+      if {[llength $t]==$n} {
+         lappend res $t
+         set t [list]
+      }
+   }
+   if [llength $t] {lappend res $t} ;# maybe keep the rest
+   set res
+}
+
+proc ::tcc4tcl::dlexport_procdefs {procdefs proclist} {
+    #
+    ### experimental insert###
+    #
+    ##########################
+    #
+    set exportcode ""
+    foreach {procname cname_obj} $procdefs {
+        # [list $tclname $rtype $adefs]
+        lassign $cname_obj cname rtype adefs
+        if {[string range $procname 0 1]!="__"} {;#rmoeve special procs
+            #
+            set adefs [lstride $adefs 2]
+            set adefs [join $adefs ,]
+            set dlcode "DLLEXPORT $rtype $cname ($adefs);\n"
+            puts "$procname -> obj $cname_obj cname $cname rtype $rtype adefs $adefs"
+            puts $dlcode
+            append exportcode $dlcode
+        }
+    }
+    return $exportcode
+}
+
+proc ::tcc4tcl::prepare_packagecode {handle} {
+    #
+    set DLEXPORTMAKRO $::tccenv::DLEXPORTMAKRO
+    upvar #0 $handle state
+    #modify code with dlexportmakro
+    set oldcode $state(code)
+    set newcode $DLEXPORTMAKRO
+    append newcode $oldcode
+    #append newcode [::tcc4tcl::dlexport_procdefs $state(procdefs) ""]
+    set state(code) $newcode
+
+}
+
 proc ::tcc4tcl::write_packagecode {handle packagename {filepath ""} {packageversion 1.0} {tclversion TCL_VERSION}} {
     proc relTo {targetfile currentpath } {
         # Get relative path to target file from current path
@@ -397,24 +473,7 @@ proc ::tcc4tcl::write_packagecode {handle packagename {filepath ""} {packagevers
             default {\n}
         }
     }
-
-        set DLEXPORTMAKRO "
-/***************** DLL EXPORT MAKRO FOR TCC AND GCC ************/
-#if (defined(_WIN32) && (defined(_MSC_VER)|| defined(__TINYC__)  || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec))))
-#undef DLLIMPORT
-#undef DLLEXPORT
-#   define DLLIMPORT __declspec(dllimport)
-#   define DLLEXPORT __declspec(dllexport)
-#else
-#   define DLLIMPORT __attribute__(dllimport)
-#   if defined(__GNUC__) && __GNUC__ > 3
-#       define DLLEXPORT __attribute__ ((visibility(\"default\")))
-#   else
-#       define DLLEXPORT
-#   endif
-#endif
-/***************************************************************/
-"        
+
     upvar #0 $handle state
     set oldtype "package"
     if {$state(type)!="package"} {
@@ -423,28 +482,25 @@ proc ::tcc4tcl::write_packagecode {handle packagename {filepath ""} {packagevers
         set state(type) "package"
     }
 
-    #modify code with dlexportmakro
-    set oldcode $state(code)
-    set newcode $DLEXPORTMAKRO
-    append newcode $oldcode
-    set state(code) $newcode
-
+    set ::tccenv::compiletime [clock format [clock seconds]]
+#
     puts "Writing Package $packagename --> $filepath"
     set mycode [$handle code]
+
     # beautify code
     set mycode [::tcc4tcl::reformat [string map [list [eol] \n] $mycode] 4]
     set $state(type) $oldtype
 
     set filename [file join $filepath "$packagename.c"]
-    set ccdirectives [::tcc4tcl::prepare_compilerdirectives $filename $::tsp::TCC_HANDLE]
+    set ccdirectives [::tcc4tcl::prepare_compilerdirectives $filename $handle]
     set fp [open $filename w]
-    puts $fp "/***************** Automatically Created with TCC4TCL Helper and maybe TSP **********************************/"
+    puts $fp "/***************** $::tccenv::compiletime Automatically Created with TCC4TCL Helper and maybe TSP **********************************/"
     puts $fp "/* Compiler directives are raw estimates, please adapt to given pathstructure */\n"
     foreach {compiler ccdirective} $ccdirectives {
         puts $fp "/* for $compiler use */"
         puts $fp "/* $ccdirective */\n"
     }
-    puts $fp "/***************** Automatically Created with TCC4TCL Helper and maybe TSP **********************************/"
+    puts $fp "/***************** $::tccenv::compiletime Automatically Created with TCC4TCL Helper and maybe TSP **********************************/"
     puts $fp $mycode
     close $fp
     return $ccdirectives

tsp-clang.tcl

@@ -134,20 +134,23 @@ proc ::tsp::lang_type_null {} {
 # declare a native boolean
 #
 proc ::tsp::lang_decl_native_boolean {varName} {
+    return "int $varName;\n"
     return "int $varName = 0;\n"
 }
 
 ##############################################
 # declare a native int
 #
 proc ::tsp::lang_decl_native_int {varName} {
+    return "Tcl_WideInt $varName;\n"
     return "Tcl_WideInt $varName = 0;\n"
 }
 
 ##############################################
 # declare a native double
 #
 proc ::tsp::lang_decl_native_double {varName} {
+    return "double $varName;\n"
     return "double $varName = 0;\n"
 }
 
@@ -263,7 +266,8 @@ proc ::tsp::lang_convert_int_string {targetVarName sourceVarName errMsg} {
         append result "if ((*rc = TSP_Util_lang_convert_int_string(interp, $sourceVarName, &$targetVarName)) != TCL_OK) \{\n"
     }
 #FIXME: see Tcl_GetInt()   but convert use Tcl_GetWideIntFromObj instead.
-    append result "    Tcl_AppendResult(interp, [::tsp::lang_quote_string $errMsg], Tcl_GetString($sourceVarName), (char *) NULL);\n"
+#    append result "    Tcl_AppendResult(interp, [::tsp::lang_quote_string $errMsg], Tcl_GetString($sourceVarName), (char *) NULL);\n"
+    append result "    Tcl_AppendResult(interp, [::tsp::lang_quote_string $errMsg], $sourceVarName, (char *) NULL);\n"
     append result "    ERROR_EXIT;\n"
     append result "\}\n"
     return $result
@@ -567,13 +571,14 @@ proc ::tsp::lang_assign_empty_zero {var type} {
 #
 proc ::tsp::lang_assign_var_array_idxvar {targetObj arrVar idxVar errMsg} {
     append result "/* ::tsp::lang_assign_var_array_idxvar */\n"
-
+    append result "[::tsp::lang_safe_release $targetObj]"
     append result "$targetObj = Tcl_ObjGetVar2(interp, $arrVar, $idxVar, TCL_LEAVE_ERR_MSG);\n"
     append result "if ($targetObj == NULL) \{\n"
     append result "    /* Tcl_AppendResult(interp, [::tsp::lang_quote_string $errMsg], (char *) NULL);*/\n"
     append result "    *rc = TCL_ERROR;\n"
     append result "    ERROR_EXIT;\n"
     append result "\}\n"
+    append result "[::tsp::lang_preserve $targetObj]"
     return $result
 }
 
@@ -584,15 +589,14 @@ proc ::tsp::lang_assign_var_array_idxvar {targetObj arrVar idxVar errMsg} {
 #
 proc ::tsp::lang_assign_var_array_idxtext {targetObj arrVar idxTxtVar errMsg} {
     append result "/* ::tsp::lang_array_get_array_idxtext */\n"
-
+    append result "[::tsp::lang_safe_release $targetObj]"
     append result "$targetObj = Tcl_ObjGetVar2(interp, $arrVar, $idxTxtVar, TCL_LEAVE_ERR_MSG);\n"
     append result "if ($targetObj == NULL) \{\n"
     append result "    /* Tcl_AppendResult(interp, [::tsp::lang_quote_string $errMsg], (char *) NULL);*/\n"
     append result "    *rc = TCL_ERROR;\n"
     append result "    ERROR_EXIT;\n"
     append result "\}\n"
-    return $result
-
+    append result "[::tsp::lang_preserve $targetObj]"
     return $result
 }
 
@@ -671,8 +675,7 @@ proc ::tsp::lang_assign_var_var {targetVarName sourceVarName {preserve 1}} {
 #   which is preserved and released
 #
 proc ::tsp::lang_assign_array_var {targetArrayVar targetIdxVar var} {
-    append result "/* ::tsp::lang_assign_array_var */\n"
-
+    append result "/* ::tsp::lang_assign_array_var $targetArrayVar $targetIdxVar $var */\n"
     append result "TSP_Util_lang_assign_array_var(interp, $targetArrayVar, $targetIdxVar, $var);\n"
     return $result
 }
@@ -1161,7 +1164,7 @@ proc ::tsp::lang_create_compilable {compUnitDict code} {
         lassign $proc_info procType procArgTypes procRef
 
         if {$procType eq "void"} {
-            set procNativeType ""
+            set procNativeType "void"
         } else {
             set procNativeType "[::tsp::lang_xlate_native_type $procType] "
         }
@@ -1232,10 +1235,11 @@ TSP_UserDirect_${name}(Tcl_Interp* interp, int* rc  $nativeTypedArgs ) {
     int idx2;
     char* str1;     
     char* str2;     
-    char* exprErrMsg = NULL;
+    char* exprErrMsg ;
+
     Tcl_Obj* _tmpVar_cmdResultObj = NULL;
 
-    Tcl_CallFrame* frame = NULL; 
+    Tcl_CallFrame* frame; 
 
     $returnVarDecl
     [::tsp::indent compUnit $argObjvArrays 1 \n]