Updated 2011-12-21 14:55:16 by dkf

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