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.c
/*
* RPN Extension
*
* Copyright 2006 George Peter Staplin
*
* Version 1 - July 25, 2006
*/
#include <tcl.h>
#define TCL_OBJ_CMD_ARGS ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]
/*
* 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)
/*
* C doesn't have polymorphism, but we can fake it with templates.
* This macro is used to generate at least 3 functions.
*/
#define TEMPLATE(FUNC,ARGS,STACKTYPE,GET,NEWOBJ) \
static int FUNC ( ARGS ) { \
STACKTYPE stack[objc], *sptr, *stackupperlimit; \
int i; \
if (objc <= 1) { \
Tcl_WrongNumArgs (interp, 1, objv, #FUNC " takes at least 1 argument"); \
return TCL_ERROR; \
} \
\
stackupperlimit = sptr = stack + objc; \
\
for (i = 1; i < objc; ++i) { \
--sptr; \
if (TCL_OK != GET (interp, objv[i], sptr)) { \
int slen; \
char *op = Tcl_GetStringFromObj (objv[i], &slen); \
++sptr; \
\
if (1 != slen) { \
Tcl_SetResult (interp, "invalid operator. ", TCL_STATIC); \
Tcl_AppendResult (interp, " more info: ", op, "\n", NULL); \
return TCL_ERROR; \
} \
\
switch (op[0]) { \ 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; \
\ Tcl_SetResult (interp, "invalid operator. ", TCL_STATIC); \
Tcl_AppendResult (interp, " more info: ", op, "\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);
TEMPLATE (rpnfloat_cmd, TCL_OBJ_CMD_ARGS, double, Tcl_GetDoubleFromObj,
Tcl_NewDoubleObj);
TEMPLATE (rpn_cmd, TCL_OBJ_CMD_ARGS, long, Tcl_GetLongFromObj, Tcl_NewLongObj);
int Rpn_Init (Tcl_Interp *interp) {
if (NULL == Tcl_InitStubs (interp, TCL_VERSION, 0))
return TCL_ERROR;
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;
}