## sfprintf.pkg -- support for printf/fprintf/sprintf functionality.
# Compiled by:
# src/lib/std/standard.lib# TODO XXX BUGGO FIXME
# - field widths in scan
# - add PREC of (Int * format_item) constructor to allow dynamic control of
# precision.
# - precision in %d, %s, ...
# - * flag in scan (checks, but doesn't scan input)
# - %n specifier in scan
stipulate
package f8b = eight_byte_float; # eight_byte_float is from src/lib/std/eight-byte-float.pkg package fil = file__premicrothread; # file__premicrothread is from src/lib/std/src/posix/file--premicrothread.pkgherein
package sfprintf
: (weak) Sfprintf # Sfprintf is from src/lib/src/sfprintf.api {
package ss = substring; # substring is from src/lib/std/substring.pkg package sc = number_string; # number_string is from src/lib/std/src/number-string.pkg # printf_field is from src/lib/src/printf-field.pkg include package printf_field;
exception BAD_FORMAT_LIST;
fun pad_left (str, pad) = sc::pad_left ' ' pad str;
fun pad_right (str, pad) = sc::pad_right ' ' pad str;
fun zero_lpad (str, pad) = sc::pad_left '0' pad str;
fun zero_rpad (str, pad) = sc::pad_right '0' pad str;
# Int to string conversions (for positive integers only):
#
stipulate
my (max_int2, max_int8, max_int10, max_int16)
=
case large_int::max_int
#
THE n
=>
{ max_p1 = large_unt::from_multiword_int n + 0u1;
#
( large_unt::format sc::BINARY max_p1,
large_unt::format sc::OCTAL max_p1,
large_unt::format sc::DECIMAL max_p1,
large_unt::format sc::HEX max_p1
);
};
NULL => ("", "", "", "");
esac;
herein
# MAX_INT is used to represent the absolute value
# of the largest representable negative integer.
#
Posint
= POS_INT large_int::Int
| MAX_INT
;
fun int_to_binary MAX_INT => max_int2;
int_to_binary (POS_INT i) => large_int::format sc::BINARY i;
end;
fun int_to_octal MAX_INT => max_int8;
int_to_octal (POS_INT i) => large_int::format sc::OCTAL i;
end;
fun int_to_string MAX_INT => max_int10;
int_to_string (POS_INT i) => large_int::to_string i;
end;
fun int_to_hex MAX_INT => max_int16;
int_to_hex (POS_INT i) => large_int::format sc::HEX i;
end;
fun int_to_he_x i
=
string::implode (
vector_of_chars::fold_backward (\\ (c, l) = char::to_upper c ! l) [] (int_to_hex i)
);
end; # stipulate
# Unt to string conversions:
#
word_to_binary = large_unt::format sc::BINARY;
word_to_octal = large_unt::format sc::OCTAL;
word_to_string = large_unt::format sc::DECIMAL;
word_to_hex = large_unt::format sc::HEX;
#
fun word_to_he_x i
=
string::map char::to_upper (word_to_hex i);
# Accept a printf-style format string like "This is %d %6.2f".
# Return a matching list of printf_field::Printf_Field records -- see src/lib/src/printf-field.pkg #
fun parse_format_string_into_printf_field_list
format_string
=
loop (ss::from_string format_string, [])
where
# Define a predicate true on every char but '%',
# for splitting up the format string:
#
split = ss::split_off_prefix {. #c != '%'; };
fun loop (input_string, resultlist)
=
if (ss::is_empty input_string)
reverse resultlist;
else
my ( leading_literal, # Everything up to the first '%' in 'input_string'
rest_of_string # Everything from the first '%' in 'input_string' on.
)
=
split input_string;
# scan_field we get from printf_field.
# printf_field is from src/lib/src/printf-field.pkg case (ss::getc rest_of_string)
THE ('%', rest_of_string')
=>
{ my (field', left_to_do)
=
scan_field rest_of_string';
loop (left_to_do, field' ! (RAW leading_literal) ! resultlist);
};
_ => reverse ((RAW leading_literal) ! resultlist);
esac;
fi;
end; # fun parse_format_string_into_printf_field_list
fun sprintf'
format_string # Printf-style format string like "This is %d %2.3g"
=
\\ args
=
do_args (fields, args, [])
where
fields # List of printf_field::Printf_Field records -- see src/lib/src/printf-field.pkg =
parse_format_string_into_printf_field_list
format_string;
# Apply one Printf_Field FIELD to a value.
#
# The first three args are the FIELD fields,
# digested from some spec like "%6.2f".
#
# The fourth argument is the value being formatted,
# represented as a Printf_Arg -- something like FLOAT f.
#
fun do_field (flags, width, printf_field_type, arg)
=
{ fun pad_fn string
=
case (flags.left_justify, width)
#
(_, NO_PAD) => string;
(FALSE, WIDTH i) => pad_left (string, i);
(TRUE, WIDTH i) => pad_right (string, i);
esac;
fun zero_pad_fn (sign, s)
=
case width
NO_PAD => raise exception BAD_FORMAT "NO_PAD not allowed here";
WIDTH i => zero_lpad (s, i - (string::length_in_bytes sign));
esac;
fun negate i
=
(POS_INT(-i))
except
_ = MAX_INT;
fun do_sign i
=
case (i < 0, flags.sign, flags.neg_char)
#
(FALSE, ALWAYS_SIGN, _) => ("+", POS_INT i);
(FALSE, BLANK_SIGN, _) => (" ", POS_INT i);
(FALSE, _, _) => ("", POS_INT i);
(TRUE, _, TILDE_SIGN) => ("~", negate i);
(TRUE, _, _ ) => ("-", negate i);
esac;
fun do_real_sign sign
=
case (sign, flags.sign, flags.neg_char)
#
(FALSE, ALWAYS_SIGN, _) => "+";
(FALSE, BLANK_SIGN, _) => " ";
(FALSE, _, _) => "";
(TRUE, _, TILDE_SIGN) => "~";
(TRUE, _, _) => "-";
esac;
fun do_exp_sign (exp, is_cap)
=
{ e = if is_cap "E";
else "e";
fi;
fun mk_expression e
=
zero_lpad (int::to_string e, 2);
case (exp < 0, flags.neg_char)
#
(FALSE, _ ) => [e, mk_expression exp ];
(TRUE, TILDE_SIGN) => [e, "~", mk_expression(-exp)];
(TRUE, _ ) => [e, "-", mk_expression(-exp)];
esac;
};
fun binary i
=
{ (do_sign i) -> (sign, i);
#
sign = if flags.base sign + "0";
else sign;
fi;
s = int_to_binary i;
if flags.zero_pad sign + zero_pad_fn (sign, s);
else pad_fn (sign + s);
fi;
};
fun octal i
=
{ (do_sign i) -> (sign, i);
#
sign = if flags.base sign + "0";
else sign;
fi;
s = int_to_octal i;
if flags.zero_pad sign + zero_pad_fn (sign, s);
else pad_fn (sign + s);
fi;
};
fun decimal i
=
{ (do_sign i) -> (sign, i);
#
s = int_to_string i;
if flags.zero_pad sign + zero_pad_fn (sign, s);
else pad_fn (sign + s);
fi;
};
fun hexidecimal i
=
{ (do_sign i) -> (sign, i);
#
sign = if flags.base sign + "0x";
else sign;
fi;
s = int_to_hex i;
if flags.zero_pad sign + zero_pad_fn (sign, s);
else pad_fn (sign + s);
fi;
};
fun cap_hexidecimal i
=
{ (do_sign i) -> (sign, i);
#
sign = if flags.base sign + "0X"; else sign;fi;
s = int_to_he_x i;
if flags.zero_pad sign + zero_pad_fn (sign, s);
else pad_fn (sign + s);
fi;
};
# Unt formatting:
#
fun do_unt_sign ()
=
case flags.sign
#
ALWAYS_SIGN => "+";
BLANK_SIGN => " ";
_ => "";
esac;
fun binary_w i
=
{ sign = do_unt_sign ();
#
sign = if flags.base sign + "0";
else sign;
fi;
s = word_to_binary i;
if flags.zero_pad sign + zero_pad_fn (sign, s);
else pad_fn (sign + s);
fi;
};
fun octal_w i
=
{ sign = do_unt_sign ();
#
sign = if flags.base sign + "0";
else sign;
fi;
s = word_to_octal i;
if flags.zero_pad sign + zero_pad_fn (sign, s);
else pad_fn (sign + s);
fi;
};
fun decimal_w i
=
{ sign = do_unt_sign ();
#
s = word_to_string i;
if flags.zero_pad sign + zero_pad_fn (sign, s);
else pad_fn (sign + s);
fi;
};
fun hexidecimal_w i
=
{ sign = do_unt_sign ();
#
sign = if flags.base sign + "0x";
else sign;
fi;
s = word_to_hex i;
if flags.zero_pad sign + zero_pad_fn (sign, s);
else pad_fn (sign + s);
fi;
};
fun cap_hexidecimal_w i
=
{ sign = do_unt_sign ();
#
sign = if flags.base sign + "0X";
else sign;
fi;
s = word_to_he_x i;
if flags.zero_pad sign + zero_pad_fn (sign, s);
else pad_fn (sign + s);
fi;
};
case (printf_field_type, arg)
#
# NB: If you change this caselist,
# be sure to also update
# fun printf_field_type_to_printf_arg_list.
(BINARY_FIELD, LINT i) => binary i;
(BINARY_FIELD, INT i) => binary (int::to_multiword_int i);
(BINARY_FIELD, UNT w) => binary_w (unt::to_large_unt w);
(BINARY_FIELD, LUNT w) => binary_w w;
(BINARY_FIELD, UNT8 w) => binary_w (one_byte_unt::to_large_unt w);
(OCTAL_FIELD, LINT i) => octal i;
(OCTAL_FIELD, INT i) => octal (int::to_multiword_int i);
(OCTAL_FIELD, UNT w) => octal_w (unt::to_large_unt w);
(OCTAL_FIELD, LUNT w) => octal_w w;
(OCTAL_FIELD, UNT8 w) => octal_w (one_byte_unt::to_large_unt w);
(INT_FIELD, LINT i) => decimal i;
(INT_FIELD, INT i) => decimal (int::to_multiword_int i);
(INT_FIELD, UNT w) => decimal_w (unt::to_large_unt w);
(INT_FIELD, LUNT w) => decimal_w w;
(INT_FIELD, UNT8 w) => decimal_w (one_byte_unt::to_large_unt w);
(HEX_FIELD, LINT i) => hexidecimal i;
(HEX_FIELD, INT i) => hexidecimal (int::to_multiword_int i);
(HEX_FIELD, UNT w) => hexidecimal_w (unt::to_large_unt w);
(HEX_FIELD, LUNT w) => hexidecimal_w w;
(HEX_FIELD, UNT8 w) => hexidecimal_w (one_byte_unt::to_large_unt w);
(CAP_HEX_FIELD, LINT i) => cap_hexidecimal i;
(CAP_HEX_FIELD, INT i) => cap_hexidecimal (int::to_multiword_int i);
(CAP_HEX_FIELD, UNT w) => cap_hexidecimal_w (unt::to_large_unt w);
(CAP_HEX_FIELD, LUNT w) => cap_hexidecimal_w w;
(CAP_HEX_FIELD, UNT8 w) => cap_hexidecimal_w (one_byte_unt::to_large_unt w);
(CHAR_FIELD, CHAR c) => pad_fn (string::from_char c);
(BOOL_FIELD, BOOL FALSE) => pad_fn "FALSE";
(BOOL_FIELD, BOOL TRUE ) => pad_fn "TRUE";
(STRING_FIELD, QUICKSTRING s) => pad_fn (quickstring__premicrothread::to_string s);
(STRING_FIELD, STRING s) => pad_fn s;
(FLOAT_FIELD { prec, format }, FLOAT r)
=>
if (f8b::is_finite r)
#
# float_format is from src/lib/src/float-format.pkg case format
#
F_FORMAT
=>
{ my { sign, mantissa }
=
float_format::float_fformat (r, prec);
sign = do_real_sign sign;
if (prec == 0 and flags.base)
pad_fn (cat [sign, mantissa, "."]);
else pad_fn (cat [sign, mantissa ]);
fi;
};
E_FORMAT is_cap
=>
{ my { sign, mantissa, exp }
=
float_format::float_eformat (r, prec);
sign = do_real_sign sign;
exp_string = do_exp_sign (exp, is_cap);
if (prec == 0 and flags.base)
pad_fn (cat (sign ! mantissa ! "." ! exp_string));
else pad_fn (cat (sign ! mantissa ! exp_string));
fi;
};
G_FORMAT is_cap
=>
{ prec = if (prec == 0 ) 1;
else prec; fi;
(float_format::float_gformat (r, prec))
->
{ sign, whole, frac, exp };
sign = do_real_sign sign;
exp_string
=
case exp
THE e => do_exp_sign (e, is_cap);
NULL => [];
esac;
num =
if flags.base
diff = prec - ((size whole) + (size frac));
if (diff > 0)
zero_rpad (frac, (size frac) + diff);
else
frac;
fi;
else
if (frac == "")
"";
else
("." + frac);
fi;
fi;
pad_fn (cat (sign ! whole ! num ! exp_string));
};
esac;
else
if (f8b::(====) (f8b::neg_inf, r))
#
do_real_sign TRUE + "inf";
else
if (f8b::(====) (f8b::pos_inf, r))
#
do_real_sign FALSE + "inf";
else
"nan";
fi;
fi;
fi;
(_, LEFT (w, arg))
=>
{ flags = { sign => flags.sign,
neg_char => flags.neg_char,
zero_pad => flags.zero_pad,
base => flags.base,
left_justify => TRUE,
large => FALSE
};
do_field (flags, WIDTH w, printf_field_type, arg);
};
(_, RIGHT (w, arg))
=>
do_field (flags, WIDTH w, printf_field_type, arg);
_ => raise exception BAD_FORMAT_LIST;
esac;
}; # fun do_field
# First arg is list of vals to print, say [ INT 12, STRING "funky", FLOAT 1.3 ]
# Second arg is the "%3.sf" style format string digested into
# a list of printf_field::Printf_Field records -- see src/lib/src/printf-field.pkg # Third arg is our result accumulator:
#
fun do_args ([], [], resultlist)
=>
ss::cat (reverse resultlist);
do_args ((RAW s) ! remaining_fields, args, resultlist)
=>
do_args (remaining_fields, args, s ! resultlist);
do_args
( FIELD (flags, width, printf_field_type) ! remaining_fields,
arg ! remaining_args,
resultlist
)
=>
do_args
( remaining_fields,
remaining_args,
ss::from_string (do_field (flags, width, printf_field_type, arg)) ! resultlist
);
do_args _
=>
raise exception BAD_FORMAT_LIST;
end;
end; # fun sprintf'
fun fnprintf' consumer
=
\\ format
=
\\ args
=
consumer (sprintf' format args);
fun fprintf' stream
=
\\ format
=
\\ args
=
{ fil::write (stream, sprintf' format args);
fil::flush stream; # Default to occasional inefficiency rather than occasional mysterious lockups.
};
printf' = fprintf' fil::stdout;
# printf_field is from src/lib/src/printf-field.pkg # In conjunction with
# fun parse_format_string_into_printf_field_list,
# this function can be used to mechanically
# synthesize an appropriate arglist from a
# sfprintf format string like "%d %6.2f\n":
#
fun printf_field_type_to_printf_arg_list f
=
{ u0 = unt::from_int 0;
li0 = large_int::from_int 0;
lu0 = large_unt::from_int 0;
b0 = one_byte_unt::from_int 0;
case f
#
# Here we give, for each printf_field::Printf_Field_Type,
# the list of printf_field::Printf_Arg constructors.
#
# The values are dummies, we're
# only interested in the constructors.
#
# Order is significant in that caller
# expects the most vanilla altenative
# will be first in the returned list:
#
BINARY_FIELD => [INT 0, UNT u0, LINT li0, LUNT lu0, UNT8 b0];
OCTAL_FIELD => [INT 0, UNT u0, LINT li0, LUNT lu0, UNT8 b0];
INT_FIELD => [INT 0, UNT u0, LINT li0, LUNT lu0, UNT8 b0];
HEX_FIELD => [INT 0, UNT u0, LINT li0, LUNT lu0, UNT8 b0];
CAP_HEX_FIELD => [INT 0, UNT u0, LINT li0, LUNT lu0, UNT8 b0];
CHAR_FIELD => [CHAR 'a'];
BOOL_FIELD => [BOOL FALSE];
STRING_FIELD => [STRING ""];
FLOAT_FIELD _ => [FLOAT 0.0];
esac;
};
}; # pkg sfprintf
end;