Check-in [a972717fe8]
Overview
Comment:Cleanup
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: a972717fe8cbae55982403c5258846cb40d1388b
User & Date: rkeene on 2014-06-15 19:56:23
Other Links: manifest | tags
Context
2014-06-15
20:06
Improved error handling check-in: 92a72f9f80 user: rkeene tags: trunk
19:56
Cleanup check-in: a972717fe8 user: rkeene tags: trunk
2014-06-13
04:15
Updated to support colons in C procedure names check-in: fa96098302 user: rkeene tags: trunk
Changes

Modified tcc4tcl.tcl from [5cbfa0bb9e] to [24323fece8].

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

Modified test from [98d98c7c3c] to [67f0fe4037].

     1      1   #! /usr/bin/env tclsh
     2      2   
     3      3   lappend auto_path [lindex $argv 0]
     4      4   package require tcc4tcl
     5      5   
     6      6   tcc4tcl::cproc test {int i} int { return(i+42); }
     7      7   tcc4tcl::cproc test1 {int i} int { return(i+42); }
            8  +tcc4tcl::cproc ::bob::test1 {int i} int { return(i+42); }
            9  +
     8     10   puts [test 1]
           11  +puts [::test1 1]
           12  +puts [::bob::test1 1]