summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2003-09-12 23:55:32 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2003-09-12 23:55:32 (GMT)
commitda60f636030ff5e28efdfe34eb534c9dd46e2fb3 (patch)
tree2f2c7e65505a410bb72e9cc37de0a6baab73939f /generic
parent15cd6e14858186b0fc6748418f0c92ee5c1495ab (diff)
downloadtcl-da60f636030ff5e28efdfe34eb534c9dd46e2fb3.zip
tcl-da60f636030ff5e28efdfe34eb534c9dd46e2fb3.tar.gz
tcl-da60f636030ff5e28efdfe34eb534c9dd46e2fb3.tar.bz2
TIP#123 Implementation based on work by Arjen Markus. [Patch 655176]
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCompExpr.c4
-rw-r--r--generic/tclCompile.c4
-rw-r--r--generic/tclCompile.h4
-rw-r--r--generic/tclExecute.c211
-rw-r--r--generic/tclParseExpr.c90
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 '/':