Check-in [7a4c3ad58c]
Overview
Comment:Updated namespace and command to be called "tcc4tcl"
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 7a4c3ad58c8a0ec813719df885d8aae9a827c079
User & Date: rkeene on 2014-05-02 02:56:22
Other Links: manifest | tags
Context
2014-05-02
02:57
Updated ignores check-in: eef200d382 user: rkeene tags: trunk
02:56
Updated namespace and command to be called "tcc4tcl" check-in: 7a4c3ad58c user: rkeene tags: trunk
01:50
Updated to be more simple about loading objects check-in: 5b517f12c1 user: rkeene tags: trunk
Changes

Modified Makefile.in from [0b56aecef2] to [ec9fd55538].

     6      6   LDFLAGS =
     7      7   SHOBJLDFLAGS = @SHOBJLDFLAGS@
     8      8   LIBS = @LIBS@
     9      9   INSTALL = @INSTALL@
    10     10   PACKAGE_NAME = @PACKAGE_NAME@
    11     11   PACKAGE_VERSION = @PACKAGE_VERSION@
    12     12   TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@
           13  +TCLCONFIGPATH = @TCLCONFIGPATH@
    13     14   PACKAGE_INSTALL_DIR = $(TCL_PACKAGE_PATH)/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
    14     15   TARGETS = @TARGETS@
           16  +TCC_CONFIGURE_OPTS = --extra-cflags='$(CFLAGS)' --with-tcl=$(TCLCONFIGPATH)
    15     17   srcdir = @srcdir@
    16     18   
    17     19   all: $(TARGETS)
    18     20   
    19     21   tcc/config.h:
    20     22   	if [ "$(srcdir)" = "." ]; then \
    21         -		cd tcc && ./configure; \
           23  +		cd tcc && ./configure $(TCC_CONFIGURE_OPTS); \
    22     24   	else \
    23     25   		mkdir tcc >/dev/null 2>/dev/null; \
    24         -		cd tcc && $(shell cd $(srcdir) && pwd)/tcc/configure; \
           26  +		cd tcc && $(shell cd $(srcdir) && pwd)/tcc/configure $(TCC_CONFIGURE_OPTS); \
    25     27   	fi
    26     28   
    27     29   tcc/libtcc.a: tcc/config.h
    28     30   	$(MAKE) -C tcc libtcc.a
    29     31   
    30     32   tcc/libtcc1.a: tcc/config.h
    31     33   	$(MAKE) -C tcc libtcc1.a
    32     34   
    33     35   tcltcc.o: $(srcdir)/tcltcc.c $(srcdir)/tcc/tcc.h $(srcdir)/tcc/libtcc.h tcc/config.h
    34     36   	$(CC) $(CPPFLAGS) $(CFLAGS) -o tcltcc.o -c $(srcdir)/tcltcc.c
    35     37   
    36     38   tcltcc.@SHOBJEXT@: tcltcc.o tcc/libtcc.a
    37         -	$(CC) $(CPPFLAGS) $(CFLAGS) $(LDFLAGS) $(SHOBJLDFLAGS) -o tcltcc.@SHOBJEXT@ tcltcc.o $(LIBS)
           39  +	$(CC) $(CPPFLAGS) $(CFLAGS) $(LDFLAGS) $(SHOBJLDFLAGS) -o tcltcc.@SHOBJEXT@ tcltcc.o tcc/libtcc.a $(LIBS)
    38     40   
    39     41   tcltcc-static.a: tcltcc.o tcc/libtcc.a
    40     42   	cp tcc/libtcc.a tcltcc-static.new.a
    41     43   	$(AR) rcu tcltcc-static.new.a tcltcc.o
    42     44   	-$(RANLIB) tcltcc-static.new.a
    43     45   	mv tcltcc-static.new.a tcltcc-static.a
    44     46   

Modified tcc.tcl from [c56e45f7c0] to [40e66e4fa1].

     1      1   # tcc.tcl - library routines for the tcc wrapper (Mark Janssen)
     2      2   
     3         -namespace eval tcc {
            3  +namespace eval tcc4tcl {
     4      4      variable dir 
     5      5      variable libs
     6      6      variable includes
     7      7      variable count
     8      8      variable command_count
     9      9      variable commands
    10     10   
    11     11      set dir [file dirname [info script]]
    12         -   if {[info command ::tcc] == ""} {
    13         -      catch { load {} tcc }
           12  +   if {[info command ::tcc4tcl] == ""} {
           13  +      catch { load {} tcc4tcl }
    14     14      }
    15         -   if {[info command ::tcc] == ""} {
    16         -       load [file join $dir tcctcl[info sharedlibextension]] tcc
           15  +   if {[info command ::tcc4tcl] == ""} {
           16  +       load [file join $dir tcltcc[info sharedlibextension]] tcc4tcl
    17     17      }
    18     18      set libs $dir/lib
    19     19      set includes $dir/include
    20     20      set count 0
    21     21      set command_count 0
    22     22      array set commands {}
    23     23      proc new {} {
    24     24          variable dir
    25     25          variable count
    26     26          set handle tcc_[incr count]
    27         -       tcc $dir $handle
           27  +       tcc4tcl $dir $handle
    28     28          return tcc_$count
    29     29      }
    30     30      proc tclcommand {handle name ccode} {
    31     31          variable commands
    32     32          variable command_count
    33     33          set cname _tcc_tcl_command_[incr command_count]
    34     34          set code    {#include "tcl.h"}
................................................................................
    49     49              set tclcommand [join [lrange [split $cmd ,] 1 end] {}]
    50     50              set handle [lindex [split $cmd ,] 0]
    51     51              $handle command $tclcommand $cname
    52     52           }
    53     53          return
    54     54      }
    55     55   }
    56         -proc tcc::to_dll {code dll {libs {}}} {
    57         -    tcc $::tcc::dir dll tcc_1
           56  +proc tcc4tcl::to_dll {code dll {libs {}}} {
           57  +    tcc4tcl $::tcc4tcl::dir dll tcc_1
    58     58       tcc_1 add_library tcl8.5 
    59     59       tcc_1 add_library_path .
    60     60       foreach lib $libs {tcc_1 add_library $lib}
    61     61       if {$::tcl_platform(platform) eq "windows"} {
    62     62           tcc_1 define DLL_EXPORT {__declspec(dllexport)} 
    63         -        set f [open $::tcc::dir/c/dllcrt1.c]
           63  +        set f [open $::tcc4tcl::dir/c/dllcrt1.c]
    64     64           tcc_1 compile [read $f]
    65     65           close $f
    66         -        set f [open $::tcc::dir/c/dllmain.c]
           66  +        set f [open $::tcc4tcl::dir/c/dllmain.c]
    67     67           tcc_1 compile [read $f]
    68     68           close $f
    69     69       } else {
    70     70           tcc_1 define DLL_EXPORT ""
    71     71       }
    72     72       tcc_1 compile $code
    73     73       tcc_1 output_file $dll
    74     74       rename tcc_1 {}
    75     75   }
    76         -proc ::tcc::Log {args} {
           76  +proc ::tcc4tcl::Log {args} {
    77     77     # puts $args
    78     78   }
    79         -proc ::tcc::reset {} {
           79  +proc ::tcc4tcl::reset {} {
    80     80     variable tcc
    81     81     set tcc(code)   ""
    82     82     set tcc(cfiles) [list]
    83     83     set tcc(tk) 0
    84     84   }
    85     85   # Custom helpers
    86         -proc ::tcc::checkname {n} {expr {[regexp {^[a-zA-Z0-9_]+$} $n] > 0}}
    87         -proc ::tcc::cleanname {n} {regsub -all {[^a-zA-Z0-9_]+} $n _}
           86  +proc ::tcc4tcl::checkname {n} {expr {[regexp {^[a-zA-Z0-9_]+$} $n] > 0}}
           87  +proc ::tcc4tcl::cleanname {n} {regsub -all {[^a-zA-Z0-9_]+} $n _}
    88     88   
    89         -proc ::tcc::ccode {code} {
           89  +proc ::tcc4tcl::ccode {code} {
    90     90     variable tcc
    91     91     Log "INJECTING CCODE"
    92     92     append tcc(code) $code \n
    93     93   }
    94         -proc ::tcc::cc {code} {
           94  +proc ::tcc4tcl::cc {code} {
    95     95     variable tcc
    96     96     if {![info exists tcc(cc)]} {
    97     97         set tcc(cc) tcc1
    98         -      tcc $tcc::dir $tcc(cc)
           98  +      tcc4tcl $tcc4tcl::dir $tcc(cc)
    99     99         $tcc(cc) add_library tcl8.5
   100         -      $tcc(cc) add_include_path [file join $::tcc::dir include]
          100  +      $tcc(cc) add_include_path [file join $::tcc4tcl::dir include]
   101    101     }
   102    102     Log code:$code
   103    103     $tcc(cc) compile $code
   104    104   }
   105    105   #----------------------------------------------------------- New DLL API
   106         -proc ::tcc::dll {{name ""}} {
          106  +proc ::tcc4tcl::dll {{name ""}} {
   107    107       variable count
   108    108       if {$name eq ""} {set name dll[incr count]}
   109         -    namespace eval ::tcc::dll::$name {
          109  +    namespace eval ::tcc4tcl::dll::$name {
   110    110           variable code "#include <tcl.h>\n" ;# always needed
   111    111           variable cmds {}
   112    112       }
   113         -    proc ::$name {cmd args} "::tcc::dll::\$cmd $name \$args"
          113  +    proc ::$name {cmd args} "::tcc4tcl::dll::\$cmd $name \$args"
   114    114       return $name
   115    115   }
   116         -namespace eval ::tcc::dll {}
   117         -proc ::tcc::dll::ccode {name argl} {
          116  +namespace eval ::tcc4tcl::dll {}
          117  +proc ::tcc4tcl::dll::ccode {name argl} {
   118    118       append ${name}::code \n [lindex $argl 0]
   119    119       return
   120    120   }
   121         -proc ::tcc::dll::cproc {name argl} {
          121  +proc ::tcc4tcl::dll::cproc {name argl} {
   122    122       foreach {pname pargs rtype body} $argl break
   123         -    set code [::tcc::wrapCmd $pname $pargs $rtype cx_$pname $body]
          123  +    set code [::tcc4tcl::wrapCmd $pname $pargs $rtype cx_$pname $body]
   124    124       lappend ${name}::cmds $pname cx_$pname
   125    125       append ${name}::code \n $code
   126    126       return
   127    127   }
   128         -proc ::tcc::dll::write {name argl} {
          128  +proc ::tcc4tcl::dll::write {name argl} {
   129    129       set (-dir) .
   130    130       set (-code) "" ;# possible extra code to go into the _Init function
   131    131       set (-libs) ""
   132    132       set (-name) [string tolower $name]
   133    133       array set "" $argl
   134    134       append ${name}::code \n \
   135         -        [::tcc::wrapExport $(-name) [set ${name}::cmds] $(-code)]
          135  +        [::tcc4tcl::wrapExport $(-name) [set ${name}::cmds] $(-code)]
   136    136       set outfile $(-dir)/$(-name)[info sharedlibextension]
   137         -    ::tcc::to_dll [set ${name}::code] $outfile $(-libs)
          137  +    ::tcc4tcl::to_dll [set ${name}::code] $outfile $(-libs)
   138    138   }
   139    139   #---------------------------------------------------------------------
   140         -proc ::tcc::wrap {name adefs rtype {body "#"}} {
          140  +proc ::tcc4tcl::wrap {name adefs rtype {body "#"}} {
   141    141     set cname c_$name
   142    142     set wname tcl_$name
   143    143     array set types {}
   144    144     set names {}
   145    145     set cargs {}
   146    146     set cnames {}  
   147    147     # if first arg is "Tcl_Interp*", pass it without counting it as a cmd arg
................................................................................
   261    261     }
   262    262     if {$rtype != "ok"} {append cbody "  return TCL_OK;" \n}
   263    263   
   264    264     #puts ----code:\n$code
   265    265     #puts ----cbody:\n$cbody
   266    266     list $code $cbody
   267    267   }
   268         -proc ::tcc::wrapCmd {tclname argl rtype cname body} {
          268  +proc ::tcc4tcl::wrapCmd {tclname argl rtype cname body} {
   269    269       foreach {code cbody} [wrap $tclname $argl $rtype $body] break
   270    270       append code "\nstatic int $cname"
   271    271       append code {(ClientData cdata,Tcl_Interp *ip,
   272    272           int objc,Tcl_Obj* CONST objv[])} " \{"
   273    273       append code \n$cbody \n\}\n
   274    274   }
   275         -proc ::tcc::wrapExport {name cmds {body ""}} {
          275  +proc ::tcc4tcl::wrapExport {name cmds {body ""}} {
   276    276       set code "DLL_EXPORT int [string totitle $name]_Init(Tcl_Interp *interp)"
   277    277       append code " \{\n"
   278    278       foreach {tclname cname} $cmds {
   279    279           append code \
   280    280               "Tcl_CreateObjCommand(interp,\"$tclname\",$cname,NULL,NULL);\n"
   281    281       }
   282    282       append code $body
   283    283       append code "\nreturn TCL_OK;\n\}"
   284    284   }
   285    285   #---------------------------------------------------------------------
   286         -proc ::tcc::cproc {name adefs rtype {body "#"}} {
          286  +proc ::tcc4tcl::cproc {name adefs rtype {body "#"}} {
   287    287     foreach {code cbody} [wrap $name $adefs $rtype $body] break
   288    288     ccode $code
   289    289     set ns [namespace current]
   290    290     uplevel 1 [list ${ns}::ccommand $name {dummy ip objc objv} $cbody]
   291    291   }
   292    292   #---------------------------------------------------------------------
   293         -proc ::tcc::cdata {name data} {
          293  +proc ::tcc4tcl::cdata {name data} {
   294    294     # Extract bytes from data
   295    295     binary scan $data c* bytes
   296    296       set inittext "\n"
   297    297     set line ""
   298    298     set n 0
   299    299     set l 0
   300    300     foreach c $bytes {
................................................................................
   317    317     append cbody "Tcl_SetByteArrayObj(Tcl_GetObjResult(ip), (unsigned char*) script, $count);\n"
   318    318     append cbody "return TCL_OK;" "\n"
   319    319     set ns [namespace current]
   320    320     uplevel 1 [list ${ns}::ccommand $name {dummy ip objc objv} $cbody]
   321    321     return $name
   322    322   }
   323    323   #-------------------------------------------------------------------
   324         -proc ::tcc::ccommand {procname anames args} {
          324  +proc ::tcc4tcl::ccommand {procname anames args} {
   325    325     variable tcc
   326    326     # Fully qualified proc name
   327    327     if {[string match "::*" $procname]} {
   328    328       # procname is already absolute
   329    329     } else {
   330    330       set nsfrom [uplevel 1 {namespace current}]    
   331    331       if {$nsfrom eq "::"} {set nsfrom ""}
................................................................................
   361    361     append code "}" "\n"
   362    362     set ns [namespace current]
   363    363     uplevel 1 [list ${ns}::cc $code]
   364    364     Log "CREATING TCL COMMAND $procname / $cname"
   365    365     uplevel 1 [list $tcc(cc) command $procname $cname]
   366    366     unset tcc(cc) ;# can't be used for compiling anymore
   367    367   }
   368         -proc ::tcc::tk {args} {
          368  +proc ::tcc4tcl::tk {args} {
   369    369     variable tcc
   370    370     set tcc(tk) 1
   371    371   }
   372         -::tcc::reset
   373         -namespace eval tcc {namespace export cproc ccode cdata}
          372  +::tcc4tcl::reset
          373  +namespace eval tcc4tcl {namespace export cproc ccode cdata}
   374    374   

Modified tcltcc.c from [fae14f0ce9] to [056e832bbd].

    16     16    *
    17     17    * You should have received a copy of the GNU Lesser General Public
    18     18    * License along with this library; if not, write to the Free Software
    19     19    * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
    20     20    */
    21     21   
    22     22   #include <tcl.h>
           23  +#include <stdlib.h>
    23     24   #include "tcc.h"
    24     25   
    25     26   struct TclTCCState {
    26     27   	TCCState *s;
    27     28   	int relocated;
    28     29   };
    29     30   
................................................................................
    34     35   static void TccCCommandDeleteProc (ClientData cdata) {
    35     36   	struct TclTCCState *ts;
    36     37   	TCCState *s ;
    37     38   
    38     39   	ts = (struct TclTCCState *) cdata;
    39     40   	s = ts->s;
    40     41   
    41         -	Tcl_DecrRefCount(s->tcc_lib_path);
    42         -
    43     42   	/* We can delete the compiler if the output was not to memory */
    44     43   	if (s->output_type != TCC_OUTPUT_MEMORY) {
    45     44   		tcc_delete(s);
    46     45   		ts->s = NULL;
    47     46   	}
    48     47   
    49         -	free(ts);
           48  +	ckfree((void *) ts);
    50     49   }
    51     50   
    52     51   static int TccHandleCmd ( ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]){
    53     52   	unsigned long val;
           53  +	void *val_p;
    54     54   	int index;
    55     55   	int res;
    56     56   	struct TclTCCState *ts;
    57     57   	TCCState *s;
    58     58   	Tcl_Obj *sym_addr;
    59     59   	static CONST char *options[] = {
    60     60   		"add_include_path", "add_file",  "add_library", 
................................................................................
   111    111               if (objc != 3) {
   112    112                   Tcl_WrongNumArgs(interp, 2, objv, "path");
   113    113                   return TCL_ERROR;
   114    114               } else {
   115    115                   tcc_add_library_path(s, Tcl_GetString(objv[2]));
   116    116                   return TCL_OK;
   117    117               }
          118  +#if 0
   118    119           case TCLTCC_ADD_SYMBOL:
   119    120               if (objc != 4) {
   120    121                   Tcl_WrongNumArgs(interp, 2, objv, "symbol value");
   121    122                   return TCL_ERROR;
   122    123               }
   123    124               Tcl_GetLongFromObj(interp,objv[3], &val);
          125  +
   124    126               tcc_add_symbol(s,Tcl_GetString(objv[2]),val); 
   125    127               return TCL_OK; 
          128  +#endif
   126    129           case TCLTCC_COMMAND:
   127    130               if (objc != 4) {
   128    131                   Tcl_WrongNumArgs(interp, 2, objv, "tclname cname");
   129    132                   return TCL_ERROR;
   130    133               }
   131    134               if (!ts->relocated) {     
   132         -                if(tcc_relocate(s)!=0) {
          135  +                if(tcc_relocate(s, TCC_RELOCATE_AUTO)!=0) {
   133    136                       Tcl_AppendResult(interp, "relocating failed", NULL);
   134    137                       return TCL_ERROR;
   135    138                   } else {
   136    139                       ts->relocated=1;
   137    140                   }
   138    141               }
   139         -            if (tcc_get_symbol(s,&val,Tcl_GetString(objv[3]))!=0) {
          142  +
          143  +            val_p = tcc_get_symbol(s, Tcl_GetString(objv[3]));
          144  +            if (val_p == NULL) {
   140    145   		    Tcl_AppendResult(interp, "symbol '", Tcl_GetString(objv[3]),"' not found", NULL);
   141    146   		    return TCL_ERROR;
   142    147   	    }
   143    148   
   144    149               /*printf("symbol: %x\n",val); */
   145         -            Tcl_CreateObjCommand(interp,Tcl_GetString(objv[2]),(void *)val,NULL,NULL);
          150  +            Tcl_CreateObjCommand(interp,Tcl_GetString(objv[2]),val_p,NULL,NULL);
   146    151               return TCL_OK;
   147    152           case TCLTCC_COMPILE:
   148    153               if(ts->relocated == 1) {
   149    154                   Tcl_AppendResult(interp, "code already relocated, cannot compile more",NULL);
   150    155                   return TCL_ERROR;
   151    156               }
   152    157               if (objc != 3) {
................................................................................
   173    178               return TCL_OK;
   174    179           case TCLTCC_GET_SYMBOL:
   175    180               if (objc != 3) {
   176    181                   Tcl_WrongNumArgs(interp, 2, objv, "symbol");
   177    182                   return TCL_ERROR;
   178    183               }
   179    184               if (!ts->relocated) {     
   180         -                if(tcc_relocate(s)!=0) {
          185  +                if(tcc_relocate(s, TCC_RELOCATE_AUTO)!=0) {
   181    186                       Tcl_AppendResult(interp, "relocating failed", NULL);
   182    187                       return TCL_ERROR;
   183    188                   } else {
   184    189                       ts->relocated=1;
   185    190                   }
   186    191               }
   187         -            if(tcc_get_symbol(s,&val,Tcl_GetString(objv[2]))!=0) {
          192  +            val_p = tcc_get_symbol(s,Tcl_GetString(objv[2]));
          193  +            if(val_p == NULL) {
   188    194                   Tcl_AppendResult(interp, "symbol '", Tcl_GetString(objv[2]),"' not found", NULL);
   189    195                   return TCL_ERROR;
   190    196               }
   191         -            sym_addr = Tcl_NewLongObj(val);
          197  +            sym_addr = Tcl_NewWideIntObj((Tcl_WideInt) val_p);
   192    198               Tcl_SetObjResult(interp, sym_addr);
   193    199               return TCL_OK; 
   194    200           case TCLTCC_OUTPUT_FILE:
   195    201               if (objc != 3) {
   196    202                   Tcl_WrongNumArgs(interp, 2, objv, "filename");
   197    203                   return TCL_ERROR;
   198    204               }
................................................................................
   226    232           default:
   227    233               Tcl_Panic("internal error during option lookup");
   228    234       }
   229    235       return TCL_OK;
   230    236   } 
   231    237   
   232    238   static int TccCreateCmd( ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]){
   233         -	struct TclTCCState *ts
          239  +	struct TclTCCState *ts;
   234    240   	TCCState *s;
   235    241       	int index;
   236    242   	static CONST char *types[] = {
   237    243   		"memory", "exe", "dll", "obj", "preprocess",    (char *) NULL
   238    244   	};
   239    245   
   240    246   	if (objc < 3 || objc > 4) {
................................................................................
   246    252   		index = TCC_OUTPUT_MEMORY;
   247    253   	} else {
   248    254   		if (Tcl_GetIndexFromObj(interp, objv[2], types, "type", 0, &index) != TCL_OK) {
   249    255   			return TCL_ERROR;
   250    256   		}
   251    257   	}
   252    258   
   253         -	s = tcc_new(objv[1]);
          259  +	s = tcc_new();
          260  +	if (s == NULL) {
          261  +		return(TCL_ERROR);
          262  +	}
          263  +
   254    264   	tcc_set_error_func(s, interp, (void *)&TccErrorFunc);
   255    265   
   256         -	ts = malloc(sizeof(*ts));
          266  +	ts = (void *) ckalloc(sizeof(*ts));
   257    267   	ts->s = s;
   258    268       	ts->relocated = 0;
   259    269   
   260    270   	/*printf("type: %d\n", index); */
   261    271   	tcc_set_output_type(s,index);
   262         -	Tcl_CreateObjCommand(interp,Tcl_GetString(objv[objc-1]),TccHandleCmd,s,TccCCommandDeleteProc);
          272  +	Tcl_CreateObjCommand(interp,Tcl_GetString(objv[objc-1]),TccHandleCmd,ts,TccCCommandDeleteProc);
   263    273   
   264    274   	return TCL_OK;
   265    275   }
   266    276   
   267         -DLL_EXPORT int Tcc_Init(Tcl_Interp *interp) {
          277  +int Tcc4tcl_Init(Tcl_Interp *interp) {
   268    278   #ifdef TCL_USE_STUBS
   269    279   	if (Tcl_InitStubs(interp, "8.4" , 0) == 0L) {
   270    280   		return TCL_ERROR;
   271    281   	}
   272    282   #endif
   273         -	Tcl_CreateObjCommand(interp,PACKAGE_NAME,TccCreateCmd,NULL,NULL);
   274         -	Tcl_PkgProvide(interp,PACKAGE_NAME,PACKAGE_VERSION);
          283  +
          284  +	Tcl_CreateObjCommand(interp, PACKAGE_NAME, TccCreateCmd, NULL, NULL);
          285  +	Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION);
   275    286   
   276    287   	return TCL_OK;
   277    288   }