/*
* 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,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case TCLTCC_ADD_INCLUDE:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "path");
return TCL_ERROR;
} else {
tcc_add_include_path(s, Tcl_GetString(objv[2]));
return TCL_OK;
}
case TCLTCC_ADD_FILE:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "filename");
return TCL_ERROR;
} else {
if(tcc_add_file(s, Tcl_GetString(objv[2]))!=0) {
return TCL_ERROR;
} else {
return TCL_OK;
}
}
case TCLTCC_ADD_LIBRARY:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "lib");
return TCL_ERROR;
} else {
tcc_add_library(s, Tcl_GetString(objv[2]));
return TCL_OK;
}
case TCLTCC_ADD_LIBRARY_PATH:
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 {
int i;
Tcl_GetString(objv[2]);
i = tcc_compile_string(s,Tcl_GetString(objv[2]));
if (i!=0) {
Tcl_AppendResult(interp,"compilation failed",NULL);
return TCL_ERROR;
} else {
return TCL_OK;
}
}
case TCLTCC_DEFINE:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "symbol value");
return TCL_ERROR;
}
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);
}
#ifdef USE_TCL_STUBS
tcc_add_symbol(s, "tclStubsPtr", &tclStubsPtr);
tcc_define_symbol(s, "USE_TCL_STUBS", "1");
#endif
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;
}
Documentation