a68: implementation of L bits_pack in standard prelude

Signed-off-by: Jose E. Marchesi <jemarch@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.

diff --git a/gcc/algol68/a68-parser-prelude.cc b/gcc/algol68/a68-parser-prelude.cc
index e283c2c3f1170d6bbedcd781b83a99a088a978b9..46412bc88aa731e91c7063ca80c30882ab39c94c 100644 (file)
--- 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 0078e6a593f919e3ded6b281d2ffb9607ebd821a..4478da144dddee06ffb0ea0e6cb42496811fbf7f 100644 (file)
--- 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 630c7e5a2399327c462a0f8164a1a434037b6112..1758d8a2fc996a7b685773f23e3e975b9e12fce8 100644 (file)
--- 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