[COMMITTED] a68: add some standard operators for SIZETY compl
Jose E. Marchesi
jemarch@gnu.org
Mon Oct 26 13:11:29 GMT 2026
Signed-off-by: James LeBlanc <jpl.algol68@gmail.com>
Co-authored-by: Jose E. Marchesi <jemarch@gnu.org>
gcc/algol68/ChangeLog
* a68-parser-prelude.cc (stand_prelude): Do not declare compl
operators, as these are now defined in standard.a68.
libga68/ChangeLog
* standard.a68.in (=): New operator on SIZETY compl.
(EQ): Likewise.
(/=): Likewise.
(NE): Likewise.
(+): Likewise
(+:=): Likewise.
(PLUSAB): Likewise.
(-): Likewise.
(-:=): Likewise.
(MINUSAB): Likewise.
(*): Likewise.
(*:=): Likewise.
(TIMESAB): Likewise.
(/): Likewise.
(/:=): Likewise.
(DIVAB): Likewise.
(CONJ): Likewise.
(ABS): Likewise.
(ARG): Likewise.
gcc/testsuite/ChangeLog
* algol68/execute/compl-1.a68: New test.
---
gcc/algol68/a68-parser-prelude.cc | 76 --------------------
gcc/testsuite/algol68/execute/compl-1.a68 | 84 +++++++++++++++++++++++
libga68/standard.a68.in | 83 ++++++++++++++++++----
3 files changed, 154 insertions(+), 89 deletions(-)
create mode 100644 gcc/testsuite/algol68/execute/compl-1.a68
diff --git a/gcc/algol68/a68-parser-prelude.cc b/gcc/algol68/a68-parser-prelude.cc
index b46777f590b..c9e71b4c5a7 100644
--- a/gcc/algol68/a68-parser-prelude.cc
+++ b/gcc/algol68/a68-parser-prelude.cc
@@ -1155,35 +1155,10 @@ stand_prelude (void)
m = a68_proc (M_REAL, M_COMPLEX, NO_MOID);
a68_op (A68_STD, "RE", m, a68_lower_re2);
a68_op (A68_STD, "IM", m, a68_lower_im2);
- a68_op (A68_STD, "ABS", m);
- a68_op (A68_STD, "ARG", m);
- m = A68_MCACHE (proc_complex_complex);
- a68_op (A68_STD, "+", m);
- a68_op (A68_STD, "-", m);
- a68_op (A68_STD, "CONJ", m, a68_lower_conj2);
- m = a68_proc (M_BOOL, M_COMPLEX, M_COMPLEX, NO_MOID);
- a68_op (A68_STD, "=", m);
- a68_op (A68_STD, "/=", m);
- a68_op (A68_STD, "EQ", m);
- a68_op (A68_STD, "NE", m);
- m = a68_proc (M_COMPLEX, M_COMPLEX, M_COMPLEX, NO_MOID);
- a68_op (A68_STD, "+", m);
- a68_op (A68_STD, "-", m);
- a68_op (A68_STD, "*", m);
- a68_op (A68_STD, "/", m);
m = a68_proc (M_COMPLEX, M_COMPLEX, M_INT, NO_MOID);
a68_op (A68_STD, "**", m);
a68_op (A68_STD, "UP", m);
a68_op (A68_STD, "^", m);
- m = a68_proc (M_REF_COMPLEX, M_REF_COMPLEX, M_COMPLEX, NO_MOID);
- a68_op (A68_STD, "+:=", m);
- a68_op (A68_STD, "-:=", m);
- a68_op (A68_STD, "*:=", m);
- a68_op (A68_STD, "/:=", m);
- a68_op (A68_STD, "PLUSAB", m);
- a68_op (A68_STD, "MINUSAB", m);
- a68_op (A68_STD, "TIMESAB", m);
- a68_op (A68_STD, "DIVAB", m);
m = a68_proc (M_COMPLEX, M_COMPLEX, NO_MOID);
a68_op (A68_STD, "SHORTEN", m);
/* LONG COMPLEX operators */
@@ -1204,35 +1179,10 @@ stand_prelude (void)
m = a68_proc (M_LONG_REAL, M_LONG_COMPLEX, NO_MOID);
a68_op (A68_STD, "RE", m, a68_lower_re2);
a68_op (A68_STD, "IM", m, a68_lower_im2);
- a68_op (A68_STD, "ARG", m);
- a68_op (A68_STD, "ABS", m);
- m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID);
- a68_op (A68_STD, "+", m);
- a68_op (A68_STD, "-", m);
- a68_op (A68_STD, "CONJ", m, a68_lower_conj2);
- m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID);
- a68_op (A68_STD, "+", m);
- a68_op (A68_STD, "-", m);
- a68_op (A68_STD, "*", m);
- a68_op (A68_STD, "/", m);
m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, M_INT, NO_MOID);
a68_op (A68_STD, "**", m);
a68_op (A68_STD, "UP", m);
a68_op (A68_STD, "^", m);
- m = a68_proc (M_BOOL, M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID);
- a68_op (A68_STD, "=", m);
- a68_op (A68_STD, "EQ", m);
- a68_op (A68_STD, "/=", m);
- a68_op (A68_STD, "NE", m);
- m = a68_proc (M_REF_LONG_COMPLEX, M_REF_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID);
- a68_op (A68_STD, "+:=", m);
- a68_op (A68_STD, "-:=", m);
- a68_op (A68_STD, "*:=", m);
- a68_op (A68_STD, "/:=", m);
- a68_op (A68_STD, "PLUSAB", m);
- a68_op (A68_STD, "MINUSAB", m);
- a68_op (A68_STD, "TIMESAB", m);
- a68_op (A68_STD, "DIVAB", m);
/* LONG LONG COMPLEX operators. */
m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID);
a68_op (A68_STD, "I", m, a68_lower_longlonginti);
@@ -1243,35 +1193,10 @@ stand_prelude (void)
m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, NO_MOID);
a68_op (A68_STD, "RE", m, a68_lower_re2);
a68_op (A68_STD, "IM", m, a68_lower_im2);
- a68_op (A68_STD, "ARG", m);
- a68_op (A68_STD, "ABS", m);
- m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID);
- a68_op (A68_STD, "+", m);
- a68_op (A68_STD, "-", m);
- a68_op (A68_STD, "CONJ", m, a68_lower_conj2);
- m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID);
- a68_op (A68_STD, "+", m);
- a68_op (A68_STD, "-", m);
- a68_op (A68_STD, "*", m);
- a68_op (A68_STD, "/", m);
m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, M_INT, NO_MOID);
a68_op (A68_STD, "**", m);
a68_op (A68_STD, "UP", m);
a68_op (A68_STD, "^", m);
- m = a68_proc (M_BOOL, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID);
- a68_op (A68_STD, "=", m);
- a68_op (A68_STD, "EQ", m);
- a68_op (A68_STD, "/=", m);
- a68_op (A68_STD, "NE", m);
- m = a68_proc (M_REF_LONG_LONG_COMPLEX, M_REF_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID);
- a68_op (A68_STD, "+:=", m);
- a68_op (A68_STD, "-:=", m);
- a68_op (A68_STD, "*:=", m);
- a68_op (A68_STD, "/:=", m);
- a68_op (A68_STD, "PLUSAB", m);
- a68_op (A68_STD, "MINUSAB", m);
- a68_op (A68_STD, "TIMESAB", m);
- a68_op (A68_STD, "DIVAB", m);
m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID);
a68_op (A68_STD, "LENG", m);
/* SEMA operators. */
@@ -1283,7 +1208,6 @@ stand_prelude (void)
a68_op (A68_STD, "UP", m);
a68_op (A68_STD, "DOWN", m);
-
/* Load Algol 68 parts. */
if (!flag_building_libga68)
a68_extract_revelation (A68_STANDENV, LINE (INFO (TOP_NODE (&A68_JOB))),
diff --git a/gcc/testsuite/algol68/execute/compl-1.a68 b/gcc/testsuite/algol68/execute/compl-1.a68
new file mode 100644
index 00000000000..b6d5477c9c4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/compl-1.a68
@@ -0,0 +1,84 @@
+begin real eps := 1e-5;
+ long real epsl := long 1e-13;
+ long long real epsll := long long 1e-13;
+
+ { COMPL -------------------------------------------}
+ compl a := (1.2, 3.4);
+ compl b := (5.6, -7.8);
+ long compl aa := (Leng 1.2, Leng 3.4);
+ long compl bb := (Leng 5.6, Leng -7.8);
+ long long compl aaa := (Leng Leng 1.2, Leng Leng 3.4);
+ long long compl bbb := (Leng Leng 5.6, Leng Leng-7.8);
+
+ compl c, rt;
+ long compl cc, rtl;
+ long long compl ccc, rtll;
+
+ { first verify absolute value, and subtraction so they can be
+ used for testing }
+ assert( (Abs(b) - 9.602083107326242) < eps);
+ assert( (Abs(bb) - Leng 9.602083107326242) < epsl);
+ assert( (Abs(bbb) - Leng Leng 9.602083107326242) < epsll);
+
+ c := a-b;
+ cc := aa-bb;
+ ccc := aaa-bbb;
+ assert( Abs(re'c - -4.4) < eps); assert( Abs(im'c - 11.2) < eps);
+ assert( Abs(re'cc - Leng -4.4) < epsl);
+ assert( Abs(im'cc - Leng 11.2) < epsl);
+ assert( Abs(re'ccc - Leng Leng -4.4) < epsll);
+ assert( Abs(im'ccc - Leng Leng 11.2) < epsll);
+
+ { now, we proceed with the rest }
+ c := a+b;
+ cc := aa+bb;
+ ccc := aaa+bbb;
+
+ { right answers }
+ rt := (6.8, -4.4);
+ rtl := (Leng 6.8, Leng -4.4);
+ rtll := (Leng Leng 6.8, Leng Leng -4.4);
+ assert( Abs(c-rt) < eps );
+ assert( Abs(cc-rtl) < epsl );
+ assert( Abs(ccc-rtll) < epsll );
+
+ c := a*b;
+ cc := aa*bb;
+ ccc := aaa*bbb;
+
+ { right answers }
+ rt := (33.24, 9.68);
+ rtl := (Leng 33.24, Leng 9.68);
+ rtll := (Leng Leng 33.24, Leng Leng 9.68);
+ assert( Abs(c-rt) < eps );
+ assert( Abs(cc-rtl) < epsl );
+ assert( Abs(ccc-rtll) < epsll );
+
+ c := a/b;
+ cc := aa/bb;
+ ccc := aaa/bbb;
+
+ { right answers }
+ rt := (-0.214750542299349, 0.308026030368764);
+ rtl := (Leng -0.214750542299349, Leng 0.308026030368764);
+ rtll := (Leng Leng-0.214750542299349, Leng Leng 0.308026030368764);
+ assert( Abs(c-rt) < eps );
+ assert( Abs(cc-rtl) < epsl );
+ assert( Abs(ccc-rtll) < epsll );
+
+ c := Conj a;
+ cc := Conj aa;
+ ccc := Conj aaa;
+ assert( re'c = re'a And im'c = -im'a );
+ assert( re'cc = re'aa And im'cc = -im'aa );
+ assert( re'ccc = re'aaa And im'ccc = -im'aaa );
+
+ assert( Abs(Arg(a)- 1.231503712340852) < eps );
+ assert( Abs(Arg(b) - -0.948125538037829) < eps);
+ assert( Abs(Arg(aa)- Leng 1.231503712340852) < epsl );
+ assert( Abs(Arg(bb) - -Leng 0.948125538037829) < epsl);
+ assert( Abs(Arg(aaa)- Leng Leng 1.231503712340852) < epsll);
+ assert( Abs(Arg(bbb) - Leng Leng -0.948125538037829) < epsll);
+
+ skip
+end
diff --git a/libga68/standard.a68.in b/libga68/standard.a68.in
index 5ecb36b4a37..adda912465a 100644
--- a/libga68/standard.a68.in
+++ b/libga68/standard.a68.in
@@ -29,6 +29,63 @@ def
{ L bits_width are implemented in compiler. }
+ { 10.2.3.7 Operations on complex operands }
+
+ {iter L {} {long} {long long}}
+ {iter K {} {LENG} {LENG LENG}}
+ {iter L_ {} {long_} {long_long_}}
+ pub op = = ({L} compl a,b) bool: (re'a = re'b AND im'a = im'b);
+ pub op EQ = ({L} compl a,b) bool: a = b;
+
+ pub op /= = ({L} compl a,b) bool: NOT (a = b);
+ pub op NE = ({L} compl a,b) bool: a /= b;
+
+ pub op + = ({L} compl a,b) {L} compl: (re'a + re'b, im'a + im'b);
+ pub op +:= = (ref {L} compl a, {L} compl b) ref {L} compl:
+ (a := a + b; a);
+ pub op PLUSAB = (ref {L} compl a, {L} compl b) ref {L} compl:
+ a +:= b;
+
+ pub op - = ({L} compl a) {L} compl: (-re'a, -im'a);
+ pub op - = ({L} compl a,b) {L} compl: (re'a - re'b, im'a - im'b);
+ pub op -:= = (ref {L} compl a, {L} compl b) ref {L} compl:
+ (a := a - b; a);
+ pub op MINUSAB = (ref {L} compl a, {L} compl b) ref {L} compl:
+ a -:= b;
+
+ pub op * = ({L} compl a,b) {L} compl:
+ (re'a * re'b - im'a * im'b, re'a * im'b + im'a * re'b);
+ pub op *:= = (ref {L} compl a, {L} compl b) ref {L} compl:
+ (a := a * b; a);
+ pub op TIMESAB = (ref {L} compl a, {L} compl b) ref {L} compl:
+ a *:= b;
+
+ pub op / = ({L} compl a,b) {L} compl:
+ begin
+ {L} real d = re'(b * CONJ b);
+ {L} compl n = a * CONJ b;
+ (re'n/d, im'n/d)
+ end;
+
+ pub op /:= = (ref {L} compl a, {L} compl b) ref {L} compl:
+ (a := a / b; a);
+ pub op DIVAB = (ref {L} compl a, {L} compl b) ref {L} compl:
+ a /:= b;
+
+ pub op CONJ = ({L} compl z) {L} compl: (re'z, -im'z);
+ pub op ABS = ({L} compl z) {L} real: {L_}sqrt(re'z*re'z + im'z*im'z);
+
+ pub op ARG = ({L} compl z) {L} real:
+ if {L} real zr = re'z, zi = im'z;
+ zr /= {L} 0 OR zi /= {L} 0
+ then if ABS zr > ABS zi
+ then {L_}arctan(zi/zr)
+ + {L_}pi/{L} 2*(zi<{L} 0 | {K} SIGN zr - {L} 1 | {L} 1 - {K} SIGN zr)
+ else -{L_}arctan(zr/zi) + {L_}pi/{L} 2*{K} SIGN zi
+ fi
+ fi;
+ {reti}
+
{ 10.2.3.8.l L bitspack. }
{iter L {short short} {short} {} {long} {long long}}
@@ -59,19 +116,19 @@ def
);
{ The definition of mode Integer used by both the RR subwhole and this one. }
-
+
mode Integer = union (
{iter L {long long } {long } {} {short } {short short }}
{L}int
{reti {,}}
);
-
+
{ The whole_powers_of_10 row is used to look up the appropriate power of 10 for
each integer division required to select the leading in the conversion
process, for each integer multiplication to eliminate the leading digit,
and in the lookup operator WHOLEDIGITS to determine the number of digits in
the integer to be converted. }
-
+
int whole_max_entry := 1;
long long int whole_p10 := long long 1;
long long int whole_stop_after = long_long_max_int % long long 10;
@@ -87,11 +144,11 @@ def
whole_p10 %:= long long 10;
whole_max_entry -:= 1
od;
-
+
{ The WHOLEDIGITS operator is used to determine the number of decimal digits in a
number. We convert the operand to long long and make it negative if
necessary, to allow for twos-complement minimum (negative) integer. }
-
+
op WHOLEDIGITS = (Integer number) int:
begin
long long int work =
@@ -108,15 +165,15 @@ def
do num_digits +:= 1 od;
num_digits
end { WHOLEDIGITS };
-
+
{ proc whole checks for a too-small width, returning a string of the error
character if so; it left-pads the result with blanks as necessary and the
sign as necessary; and it relies on subwhole to do the actual digit
conversion. The [] result returned is either exactly the number of chars
needed (width = 0) to hold the converted integer and negative sign if < 0
or width characters (width ≠ 0). }
-
-
+
+
pub proc whole = (Number v, int width) string:
case v in
{iter L {long long } {long } {} {short } {short short }}
@@ -205,22 +262,22 @@ def
esac;
{ The RR proc subwhole looks like
-
+
proc ℵ₀ subwhole = (number v, int width) string: { implementation };
-
+
We deviate from that design below. This means that, should someone copy
proc putf from the RR, they must recognize that the subwhole mentioned
there is no longer defined here, and make adjustments.
-
+
I considered calling this subwhole something else (whole_do_conv for example)
but that would mean anyone else calling subwhole hoping to get the new
version would silently get the old subwhole instead.
-
+
This subwhole converts digit by digit from left to right. It relies on the
caller having padded out the buffer with spaces and sign as required and
begins filling digits starting at the value passed in buf_ch. The final
[]char array and final value of buf_ch are returned. }
-
+
proc subwhole = (Integer v, ref []char buffer, ref int buf_ch) void:
case int char_zero = ABS "0"; v in
{iter L {long long } {long } {} {short } {short short }}
--
2.39.5
More information about the Algol68
mailing list