d0p1/ack
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Merge pull request #40 from davidgiven/dtrg-pas

Browse source 
Make Pascal sets work on PowerPC (both ncg and mcg); make Pascal know about 8-bit bytes.
This commit is contained in:
David Given 2017-01-15 22:56:06 +01:00 committed by GitHub
commit c4ad07fdfc
13 changed files with 230 additions and 144 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
first/testsummary.sh
View file

@ -26,6 +26,13 @@ echo "$(echo "$timedout" | wc -w) timed out"
echo "$(echo "$failed" | wc -w) failed" echo "$(echo "$failed" | wc -w) failed"
echo "" echo ""
if [ "$failed" != "" ]; then
echo "Failing test logs:"
for t in $failed; do
echo $t
done
exit 1
fi
if [ "$failed" != "" -o "$timedout" != "" ]; then if [ "$failed" != "" -o "$timedout" != "" ]; then
echo "Test status: SAD FACE (tests are failing)" echo "Test status: SAD FACE (tests are failing)"
exit 1 exit 1

9
lang/pc/comp/LLlex.c
View file

@ -168,10 +168,6 @@ register int delim;
str->s_str = p = Malloc((unsigned int) ISTRSIZE); str->s_str = p = Malloc((unsigned int) ISTRSIZE);
for( ; ; ) { for( ; ; ) {
LoadChar(ch); LoadChar(ch);
if( ch & 0200 ) {
fatal("non-ascii '\\%03o' read", ch & 0377);
/*NOTREACHED*/
}
if( class(ch) == STNL ) { if( class(ch) == STNL ) {
lexerror("newline in string"); lexerror("newline in string");
LineNumber++; LineNumber++;
@ -310,11 +306,6 @@ again:
LoadChar(ch); LoadChar(ch);
if( !options['C'] ) /* -C : cases are different */ if( !options['C'] ) /* -C : cases are different */
TO_LOWER(ch); TO_LOWER(ch);
if( (ch & 0200) && ch != EOI ) {
fatal("non-ascii '\\%03o' read", ch & 0377);
/*NOTREACHED*/
}
} }
switch( class(ch) ) { switch( class(ch) ) {

2
lang/pc/comp/type.c
View file

@ -94,7 +94,7 @@ InitTypes()
/* character type /* character type
*/ */
char_type = standard_type(T_CHAR, 1, (arith) 1); char_type = standard_type(T_CHAR, 1, (arith) 1);
char_type->enm_ncst = 128; /* only 7 bits ASCII characters */ char_type->enm_ncst = 256; /* all bytes */
/* boolean type /* boolean type
*/ */

6
mach/powerpc/libem/ior.s
View file

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

22
mach/powerpc/libem/rck.s Normal file
View file

@ -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

7
mach/powerpc/libem/set.s
View file

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

6
mach/powerpc/libem/zer.s
View file

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

56
mach/powerpc/ncg/table
View file

@ -1503,18 +1503,14 @@ PATTERNS
yields {OR_RC, %2, lo(%1.val)} yields {OR_RC, %2, lo(%1.val)}
pat ior defined($1) /* OR set */ 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 */ /* OR set (variable), used in lang/m2/libm2/LtoUset.e */
pat ior !defined($1) pat ior !defined($1)
with GPR3 STACK leaving
kills ALL cal ".ior"
gen
bl {LABEL, ".ior"}
pat xor $1==4 /* XOR word */ pat xor $1==4 /* XOR word */
with REG REG with REG REG
@ -1573,11 +1569,9 @@ PATTERNS
loc 0 loc 0
pat zer defined($1) /* Create empty set */ 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) */ pat sli $1==4 /* Shift left (second << top) */
with CONST_ALL GPR with CONST_ALL GPR
@ -1655,27 +1649,19 @@ PATTERNS
/* Sets */ /* Sets */
pat set defined($1) /* Create singleton set */ 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 */ /* Create set (variable), used in lang/m2/libm2/LtoUset.e */
pat set !defined($1) 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 */ 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 */ /* Boolean resolutions */
@ -2066,6 +2052,16 @@ PATTERNS
loc $1 loc $1
ass 4 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 */ /* Floating point support */

111
mach/proto/mcg/treebuilder.c
View file

@ -528,10 +528,12 @@ static void insn_simple(int opcode)
} }
/* FIXME: These instructions are really complex and barely used /* 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_set: helper_function(".unimplemented_set"); break;
case op_ior: helper_function(".unimplemented_ior"); break; case op_ior: helper_function(".unimplemented_ior"); break;
case op_dch: case op_dch:
push( push(
new_ir1( new_ir1(
@ -607,7 +609,18 @@ 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); struct ir* val = pop(size);
@ -618,8 +631,20 @@ static void simple_alu1(int opcode, int size, int irop)
) )
); );
} }
}
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* right = pop(size);
struct ir* left = pop(size); struct ir* left = pop(size);
@ -631,6 +656,7 @@ static void simple_alu2(int opcode, int size, int irop)
) )
); );
} }
}
static struct ir* extract_block_refs(struct basicblock* bb) static struct ir* extract_block_refs(struct basicblock* bb)
{ {
@ -708,39 +734,43 @@ static void insn_ivalue(int opcode, arith value)
{ {
switch (opcode) 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_cmu: /* fall through */
case op_cms: push(tristate_compare(value, IR_COMPAREUI)); break; case op_cms: push(tristate_compare(value, IR_COMPAREUI)); break;
case op_cmi: push(tristate_compare(value, IR_COMPARESI)); break; case op_cmi: push(tristate_compare(value, IR_COMPARESI)); break;
case op_cmf: push(tristate_compare(value, IR_COMPAREF)); 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: case op_lol:
push( push(
load( load(
@ -1084,6 +1114,18 @@ static void insn_ivalue(int opcode, arith value)
break; 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: case op_asp:
{ {
switch (value) switch (value)
@ -1108,15 +1150,12 @@ static void insn_ivalue(int opcode, arith value)
value -= s; value -= s;
} }
if (value != 0)
{
appendir( appendir(
new_ir1( new_ir1(
IR_STACKADJUST, EM_pointersize, IR_STACKADJUST, EM_pointersize,
new_wordir(value) new_wordir(value)
) )
); );
}
break; break;
} }
break; break;
@ -1492,18 +1531,6 @@ static void insn_ivalue(int opcode, arith value)
break; 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: case op_lin:
{ {
/* Set line number --- ignore. */ /* Set line number --- ignore. */

5
plat/linuxppc/libsys/trap.s
View file

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

5
plat/qemuppc/libsys/trap.s
View file

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

28
tests/plat/pascalsets_p.p Normal file
View file

@ -0,0 +1,28 @@
#
(*$U+ -- enables underscores in identifiers *)
program pascalsets;
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.