Check-in [daa895fdb4]
Overview
Comment:Rewrote high-level API to support a handle-based interface
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: daa895fdb417b960e251fa6233508753dff2eb97
User & Date: rkeene on 2014-06-18 04:45:59
Other Links: manifest | tags
Context
2014-06-18
05:05
Updated to allow output to file (DLL/SO) to work -- but segfaults check-in: c208e3c07f user: rkeene tags: trunk
04:45
Rewrote high-level API to support a handle-based interface check-in: daa895fdb4 user: rkeene tags: trunk
2014-06-17
16:56
Updated to treat NULL return values as errors from most types of return types check-in: fbca0aea0c user: rkeene tags: trunk
Changes

Modified tcc4tcl.tcl from [cb9913280b] to [cdff98c77e].

     1      1   # tcc.tcl - library routines for the tcc wrapper (Mark Janssen)
     2      2   
     3      3   namespace eval tcc4tcl {
     4      4   	variable dir 
     5         -	variable libs
     6         -	variable includes
     7      5   	variable count
     8         -	variable command_count
     9         -	variable commands
    10      6   
    11      7   	set dir [file dirname [info script]]
    12      8   	if {[info command ::tcc4tcl] == ""} {
    13      9   		catch { load {} tcc4tcl }
    14     10   	}
    15     11   	if {[info command ::tcc4tcl] == ""} {
    16     12   		load [file join $dir tcc4tcl[info sharedlibextension]] tcc4tcl
    17     13   	}
    18     14   
    19         -	set libs $dir/lib
    20         -	set includes $dir/include
    21     15   	set count 0
    22         -	set command_count 0
    23         -	array set commands {}
    24     16   
    25         -	proc new {{output "memory"}} {
           17  +	proc new {{output ""}} {
    26     18   		variable dir
    27     19   		variable count
    28     20   
    29         -		set handle tcc_[incr count]
    30         -		tcc4tcl $dir $output $handle
           21  +		set handle ::tcc4tcl::tcc_[incr count]
           22  +		set tcc_handle ::tcc4tcl::tcc_[incr count]
           23  +
           24  +		if {$output == ""} {
           25  +			set type "memory"
           26  +		} else {
           27  +			set type "dll"
           28  +		}
           29  +
           30  +		array set $handle [list tcc $tcc_handle code "" type $type]
           31  +
           32  +		proc $handle {cmd args} [string map [list @@HANDLE@@ $handle] {
           33  +			set handle {@@HANDLE@@}
           34  +			uplevel 1 [list ::tcc4tcl::_$cmd $handle {*}$args]
           35  +		}]
    31     36   
    32     37   		return $handle
    33     38   	}
    34     39   
    35         -	proc tclcommand {handle name ccode} {
    36         -		variable commands
    37         -		variable command_count
    38         -
    39         -		set cname _tcc_tcl_command_[incr command_count]
    40         -
    41         -		set code    {#include "tcl.h"}
    42         -		append code "\nint $cname(ClientData cdata,Tcl_Interp *interp,int objc,Tcl_Obj* CONST objv\[\]) \{"
    43         -		append code "\n$ccode"
    44         -		append code "\}"
    45         -
    46         -		$handle compile $code
    47         -
    48         -		set commands($handle,$name) $cname
    49         -
    50         -		return
    51         -	}
    52         -
    53         -	proc compile {handle} {
    54         -		variable commands
    55         -
    56         -		foreach cmd [array names commands ${handle},*] {
    57         -			set cname $commands($cmd)
    58         -			set tclcommand [join [lrange [split $cmd ,] 1 end] {}]
    59         -
    60         -			set handle [lindex [split $cmd ,] 0]
    61         -
    62         -			$handle command $tclcommand $cname
           40  +	proc _cproc {handle name adefs rtype {body "#"}} {
           41  +		upvar #0 $handle state
           42  +
           43  +		set wrap [::tcc4tcl::wrap $name $adefs $rtype $body]
           44  +
           45  +		set wrapped [lindex $wrap 0]
           46  +		set wrapper [lindex $wrap 1]
           47  +		set tclname [lindex $wrap 2]
           48  +
           49  +		append state(code) $wrapped "\n"
           50  +		append state(code) $wrapper "\n"
           51  +
           52  +		lappend state(procs) $name $tclname
           53  +	}
           54  +
           55  +	proc _ccode {handle code} {
           56  +		upvar #0 $handle state
           57  +
           58  +		append state(code) $code
           59  +	}
           60  +
           61  +	proc _tk {handle} {
           62  +		upvar #0 $handle state
           63  +
           64  +		set state(tk) 1
           65  +	}
           66  +
           67  +	proc _go {handle} {
           68  +		variable dir
           69  +
           70  +		upvar #0 $handle state
           71  +
           72  +		if {[info exists state(tk)]} {
           73  +			set state(code) "#include <tk.h>\n$state(code)"
           74  +		}
           75  +		set state(code) "#include <tcl.h>\n\n$state(code)"
           76  +
           77  +		tcc4tcl $dir $state(type) tcc
           78  +		tcc compile $state(code)
           79  +
           80  +		foreach {procname cname} $state(procs) {
           81  +			tcc command $procname $cname
    63     82   		}
    64     83   
    65         -		return
           84  +		rename $handle ""
           85  +		unset $handle
    66     86   	}
           87  +
    67     88   }
    68     89   
    69         -proc tcc4tcl::to_dll {code dll {libs {}}} {
    70         -	set handle [::tcc4tcl::new dll]
    71         -	foreach lib $libs {
    72         -		$handle add_library $lib
    73         -	}
    74         -
    75         -	if {$::tcl_platform(platform) eq "windows"} {
    76         -		$handle define DLL_EXPORT {__declspec(dllexport)} 
    77         -
    78         -		set f [open [file join $::tcc4tcl::dir lib dllcrt1.c]]
    79         -		$handle compile [read $f]
    80         -		close $f
    81         -
    82         -		set f [open [file join $::tcc4tcl::dir lib dllmain.c]]
    83         -		$handle compile [read $f]
    84         -		close $f
    85         -	} else {
    86         -		$handle define DLL_EXPORT ""
    87         -	}
    88         -
    89         -	$handle compile $code
    90         -	$handle output_file $dll
    91         -
    92         -	rename $handle {}
    93         -}
    94         -
    95         -proc ::tcc4tcl::Log {args} {
    96         -	# puts $args
    97         -}
    98         -
    99         -proc ::tcc4tcl::reset {} {
   100         -	variable tcc
   101         -	set tcc(code)   ""
   102         -	set tcc(cfiles) [list]
   103         -	set tcc(tk) 0
   104         -}
   105         -
   106         -# Custom helpers
   107     90   proc ::tcc4tcl::checkname {n} {expr {[regexp {^[a-zA-Z0-9_]+$} $n] > 0}}
   108     91   proc ::tcc4tcl::cleanname {n} {regsub -all {[^a-zA-Z0-9_]+} $n _}
   109     92   
   110         -proc ::tcc4tcl::ccode {code} {
   111         -	variable tcc
   112         -
   113         -	Log "INJECTING CCODE"
   114         -
   115         -	append tcc(code) $code \n
           93  +proc ::tcc4tcl::cproc {name adefs rtype {body "#"}} {
           94  +	set handle [::tcc4tcl::new]
           95  +	$handle cproc $name $adefs $rtype $body
           96  +	return [$handle go]
   116     97   }
   117     98   
   118         -proc ::tcc4tcl::cc {code} {
   119         -	variable tcc
   120         -
   121         -	if {![info exists tcc(cc)]} {
   122         -		set tcc(cc) [::tcc4tcl::new]
           99  +proc ::tcc4tcl::wrap {name adefs rtype {body "#"} {cname ""}} {
          100  +	if {$cname == ""} {
          101  +		set cname c_[tcc4tcl::cleanname $name]
   123    102   	}
   124    103   
   125         -	$tcc(cc) compile $code
   126         -}
          104  +	set wname tcl_[tcc4tcl::cleanname $name]
   127    105   
   128         -#----------------------------------------------------------- New DLL API
   129         -namespace eval ::tcc4tcl::dll {}
   130         -proc ::tcc4tcl::dll {{name ""}} {
   131         -	variable count
          106  +	# Fully qualified proc name
          107  +	if {![string match "::*" $name]} {
          108  +		set nsfrom [uplevel 1 {namespace current}]    
          109  +		if {$nsfrom eq "::"} {
          110  +			set nsfrom ""
          111  +		}
   132    112   
   133         -	if {$name eq ""} {
   134         -		set name dll[incr count]
          113  +		set name "${nsfrom}::${name}"
   135    114   	}
   136    115   
   137         -	namespace eval ::tcc4tcl::dll::$name {
   138         -		variable code "#include <tcl.h>\n" ;# always needed
   139         -		variable cmds {}
   140         -	}
   141         -
   142         -	proc ::$name {cmd args} "::tcc4tcl::dll::\$cmd $name \$args"
   143         -	return $name
   144         -}
   145         -
   146         -proc ::tcc4tcl::dll::ccode {name argl} {
   147         -	append ${name}::code "\n" [lindex $argl 0]
   148         -
   149         -	return
   150         -}
   151         -
   152         -proc ::tcc4tcl::dll::cproc {name argl} {
   153         -	foreach {pname pargs rtype body} $argl break
   154         -
   155         -	set code [::tcc4tcl::wrapCmd $pname $pargs $rtype cx_$pname $body]
   156         -
   157         -	lappend ${name}::cmds $pname cx_$pname
   158         -	append ${name}::code "\n" $code
   159         -
   160         -	return
   161         -}
   162         -
   163         -proc ::tcc4tcl::dll::write {name argl} {
   164         -	set (-dir) .
   165         -	set (-code) "" ;# possible extra code to go into the _Init function
   166         -	set (-libs) ""
   167         -	set (-name) [string tolower $name]
   168         -	array set "" $argl
   169         -
   170         -	append ${name}::code "\n" \
   171         -		[::tcc4tcl::wrapExport $(-name) [set ${name}::cmds] $(-code)]
   172         -
   173         -	set outfile $(-dir)/$(-name)[info sharedlibextension]
   174         -
   175         -	::tcc4tcl::to_dll [set ${name}::code] $outfile $(-libs)
   176         -}
   177         -
   178         -#---------------------------------------------------------------------
   179         -proc ::tcc4tcl::wrap {name adefs rtype {body "#"}} {
   180         -	set cname c_[tcc4tcl::cleanname $name]
   181         -	set wname tcl_$name
   182    116   	array set types {}
   183    117   	set varnames {}
   184    118   	set cargs {}
   185    119   	set cnames {}  
   186    120   	set cbody {}
   187    121   	set code {}
   188    122   
          123  +	# Write wrapper
          124  +	append cbody "int $wname\(ClientData dummy, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv\[\]) {" "\n"
          125  +
   189    126   	# if first arg is "Tcl_Interp*", pass it without counting it as a cmd arg
   190    127   	if {[lindex $adefs 0] eq "Tcl_Interp*"} {
   191    128   		lappend cnames ip
   192    129   		lappend cargs [lrange $adefs 0 1]
   193    130   		set adefs [lrange $adefs 2 end]
   194    131   	}
   195    132   
................................................................................
   209    146   			set rtype2 "char*"
   210    147   		}
   211    148   		default {
   212    149   			set rtype2 $rtype
   213    150   		}
   214    151   	}
   215    152   
   216         -	append code "#include <tcl.h>\n"
   217         -	if {[info exists tcc(tk)] && $tcc(tk)} {
   218         -		append code "#include <tk.h>\n"
   219         -	}
   220         -
   221    153   	# Create wrapped function
   222    154   	if {$body ne "#"} {
   223    155   		append code "static $rtype2 ${cname}([join $cargs {, }]) \{\n"
   224    156   		append code $body
   225    157   		append code "\}\n"
   226    158   	} else {
   227    159   		append code "#define $cname $name" "\n"
................................................................................
   291    223   			}
   292    224   		}
   293    225   	}
   294    226   	append cbody "\n"
   295    227   
   296    228   	# Call wrapped function
   297    229   	if {$rtype != "void"} {
   298         -		append cbody "rv = "
          230  +		append cbody "  rv = "
   299    231   	}
   300    232   	append cbody "${cname}([join $cnames {, }]);" "\n"
   301    233   
   302    234   	# Return types supported by critcl
   303    235   	#   void
   304    236   	#   ok
   305    237   	#   int
................................................................................
   335    267   		default        { append cbody "  Tcl_SetObjResult(ip, rv); Tcl_DecrRefCount(rv);" "\n" }
   336    268   	}
   337    269   
   338    270   	if {$rtype != "ok"} {
   339    271   		append cbody "  return TCL_OK;\n"
   340    272   	}
   341    273   
   342         -	return [list $code $cbody]
   343         -}
          274  +	append cbody "}" "\n"
   344    275   
   345         -proc ::tcc4tcl::wrapCmd {tclname argl rtype cname body} {
   346         -	foreach {code cbody} [wrap $tclname $argl $rtype $body] break
   347         -
   348         -	append code "\nstatic int $cname(ClientData cdata,Tcl_Interp *ip, int objc,Tcl_Obj* CONST objv\[\]) \{\n"
   349         -	append code "\n$cbody\n\}\n"
   350         -
   351         -	return $code
          276  +	return [list $code $cbody $wname]
   352    277   }
   353    278   
   354         -proc ::tcc4tcl::wrapExport {name cmds {body ""}} {
   355         -	set code "DLL_EXPORT int [string totitle $name]_Init(Tcl_Interp *interp) \{\n"
   356         -
   357         -	foreach {tclname cname} $cmds {
   358         -		append code "Tcl_CreateObjCommand(interp, \"$tclname\", $cname, NULL, NULL);\n"
   359         -	}
   360         -
   361         -	append code $body
   362         -	append code "\nreturn TCL_OK;\n\}"
   363         -
   364         -	return $code
   365         -}
   366         -
   367         -#---------------------------------------------------------------------
   368         -proc ::tcc4tcl::cproc {name adefs rtype {body "#"}} {
   369         -	foreach {code cbody} [wrap $name $adefs $rtype $body] break
   370         -
   371         -	::tcc4tcl::ccode $code
   372         -
   373         -	uplevel 1 [list ::tcc4tcl::ccommand $name {dummy ip objc objv} $cbody]
   374         -}
   375         -
   376         -#---------------------------------------------------------------------
   377         -proc ::tcc4tcl::cdata {name data} {
   378         -	# Extract bytes from data
   379         -	binary scan $data c* bytes
   380         -
   381         -	set inittext "\n"
   382         -	set line ""
   383         -	set n 0
   384         -	set l 0
   385         -	foreach c $bytes {
   386         -		if {$n > 0} {
   387         -			append inittext ","
   388         -		}
   389         -		if {$l > 20} {
   390         -			append inittext "\n"
   391         -			set l 0
   392         -		}
   393         -
   394         -		if {$l==0} {
   395         -			append inittext "  "
   396         -		}
   397         -
   398         -		append inittext [format "0x%02X" [expr {$c & 0xff}]]
   399         -		incr n
   400         -		incr l
   401         -	}
   402         -
   403         -	append inittext "\n"
   404         -
   405         -	set count [llength $bytes]  
   406         -
   407         -	set cbody ""
   408         -	append cbody "static unsigned char script\[$count\] = \{" "\n"
   409         -	append cbody $inittext
   410         -	append cbody "\};" "\n"
   411         -
   412         -	append cbody "Tcl_SetByteArrayObj(Tcl_GetObjResult(ip), (unsigned char*) script, $count);\n"
   413         -	append cbody "return TCL_OK;" "\n"
   414         -
   415         -	uplevel 1 [list tcc4tcl::ccommand $name {dummy ip objc objv} $cbody]
   416         -
   417         -	return $name
   418         -}
   419         -
   420         -#-------------------------------------------------------------------
   421         -proc ::tcc4tcl::ccommand {procname anames body} {
   422         -	variable tcc
   423         -
   424         -	# Fully qualified proc name
   425         -	if {[string match "::*" $procname]} {
   426         -		# procname is already absolute
   427         -	} else {
   428         -		set nsfrom [uplevel 1 {namespace current}]    
   429         -		if {$nsfrom eq "::"} {
   430         -			set nsfrom ""
   431         -		}
   432         -
   433         -		set procname "${nsfrom}::${procname}"
   434         -	}
   435         -
   436         -	set v(clientdata) clientdata
   437         -	set v(interp)     interp
   438         -	set v(objc)       objc
   439         -	set v(objv)       objv
   440         -
   441         -	set id 0
   442         -
   443         -	foreach defname {clientdata interp objc objv} {
   444         -		if {[llength $anames] > $id} {
   445         -			set vname [lindex $anames $id]
   446         -
   447         -			if {![checkname $vname]} {
   448         -				error "invalid variable name \"$vname\""
   449         -			}
   450         -		} else {
   451         -			set vname $defname
   452         -		}
   453         -
   454         -		set v($defname) $vname
   455         -
   456         -		incr id
   457         -	}
   458         -
   459         -	set cname Cmd_N${id}_[cleanname $procname]
   460         -	set code ""
   461         -
   462         -	if {[info exists tcc(tk)] && $tcc(tk)} {
   463         -		append code "\#include <tk.h>" "\n"
   464         -	}
   465         -
   466         -	if {[info exists tcc(code)]} {
   467         -		append code $tcc(code)
   468         -		append code "\n"
   469         -	}
   470         -	set tcc(code) ""
   471         -
   472         -	append code "int $cname (ClientData $v(clientdata),Tcl_Interp *$v(interp),"
   473         -	append code "int $v(objc),Tcl_Obj *CONST $v(objv)\[\]) {" "\n"
   474         -	append code $body "\n"
   475         -	append code "}" "\n"
   476         -
   477         -	if {[catch {
   478         -		uplevel 1 [list tcc4tcl::cc $code]
   479         -	} err]} {
   480         -		unset tcc(cc)
   481         -		tcc4tcl::reset
   482         -
   483         -		return -code error $err
   484         -	}
   485         -
   486         -	Log "CREATING TCL COMMAND $procname / $cname"
   487         -	uplevel 1 [list $tcc(cc) command $procname $cname]
   488         -
   489         -	unset tcc(cc) ;# can't be used for compiling anymore
   490         -	tcc4tcl::reset
   491         -}
   492         -
   493         -proc ::tcc4tcl::tk {args} {
   494         -	variable tcc
   495         -	set tcc(tk) 1
   496         -}
   497         -
   498         -::tcc4tcl::reset
   499         -namespace eval tcc4tcl {namespace export cproc ccode cdata}
          279  +namespace eval tcc4tcl {namespace export cproc new}