https://gcc.gnu.org/g:08ad2ccb6cb660b7792d2928f2a363d23a2f993a
commit r17-5580-g08ad2ccb6cb660b7792d2928f2a363d23a2f993a Author: James LeBlanc <[email protected]> Date: Sun Oct 25 23:00:05 2026 +0100 a68: add some standard operators for SIZETY compl Signed-off-by: James LeBlanc <[email protected]> Co-authored-by: Jose E. Marchesi <[email protected]> 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. Diff: --- 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(-) diff --git a/gcc/algol68/a68-parser-prelude.cc b/gcc/algol68/a68-parser-prelude.cc index b46777f590be..c9e71b4c5a75 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 000000000000..b6d5477c9c4d --- /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 5ecb36b4a370..adda912465a9 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 }}
