Add a test (currently failing) to check that Pascal char sets can store all 256

possible values. Add the PowerPC ncg and mcg backend support to let the test
actually run, including modifying a bunch of PowrePC libem functions so that
they can be called from both ncg and mcg.

mach/powerpc/libem/ior.s

@@ -3,11 +3,13 @@
 .sect .text
 
 ! Set union.
-!  Stack: ( b a -- a+b )
+!  Stack: ( size b a -- a+b )
-!  With r3 = size of set
 
 .define .ior
 .ior:
+	lwz r3, 0 (sp)
+	addi sp, sp, 4
+
 	mr	r4, sp			! r4 = ptr to set a
 	add	r5, sp, r3		! r5 = ptr to set b
 	rlwinm	r6, r3, 30, 2, 31

mach/powerpc/libem/rck.s

@@ -0,0 +1,22 @@
+#include "powerpc.h"
+
+.sect .text
+
+! Bounds check. Traps if the value is out of range.
+!  Stack: ( descriptor value -- )
+
+.define .rck
+.rck:
+    lwz r3, 0 (sp)
+    lwz r4, 4 (sp)
+    addi sp, sp, 8
+
+    lwz r5, 0 (r3)
+    cmp cr0, 0, r4, r5
+    bc IFTRUE, LT, .trap_erange
+
+    lwz r5, 4 (r3)
+    cmp cr0, 0, r4, r5
+    bc IFTRUE, GT, .trap_erange
+
+	bclr ALWAYS, 0, 0

mach/powerpc/libem/set.s

@@ -3,11 +3,14 @@
 .sect .text
 
 ! Create singleton set.
-!  Stack: ( -- set )
+!  Stack: ( size bitnumber -- set )
-!  With r3 = size of set, r4 = bit number
 
 .define .set
 .set:
+	lwz     r3, 0 (sp)
+	lwz     r4, 4 (sp)
+	addi    sp, sp, 8
+
 	rlwinm	r7, r3, 30, 2, 31
 	neg	r5, r3
 	add	sp, sp, r5		! allocate set

mach/powerpc/libem/zer.s

@@ -3,11 +3,13 @@
 .sect .text
 
 ! Create empty set.
-!  Stack: ( -- set )
+!  Stack: ( size -- set )
-!  With r3 = size of set
 
 .define .zer
 .zer:
+	lwz     r3, 0(sp)
+	addi    sp, sp, 4
+
 	rlwinm	r7, r3, 30, 2, 31
 	addi	r4, r0, 0		! r4 = zero
 	neg	r5, r3

mach/powerpc/ncg/table

@@ -1503,18 +1503,14 @@ PATTERNS
 			yields {OR_RC, %2, lo(%1.val)}
 
 	pat ior defined($1)                /* OR set */
-		with STACK
+		leaving
-			kills ALL
+			loc $1
-			gen
+			cal ".ior"
-				move {CONST, $1}, R3
-				bl {LABEL, ".ior"}
 
 	/* OR set (variable), used in lang/m2/libm2/LtoUset.e */
 	pat ior !defined($1)
-		with GPR3 STACK
+		leaving
-			kills ALL
+			cal ".ior"
-			gen
-				bl {LABEL, ".ior"}
 
 	pat xor $1==4                      /* XOR word */
 		with REG REG
@@ -1573,11 +1569,9 @@ PATTERNS
 			loc 0
 
 	pat zer defined($1)	   	           /* Create empty set */
-		with STACK
+		leaving
-			kills ALL
+			loc $1
-			gen
+			cal ".zer"
-				move {CONST, $1}, R3
-				bl {LABEL, ".zer"}
 
 	pat sli $1==4                      /* Shift left (second << top) */
 		with CONST_ALL GPR
@@ -1655,27 +1649,19 @@ PATTERNS
 /* Sets */
 
 	pat set defined($1)                /* Create singleton set */
-		with GPR4 STACK
+		leaving
-			kills ALL
+			loc $1
-			gen
+			cal ".set"
-				move {CONST, $1}, R3
-				bl {LABEL, ".set"}
 
 	/* Create set (variable), used in lang/m2/libm2/LtoUset.e */
 	pat set !defined($1)
-		with GPR3 GPR4 STACK
+		leaving
-			kills ALL
+			cal ".set"
-			gen
-				bl {LABEL, ".set"}
 
 	pat inn defined($1)                /* Test for set bit */
-		with STACK
+		leaving
-			kills ALL
+			loc $1
-			uses REG
+			cal ".inn"
-			gen
-				li32 %a, {CONST, $1}
-				stwu %a, {GPRINDIRECT, SP, 0-4}
-				bl {LABEL, ".inn"}
 
 
 /* Boolean resolutions */
@@ -2066,6 +2052,16 @@ PATTERNS
 			loc $1
 			ass 4
 
+	pat lae rck $2==4                  /* Range check */
+		with GPR
+			uses CR0
+			gen
+				cmpli %a, {CONST, 0}, %1, {CONST, rom($1, 1)}
+				bc IFTRUE, LT, {LABEL, ".trap_erange"}
+				cmpli %a, {CONST, 0}, %1, {CONST, rom($1, 2)}
+				bc IFTRUE, GT, {LABEL, ".trap_erange"}
+
+
 
 
 /* Floating point support */

mach/proto/mcg/treebuilder.c

@@ -528,10 +528,12 @@ static void insn_simple(int opcode)
         }
 
         /* FIXME: These instructions are really complex and barely used
-         * (Modula-2 bitset support, I believe). Leave them until later. */
+         * (Modula-2 and Pascal set support, I believe). Leave them until
+         * later. */
         case op_set: helper_function(".unimplemented_set"); break;
         case op_ior: helper_function(".unimplemented_ior"); break;
 
+
         case op_dch:
             push(
                 new_ir1(
@@ -607,8 +609,19 @@ static void insn_bvalue(int opcode, struct basicblock* leftbb, struct basicblock
     }
 }
 
-static void simple_alu1(int opcode, int size, int irop)
+static void simple_alu1(int opcode, int size, int irop, const char* fallback)
 {
+    if (size > (2*EM_wordsize))
+    {
+        if (!fallback)
+            fatal("treebuilder: can't do opcode %d with size %d", opcode, size);
+        push(
+            new_wordir(size)
+        );
+        helper_function(fallback);
+    }
+    else
+    {
         struct ir* val = pop(size);
 
         push(
@@ -617,10 +630,22 @@ static void simple_alu1(int opcode, int size, int irop)
                 val
             )
         );
+    }
 }
 
-static void simple_alu2(int opcode, int size, int irop)
+static void simple_alu2(int opcode, int size, int irop, const char* fallback)
 {
+    if (size > (2*EM_wordsize))
+    {
+        if (!fallback)
+            fatal("treebuilder: can't do opcode %d with size %d", opcode, size);
+        push(
+            new_wordir(size)
+        );
+        helper_function(fallback);
+    }
+    else
+    {
         struct ir* right = pop(size);
         struct ir* left = pop(size);
 
@@ -630,6 +655,7 @@ static void simple_alu2(int opcode, int size, int irop)
                 left, right
             )
         );
+    }
 }
 
 static struct ir* extract_block_refs(struct basicblock* bb)
@@ -708,39 +734,43 @@ static void insn_ivalue(int opcode, arith value)
 {
     switch (opcode)
     {
-        case op_adi: simple_alu2(opcode, value, IR_ADD); break;
+        case op_adi: simple_alu2(opcode, value, IR_ADD, NULL); break;
-        case op_sbi: simple_alu2(opcode, value, IR_SUB); break;
+        case op_sbi: simple_alu2(opcode, value, IR_SUB, NULL); break;
-        case op_mli: simple_alu2(opcode, value, IR_MUL); break;
+        case op_mli: simple_alu2(opcode, value, IR_MUL, NULL); break;
-        case op_dvi: simple_alu2(opcode, value, IR_DIV); break;
+        case op_dvi: simple_alu2(opcode, value, IR_DIV, NULL); break;
-        case op_rmi: simple_alu2(opcode, value, IR_MOD); break;
+        case op_rmi: simple_alu2(opcode, value, IR_MOD, NULL); break;
-        case op_sli: simple_alu2(opcode, value, IR_ASL); break;
+        case op_sli: simple_alu2(opcode, value, IR_ASL, NULL); break;
-        case op_sri: simple_alu2(opcode, value, IR_ASR); break;
+        case op_sri: simple_alu2(opcode, value, IR_ASR, NULL); break;
-        case op_ngi: simple_alu1(opcode, value, IR_NEG); break;
+        case op_ngi: simple_alu1(opcode, value, IR_NEG, NULL); break;
 
-        case op_adu: simple_alu2(opcode, value, IR_ADD); break;
+        case op_adu: simple_alu2(opcode, value, IR_ADD, NULL); break;
-        case op_sbu: simple_alu2(opcode, value, IR_SUB); break;
+        case op_sbu: simple_alu2(opcode, value, IR_SUB, NULL); break;
-        case op_mlu: simple_alu2(opcode, value, IR_MUL); break;
+        case op_mlu: simple_alu2(opcode, value, IR_MUL, NULL); break;
-        case op_slu: simple_alu2(opcode, value, IR_LSL); break;
+        case op_slu: simple_alu2(opcode, value, IR_LSL, NULL); break;
-        case op_sru: simple_alu2(opcode, value, IR_LSR); break;
+        case op_sru: simple_alu2(opcode, value, IR_LSR, NULL); break;
-        case op_rmu: simple_alu2(opcode, value, IR_MODU); break;
+        case op_rmu: simple_alu2(opcode, value, IR_MODU, NULL); break;
-        case op_dvu: simple_alu2(opcode, value, IR_DIVU); break;
+        case op_dvu: simple_alu2(opcode, value, IR_DIVU, NULL); break;
 
-        case op_and: simple_alu2(opcode, value, IR_AND); break;
+        case op_and: simple_alu2(opcode, value, IR_AND, NULL); break;
-        case op_ior: simple_alu2(opcode, value, IR_OR); break;
+        case op_ior: simple_alu2(opcode, value, IR_OR, ".ior"); break;
-        case op_xor: simple_alu2(opcode, value, IR_EOR); break;
+        case op_xor: simple_alu2(opcode, value, IR_EOR, NULL); break;
-        case op_com: simple_alu1(opcode, value, IR_NOT); break;
+        case op_com: simple_alu1(opcode, value, IR_NOT, NULL); break;
 
-        case op_adf: simple_alu2(opcode, value, IR_ADDF); break;
+        case op_adf: simple_alu2(opcode, value, IR_ADDF, NULL); break;
-        case op_sbf: simple_alu2(opcode, value, IR_SUBF); break;
+        case op_sbf: simple_alu2(opcode, value, IR_SUBF, NULL); break;
-        case op_mlf: simple_alu2(opcode, value, IR_MULF); break;
+        case op_mlf: simple_alu2(opcode, value, IR_MULF, NULL); break;
-        case op_dvf: simple_alu2(opcode, value, IR_DIVF); break;
+        case op_dvf: simple_alu2(opcode, value, IR_DIVF, NULL); break;
-        case op_ngf: simple_alu1(opcode, value, IR_NEGF); break;
+        case op_ngf: simple_alu1(opcode, value, IR_NEGF, NULL); break;
 
         case op_cmu: /* fall through */
         case op_cms: push(tristate_compare(value, IR_COMPAREUI)); break;
         case op_cmi: push(tristate_compare(value, IR_COMPARESI)); break;
         case op_cmf: push(tristate_compare(value, IR_COMPAREF)); break;
 
+        case op_rck: helper_function(".rck"); break;
+        case op_set: push(new_wordir(value)); helper_function(".set"); break;
+        case op_inn: push(new_wordir(value)); helper_function(".inn"); break;
+
         case op_lol:
             push(
                 load(
@@ -1084,6 +1114,18 @@ static void insn_ivalue(int opcode, arith value)
             break;
         }
 
+        case op_zer:
+        {
+            if (value <= EM_wordsize)
+                push(new_constir(value, 0));
+            else
+            {
+                push(new_wordir(value));
+                helper_function(".zer");
+            }
+            break;
+        }
+
         case op_asp:
         {
             switch (value)
@@ -1108,15 +1150,12 @@ static void insn_ivalue(int opcode, arith value)
                         value -= s;
                     }
 
-                    if (value != 0)
-                    {
                     appendir(
                         new_ir1(
                             IR_STACKADJUST, EM_pointersize,
                             new_wordir(value)
                         )
                     );
-                    }
                     break;
             }
             break;
@@ -1492,18 +1531,6 @@ static void insn_ivalue(int opcode, arith value)
             break;
         }
 
-        /* FIXME: These instructions are really complex and barely used
-         * (Modula-2 bitset support, I believe). Leave them until leter. */
-        case op_inn:
-        {
-            push(
-                new_wordir(value)
-            );
-
-            helper_function(".inn");
-            break;
-        }
-
         case op_lin:
         {
             /* Set line number --- ignore. */

plat/linuxppc/libsys/trap.s

@@ -58,6 +58,11 @@ EUNIMPL = 63		! unimplemented em-instruction called
 	addi r3, r0, EARRAY
 	b .trap
 
+.define .trap_erange
+.trap_erange:
+	addi r3, r0, ERANGE
+	b .trap
+
 .define .trap
 .trap:
 	cmpi cr0, 0, r3, 15      ! traps >15 can't be ignored

plat/qemuppc/libsys/trap.s

@@ -54,6 +54,10 @@ EUNIMPL = 63		! unimplemented em-instruction called
 .trap_earray:
 	b .trp
 
+.define .trap_erange
+.trap_erange:
+	b .trap
+
 .define .trp
 .define .trap
 .trp:
@@ -66,4 +70,3 @@ EUNIMPL = 63		! unimplemented em-instruction called
 	li32 r4, .trppc
 	stw r3, 0(r4)
 	bclr ALWAYS, 0, 0		! return
-	

tests/plat/charsignedness_p.p

@@ -0,0 +1,28 @@
+#
+(*$U+ -- enables underscores in identifiers *)
+
+program markrelease;
+
+type
+    charset = set of char;
+
+var
+    s : charset;
+    i : integer;
+
+procedure finished;
+    extern;
+
+procedure fail(line: integer);
+    extern;
+
+#define ASSERT(cond) \
+    if (not (cond)) then fail(__LINE__)
+
+begin
+    s := [];
+    for i := 0 to 255 do
+        s := s + [chr(i)];
+
+    finished
+end.