[COMMITTED 4/6] a68: implementation of L bits_pack in standard prelude

[Jose E. Marchesi]

Signed-off-by: Jose E. Marchesi <jema...@gnu.org>

gcc/algol68/ChangeLog

        * a68-parser-prelude.cc (stand_prelude): Remove definitions for
        bitpacks.

gcc/testsuite/ChangeLog

        * algol68/compile/warning-hidding-4.a68: Mention bitspack.

libga68/ChangeLog

        * standard.a68.in ({L_}bits_pack): New procedures.
---
 gcc/algol68/a68-parser-prelude.cc              | 17 +----------------
 .../algol68/compile/warning-hidding-4.a68      |  1 +
 libga68/standard.a68.in                        | 18 ++++++++++++++++++
 3 files changed, 20 insertions(+), 16 deletions(-)

diff --git a/gcc/algol68/a68-parser-prelude.cc 
b/gcc/algol68/a68-parser-prelude.cc
index e283c2c3f11..46412bc88aa 100644
--- a/gcc/algol68/a68-parser-prelude.cc
+++ b/gcc/algol68/a68-parser-prelude.cc
@@ -414,23 +414,8 @@ stand_prelude (void)
   a68_idf (A68_STD, "errorchar", M_CHAR, a68_lower_errorchar);
   a68_idf (A68_STD, "nullcharacter", M_CHAR, a68_lower_nullcharacter);
   a68_idf (A68_STD, "blank", M_CHAR, a68_lower_blank);
-  /* BITS procedures.  */
-  MOID_T *m = a68_proc (M_BITS, M_ROW_BOOL, NO_MOID);
-  a68_idf (A68_STD, "bitspack", m);
-  /* SHORT BITS procedures.  */
-  m = a68_proc (M_SHORT_BITS, M_ROW_BOOL, NO_MOID);
-  a68_idf (A68_STD, "shortbitspack", m);
-  /* SHORT SHORT BITS procedures.  */
-  m = a68_proc (M_SHORT_SHORT_BITS, M_ROW_BOOL, NO_MOID);
-  a68_idf (A68_STD, "shortshortbitspack", m);
-  /* LONG BITS procedures.  */
-  m = a68_proc (M_LONG_BITS, M_ROW_BOOL, NO_MOID);
-  a68_idf (A68_STD, "longbitspack", m);
-  /* LONG LONG BITS procedures.  */
-  m = a68_proc (M_LONG_LONG_BITS, M_ROW_BOOL, NO_MOID);
-  a68_idf (A68_STD, "longlongbitspack", m);
   /* RNG procedures.  */
-  m = a68_proc (M_VOID, M_INT, NO_MOID);
+  MOID_T *m = a68_proc (M_VOID, M_INT, NO_MOID);
   a68_idf (A68_STD, "firstrandom", m);
   /* REAL procedures.  */
   m = A68_MCACHE (proc_real);
diff --git a/gcc/testsuite/algol68/compile/warning-hidding-4.a68 
b/gcc/testsuite/algol68/compile/warning-hidding-4.a68
index 0078e6a593f..4478da144dd 100644
--- a/gcc/testsuite/algol68/compile/warning-hidding-4.a68
+++ b/gcc/testsuite/algol68/compile/warning-hidding-4.a68
@@ -1,5 +1,6 @@
 { dg-options "-Whidden-declarations" }
 begin
+      int bitspack = 10; { dg-warning "" }
       op UPB = (int i, union (int,string) v) int: { dg-warning "hides" }
          (v | (string s): UPB s | 0);
       UPB "lala"
diff --git a/libga68/standard.a68.in b/libga68/standard.a68.in
index 630c7e5a239..1758d8a2fc9 100644
--- a/libga68/standard.a68.in
+++ b/libga68/standard.a68.in
@@ -25,5 +25,23 @@
 
 module Standard =
 def
+    { 10.2.3.8.l L bitspack
+      ───────────────────── }
+
+    {iter L  {short short}  {short}  {} {long}  {long long}}
+    {iter L_ {short_short_} {short_} {} {long_} {long_long_}}
+    pub proc {L_}bits_pack = ([]bool a) {L} bits:
+       if int n = UPB a[@1];
+          n <= {L_}bits_width
+       then {L} bits c := {L} 16r0;
+            for i to {L_}bits_width
+            do if i > {L_}bits_width - n
+                  andth a[@1][i - {L_}bits_width + n]
+               then c := c OR ({L} 2r1 SHL ({L_}bits_width - i)) fi
+            od;
+            c
+       fi;
+    {reti}
+
     skip
 fed
-- 
2.39.5