From 6ab0c0f5bf14ed9c15370407b9ee7e0b4b089ae1 Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Sun, 27 Jan 2013 23:51:56 +0000 Subject: Initial upstream version 9.4.3 --- src/runtime/rcomp.r | 444 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 444 insertions(+) create mode 100644 src/runtime/rcomp.r (limited to 'src/runtime/rcomp.r') diff --git a/src/runtime/rcomp.r b/src/runtime/rcomp.r new file mode 100644 index 0000000..6cd0610 --- /dev/null +++ b/src/runtime/rcomp.r @@ -0,0 +1,444 @@ +/* + * File: rcomp.r + * Contents: anycmp, equiv, lexcmp + */ + +/* + * anycmp - compare any two objects. + */ + +int anycmp(dp1,dp2) +dptr dp1, dp2; + { + register int o1, o2; + register long v1, v2, lresult; + int iresult; + double rres1, rres2, rresult; + + /* + * Get a collating number for dp1 and dp2. + */ + o1 = order(dp1); + o2 = order(dp2); + + /* + * If dp1 and dp2 aren't of the same type, compare their collating numbers. + */ + if (o1 != o2) + return (o1 > o2 ? Greater : Less); + + if (o1 == 3) + /* + * dp1 and dp2 are strings, use lexcmp to compare them. + */ + return lexcmp(dp1,dp2); + + switch (Type(*dp1)) { + +#ifdef LargeInts + + case T_Integer: + if (Type(*dp2) != T_Lrgint) { + v1 = IntVal(*dp1); + v2 = IntVal(*dp2); + if (v1 < v2) + return Less; + else if (v1 == v2) + return Equal; + else + return Greater; + } + /* if dp2 is a Lrgint, flow into next case */ + + case T_Lrgint: + lresult = bigcmp(dp1, dp2); + if (lresult == 0) + return Equal; + return ((lresult > 0) ? Greater : Less); + +#else /* LargeInts */ + + case T_Integer: + v1 = IntVal(*dp1); + v2 = IntVal(*dp2); + if (v1 < v2) + return Less; + else if (v1 == v2) + return Equal; + else + return Greater; + +#endif /* LargeInts */ + + case T_Coexpr: + /* + * Collate on co-expression id. + */ + lresult = (BlkLoc(*dp1)->coexpr.id - BlkLoc(*dp2)->coexpr.id); + if (lresult == 0) + return Equal; + return ((lresult > 0) ? Greater : Less); + + case T_Cset: + return csetcmp((unsigned int *)((struct b_cset *)BlkLoc(*dp1))->bits, + (unsigned int *)((struct b_cset *)BlkLoc(*dp2))->bits); + + case T_File: + /* + * Collate on file name or window label. + */ + { + struct descrip s1, s2; /* live only long enough to lexcmp them */ + dptr ps1 = &(BlkLoc(*dp1)->file.fname); + dptr ps2 = &(BlkLoc(*dp2)->file.fname); +#ifdef Graphics + if (BlkLoc(*dp1)->file.status & Fs_Window) { + wbp w = (wbp) BlkLoc(*dp1)->file.fd; + StrLoc(s1) = w->window->windowlabel; + StrLen(s1) = strlen(w->window->windowlabel); + ps1 = &s1; + } + if (BlkLoc(*dp2)->file.status & Fs_Window) { + wbp w = (wbp) BlkLoc(*dp2)->file.fd; + StrLoc(s2) = w->window->windowlabel; + StrLen(s2) = strlen(w->window->windowlabel); + ps2 = &s2; + } +#endif /* Graphics */ + return lexcmp(ps1, ps2); + } + + case T_List: + /* + * Collate on list id. + */ + lresult = (BlkLoc(*dp1)->list.id - BlkLoc(*dp2)->list.id); + if (lresult == 0) + return Equal; + return ((lresult > 0) ? Greater : Less); + + case T_Null: + return Equal; + + case T_Proc: + /* + * Collate on procedure name. + */ + return lexcmp(&(BlkLoc(*dp1)->proc.pname), + &(BlkLoc(*dp2)->proc.pname)); + + case T_Real: + GetReal(dp1,rres1); + GetReal(dp2,rres2); + rresult = rres1 - rres2; + if (rresult == 0.0) + return Equal; + return ((rresult > 0.0) ? Greater : Less); + + case T_Record: + /* + * Collate on record id within record name. + */ + iresult = lexcmp(&(BlkLoc(*dp1)->record.recdesc->proc.pname), + &(BlkLoc(*dp2)->record.recdesc->proc.pname)); + if (iresult == Equal) { + lresult = (BlkLoc(*dp1)->record.id - BlkLoc(*dp2)->record.id); + if (lresult > 0) /* coded this way because of code-generation */ + return Greater; /* bug in MSC++ 7.0A; do not change. */ + else if (lresult < 0) + return Less; + else + return Equal; + } + return iresult; + + case T_Set: + /* + * Collate on set id. + */ + lresult = (BlkLoc(*dp1)->set.id - BlkLoc(*dp2)->set.id); + if (lresult == 0) + return Equal; + return ((lresult > 0) ? Greater : Less); + + case T_Table: + /* + * Collate on table id. + */ + lresult = (BlkLoc(*dp1)->table.id - BlkLoc(*dp2)->table.id); + if (lresult == 0) + return Equal; + return ((lresult > 0) ? Greater : Less); + + case T_External: + /* + * Collate these values according to the relative positions of + * their blocks in the heap. + */ + lresult = ((long)BlkLoc(*dp1) - (long)BlkLoc(*dp2)); + if (lresult == 0) + return Equal; + return ((lresult > 0) ? Greater : Less); + + default: + syserr("anycmp: unknown datatype."); + /*NOTREACHED*/ + return 0; /* avoid gcc warning */ + } + } + +/* + * order(x) - return collating number for object x. + */ + +int order(dp) +dptr dp; + { + if (Qual(*dp)) + return 3; /* string */ + switch (Type(*dp)) { + case T_Null: + return 0; + case T_Integer: + return 1; + +#ifdef LargeInts + case T_Lrgint: + return 1; +#endif /* LargeInts */ + + case T_Real: + return 2; + + /* string: return 3 (see above) */ + + case T_Cset: + return 4; + case T_File: + return 5; + case T_Coexpr: + return 6; + case T_Proc: + return 7; + case T_List: + return 8; + case T_Set: + return 9; + case T_Table: + return 10; + case T_Record: + return 11; + case T_External: + return 12; + default: + syserr("order: unknown datatype."); + /*NOTREACHED*/ + return 0; /* avoid gcc warning */ + } + } + +/* + * equiv - test equivalence of two objects. + */ + +int equiv(dp1, dp2) +dptr dp1, dp2; + { + register int result; + register word i; + register char *s1, *s2; + double rres1, rres2; + + result = 0; + + /* + * If the descriptors are identical, the objects are equivalent. + */ + if (EqlDesc(*dp1,*dp2)) + result = 1; + else if (Qual(*dp1) && Qual(*dp2)) { + + /* + * If both are strings of equal length, compare their characters. + */ + + if ((i = StrLen(*dp1)) == StrLen(*dp2)) { + + + s1 = StrLoc(*dp1); + s2 = StrLoc(*dp2); + result = 1; + while (i--) + if (*s1++ != *s2++) { + result = 0; + break; + } + + } + } + else if (dp1->dword == dp2->dword) + switch (Type(*dp1)) { + /* + * For integers and reals, just compare the values. + */ + case T_Integer: + result = (IntVal(*dp1) == IntVal(*dp2)); + break; + +#ifdef LargeInts + case T_Lrgint: + result = (bigcmp(dp1, dp2) == 0); + break; +#endif /* LargeInts */ + + + case T_Real: + GetReal(dp1, rres1); + GetReal(dp2, rres2); + result = (rres1 == rres2); + break; + + case T_Cset: + /* + * Compare the bit arrays of the csets. + */ + result = 1; + for (i = 0; i < CsetSize; i++) + if (BlkLoc(*dp1)->cset.bits[i] != BlkLoc(*dp2)->cset.bits[i]) { + result = 0; + break; + } + } + else + /* + * dp1 and dp2 are of different types, so they can't be + * equivalent. + */ + result = 0; + + return result; + } + +/* + * lexcmp - lexically compare two strings. + */ + +int lexcmp(dp1, dp2) +dptr dp1, dp2; + { + + + register char *s1, *s2; + register word minlen; + word l1, l2; + + /* + * Get length and starting address of both strings. + */ + l1 = StrLen(*dp1); + s1 = StrLoc(*dp1); + l2 = StrLen(*dp2); + s2 = StrLoc(*dp2); + + /* + * Set minlen to length of the shorter string. + */ + minlen = Min(l1, l2); + + /* + * Compare as many bytes as are in the smaller string. If an + * inequality is found, compare the differing bytes. + */ + while (minlen--) + if (*s1++ != *s2++) + return (*--s1 & 0377) > (*--s2 & 0377) ? Greater : Less; + + /* + * The strings compared equal for the length of the shorter. + */ + if (l1 == l2) + return Equal; + else if (l1 > l2) + return Greater; + else + return Less; + + } + +/* + * csetcmp - compare two cset bit arrays. + * The order defined by this function is identical to the lexical order of + * the two strings that the csets would be converted into. + */ + +int csetcmp(cs1, cs2) +unsigned int *cs1, *cs2; + { + unsigned int nbit, mask, *cs_end; + + if (cs1 == cs2) return Equal; + + /* + * The longest common prefix of the two bit arrays converts to some + * common prefix string. The first bit on which the csets disagree is + * the first character of the conversion strings that disagree, and so this + * is the character on which the order is determined. The cset that has + * this first non-common bit = one, has in that position the lowest + * character, so this cset is lexically least iff the other cset has some + * following bit set. If the other cset has no bits set after the first + * point of disagreement, then it is a prefix of the other, and is therefor + * lexically less. + * + * Find the first word where cs1 and cs2 are different. + */ + for (cs_end = cs1 + CsetSize; cs1 < cs_end; cs1++, cs2++) + if (*cs1 != *cs2) { + /* + * Let n be the position at which the bits first differ within + * the word. Set nbit to some integer for which the nth bit + * is the first bit in the word that is one. Note here and in the + * following, that bits go from right to left within a word, so + * the _first_ bit is the _rightmost_ bit. + */ + nbit = *cs1 ^ *cs2; + + /* Set mask to an integer that has all zeros in bit positions + * upto and including position n, and all ones in bit positions + * _after_ bit position n. + */ + for (mask = (unsigned)MaxLong << 1; !(~mask & nbit); mask <<= 1); + + /* + * nbit & ~mask contains zeros everywhere except position n, which + * is a one, so *cs2 & (nbit & ~mask) is non-zero iff the nth bit + * of *cs2 is one. + */ + if (*cs2 & (nbit & ~mask)) { + /* + * If there are bits set in cs1 after bit position n in the + * current word, then cs1 is lexically greater than cs2. + */ + if (*cs1 & mask) return Greater; + while (++cs1 < cs_end) + if (*cs1) return Greater; + + /* + * Otherwise cs1 is a proper prefix of cs2 and is therefore + * lexically less. + */ + return Less; + } + + /* + * If the nth bit of *cs2 isn't one, then the nth bit of cs1 + * must be one. Just reverse the logic for the previous + * case. + */ + if (*cs2 & mask) return Less; + cs_end = cs2 + (cs_end - cs1); + while (++cs2 < cs_end) + if (*cs2) return Less; + return Greater; + } + return Equal; + } -- cgit v1.2.3