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 ""
if [ "$failed" != "" ]; then
echo "Failing test logs:"
for t in $failed; do
echo $t
done
exit 1
fi
if [ "$failed" != "" -o "$timedout" != "" ]; then
echo "Test status: SAD FACE (tests are failing)"
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);
for( ; ; ) {
LoadChar(ch);
if( ch & 0200 ) {
fatal("non-ascii '\\%03o' read", ch & 0377);
/*NOTREACHED*/
}
if( class(ch) == STNL ) {
lexerror("newline in string");
LineNumber++;
@ -310,11 +306,6 @@ again:
LoadChar(ch);
if( !options['C'] ) /* -C : cases are different */
TO_LOWER(ch);
if( (ch & 0200) && ch != EOI ) {
fatal("non-ascii '\\%03o' read", ch & 0377);
/*NOTREACHED*/
}
}
switch( class(ch) ) {

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

@ -94,7 +94,7 @@ InitTypes()
/* character type
*/
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
*/

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

@ -3,11 +3,13 @@
.sect .text
! Set union.
! Stack: ( b a -- a+b )
! With r3 = size of set
! Stack: ( size b a -- a+b )
.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

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
! Create singleton set.
! Stack: ( -- set )
! With r3 = size of set, r4 = bit number
! Stack: ( size bitnumber -- set )
.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

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

@ -3,11 +3,13 @@
.sect .text
! Create empty set.
! Stack: ( -- set )
! With r3 = size of set
! Stack: ( size -- 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

56
mach/powerpc/ncg/table
View file

@ -1503,18 +1503,14 @@ PATTERNS
yields {OR_RC, %2, lo(%1.val)}
pat ior defined($1) /* OR set */
with STACK
kills ALL
gen
move {CONST, $1}, R3
bl {LABEL, ".ior"}
leaving
loc $1
cal ".ior"
/* OR set (variable), used in lang/m2/libm2/LtoUset.e */
pat ior !defined($1)
with GPR3 STACK
kills ALL
gen
bl {LABEL, ".ior"}
leaving
cal ".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
kills ALL
gen
move {CONST, $1}, R3
bl {LABEL, ".zer"}
leaving
loc $1
cal ".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
kills ALL
gen
move {CONST, $1}, R3
bl {LABEL, ".set"}
leaving
loc $1
cal ".set"
/* Create set (variable), used in lang/m2/libm2/LtoUset.e */
pat set !defined($1)
with GPR3 GPR4 STACK
kills ALL
gen
bl {LABEL, ".set"}
leaving
cal ".set"
pat inn defined($1) /* Test for set bit */
with STACK
kills ALL
uses REG
gen
li32 %a, {CONST, $1}
stwu %a, {GPRINDIRECT, SP, 0-4}
bl {LABEL, ".inn"}
leaving
loc $1
cal ".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 */

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
* (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,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);
@ -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* 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)
{
@ -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_sbi: simple_alu2(opcode, value, IR_SUB); break;
case op_mli: simple_alu2(opcode, value, IR_MUL); break;
case op_dvi: simple_alu2(opcode, value, IR_DIV); break;
case op_rmi: simple_alu2(opcode, value, IR_MOD); break;
case op_sli: simple_alu2(opcode, value, IR_ASL); break;
case op_sri: simple_alu2(opcode, value, IR_ASR); break;
case op_ngi: simple_alu1(opcode, value, IR_NEG); break;
case op_adi: simple_alu2(opcode, value, IR_ADD, NULL); break;
case op_sbi: simple_alu2(opcode, value, IR_SUB, NULL); break;
case op_mli: simple_alu2(opcode, value, IR_MUL, NULL); break;
case op_dvi: simple_alu2(opcode, value, IR_DIV, NULL); break;
case op_rmi: simple_alu2(opcode, value, IR_MOD, NULL); break;
case op_sli: simple_alu2(opcode, value, IR_ASL, NULL); break;
case op_sri: simple_alu2(opcode, value, IR_ASR, NULL); break;
case op_ngi: simple_alu1(opcode, value, IR_NEG, NULL); break;
case op_adu: simple_alu2(opcode, value, IR_ADD); break;
case op_sbu: simple_alu2(opcode, value, IR_SUB); break;
case op_mlu: simple_alu2(opcode, value, IR_MUL); break;
case op_slu: simple_alu2(opcode, value, IR_LSL); break;
case op_sru: simple_alu2(opcode, value, IR_LSR); break;
case op_rmu: simple_alu2(opcode, value, IR_MODU); break;
case op_dvu: simple_alu2(opcode, value, IR_DIVU); break;
case op_adu: simple_alu2(opcode, value, IR_ADD, NULL); break;
case op_sbu: simple_alu2(opcode, value, IR_SUB, NULL); break;
case op_mlu: simple_alu2(opcode, value, IR_MUL, NULL); break;
case op_slu: simple_alu2(opcode, value, IR_LSL, NULL); break;
case op_sru: simple_alu2(opcode, value, IR_LSR, NULL); break;
case op_rmu: simple_alu2(opcode, value, IR_MODU, NULL); break;
case op_dvu: simple_alu2(opcode, value, IR_DIVU, NULL); break;
case op_and: simple_alu2(opcode, value, IR_AND); break;
case op_ior: simple_alu2(opcode, value, IR_OR); break;
case op_xor: simple_alu2(opcode, value, IR_EOR); break;
case op_com: simple_alu1(opcode, value, IR_NOT); break;
case op_and: simple_alu2(opcode, value, IR_AND, NULL); break;
case op_ior: simple_alu2(opcode, value, IR_OR, ".ior"); break;
case op_xor: simple_alu2(opcode, value, IR_EOR, NULL); break;
case op_com: simple_alu1(opcode, value, IR_NOT, NULL); break;
case op_adf: simple_alu2(opcode, value, IR_ADDF); break;
case op_sbf: simple_alu2(opcode, value, IR_SUBF); break;
case op_mlf: simple_alu2(opcode, value, IR_MULF); break;
case op_dvf: simple_alu2(opcode, value, IR_DIVF); break;
case op_ngf: simple_alu1(opcode, value, IR_NEGF); break;
case op_adf: simple_alu2(opcode, value, IR_ADDF, NULL); break;
case op_sbf: simple_alu2(opcode, value, IR_SUBF, NULL); break;
case op_mlf: simple_alu2(opcode, value, IR_MULF, NULL); break;
case op_dvf: simple_alu2(opcode, value, IR_DIVF, NULL); 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. */

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

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

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

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

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.