tcc4tcl
Check-in [7a4c3ad58c]
Login
HomeTimelineFilesBranchesTagsTicketsWiki
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
Hide Diffs Unified Diffs Ignore Whitespace Patch

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

1
2
3
4
5
6
7
8
9
10
11
12

13
14

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44

CC = @CC@
AR = @AR@
RANLIB = @RANLIB@
CFLAGS = @CFLAGS@ @SHOBJFLAGS@
CPPFLAGS = @CPPFLAGS@ -I@srcdir@ -I@srcdir@/tcc -Itcc @DEFS@
LDFLAGS =
SHOBJLDFLAGS = @SHOBJLDFLAGS@
LIBS = @LIBS@
INSTALL = @INSTALL@
PACKAGE_NAME = @PACKAGE_NAME@
PACKAGE_VERSION = @PACKAGE_VERSION@
TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@

PACKAGE_INSTALL_DIR = $(TCL_PACKAGE_PATH)/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
TARGETS = @TARGETS@

srcdir = @srcdir@

all: $(TARGETS)

tcc/config.h:
	if [ "$(srcdir)" = "." ]; then \
		cd tcc && ./configure; \
	else \
		mkdir tcc >/dev/null 2>/dev/null; \
		cd tcc && $(shell cd $(srcdir) && pwd)/tcc/configure; \
	fi

tcc/libtcc.a: tcc/config.h
	$(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 $(LIBS)

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














>


>






|


|












|








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46

CC = @CC@
AR = @AR@
RANLIB = @RANLIB@
CFLAGS = @CFLAGS@ @SHOBJFLAGS@
CPPFLAGS = @CPPFLAGS@ -I@srcdir@ -I@srcdir@/tcc -Itcc @DEFS@
LDFLAGS =
SHOBJLDFLAGS = @SHOBJLDFLAGS@
LIBS = @LIBS@
INSTALL = @INSTALL@
PACKAGE_NAME = @PACKAGE_NAME@
PACKAGE_VERSION = @PACKAGE_VERSION@
TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@
TCLCONFIGPATH = @TCLCONFIGPATH@
PACKAGE_INSTALL_DIR = $(TCL_PACKAGE_PATH)/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
TARGETS = @TARGETS@
TCC_CONFIGURE_OPTS = --extra-cflags='$(CFLAGS)' --with-tcl=$(TCLCONFIGPATH)
srcdir = @srcdir@

all: $(TARGETS)

tcc/config.h:
	if [ "$(srcdir)" = "." ]; then \
		cd tcc && ./configure $(TCC_CONFIGURE_OPTS); \
	else \
		mkdir tcc >/dev/null 2>/dev/null; \
		cd tcc && $(shell cd $(srcdir) && pwd)/tcc/configure $(TCC_CONFIGURE_OPTS); \
	fi

tcc/libtcc.a: tcc/config.h
	$(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)

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
︙︙

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

# tcc.tcl - library routines for the tcc wrapper (Mark Janssen)

namespace eval tcc {
   variable dir 
   variable libs
   variable includes
   variable count
   variable command_count
   variable commands

   set dir [file dirname [info script]]
   if {[info command ::tcc] == ""} {
      catch { load {} tcc }
   }
   if {[info command ::tcc] == ""} {
       load [file join $dir tcctcl[info sharedlibextension]] tcc
   }
   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]
       tcc $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"}



|








|
|

|
|










|








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

# 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"}
︙︙
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147

           set tclcommand [join [lrange [split $cmd ,] 1 end] {}]
           set handle [lindex [split $cmd ,] 0]
           $handle command $tclcommand $cname
        }
       return
   }
}
proc tcc::to_dll {code dll {libs {}}} {
    tcc $::tcc::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 $::tcc::dir/c/dllcrt1.c]
        tcc_1 compile [read $f]
        close $f
        set f [open $::tcc::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 ::tcc::Log {args} {
  # puts $args
}
proc ::tcc::reset {} {
  variable tcc
  set tcc(code)   ""
  set tcc(cfiles) [list]
  set tcc(tk) 0
}
# Custom helpers
proc ::tcc::checkname {n} {expr {[regexp {^[a-zA-Z0-9_]+$} $n] > 0}}
proc ::tcc::cleanname {n} {regsub -all {[^a-zA-Z0-9_]+} $n _}

proc ::tcc::ccode {code} {
  variable tcc
  Log "INJECTING CCODE"
  append tcc(code) $code \n
}
proc ::tcc::cc {code} {
  variable tcc
  if {![info exists tcc(cc)]} {
      set tcc(cc) tcc1
      tcc $tcc::dir $tcc(cc)
      $tcc(cc) add_library tcl8.5
      $tcc(cc) add_include_path [file join $::tcc::dir include]
  }
  Log code:$code
  $tcc(cc) compile $code
}
#----------------------------------------------------------- New DLL API
proc ::tcc::dll {{name ""}} {
    variable count
    if {$name eq ""} {set name dll[incr count]}
    namespace eval ::tcc::dll::$name {
        variable code "#include <tcl.h>\n" ;# always needed
        variable cmds {}
    }
    proc ::$name {cmd args} "::tcc::dll::\$cmd $name \$args"
    return $name
}
namespace eval ::tcc::dll {}
proc ::tcc::dll::ccode {name argl} {
    append ${name}::code \n [lindex $argl 0]
    return
}
proc ::tcc::dll::cproc {name argl} {
    foreach {pname pargs rtype body} $argl break
    set code [::tcc::wrapCmd $pname $pargs $rtype cx_$pname $body]
    lappend ${name}::cmds $pname cx_$pname
    append ${name}::code \n $code
    return
}
proc ::tcc::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 \
        [::tcc::wrapExport $(-name) [set ${name}::cmds] $(-code)]
    set outfile $(-dir)/$(-name)[info sharedlibextension]
    ::tcc::to_dll [set ${name}::code] $outfile $(-libs)
}
#---------------------------------------------------------------------
proc ::tcc::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








|
|





|


|









|


|






|
|

|




|



|

|





|


|



|


|
|



|

|




|






|

|


|








49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147

           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 $tcc4tcl::dir $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 <tcl.h>\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
︙︙
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300

  }
  if {$rtype != "ok"} {append cbody "  return TCL_OK;" \n}

  #puts ----code:\n$code
  #puts ----cbody:\n$cbody
  list $code $cbody
}
proc ::tcc::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 ::tcc::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 ::tcc::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 ::tcc::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 {








|






|










|






|








261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300

  }
  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 {
︙︙
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331

  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 ::tcc::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 ""}








|








317
318
319
320
321
322
323
324
325
326
327
328
329
330
331

  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 ""}
︙︙
361
362
363
364
365
366
367
368
369
370
371
372
373
374

  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 ::tcc::tk {args} {
  variable tcc
  set tcc(tk) 1
}
::tcc::reset
namespace eval tcc {namespace export cproc ccode cdata}









|



|
|


361
362
363
364
365
366
367
368
369
370
371
372
373
374

  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}

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

︙︙
16
17
18
19
20
21
22

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

54
55
56
57
58
59
60

 *
 * 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 <tcl.h>

#include "tcc.h"

struct TclTCCState {
	TCCState *s;
	int relocated;
};

static void TccErrorFunc(Tcl_Interp * interp, char * msg) {
	Tcl_AppendResult(interp, msg, "\n", NULL);
}

static void TccCCommandDeleteProc (ClientData cdata) {
	struct TclTCCState *ts;
	TCCState *s ;

	ts = (struct TclTCCState *) cdata;
	s = ts->s;

	Tcl_DecrRefCount(s->tcc_lib_path);

	/* 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;
	}

	free(ts);
}

static int TccHandleCmd ( ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]){
	unsigned long val;

	int index;
	int res;
	struct TclTCCState *ts;
	TCCState *s;
	Tcl_Obj *sym_addr;
	static CONST char *options[] = {
		"add_include_path", "add_file",  "add_library", 








>


















<
<






|




>








16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41


42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60

 *
 * 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 <tcl.h>
#include <stdlib.h>
#include "tcc.h"

struct TclTCCState {
	TCCState *s;
	int relocated;
};

static void TccErrorFunc(Tcl_Interp * interp, char * msg) {
	Tcl_AppendResult(interp, msg, "\n", NULL);
}

static void TccCCommandDeleteProc (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 TccHandleCmd ( 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",
︙︙
111
112
113
114
115
116
117

118
119
120
121
122
123

124
125

126
127
128
129
130
131
132
133
134
135
136
137
138

139

140
141
142
143
144
145
146
147
148
149
150
151
152

            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;
            }

        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; 

        case TCLTCC_COMMAND:
            if (objc != 4) {
                Tcl_WrongNumArgs(interp, 2, objv, "tclname cname");
                return TCL_ERROR;
            }
            if (!ts->relocated) {     
                if(tcc_relocate(s)!=0) {
                    Tcl_AppendResult(interp, "relocating failed", NULL);
                    return TCL_ERROR;
                } else {
                    ts->relocated=1;
                }
            }

            if (tcc_get_symbol(s,&val,Tcl_GetString(objv[3]))!=0) {

		    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]),(void *)val,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) {








>






>


>






|






>
|
>





|








111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157

            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) {
︙︙
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187

188
189
190
191
192
193
194
195
196
197
198

            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)!=0) {
                    Tcl_AppendResult(interp, "relocating failed", NULL);
                    return TCL_ERROR;
                } else {
                    ts->relocated=1;
                }
            }
            if(tcc_get_symbol(s,&val,Tcl_GetString(objv[2]))!=0) {

                Tcl_AppendResult(interp, "symbol '", Tcl_GetString(objv[2]),"' not found", NULL);
                return TCL_ERROR;
            }
            sym_addr = Tcl_NewLongObj(val);
            Tcl_SetObjResult(interp, sym_addr);
            return TCL_OK; 
        case TCLTCC_OUTPUT_FILE:
            if (objc != 3) {
                Tcl_WrongNumArgs(interp, 2, objv, "filename");
                return TCL_ERROR;
            }








|






|
>



|








178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204

            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;
            }
︙︙
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253




254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272

273
274
275
276
277

        default:
            Tcl_Panic("internal error during option lookup");
    }
    return TCL_OK;
} 

static int TccCreateCmd( 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(objv[1]);




	tcc_set_error_func(s, interp, (void *)&TccErrorFunc);

	ts = malloc(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]),TccHandleCmd,s,TccCCommandDeleteProc);

	return TCL_OK;
}

DLL_EXPORT int Tcc_Init(Tcl_Interp *interp) {
#ifdef TCL_USE_STUBS
	if (Tcl_InitStubs(interp, "8.4" , 0) == 0L) {
		return TCL_ERROR;
	}
#endif

	Tcl_CreateObjCommand(interp,PACKAGE_NAME,TccCreateCmd,NULL,NULL);
	Tcl_PkgProvide(interp,PACKAGE_NAME,PACKAGE_VERSION);

	return TCL_OK;
}








|



















|
>
>
>
>


|





|




|





>
|
|




232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288

        default:
            Tcl_Panic("internal error during option lookup");
    }
    return TCL_OK;
} 

static int TccCreateCmd( 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);
	}

	tcc_set_error_func(s, interp, (void *)&TccErrorFunc);

	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]),TccHandleCmd,ts,TccCCommandDeleteProc);

	return TCL_OK;
}

int Tcc4tcl_Init(Tcl_Interp *interp) {
#ifdef TCL_USE_STUBS
	if (Tcl_InitStubs(interp, "8.4" , 0) == 0L) {
		return TCL_ERROR;
	}
#endif

	Tcl_CreateObjCommand(interp, PACKAGE_NAME, TccCreateCmd, NULL, NULL);
	Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION);

	return TCL_OK;
}

Powered by Fossil · RSS