[RFC 1/3] a68: initial Algol 68 standard prelude in libga68
Jose E. Marchesi
jemarch@gnu.org
Wed Dec 10 16:41:53 GMT 2025
Most of the standard prelude is implemented in a combination of code
lowered by the front-end (standard operators, contants, etc) and
functions provided by the libga68 run-time library, to which the
former libcalls. Until now, all the support routines in libga68 were
written in C. However, many of the transput facilities are better
implemented in Algol 68.
The Revised Report includes an implementation (code listing) of many
of the standard routines. This implementation, however, makes use of
an "extended" program notation in order to denote certain notions to
avoid repetitive code. Therefore this commit includes sppp, a
build-time pre-processor written in awk that is only intended to be
used internally by the libga68 run-time library. This preprocessor
allows us to write code like:
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;
Resulting in cases for short short int, short int, int, long int and
long long int being macro-expanded in the routine's conformance
clause.
This commit adds the necessary infrastructure for writing Algol 68
code in the libga68 library, including the ability of having modules
exported by libga68. An implementation of some of the transput
routines is also provided in standard.a68: whole, fixed, float,
string_to_L_real, char_in_string, L_int_width, L_real_width and
L_exp_with.
Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
libga68/ChangeLog
* sppp.awk: New file.
* standard.a68.in: Likewise.
gcc/algol68/ChangeLog
* a68-lang.cc: register modules in libga68.
---
gcc/algol68/a68-lang.cc | 1 +
libga68/sppp.awk | 94 ++++++++++++++
libga68/standard.a68.in | 279 ++++++++++++++++++++++++++++++++++++++++
3 files changed, 374 insertions(+)
create mode 100644 libga68/sppp.awk
create mode 100644 libga68/standard.a68.in
diff --git a/gcc/algol68/a68-lang.cc b/gcc/algol68/a68-lang.cc
index f5f316a3fdb..db3d39dd645 100644
--- a/gcc/algol68/a68-lang.cc
+++ b/gcc/algol68/a68-lang.cc
@@ -242,6 +242,7 @@ a68_init (void)
/* Create an empty module files map. */
A68_MODULE_FILES = hash_map<nofree_string_hash,const char*>::create_ggc (16);
A68_MODULE_FILES->empty ();
+ A68_MODULE_FILES->put (ggc_strdup ("STANDARD"), ggc_strdup ("ga68"));
return true;
}
diff --git a/libga68/sppp.awk b/libga68/sppp.awk
new file mode 100644
index 00000000000..e2701e03b17
--- /dev/null
+++ b/libga68/sppp.awk
@@ -0,0 +1,94 @@
+# sppp - the Standard Prelude Pre-Processor
+#
+# Copyright (C) 2025 Jose E. Marchesi
+#
+# This file 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 of the License, or
+# (at your option) any later version.
+#
+# This program 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.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+function error(msg)
+{
+ print FILENAME ":" msg | "cat 1>&2"
+ exit (1)
+}
+
+BEGIN {
+ num_alternatives = 0
+ in_iter = 0
+ template = ""
+}
+
+/^[ \t]*\{ Process this file/ {
+ print "{ This is auto-generated from " FILENAME ". Do not edit. }"
+ next
+}
+
+/^[ \t]*\{[ \t]*iter[ \t]+/ {
+ if (match ($0, /[ \t]*\{[ \t]*iter[ \t]+([a-zA-Z_]+)[\t ]*(\{.*\}[ \t]*){1,}[ \t]*\}/, matches) == 0)
+ error(FNR ": invalid iter")
+
+ iter_name = matches[1]
+ iter_alts = matches[2]
+
+ # Count and collect alternatives. #
+ iter_num_alternatives = 0
+ while (match (iter_alts, /[ \t]*\{([^\}]*)\}/, matches) > 0)
+ {
+ iter_num_alternatives++
+ iter_alts = substr (iter_alts, RSTART + RLENGTH)
+ iter_names[iter_name] = 1
+ iterators[iter_name,iter_num_alternatives] = matches[1]
+ }
+
+ if (in_iter == 1)
+ {
+ if (iter_num_alternatives != num_alternatives)
+ error(FNR ": invalid number of alternatives in iterator")
+ }
+
+ num_alternatives = iter_num_alternatives
+ in_iter = 1
+ next
+}
+
+/^[ \t]*\{[ \t]*reti/ {
+ separator = ""
+ if (match ($0, /[ \t]*\{[ \t]*reti[ \t]+\{([^\}]*)\}/, matches) > 0)
+ separator = matches[1]
+
+ for (nalt = 1; nalt <= num_alternatives; nalt++)
+ {
+ output = template
+ for (iter_name in iter_names)
+ {
+ while (sub ("\\{" iter_name "\\}", iterators[iter_name,nalt], output)) {}
+ }
+ printf "%s%s\n", substr (output, 0, length(output) - 1), nalt < num_alternatives ? separator : ""
+ }
+
+ for (key in iter_names) delete iter_names[key]
+ for (key in iterators) delete iterators[key]
+ in_iter = 0;
+ template = ""
+ num_alternatives = 0
+ next
+}
+
+in_iter == 1 {
+ template = template $0 "\n"
+ next
+}
+
+{
+ print $0
+}
diff --git a/libga68/standard.a68.in b/libga68/standard.a68.in
new file mode 100644
index 00000000000..236589b5e91
--- /dev/null
+++ b/libga68/standard.a68.in
@@ -0,0 +1,279 @@
+{ Process this file with sppp.awk to get standard.a68 }
+
+{ standard.a68.in - Standard prelude.
+
+ 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 Standard =
+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
--
2.30.2
More information about the Algol68
mailing list