mirror of
https://github.com/gcc-mirror/gcc.git
synced 2026-05-06 14:59:39 +02:00
a68: more standard prelude in Algol 68
This commit moves the contents of libga68/transput.a68.in to
libga68/standard.a68.in and removes the built-in expansion of the
L_{int,real,exp}_width standard routines.
Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
libga68/ChangeLog
* transput.a68.in: Remove and move content to..
* standard.a68.in: .. here.
* Makefile.am (libga68_la_DEPENDENCIES): Remove transput.lo.
(libga68_la_LIBADD): Likewise.
(transput.a68): Remove rule.
(standard.a68): Remove transput.a68.
* Makefile.in: Regenerate.
gcc/algol68/ChangeLog
* a68.h: Remove prototypes for *_width functions.
* a68-parser-prelude.cc (stand_prelude): Do not define *width
functions.
* a68-low-ints.cc (a68_int_width): Remove.
* a68-low-reals.cc (a68_real_width): Likewise.
(a68_real_exp_width): Likewise.
* a68-low-prelude.cc (a68_lower_longintwidth): Likewise.
(a68_lower_intwidth): Likewise.
(a68_lower_longlongintwidth): Likewise.
(a68_lower_shortintwidth): Likewise.
(a68_lower_shortshortintwidth): Likewise.
(a68_lower_realwidth): Likewise.
(a68_lower_longrealwidth): Likewise.
(a68_lower_longlongrealwidth): Likewise.
(a68_lower_expwidth): Likewise.
(a68_lower_longexpwidth): Likewise.
(a68_lower_longlongexpwidth): Likewise.
gcc/testsuite/ChangeLog
* algol68/execute/char-in-string-1.a68: It is no longer need to
access Transput explicitly.
This commit is contained in:
Jose E. Marchesi
@@ -83,24 +83,6 @@ a68_int_minval (tree type)
|
||||
return fold_convert (type, TYPE_MIN_VALUE (type));
|
||||
}
|
||||
|
||||
/* Given an integral type, build an INT with the number of decimal digits
|
||||
required to represent a value of that typ, not including sign. */
|
||||
|
||||
tree
|
||||
a68_int_width (tree type)
|
||||
{
|
||||
/* Note that log10 (2) is ~ 0.3.
|
||||
Thanks to Andrew Pinski for suggesting using this expression. */
|
||||
return fold_build2 (PLUS_EXPR, a68_int_type,
|
||||
build_int_cst (a68_int_type, 1),
|
||||
fold_build2 (TRUNC_DIV_EXPR,
|
||||
a68_int_type,
|
||||
fold_build2 (MULT_EXPR, a68_int_type,
|
||||
build_int_cst (a68_int_type, TYPE_PRECISION (type)),
|
||||
build_int_cst (a68_int_type, 3)),
|
||||
build_int_cst (a68_int_type, 10)));
|
||||
}
|
||||
|
||||
/* Given an integer value VAL, return -1 if it is less than zero, 0 if it is
|
||||
zero and +1 if it is bigger than zero. The built value is always of mode
|
||||
M_INT. */
|
||||
|
||||
@@ -1206,72 +1206,6 @@ a68_lower_shortshortbitswidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBU
|
||||
return a68_bits_width (a68_short_short_bits_type);
|
||||
}
|
||||
|
||||
tree
|
||||
a68_lower_intwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
|
||||
{
|
||||
return a68_int_width (a68_int_type);
|
||||
}
|
||||
|
||||
tree
|
||||
a68_lower_longintwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
|
||||
{
|
||||
return a68_int_width (a68_long_int_type);
|
||||
}
|
||||
|
||||
tree
|
||||
a68_lower_longlongintwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
|
||||
{
|
||||
return a68_int_width (a68_long_long_int_type);
|
||||
}
|
||||
|
||||
tree
|
||||
a68_lower_shortintwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
|
||||
{
|
||||
return a68_int_width (a68_short_int_type);
|
||||
}
|
||||
|
||||
tree
|
||||
a68_lower_shortshortintwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
|
||||
{
|
||||
return a68_int_width (a68_short_short_int_type);
|
||||
}
|
||||
|
||||
tree
|
||||
a68_lower_realwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
|
||||
{
|
||||
return a68_real_width (a68_real_type);
|
||||
}
|
||||
|
||||
tree
|
||||
a68_lower_longrealwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
|
||||
{
|
||||
return a68_real_width (a68_long_real_type);
|
||||
}
|
||||
|
||||
tree
|
||||
a68_lower_longlongrealwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
|
||||
{
|
||||
return a68_real_width (a68_long_long_real_type);
|
||||
}
|
||||
|
||||
tree
|
||||
a68_lower_expwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
|
||||
{
|
||||
return a68_real_exp_width (a68_real_type);
|
||||
}
|
||||
|
||||
tree
|
||||
a68_lower_longexpwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
|
||||
{
|
||||
return a68_real_exp_width (a68_long_real_type);
|
||||
}
|
||||
|
||||
tree
|
||||
a68_lower_longlongexpwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
|
||||
{
|
||||
return a68_real_exp_width (a68_long_long_real_type);
|
||||
}
|
||||
|
||||
tree
|
||||
a68_lower_pi (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
|
||||
{
|
||||
|
||||
@@ -129,34 +129,6 @@ a68_real_smallval (tree type)
|
||||
return build_real (type, res);
|
||||
}
|
||||
|
||||
/* Given a real type, build an INT with the number of decimal digits required
|
||||
to represent a mantissa, such that a real is not reglected in comparison
|
||||
with 1, not including sign. */
|
||||
|
||||
tree
|
||||
a68_real_width (tree type)
|
||||
{
|
||||
const machine_mode mode = TYPE_MODE (type);
|
||||
const struct real_format *fmt = REAL_MODE_FORMAT (mode);
|
||||
return build_int_cst (a68_int_type, fmt->p);
|
||||
}
|
||||
|
||||
/* Given a real type, build an INT with the number of decimal digits required
|
||||
to represent a decimal exponent, such that a real can be correctly
|
||||
represented, not including sign. */
|
||||
|
||||
tree
|
||||
a68_real_exp_width (tree type ATTRIBUTE_UNUSED)
|
||||
{
|
||||
const machine_mode mode = TYPE_MODE (type);
|
||||
const struct real_format *fmt = REAL_MODE_FORMAT (mode);
|
||||
const double log10_2 = .30102999566398119521;
|
||||
double log10_b = log10_2;
|
||||
int max_10_exp = fmt->emax * log10_b;
|
||||
|
||||
return build_int_cst (a68_int_type, 1 + log10 (max_10_exp));
|
||||
}
|
||||
|
||||
/* Given a real value VAL, return -1 if it is less than zero, 0 if it is zero
|
||||
and +1 if it is bigger than zero. The built value is always of mode
|
||||
M_INT. */
|
||||
|
||||
@@ -357,7 +357,7 @@ stand_moids (void)
|
||||
SLICE (M_ROW_SIMPLOUT) = M_SIMPLOUT;
|
||||
}
|
||||
|
||||
/* Set up standenv - general RR but not transput. */
|
||||
/* Set up standenv - general RR including transput. */
|
||||
|
||||
static void
|
||||
stand_prelude (void)
|
||||
@@ -389,17 +389,6 @@ stand_prelude (void)
|
||||
a68_idf (A68_STD, "longmaxbits", M_LONG_BITS, a68_lower_maxbits);
|
||||
a68_idf (A68_STD, "longlongmaxbits", M_LONG_LONG_BITS, a68_lower_maxbits);
|
||||
a68_idf (A68_STD, "maxabschar", M_INT, a68_lower_maxabschar);
|
||||
a68_idf (A68_STD, "intwidth", M_INT, a68_lower_intwidth);
|
||||
a68_idf (A68_STD, "longintwidth", M_INT, a68_lower_longintwidth);
|
||||
a68_idf (A68_STD, "longlongintwidth", M_INT, a68_lower_longlongintwidth);
|
||||
a68_idf (A68_STD, "shortintwidth", M_INT, a68_lower_shortintwidth);
|
||||
a68_idf (A68_STD, "shortshortintwidth", M_INT, a68_lower_shortshortintwidth);
|
||||
a68_idf (A68_STD, "realwidth", M_INT, a68_lower_realwidth);
|
||||
a68_idf (A68_STD, "longrealwidth", M_INT, a68_lower_longrealwidth);
|
||||
a68_idf (A68_STD, "longlongrealwidth", M_INT, a68_lower_longlongrealwidth);
|
||||
a68_idf (A68_STD, "expwidth", M_INT, a68_lower_expwidth);
|
||||
a68_idf (A68_STD, "longexpwidth", M_INT, a68_lower_longexpwidth);
|
||||
a68_idf (A68_STD, "longlongexpwidth", M_INT, a68_lower_longlongexpwidth);
|
||||
a68_idf (A68_STD, "pi", M_REAL, a68_lower_pi);
|
||||
a68_idf (A68_STD, "longpi", M_LONG_REAL, a68_lower_pi);
|
||||
a68_idf (A68_STD, "longlongpi", M_LONG_LONG_REAL, a68_lower_pi);
|
||||
@@ -1299,16 +1288,6 @@ stand_prelude (void)
|
||||
"STANDARD", "ga68");
|
||||
}
|
||||
|
||||
/* Transput. */
|
||||
|
||||
static void
|
||||
stand_transput (void)
|
||||
{
|
||||
// if (!flag_building_libga68)
|
||||
// a68_extract_revelation (A68_STANDENV, LINE (INFO (TOP_NODE (&A68_JOB))),
|
||||
// "TRANSPUT", "ga68");
|
||||
}
|
||||
|
||||
/* GNU extensions for the standenv. */
|
||||
|
||||
static void
|
||||
@@ -1441,5 +1420,4 @@ a68_make_standard_environ (void)
|
||||
gnu_prelude ();
|
||||
posix_prelude ();
|
||||
}
|
||||
stand_transput ();
|
||||
}
|
||||
|
||||
@@ -561,7 +561,6 @@ tree a68_bool_ne (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
|
||||
tree a68_get_int_skip_tree (MOID_T *m);
|
||||
tree a68_int_maxval (tree type);
|
||||
tree a68_int_minval (tree type);
|
||||
tree a68_int_width (tree type);
|
||||
tree a68_int_sign (tree val);
|
||||
tree a68_int_abs (tree val);
|
||||
tree a68_int_shorten (MOID_T *to_mode, MOID_T *from_mode, tree val);
|
||||
@@ -595,8 +594,6 @@ tree a68_real_pi (tree type);
|
||||
tree a68_real_maxval (tree type);
|
||||
tree a68_real_minval (tree type);
|
||||
tree a68_real_smallval (tree type);
|
||||
tree a68_real_width (tree type);
|
||||
tree a68_real_exp_width (tree type);
|
||||
tree a68_real_sign (tree val);
|
||||
tree a68_real_abs (tree val);
|
||||
tree a68_real_sqrt (tree val);
|
||||
@@ -988,17 +985,6 @@ tree a68_lower_longbitswidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_longlongbitswidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_shortbitswidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_shortshortbitswidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_intwidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_longintwidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_longlongintwidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_shortintwidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_shortshortintwidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_realwidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_longrealwidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_longlongrealwidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_expwidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_longexpwidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_longlongexpwidth (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_pi (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_nullcharacter (NODE_T *p, LOW_CTX_T ctx);
|
||||
tree a68_lower_flip (NODE_T *p, LOW_CTX_T ctx);
|
||||
|
||||
@@ -1,4 +1,3 @@
|
||||
access Transput
|
||||
begin int pos;
|
||||
assert (char_in_string ("o", pos, "foo"));
|
||||
assert (pos = 2)
|
||||
|
||||
@@ -134,8 +134,8 @@ libga68_la_LIBTOOLFLAGS =
|
||||
libga68_la_CFLAGS = $(LIBGA68_GCFLAGS) $(LIBGA68_BOEHM_GC_INCLUDES)
|
||||
libga68_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` \
|
||||
$(version_arg) $(lt_host_flags) $(extra_darwin_ldflags_libga68)
|
||||
libga68_la_DEPENDENCIES = libga68.spec $(version_dep) transput.lo standard.lo posix.lo
|
||||
libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS) transput.lo standard.lo posix.lo
|
||||
libga68_la_DEPENDENCIES = libga68.spec $(version_dep) standard.lo posix.lo
|
||||
libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS) standard.lo posix.lo
|
||||
|
||||
# Rules to build the Algol 68 code in the library.
|
||||
|
||||
@@ -148,13 +148,10 @@ LTA68COMPILE = $(LIBTOOL) --tag=A68 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
|
||||
.a68.lo:
|
||||
$(LTA68COMPILE) $(A68FLAGS) $(MULTIFLAGS) -fbuilding-libga68 -c -o $@ $<
|
||||
|
||||
transput.a68 : transput.a68.in
|
||||
$(AWK) -f $(srcdir)/sppp.awk $< > $@
|
||||
|
||||
standard.a68 : standard.a68.in
|
||||
$(AWK) -f $(srcdir)/sppp.awk $< > $@
|
||||
|
||||
BUILT_SOURCES = transput.a68 standard.a68
|
||||
BUILT_SOURCES = standard.a68
|
||||
|
||||
# target overrides
|
||||
-include $(tmake_file)
|
||||
|
||||
@@ -475,14 +475,14 @@ libga68_la_CFLAGS = $(LIBGA68_GCFLAGS) $(LIBGA68_BOEHM_GC_INCLUDES)
|
||||
libga68_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` \
|
||||
$(version_arg) $(lt_host_flags) $(extra_darwin_ldflags_libga68)
|
||||
|
||||
libga68_la_DEPENDENCIES = libga68.spec $(version_dep) transput.lo standard.lo posix.lo
|
||||
libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS) transput.lo standard.lo posix.lo
|
||||
libga68_la_DEPENDENCIES = libga68.spec $(version_dep) standard.lo posix.lo
|
||||
libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS) standard.lo posix.lo
|
||||
|
||||
# Rules to build the Algol 68 code in the library.
|
||||
LTA68COMPILE = $(LIBTOOL) --tag=A68 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
|
||||
--mode=compile $(A68) $(AM_A68FLAGS)
|
||||
|
||||
BUILT_SOURCES = transput.a68 standard.a68
|
||||
BUILT_SOURCES = standard.a68
|
||||
MULTISRCTOP =
|
||||
MULTIBUILDTOP =
|
||||
MULTIDIRS =
|
||||
@@ -901,9 +901,6 @@ uninstall-am: uninstall-toolexeclibDATA \
|
||||
.a68.lo:
|
||||
$(LTA68COMPILE) $(A68FLAGS) $(MULTIFLAGS) -fbuilding-libga68 -c -o $@ $<
|
||||
|
||||
transput.a68 : transput.a68.in
|
||||
$(AWK) -f $(srcdir)/sppp.awk $< > $@
|
||||
|
||||
standard.a68 : standard.a68.in
|
||||
$(AWK) -f $(srcdir)/sppp.awk $< > $@
|
||||
|
||||
|
||||
@@ -25,8 +25,11 @@
|
||||
|
||||
module Standard =
|
||||
def
|
||||
{ 10.2.3.8.l L bitspack
|
||||
───────────────────── }
|
||||
{ 10.2.1 Environment enquiries. }
|
||||
|
||||
{ L bits_width are implemented in compiler. }
|
||||
|
||||
{ 10.2.3.8.l L bitspack. }
|
||||
|
||||
{iter L {short short} {short} {} {long} {long long}}
|
||||
{iter L_ {short_short_} {short_} {} {long_} {long_long_}}
|
||||
@@ -43,5 +46,255 @@ def
|
||||
fi;
|
||||
{reti}
|
||||
|
||||
{ 10.3.2.1. Conversion routines. }
|
||||
|
||||
mode Number = union (
|
||||
{iter L {short short} {short} {} {long} {long long}}
|
||||
{L} int
|
||||
{reti {,}}
|
||||
,
|
||||
{iter L {} {long} {long long}}
|
||||
{L} real
|
||||
{reti {,}}
|
||||
);
|
||||
|
||||
pub proc whole = (Number v, int width) string:
|
||||
case v in
|
||||
{iter L {short short} {short} {} {long} {long long}}
|
||||
{iter L_ {short_short_} {short_} {} {long_} {long_long_}}
|
||||
({L} int x):
|
||||
(int length := ABS width - (x < {L} 0 OR width > 0 | 1 | 0),
|
||||
{L} int n := ABS x;
|
||||
if width = 0
|
||||
then {L} int m := n; length := 0;
|
||||
while m %:= {L} 10; length +:= 1; m /= {L} 0
|
||||
do ~ od
|
||||
fi;
|
||||
string s := subwhole (n, length);
|
||||
if length = 0 OR char_in_string (errorchar, loc int, s)
|
||||
then ABS width * errorchar
|
||||
else (x < {L} 0 | "-" |: width > 0 | "+" | "") +=: s;
|
||||
(width /= 0 | (ABS width - UPB s) * " " +=: s);
|
||||
s
|
||||
fi),
|
||||
({L} real x): fixed (x, width, 0)
|
||||
{reti {,}}
|
||||
esac;
|
||||
|
||||
pub proc fixed = (Number v, int width, after) string:
|
||||
case v in
|
||||
{iter L {} {long} {long long}}
|
||||
({L} real x):
|
||||
if int length := ABS width - (x < {L} 0 OR width > 0 | 1 | 0);
|
||||
after >= 0 AND (length > after OR width = 0)
|
||||
then {L} real y = ABS x;
|
||||
if width = 0
|
||||
then length := (after = 0 | 1 | 0);
|
||||
while y + {L} .5 * {L} .1 ** after >= {L} 10 ** length
|
||||
do length +:= 1 od;
|
||||
length +:= (after = 0 | 0 | after + 1)
|
||||
fi;
|
||||
string s := subfixed (y, length, after);
|
||||
if ~char_in_string (errorchar, loc int, s)
|
||||
then (length > UPB s AND y < {L} 1.0 | "0" +=: s);
|
||||
(x < {L} 0 | "-" |: width > 0 | "+" | "") +=: s;
|
||||
(width /= 0 | (ABS width - UPB s) * " " +=: s);
|
||||
s
|
||||
elif after > 0
|
||||
then fixed (v, width, after - 1)
|
||||
else ABS width * errorchar
|
||||
fi
|
||||
else { XXX undefined } skip; ABS width * errorchar
|
||||
fi,
|
||||
({L} int x): fixed ({L} real (x), width, after)
|
||||
{reti {,}}
|
||||
esac;
|
||||
|
||||
pub proc float = (Number v, int width, after, exp) string:
|
||||
case v in
|
||||
{iter L {} {long} {long long}}
|
||||
{iter L_ {} {long_} {long_long_}}
|
||||
({L} real x):
|
||||
if int before = ABS width - ABS exp - (after /= 0 | after+1 | 0) - 2;
|
||||
SIGN before + SIGN after > 0
|
||||
then string s, {L} real y := ABS x, int p := 0;
|
||||
{L_}standardize (y, before, after, p);
|
||||
s := fixed (SIGN (x * y), SIGN width * (ABS width - ABS exp - 1),
|
||||
after) + "*^" + whole (p, exp);
|
||||
if exp = 0 OR char_in_string (errorchar, loc int, s)
|
||||
then float (x, width, (after /= 0 | after-1 | 0),
|
||||
(exp > 0 | exp+1 | exp-1))
|
||||
else s
|
||||
fi
|
||||
else { XXX undefined } skip; ABS width * errorchar
|
||||
fi,
|
||||
({L} int x): float ({L} real (x), width, after, exp)
|
||||
{reti {,}}
|
||||
esac;
|
||||
|
||||
{ Returns a string of maximum length `width' containing a decimal
|
||||
representation of the positive integer `v'. }
|
||||
|
||||
proc subwhole = (Number v, int width) string:
|
||||
case v in
|
||||
{iter L {short short} {short} {} {long} {long long}}
|
||||
{iter S {LENG LENG} {LENG} {} {SHORTEN} {SHORTEN SHORTEN}}
|
||||
({L} int x):
|
||||
begin string s, {L} int n := x;
|
||||
while dig_char ({S} (n MOD {L} 10)) +=: s;
|
||||
n %:= {L} 10; n /= {L} 0
|
||||
do ~ od;
|
||||
(UPB s > width | width * errorchar | s)
|
||||
end
|
||||
{reti {,}}
|
||||
esac;
|
||||
|
||||
{ Returns a string of maximum length `width' containing a rounded
|
||||
decimal representation of the positive real number `v'; if
|
||||
`after' is greater than zero, this string contains a decimal
|
||||
point followed by `after' digits. }
|
||||
|
||||
proc subfixed = (Number v, int width, after) string:
|
||||
case v in
|
||||
{iter L {} {long} {long long}}
|
||||
{iter K {} {LENG} {LENG LENG}}
|
||||
{iter S {} {SHORTEN} {SHORTEN SHORTEN}}
|
||||
({L} real x):
|
||||
begin string s, int before := 0;
|
||||
{L} real y := x + {L} .5 * {L} .1 ** after;
|
||||
proc choosedig = (ref {L} real y) char:
|
||||
dig_char ((int c := {S} ENTIER (y *:= {L} 10.0); (c > 9 | c := 9);
|
||||
y -:= {K} c; c));
|
||||
while y >= {L} 10.0 ** before do before +:= 1 od;
|
||||
y /:= {L} 10.0 ** before;
|
||||
to before do s +:= choosedig (y) od;
|
||||
(after > 0 | s +:= ".");
|
||||
to after do s +:= choosedig (y) od;
|
||||
(UPB s > width | width * errorchar | s)
|
||||
end
|
||||
{reti {,}}
|
||||
esac;
|
||||
|
||||
{ Adjusts the value of `y' so that it may be transput according to
|
||||
the format $ n(before)d, n(after)d $; `p' is set so that y * 10
|
||||
** p is equal to the original value of `y'. }
|
||||
|
||||
{iter L {} {long} {long long}}
|
||||
{iter L_ {} {long_} {long_long_}}
|
||||
proc {L_}standardize = (ref {L} real y, int before, after, ref int p) void:
|
||||
begin
|
||||
{L} real g = {L} 10.0 ** before; {L} real h = g * {L} .1;
|
||||
while y >= g do y *:= {L} .1; p +:= 1 od;
|
||||
(y /= {L} 0.0 | while y < h do y *:= {L} 10.0; p -:= 1 od);
|
||||
(y + {L} .5 * {L} .1 ** after >= g | y := h; p +:= 1)
|
||||
end;
|
||||
{reti}
|
||||
|
||||
proc dig_char = (int x) char: "0123456789abcdef"[x+1];
|
||||
|
||||
{ Returns true if the absolute value of the result is
|
||||
<= L max int }
|
||||
|
||||
{iter L {short short} {short} {} {long} {long long}}
|
||||
{iter K {SHORTEN SHORTEN} {SHORTEN} {} {LENG} {LENG LENG}}
|
||||
{iter L_ {short_short_} {short_} {} {long_} {long_long_}}
|
||||
proc string_to_{L_}int = (string s, int radix, ref {L} int i) bool:
|
||||
begin
|
||||
{L} int lr = {K} radix; bool safe := true;
|
||||
{L} int n := {L} 0, {L} int m = {L_}max_int % lr;
|
||||
{L} int m1 = {L_}max_int - m * lr;
|
||||
for i from 2 to UPB s
|
||||
while {L} int dig = {K} char_dig (s[i]);
|
||||
safe := n < m OR n = m AND dig <= m1
|
||||
do n := n * lr + dig od;
|
||||
if safe then i := (s[1] = "+" | n | -n); true else false fi
|
||||
end;
|
||||
{reti}
|
||||
|
||||
{ Returns true if the absolute value of the result is <= L max
|
||||
real. }
|
||||
|
||||
{iter L {} {long} {long long}}
|
||||
{iter K {} {LENG} {LENG LENG}}
|
||||
{iter S {} {SHORTEN} {SHORTEN SHORTEN}}
|
||||
{iter L_ {} {long_} {long_long_}}
|
||||
pub proc string_to_{L_}real = (string s, ref {L} real r) bool:
|
||||
begin
|
||||
int e := UPB s + 1;
|
||||
char_in_string ("^" { XXX unicode 10^ }, e, s);
|
||||
int p := e; char_in_string (".", p, s);
|
||||
int j := 1, length := 0, {L} real x := {L} 0.0;
|
||||
{ Skip leading zeroes: }
|
||||
for i from 2 to e - 1
|
||||
while s[i] = "0" OR s[i] = "." OR s[i] = "_."
|
||||
do j := i od;
|
||||
for i from j + 1 to e - 1 while length < {L_}real_width
|
||||
do
|
||||
if s[i] /= "."
|
||||
then x := x * {L} 10.0 + {K} char_dig (s[j:=i]); length +:= 1
|
||||
fi { all significant digits converted. }
|
||||
od;
|
||||
{ Set preliminary exponent: }
|
||||
int exp := (p > j | p - j - 1 | p - j), expart := 0;
|
||||
{ Convert exponent part: }
|
||||
bool safe := if e < UPB s
|
||||
then {L} int tmp := {K} expart;
|
||||
bool b = string_to_{L_}int (s[e+1:], 10, tmp);
|
||||
expart = {S} tmp;
|
||||
b
|
||||
else true
|
||||
fi;
|
||||
{ Prepare a representation of L max real to compare with the L
|
||||
real value to be delivered: }
|
||||
{L} real max_stag := {L_}max_real, int max_exp := 0;
|
||||
{L_}standardize (max_stag, length, 0, max_exp); exp +:= expart;
|
||||
if ~safe OR (exp > max_exp OR exp = max_exp AND x > max_stag)
|
||||
then false
|
||||
else r := (s[1] = "+" | x | -x) * {L} 10.0 ** exp; true
|
||||
fi
|
||||
end;
|
||||
{reti}
|
||||
|
||||
proc char_dig = (char x) int:
|
||||
(x = "." | 0 | int i; char_in_string (x,i,"0123456789abcdef"); i-1);
|
||||
|
||||
pub proc char_in_string = (char c, ref int i, string s) bool:
|
||||
begin bool found := false;
|
||||
for k from LWB s to UPB s while ~found
|
||||
do (c = s[k] | i := k; found := true) od;
|
||||
found
|
||||
end;
|
||||
|
||||
{ The smallest integral value such that `L max int' may be
|
||||
converted without error using the pattern n(L int width)d }
|
||||
|
||||
{iter L {short short} {short} {} {long} {long long}}
|
||||
{iter L_ {short_short_} {short_} {} {long_} {long_long_}}
|
||||
pub int {L_}int_width =
|
||||
(int c := 1; while {L} 10 ** (c - 1) < {L_}max_int % {L} 10 do c +:= 1 od;
|
||||
c);
|
||||
{reti}
|
||||
|
||||
{ The smallest integral value such that different string are
|
||||
produced by conversion of `1.0' and of `1.0 + L small real'
|
||||
using the pattern d .n(L real width - 1)d }
|
||||
|
||||
{iter L {} {long} {long long}}
|
||||
{iter L_ {} {long_} {long_long_}}
|
||||
{iter S {} {SHORTEN} {SHORTEN SHORTEN}}
|
||||
pub int {L_}real_width = 1 - {S} ENTIER ({L_}ln ({L_}small_real) / {L_}ln ({L} 10));
|
||||
{reti}
|
||||
|
||||
{ The smallest integral value such that `L max real' may be
|
||||
converted without error using the pattern
|
||||
d .n(L real width - 1)d e n(L exp with)d }
|
||||
|
||||
{iter L {} {long} {long long}}
|
||||
{iter L_ {} {long_} {long_long_}}
|
||||
{iter S {} {SHORTEN} {SHORTEN SHORTEN}}
|
||||
pub int {L_}exp_width =
|
||||
1 + {S} ENTIER ({L_}ln ({L_}ln ({L_}max_real) / {L_}ln ({L} 10)) / {L_}ln ({L} 10));
|
||||
{reti}
|
||||
|
||||
skip
|
||||
fed
|
||||
|
||||
@@ -1,279 +0,0 @@
|
||||
{ Process this file with sppp.awk -*- mode: a68 -*- }
|
||||
|
||||
{ transput.a68.in - Standard transput.
|
||||
|
||||
Copyright (C) 2025 Jose E. Marchesi
|
||||
|
||||
GCC is free software; you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free
|
||||
Software Foundation; either version 3, or (at your option) any later
|
||||
version.
|
||||
|
||||
GCC is distributed in the hope that it will be useful, but WITHOUT
|
||||
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
|
||||
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
|
||||
License for more details.
|
||||
|
||||
Under Section 7 of GPL version 3, you are granted additional
|
||||
permissions described in the GCC Runtime Library Exception, version
|
||||
3.1, as published by the Free Software Foundation.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
and a copy of the GCC Runtime Library Exception along with this
|
||||
program; see the files COPYING3 and COPYING.RUNTIME respectively.
|
||||
If not, see <http://www.gnu.org/licenses/>. }
|
||||
|
||||
module Transput =
|
||||
def
|
||||
{ 10.3.2.1. Conversion routines. }
|
||||
|
||||
mode Number = union (
|
||||
{iter L {short short} {short} {} {long} {long long}}
|
||||
{L} int
|
||||
{reti {,}}
|
||||
,
|
||||
{iter L {} {long} {long long}}
|
||||
{L} real
|
||||
{reti {,}}
|
||||
);
|
||||
|
||||
pub proc whole = (Number v, int width) string:
|
||||
case v in
|
||||
{iter L {short short} {short} {} {long} {long long}}
|
||||
{iter L_ {short_short_} {short_} {} {long_} {long_long_}}
|
||||
({L} int x):
|
||||
(int length := ABS width - (x < {L} 0 OR width > 0 | 1 | 0),
|
||||
{L} int n := ABS x;
|
||||
if width = 0
|
||||
then {L} int m := n; length := 0;
|
||||
while m %:= {L} 10; length +:= 1; m /= {L} 0
|
||||
do ~ od
|
||||
fi;
|
||||
string s := subwhole (n, length);
|
||||
if length = 0 OR char_in_string (errorchar, loc int, s)
|
||||
then ABS width * errorchar
|
||||
else (x < {L} 0 | "-" |: width > 0 | "+" | "") +=: s;
|
||||
(width /= 0 | (ABS width - UPB s) * " " +=: s);
|
||||
s
|
||||
fi),
|
||||
({L} real x): fixed (x, width, 0)
|
||||
{reti {,}}
|
||||
esac;
|
||||
|
||||
pub proc fixed = (Number v, int width, after) string:
|
||||
case v in
|
||||
{iter L {} {long} {long long}}
|
||||
({L} real x):
|
||||
if int length := ABS width - (x < {L} 0 OR width > 0 | 1 | 0);
|
||||
after >= 0 AND (length > after OR width = 0)
|
||||
then {L} real y = ABS x;
|
||||
if width = 0
|
||||
then length := (after = 0 | 1 | 0);
|
||||
while y + {L} .5 * {L} .1 ** after >= {L} 10 ** length
|
||||
do length +:= 1 od;
|
||||
length +:= (after = 0 | 0 | after + 1)
|
||||
fi;
|
||||
string s := subfixed (y, length, after);
|
||||
if ~char_in_string (errorchar, loc int, s)
|
||||
then (length > UPB s AND y < {L} 1.0 | "0" +=: s);
|
||||
(x < {L} 0 | "-" |: width > 0 | "+" | "") +=: s;
|
||||
(width /= 0 | (ABS width - UPB s) * " " +=: s);
|
||||
s
|
||||
elif after > 0
|
||||
then fixed (v, width, after - 1)
|
||||
else ABS width * errorchar
|
||||
fi
|
||||
else { XXX undefined } skip; ABS width * errorchar
|
||||
fi,
|
||||
({L} int x): fixed ({L} real (x), width, after)
|
||||
{reti {,}}
|
||||
esac;
|
||||
|
||||
pub proc float = (Number v, int width, after, exp) string:
|
||||
case v in
|
||||
{iter L {} {long} {long long}}
|
||||
{iter L_ {} {long_} {long_long_}}
|
||||
({L} real x):
|
||||
if int before = ABS width - ABS exp - (after /= 0 | after+1 | 0) - 2;
|
||||
SIGN before + SIGN after > 0
|
||||
then string s, {L} real y := ABS x, int p := 0;
|
||||
{L_}standardize (y, before, after, p);
|
||||
s := fixed (SIGN (x * y), SIGN width * (ABS width - ABS exp - 1),
|
||||
after) + "*^" + whole (p, exp);
|
||||
if exp = 0 OR char_in_string (errorchar, loc int, s)
|
||||
then float (x, width, (after /= 0 | after-1 | 0),
|
||||
(exp > 0 | exp+1 | exp-1))
|
||||
else s
|
||||
fi
|
||||
else { XXX undefined } skip; ABS width * errorchar
|
||||
fi,
|
||||
({L} int x): float ({L} real (x), width, after, exp)
|
||||
{reti {,}}
|
||||
esac;
|
||||
|
||||
{ Returns a string of maximum length `width' containing a decimal
|
||||
representation of the positive integer `v'. }
|
||||
|
||||
proc subwhole = (Number v, int width) string:
|
||||
case v in
|
||||
{iter L {short short} {short} {} {long} {long long}}
|
||||
{iter S {LENG LENG} {LENG} {} {SHORTEN} {SHORTEN SHORTEN}}
|
||||
({L} int x):
|
||||
begin string s, {L} int n := x;
|
||||
while dig_char ({S} (n MOD {L} 10)) +=: s;
|
||||
n %:= {L} 10; n /= {L} 0
|
||||
do ~ od;
|
||||
(UPB s > width | width * errorchar | s)
|
||||
end
|
||||
{reti {,}}
|
||||
esac;
|
||||
|
||||
{ Returns a string of maximum length `width' containing a rounded
|
||||
decimal representation of the positive real number `v'; if
|
||||
`after' is greater than zero, this string contains a decimal
|
||||
point followed by `after' digits. }
|
||||
|
||||
proc subfixed = (Number v, int width, after) string:
|
||||
case v in
|
||||
{iter L {} {long} {long long}}
|
||||
{iter K {} {LENG} {LENG LENG}}
|
||||
{iter S {} {SHORTEN} {SHORTEN SHORTEN}}
|
||||
({L} real x):
|
||||
begin string s, int before := 0;
|
||||
{L} real y := x + {L} .5 * {L} .1 ** after;
|
||||
proc choosedig = (ref {L} real y) char:
|
||||
dig_char ((int c := {S} ENTIER (y *:= {L} 10.0); (c > 9 | c := 9);
|
||||
y -:= {K} c; c));
|
||||
while y >= {L} 10.0 ** before do before +:= 1 od;
|
||||
y /:= {L} 10.0 ** before;
|
||||
to before do s +:= choosedig (y) od;
|
||||
(after > 0 | s +:= ".");
|
||||
to after do s +:= choosedig (y) od;
|
||||
(UPB s > width | width * errorchar | s)
|
||||
end
|
||||
{reti {,}}
|
||||
esac;
|
||||
|
||||
{ Adjusts the value of `y' so that it may be transput according to
|
||||
the format $ n(before)d, n(after)d $; `p' is set so that y * 10
|
||||
** p is equal to the original value of `y'. }
|
||||
|
||||
{iter L {} {long} {long long}}
|
||||
{iter L_ {} {long_} {long_long_}}
|
||||
proc {L_}standardize = (ref {L} real y, int before, after, ref int p) void:
|
||||
begin
|
||||
{L} real g = {L} 10.0 ** before; {L} real h = g * {L} .1;
|
||||
while y >= g do y *:= {L} .1; p +:= 1 od;
|
||||
(y /= {L} 0.0 | while y < h do y *:= {L} 10.0; p -:= 1 od);
|
||||
(y + {L} .5 * {L} .1 ** after >= g | y := h; p +:= 1)
|
||||
end;
|
||||
{reti}
|
||||
|
||||
proc dig_char = (int x) char: "0123456789abcdef"[x+1];
|
||||
|
||||
{ Returns true if the absolute value of the result is
|
||||
<= L max int }
|
||||
|
||||
{iter L {short short} {short} {} {long} {long long}}
|
||||
{iter K {SHORTEN SHORTEN} {SHORTEN} {} {LENG} {LENG LENG}}
|
||||
{iter L_ {short_short_} {short_} {} {long_} {long_long_}}
|
||||
proc string_to_{L_}int = (string s, int radix, ref {L} int i) bool:
|
||||
begin
|
||||
{L} int lr = {K} radix; bool safe := true;
|
||||
{L} int n := {L} 0, {L} int m = {L_}max_int % lr;
|
||||
{L} int m1 = {L_}max_int - m * lr;
|
||||
for i from 2 to UPB s
|
||||
while {L} int dig = {K} char_dig (s[i]);
|
||||
safe := n < m OR n = m AND dig <= m1
|
||||
do n := n * lr + dig od;
|
||||
if safe then i := (s[1] = "+" | n | -n); true else false fi
|
||||
end;
|
||||
{reti}
|
||||
|
||||
{ Returns true if the absolute value of the result is <= L max
|
||||
real. }
|
||||
|
||||
{iter L {} {long} {long long}}
|
||||
{iter K {} {LENG} {LENG LENG}}
|
||||
{iter S {} {SHORTEN} {SHORTEN SHORTEN}}
|
||||
{iter L_ {} {long_} {long_long_}}
|
||||
pub proc string_to_{L_}real = (string s, ref {L} real r) bool:
|
||||
begin
|
||||
int e := UPB s + 1;
|
||||
char_in_string ("^" { XXX unicode 10^ }, e, s);
|
||||
int p := e; char_in_string (".", p, s);
|
||||
int j := 1, length := 0, {L} real x := {L} 0.0;
|
||||
{ Skip leading zeroes: }
|
||||
for i from 2 to e - 1
|
||||
while s[i] = "0" OR s[i] = "." OR s[i] = "_."
|
||||
do j := i od;
|
||||
for i from j + 1 to e - 1 while length < {L_}real_width
|
||||
do
|
||||
if s[i] /= "."
|
||||
then x := x * {L} 10.0 + {K} char_dig (s[j:=i]); length +:= 1
|
||||
fi { all significant digits converted. }
|
||||
od;
|
||||
{ Set preliminary exponent: }
|
||||
int exp := (p > j | p - j - 1 | p - j), expart := 0;
|
||||
{ Convert exponent part: }
|
||||
bool safe := if e < UPB s
|
||||
then {L} int tmp := {K} expart;
|
||||
bool b = string_to_{L_}int (s[e+1:], 10, tmp);
|
||||
expart = {S} tmp;
|
||||
b
|
||||
else true
|
||||
fi;
|
||||
{ Prepare a representation of L max real to compare with the L
|
||||
real value to be delivered: }
|
||||
{L} real max_stag := {L_}max_real, int max_exp := 0;
|
||||
{L_}standardize (max_stag, length, 0, max_exp); exp +:= expart;
|
||||
if ~safe OR (exp > max_exp OR exp = max_exp AND x > max_stag)
|
||||
then false
|
||||
else r := (s[1] = "+" | x | -x) * {L} 10.0 ** exp; true
|
||||
fi
|
||||
end;
|
||||
{reti}
|
||||
|
||||
proc char_dig = (char x) int:
|
||||
(x = "." | 0 | int i; char_in_string (x,i,"0123456789abcdef"); i-1);
|
||||
|
||||
pub proc char_in_string = (char c, ref int i, string s) bool:
|
||||
begin bool found := false;
|
||||
for k from LWB s to UPB s while ~found
|
||||
do (c = s[k] | i := k; found := true) od;
|
||||
found
|
||||
end;
|
||||
|
||||
{ The smallest integral value such that `L max int' may be
|
||||
converted without error using the pattern n(L int width)d }
|
||||
|
||||
{iter L {} {long} {long long}}
|
||||
{iter L_ {} {long_} {long_long_}}
|
||||
pub int {L_}int_width =
|
||||
(int c := 1; while {L} 10 ** (c - 1) < {L} .1 * {L_}max_int do c +:= 1 od;
|
||||
c);
|
||||
{reti}
|
||||
|
||||
{ The smallest integral value such that different string are
|
||||
produced by conversion of `1.0' and of `1.0 + L small real'
|
||||
using the pattern d .n(L real width - 1)d }
|
||||
|
||||
{iter L {} {long} {long long}}
|
||||
{iter L_ {} {long_} {long_long_}}
|
||||
{iter S {} {SHORTEN} {SHORTEN SHORTEN}}
|
||||
pub int {L_}real_width = 1 - {S} ENTIER ({L_}ln ({L_}small_real) / {L_}ln ({L} 10));
|
||||
{reti}
|
||||
|
||||
{ The smallest integral value such that `L max real' may be
|
||||
converted without error using the pattern
|
||||
d .n(L real width - 1)d e n(L exp with)d }
|
||||
|
||||
{iter L {} {long} {long long}}
|
||||
{iter L_ {} {long_} {long_long_}}
|
||||
{iter S {} {SHORTEN} {SHORTEN SHORTEN}}
|
||||
pub int {L_}exp_width =
|
||||
1 + {S} ENTIER ({L_}ln ({L_}ln ({L_}max_real) / {L_}ln ({L} 10)) / {L_}ln ({L} 10));
|
||||
{reti}
|
||||
|
||||
skip
|
||||
fed
|
||||
Reference in New Issue
Block a user