https://gcc.gnu.org/g:f4fbf96acccb20b59f34993f1243b1f46ee20a4a
commit r16-7634-gf4fbf96acccb20b59f34993f1243b1f46ee20a4a Author: Jose E. Marchesi <[email protected]> Date: Mon Feb 23 01:29:56 2026 +0100 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 <[email protected]> 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. Diff: --- gcc/algol68/a68-low-ints.cc | 18 -- gcc/algol68/a68-low-prelude.cc | 66 ----- gcc/algol68/a68-low-reals.cc | 28 --- gcc/algol68/a68-parser-prelude.cc | 24 +- gcc/algol68/a68.h | 14 -- gcc/testsuite/algol68/execute/char-in-string-1.a68 | 1 - libga68/Makefile.am | 9 +- libga68/Makefile.in | 9 +- libga68/standard.a68.in | 257 ++++++++++++++++++- libga68/transput.a68.in | 279 --------------------- 10 files changed, 262 insertions(+), 443 deletions(-) diff --git a/gcc/algol68/a68-low-ints.cc b/gcc/algol68/a68-low-ints.cc index 07b51e51d089..72953d24d6f4 100644 --- a/gcc/algol68/a68-low-ints.cc +++ b/gcc/algol68/a68-low-ints.cc @@ -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. */ diff --git a/gcc/algol68/a68-low-prelude.cc b/gcc/algol68/a68-low-prelude.cc index 533b9261afe9..8b9d973327f4 100644 --- a/gcc/algol68/a68-low-prelude.cc +++ b/gcc/algol68/a68-low-prelude.cc @@ -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) { diff --git a/gcc/algol68/a68-low-reals.cc b/gcc/algol68/a68-low-reals.cc index adb0257d6ff6..4f2d74c5edeb 100644 --- a/gcc/algol68/a68-low-reals.cc +++ b/gcc/algol68/a68-low-reals.cc @@ -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. */ diff --git a/gcc/algol68/a68-parser-prelude.cc b/gcc/algol68/a68-parser-prelude.cc index 46412bc88aa7..67edf55f9f7b 100644 --- a/gcc/algol68/a68-parser-prelude.cc +++ b/gcc/algol68/a68-parser-prelude.cc @@ -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 (); } diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h index f9c7d2e62928..13603061290c 100644 --- a/gcc/algol68/a68.h +++ b/gcc/algol68/a68.h @@ -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); diff --git a/gcc/testsuite/algol68/execute/char-in-string-1.a68 b/gcc/testsuite/algol68/execute/char-in-string-1.a68 index 5ae821f654d8..a2143b2d9360 100644 --- a/gcc/testsuite/algol68/execute/char-in-string-1.a68 +++ b/gcc/testsuite/algol68/execute/char-in-string-1.a68 @@ -1,4 +1,3 @@ -access Transput begin int pos; assert (char_in_string ("o", pos, "foo")); assert (pos = 2) diff --git a/libga68/Makefile.am b/libga68/Makefile.am index 4430e1ef0f17..073e71c611e7 100644 --- a/libga68/Makefile.am +++ b/libga68/Makefile.am @@ -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) diff --git a/libga68/Makefile.in b/libga68/Makefile.in index d5ed7df7f486..2b91a5e952fe 100644 --- a/libga68/Makefile.in +++ b/libga68/Makefile.in @@ -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 $< > $@ diff --git a/libga68/standard.a68.in b/libga68/standard.a68.in index 1758d8a2fc99..6d543e7cff86 100644 --- a/libga68/standard.a68.in +++ b/libga68/standard.a68.in @@ -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 diff --git a/libga68/transput.a68.in b/libga68/transput.a68.in deleted file mode 100644 index 4dbef44ddfc3..000000000000 --- a/libga68/transput.a68.in +++ /dev/null @@ -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
