[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) {								\
    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];							\
     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;
 }
 
----
[Category Mathematics]