* srfi/48.scm: Implement SRFI 48.

* Makefile.am: Compile srfi/48.scm.
* LispRealFormat.java, LispFormat.java:  Support for srfi-48 version
of format being different from default.
* FixedRealFormat.java: Better handling for Complex/Quaternions.
* standard/ImportFromLibrary.java (SRFI97Map) Support srfi 48.
* formatst.scm: New tests, mainly srfi-48.

gnu/kawa/functions/ChangeLog

+2020-03-18  Per Bothner  <per@bothner.com>
+
+	* LispRealFormat.java, LispFormat.java:  Support for srfi-48 version
+	of format being different from default.
+
 2020-03-11  Per Bothner  <per@bothner.com>
 
 	* Arrays.java (shareArray): Tweak due to GeneralArray changes.

gnu/kawa/functions/LispFormat.java

@@ -17,15 +17,50 @@ public class LispFormat extends CompoundFormat
   public static final String paramFromList = "<from list>";
   public static final String paramFromCount = "<from count>";
   public static final String paramUnspecified = "<unspecified>";
+    static final int SRFI48_STYLE = 1;
 
     static final DelimitSubstitutionFormat delimitSubstitutionInstance
         = DelimitSubstitutionFormat
         .getInstance(ObjectFormat.getInstance(false));
 
-  public LispFormat(char[] format, int offset, int length)
+    public LispFormat() {
+        super(null, 0);
+    }
+
+    public LispFormat(char[] format)
+        throws ParseException {
+        this();
+        parseFormat(format, 0, format.length, 0);
+    }
+
+    public LispFormat(char[] format, int offset, int length)
+            throws ParseException {
+        this();
+        parseFormat(format, offset, length, 0);
+    }
+
+    public LispFormat(String str)
+        throws ParseException {
+        this();
+        parseFormat(str, 0);
+    }
+
+    public static LispFormat asSrfi48Format(String str)
+            throws ParseException {
+        LispFormat fmt = new LispFormat();
+        fmt.parseFormat(str, SRFI48_STYLE);
+        return fmt;
+    }
+
+    public void parseFormat(String str, int flags)
+        throws ParseException {
+        char[] arr = str.toCharArray();
+        parseFormat(arr, 0, arr.length, flags);
+    }
+
+  public void parseFormat(char[] format, int offset, int length, int flags)
     throws ParseException
   {
-    super(null, 0);
     // The index in spec of the most recent ~{, ~(, ~{ or ~[.
     int start_nesting = -1;
     int choices_seen = 0;  // Number of "~;" seen.
@@ -133,13 +168,13 @@ public class LispFormat extends CompoundFormat
 	    padChar = getParam(stack, argstart+1);
 	    int commaChar = getParam(stack, argstart+2);
 	    int commaInterval = getParam(stack, argstart+3);
-            int flags = 0;
+            int fflags = 0;
             if (seenColon)
-              flags |= IntegerFormat.SHOW_GROUPS;
+              fflags |= IntegerFormat.SHOW_GROUPS;
             if (seenAt)
-              flags |= IntegerFormat.SHOW_PLUS;
+              fflags |= IntegerFormat.SHOW_PLUS;
 	    fmt = IntegerFormat.getInstance(base, minWidth, padChar,
-                                            commaChar, commaInterval, flags);
+                                            commaChar, commaInterval, fflags);
 	    break;
 	  case 'P':
 	    fmt = LispPluralFormat.getInstance(seenColon, seenAt);
@@ -166,7 +201,11 @@ public class LispFormat extends CompoundFormat
 	      }
 	    dfmt.showPlus = seenAt;
 	    dfmt.internalPad = seenColon;
-            fmt = dfmt.resolve(null, 0);
+            if ((flags & SRFI48_STYLE) != 0) {
+                dfmt.style = '4';
+                fmt = dfmt;
+            } else
+                fmt = dfmt.resolve(null, 0);
 	    break;
 	  case 'A':  case 'S':  case 'W':
 	  case 'Y': {// SRFI-48 "yuppify" (pretty-print)
@@ -428,6 +467,12 @@ public class LispFormat extends CompoundFormat
           case 'Q':
               fmt = delimitSubstitutionInstance;
               break;
+          case 'H':
+              if ((flags & SRFI48_STYLE) != 0) {
+                  fmt = new LiteralFormat(srfi48HelpString);
+                  break;
+              }
+              /* ... fall through ... */
           default:
 	    throw new ParseException("unrecognized format specifier ~"+ch, i);
           }
@@ -464,12 +509,6 @@ public class LispFormat extends CompoundFormat
     return f;
   }
 
-  public LispFormat (String str)
-    throws ParseException
-  {
-    this(str.toCharArray());
-  }
-
   /*
   private void clearSpecs (int speci, int max)
   {
@@ -515,12 +554,6 @@ public class LispFormat extends CompoundFormat
   }
   */
 
-  public LispFormat(char[] format)
-    throws ParseException
-  {
-    this(format, 0, format.length);
-  }
-
   public static int getParam(java.util.Vector vec, int index)
   {
     if (index >= vec.size())
@@ -581,6 +614,28 @@ public class LispFormat extends CompoundFormat
 	}
     }
 
+
+static final String srfi48HelpString =
+      "(format [<port>] <format-string> [<arg>...]) -- <port> is #t, #f or an output-port\n" +
+      "OPTION  [MNEMONIC]      DESCRIPTION     -- Implementation Assumes ASCII Text Encoding\n" +
+      "~H      [Help]          output this text\n" +
+      "~A      [Any]           (display arg) for humans\n" +
+      "~S      [Slashified]    (write arg) for parsers\n" +
+      "~W      [WriteCircular] like ~s but outputs circular and recursive data structures\n" +
+      "~~      [tilde]         output a tilde\n" +
+      "~T      [Tab]           output a tab character\n" +
+      "~%      [Newline]       output a newline character\n" +
+      "~&      [Freshline]     output a newline character if the previous output was not a newline\n" +
+      "~D      [Decimal]       the arg is a number which is output in decimal radix\n" +
+      "~X      [heXadecimal]   the arg is a number which is output in hexdecimal radix\n" +
+      "~O      [Octal]         the arg is a number which is output in octal radix\n" +
+      "~B      [Binary]        the arg is a number which is output in binary radix\n" +
+      "~w,dF   [Fixed]         the arg is a string or number which has width w and d digits after the decimal\n" +
+      "~C      [Character]     charater arg is output by write-char\n" +
+      "~_      [Space]         a single space character is output\n" +
+      "~Y      [Yuppify]       the list arg is pretty-printed to the output\n" +
+      "~?      [Indirection]   recursive format: next 2 args are format-string and list of arguments\n" +
+      "~K      [Indirection]   same as ~?\n";
 }
 
 /** Add plural suffixes ("s" or "y/ies") of English words.
@@ -1312,4 +1367,5 @@ class LispTabulateFormat extends ReportFormat
       dst.append(padChar);
     return start;
   }
-}
+
+    }

gnu/kawa/functions/LispRealFormat.java

@@ -23,7 +23,7 @@ class LispRealFormat extends ReportFormat {
     /** Twice the number of args consumed; odd if any arg is PARAM_FROM_COUNT. */
     int argsUsed = -1;
 
-    /** 'L': Common Lisp style; 'P' C/Java printf-style.
+    /** 'L': Common Lisp style; 'P' C/Java printf-style; '4' SRFI-48 style.
      * Used for fine points of printing 'g' style. */
     public char style = 'L';
 
@@ -105,7 +105,7 @@ class LispRealFormat extends ReportFormat {
             efmt.exponentChar = getParam(this.arg7, 'E', args, start);
             if (this.arg7 == LispFormat.PARAM_FROM_LIST)  start++;
             efmt.general = op == 'G' || op == 'g';
-            efmt.style = this.style;
+            efmt.style = this.style == '4' ? 'L' : this.style;
             efmt.showPlus = showPlus;
             return efmt;
         }
@@ -113,12 +113,34 @@ class LispRealFormat extends ReportFormat {
 
     public int format(Object[] args, int start, Appendable dst, FieldPosition fpos)
         throws java.io.IOException {
-        StringBuffer sbuf = new StringBuffer(100);
         Format fmt = resolve(args, start);
         start += argsUsed >> 1;
-        Number value = (Number) args[start++];
-        fmt.format(value, sbuf, fpos);
-        dst.append(sbuf);
+        Object arg = args[start++];
+        boolean done = false;
+        // SRFI-48 kludges
+        if (style == '4' && fmt instanceof FixedRealFormat) {
+            FixedRealFormat ffmt = (FixedRealFormat) fmt;
+            IntNum inum;
+            if (ffmt.getMaximumFractionDigits() < 0
+                && (inum = IntNum.asIntNumOrNull(arg)) != null) {
+                arg = inum.toString();
+            }
+            if (arg instanceof CharSequence) {
+                CharSequence carg = (CharSequence) arg;
+                int clen = gnu.lists.Strings.sizeInCodePoints(carg);
+                int w = ffmt.width;
+                while (--w >= clen)
+                    dst.append(' ');
+                dst.append(carg);
+                done = true;
+            }
+        }
+        if (! done) {
+            Number value = (Number) arg;
+            StringBuffer sbuf = new StringBuffer(100);
+            fmt.format(value, sbuf, fpos);
+            dst.append(sbuf);
+        }
         return start;
     }
 }

gnu/math/ChangeLog

+2020-03-18  Per Bothner  <per@bothner.com>
+
+	* FixedRealFormat.java: Better handling for Complex/Quaternions.
+
 2016-08-31  Per Bothner  <per@bothner.com>
 
 	* IntNum.java (add): Minor optimization.  Check for zero.

gnu/math/FixedRealFormat.java

@@ -14,7 +14,7 @@ import java.text.FieldPosition;
 
 public class FixedRealFormat extends java.text.Format
 {
-  private int i, d;
+  private int i, d = -1;
   public int getMaximumFractionDigits() { return d; }
   public int getMinimumIntegerDigits() { return i; }
   public void setMaximumFractionDigits(int d) { this.d = d; }
@@ -28,7 +28,8 @@ public class FixedRealFormat extends java.text.Format
   public boolean internalPad;
   public char overflowChar;
 
-  public void format(RealNum number, StringBuffer sbuf, FieldPosition fpos)
+  private void format(RealNum number, StringBuffer sbuf,
+                      FieldPosition fpos, boolean showPlus, int width)
   {
     int decimals;
     if (number instanceof RatNum
@@ -51,24 +52,28 @@ public class FixedRealFormat extends java.text.Format
         sbuf.append(string);
         int length = string.length();
         int digits = length - decimals;
-        format(sbuf, fpos, length, digits, decimals, signLen, oldSize);
+        format(sbuf, fpos, length, digits, decimals, signLen, oldSize, width);
       }
     else
-      format(number.doubleValue(), sbuf, fpos);
+        format(number.doubleValue(), sbuf, fpos, showPlus, width);
   }
 
   public StringBuffer format(long num, StringBuffer sbuf, FieldPosition fpos)
   {
-    format(IntNum.make(num), sbuf, fpos);
+      format(IntNum.make(num), sbuf, fpos, this.showPlus, this.width);
     return sbuf;
   }
 
-  public StringBuffer format(double num, StringBuffer sbuf, FieldPosition fpos)
+    public StringBuffer format(double num, StringBuffer sbuf, FieldPosition fpos) {
+        return format(num, sbuf, fpos, this.showPlus, this.width);
+    }
+  public StringBuffer format(double num, StringBuffer sbuf,
+                             FieldPosition fpos, boolean showPlus, int width)
   {
     if (Double.isNaN(num) || Double.isInfinite(num))
       return sbuf.append(num);
     if (getMaximumFractionDigits() >= 0)
-      format(DFloNum.toExact(num), sbuf, fpos);
+        format(DFloNum.toExact(num), sbuf, fpos, showPlus, width);
     else
       {
         boolean negative;
@@ -183,7 +188,7 @@ public class FixedRealFormat extends java.text.Format
 
         format(sbuf, fpos, length, digits, decimals,
                negative ? 1 : 0,
-               oldSize);
+               oldSize, width);
       }
     return sbuf;
   }
@@ -193,23 +198,62 @@ public class FixedRealFormat extends java.text.Format
     RealNum rnum = RealNum.asRealNumOrNull(num);
     if (rnum == null)
       {
-        if (num instanceof Complex)
-          {
-            // Common Lisp says if value is non-real, print as if with ~wD.
-            String str = num.toString();
-            int padding = width - str.length();
-            while (--padding >= 0)
-              sbuf.append(' ');
-            sbuf.append(str);
-            return sbuf;
-          }
-        rnum = (RealNum) num;
+        int decimals;
+        if (num instanceof Quaternion
+            && (decimals = getMaximumFractionDigits()) >= 0) {
+            Quaternion qnum = (Quaternion) num;
+            RealNum re = qnum.re();
+            RealNum im = qnum.im();
+            RealNum jm = qnum.jm();
+            RealNum km = qnum.km();
+            if (! im.isZero() || ! jm.isZero() || ! km.isZero()) {
+                int oldSize = sbuf.length();
+                int startSize = oldSize;
+                boolean reZero = re.isZero();
+                if (! reZero || width > 0) {
+                    format(re, sbuf, null, this.showPlus, -1);
+                    if (reZero)
+                        startSize = sbuf.length();
+                }
+                if (! im.isZero()) {
+                    format(im, sbuf, null, true, -1);
+                    sbuf.append('i');
+                }
+                if (! jm.isZero()) {
+                    format(jm, sbuf, null, true, -1);
+                    sbuf.append('j');
+                }
+                if (! km.isZero()) {
+                    format(km, sbuf, null, true, -1);
+                    sbuf.append('k');
+                }
+                int emitted;
+                if (width > 0) {
+                    int padding = width - (sbuf.length() - oldSize);
+                    if (startSize > oldSize && padding < 0) {
+                        sbuf.delete(oldSize, startSize);
+                        padding += startSize - oldSize;
+                    }
+                    if (padding >= 0) {
+                        int i = oldSize;
+                        while (--padding >= 0)
+                            sbuf.insert(i, padChar);
+                    } else if (overflowChar != '\0') {
+                        sbuf.setLength(oldSize);
+                        for (i = width;  --i >= 0; )
+                            sbuf.append(overflowChar);
+                    }
+                }
+                return sbuf;
+            }
+        }
       }
-    return format(rnum.doubleValue(), sbuf, fpos);
+    format(rnum, sbuf, fpos, this.showPlus, this.width);
+    return sbuf;
   }
 
   /** Do padding and similar adjustments on the converted number. */
-  private void format (StringBuffer sbuf, FieldPosition fpos, int length, int digits, int decimals, int signLen, int oldSize)
+  private void format (StringBuffer sbuf, FieldPosition fpos, int length, int digits, int decimals, int signLen, int oldSize, int width)
   {
     int total_digits = digits + decimals;
     // Number of initial zeros to add.

kawa/ChangeLog

+2020-03-18  Per Bothner  <per@bothner.com>
+
+	* standard/ImportFromLibrary.java (SRFI97Map) Support srfi 48.
+
 2020-03-16  Per Bothner  <per@bothner.com>
 
 	* standard/define_library.java: Handle begin Syntax added by reader.

kawa/lib/ChangeLog

+2020-03-18  Per Bothner  <per@bothner.com>
+
+	* srfi/48.scm: Implement SRFI 48.
+	* Makefile.am: Compile srfi/48.scm.
+
 2020-03-11  Per Bothner  <per@bothner.com>
 
 	* kawa/istrings.scm: Use 'istring' for appropriate return types.

kawa/lib/Makefile.am

@@ -48,7 +48,7 @@ java_SCM_ALWAYS2 = enums.scm srfi/8.scm srfi/26.scm srfi/95.scm \
   kawa/base.scm
 # The following files may import (kawa base).
 java_SCM_ALWAYS3 = kawa/quaternions.scm kawa/pprint.scm kawa/rotations.scm \
-  kawa/null-5.scm kawa/reflect.scm 
+  kawa/null-5.scm kawa/reflect.scm srfi/48.scm
 
 scm_WITH_SWING = windows.scm kawa/swing.scm
 scm_WITH_AWT = kawa/pictures.scm 

kawa/lib/srfi/48.scm

+(module-name (srfi 48))
+(module-export format)
+(import (scheme base))
+
+(define (sformat (format::java.lang.CharSequence) (args::object[]) (arg_start::int))::constant-string
+  (let ((port (make gnu.kawa.io.CharArrayOutPort)))
+    (rformat port format args arg_start)
+    (! str (port:toString))
+    (port:close)
+    str))
+
+(define (rformat port::java.lang.Appendable format::java.lang.CharSequence
+                 args::object[] arg-start::int)
+  ::void
+  ((gnu.kawa.functions.LispFormat:asSrfi48Format format):format
+   args arg-start port #!null))
+
+(define (format arg1 #!rest args::object[])
+  (cond ((string? arg1)
+         (sformat arg1 args 0))
+        ((boolean? arg1)
+         (if arg1
+             (rformat (current-output-port) (args 0) args 1)
+             (sformat (args 0) args 1)))
+        ((java.io.Writer? arg1)
+         (rformat arg1 (args 0) args 1))
+        ((java.io.OutputStream? arg1)
+         (rformat arg1 (args 0) args 1))
+        (else
+         (error "invalid first argument for format"))))

kawa/standard/ImportFromLibrary.java

@@ -64,7 +64,8 @@ public class ImportFromLibrary extends Syntax
         { "45", "lazy", MISSING },
         { "46", "syntax-rules", MISSING },
         { "47", "arrays", MISSING },
-        { "48", "intermediate-format-strings", MISSING },
+        { "48", "intermediate-format-strings",
+          Mangling.mangleQualifiedName("kawa.lib.srfi.48") },
         { "51", "rest-values", MISSING },
         { "54", "cat", MISSING },
         { "57", "records", MISSING },

testsuite/ChangeLog

+2020-03-18  Per Bothner  <per@bothner.com>
+
+	* formatst.scm: New tests, mainly srfi-48.
+
 2020-03-11  Per Bothner  <per@bothner.com>
 
 	* arr-test.scm: Some tests based on GibLab issues #66 and #67.

testsuite/formatst.scm

@@ -28,7 +28,7 @@
 ;      (newline)
 ;      (format:abort)))
 
-(test-begin "format" 432)
+(test-begin "format" 454)
 (define-syntax test 
   (syntax-rules ()
     ((test format-args out-str)
@@ -662,8 +662,7 @@ def")
 (test '("~8,3F" 12.3456) "  12.346")
 (test '("~6,3F" 123.3456) "123.346")
 (test '("~4,3F" 123.3456) "123.346")
-(test-expect-fail 1) ; ~F doesn't properly support complex numbers
-(test `("~8,3F" ,(sqrt -3.8)) "0.000+1.949i")
+(test `("~8,3F" ,(sqrt -3.8)) " +1.949i")
 (test '("~6,2F" 32) " 32.00")
 ;; NB: (not (and (exact? 32.) (integer? 32.)))
 #| SRFI-48 results
@@ -695,8 +694,8 @@ def")
 (test '("~12F" 1.2345) "      1.2345")
 (test '("~12,2F" 1.2345) "        1.23")
 (test '("~12,3F" 1.2345) "       1.234")
-(test `("~20,3F" ,(sqrt -3.8)) "+1.9493588689617927i") ; SRFI-48: "        0.000+1.949i"
-(test `("~8,3F" ,(sqrt -3.8)) "+1.9493588689617927i"); SRFI-48: "0.000+1.949i")
+(test `("~20,3F" ,(sqrt -3.8)) "        0.000+1.949i") ; SRFI-48: "        0.000+1.949i"
+(test `("~8,3F" ,(sqrt -3.8)) " +1.949i"); SRFI-48: "0.000+1.949i")
 (test '("~8,2F" 3.4567e11) "345670000000.00") ; SRFI-48: " 3.46e11")
 ; (expect "#1=(a b c . #1#)"
 ;         (format "~w" (let ( (c '(a b c)) ) (set-cdr! (cddr c) c) c)))
@@ -733,6 +732,55 @@ Does not match implementation - or Common Lisp.
 (test '("~10<~a~;~a~;~a~>" 1 2 34567) "1 2  34567")
 (test '("~<~a~;~a~;~a~>" 1 2 34567) "1234567")
 
+;; SRFI-48
+
+(import (only (srfi 48) (format format48)))
+(test-assert (string-contains (format48 "~h")
+                              "the arg is a number which"))
+(test-equal "Hello, World!"
+            (format48 "Hello, ~a" "World!"))
+(test-equal "Error, list is too short: (one \"two\" 3)"
+     ; SRFI bogus extra paren: "Error, list is too short: (one \"two\" 3))"
+            (format48 "Error, list is too short: ~s" '(one "two" 3)))
+(test-equal "test me" (format48 "test me"))
+(test-equal "this is a \"test\""
+            (format48 "~a ~s ~a ~s" 'this 'is "a" "test"))
+(test-equal "#d32 #x20 #o40 #b100000\n"
+            (format48 "#d~d #x~x #o~o #b~b~%" 32 32 32 32))
+(test-equal "a new test"
+            (format48 "~a ~? ~a" 'a "~s" '(new) 'test))
+
+(test-expect-fail 1)
+;; SRFI-48 specification and test of "freshline" is questionable.
+(test-equal "\n1\n2\n3\n"
+            (format48 "~&1~&~&2~&~&~&3~%"))
+;; Actual and preferred CL-style result:
+(test-equal "1\n2\n3\n"
+            (format "~&1~&~&2~&~&~&3~%"))
+
+(test-equal "3  2 2  3 \n"
+            (format48 #f "~a ~? ~a ~%" 3 " ~s ~s " '(2 2) 3))
+(let ((r (format48 "~w" (let ( (c (list 'a 'b 'c)) ) (set-cdr! (cddr c) c) c))))
+  (test-assert (or (equal? r "#0=(a b c . #0#)")
+                   (equal? r "#1=(a b c . #1#)"))))
+(test-equal "   32.00" (format48 "~8,2F" 32))
+
+(test-expect-fail 1)
+;; Actual " +1.949i" output is, I think, preferred.
+(test-equal "0.000+1.949i" (format48 "~8,3F" (sqrt -3.8)))
+
+;;(test-equal " 3.45e11" (format48 "~8,2F" 3.4567e11))
+(test-equal " 0.333" (format48 "~6,3F" 1/3))
+(test-equal "  12" (format48 "~4F" 12))
+(test-equal "   12.00" (format48 "~8,2F" 12))
+(test-equal "4321.00" (format48 "~1,2F" 4321))
+(test-equal " 123.346" (format48 "~8,3F" 123.3456))
+(test-equal "123.346" (format48 "~6,3F" 123.3456))
+(test-equal "123.346" (format48 "~2,3F" 123.3456))
+(test-equal "     foo" (format48 "~8,3F" "foo"))
+(test-equal "\n"
+            (format "~a~a~&" (list->string (list #\newline)) ""))
+
 ; inquiry test
 
 ;; SLIB specific: (test '("~:q") format:version)