ADDED: format/2 specifier ~h

This provides compatibility to SICStus. It also makes write/1 output for
floats compatible to SICStus for deciding between fixed point and
exponential notation.

man/builtin.doc

@@ -9768,6 +9768,23 @@ Floating point in {\bf e} or {\bf f} notation, whichever is shorter.
     \fmtchar{G}
 Floating point in {\bf E} or {\bf f} notation, whichever is shorter.
 
+    \fmtchar{h}
+    \nodescription
+    \fmtchar{H}
+Print a floating point number with the minimal number of digits such
+that read/1 produces exactly (as in \predref{==}{2}) the same number.
+The argument specifies whether a number is written using exponential
+notation (using \textbf{e} (h) or \textbf{E} (H)) or fixed point
+notation (as \verb$~f$).  If the argument is -1, the number is always
+written using exponential notation.  Otherwise, number is written
+using exponential notation if the exponent is less than \arg{Arg}-1
+or greater than \arg{Arg}+\arg{d}, where \arg{d} is the number of
+digits emitted to establish the required precision.   Using an
+argument larger than the the maximum exponent such as \verb$~999h$
+never uses exponential notation.   The default argument is 3.  The
+predicate write/1 and friends act as if using the format \verb$~3h$.
+This option is compatible to SICStus Prolog.
+
     \fmtchar{i}
 Ignore next argument of the argument list. Produces no output.
 

src/os/pl-fmt.c

@@ -80,7 +80,7 @@ typedef struct
 } format_state;
 
 #define BUFSIZE		1024
-#define DEFAULT		(-1)
+#define DEFAULT		INT_MIN
 #define SHIFT		{ argc--; argv++; }
 #define NEED_ARG	{ if ( argc <= 0 ) \
 			  { FMT_ERROR("not enough arguments"); \
@@ -488,9 +488,17 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv, Module m)
     { case '~':
 	{ int arg = DEFAULT;		/* Numeric argument */
 	  int mod_colon = false;	/* Used colon modifier */
+	  bool neg = false;
 	  predicate_t proc;
 					/* Get the numeric argument */
 	  c = get_chr_from_text(fmt, ++here);
+	  if ( c == '-' )
+	  { neg = true;
+	    c = get_chr_from_text(fmt, ++here);
+	    if ( !isDigitW(c) )
+	    { FMT_ERROR("invalid argument");
+	    }
+	  }
 
 	  if ( isDigitW(c) )
 	  { arg = c - '0';
@@ -509,7 +517,10 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv, Module m)
 		arg = arg2;
 		here++;
 	      } else
+	      { if ( neg )
+		  arg = -arg;
 		break;
+	      }
 	    }
 	  } else if ( c == '*' )
 	  { NEED_ARG;
@@ -597,6 +608,8 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv, Module m)
 	      case 'f':			/* float */
 	      case 'g':			/* shortest of 'f' and 'e' */
 	      case 'G':			/* shortest of 'f' and 'E' */
+	      case 'h':
+	      case 'H':			/* Precise */
 		{ AR_CTX
 		  number n;
 		  union {
@@ -1358,16 +1371,21 @@ the following algorithm, courtesy of Jan Burse:
 
 static char *
 formatFloat(PL_locale *locale, int how, int arg, Number f, Buffer out)
-{ if ( arg == DEFAULT )
-  { arg = 6;
-  } else if ( arg < 0 )
+{ bool use_h = how == 'h' || how == 'H';
+
+  if ( arg == DEFAULT )
+  { arg = use_h ? 3 : 6;
+  } else if ( arg < 0 && !use_h )
   { GET_LD
     term_t a = PL_new_term_ref();
     PL_put_integer(a, arg);
     PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_zero, a);
     return NULL;
   }
 
+  if ( use_h && !promoteToFloatNumber(f) )
+    return NULL;
+
   switch(f->type)
   {
 #ifdef O_GMP
@@ -1698,26 +1716,36 @@ formatFloat(PL_locale *locale, int how, int arg, Number f, Buffer out)
   }
 #endif /* O_GMP OR O_BF */
     case V_INTEGER:
-      promoteToFloatNumber(f);
+      if ( !promoteToFloatNumber(f) )
+	return NULL;
       /*FALLTHROUGH*/
     case V_FLOAT:
     { char tmp[12];
       int written = arg+20;
       int size = 0;
 
-      Ssprintf(tmp, "%%.%d%c", arg, how);
-      while(written >= size)
-      { size = written+1;
-
-	if ( !growBuffer(out, size) )
+      if ( how == 'h' || how == 'H' )
+      { if ( !growBuffer(out, 100) )
 	{ PL_no_memory();
 	  return NULL;
 	}
-	written = snprintf(baseBuffer(out, char), size, tmp, f->value.f);
+	format_float(f->value.f, arg, how == 'H' ? 'E' : 'e', out->base);
+	written = strlen(out->base);
+      } else
+      { Ssprintf(tmp, "%%.%d%c", arg, how);
+	while(written >= size)
+	{ size = written+1;
+
+	  if ( !growBuffer(out, size) )
+	  { PL_no_memory();
+	    return NULL;
+	  }
+	  written = snprintf(baseBuffer(out, char), size, tmp, f->value.f);
 #ifdef __WINDOWS__
-	if ( written < 0 )	/* pre-C99 Windows snprintf() returns -1 */
-	  written = size*2;
+	  if ( written < 0 )	/* pre-C99 Windows snprintf() returns -1 */
+	    written = size*2;
 #endif
+	}
       }
 
 #ifdef __WINDOWS__

src/os/pl-text.c

@@ -282,7 +282,7 @@ PL_get_text(DECL_LD term_t l, PL_chars_t *text, int flags)
     text->encoding  = ENC_ISO_LATIN_1;
     text->canonical = true;
   } else if ( (flags & CVT_FLOAT) && isFloat(w) )
-  { format_float(valFloat(w), text->buf);
+  { format_float(valFloat(w), 3, 'e', text->buf);
     text->text.t    = text->buf;
     text->length    = strlen(text->text.t);
     text->encoding  = ENC_ISO_LATIN_1;

src/pl-arith.c

@@ -803,7 +803,7 @@ isCurrentArithFunction(functor_t f)
 }
 
 
-int
+bool
 check_float(Number n)
 { PL_error_code code = ERR_NO_ERROR;
 #ifdef HAVE_FPCLASSIFY

src/pl-arith.h

@@ -3,10 +3,10 @@
     Author:        Jan Wielemaker
     E-mail:        [email protected]
     WWW:           http://www.swi-prolog.org
-    Copyright (c)  2023, University of Amsterdam
-                         VU University Amsterdam
-			 CWI, Amsterdam
-			 SWI-Prolog Solutions b.v.
+    Copyright (c)  2023-2024, University of Amsterdam
+                              VU University Amsterdam
+			      CWI, Amsterdam
+			      SWI-Prolog Solutions b.v.
     All rights reserved.
 
     Redistribution and use in source and binary forms, with or without
@@ -82,7 +82,7 @@ Number		growArithStack(void);
 void		freeArithLocalData(PL_local_data_t *ld);
 int		ar_sign_i(Number n1);
 int		ar_signbit(Number n1);
-int		check_float(Number n);
+bool		check_float(Number n);
 int		ar_rdiv_mpz(Number n1, Number n2, Number r);
 int		PL_eval_expression_to_int64_ex(term_t t, int64_t *val);
 int		is_arith_flag(atom_t k);

src/pl-debug.c

@@ -238,6 +238,8 @@ const debug_topic debug_topics[] =
 
   DEBUG_TOPIC(MSG_READ_OP),
 
+  DEBUG_TOPIC(MSG_WRITE_FLOAT),
+
   DEBUG_TOPIC(CHK_SECURE),
   DEBUG_TOPIC(CHK_HIGH_ARITY),
   DEBUG_TOPIC(CHK_HIGHER_ADDRESS),

src/pl-debug.h

@@ -238,6 +238,8 @@
 
 #define MSG_READ_OP		 362
 
+#define MSG_WRITE_FLOAT		 370
+
 #define CHK_SECURE              1000
 #define CHK_HIGH_ARITY          1001
 #define CHK_HIGHER_ADDRESS      1002

src/pl-write.c

@@ -1037,7 +1037,7 @@ NaN_value(double f)
 
 static char *
 writeNaN(double f, char *buf)
-{ format_float(NaN_value(f), buf);
+{ format_float(NaN_value(f), 3, 'e', buf);
   strcat(buf, "NaN");
   return buf;
 }
@@ -1129,30 +1129,32 @@ format_special_float(double f, char *buf)
 
 
 char *
-format_float(double f, char *buf)
+format_float(double f, int N, char E, char *buf)
 { char *end, *o=buf, *s;
   int decpt, sign;
 
   if ( (s=format_special_float(f, buf)) )
     return s;
 
   s = dtoa(f, 0, 30, &decpt, &sign, &end);
-  DEBUG(2, Sdprintf("decpt=%d, sign=%d, len = %d, '%s'\n",
-		    decpt, sign, end-s, s));
+  DEBUG(MSG_WRITE_FLOAT,
+	Sdprintf("dtoa(): decpt=%d, sign=%d, len = %d, '%s'\n",
+		 decpt, sign, end-s, s));
 
   if ( sign )
     *o++ = '-';
 
   if ( decpt <= 0 )			/* decimal dot before */
-  { if ( decpt <= -4 )
+  { int e = decpt-1;
+    if ( N < 0 || e < -N-1 )
     { *o++ = s[0];
       *o++ = '.';
       if ( end-s > 1 )
       { memcpy(o, s+1, end-s-1);
 	o += end-s-1;
       } else
 	*o++ = '0';
-      sprintf(o, "e%d", decpt-1);
+      sprintf(o, "%c%03d", E, e);
     } else
     { int i;
 
@@ -1163,31 +1165,35 @@ format_float(double f, char *buf)
       memcpy(o, s, end-s);
       o[end-s] = 0;
     }
-  } else if ( end-s > decpt )		/* decimal dot inside */
+  } else if ( N >=0 && end-s > decpt ) /* decimal dot inside */
   { memcpy(o, s, decpt);
     o += decpt;
     *o++ = '.';
     memcpy(o, s+decpt, end-s-decpt);
     o[end-s-decpt] = 0;
   } else				/* decimal dot after */
   { int i;
-    int trailing = decpt-(int)(end-s);
-
-    if ( decpt > 15 )			/* over precision: use eE */
+    int d = (int)(end-s);
+    int trailing = decpt-d;
+    int exp = trailing+d-1;
+
+    DEBUG(MSG_WRITE_FLOAT,
+	  Sdprintf("trailing = %d; exp=%d; d=%d; N=%d\n",
+		   trailing, exp, d, N));
+    if ( N < 0 || exp >= N+d )	/* over precision: use eE */
     { *o++ = s[0];
       *o++ = '.';
-      if ( end-s > 1 )
-      { trailing += (int)(end-s)-1;
-	memcpy(o, s+1, end-s-1);
-	o += end-s-1;
+      if ( d > 1 )
+      { memcpy(o, s+1, d-1);
+	o += d-1;
       } else
 	*o++ = '0';
-      sprintf(o, "e+%d", trailing);
+      sprintf(o, "%c+%02d", E, exp);
     } else				/* within precision trail with .0 */
     { memcpy(o, s, end-s);
       o += end-s;
 
-      for(i=(int)(end-s); i<decpt; i++)
+      for(i=d; i<decpt; i++)
 	*o++ = '0';
       *o++ = '.';
       *o++ = '0';
@@ -1278,7 +1284,7 @@ WriteNumber(Number n, write_options *options)
     case V_FLOAT:
     { char buf[100];
 
-      format_float(n->value.f, buf);
+      format_float(n->value.f, 3, 'e', buf);
       return PutToken(buf, options->out);
     }
     default:

src/pl-write.h

@@ -3,9 +3,10 @@
     Author:        Jan Wielemaker
     E-mail:        [email protected]
     WWW:           http://www.swi-prolog.org
-    Copyright (c)  1985-2020, University of Amsterdam
+    Copyright (c)  1985-2024, University of Amsterdam
                               VU University Amsterdam
 			      CWI, Amsterdam
+			      SWI-Prolog Solutions b.v.
     All rights reserved.
 
     Redistribution and use in source and binary forms, with or without
@@ -68,7 +69,7 @@ int		writeAttributeMask(atom_t name);
 int		writeUCSAtom(IOSTREAM *fd, atom_t atom, int flags);
 int		writeReservedSymbol(IOSTREAM *fd, atom_t atom, int flags);
 int		writeAtomToStream(IOSTREAM *s, atom_t atom);
-char *		format_float(double f, char *buf);
+char *		format_float(double f, int N, char E, char *buf);
 int		unquoted_atom(atom_t a);
 strnumstat	make_nan(double *f);
 double		NaN_value(double f);