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 {} {
	proc new {{output "memory"}} {
       variable dir
       variable count

       set handle tcc_[incr count]
       tcc4tcl $dir $handle
       return tcc_$count
		tcc4tcl $dir $output $handle

		return $handle
   }

   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 "\nint $cname(ClientData cdata,Tcl_Interp *interp,int objc,Tcl_Obj* CONST objv\[\]) \{"
       append code "\n$ccode"
       append code "}"
		append code "\}"

       $handle compile $code

       set commands($handle,$name) $cname

       return
   }

   proc compile {handle} {
       variable commands

       foreach cmd [array names commands $handle*] {
		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
    foreach lib $libs {tcc_1 add_library $lib}
	set handle [::tcc4tcl::new dll]
	foreach lib $libs {
		$handle 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]
		$handle define DLL_EXPORT {__declspec(dllexport)} 

		set f [open [file join $::tcc4tcl::dir c dllcrt1.c]]
		$handle compile [read $f]
        close $f
        set f [open $::tcc4tcl::dir/c/dllmain.c]
        tcc_1 compile [read $f]

		set f [open [file join $::tcc4tcl::dir c dllmain.c]]
		$handle compile [read $f]
        close $f
    } else {
        tcc_1 define DLL_EXPORT ""
		$handle define DLL_EXPORT ""
    }

    tcc_1 compile $code
    tcc_1 output_file $dll
    rename tcc_1 {}
	$handle compile $code
	$handle output_file $dll

	rename $handle {}
}
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
		set tcc(cc) [::tcc4tcl::new]
      tcc4tcl $::tcc4tcl::dir $tcc(cc)
  }

  Log code:$code
  $tcc(cc) compile $code
}

#----------------------------------------------------------- New DLL API
namespace eval ::tcc4tcl::dll {}
proc ::tcc4tcl::dll {{name ""}} {
    variable count

    if {$name eq ""} {set name dll[incr 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]
	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
	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 \
	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_[string map [list ":" "_"] $name]
	set cname c_[tcc4tcl::cleanname $name]
  set wname tcl_$name
  array set types {}
  set names {}
	set varnames {}
  set cargs {}
  set cnames {}  
	set cbody {}
	set code {}

  # 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 varnames $n
    lappend cnames _$n
    lappend cargs "$t $n"
  }

	# Handle return type
  switch -- $rtype {
		ok      {
    ok      { set rtype2 "int" }
    string - dstring - vstring { set rtype2 "char*" }
    default { set rtype2 $rtype }
			set rtype2 "int"
		}
		string - dstring - vstring {
			set rtype2 "char*"
		}
		default {
			set rtype2 $rtype
  }
	}
  set code ""
  append code "\n#include <tcl.h>" "\n"

	append code "#include <tcl.h>\n"
  if {[info exists tcc(tk)] && $tcc(tk)} {
    append code "\#include <tk.h>" "\n"
		append code "#include <tk.h>\n"
  }

	# Create wrapped function
  if {$body ne "#"} {
    append code "static $rtype2" "\n"
		append code "static $rtype2 ${cname}([join $cargs {, }]) \{\n"
    append code "${cname}([join $cargs {, }]) \{\n"
    append code $body
    append code "\}" "\n"
		append code "\}\n"
  } else {
    append code "#define $cname $name" "\n"
  }

	# Create wrapper function
  # Supported input types
  #   Tcl_Interp*
  #   int
  #   long
  #   float
  #   double
  #   char*
  #   Tcl_Obj*
  #   void*
  foreach x $names {
	## Supported input types
	##   Tcl_Interp*
	##   int
	##   long
	##   float
	##   double
	##   char*
	##   Tcl_Obj*
	##   void*
	foreach x $varnames {
    set t $types($x)

    switch -- $t {
      int - long - float - double - char* - Tcl_Obj* {
          append cbody "  $types($x) _$x;" "\n"
      }
			default {
      default {append cbody "  void *_$x;" "\n"}
				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"
	if {$rtype ne "void"} {
		append cbody  "  $rtype2 rv;" "\n"
	}  

	append cbody "  if (objc != [expr {[llength $varnames] + 1}]) {" "\n"
	append cbody "    Tcl_WrongNumArgs(ip, 1, objv, \"[join $varnames { }]\");\n"
  append cbody "    return TCL_ERROR;" "\n"
  append cbody "  }" "\n"

  set n 0
  foreach x $names {
	foreach x $varnames {
    incr n
    switch -- $types($x) {
      int {
	append cbody "  if (Tcl_GetIntFromObj(ip, objv\[$n], &_$x) != TCL_OK)"
	append cbody "    return TCL_ERROR;" "\n"
      }
      long {

      }
      default {
	append cbody "  _$x = objv\[$n];" "\n"
      }
    }
  }
  append cbody "\n  "

	# Call wrapped function
  if {$rtype != "void"} {append cbody "rv = "}
	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
	if {$rtype != "ok"} {
		append cbody "  return TCL_OK;\n"
	}

  #puts ----cbody:\n$cbody
  list $code $cbody
	return [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
	append code "\nstatic int $cname(ClientData cdata,Tcl_Interp *ip, int objc,Tcl_Obj* CONST objv\[\]) \{\n"
	append code "\n$cbody\n\}\n"

	return $code
}

proc ::tcc4tcl::wrapExport {name cmds {body ""}} {
    set code "DLL_EXPORT int [string totitle $name]_Init(Tcl_Interp *interp)"
    append code " \{\n"
	set code "DLL_EXPORT int [string totitle $name]_Init(Tcl_Interp *interp) \{\n"

    foreach {tclname cname} $cmds {
        append code \
            "Tcl_CreateObjCommand(interp,\"$tclname\",$cname,NULL,NULL);\n"
		append code "Tcl_CreateObjCommand(interp, \"$tclname\", $cname, NULL, NULL);\n"
    }

    append code $body
    append code "\nreturn TCL_OK;\n\}"
}

	return $code
}

#---------------------------------------------------------------------
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]
	::tcc4tcl::ccode $code

	uplevel 1 [list ::tcc4tcl::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} {
    if {$n>0} {append inittext ","}
			append inittext ","
		}
    if {$l>20} {
      append inittext "\n"
      set l 0
    }

    if {$l==0} {append inittext "  "}
		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]

	uplevel 1 [list tcc4tcl::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 ""}
		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 {
    } else {set vname $defname}
			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 <tk.h>" "\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]

	uplevel 1 [list tcc4tcl::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}

#! /usr/bin/env tclsh

lappend auto_path [lindex $argv 0]
package require tcc4tcl

tcc4tcl::cproc test {int i} int { return(i+42); }
tcc4tcl::cproc test1 {int i} int { return(i+42); }
tcc4tcl::cproc ::bob::test1 {int i} int { return(i+42); }

puts [test 1]
puts [::test1 1]
puts [::bob::test1 1]