[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:
 */

----
[Category Mathematics]