Commit a5f9754b authored by Per Bothner's avatar Per Bothner

* 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.
parent 5fe469bf
Pipeline #127589737 failed with stage
in 5 minutes and 16 seconds
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.
......
......@@ -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;
}
}
}
......@@ -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;
}
}
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.
......
......@@ -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.
......
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.
......
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.
......
......@@ -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
......
(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"))))
......@@ -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 },
......
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.
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment