#! /bin/bash

# Download latest copy of autoconf macros
(
	mkdir aclocal >/dev/null 2>/dev/null
	cd aclocal || exit 1

	for file in shobj.m4 tcl.m4 versionscript.m4; do
		rm -f "${file}"

		wget -O "${file}.new" "http://rkeene.org/devel/autoconf/${file}" || continue

package ifneeded tcc4tcl @PACKAGE_VERSION@ [list source [file join $dir tcc4tcl.tcl]]

/*
 *  TclTCC - Tcl binding to Tiny C Compiler
 * 
 *  Copyright (c) 2007 Mark Janssen
 *  Copyright (c) 2014 Roy Keene
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 */

#include <tcl.h>
#include <stdlib.h>
#include "tcc.h"

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

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


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

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

	/* We can delete the compiler if the output was not to memory */
	if (s->output_type != TCC_OUTPUT_MEMORY) {
		tcc_delete(s);
		ts->s = NULL;
	}

	ckfree((void *) ts);
}

static int Tcc4tclHandleCmd ( ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]){
	unsigned long val;
	void *val_p;
	int index;
	int res;
	struct TclTCCState *ts;
	TCCState *s;
	Tcl_Obj *sym_addr;

	static CONST char *options[] = {
		"add_include_path", "add_file",  "add_library", 
		"add_library_path", "add_symbol", "command", "compile",
		"define", "get_symbol", "output_file", "undefine",    (char *) NULL
	};
	enum options {
		TCLTCC_ADD_INCLUDE, TCLTCC_ADD_FILE, TCLTCC_ADD_LIBRARY, 
		TCLTCC_ADD_LIBRARY_PATH, TCLTCC_ADD_SYMBOL, TCLTCC_COMMAND, TCLTCC_COMPILE,
		TCLTCC_DEFINE, TCLTCC_GET_SYMBOL, TCLTCC_OUTPUT_FILE, TCLTCC_UNDEFINE
	};

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

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "subcommand arg ?arg ...?");
        return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,

            if (objc != 3) {
                Tcl_WrongNumArgs(interp, 2, objv, "path");
                return TCL_ERROR;
            } else {
                tcc_add_library_path(s, Tcl_GetString(objv[2]));
                return TCL_OK;
            }
#if 0
        case TCLTCC_ADD_SYMBOL:
            if (objc != 4) {
                Tcl_WrongNumArgs(interp, 2, objv, "symbol value");
                return TCL_ERROR;
            }
            Tcl_GetLongFromObj(interp,objv[3], &val);

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

            val_p = tcc_get_symbol(s, Tcl_GetString(objv[3]));
            if (val_p == NULL) {
		    Tcl_AppendResult(interp, "symbol '", Tcl_GetString(objv[3]),"' not found", NULL);
		    return TCL_ERROR;
	    }

            /*printf("symbol: %x\n",val); */
            Tcl_CreateObjCommand(interp,Tcl_GetString(objv[2]),val_p,NULL,NULL);
            return TCL_OK;
        case TCLTCC_COMPILE:
            if(ts->relocated == 1) {
                Tcl_AppendResult(interp, "code already relocated, cannot compile more",NULL);
                return TCL_ERROR;
            }
            if (objc != 3) {
                Tcl_WrongNumArgs(interp, 2, objv, "ccode");
                return TCL_ERROR;
            } else {

            tcc_define_symbol(s,Tcl_GetString(objv[2]),Tcl_GetString(objv[3]));
            return TCL_OK;
        case TCLTCC_GET_SYMBOL:
            if (objc != 3) {
                Tcl_WrongNumArgs(interp, 2, objv, "symbol");
                return TCL_ERROR;
            }
            if (!ts->relocated) {     
                if(tcc_relocate(s, TCC_RELOCATE_AUTO)!=0) {
                    Tcl_AppendResult(interp, "relocating failed", NULL);
                    return TCL_ERROR;
                } else {
                    ts->relocated=1;
                }
            }
            val_p = tcc_get_symbol(s,Tcl_GetString(objv[2]));
            if(val_p == NULL) {
                Tcl_AppendResult(interp, "symbol '", Tcl_GetString(objv[2]),"' not found", NULL);
                return TCL_ERROR;
            }
            sym_addr = Tcl_NewWideIntObj((Tcl_WideInt) val_p);
            Tcl_SetObjResult(interp, sym_addr);
            return TCL_OK; 
        case TCLTCC_OUTPUT_FILE:
            if (objc != 3) {
                Tcl_WrongNumArgs(interp, 2, objv, "filename");
                return TCL_ERROR;
            }
            if (ts->relocated) {     
                Tcl_AppendResult(interp, "code already relocated, cannot output to file", NULL);
                return TCL_ERROR;
            }
            if (s->output_type == TCC_OUTPUT_MEMORY) {     
                Tcl_AppendResult(interp, "output_type memory not valid for output to file", NULL);
                return TCL_ERROR;
            }



            res = tcc_output_file(s,Tcl_GetString(objv[2]));


            if (res!=0) {
                Tcl_AppendResult(interp, "output to file failed", NULL);
                return TCL_ERROR;
            } else {
                return TCL_OK;
            }
        case TCLTCC_UNDEFINE:
            if (objc != 3) {
                Tcl_WrongNumArgs(interp, 2, objv, "symbol");
                return TCL_ERROR;
            }
            tcc_undefine_symbol(s,Tcl_GetString(objv[2]));
            return TCL_OK;
        default:
            Tcl_Panic("internal error during option lookup");
    }
    return TCL_OK;
} 

static int Tcc4tclCreateCmd( ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]){
	struct TclTCCState *ts;
	TCCState *s;
    	int index;
	static CONST char *types[] = {
		"memory", "exe", "dll", "obj", "preprocess",    (char *) NULL
	};

	if (objc < 3 || objc > 4) {
		Tcl_WrongNumArgs(interp, 1, objv, "tcc_libary_path ?output_type? handle");
		return TCL_ERROR;
	}

	if (objc == 3) {
		index = TCC_OUTPUT_MEMORY;
	} else {
		if (Tcl_GetIndexFromObj(interp, objv[2], types, "type", 0, &index) != TCL_OK) {

			return TCL_ERROR;
		}
	}

	s = tcc_new(Tcl_GetString(objv[1]));
	if (s == NULL) {
		return(TCL_ERROR);
	}


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

	ts = (void *) ckalloc(sizeof(*ts));
	ts->s = s;
    	ts->relocated = 0;

	/*printf("type: %d\n", index); */
	tcc_set_output_type(s,index);
	Tcl_CreateObjCommand(interp,Tcl_GetString(objv[objc-1]),Tcc4tclHandleCmd,ts,Tcc4tclCCommandDeleteProc);

	return TCL_OK;
}

int Tcc4tcl_Init(Tcl_Interp *interp) {

#ifdef USE_TCL_STUBS
	if (Tcl_InitStubs(interp, "8.4" , 0) == 0L) {
		return TCL_ERROR;
	}


#endif

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

	return TCL_OK;
}

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

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

   set dir [file dirname [info script]]
   if {[info command ::tcc4tcl] == ""} {
      catch { load {} tcc4tcl }
   }
   if {[info command ::tcc4tcl] == ""} {

       load [file join $dir tcc4tcl[info sharedlibextension]] tcc4tcl



   }
   set libs $dir/lib
   set includes $dir/include
   set count 0
   set command_count 0
   array set commands {}
   proc new {} {
       variable dir
       variable count
       set handle tcc_[incr count]
       tcc4tcl $dir $handle
       return tcc_$count
   }
   proc tclcommand {handle name ccode} {
       variable commands
       variable command_count
       set cname _tcc_tcl_command_[incr command_count]
       set code    {#include "tcl.h"}

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


  }
  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

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

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

  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}