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 -O -Wall -DUSE_TCL_STUBS -std=c99 rpn.c -I/gps/runtime8.4/include -L/gps/runtime8.4/lib -ltclstub84 -shared -o rpn.so
Then just load ./rpn.so to use the extension commands.
The backup code is here: http://www.xmission.com/~georgeps/implementation/software/tcl/rpn-4.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 George Peter Staplin
*
* Version 4 - Aug 21, 2006 (released to the world for the 2nd time)
* 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 -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 TCL_OBJ_CMD_ARGS ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]
static Tcl_ObjType *rpnwidetype = NULL;
static Tcl_ObjType *rpnfloattype = NULL;
static 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) {
if (&rpnoptype == obj->typePtr) {
*op = obj->bytes[0];
return TCL_OK;
}
int slen;
char *s = Tcl_GetStringFromObj (obj, &slen);
if (1 != slen) {
Tcl_SetResult (interp, "invalid operator: ", TCL_STATIC);
Tcl_AppendResult (interp, s, "\n", NULL);
return TCL_ERROR;
}
obj->typePtr = &rpnoptype;
*op = obj->bytes[0];
return TCL_OK;
}
/*
* C doesn't have polymorphism, but we can fake it with templates.
* 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) { \ OP2_STACK_CHECK ("+"); \
*(sptr + 1) += *sptr; \
++sptr; \
break; \
\ OP2_STACK_CHECK ("-"); \
*(sptr + 1) -= *sptr; \
++sptr; \
break; \
\ OP2_STACK_CHECK ("*"); \
*(sptr + 1) *= *sptr; \
++sptr; \
break; \
\ OP2_STACK_CHECK ("/"); \
*(sptr + 1) /= *sptr; \
++sptr; \
break; \
\ { \
char opstr[2]; \
opstr[0] = op; \
opstr[1] = '\0'; \
\
Tcl_SetResult (interp, "invalid operator. ", TCL_STATIC); \
Tcl_AppendResult (interp, " more info: ", opstr, "\n", NULL); \
return TCL_ERROR; \
} \
} \
} \
\
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, TCL_OBJ_CMD_ARGS, Tcl_WideInt, Tcl_GetWideIntFromObj,
Tcl_NewWideIntObj, rpnwidetype);
TEMPLATE (rpnfloat_cmd, TCL_OBJ_CMD_ARGS, double, Tcl_GetDoubleFromObj,
Tcl_NewDoubleObj, rpnfloattype);
TEMPLATE (rpn_cmd, TCL_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;
}