George Peter Staplin 07.25.2006 - Below is an RPN extension in C that supports int, wide, and double types.
Compile it using a pattern like: gcc -shared -I/usr/local/include -DUSE_TCL_STUBS rpn-5.c /usr/local/lib/libtclstub8.6.a -Wall -o rpn.so -O
Then just load ./rpn.so to use the extension commands.
The backup code is here: http://www.xmission.com/~georgeps/implementation/software/tcl/rpn-5.c
Example usage:
% load ./rpn.so % rpnwide 1 2 + 3 * 9 % rpnfloat 1.0 3.0 * 9.0 - -6.0 % rpn 3 3 / 1
/*
* RPN C Extension
*
* Copyright 2006, 2008 George Peter Staplin
*
* Version 5 - Sep 1, 2008 (updated to fix a memory leak and use Tcl_ObjPrintf)
* Version 4 - Aug 21, 2006 (released to the world)
* Version 3 - July 25, 2006 (specialization and better algorithms)
* Version 2 - July 25, 2006 (much faster from custom Tcl_ObjType types)
* Version 1 - July 25, 2006
*
*
* gcc -O -shared -I/usr/local/include -DUSE_TCL_STUBS rpn-5.c \
/usr/local/lib/libtclstub8.6.a -Wall -o rpn.so
*
* gcc -O -Wall -finline-functions -Winline -DUSE_TCL_STUBS -std=c99 rpn-3.c \
-I/gps/runtime8.4/include -L/gps/runtime8.4/lib -ltclstub84 -shared -o rpn.so
*
* when optimising:
gcc -O -Wall -finline-functions -Winline -DUSE_TCL_STUBS -std=c99 rpn-3.c \
-I/gps/runtime8.4/include -S -fverbose-asm
*/
#include <assert.h>
#include <tcl.h>
#define OBJ_CMD_ARGS ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]
static const Tcl_ObjType *rpnwidetype = NULL;
static const Tcl_ObjType *rpnfloattype = NULL;
static const Tcl_ObjType *rpnlongtype = NULL;
static Tcl_ObjType rpnoptype = {
"rpnop",
NULL,
NULL,
NULL,
NULL
};
/*
* The stack grows downwards from stackupperlimit.
*/
#define OP2_STACK_CHECK(op) do { \
if((sptr + 1) >= stackupperlimit) { \
Tcl_SetResult(interp, \
"stack underflow with " op " operator", TCL_STATIC); \
return TCL_ERROR; \
} \
} while(0)
inline static int
get_op_from_obj(Tcl_Interp *interp, Tcl_Obj *obj, int *op) {
int slen;
char *s;
if(&rpnoptype == obj->typePtr) {
*op = obj->bytes[0];
return TCL_OK;
}
s = Tcl_GetStringFromObj(obj, &slen);
if(1 != slen) {
Tcl_Obj *err = Tcl_ObjPrintf("invalid operator: %s", obj);
Tcl_SetObjResult(interp, err);
return TCL_ERROR;
}
if(NULL != obj->typePtr && NULL != obj->typePtr->freeIntRepProc) {
obj->typePtr->freeIntRepProc(obj);
}
obj->typePtr = &rpnoptype;
*op = obj->bytes[0];
return TCL_OK;
}
/*
* This macro is used to generate at least 3 functions for handling
* different types.
*/
#define TEMPLATE(FUNC,ARGS,STACKTYPE,GET,NEWOBJ,OBJTYPE) \
static int FUNC ( ARGS ) { \
STACKTYPE stack[objc], *sptr, *stackupperlimit, value; \
int i; \
int op; \
\
if(objc <= 1) { \
Tcl_WrongNumArgs(interp, 1, objv, "n ?n? ?op? ..."); \
return TCL_ERROR; \
} \
\
stackupperlimit = sptr = stack + objc; \
\
for(i = 1; i < objc; ++i) { \
Tcl_Obj *obj = objv[i]; \
if(TCL_OK == GET(NULL, obj, &value)) { \
--sptr; *sptr = value; \
continue; \
} \
\
if(TCL_OK != get_op_from_obj(interp, obj, &op)) { \
return TCL_ERROR; \
} \
\
switch(op) { \
case '+': \
OP2_STACK_CHECK("+"); \
*(sptr + 1) += *sptr; \
++sptr; \
break; \
\
case '-': \
OP2_STACK_CHECK("-"); \
*(sptr + 1) -= *sptr; \
++sptr; \
break; \
\
case '*': \
OP2_STACK_CHECK("*"); \
*(sptr + 1) *= *sptr; \
++sptr; \
break; \
\
case '/': \
OP2_STACK_CHECK("/"); \
*(sptr + 1) /= *sptr; \
++sptr; \
break; \
\
default: { \
char opstr[2]; \
Tcl_Obj *err; \
opstr[0] = op; \
opstr[1] = '\0'; \
\
err = Tcl_ObjPrintf("invalid operator: %s", opstr); \
Tcl_SetObjResult(interp, err); \
return TCL_ERROR; \
} \
break; \
} \
} \
\
if((stackupperlimit - 1) != sptr) { \
Tcl_SetResult(interp, \
"more than 1 value remains on the operand stack", \
TCL_STATIC); \
return TCL_ERROR; \
} \
Tcl_SetObjResult(interp, NEWOBJ (*sptr)); \
\
return TCL_OK; \
}
TEMPLATE(rpnwide_cmd, OBJ_CMD_ARGS, Tcl_WideInt, Tcl_GetWideIntFromObj,
Tcl_NewWideIntObj, rpnwidetype);
TEMPLATE(rpnfloat_cmd, OBJ_CMD_ARGS, double, Tcl_GetDoubleFromObj,
Tcl_NewDoubleObj, rpnfloattype);
TEMPLATE(rpn_cmd, OBJ_CMD_ARGS, long, Tcl_GetLongFromObj,
Tcl_NewLongObj, rpnlongtype);
int Rpn_Init (Tcl_Interp *interp) {
Tcl_Obj *tmp;
if (NULL == Tcl_InitStubs (interp, TCL_VERSION, 0))
return TCL_ERROR;
tmp = Tcl_NewWideIntObj (1);
rpnwidetype = tmp->typePtr;
Tcl_DecrRefCount (tmp);
tmp = Tcl_NewDoubleObj (1.0);
rpnfloattype = tmp->typePtr;
Tcl_DecrRefCount (tmp);
tmp = Tcl_NewLongObj (1);
rpnlongtype = tmp->typePtr;
Tcl_DecrRefCount (tmp);
Tcl_CreateObjCommand (interp, "rpnwide", rpnwide_cmd,
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand (interp, "rpnfloat", rpnfloat_cmd,
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand (interp, "rpn", rpn_cmd,
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 8
* fill-column: 78
* End:
*/