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 "$(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

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

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

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

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

2
lib/descr/fe
View file

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

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

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

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

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

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: ( b a size -- 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: ( 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 .sect .text
! Create singleton set. ! Create singleton set.
! Stack: ( -- set ) ! Stack: ( bitnumber size -- 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

86
mach/powerpc/ncg/table
View file

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

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

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

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

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

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

@ -49,21 +49,17 @@ EUNIMPL = 63 ! unimplemented em-instruction called
.define .trap_ecase .define .trap_ecase
.trap_ecase: .trap_ecase:
b .trp b .trp
.define .trap_earray .define .trap_earray
.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:
.trap: .trap:
b .trp ! spin forever 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 var
ptr1 : iptr; ptr1 : iptr;
ptr2 : iptr; ptr2 : iptr;
procedure finished; procedure finished;
extern; extern;
procedure fail(line: integer); procedure fail(line: integer);
extern; extern;
#define ASSERT(cond) \ #define ASSERT(cond) \
if (not (cond)) then fail(__LINE__) 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.