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

Merge from default.

Browse source
This commit is contained in:
David Given 2017-01-18 00:02:32 +01:00
parent b63a4513d5 81c677d218
commit 232545606d
18 changed files with 1241 additions and 957 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

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

@ -164,14 +164,10 @@ register int delim;
Malloc((unsigned) sizeof(struct string));
register char *p;
register int len = ISTRSIZE;
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) ) {
@ -420,7 +411,7 @@ again:
/* dtrg: removed to allow Pascal programs to access system routines
* (necessary to make them do anything useful). What's this for,
* anyway? */
#if 0
if( buf[0] == '_' ) lexerror("underscore starts identifier");
#endif
@ -492,7 +483,7 @@ again:
PushBack();
goto end;
}
}
if( ch == 'e' || ch == 'E' ) {
char *tp = np; /* save position in string */

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

@ -94,8 +94,8 @@ 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
*/
bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);

2
lib/descr/fe
View file

@ -185,7 +185,7 @@ name b
to .k
program {EM}/lib/ack/em_b
mapflag -B* ABC_F={ABC_F?} -B*
args -i < -o > -w {p} {ABC_F}
args -i < -o > -w {p} {ABC_F?}
prep cond
rts .b
need .b

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

@ -3,11 +3,13 @@
.sect .text
! Set intersection.
! Stack: ( b a -- a*b )
! With r3 = size of set
! Stack: ( b a size -- a*b )
.define .and
.and:
lwz r3, 0 (sp) ! r3 = size
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

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

@ -3,11 +3,13 @@
.sect .text
! Set complement.
! Stack: ( a -- ~a )
! With r3 = size of set
! Stack: ( a size -- ~a )
.define .com
.com:
lwz r3, 0 (sp) ! size
addi sp, sp, 4
mr r4, sp ! r4 = pointer to set a
rlwinm r5, r3, 30, 2, 31
mtspr ctr, r5 ! ctr = r3 / 4

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: ( b a size -- 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: ( value descriptor -- value )
.define .rck
.rck:
lwz r3, 0 (sp)
lwz r4, 4 (sp)
addi sp, sp, 4 ! leave value on stack
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: ( bitnumber size -- 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

86
mach/powerpc/ncg/table
View file

@ -1476,11 +1476,13 @@ PATTERNS
yields %a
pat and defined($1) /* AND set */
with STACK
kills ALL
gen
move {CONST, $1}, R3
bl {LABEL, ".and"}
leaving
loc $1
cal ".and"
pat and !defined($1)
leaving
cal ".and"
pat ior $1==4 /* OR word */
with REG NOT_R
@ -1513,18 +1515,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,21 +1571,22 @@ PATTERNS
yields {NOT_R, %1}
pat com defined($1) /* NOT set */
with STACK
gen
move {CONST, $1}, R3
bl {LABEL, ".com"}
leaving
loc $1
cal ".com"
pat com !defined($1)
leaving
cal ".com"
pat zer $1==4 /* Push zero */
leaving
loc 0
pat zer defined($1) /* Create empty set */
with STACK
kills ALL
gen
move {CONST, $1}, R3
bl {LABEL, ".zer"}
pat zer defined($1) /* Create empty set */
leaving
loc $1
cal ".zer"
pat sli $1==4 /* Shift left (second << top) */
with CONST_ALL GPR
@ -1665,27 +1664,23 @@ 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"
pat inn !defined($1)
leaving
cal ".inn"
/* Boolean resolutions */
@ -2076,6 +2071,17 @@ PATTERNS
loc $1
ass 4
pat lae rck $2==4 /* Range check */
with REG
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"}
yields %1
/* Floating point support */

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

@ -66,7 +66,7 @@ static struct ir* pop(int size)
#if 0
/* If we try to pop something which is smaller than a word, convert it first. */
if (size < EM_wordsize)
ir = convertu(ir, size);
#endif
@ -200,7 +200,7 @@ static struct ir* address_of_external(const char* label, arith offset)
static struct ir* convert(struct ir* src, int srcsize, int destsize, int opcode)
{
if (srcsize == 1)
if (srcsize == 1)
{
if ((opcode == IR_FROMSI) || (opcode == IR_FROMSL))
{
@ -433,7 +433,7 @@ static void insn_simple(int opcode)
);
break;
}
case op_cii: simple_convert(IR_FROMSI); break;
case op_ciu: simple_convert(IR_FROMSI); break;
case op_cui: simple_convert(IR_FROMUI); break;
@ -519,7 +519,19 @@ static void insn_simple(int opcode)
}
case op_trp: helper_function(".trp"); break;
case op_sig: helper_function(".sig"); break;
case op_sig:
{
struct ir* value = pop(EM_pointersize);
appendir(
store(
EM_pointersize,
new_labelir(".trppc"), 0,
value
)
);
break;
}
case op_rtt:
{
@ -528,10 +540,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(
@ -540,7 +554,7 @@ static void insn_simple(int opcode)
)
);
break;
case op_lpb:
push(
new_ir1(
@ -607,29 +621,53 @@ 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)
{
struct ir* val = pop(size);
if (size > (2*EM_wordsize))
{
if (!fallback)
fatal("treebuilder: can't do opcode %s with size %d", em_mnem[opcode - sp_fmnem], size);
push(
new_wordir(size)
);
helper_function(fallback);
}
else
{
struct ir* val = pop(size);
push(
new_ir1(
irop, size,
val
)
);
push(
new_ir1(
irop, size,
val
)
);
}
}
static void simple_alu2(int opcode, int size, int irop)
static void simple_alu2(int opcode, int size, int irop, const char* fallback)
{
struct ir* right = pop(size);
struct ir* left = pop(size);
if (size > (2*EM_wordsize))
{
if (!fallback)
fatal("treebuilder: can't do opcode %s with size %d", em_mnem[opcode - sp_fmnem], size);
push(
new_wordir(size)
);
helper_function(fallback);
}
else
{
struct ir* right = pop(size);
struct ir* left = pop(size);
push(
new_ir2(
irop, size,
left, right
)
);
push(
new_ir2(
irop, size,
left, right
)
);
}
}
static struct ir* extract_block_refs(struct basicblock* bb)
@ -708,39 +746,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, ".and"); 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, ".com"); 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(
@ -874,7 +916,7 @@ static void insn_ivalue(int opcode, arith value)
)
);
break;
case op_loc:
push(
new_wordir(value)
@ -1041,7 +1083,7 @@ static void insn_ivalue(int opcode, arith value)
struct ir* right = pop(EM_pointersize);
struct ir* left = pop(EM_pointersize);
struct ir* delta =
struct ir* delta =
new_ir2(
IR_SUB, EM_pointersize,
left, right
@ -1053,7 +1095,7 @@ static void insn_ivalue(int opcode, arith value)
push(delta);
break;
}
case op_dup:
{
sequence_point();
@ -1084,6 +1126,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 +1162,12 @@ static void insn_ivalue(int opcode, arith value)
value -= s;
}
if (value != 0)
{
appendir(
new_ir1(
IR_STACKADJUST, EM_pointersize,
new_wordir(value)
)
);
}
appendir(
new_ir1(
IR_STACKADJUST, EM_pointersize,
new_wordir(value)
)
);
break;
}
break;
@ -1169,7 +1220,7 @@ static void insn_ivalue(int opcode, arith value)
);
break;
}
case op_lfr:
{
push(
@ -1300,11 +1351,11 @@ static void insn_ivalue(int opcode, arith value)
new_labelir((value == 4) ? ".fef4" : ".fef8")
)
);
/* exit, leaving an int and then a float (or double) on the stack. */
break;
}
case op_fif:
{
/* fif is implemented by calling a helper function which then mutates
@ -1320,11 +1371,11 @@ static void insn_ivalue(int opcode, arith value)
new_labelir((value == 4) ? ".fif4" : ".fif8")
)
);
/* exit, leaving two floats (or doubles) on the stack. */
break;
}
case op_lor:
{
switch (value)
@ -1341,7 +1392,7 @@ static void insn_ivalue(int opcode, arith value)
)
);
break;
case 1:
push(
appendir(
@ -1492,18 +1543,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. */
@ -1577,7 +1616,7 @@ static void insn_lvalue(int opcode, const char* label, arith offset)
)
);
break;
case op_ine:
sequence_point();
appendir(
@ -1666,7 +1705,7 @@ static void insn_lvalue(int opcode, const char* label, arith offset)
/* Set filename --- ignore. */
break;
}
default:
fatal("treebuilder: unknown lvalue instruction '%s'",
em_mnem[opcode - sp_fmnem]);
@ -1699,7 +1738,7 @@ static void generate_tree(struct basicblock* bb)
break;
case PARAM_LVALUE:
tracef('E', "label=%s offset=%d\n",
tracef('E', "label=%s offset=%d\n",
em->u.lvalue.label, em->u.lvalue.offset);
insn_lvalue(em->opcode, em->u.lvalue.label, em->u.lvalue.offset);
break;

1748
mach/proto/ncg/codegen.c
View file

File diff suppressed because it is too large Load diff

2
mach/proto/ncg/salloc.c
View file

@ -37,7 +37,7 @@ void chkstr();
string myalloc(size) {
register string p;
p = (string) malloc((unsigned)size);
p = (string) calloc((unsigned)size, 1);
if (p==0)
fatal("Out of memory");
return(p);

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

@ -52,43 +52,50 @@ EUNIMPL = 63 ! unimplemented em-instruction called
.trap_ecase:
addi r3, r0, ECASE
b .trap
.define .trap_earray
.trap_earray:
addi r3, r0, EARRAY
b .trap
.define .trap_erange
.trap_erange:
addi r3, r0, ERANGE
b .trap
.define .trp
.define .trap
.trp:
.trap:
cmpi cr0, 0, r3, 15 ! traps >15 can't be ignored
bc IFTRUE, LT, 1f
addi r4, r0, 1
rlwnm r4, r4, r3, 0, 31 ! calculate trap bit
li32 r5, .ignmask
lwz r5, 0(r5) ! load ignore mask
and. r4, r4, r5 ! compare
bclr IFFALSE, EQ, 0 ! return if non-zero
1:
li32 r4, .trppc
lwz r5, 0(r4) ! load user trap routine
or. r5, r5, r5 ! test
bc IFTRUE, EQ, fatal ! if no user trap routine, bail out
addi r0, r0, 0
stw r0, 0(r4) ! reset trap routine
mfspr r0, lr
stwu r0, -4(sp) ! save old lr
stwu r3, -4(sp)
mtspr ctr, r5
bcctrl ALWAYS, 0, 0 ! call trap routine
lwz r0, 4(sp) ! load old lr again
addi sp, sp, 8 ! retract over stack usage
bclr ALWAYS, 0, 0 ! return
bclr ALWAYS, 0, 0 ! return
fatal:
addi r3, r0, 1
@ -96,7 +103,7 @@ fatal:
addi r5, r0, 6
addi r0, r0, 4 ! write()
sc 0
addi r0, r0, 1 ! exit()
sc 0

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

@ -49,21 +49,17 @@ EUNIMPL = 63 ! unimplemented em-instruction called
.define .trap_ecase
.trap_ecase:
b .trp
.define .trap_earray
.trap_earray:
b .trp
.define .trap_erange
.trap_erange:
b .trap
.define .trp
.define .trap
.trp:
.trap:
b .trp ! spin forever
.define .sig
.sig:
lwz r3, 0(sp)
li32 r4, .trppc
stw r3, 0(r4)
bclr ALWAYS, 0, 0 ! return

4
tests/plat/newdispose_p.p
View file

@ -9,13 +9,13 @@ type
var
ptr1 : iptr;
ptr2 : iptr;
procedure finished;
extern;
procedure fail(line: integer);
extern;
#define ASSERT(cond) \
if (not (cond)) then fail(__LINE__)

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

@ -0,0 +1,37 @@
#
(*$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)];
i := 99; (* to defeat optimisation *)
ASSERT(chr(42) in s);
ASSERT(chr(142) in s);
ASSERT(chr(i) in s);
s := s - [chr(42)];
ASSERT(not(chr(42) in s));
ASSERT(chr(142) in s);
ASSERT(chr(i) in s);
finished
end.