Index: Makefile.in ================================================================== --- Makefile.in +++ Makefile.in @@ -41,31 +41,31 @@ $(MAKE) -C tcc libtcc.a tcc/libtcc1.a: tcc/config.h $(MAKE) -C tcc libtcc1.a -tcltcc.o: $(srcdir)/tcltcc.c $(srcdir)/tcc/tcc.h $(srcdir)/tcc/libtcc.h tcc/config.h - $(CC) $(CPPFLAGS) $(CFLAGS) -o tcltcc.o -c $(srcdir)/tcltcc.c - -tcltcc.@SHOBJEXT@: tcltcc.o tcc/libtcc.a - $(CC) $(CPPFLAGS) $(CFLAGS) $(LDFLAGS) $(SHOBJLDFLAGS) -o tcltcc.@SHOBJEXT@ tcltcc.o tcc/libtcc.a $(LIBS) - -@WEAKENSYMS@ tcltcc.@SHOBJEXT@ - -@REMOVESYMS@ tcltcc.@SHOBJEXT@ - -tcltcc-static.a: tcltcc.o tcc/libtcc.a - cp tcc/libtcc.a tcltcc-static.new.a - $(AR) rcu tcltcc-static.new.a tcltcc.o - -$(RANLIB) tcltcc-static.new.a - mv tcltcc-static.new.a tcltcc-static.a - -install: $(TARGET) pkgIndex.tcl $(srcdir)/tcc.tcl tcc/libtcc1.a $(shell echo $(srcdir)/tcc/include/*) $(srcdir)/headers.awk +tcc4tcl.o: $(srcdir)/tcc4tcl.c $(srcdir)/tcc/tcc.h $(srcdir)/tcc/libtcc.h tcc/config.h + $(CC) $(CPPFLAGS) $(CFLAGS) -o tcc4tcl.o -c $(srcdir)/tcc4tcl.c + +tcc4tcl.@SHOBJEXT@: tcc4tcl.o tcc/libtcc.a + $(CC) $(CPPFLAGS) $(CFLAGS) $(LDFLAGS) $(SHOBJLDFLAGS) -o tcc4tcl.@SHOBJEXT@ tcc4tcl.o tcc/libtcc.a $(LIBS) + -@WEAKENSYMS@ tcc4tcl.@SHOBJEXT@ + -@REMOVESYMS@ tcc4tcl.@SHOBJEXT@ + +tcc4tcl-static.a: tcc4tcl.o tcc/libtcc.a + cp tcc/libtcc.a tcc4tcl-static.new.a + $(AR) rcu tcc4tcl-static.new.a tcc4tcl.o + -$(RANLIB) tcc4tcl-static.new.a + mv tcc4tcl-static.new.a tcc4tcl-static.a + +install: $(TARGET) pkgIndex.tcl $(srcdir)/tcc4tcl.tcl tcc/libtcc1.a $(shell echo $(srcdir)/tcc/include/*) $(srcdir)/headers.awk $(INSTALL) -d "$(DESTDIR)$(PACKAGE_INSTALL_DIR)" $(INSTALL) -d "$(DESTDIR)$(PACKAGE_INSTALL_DIR)/lib" $(INSTALL) -d "$(DESTDIR)$(PACKAGE_INSTALL_DIR)/include" $(INSTALL) -m 0755 $(TARGET) "$(DESTDIR)$(PACKAGE_INSTALL_DIR)" $(INSTALL) -m 0644 pkgIndex.tcl "$(DESTDIR)$(PACKAGE_INSTALL_DIR)" - $(INSTALL) -m 0644 $(srcdir)/tcc.tcl "$(DESTDIR)$(PACKAGE_INSTALL_DIR)" + $(INSTALL) -m 0644 $(srcdir)/tcc4tcl.tcl "$(DESTDIR)$(PACKAGE_INSTALL_DIR)" $(INSTALL) -m 0644 tcc/libtcc1.a "$(DESTDIR)$(PACKAGE_INSTALL_DIR)/lib" $(INSTALL) -m 0644 $(shell echo $(srcdir)/tcc/include/*) "$(DESTDIR)$(PACKAGE_INSTALL_DIR)/include" @if ! echo "_WIN32" | $(CPP) $(CPPFLAGS) - | grep '^_WIN32$$' >/dev/null; then \ echo cp -r $(srcdir)/tcc/win32/include/* "$(DESTDIR)$(PACKAGE_INSTALL_DIR)/include/"; \ cp -r $(srcdir)/tcc/win32/include/* "$(DESTDIR)$(PACKAGE_INSTALL_DIR)/include/"; \ @@ -80,19 +80,19 @@ echo cp "$$src" "$$dst"; \ cp "$$src" "$$dst"; \ done clean: - rm -f tcltcc.o - rm -f tcltcc.@SHOBJEXT@ tcltcc-static.a - rm -f tcltcc.@SHOBJEXT@.a tcltcc.@SHOBJEXT@.def + rm -f tcc4tcl.o + rm -f tcc4tcl.@SHOBJEXT@ tcc4tcl-static.a + rm -f tcc4tcl.@SHOBJEXT@.a tcc4tcl.@SHOBJEXT@.def -$(MAKE) -C tcc clean distclean: clean rm -rf autom4te.cache rm -f config.log config.status - rm -f pkgIndex.tcl tcltcc.syms tcltcc.vers + rm -f pkgIndex.tcl tcc4tcl.syms tcc4tcl.vers rm -f Makefile -$(MAKE) -C tcc distclean mrproper: distclean rm -rf __TMP__ Index: build/makearch.info ================================================================== --- build/makearch.info +++ build/makearch.info @@ -1,11 +1,11 @@ # This is the name of the utility, it will be prefixed to the tarball name UTIL="tcc4tcl" # This is the name of output files that should exist after configure # procedures. -BINS="tcltcc.so" +BINS="tcc4tcl.so" # This lists the name of files that are required to exist REQS="pkgIndex.tcl" # Version of utility, if empty it will be guessed. Index: configure.ac ================================================================== --- configure.ac +++ configure.ac @@ -33,16 +33,16 @@ if test "${TCC4TCL_TARGET}" = "shared"; then dnl Determine how to make shared objects DC_GET_SHOBJFLAGS dnl Only export symbols we wish to expose - DC_SETVERSIONSCRIPT([tcltcc.syms], [tcltcc.vers]) - DC_FIND_STRIP_AND_REMOVESYMS([tcltcc.syms]) + DC_SETVERSIONSCRIPT([tcc4tcl.syms], [tcc4tcl.vers]) + DC_FIND_STRIP_AND_REMOVESYMS([tcc4tcl.syms]) - TARGET="tcltcc.${SHOBJEXT}" + TARGET="tcc4tcl.${SHOBJEXT}" else - TARGET="tcltcc-static.a" + TARGET="tcc4tcl-static.a" fi AC_SUBST(TARGET) AC_SUBST(TCC4TCL_TARGET) dnl Find out if we have the functions needed to open shared objects @@ -56,6 +56,6 @@ dnl Perform Tcl Extension required stuff TCLEXT_INIT dnl Produce output -AC_OUTPUT(Makefile pkgIndex.tcl tcltcc.syms) +AC_OUTPUT(Makefile pkgIndex.tcl tcc4tcl.syms) Index: pkgIndex.tcl.in ================================================================== --- pkgIndex.tcl.in +++ pkgIndex.tcl.in @@ -1,1 +1,1 @@ -package ifneeded tcc4tcl @PACKAGE_VERSION@ [list source [file join $dir tcc.tcl]] +package ifneeded tcc4tcl @PACKAGE_VERSION@ [list source [file join $dir tcc4tcl.tcl]] DELETED tcc.tcl Index: tcc.tcl ================================================================== --- tcc.tcl +++ tcc.tcl @@ -1,374 +0,0 @@ -# tcc.tcl - library routines for the tcc wrapper (Mark Janssen) - -namespace eval tcc4tcl { - variable dir - variable libs - variable includes - variable count - variable command_count - variable commands - - set dir [file dirname [info script]] - if {[info command ::tcc4tcl] == ""} { - catch { load {} tcc4tcl } - } - if {[info command ::tcc4tcl] == ""} { - load [file join $dir tcltcc[info sharedlibextension]] tcc4tcl - } - set libs $dir/lib - set includes $dir/include - set count 0 - set command_count 0 - array set commands {} - proc new {} { - variable dir - variable count - set handle tcc_[incr count] - tcc4tcl $dir $handle - return tcc_$count - } - proc tclcommand {handle name ccode} { - variable commands - variable command_count - set cname _tcc_tcl_command_[incr command_count] - set code {#include "tcl.h"} - append code "\n int $cname" - append code "(ClientData cdata,Tcl_Interp *interp,int objc,Tcl_Obj* CONST objv[]){" - append code "\n$ccode" - append code "}" - $handle compile $code - set commands($handle,$name) $cname - return - } - proc compile {handle} { - variable commands - foreach cmd [array names commands $handle*] { - puts $cmd - puts $commands($cmd) - set cname $commands($cmd) - set tclcommand [join [lrange [split $cmd ,] 1 end] {}] - set handle [lindex [split $cmd ,] 0] - $handle command $tclcommand $cname - } - return - } -} -proc tcc4tcl::to_dll {code dll {libs {}}} { - tcc4tcl $::tcc4tcl::dir dll tcc_1 - tcc_1 add_library tcl8.5 - tcc_1 add_library_path . - foreach lib $libs {tcc_1 add_library $lib} - if {$::tcl_platform(platform) eq "windows"} { - tcc_1 define DLL_EXPORT {__declspec(dllexport)} - set f [open $::tcc4tcl::dir/c/dllcrt1.c] - tcc_1 compile [read $f] - close $f - set f [open $::tcc4tcl::dir/c/dllmain.c] - tcc_1 compile [read $f] - close $f - } else { - tcc_1 define DLL_EXPORT "" - } - tcc_1 compile $code - tcc_1 output_file $dll - rename tcc_1 {} -} -proc ::tcc4tcl::Log {args} { - # puts $args -} -proc ::tcc4tcl::reset {} { - variable tcc - set tcc(code) "" - set tcc(cfiles) [list] - set tcc(tk) 0 -} -# Custom helpers -proc ::tcc4tcl::checkname {n} {expr {[regexp {^[a-zA-Z0-9_]+$} $n] > 0}} -proc ::tcc4tcl::cleanname {n} {regsub -all {[^a-zA-Z0-9_]+} $n _} - -proc ::tcc4tcl::ccode {code} { - variable tcc - Log "INJECTING CCODE" - append tcc(code) $code \n -} -proc ::tcc4tcl::cc {code} { - variable tcc - if {![info exists tcc(cc)]} { - set tcc(cc) tcc1 - tcc4tcl [file join $::tcc4tcl::dir lib] $tcc(cc) - $tcc(cc) add_library tcl8.5 - $tcc(cc) add_include_path [file join $::tcc4tcl::dir include] - } - Log code:$code - $tcc(cc) compile $code -} -#----------------------------------------------------------- New DLL API -proc ::tcc4tcl::dll {{name ""}} { - variable count - if {$name eq ""} {set name dll[incr count]} - namespace eval ::tcc4tcl::dll::$name { - variable code "#include \n" ;# always needed - variable cmds {} - } - proc ::$name {cmd args} "::tcc4tcl::dll::\$cmd $name \$args" - return $name -} -namespace eval ::tcc4tcl::dll {} -proc ::tcc4tcl::dll::ccode {name argl} { - append ${name}::code \n [lindex $argl 0] - return -} -proc ::tcc4tcl::dll::cproc {name argl} { - foreach {pname pargs rtype body} $argl break - set code [::tcc4tcl::wrapCmd $pname $pargs $rtype cx_$pname $body] - lappend ${name}::cmds $pname cx_$pname - append ${name}::code \n $code - return -} -proc ::tcc4tcl::dll::write {name argl} { - set (-dir) . - set (-code) "" ;# possible extra code to go into the _Init function - set (-libs) "" - set (-name) [string tolower $name] - array set "" $argl - append ${name}::code \n \ - [::tcc4tcl::wrapExport $(-name) [set ${name}::cmds] $(-code)] - set outfile $(-dir)/$(-name)[info sharedlibextension] - ::tcc4tcl::to_dll [set ${name}::code] $outfile $(-libs) -} -#--------------------------------------------------------------------- -proc ::tcc4tcl::wrap {name adefs rtype {body "#"}} { - set cname c_$name - set wname tcl_$name - array set types {} - set names {} - set cargs {} - set cnames {} - # if first arg is "Tcl_Interp*", pass it without counting it as a cmd arg - if {[lindex $adefs 0] eq "Tcl_Interp*"} { - lappend cnames ip - lappend cargs [lrange $adefs 0 1] - set adefs [lrange $adefs 2 end] - } - foreach {t n} $adefs { - set types($n) $t - lappend names $n - lappend cnames _$n - lappend cargs "$t $n" - } - switch -- $rtype { - ok { set rtype2 "int" } - string - dstring - vstring { set rtype2 "char*" } - default { set rtype2 $rtype } - } - set code "" - append code "\n#include " "\n" - if {[info exists tcc(tk)] && $tcc(tk)} { - append code "\#include " "\n" - } - if {$body ne "#"} { - append code "static $rtype2" "\n" - append code "${cname}([join $cargs {, }]) \{\n" - append code $body - append code "\}" "\n" - } else { - append code "#define $cname $name" "\n" - } - # Supported input types - # Tcl_Interp* - # int - # long - # float - # double - # char* - # Tcl_Obj* - # void* - foreach x $names { - set t $types($x) - switch -- $t { - int - long - float - double - char* - Tcl_Obj* { - append cbody " $types($x) _$x;" "\n" - } - default {append cbody " void *_$x;" "\n"} - } - } - if {$rtype ne "void"} { append cbody " $rtype2 rv;" "\n" } - append cbody " if (objc != [expr {[llength $names] + 1}]) {" "\n" - append cbody " Tcl_WrongNumArgs(ip, 1, objv, \"[join $names { }]\");\n" - append cbody " return TCL_ERROR;" "\n" - append cbody " }" "\n" - set n 0 - foreach x $names { - incr n - switch -- $types($x) { - int { - append cbody " if (Tcl_GetIntFromObj(ip, objv\[$n], &_$x) != TCL_OK)" - append cbody " return TCL_ERROR;" "\n" - } - long { - append cbody " if (Tcl_GetLongFromObj(ip, objv\[$n], &_$x) != TCL_OK)" - append cbody " return TCL_ERROR;" "\n" - } - float { - append cbody " {" "\n" - append cbody " double t;" "\n" - append cbody " if (Tcl_GetDoubleFromObj(ip, objv\[$n], &t) != TCL_OK)" - append cbody " return TCL_ERROR;" "\n" - append cbody " _$x = (float) t;" "\n" - append cbody " }" "\n" - } - double { - append cbody " if (Tcl_GetDoubleFromObj(ip, objv\[$n], &_$x) != TCL_OK)" - append cbody " return TCL_ERROR;" "\n" - } - char* { - append cbody " _$x = Tcl_GetString(objv\[$n]);" "\n" - } - default { - append cbody " _$x = objv\[$n];" "\n" - } - } - } - append cbody "\n " - if {$rtype != "void"} {append cbody "rv = "} - append cbody "${cname}([join $cnames {, }]);" "\n" - # Return types supported by critcl - # void - # ok - # int - # long - # float - # double - # char* (TCL_STATIC char*) - # string (TCL_DYNAMIC char*) - # dstring (TCL_DYNAMIC char*) - # vstring (TCL_VOLATILE char*) - # default (Tcl_Obj*) - # Our extensions - # wide - switch -- $rtype { - void { } - ok { append cbody " return rv;" "\n" } - int { append cbody " Tcl_SetIntObj(Tcl_GetObjResult(ip), rv);" "\n" } - long { append cbody " Tcl_SetLongObj(Tcl_GetObjResult(ip), rv);" "\n" } - float - - double { append cbody " Tcl_SetDoubleObj(Tcl_GetObjResult(ip), rv);" "\n" } - char* { append cbody " Tcl_SetResult(ip, rv, TCL_STATIC);" "\n" } - string - - dstring { append cbody " Tcl_SetResult(ip, rv, TCL_DYNAMIC);" "\n" } - vstring { append cbody " Tcl_SetResult(ip, rv, TCL_VOLATILE);" "\n" } - default { append cbody " Tcl_SetObjResult(ip, rv); Tcl_DecrRefCount(rv);" "\n" } - } - if {$rtype != "ok"} {append cbody " return TCL_OK;" \n} - - #puts ----code:\n$code - #puts ----cbody:\n$cbody - list $code $cbody -} -proc ::tcc4tcl::wrapCmd {tclname argl rtype cname body} { - foreach {code cbody} [wrap $tclname $argl $rtype $body] break - append code "\nstatic int $cname" - append code {(ClientData cdata,Tcl_Interp *ip, - int objc,Tcl_Obj* CONST objv[])} " \{" - append code \n$cbody \n\}\n -} -proc ::tcc4tcl::wrapExport {name cmds {body ""}} { - set code "DLL_EXPORT int [string totitle $name]_Init(Tcl_Interp *interp)" - append code " \{\n" - foreach {tclname cname} $cmds { - append code \ - "Tcl_CreateObjCommand(interp,\"$tclname\",$cname,NULL,NULL);\n" - } - append code $body - append code "\nreturn TCL_OK;\n\}" -} -#--------------------------------------------------------------------- -proc ::tcc4tcl::cproc {name adefs rtype {body "#"}} { - foreach {code cbody} [wrap $name $adefs $rtype $body] break - ccode $code - set ns [namespace current] - uplevel 1 [list ${ns}::ccommand $name {dummy ip objc objv} $cbody] -} -#--------------------------------------------------------------------- -proc ::tcc4tcl::cdata {name data} { - # Extract bytes from data - binary scan $data c* bytes - set inittext "\n" - set line "" - set n 0 - set l 0 - foreach c $bytes { - if {$n>0} {append inittext ","} - if {$l>20} { - append inittext "\n" - set l 0 - } - if {$l==0} {append inittext " "} - append inittext [format "0x%02X" [expr {$c & 0xff}]] - incr n - incr l - } - append inittext "\n" - set count [llength $bytes] - set cbody "" - append cbody "static unsigned char script\[$count\] = \{" "\n" - append cbody $inittext - append cbody "\};" "\n" - append cbody "Tcl_SetByteArrayObj(Tcl_GetObjResult(ip), (unsigned char*) script, $count);\n" - append cbody "return TCL_OK;" "\n" - set ns [namespace current] - uplevel 1 [list ${ns}::ccommand $name {dummy ip objc objv} $cbody] - return $name -} -#------------------------------------------------------------------- -proc ::tcc4tcl::ccommand {procname anames args} { - variable tcc - # Fully qualified proc name - if {[string match "::*" $procname]} { - # procname is already absolute - } else { - set nsfrom [uplevel 1 {namespace current}] - if {$nsfrom eq "::"} {set nsfrom ""} - set procname "${nsfrom}::${procname}" - } - set v(clientdata) clientdata - set v(interp) interp - set v(objc) objc - set v(objv) objv - set id 0 - foreach defname {clientdata interp objc objv} { - if {[llength $anames]>$id} { - set vname [lindex $anames $id] - if {![checkname $vname]} { - error "invalid variable name \"$vname\"" - } - } else {set vname $defname} - set v($defname) $vname - incr id - } - set cname Cmd_N${id}_[cleanname $procname] - set code "" - if {[info exists tcc(tk)] && $tcc(tk)} { - append code "\#include " "\n" - } - if {[info exists tcc(code)] && [string length $tcc(code)]>0} { - append code $tcc(code) - append code "\n" - } - append code "int $cname (ClientData $v(clientdata),Tcl_Interp *$v(interp)," - append code "int $v(objc),Tcl_Obj *CONST $v(objv)\[\]) {" "\n" - append code [lindex $args end] "\n" - append code "}" "\n" - set ns [namespace current] - uplevel 1 [list ${ns}::cc $code] - Log "CREATING TCL COMMAND $procname / $cname" - uplevel 1 [list $tcc(cc) command $procname $cname] - unset tcc(cc) ;# can't be used for compiling anymore -} -proc ::tcc4tcl::tk {args} { - variable tcc - set tcc(tk) 1 -} -::tcc4tcl::reset -namespace eval tcc4tcl {namespace export cproc ccode cdata} - ADDED tcc4tcl.c Index: tcc4tcl.c ================================================================== --- tcc4tcl.c +++ tcc4tcl.c @@ -0,0 +1,286 @@ +/* + * TclTCC - Tcl binding to Tiny C Compiler + * + * Copyright (c) 2007 Mark Janssen + * Copyright (c) 2014 Roy Keene + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include +#include "tcc.h" + +struct TclTCCState { + TCCState *s; + int relocated; +}; + +static void Tcc4tclErrorFunc(Tcl_Interp * interp, char * msg) { + Tcl_AppendResult(interp, msg, "\n", NULL); +} + +static void Tcc4tclCCommandDeleteProc (ClientData cdata) { + struct TclTCCState *ts; + TCCState *s ; + + ts = (struct TclTCCState *) cdata; + s = ts->s; + + /* We can delete the compiler if the output was not to memory */ + if (s->output_type != TCC_OUTPUT_MEMORY) { + tcc_delete(s); + ts->s = NULL; + } + + ckfree((void *) ts); +} + +static int Tcc4tclHandleCmd ( ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]){ + unsigned long val; + void *val_p; + int index; + int res; + struct TclTCCState *ts; + TCCState *s; + Tcl_Obj *sym_addr; + static CONST char *options[] = { + "add_include_path", "add_file", "add_library", + "add_library_path", "add_symbol", "command", "compile", + "define", "get_symbol", "output_file", "undefine", (char *) NULL + }; + enum options { + TCLTCC_ADD_INCLUDE, TCLTCC_ADD_FILE, TCLTCC_ADD_LIBRARY, + TCLTCC_ADD_LIBRARY_PATH, TCLTCC_ADD_SYMBOL, TCLTCC_COMMAND, TCLTCC_COMPILE, + TCLTCC_DEFINE, TCLTCC_GET_SYMBOL, TCLTCC_OUTPUT_FILE, TCLTCC_UNDEFINE + }; + + ts = (struct TclTCCState *) cdata; + s = ts->s; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand arg ?arg ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case TCLTCC_ADD_INCLUDE: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } else { + tcc_add_include_path(s, Tcl_GetString(objv[2])); + return TCL_OK; + } + case TCLTCC_ADD_FILE: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "filename"); + return TCL_ERROR; + } else { + if(tcc_add_file(s, Tcl_GetString(objv[2]))!=0) { + return TCL_ERROR; + } else { + return TCL_OK; + } + } + case TCLTCC_ADD_LIBRARY: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "lib"); + return TCL_ERROR; + } else { + tcc_add_library(s, Tcl_GetString(objv[2])); + return TCL_OK; + } + case TCLTCC_ADD_LIBRARY_PATH: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } else { + tcc_add_library_path(s, Tcl_GetString(objv[2])); + return TCL_OK; + } +#if 0 + case TCLTCC_ADD_SYMBOL: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "symbol value"); + return TCL_ERROR; + } + Tcl_GetLongFromObj(interp,objv[3], &val); + + tcc_add_symbol(s,Tcl_GetString(objv[2]),val); + return TCL_OK; +#endif + case TCLTCC_COMMAND: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "tclname cname"); + return TCL_ERROR; + } + if (!ts->relocated) { + if(tcc_relocate(s, TCC_RELOCATE_AUTO)!=0) { + Tcl_AppendResult(interp, "relocating failed", NULL); + return TCL_ERROR; + } else { + ts->relocated=1; + } + } + + val_p = tcc_get_symbol(s, Tcl_GetString(objv[3])); + if (val_p == NULL) { + Tcl_AppendResult(interp, "symbol '", Tcl_GetString(objv[3]),"' not found", NULL); + return TCL_ERROR; + } + + /*printf("symbol: %x\n",val); */ + Tcl_CreateObjCommand(interp,Tcl_GetString(objv[2]),val_p,NULL,NULL); + return TCL_OK; + case TCLTCC_COMPILE: + if(ts->relocated == 1) { + Tcl_AppendResult(interp, "code already relocated, cannot compile more",NULL); + return TCL_ERROR; + } + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "ccode"); + return TCL_ERROR; + } else { + + int i; + Tcl_GetString(objv[2]); + i = tcc_compile_string(s,Tcl_GetString(objv[2])); + if (i!=0) { + Tcl_AppendResult(interp,"compilation failed",NULL); + return TCL_ERROR; + } else { + return TCL_OK; + } + } + case TCLTCC_DEFINE: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "symbol value"); + return TCL_ERROR; + } + tcc_define_symbol(s,Tcl_GetString(objv[2]),Tcl_GetString(objv[3])); + return TCL_OK; + case TCLTCC_GET_SYMBOL: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "symbol"); + return TCL_ERROR; + } + if (!ts->relocated) { + if(tcc_relocate(s, TCC_RELOCATE_AUTO)!=0) { + Tcl_AppendResult(interp, "relocating failed", NULL); + return TCL_ERROR; + } else { + ts->relocated=1; + } + } + val_p = tcc_get_symbol(s,Tcl_GetString(objv[2])); + if(val_p == NULL) { + Tcl_AppendResult(interp, "symbol '", Tcl_GetString(objv[2]),"' not found", NULL); + return TCL_ERROR; + } + sym_addr = Tcl_NewWideIntObj((Tcl_WideInt) val_p); + Tcl_SetObjResult(interp, sym_addr); + return TCL_OK; + case TCLTCC_OUTPUT_FILE: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "filename"); + return TCL_ERROR; + } + if (ts->relocated) { + Tcl_AppendResult(interp, "code already relocated, cannot output to file", NULL); + return TCL_ERROR; + } + if (s->output_type == TCC_OUTPUT_MEMORY) { + Tcl_AppendResult(interp, "output_type memory not valid for output to file", NULL); + return TCL_ERROR; + } + res = tcc_output_file(s,Tcl_GetString(objv[2])); + + if (res!=0) { + Tcl_AppendResult(interp, "output to file failed", NULL); + return TCL_ERROR; + } else { + return TCL_OK; + } + case TCLTCC_UNDEFINE: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "symbol"); + return TCL_ERROR; + } + tcc_undefine_symbol(s,Tcl_GetString(objv[2])); + return TCL_OK; + default: + Tcl_Panic("internal error during option lookup"); + } + return TCL_OK; +} + +static int Tcc4tclCreateCmd( ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]){ + struct TclTCCState *ts; + TCCState *s; + int index; + static CONST char *types[] = { + "memory", "exe", "dll", "obj", "preprocess", (char *) NULL + }; + + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "tcc_libary_path ?output_type? handle"); + return TCL_ERROR; + } + + if (objc == 3) { + index = TCC_OUTPUT_MEMORY; + } else { + if (Tcl_GetIndexFromObj(interp, objv[2], types, "type", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + } + + s = tcc_new(); + if (s == NULL) { + return(TCL_ERROR); + } + + s->tcc_lib_path = tcc_strdup(Tcl_GetString(objv[1])); + + tcc_set_error_func(s, interp, (void *)&Tcc4tclErrorFunc); + + ts = (void *) ckalloc(sizeof(*ts)); + ts->s = s; + ts->relocated = 0; + + /*printf("type: %d\n", index); */ + tcc_set_output_type(s,index); + Tcl_CreateObjCommand(interp,Tcl_GetString(objv[objc-1]),Tcc4tclHandleCmd,ts,Tcc4tclCCommandDeleteProc); + + return TCL_OK; +} + +int Tcc4tcl_Init(Tcl_Interp *interp) { +#ifdef USE_TCL_STUBS + if (Tcl_InitStubs(interp, "8.4" , 0) == 0L) { + return TCL_ERROR; + } +#endif + + Tcl_CreateObjCommand(interp, PACKAGE_NAME, Tcc4tclCreateCmd, NULL, NULL); + Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION); + + return TCL_OK; +} ADDED tcc4tcl.syms.in Index: tcc4tcl.syms.in ================================================================== --- tcc4tcl.syms.in +++ tcc4tcl.syms.in @@ -0,0 +1,1 @@ +@SYMPREFIX@Tcc4tcl_Init ADDED tcc4tcl.tcl Index: tcc4tcl.tcl ================================================================== --- tcc4tcl.tcl +++ tcc4tcl.tcl @@ -0,0 +1,374 @@ +# tcc.tcl - library routines for the tcc wrapper (Mark Janssen) + +namespace eval tcc4tcl { + variable dir + variable libs + variable includes + variable count + variable command_count + variable commands + + set dir [file dirname [info script]] + if {[info command ::tcc4tcl] == ""} { + catch { load {} tcc4tcl } + } + if {[info command ::tcc4tcl] == ""} { + load [file join $dir tcc4tcl[info sharedlibextension]] tcc4tcl + } + set libs $dir/lib + set includes $dir/include + set count 0 + set command_count 0 + array set commands {} + proc new {} { + variable dir + variable count + set handle tcc_[incr count] + tcc4tcl $dir $handle + return tcc_$count + } + proc tclcommand {handle name ccode} { + variable commands + variable command_count + set cname _tcc_tcl_command_[incr command_count] + set code {#include "tcl.h"} + append code "\n int $cname" + append code "(ClientData cdata,Tcl_Interp *interp,int objc,Tcl_Obj* CONST objv[]){" + append code "\n$ccode" + append code "}" + $handle compile $code + set commands($handle,$name) $cname + return + } + proc compile {handle} { + variable commands + foreach cmd [array names commands $handle*] { + puts $cmd + puts $commands($cmd) + set cname $commands($cmd) + set tclcommand [join [lrange [split $cmd ,] 1 end] {}] + set handle [lindex [split $cmd ,] 0] + $handle command $tclcommand $cname + } + return + } +} +proc tcc4tcl::to_dll {code dll {libs {}}} { + tcc4tcl $::tcc4tcl::dir dll tcc_1 + tcc_1 add_library tcl8.5 + tcc_1 add_library_path . + foreach lib $libs {tcc_1 add_library $lib} + if {$::tcl_platform(platform) eq "windows"} { + tcc_1 define DLL_EXPORT {__declspec(dllexport)} + set f [open $::tcc4tcl::dir/c/dllcrt1.c] + tcc_1 compile [read $f] + close $f + set f [open $::tcc4tcl::dir/c/dllmain.c] + tcc_1 compile [read $f] + close $f + } else { + tcc_1 define DLL_EXPORT "" + } + tcc_1 compile $code + tcc_1 output_file $dll + rename tcc_1 {} +} +proc ::tcc4tcl::Log {args} { + # puts $args +} +proc ::tcc4tcl::reset {} { + variable tcc + set tcc(code) "" + set tcc(cfiles) [list] + set tcc(tk) 0 +} +# Custom helpers +proc ::tcc4tcl::checkname {n} {expr {[regexp {^[a-zA-Z0-9_]+$} $n] > 0}} +proc ::tcc4tcl::cleanname {n} {regsub -all {[^a-zA-Z0-9_]+} $n _} + +proc ::tcc4tcl::ccode {code} { + variable tcc + Log "INJECTING CCODE" + append tcc(code) $code \n +} +proc ::tcc4tcl::cc {code} { + variable tcc + if {![info exists tcc(cc)]} { + set tcc(cc) tcc1 + tcc4tcl [file join $::tcc4tcl::dir lib] $tcc(cc) + $tcc(cc) add_library tcl8.5 + $tcc(cc) add_include_path [file join $::tcc4tcl::dir include] + } + Log code:$code + $tcc(cc) compile $code +} +#----------------------------------------------------------- New DLL API +proc ::tcc4tcl::dll {{name ""}} { + variable count + if {$name eq ""} {set name dll[incr count]} + namespace eval ::tcc4tcl::dll::$name { + variable code "#include \n" ;# always needed + variable cmds {} + } + proc ::$name {cmd args} "::tcc4tcl::dll::\$cmd $name \$args" + return $name +} +namespace eval ::tcc4tcl::dll {} +proc ::tcc4tcl::dll::ccode {name argl} { + append ${name}::code \n [lindex $argl 0] + return +} +proc ::tcc4tcl::dll::cproc {name argl} { + foreach {pname pargs rtype body} $argl break + set code [::tcc4tcl::wrapCmd $pname $pargs $rtype cx_$pname $body] + lappend ${name}::cmds $pname cx_$pname + append ${name}::code \n $code + return +} +proc ::tcc4tcl::dll::write {name argl} { + set (-dir) . + set (-code) "" ;# possible extra code to go into the _Init function + set (-libs) "" + set (-name) [string tolower $name] + array set "" $argl + append ${name}::code \n \ + [::tcc4tcl::wrapExport $(-name) [set ${name}::cmds] $(-code)] + set outfile $(-dir)/$(-name)[info sharedlibextension] + ::tcc4tcl::to_dll [set ${name}::code] $outfile $(-libs) +} +#--------------------------------------------------------------------- +proc ::tcc4tcl::wrap {name adefs rtype {body "#"}} { + set cname c_$name + set wname tcl_$name + array set types {} + set names {} + set cargs {} + set cnames {} + # if first arg is "Tcl_Interp*", pass it without counting it as a cmd arg + if {[lindex $adefs 0] eq "Tcl_Interp*"} { + lappend cnames ip + lappend cargs [lrange $adefs 0 1] + set adefs [lrange $adefs 2 end] + } + foreach {t n} $adefs { + set types($n) $t + lappend names $n + lappend cnames _$n + lappend cargs "$t $n" + } + switch -- $rtype { + ok { set rtype2 "int" } + string - dstring - vstring { set rtype2 "char*" } + default { set rtype2 $rtype } + } + set code "" + append code "\n#include " "\n" + if {[info exists tcc(tk)] && $tcc(tk)} { + append code "\#include " "\n" + } + if {$body ne "#"} { + append code "static $rtype2" "\n" + append code "${cname}([join $cargs {, }]) \{\n" + append code $body + append code "\}" "\n" + } else { + append code "#define $cname $name" "\n" + } + # Supported input types + # Tcl_Interp* + # int + # long + # float + # double + # char* + # Tcl_Obj* + # void* + foreach x $names { + set t $types($x) + switch -- $t { + int - long - float - double - char* - Tcl_Obj* { + append cbody " $types($x) _$x;" "\n" + } + default {append cbody " void *_$x;" "\n"} + } + } + if {$rtype ne "void"} { append cbody " $rtype2 rv;" "\n" } + append cbody " if (objc != [expr {[llength $names] + 1}]) {" "\n" + append cbody " Tcl_WrongNumArgs(ip, 1, objv, \"[join $names { }]\");\n" + append cbody " return TCL_ERROR;" "\n" + append cbody " }" "\n" + set n 0 + foreach x $names { + incr n + switch -- $types($x) { + int { + append cbody " if (Tcl_GetIntFromObj(ip, objv\[$n], &_$x) != TCL_OK)" + append cbody " return TCL_ERROR;" "\n" + } + long { + append cbody " if (Tcl_GetLongFromObj(ip, objv\[$n], &_$x) != TCL_OK)" + append cbody " return TCL_ERROR;" "\n" + } + float { + append cbody " {" "\n" + append cbody " double t;" "\n" + append cbody " if (Tcl_GetDoubleFromObj(ip, objv\[$n], &t) != TCL_OK)" + append cbody " return TCL_ERROR;" "\n" + append cbody " _$x = (float) t;" "\n" + append cbody " }" "\n" + } + double { + append cbody " if (Tcl_GetDoubleFromObj(ip, objv\[$n], &_$x) != TCL_OK)" + append cbody " return TCL_ERROR;" "\n" + } + char* { + append cbody " _$x = Tcl_GetString(objv\[$n]);" "\n" + } + default { + append cbody " _$x = objv\[$n];" "\n" + } + } + } + append cbody "\n " + if {$rtype != "void"} {append cbody "rv = "} + append cbody "${cname}([join $cnames {, }]);" "\n" + # Return types supported by critcl + # void + # ok + # int + # long + # float + # double + # char* (TCL_STATIC char*) + # string (TCL_DYNAMIC char*) + # dstring (TCL_DYNAMIC char*) + # vstring (TCL_VOLATILE char*) + # default (Tcl_Obj*) + # Our extensions + # wide + switch -- $rtype { + void { } + ok { append cbody " return rv;" "\n" } + int { append cbody " Tcl_SetIntObj(Tcl_GetObjResult(ip), rv);" "\n" } + long { append cbody " Tcl_SetLongObj(Tcl_GetObjResult(ip), rv);" "\n" } + float - + double { append cbody " Tcl_SetDoubleObj(Tcl_GetObjResult(ip), rv);" "\n" } + char* { append cbody " Tcl_SetResult(ip, rv, TCL_STATIC);" "\n" } + string - + dstring { append cbody " Tcl_SetResult(ip, rv, TCL_DYNAMIC);" "\n" } + vstring { append cbody " Tcl_SetResult(ip, rv, TCL_VOLATILE);" "\n" } + default { append cbody " Tcl_SetObjResult(ip, rv); Tcl_DecrRefCount(rv);" "\n" } + } + if {$rtype != "ok"} {append cbody " return TCL_OK;" \n} + + #puts ----code:\n$code + #puts ----cbody:\n$cbody + list $code $cbody +} +proc ::tcc4tcl::wrapCmd {tclname argl rtype cname body} { + foreach {code cbody} [wrap $tclname $argl $rtype $body] break + append code "\nstatic int $cname" + append code {(ClientData cdata,Tcl_Interp *ip, + int objc,Tcl_Obj* CONST objv[])} " \{" + append code \n$cbody \n\}\n +} +proc ::tcc4tcl::wrapExport {name cmds {body ""}} { + set code "DLL_EXPORT int [string totitle $name]_Init(Tcl_Interp *interp)" + append code " \{\n" + foreach {tclname cname} $cmds { + append code \ + "Tcl_CreateObjCommand(interp,\"$tclname\",$cname,NULL,NULL);\n" + } + append code $body + append code "\nreturn TCL_OK;\n\}" +} +#--------------------------------------------------------------------- +proc ::tcc4tcl::cproc {name adefs rtype {body "#"}} { + foreach {code cbody} [wrap $name $adefs $rtype $body] break + ccode $code + set ns [namespace current] + uplevel 1 [list ${ns}::ccommand $name {dummy ip objc objv} $cbody] +} +#--------------------------------------------------------------------- +proc ::tcc4tcl::cdata {name data} { + # Extract bytes from data + binary scan $data c* bytes + set inittext "\n" + set line "" + set n 0 + set l 0 + foreach c $bytes { + if {$n>0} {append inittext ","} + if {$l>20} { + append inittext "\n" + set l 0 + } + if {$l==0} {append inittext " "} + append inittext [format "0x%02X" [expr {$c & 0xff}]] + incr n + incr l + } + append inittext "\n" + set count [llength $bytes] + set cbody "" + append cbody "static unsigned char script\[$count\] = \{" "\n" + append cbody $inittext + append cbody "\};" "\n" + append cbody "Tcl_SetByteArrayObj(Tcl_GetObjResult(ip), (unsigned char*) script, $count);\n" + append cbody "return TCL_OK;" "\n" + set ns [namespace current] + uplevel 1 [list ${ns}::ccommand $name {dummy ip objc objv} $cbody] + return $name +} +#------------------------------------------------------------------- +proc ::tcc4tcl::ccommand {procname anames args} { + variable tcc + # Fully qualified proc name + if {[string match "::*" $procname]} { + # procname is already absolute + } else { + set nsfrom [uplevel 1 {namespace current}] + if {$nsfrom eq "::"} {set nsfrom ""} + set procname "${nsfrom}::${procname}" + } + set v(clientdata) clientdata + set v(interp) interp + set v(objc) objc + set v(objv) objv + set id 0 + foreach defname {clientdata interp objc objv} { + if {[llength $anames]>$id} { + set vname [lindex $anames $id] + if {![checkname $vname]} { + error "invalid variable name \"$vname\"" + } + } else {set vname $defname} + set v($defname) $vname + incr id + } + set cname Cmd_N${id}_[cleanname $procname] + set code "" + if {[info exists tcc(tk)] && $tcc(tk)} { + append code "\#include " "\n" + } + if {[info exists tcc(code)] && [string length $tcc(code)]>0} { + append code $tcc(code) + append code "\n" + } + append code "int $cname (ClientData $v(clientdata),Tcl_Interp *$v(interp)," + append code "int $v(objc),Tcl_Obj *CONST $v(objv)\[\]) {" "\n" + append code [lindex $args end] "\n" + append code "}" "\n" + set ns [namespace current] + uplevel 1 [list ${ns}::cc $code] + Log "CREATING TCL COMMAND $procname / $cname" + uplevel 1 [list $tcc(cc) command $procname $cname] + unset tcc(cc) ;# can't be used for compiling anymore +} +proc ::tcc4tcl::tk {args} { + variable tcc + set tcc(tk) 1 +} +::tcc4tcl::reset +namespace eval tcc4tcl {namespace export cproc ccode cdata} + DELETED tcltcc.c Index: tcltcc.c ================================================================== --- tcltcc.c +++ tcltcc.c @@ -1,286 +0,0 @@ -/* - * TclTCC - Tcl binding to Tiny C Compiler - * - * Copyright (c) 2007 Mark Janssen - * Copyright (c) 2014 Roy Keene - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - */ - -#include -#include -#include "tcc.h" - -struct TclTCCState { - TCCState *s; - int relocated; -}; - -static void Tcc4tclErrorFunc(Tcl_Interp * interp, char * msg) { - Tcl_AppendResult(interp, msg, "\n", NULL); -} - -static void Tcc4tclCCommandDeleteProc (ClientData cdata) { - struct TclTCCState *ts; - TCCState *s ; - - ts = (struct TclTCCState *) cdata; - s = ts->s; - - /* We can delete the compiler if the output was not to memory */ - if (s->output_type != TCC_OUTPUT_MEMORY) { - tcc_delete(s); - ts->s = NULL; - } - - ckfree((void *) ts); -} - -static int Tcc4tclHandleCmd ( ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]){ - unsigned long val; - void *val_p; - int index; - int res; - struct TclTCCState *ts; - TCCState *s; - Tcl_Obj *sym_addr; - static CONST char *options[] = { - "add_include_path", "add_file", "add_library", - "add_library_path", "add_symbol", "command", "compile", - "define", "get_symbol", "output_file", "undefine", (char *) NULL - }; - enum options { - TCLTCC_ADD_INCLUDE, TCLTCC_ADD_FILE, TCLTCC_ADD_LIBRARY, - TCLTCC_ADD_LIBRARY_PATH, TCLTCC_ADD_SYMBOL, TCLTCC_COMMAND, TCLTCC_COMPILE, - TCLTCC_DEFINE, TCLTCC_GET_SYMBOL, TCLTCC_OUTPUT_FILE, TCLTCC_UNDEFINE - }; - - ts = (struct TclTCCState *) cdata; - s = ts->s; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand arg ?arg ...?"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - switch (index) { - case TCLTCC_ADD_INCLUDE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "path"); - return TCL_ERROR; - } else { - tcc_add_include_path(s, Tcl_GetString(objv[2])); - return TCL_OK; - } - case TCLTCC_ADD_FILE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "filename"); - return TCL_ERROR; - } else { - if(tcc_add_file(s, Tcl_GetString(objv[2]))!=0) { - return TCL_ERROR; - } else { - return TCL_OK; - } - } - case TCLTCC_ADD_LIBRARY: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "lib"); - return TCL_ERROR; - } else { - tcc_add_library(s, Tcl_GetString(objv[2])); - return TCL_OK; - } - case TCLTCC_ADD_LIBRARY_PATH: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "path"); - return TCL_ERROR; - } else { - tcc_add_library_path(s, Tcl_GetString(objv[2])); - return TCL_OK; - } -#if 0 - case TCLTCC_ADD_SYMBOL: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "symbol value"); - return TCL_ERROR; - } - Tcl_GetLongFromObj(interp,objv[3], &val); - - tcc_add_symbol(s,Tcl_GetString(objv[2]),val); - return TCL_OK; -#endif - case TCLTCC_COMMAND: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "tclname cname"); - return TCL_ERROR; - } - if (!ts->relocated) { - if(tcc_relocate(s, TCC_RELOCATE_AUTO)!=0) { - Tcl_AppendResult(interp, "relocating failed", NULL); - return TCL_ERROR; - } else { - ts->relocated=1; - } - } - - val_p = tcc_get_symbol(s, Tcl_GetString(objv[3])); - if (val_p == NULL) { - Tcl_AppendResult(interp, "symbol '", Tcl_GetString(objv[3]),"' not found", NULL); - return TCL_ERROR; - } - - /*printf("symbol: %x\n",val); */ - Tcl_CreateObjCommand(interp,Tcl_GetString(objv[2]),val_p,NULL,NULL); - return TCL_OK; - case TCLTCC_COMPILE: - if(ts->relocated == 1) { - Tcl_AppendResult(interp, "code already relocated, cannot compile more",NULL); - return TCL_ERROR; - } - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "ccode"); - return TCL_ERROR; - } else { - - int i; - Tcl_GetString(objv[2]); - i = tcc_compile_string(s,Tcl_GetString(objv[2])); - if (i!=0) { - Tcl_AppendResult(interp,"compilation failed",NULL); - return TCL_ERROR; - } else { - return TCL_OK; - } - } - case TCLTCC_DEFINE: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "symbol value"); - return TCL_ERROR; - } - tcc_define_symbol(s,Tcl_GetString(objv[2]),Tcl_GetString(objv[3])); - return TCL_OK; - case TCLTCC_GET_SYMBOL: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "symbol"); - return TCL_ERROR; - } - if (!ts->relocated) { - if(tcc_relocate(s, TCC_RELOCATE_AUTO)!=0) { - Tcl_AppendResult(interp, "relocating failed", NULL); - return TCL_ERROR; - } else { - ts->relocated=1; - } - } - val_p = tcc_get_symbol(s,Tcl_GetString(objv[2])); - if(val_p == NULL) { - Tcl_AppendResult(interp, "symbol '", Tcl_GetString(objv[2]),"' not found", NULL); - return TCL_ERROR; - } - sym_addr = Tcl_NewWideIntObj((Tcl_WideInt) val_p); - Tcl_SetObjResult(interp, sym_addr); - return TCL_OK; - case TCLTCC_OUTPUT_FILE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "filename"); - return TCL_ERROR; - } - if (ts->relocated) { - Tcl_AppendResult(interp, "code already relocated, cannot output to file", NULL); - return TCL_ERROR; - } - if (s->output_type == TCC_OUTPUT_MEMORY) { - Tcl_AppendResult(interp, "output_type memory not valid for output to file", NULL); - return TCL_ERROR; - } - res = tcc_output_file(s,Tcl_GetString(objv[2])); - - if (res!=0) { - Tcl_AppendResult(interp, "output to file failed", NULL); - return TCL_ERROR; - } else { - return TCL_OK; - } - case TCLTCC_UNDEFINE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "symbol"); - return TCL_ERROR; - } - tcc_undefine_symbol(s,Tcl_GetString(objv[2])); - return TCL_OK; - default: - Tcl_Panic("internal error during option lookup"); - } - return TCL_OK; -} - -static int Tcc4tclCreateCmd( ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]){ - struct TclTCCState *ts; - TCCState *s; - int index; - static CONST char *types[] = { - "memory", "exe", "dll", "obj", "preprocess", (char *) NULL - }; - - if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "tcc_libary_path ?output_type? handle"); - return TCL_ERROR; - } - - if (objc == 3) { - index = TCC_OUTPUT_MEMORY; - } else { - if (Tcl_GetIndexFromObj(interp, objv[2], types, "type", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - } - - s = tcc_new(); - if (s == NULL) { - return(TCL_ERROR); - } - - s->tcc_lib_path = tcc_strdup(Tcl_GetString(objv[1])); - - tcc_set_error_func(s, interp, (void *)&Tcc4tclErrorFunc); - - ts = (void *) ckalloc(sizeof(*ts)); - ts->s = s; - ts->relocated = 0; - - /*printf("type: %d\n", index); */ - tcc_set_output_type(s,index); - Tcl_CreateObjCommand(interp,Tcl_GetString(objv[objc-1]),Tcc4tclHandleCmd,ts,Tcc4tclCCommandDeleteProc); - - return TCL_OK; -} - -int Tcc4tcl_Init(Tcl_Interp *interp) { -#ifdef USE_TCL_STUBS - if (Tcl_InitStubs(interp, "8.4" , 0) == 0L) { - return TCL_ERROR; - } -#endif - - Tcl_CreateObjCommand(interp, PACKAGE_NAME, Tcc4tclCreateCmd, NULL, NULL); - Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION); - - return TCL_OK; -} DELETED tcltcc.syms.in Index: tcltcc.syms.in ================================================================== --- tcltcc.syms.in +++ tcltcc.syms.in @@ -1,1 +0,0 @@ -@SYMPREFIX@Tcc4tcl_Init