TIP#123 Implementation based on work by Arjen Markus. [Patch 655176]

5 files changed, 292 insertions, 21 deletions

diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 480acfe..d4fecc0 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompExpr.c,v 1.14 2003/03/13 02:48:52 dgp Exp $
+ * RCS: @(#) $Id: tclCompExpr.c,v 1.15 2003/09/12 23:55:32 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -92,6 +92,7 @@ typedef struct ExprInfo {
 #define OP_BITNOT	20
 #define OP_STREQ	21
 #define OP_STRNEQ	22
+#define OP_EXPON	23
 
 /*
  * Table describing the expression operators. Entries in this table must
@@ -134,6 +135,7 @@ static OperatorDesc operatorTable[] = {
     {"~",   1,  INST_BITNOT},
     {"eq",  2,  INST_STR_EQ},
     {"ne",  2,  INST_STR_NEQ},
+    {"**",  2,	INST_EXPON},
     {NULL}
 };
 
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index e76048b..10845d3 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompile.c,v 1.49 2003/05/09 13:53:42 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.50 2003/09/12 23:55:32 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -271,6 +271,8 @@ InstructionDesc tclInstructionTable[] = {
 	 */
     {"return",		  1,   -1,          0,   {OPERAND_NONE}},
 	/* return TCL_RETURN code. */
+    {"expon",		  1,   -1,	    0,	 {OPERAND_NONE}},
+	/* Binary exponentiation operator: push (stknext ** stktop) */
     {0}
 };
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 993bfd4..3233fd3 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompile.h,v 1.36 2003/03/19 16:51:42 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.37 2003/09/12 23:55:32 dkf Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -524,6 +524,8 @@ typedef struct ByteCode {
 
 #define INST_RETURN			98
 
+#define INST_EXPON			99 /* TIP#123 - exponentiation */
+
 /* The last opcode */
 #define LAST_INST_OPCODE        	98
 
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index fcf2dae..316d831 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclExecute.c,v 1.105 2003/08/05 15:59:15 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.106 2003/09/12 23:55:32 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -87,13 +87,16 @@ int tclTraceExec = 0;
  * Mapping from expression instruction opcodes to strings; used for error
  * messages. Note that these entries must match the order and number of the
  * expression opcodes (e.g., INST_LOR) in tclCompile.h.
+ *
+ * Does not include the string for INST_EXPON (and beyond), as that is
+ * disjoint for backward-compatability reasons
  */
 
-static char *operatorStrings[] = {
+static CONST char *operatorStrings[] = {
     "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
     "+", "-", "*", "/", "%", "+", "-", "~", "!",
     "BUILTIN FUNCTION", "FUNCTION",
-    "", "", "", "", "", "", "", "", "eq", "ne",
+    "", "", "", "", "", "", "", "", "eq", "ne"
 };
 
 /*
@@ -378,6 +381,10 @@ static void		ValidatePcAndStackTop _ANSI_ARGS_((
 #endif /* TCL_COMPILE_DEBUG */
 static int		VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
 			    Tcl_Obj *objPtr));
+static Tcl_WideInt	ExponWide _ANSI_ARGS_((Tcl_WideInt w, Tcl_WideInt w2,
+			    int *errExpon));
+static long		ExponLong _ANSI_ARGS_((long i, long i2,
+			    int *errExpon));
 
 /*
  * Table describing the built-in math functions. Entries in this table are
@@ -3159,6 +3166,7 @@ TclExecuteByteCode(interp, codePtr)
     case INST_SUB:
     case INST_MULT:
     case INST_DIV:
+    case INST_EXPON:
     {
 	/*
 	 * Operands must be numeric and ints get converted to floats
@@ -3275,6 +3283,13 @@ TclExecuteByteCode(interp, codePtr)
 		    }
 		    dResult = d1 / d2;
 		    break;
+		case INST_EXPON:
+		    if (d1==0.0 && d2<0.0) {
+			TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2));
+			goto exponOfZero;
+		    }
+		    dResult = pow(d1, d2);
+		    break;
 	    }
 		    
 	    /*
@@ -3331,11 +3346,21 @@ TclExecuteByteCode(interp, codePtr)
 		    }
 		    wResult = wquot;
 		    break;
+		case INST_EXPON: {
+		    int errExpon;
+
+		    wResult = ExponWide(w, w2, &errExpon);
+		    if (errExpon) {
+			TRACE((LLD" "LLD" => EXPONENT OF ZERO\n", w, w2));
+			goto exponOfZero;
+		    }
+		    break;
+		}
 	    }
 	} else {
 	    /*
-		     * Do integer arithmetic.
-		     */
+	     * Do integer arithmetic.
+	     */
 	    switch (*pc) {
 	        case INST_ADD:
 		    iResult = i + i2;
@@ -3368,6 +3393,16 @@ TclExecuteByteCode(interp, codePtr)
 		    }
 		    iResult = quot;
 		    break;
+		case INST_EXPON: {
+		    int errExpon;
+
+		    iResult = ExponLong(i, i2, &errExpon);
+		    if (errExpon) {
+			TRACE(("%ld %ld => EXPONENT OF ZERO\n", i, i2));
+			goto exponOfZero;
+		    }
+		    break;
+		}
 	    }
 	}
 
@@ -4044,7 +4079,21 @@ TclExecuteByteCode(interp, codePtr)
             (char *) NULL);
     result = TCL_ERROR;
     goto checkForCatch;
-	
+
+    /*
+     * Exponentiation of zero by negative number in an expression.
+     * Control only reaches this point by "goto exponOfZero".
+     */
+
+ exponOfZero:
+    Tcl_ResetResult(interp);
+    Tcl_AppendToObj(Tcl_GetObjResult(interp),
+	    "exponentiation of zero by negative power", -1);
+    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
+	    "exponentiation of zero by negative power", (char *) NULL);
+    result = TCL_ERROR;
+    goto checkForCatch;
+
     /*
      * An external evaluation (INST_INVOKE or INST_EVAL) returned 
      * something different from TCL_OK, or else INST_BREAK or 
@@ -4381,12 +4430,16 @@ IllegalExprOperandType(interp, pc, opndPtr)
 				 * with the illegal type. */
 {
     unsigned char opCode = *pc;
-    
+    CONST char *operator = operatorStrings[opCode - INST_LOR];
+    if (opCode == INST_EXPON) {
+	operator = "**";
+    }
+
     Tcl_ResetResult(interp);
     if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
 	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
-		"can't use empty string as operand of \"",
-		operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
+		"can't use empty string as operand of \"", operator, "\"",
+		(char *) NULL);
     } else {
 	char *msg = "non-numeric string";
 	char *s, *p;
@@ -4485,8 +4538,7 @@ IllegalExprOperandType(interp, pc, opndPtr)
 	}
       makeErrorMessage:
 	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
-		msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
-		"\"", (char *) NULL);
+		msg, " as operand of \"", operator, "\"", (char *) NULL);
     }
 }
 
@@ -6180,3 +6232,140 @@ StringForResultCode(result)
     return buf;
 }
 #endif /* TCL_COMPILE_DEBUG */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ExponWide --
+ *
+ *	Procedure to return w**w2 as wide integer
+ *
+ * Results:
+ *	Return value is w to the power w2, unless the computation
+ *	makes no sense mathematically. In that case *errExpon is
+ *	set to 1.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_WideInt
+ExponWide(w, w2, errExpon)
+    Tcl_WideInt w;		/* The value that must be exponentiated */
+    Tcl_WideInt w2;		/* The exponent */
+    int *errExpon;		/* Error code */
+{
+    Tcl_WideInt result;
+
+    *errExpon = 0;
+
+    /*
+     * Check for possible errors and simple/edge cases
+     */
+
+    if (w == 0) {
+	if (w2 < 0) {
+	    *errExpon = 1;
+	    return W0;
+	} else if (w2 > 0) {
+	    return W0;
+	}
+	return Tcl_LongAsWide(1); /* By definition and analysis */
+    } else if (w < -1) {
+	if (w2 < 0) {
+	    return W0;
+	} else if (w2 == 0) {
+	    return Tcl_LongAsWide(1);
+	}
+    } else if (w == -1) {
+	return (w2 & 1) ? Tcl_LongAsWide(-1) :  Tcl_LongAsWide(1);
+    } else if (w == 1) {
+	return Tcl_LongAsWide(1);
+    } else if (w>1 && w2<0) {
+	return W0;
+    }
+
+    /*
+     * The general case.  
+     */
+
+    result = Tcl_LongAsWide(1);
+    for (; w2>Tcl_LongAsWide(1) ; w*=w,w2/=2) {
+	if (w2 & 1) {
+	    result *= w;
+	}
+    }
+    return result * w;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ExponLong --
+ *
+ *      Procedure to return i**i2 as long integer
+ *
+ * Results:
+ *      Return value is i to the power i2, unless the computation
+ *      makes no sense mathematically. In that case *errExpon is
+ *      set to 1.
+ *
+ * Side effects:
+ *      None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static long
+ExponLong(i, i2, errExpon)
+    long i;			/* The value that must be exponentiated */
+    long i2;			/* The exponent */
+    int *errExpon;		/* Error code */
+{
+    long result;
+
+    *errExpon = 0;
+
+    /*
+     * Check for possible errors and simple cases
+     */
+
+    if (i == 0) {
+        if (i2 < 0) {
+            *errExpon = 1;
+            return 0L;
+        } else if (i2 > 0) {
+            return 0L;
+        }
+	/*
+	 * By definition and analysis, 0**0 is 1.
+	 */
+	return 1L;
+    } else if (i < -1) {
+        if (i2 < 0) {
+            return 0L;
+        } else if (i2 == 0) {
+	    return 1L;
+        }
+    } else if (i == -1) {
+        return (i2&1) ? -1L : 1L;
+    } else if (i == 1) {
+        return 1L;
+    } else if (i > 1 && i2 < 0) {
+        return 0L;
+    }
+
+    /*
+     * The general case
+     */
+
+    result = 1;
+    for (; i2>1 ; i*=i,i2/=2) {
+	if (i2 & 1) {
+	    result *= i;
+	}
+    }
+    return result * i;
+}
diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c
index bb88159..a0c0316 100644
--- a/generic/tclParseExpr.c
+++ b/generic/tclParseExpr.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclParseExpr.c,v 1.17 2003/02/16 01:36:32 msofer Exp $
+ * RCS: @(#) $Id: tclParseExpr.c,v 1.18 2003/09/12 23:55:34 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -130,6 +130,12 @@ typedef struct ParseInfo {
 #define STRNEQ		35
 
 /*
+ * Exponentiation operator:
+ */
+
+#define EXPON		36
+
+/*
  * Mapping from lexemes to strings; used for debugging messages. These
  * entries must match the order and number of the lexeme definitions above.
  */
@@ -140,7 +146,7 @@ static char *lexemeStrings[] = {
     "*", "/", "%", "+", "-",
     "<<", ">>", "<", ">", "<=", ">=", "==", "!=",
     "&", "^", "|", "&&", "||", "?", ":",
-    "!", "~", "eq", "ne",
+    "!", "~", "eq", "ne", "**"
 };
 
 /*
@@ -164,6 +170,7 @@ static int		ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr));
 static int		ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
 static int		ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr));
 static int		ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int		ParseExponentialExpr _ANSI_ARGS_((ParseInfo *infoPtr));
 static int		ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
 static void		PrependSubExprTokens _ANSI_ARGS_((CONST char *op,
 				int opBytes, CONST char *src, int srcBytes,
@@ -976,7 +983,7 @@ ParseAddExpr(infoPtr)
  * ParseMultiplyExpr --
  *
  *	This procedure parses a Tcl multiply expression:
- *	multiplyExpr ::= unaryExpr {('*' | '/' | '%') unaryExpr}
+ *	multiplyExpr ::= exponentialExpr {('*' | '/' | '%') exponentialExpr}
  *
  * Results:
  *	The return value is TCL_OK on a successful parse and TCL_ERROR
@@ -1004,7 +1011,7 @@ ParseMultiplyExpr(infoPtr)
     srcStart = infoPtr->start;
     firstIndex = parsePtr->numTokens;
     
-    code = ParseUnaryExpr(infoPtr);
+    code = ParseExponentialExpr(infoPtr);
     if (code != TCL_OK) {
 	return code;
     }
@@ -1016,7 +1023,7 @@ ParseMultiplyExpr(infoPtr)
 	if (code != TCL_OK) {
 	    return code;
 	}
-	code = ParseUnaryExpr(infoPtr);
+	code = ParseExponentialExpr(infoPtr);
 	if (code != TCL_OK) {
 	    return code;
 	}
@@ -1035,6 +1042,69 @@ ParseMultiplyExpr(infoPtr)
 /*
  *----------------------------------------------------------------------
  *
+ * ParseExponentialExpr --
+ *
+ *	This procedure parses a Tcl exponential expression:
+ *	exponentialExpr ::= unaryExpr {'**' unaryExpr}
+ *
+ * Results:
+ *	The return value is TCL_OK on a successful parse and TCL_ERROR
+ *	on failure. If TCL_ERROR is returned, then the interpreter's result
+ *	contains an error message.
+ *
+ * Side effects:
+ *	If there is insufficient space in parsePtr to hold all the
+ *	information about the subexpression, then additional space is
+ *	malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseExponentialExpr(infoPtr)
+    ParseInfo *infoPtr;			/* Holds the parse state for the
+					 * expression being parsed. */
+{
+    Tcl_Parse *parsePtr = infoPtr->parsePtr;
+    int firstIndex, lexeme, code;
+    CONST char *srcStart, *operator;
+
+    HERE("exponentiateExpr", 12);
+    srcStart = infoPtr->start;
+    firstIndex = parsePtr->numTokens;
+
+    code = ParseUnaryExpr(infoPtr);
+    if (code != TCL_OK) {
+	return code;
+    }
+
+    lexeme = infoPtr->lexeme;
+    while (lexeme == EXPON) {
+	operator = infoPtr->start;
+	code = GetLexeme(infoPtr);	/* skip over ** */
+	if (code != TCL_OK) {
+	    return code;
+	}
+	code = ParseUnaryExpr(infoPtr);
+	if (code != TCL_OK) {
+	    return code;
+	}
+
+	/*
+	 * Generate tokens for the subexpression and ** operator.
+	 */
+
+	PrependSubExprTokens(operator, 2, srcStart,
+		(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+	lexeme = infoPtr->lexeme;
+    }
+    return TCL_OK;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
  * ParseUnaryExpr --
  *
  *	This procedure parses a Tcl unary expression:
@@ -1062,7 +1132,7 @@ ParseUnaryExpr(infoPtr)
     int firstIndex, lexeme, code;
     CONST char *srcStart, *operator;
 
-    HERE("unaryExpr", 12);
+    HERE("unaryExpr", 13);
     srcStart = infoPtr->start;
     firstIndex = parsePtr->numTokens;
     
@@ -1132,7 +1202,7 @@ ParsePrimaryExpr(infoPtr)
      * We simply recurse on parenthesized subexpressions.
      */
 
-    HERE("primaryExpr", 13);
+    HERE("primaryExpr", 14);
     lexeme = infoPtr->lexeme;
     if (lexeme == OPEN_PAREN) {
 	code = GetLexeme(infoPtr); /* skip over the '(' */
@@ -1681,6 +1751,12 @@ GetLexeme(infoPtr)
 
 	case '*':
 	    infoPtr->lexeme = MULT;
+	    if ((infoPtr->lastChar - src)>1  &&  src[1]=='*') {
+		infoPtr->lexeme = EXPON;
+		infoPtr->size = 2;
+		infoPtr->next = src+2;
+		parsePtr->term = infoPtr->next;
+	    }
 	    return TCL_OK;
 
 	case '/':