void testSymbol()
{
#if 0 // Operator
int i = 0;
for(; i < KeywordsCount; ++i)
{
printf("%s\n", Operators[i]);
}
#endif
// test: isKeyword isLiteral isVar isSemicolon symbol_construct symbol_deconstruct
#if 0 // not ok
char *symbol[] = {"int", "i", "=", "12", ";"};
for(int i = 0; i < sizeof(symbol) / sizeof(symbol[0]); ++i)
{
// ok
printf("symbol %s : isKeyword:%s isLiteral:%s isVar:%s isSemicolon:%s\n",
symbol[i], TO_BOOL_STR(isKeyword(symbol[i])), TO_BOOL_STR(isLiteral(symbol[i])),
TO_BOOL_STR(isVar(symbol[i])), TO_BOOL_STR(isSemicolon(symbol[i])));
Symbol *sb = symbol_construct(symbol[i]);
if(sb)
{
// not ok
printf("%x %x %x %x \n", IS_KEYWORD(sb->type),
IS_LITERAL(sb->type),
IS_VAR(sb->type),
IS_SEMICOLON(sb->type));
symbol_deconstruct(sb);
}
}
#endif
// test: isCharLiteral isStringLiteral isDecNumber isOctNumber isHexNumber isFloatNumer
// tes: isDoubleNumber
#if 0 // ok
int i = 0;
const char *strArr[] = {"\'c\'", "\"abc\"", "453", "0453", "781", "a90", "0x34", "0X56",
"9.34", "9.4e2", "9.5E5", "9e+2", "9e-3", "9.34f", "9.34F"
};
for(; i < sizeof(strArr) / sizeof(strArr[0]); ++i)
{
printf("%s: isCharLiteral(%s)\n\t", strArr[i], TO_BOOL_STR(isCharLiteral(strArr[i])));
printf("isStringLiteral(%s)\n\t", TO_BOOL_STR(isStringLiteral(strArr[i])));
printf("isDecNumber(%s)\n\t", TO_BOOL_STR(isDecNumber(strArr[i])));
printf("isOctNumber(%s)\n\t", TO_BOOL_STR(isOctNumber(strArr[i])));
printf("isHexNumber(%s)\n\t", TO_BOOL_STR(isHexNumber(strArr[i])));
printf("isFloatNumber(%s)\n\t", TO_BOOL_STR(isFloatNumber(strArr[i])));
printf("isDoubleNumber(%s)\n", TO_BOOL_STR(isDoubleNumber(strArr[i])));
}
/* // I don't know why, but it can't output all strings
for(; i < sizeof(strArr) / sizeof(strArr[0]); ++i)
{
printf("%s: isCharLiteral(%s)\n\t isStringLiteral(%s)\n\t isDecNumber(%s)\n\t isOctNumber(%s)\n\t isHexNumber(%s)\n\t isFloatNumber(%s)\n\t isDoubleNumber(%s)\n",
strArr[i], TO_BOOL_STR(isCharLiteral(strArr[i])), TO_BOOL_STR(isStringLiteral(strArr[i])), TO_BOOL_STR(isDecNumber(strArr[i])), TO_BOOL_STR(isOctNumber(strArr[i])), TO_BOOL_STR(isHexNumber(strArr[i])), TO_BOOL_STR(isFloatNumber(strArr[i])), TO_BOOL_STR(isDoubleNumber(strArr[i])));
}
*/
#endif
}
static void
registerWakeup(Word name, Word value ARG_LD)
{ Word wake;
Word tail = valTermRef(LD->attvar.tail);
assert(gTop+6 <= gMax && tTop+4 <= tMax);
wake = gTop;
gTop += 4;
wake[0] = FUNCTOR_wakeup3;
wake[1] = needsRef(*name) ? makeRef(name) : *name;
wake[2] = needsRef(*value) ? makeRef(value) : *value;
wake[3] = ATOM_nil;
if ( *tail )
{ Word t; /* Non-empty list */
deRef2(tail, t);
TrailAssignment(t);
*t = consPtr(wake, TAG_COMPOUND|STG_GLOBAL);
TrailAssignment(tail); /* on local stack! */
*tail = makeRef(wake+3);
DEBUG(1, Sdprintf("appended to wakeup\n"));
} else /* empty list */
{ Word head = valTermRef(LD->attvar.head);
assert(isVar(*head));
TrailAssignment(head); /* See (*) */
*head = consPtr(wake, TAG_COMPOUND|STG_GLOBAL);
TrailAssignment(tail);
*tail = makeRef(wake+3);
LD->alerted |= ALERT_WAKEUP;
DEBUG(1, Sdprintf("new wakeup\n"));
}
}
Symbol *symbol_construct(const char *str)
{
SYMBOL_TYPE type;
Symbol *sb = (Symbol *)malloc(sizeof(Symbol));
if(!sb)
return NULL;
char *sbStr = (char *)malloc(strlen(str) + 1);
if(!sbStr)
return NULL;
type = 0;
if(isKeyword(str))
type |= SYMBOL_TYPE_KEYWORD;
if(isVar(str))
type |= SYMBOL_TYPE_VAR;
if(isSemicolon(str))
type |= SYMBOL_TYPE_SEMICOLON;
if(isLiteral(str))
type |= SYMBOL_TYPE_LITERAL;
sb->type = type;
strcpy(sbStr, str);
sb->str = sbStr;
return sb;
}
/*
* Copy an expression, but replace all occurences of a given variable with a
* given expression.
*/
Exp *replace(Exp *body, int bind, Exp *arg) { // :-) YOU CAN DO IT!!!
if(isApp(body)) {
return newApp(replace(appFun(body), bind, arg),
replace(appArg(body), bind, arg));
}
else if(isAbs(body)) {
return newAbs(replace(absBody(body), bind + 1, arg));
}
else if(isVar(body)) {
if(varBind(body) == bind) {
return copyExp(arg);
}
else {
return copyExp(body);
}
}
else if(isCon(body) || isOpn(body)) {
return copyExp(body);
}
else {
printf("Error - unrecognised expression type in replace()\n");
assert(false);
return NULL;
}
}
/*
* Determine whether or not two expressions are equal.
*/
bool expEqual(Exp *e1, Exp *e2) {
if(isApp(e1)) {
if(!isApp(e2)) {
return false;
}
else {
return expEqual(appFun(e1), appFun(e2))
&& expEqual(appArg(e1), appArg(e2));
}
}
else if(isAbs(e1)) {
if(!isAbs(e2)) {
return false;
}
else {
return expEqual(absBody(e1), absBody(e2));
}
}
else if(isVar(e1)) {
if(!isVar(e2)) {
return false;
}
else {
return varBind(e1) == varBind(e2);
}
}
else if(isCon(e1)) {
if(!isCon(e2)) {
return false;
}
else {
return (conVal(e1) == conVal(e2)) && (conTy(e1) == conTy(e2));
}
}
else if(isOpn(e1)) {
if(!isOpn(e2)) {
return false;
}
else {
return opnType(e1) == opnType(e2);
}
}
else {
printf("Error - unrecognised expression type in expEqual()\n");
assert(false);
}
}
void
assignAttVar(Word av, Word value, int flags ARG_LD)
{ Word a;
mark m;
assert(isAttVar(*av));
assert(!isRef(*value));
assert(gTop+8 <= gMax && tTop+6 <= tMax);
DEBUG(CHK_SECURE, assert(on_attvar_chain(av)));
DEBUG(1, Sdprintf("assignAttVar(%s)\n", vName(av)));
if ( isAttVar(*value) )
{ if ( value > av )
{ Word tmp = av;
av = value;
value = tmp;
} else if ( av == value )
return;
}
if( !(flags & ATT_ASSIGNONLY) )
{ a = valPAttVar(*av);
registerWakeup(av, a, value PASS_LD);
}
if ( (flags&ATT_WAKEBINDS) )
return;
Mark(m); /* must be trailed, even if above last choice */
LD->mark_bar = NO_MARK_BAR;
TrailAssignment(av);
DiscardMark(m);
if ( isAttVar(*value) )
{ DEBUG(1, Sdprintf("Unifying two attvars\n"));
*av = makeRef(value);
} else if ( isVar(*value) )
{ DEBUG(1, Sdprintf("Assigning attvar with plain var\n"));
*av = makeRef(value); /* JW: Does this happen? */
} else
*av = *value;
return;
}
void matchType() const {
givenACodeSampleToTokenize type("abc", true);
ASSERT_EQUALS(true, Token::Match(type.tokens(), "%type%"));
givenACodeSampleToTokenize isVar("int a = 3 ;");
ASSERT_EQUALS(true, Token::Match(isVar.tokens(), "%type%"));
ASSERT_EQUALS(true, Token::Match(isVar.tokens(), "%type% %var%"));
ASSERT_EQUALS(false, Token::Match(isVar.tokens(), "%type% %type%"));
givenACodeSampleToTokenize noType1_cpp("delete", true, true);
ASSERT_EQUALS(false, Token::Match(noType1_cpp.tokens(), "%type%"));
givenACodeSampleToTokenize noType1_c("delete", true, false);
ASSERT_EQUALS(true, Token::Match(noType1_c.tokens(), "%type%"));
givenACodeSampleToTokenize noType2("void delete", true);
ASSERT_EQUALS(false, Token::Match(noType2.tokens(), "!!foo %type%"));
}
/*
* Copy an expression, return a pointer to the newly allocated expression.
*/
Exp *copyExp(Exp *exp) {
if(isApp(exp)) {
return newApp(copyExp(appFun(exp)), copyExp(appArg(exp)));
}
else if(isAbs(exp)) {
return newAbs(copyExp(absBody(exp)));
}
else if(isVar(exp)) {
return newVar(varBind(exp));
}
else if(isCon(exp)) {
return newCon(conTy(exp), conVal(exp));
}
else if(isOpn(exp)) {
return newOpn(opnType(exp));
}
else {
printf("Error - unrecognised expression type in copyExp()\n");
assert(false);
}
}
Token_type
getTokenTypeByName(const char *name)
{
if(isKeyword(name))
return Token_type_keyword;
if(isCharLiteral(name))
return Token_type_literal;
if(isStringLiteral(name))
return Token_type_literal;
if(isVar(name))
return Token_type_var;
if(isOperator(name))
return Token_type_operator;
if(isDecNumber(name)
|| isHexNumber(name)
|| isOctNumber(name)
|| isFloatNumber(name)
|| isDoubleNumber(name))
return Token_type_num;
if(isSemicolon(name))
return Token_type_semicolon;
return Token_type_err;
}
/* ------------------------------------------------------------------------------------------ */
void checkInstruction(ins *p){
reg *rz=NULL;
reg *rx=NULL;
reg *ry=NULL;
reg *rt=NULL; // temporary register (may or not be used)
ins *ip=NULL; // auxiliary instruction pointer (for other registers)
ins *ti=NULL; // temporary instruction pointer (to be used with the temporary register)
ins *mi=NULL; // main instruction pointer (used with the final instruction)
/*
* >> input: rz = rx <op> ry
*
*
* rx = ARP + lookup(rx->value)
* rx = * rx
* ry = ARP + lookup(ry->value)
* ry = * ry
* rt = rx <op> ry
* rz = ARP + lookup(rz->value)
* *rz = rt
*/
if(p == NULL)
return;
#ifdef VERBOSE
printf("\n");
table_print(registers);
printf("[checkInstruction] ");
printInstruction(p);
#endif
// :: -------------------------------- :: THE ALGORITHM ::
// 1st step: ensure that 'rx' and 'ry' have register
// --
// checking 'rx'
if((p->src1[0] != '\0') && !isNumeric(p->src1)){
rx=reg_search(p->src1);
if(rx==NULL){
// allocates register
rx=reg_ensure(p->src1);
if(isVar(p->src1)){
// loading the local variable from memory
load(p->src1);
ip = createInstruction(idx++);
copy(ip->dst, rx->name);
ip->arp=true;
ip->offset=lookup(p->src1);
append(ip);
ip = createInstruction(idx++);
copy(ip->dst, rx->name);
ip->ops1='*';
copy(ip->src1, rx->name);
append(ip);
}
if(rx!=NULL){
// set properties for register
rx->dist=distance(p, rx->value);
rx->dirty=false;
}
}
} else rx=NULL;
// checking 'ry'
if((p->src2[0] != '\0') && !isNumeric(p->src2)){
ry=reg_search(p->src2);
if(ry==NULL){
// allocates register
ry=reg_ensure(p->src2);
if(isVar(p->src2)){
// loading the local variable 'ry' from memory
load(p->src2);
// loading the local variable 'ry' from memory
ip = createInstruction(idx++);
copy(ip->dst, ry->name);
ip->arp=true;
ip->offset=lookup(p->src2);
append(ip);
ip = createInstruction(idx++);
copy(ip->dst, ry->name);
ip->ops1='*';
copy(ip->src1, ry->name);
append(ip);
}
if(ry!=NULL){
// set properties for register
ry->dist=distance(p, ry->value);
ry->dirty=true;
}
}
} else ry=NULL;
// 2nd step: allocate the 'rt' temporary register; creates the 'ti' temporary instruction
// --
ti = createInstruction(idx++);
// get 'rx'
if(isNumeric(p->src1))
copy(ti->src1, p->src1); // found a constant
else if(rx!=NULL)
copy(ti->src1, rx->name); // got the 'rx'
// get the operator
ti->ops2=p->ops2;
// get 'ry'
if(isNumeric(p->src2))
copy(ti->src2, p->src2); // found a constant
else if(ry!=NULL)
copy(ti->src2, ry->name); // got the 'ry'
if((p->dst[0] != '\0') && !isNumeric(p->dst)){
// allocate the 'rt' register ("r0" by default)
rt=reg_search("store");
// rt=reg_get();
if(rt!=NULL)
rt->dirty=false;
} else rt=NULL; // this could lead to an error
if(rt!=NULL)
copy(ti->dst, rt->name);
append(ti);
// 3rd step: frees if possible frees 'rx' and 'ry'
// --
// free 'rx'
if((rx!=NULL) && (rx->dist==MAXDIST || rx->dist==-2))
reg_free(rx);
// free 'ry'
if((ry!=NULL) && (ry->dist==MAXDIST || ry->dist==-2))
reg_free(ry);
// 4th step: allocate the 'rz' register and create the main instruction 'mi'
// --
mi = createInstruction(idx++);
// allocate the 'rz' register
if((p->dst[0] != '\0') && !isNumeric(p->dst)){
// store
store(p->dst);
rz=reg_search(p->dst);
if(rz==NULL){
// allocates register
rz=reg_ensure(p->dst);
if(isVar(p->dst)){
// loads the local variable for store operation
ip = createInstruction(idx++);
copy(ip->dst, rz->name);
ip->arp=true;
ip->offset=lookup(p->dst);
append(ip);
}
if(rz!=NULL){
// set properties for register
rz->dist=distance(p, rz->value);
rz->dirty=false;
}
}
} else rz=NULL; // this would be an error
if(rz!=NULL)
copy(mi->dst, rz->name);
if(rt!=NULL)
copy(mi->src1, rt->name);
if(isVar(p->dst))
mi->opd='*';
append(mi);
// 5th step: frees 'rt'; if possible frees 'rz'
// --
#ifdef VERBOSE
if(rt!=NULL) printf(" [rt] store: %s :: (%s)\n", rt->name, rt->value);
else printf(" [rt] is null\n");
if(rz!=NULL) printf(" [rz] store: %s :: (%s)\n", rz->name, rz->value);
else printf(" [rz] is null\n");
#endif
// free 'rt'
if(rt!=NULL) reg_free(rt);
// free 'rz'
if((rz!=NULL) && (rz->dist==MAXDIST || rz->dist<0))
reg_free(rz);
// 6th step: set the dirty property for the registers
// --
// check 'rx'
if(rx!=NULL)
rx->dirty=true;
// check 'ry'
if(ry!=NULL)
ry->dirty=true;
// check 'rt'
if(rt!=NULL)
rt->dirty=true;
// check 'rz'
if(rz!=NULL)
rz->dirty=false;
// nota: um registo e' dirty apenas quando o seu conteudo e' manipulado na memoria !!!!
// (confirmar e corrigir se necessario o 6o passo)
// mudar os valores de dirty para oposto: 'false' <-> 'true'
// :: -------------------------------- :: THE END ::
#ifdef VERBOSE
table_print(registers);
printf("\n");
#endif
return;
}
/*
* Perform at least one reduction step on the given template.
*/
Exp *reduceTemplate(Exp *exp) {
// Conditionals
if(isApp(exp)
&& isApp(appFun(exp))
&& isApp(appFun(appFun(exp)))
&& isOpn(appFun(appFun(appFun(exp))))
&& (opnType(appFun(appFun(appFun(exp)))) == O_Cond)) {
Exp *guard = appArg(appFun(appFun(exp)));
Exp *truExp = appArg(appFun(exp));
Exp *falExp = appArg(exp);
// If the guard is true, return the true expression.
if(isCon(guard) && (conVal(guard) == true)) {
return copyExp(truExp);
}
// If the guard is false, return the false expression.
else if(isCon(guard) && (conVal(guard) == false)) {
return copyExp(falExp);
}
// If the guard is not reduced, reduce it.
else {
return newApp(newApp(newApp(
newOpn(O_Cond), reduceTemplate(guard)),
copyExp(truExp)), copyExp(falExp));
}
}
// End of conditional case
// Binary operations
else if(isApp(exp)
&& isApp(appFun(exp))
&& isBinaryOpn(appFun(appFun(exp)))) {
OpTy opn = opnType(appFun(appFun(exp)));
Exp *arg1 = appArg(appFun(exp));
Exp *arg2 = appArg(exp);
// Handle equality differently because it is polymorphic.
if(opn == O_Equ) {
Exp *redA1 = reduceTemplateNorm(arg1);
Exp *redA2 = reduceTemplateNorm(arg2);
bool same = expEqual(redA1, redA2);
freeExp(redA1);
freeExp(redA2);
return newCon(C_Bool, same);
}
else if(isApp(arg1) || isAbs(arg1) || isVar(arg1) || isOpn(arg1)) {
return newApp(
newApp(
newOpn(opn),
reduceTemplate(arg1)),
copyExp(arg2));
}
else if(isApp(arg2) || isAbs(arg2) || isVar(arg2) || isOpn(arg2)) {
return newApp(
newApp(
newOpn(opn),
copyExp(arg1)),
reduceTemplate(arg2));
}
else {
assert(isCon(arg1));
assert(isCon(arg2));
if(opn == O_Add) {
return newCon(C_Int, conVal(arg1) + conVal(arg2));
}
else if(opn == O_Sub) {
return newCon(C_Int, conVal(arg1) - conVal(arg2));
}
else if(opn == O_Mul) {
return newCon(C_Int, conVal(arg1) * conVal(arg2));
}
else if(opn == O_Div) {
return newCon(C_Int, conVal(arg1) / conVal(arg2));
}
else if(opn == O_Mod) {
return newCon(C_Int, conVal(arg1) % conVal(arg2));
}
else if(opn == O_Lss) {
return newCon(C_Bool, conVal(arg1) < conVal(arg2));
}
else if(opn == O_LsE) {
return newCon(C_Bool, conVal(arg1) <= conVal(arg2));
}
else if(opn == O_NEq) {
return newCon(C_Bool, conVal(arg1) != conVal(arg2));
}
else if(opn == O_Gtr) {
return newCon(C_Bool, conVal(arg1) > conVal(arg2));
}
else if(opn == O_GtE) {
return newCon(C_Bool, conVal(arg1) >= conVal(arg2));
}
else if(opn == O_Xor) {
return newCon(C_Bool, (!conVal(arg1)) != (!conVal(arg2)));
}
else if(opn == O_And) {
return newCon(C_Bool, conVal(arg1) && conVal(arg2));
}
else if(opn == O_Or ) {
return newCon(C_Bool, conVal(arg1) || conVal(arg2));
}
else {
printf("Error reducing binary operation - unrecognised "
"operation\n");
assert(false);
}
}
}
// End of binary operations case
// iszero & not unary operations
else if(isApp(exp)
&& isOpn(appFun(exp))
&& (opnType(appFun(exp)) == O_Not
|| opnType(appFun(exp)) == O_IsZ)) {
OpTy opn = opnType(appFun(exp));
Exp *arg = appArg(exp);
if(isApp(arg) || isAbs(arg) || isVar(arg) || isOpn(arg)) {
return newApp(newOpn(opn), reduceTemplate(arg));
}
else {
if(opn == O_Not) {
return newCon(C_Bool, !(conVal(arg)));
}
else {
assert(opn == O_IsZ);
return newCon(C_Bool, conVal(arg) == 0);
}
}
}
// End iszero & not unary operations case
// Polymorphic unary operations
// Null
else if(isApp(exp)
&& isOpn(appFun(exp))
&& (opnType(appFun(exp)) == O_Null)) {
Exp *arg = appArg(exp);
Exp *reducedArg = reduceTemplateNorm(arg);
if(isOpn(reducedArg) && (opnType(reducedArg) == O_Empty)) {
freeExp(reducedArg);
return newCon(C_Bool, true);
}
else {
freeExp(reducedArg);
return newCon(C_Bool, false);
}
}
// End Null
// Head and Tail
else if(isApp(exp)
&& isOpn(appFun(exp))
&& ((opnType(appFun(exp)) == O_Head)
|| (opnType(appFun(exp)) == O_Tail))) {
OpTy opn = opnType(appFun(exp));
Exp *arg = appArg(exp);
if(isApp(arg)
&& isApp(appFun(arg))
&& isOpn(appFun(appFun(arg)))
&& (opnType(appFun(appFun(arg)))) == O_Cons) {
Exp *head = appArg(appFun(arg));
Exp *tail = appArg(arg);
if(opn == O_Head) {
return copyExp(head);
}
else {
assert(opn == O_Tail);
return copyExp(tail);
}
}
else {
return newApp(newOpn(opn), reduceTemplate(arg));
}
}
// End Head and Tail
// Cons
else if(isApp(exp)
&& isOpn(appFun(exp))
&& (opnType(appFun(exp)) == O_Cons)) {
Exp *consArg = appArg(exp);
return newApp(newOpn(O_Cons), reduceTemplate(consArg));
}
// End Cons
// Sum operations
else if(isApp(exp)
&& isOpn(appFun(exp))
&& ((opnType(appFun(exp)) == O_RemL)
|| (opnType(appFun(exp)) == O_RemR))) {
OpTy opn = opnType(appFun(exp));
Exp *arg = appArg(exp);
if(isApp(arg)
&& isOpn(appFun(arg))
&& ((opnType(appFun(arg)) == O_InjL)
|| (opnType(appFun(arg)) == O_InjR))) {
OpTy innerOpn = opnType(appFun(arg));
Exp *innerArg = appArg(arg);
if(((opn == O_RemL) && (innerOpn == O_InjL))
|| ((opn == O_RemR) && (innerOpn == O_InjR))) {
return copyExp(innerArg);
}
else {
printf("Error - removed value from a non-sum expression or "
"wrong side of sum expression\n");
assert(false);
}
}
else {
return newApp(newOpn(opn), reduceTemplate(arg));
}
}
else if(isApp(exp)
&& isOpn(appFun(exp))
&& ((opnType(appFun(exp)) == O_InjL)
|| (opnType(appFun(exp)) == O_InjR))) {
OpTy opn = opnType(appFun(exp));
Exp *arg = appArg(exp);
return newApp(newOpn(opn), reduceTemplate(arg));
}
else if(isApp(exp)
&& isOpn(appFun(exp))
&& (opnType(appFun(exp)) == O_IsLeft)) {
Exp *arg = appArg(exp);
if(isApp(arg)
&& isOpn(appFun(arg))
&& ((opnType(appFun(arg)) == O_InjL)
|| (opnType(appFun(arg)) == O_InjR))) {
OpTy injOpn = opnType(appFun(arg));
return newCon(C_Bool, injOpn == O_InjL);
}
else {
return newApp(newOpn(O_IsLeft), reduceTemplate(arg));
}
}
// End sum operations
// Tuple operations
else if(isApp(exp)
&& isOpn(appFun(exp))
&& ((opnType(appFun(exp)) == O_Fst)
|| (opnType(appFun(exp)) == O_Snd))) {
OpTy opn = opnType(appFun(exp));
Exp *arg = appArg(exp);
if(isApp(arg)
&& isApp(appFun(arg))
&& isOpn(appFun(appFun(arg)))
&& (opnType(appFun(appFun(arg))) == O_Tuple)) {
Exp *fst = appArg(appFun(arg));
Exp *snd = appArg(arg);
return copyExp((opn == O_Fst) ? fst : snd);
}
else {
return newApp(newOpn(opn), reduceTemplate(arg));
}
}
else if(isApp(exp)
&& isOpn(appFun(exp))
&& (opnType(appFun(exp)) == O_Tuple)) {
Exp *arg = appArg(exp);
return newApp(newOpn(O_Tuple), reduceTemplate(arg));
}
// End Tuple operations
// Fixed point combinator
else if(isApp(exp)
&& isOpn(appFun(exp))
&& (opnType(appFun(exp)) == O_Fix)) {
return newApp(copyExp(appArg(exp)), copyExp(exp));
}
// End fixed point combinator
// End polymorphic unary operations
// Lambda abstractions
else if(isApp(exp)
&& isAbs(appFun(exp))) {
Exp *abs = appFun(exp);
Exp *arg = appArg(exp);
return replace(absBody(abs), 0, arg);
}
// End lambda abstractions
// Function calls
else if(isApp(exp)
&& isVar(appFun(exp))) {
Exp *var = appFun(exp);
Exp *arg = appArg(exp);
int bind = varBind(var);
if(hasFunc(bind)) {
return newApp(instantiate(bind), copyExp(arg));
}
else {
return newApp(copyExp(var), reduceTemplate(arg));
}
}
else if(isVar(exp)
&& hasFunc(varBind(exp))) {
return instantiate(varBind(exp));
}
// End function calls
// Catch-all application case
else if(isApp(exp)) {
Exp *fun = appFun(exp);
Exp *arg = appArg(exp);
return newApp(reduceTemplate(fun), reduceTemplate(arg));
}
// End catch-all application case
// If there are no reductions to make, return a copy of the given template.
else {
return copyExp(exp);
}
}
bool isSimple(Obj expr) { return isVar(expr) || isNum(expr); }
void assembleTo(FILE *fOut, FILE *fIn) {
char cmd[lineLim+1], arg[argLim+1];
int argI;
while( getCmd(cmd,arg, fIn) && *cmd ) {
if( *cmd == '$' ) regVar(cmd+1, arg);
if( strchr(";:.$", *cmd) ) continue;
#define case_cmd(nam) !strcmp(cmd, #nam)? cmd_##nam
fputc(
case_cmd(jmp): case_cmd(jmpImm): case_cmd(jfImm):
case_cmd(call): case_cmd(callImm): case_cmd(ret):
case_cmd(putchar): case_cmd(getchar):
case_cmd(write): case_cmd(readln):
case_cmd(putStack): case_cmd(atEof):
case_cmd(argc): case_cmd(argv):
case_cmd(pushInt): case_cmd(pushChr): case_cmd(pushStr):
case_cmd(pushVarInt): case_cmd(pushVarChr): case_cmd(pushVarStr):
case_cmd(popInt): case_cmd(popChr): case_cmd(popStr):
case_cmd(intToChr): case_cmd(intToStr):
case_cmd(strToInt): case_cmd(strToChr):
case_cmd(chrToInt): case_cmd(chrToStr):
case_cmd(add): case_cmd(sub):
case_cmd(mul): case_cmd(div): case_cmd(mod):
case_cmd(eq): case_cmd(gt): case_cmd(lt):
case_cmd(strcatChr): case_cmd(strcat):
case_cmd(strlen):
case_cmd(streq): case_cmd(strcmp):
case_cmd(strmask):
case_cmd(indexOf):
case_cmd(replaceChr): case_cmd(setChr):
case_cmd(chrAt):
case_cmd(strdivInt): case_cmd(strdivChr):
case_cmd(dupInt): case_cmd(swapInt): case_cmd(rotInt):
case_cmd(dupChr): case_cmd(swapChr): case_cmd(rotChr):
case_cmd(dupStr): case_cmd(swapStr): case_cmd(rotStr):
cmd_stop
,
fOut
);
#undef case_cmd
argI =
*arg=='\''? arg[1]:
*arg=='+'? idx+atoi(arg+1):
*arg=='-'? idx-atoi(arg+1):
*arg==':' || *arg=='.'? getLabel(fIn, arg):
isdigit(*arg)? atoi(arg):
isVar(arg)? varIdx(arg)+1:
0;
fputc(argI & 0xFF, fOut);
fputc((argI >> 8) & 0xFF, fOut);
++idx;
}
}
value caml_isVar(value e)
{
CAMLparam1(e);
CAMLreturn(Val_int(isVar(Expr_val(e))));
}
void ATMSP<T>::factor(ATMSB<T> &bc) {
/// Check available memory
if ( numInd>=ATMSP_MAXNUM || valInd>=ATMSP_SIZE || opCnt>=ATMSP_SIZE ) longjmp(errJmp, memErr);
/// Handle open parenthesis and unary operators first
if ( *cp == '(' ) {
++cp; expression(bc);
if ( *cp++ != ')' ) longjmp(errJmp, parErr);
}
else if ( *cp == '+' ) {
++cp; factor(bc);
}
else if ( *cp == '-' ) {
++cp; factor(bc);
bc.fun[opCnt++] = &ATMSB<T>::pchs;
}
/// Extract numbers starting with digit or dot
else if ( isdigit(*cp) || *cp=='.' ) {
char *end;
bc.num[numInd] = (T)strtod(cp, &end);
bc.val[valInd++] = &bc.num[numInd++];
bc.fun[opCnt++] = &ATMSB<T>::ppush;
cp = end;
}
/// Extract constants starting with $
else if ( *cp == '$' ) {
if ( !conLst.find(skipAlphaNum(), conInd) ) longjmp(errJmp, conErr);
bc.con[conInd] = conLst[conInd].val;
bc.val[valInd++] = &bc.con[conInd];
bc.fun[opCnt++] = &ATMSB<T>::ppush;
}
/// Extract variables
else if ( isVar(cp) ) {
if ( varLst.find(skipAlphaNum(), varInd) ) varCnt++; else longjmp(errJmp, varErr);
bc.val[valInd++] = &bc.var[varInd];
bc.fun[opCnt++] = &ATMSB<T>::ppush;
}
/// Extract functions
else {
// Search function and advance cp behind open parenthesis
if ( funLst.find(skipAlphaNum(), funInd) ) ++cp; else longjmp(errJmp, funErr);
// Set operator function and advance cp
switch ( funInd ) {
case 0: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::pabs; break;
case 1: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::pcos; break;
case 2: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::pcosh; break;
case 3: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::pexp; break;
case 4: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::plog; break;
case 5: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::plog10; break;
case 6: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::plog2; break;
case 7: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::psin; break;
case 8: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::psinh; break;
case 9: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::psqrt; break;
case 10: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::ptan; break;
case 11: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::ptanh; break;
#if !defined(COMPLEX)
case 12: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::pasin; break;
case 13: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::pacos; break;
case 14: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::patan; break;
case 15: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::patan2; break;
case 16: expression(bc); ++cp; expression(bc); bc.fun[opCnt++] = &ATMSB<T>::pmax; break;
case 17: expression(bc); ++cp; expression(bc); bc.fun[opCnt++] = &ATMSB<T>::pmin; break;
case 18: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::psig; break;
case 19: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::pfloor; break;
case 20: expression(bc); bc.fun[opCnt++] = &ATMSB<T>::pround; break;
#endif
}
++cp;
}
/// At last handle univalent operators like ^ or % (not implemented here)
if ( *cp == '^' ) {
// Exponent a positive number? Try to optimize later
bool optPow = isdigit( *++cp ) ? true : false;
if ( *(cp+1) == '^' ) optPow = false;
factor(bc);
// Speed up bytecode for 2^2, x^3 ...
if ( optPow ) {
if ( *bc.val[valInd-1] == (T)2.0 ) {
--valInd;
bc.fun[opCnt-1] = &ATMSB<T>::ppow2;
}
else if ( *bc.val[valInd-1] == (T)3.0 ) {
--valInd;
bc.fun[opCnt-1] = &ATMSB<T>::ppow3;
}
else if ( *bc.val[valInd-1] == (T)4.0 ) {
--valInd;
bc.fun[opCnt-1] = &ATMSB<T>::ppow4;
}
// Exponent is a positive number, but not 2-4. Proceed with standard pow()
else
bc.fun[opCnt++] = &ATMSB<T>::ppow;
}
// Exponent is a not a number or negative. Proceed with standard pow()
else
bc.fun[opCnt++] = &ATMSB<T>::ppow;
}
} // End of factor(bc)
//----------------------------------------------------------------------
static int LoadArg(op_t &x)
{
dref_t xreftype;
switch ( x.type ) {
case o_reg:
{
if ( x.reg == R_sp ) goto Undefined;
// AbstractRegister *in = &i5_getreg(x.reg);
// if ( ! in->isDef() ) goto Undefined;
// r.doInt(in->value());
return 1;
}
case o_imm:
// r.doInt(unsigned(x.value));
xreftype = dr_O;
MakeImm:
doImmdValue(x.n);
if ( isOff(uFlag, x.n) )
ua_add_off_drefs2(x, xreftype, 0);
return 1;
case o_displ:
// r.undef();
xreftype = dr_R;
goto MakeImm;
case o_mem:
{
ea_t ea = toEA(dataSeg_op(x.n),x.addr);
ua_add_dref(x.offb,ea,dr_R);
ua_dodata2(x.offb, ea, x.dtyp);
if ( !isVar(get_flags_novalue(ea)) && isLoaded(ea) )
{
// r.doInt( x.dtyp != dt_byte ? get_word(ea) : char(get_byte(ea)) );
return 1;
}
}
case o_phrase:
Undefined:
// r.undef();
break;
case o_near:
{
ea_t segbase = codeSeg(x.addr,x.n);
ea_t ea = toEA(segbase,x.addr);
ea_t thisseg = cmd.cs;
int iscall = InstrIsSet(cmd.itype,CF_CALL);
ua_add_cref(x.offb,
ea,
iscall ? ((segbase == thisseg) ? fl_CN : fl_CF)
: ((segbase == thisseg) ? fl_JN : fl_JF));
if ( iscall && !func_does_return(ea) )
flow = false;
// r.doInt(unsigned(x.addr));
}
return 1;
default:
// warning("%a: %s,%d: bad load optype %d", cmd.ea, cmd.get_canon_mnem(), x.n, x.type);
break;
}
return 0;
}
/*
* Print an expression to stdout.
*/
void printExp(Exp *exp) {
if(isApp(exp)) {
printf("(");
printExp(appFun(exp));
printf(" ");
printExp(appArg(exp));
printf(")");
}
else if(isAbs(exp)) {
printf("(\\ ");
printExp(absBody(exp));
printf(")");
}
else if(isVar(exp)) {
if(varBind(exp) >= 0) {
printf("V%d", varBind(exp));
}
else {
printf("F%d", -varBind(exp));
}
}
else if(isCon(exp) && (conTy(exp) == C_Bool) && (conVal(exp) == true)) {
printf("true");
}
else if(isCon(exp) && (conTy(exp) == C_Bool) && (conVal(exp) == false)) {
printf("false");
}
else if(isCon(exp) && (conTy(exp) == C_Char)) {
printf("\'%c\'", conVal(exp));
}
else if(isCon(exp)/* && (conTy(exp) == C_Int)*/) {
printf("%d", conVal(exp));
}
else if(isOpn(exp)) {
switch(opnType(exp)) {
case O_Cond : printf("cond") ; break;
case O_Add : printf("+") ; break;
case O_Sub : printf("-") ; break;
case O_Mul : printf("*") ; break;
case O_Div : printf("/") ; break;
case O_Mod : printf("%%") ; break;
case O_Lss : printf("<") ; break;
case O_LsE : printf("<=") ; break;
case O_NEq : printf("/=") ; break;
case O_Gtr : printf(">") ; break;
case O_GtE : printf(">=") ; break;
case O_Equ : printf("==") ; break;
case O_And : printf("and") ; break;
case O_Or : printf("or") ; break;
case O_Xor : printf("xor") ; break;
case O_Not : printf("not") ; break;
case O_IsZ : printf("iszero") ; break;
case O_Empty : printf("[]") ; break;
case O_Cons : printf(":") ; break;
case O_Null : printf("null") ; break;
case O_Head : printf("head") ; break;
case O_Tail : printf("tail") ; break;
case O_Fix : printf("fix") ; break;
case O_InjL : printf("injl") ; break;
case O_InjR : printf("injr") ; break;
case O_RemL : printf("reml") ; break;
case O_RemR : printf("remr") ; break;
case O_IsLeft : printf("isleft") ; break;
case O_Tuple : printf("tuple") ; break;
case O_Fst : printf("fst") ; break;
case O_Snd : printf("snd") ; break;
}
}
else {
printf("Error - unrecognised expression type in printExp()\n");
assert(false);
}
}