From: gah@grenache (George A. Howlett)
Subject: Tcl 6.3 "expr" patch to add "OFMT" variable 
Reply-To: george.howlett@att.com
Organization: AT&T Bell Laboratories
Date: Thu, 23 Jul 1992 16:26:59 GMT
X-Newsreader: Tin 1.1 PL4

This patch adds a global Tcl variable "OFMT" which controls the
conversion format of floating point values from the "expr" command.
The default value is "%g" (what is currently in tclExpr.c).  This
means that existing code should perform as expected.  New values for
"OFMT" must be valid format strings to convert floating point values.
There can be no auxiliary width or precision arguments (using "*").
There can be no extra characters.  If "OFMT" is unset, the value of
"OFMT" reverts back to the default.

This patch is baselined on the distributed verion of tclExpr.c and
tclBasic.c in Tcl 6.3.  Mail comments or bug reports back to
"george.howlett@att.com".

--gah 

*** tclBasic.c-dist	Mon Feb 10 12:29:43 1992
--- tclBasic.c	Mon Jun 22 15:18:34 1992
***************
*** 130,135 ****
--- 130,136 ----
  Tcl_Interp *
  Tcl_CreateInterp()
  {
+     extern Tcl_VarTraceProc OutputFormatProc;
      register Interp *iPtr;
      register Command *cmdPtr;
      register CmdInfo *cmdInfoPtr;
***************
*** 193,199 ****
  #ifndef TCL_GENERIC_ONLY
      TclSetupEnv((Tcl_Interp *) iPtr);
  #endif
! 
      return (Tcl_Interp *) iPtr;
  }
  
--- 194,202 ----
  #ifndef TCL_GENERIC_ONLY
      TclSetupEnv((Tcl_Interp *) iPtr);
  #endif
!     Tcl_TraceVar2 ((Tcl_Interp *) iPtr, "OFMT", (char *)NULL, 
! 		   (TCL_TRACE_WRITES | TCL_TRACE_UNSETS), OutputFormatProc, 
! 		   (ClientData) NULL);
      return (Tcl_Interp *) iPtr;
  }
  
*** tclExpr.c-dist	Mon Mar 23 12:54:06 1992
--- tclExpr.c	Thu Jul 23 12:07:53 1992
***************
*** 157,162 ****
--- 157,176 ----
      "-", "!", "~"
  };
  
+ 
+ /* Default format conversion string */
+ static char defFmt[] = "%g";
+ 
+ /* 
+  * Floating point output format conversion string.
+  *
+  * This probably should be part of the interpreter itself (as a
+  * Tcl or C variable), so that multiple interpreters can have 
+  * multiple formats. 
+  *
+  */
+ static char *OFMT = defFmt;
+ 
  /*
   * Declarations for local procedures to this file:
   */
***************
*** 1124,1130 ****
      if (valuePtr->type == TYPE_INT) {
  	sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue);
      } else if (valuePtr->type == TYPE_DOUBLE) {
! 	sprintf(valuePtr->pv.buffer, "%g", valuePtr->doubleValue);
      }
      valuePtr->type = TYPE_STRING;
  }
--- 1138,1144 ----
      if (valuePtr->type == TYPE_INT) {
  	sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue);
      } else if (valuePtr->type == TYPE_DOUBLE) {
! 	sprintf(valuePtr->pv.buffer, OFMT, valuePtr->doubleValue);
      }
      valuePtr->type = TYPE_STRING;
  }
***************
*** 1318,1324 ****
  	if (value.type == TYPE_INT) {
  	    sprintf(interp->result, "%ld", value.intValue);
  	} else if (value.type == TYPE_DOUBLE) {
! 	    sprintf(interp->result, "%g", value.doubleValue);
  	} else {
  	    if (value.pv.buffer != value.staticSpace) {
  		interp->result = value.pv.buffer;
--- 1332,1338 ----
  	if (value.type == TYPE_INT) {
  	    sprintf(interp->result, "%ld", value.intValue);
  	} else if (value.type == TYPE_DOUBLE) {
! 	    sprintf(interp->result, OFMT, value.doubleValue);
  	} else {
  	    if (value.pv.buffer != value.staticSpace) {
  		interp->result = value.pv.buffer;
***************
*** 1334,1336 ****
--- 1348,1519 ----
      }
      return result;
  }
+ 
+ 
+ /*
+  *----------------------------------------------------------------------
+  *
+  * VerifyFormat --
+  *
+  *      Check the format conversion string used to convert floating
+  *	point numbers.  The given format must be a valid floating
+  *	point conversion string.  There can be no other conversions
+  *	or extra characters in the description.  In addition, it cannot
+  *	have extra width or precision integer arguments (using '*').
+  *
+  * Results:
+  *      A standard Tcl result.
+  *
+  * Side effects:
+  *      See the user documentation.
+  *
+  *----------------------------------------------------------------------
+  */
+ static int
+ VerifyFormat(interp, newFormat)
+     Tcl_Interp *interp;	     /* Interpreter to report errors to */
+     char *newFormat;	     /* New conversion format to be tested */
+ {
+     register char *format;
+ 
+     format = newFormat;
+ 
+     if ((*format != '%') || (format[1] == '%')) {
+         interp->result = "format string can't specify non-numeric format";
+ 	return TCL_ERROR;
+     }
+     format++;
+ 
+     /* Zero or more flags, which modify the conversion. */
+     while ((*format == '-') || (*format == '#') || (*format == '+')
+ 	   || (*format == ' ')) {
+           format++;
+     }
+ 
+     /* Optional decimal digit string specifying field width... */
+     if (*format == '0') {
+         format++;
+     }
+     if (*format == '*') {
+         interp->result = 
+ 	  "format string can't specify integer (*) width argument";
+ 	return TCL_ERROR;
+     }
+     while (isdigit(*format)) {
+         format++;
+     }
+ 
+     /* A precision that give the minimum numnber of digits to appear... */
+     if (*format == '.') {
+         format++;
+     }
+     if (*format == '*') {
+         interp->result =
+ 	  "format string can't specify integer (*) precision argument";
+ 	return TCL_ERROR;	/* Can't allow '*' in precision */
+     }
+     while (isdigit(*format)) {
+         format++;
+     }
+     if (*format == 'l') {/* Ansi long specifier */
+         format++;
+     }
+     switch (*format) {
+     case 'D':
+     case 'O':
+     case 'U':
+     case 'd':
+     case 'o':
+     case 'u':
+     case 'x':
+     case 'X':
+     case 's':
+     case 'c':
+         interp->result = 
+ 	  "format string must specify floating point conversion";
+ 	return TCL_ERROR;
+     case 'e':
+     case 'E':
+     case 'f':
+     case 'g':
+     case 'G':
+ 	break;
+     case 0:
+ 	interp->result = "format string ended in middle of field specifier";
+ 	return TCL_ERROR;
+     default:
+ 	interp->result = "bad field specifier";
+ 	return TCL_ERROR;
+     }
+     format++;
+     if (*format != '\0') {
+ 	interp->result = "found extra characters in format string";
+ 	return TCL_ERROR;
+     }
+     return TCL_OK;
+ }
+ 
+ /*
+  *----------------------------------------------------------------------
+  *
+  * OutputFormatProc --
+  *
+  *      This procedure is invoked when the global Tcl variable "OFMT"
+  *	is written to or unset.  It sets the format conversion string
+  *	which is used in tclExpr.c. The default format is "%g".
+  *
+  * Results:
+  *      NULL is a valid output format string was given.
+  *
+  * Side effects:
+  *      See the user documentation.
+  *
+  *----------------------------------------------------------------------
+  */
+ 
+ /*ARGSUSED*/
+ char *
+ OutputFormatProc(clientData, interp, name1, name2, flags)
+     ClientData clientData;   /* not used */
+     Tcl_Interp *interp;
+     char *name1;
+     char *name2;	     /* not used */
+     int flags;
+ {
+     if (flags & TCL_TRACE_UNSETS) {
+ 	if (OFMT != defFmt)
+ 	    free (OFMT);
+         OFMT = defFmt;
+ 	if (flags & TCL_TRACE_DESTROYED) { 	/* Restore the trace */
+ 	    Tcl_TraceVar2 (interp, name1, name2, 
+ 			   (TCL_TRACE_WRITES | TCL_TRACE_UNSETS), 
+ 			   OutputFormatProc, (ClientData) NULL);
+ 	}
+     } else if (flags & TCL_TRACE_WRITES) {
+         char *newFmt;
+ 	char *fmt;
+ 	
+ 	newFmt = Tcl_GetVar2(interp, name1, name2,
+ 			    flags & (TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY));
+ 	if (newFmt == NULL) {
+ 	    return (interp->result);
+ 	}
+ 	/* Test the conversion format string */
+ 	if (VerifyFormat(interp, newFmt) != TCL_OK) {
+ 	    /* Restore variable to the previous valid value */
+ 	    Tcl_SetVar2 (interp, name1, name2, OFMT, flags & TCL_GLOBAL_ONLY);
+ 	    return (interp->result);
+ 	}
+ 	fmt = (char *)malloc(strlen(newFmt) + 1);
+ 	if (fmt == NULL) {
+ 	    return "Can't allocate format string";
+ 	}
+ 	strcpy(fmt, newFmt);
+ 	if (OFMT != defFmt)
+ 	    free (OFMT);
+ 	OFMT = fmt;
+     }
+     return (NULL);
+ }
+ 
+