1 /*
2 * boolean.c
3 *
4 * Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org>
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 */
33
34 #define LIBGAUCHE_BODY
35 #include "gauche.h"
36 #include "gauche/priv/vmP.h" /* for ScmVMUndefinedBool() */
37
Scm_EqP(ScmObj x,ScmObj y)38 int Scm_EqP(ScmObj x, ScmObj y)
39 {
40 return SCM_EQ(x, y);
41 }
42
Scm_EqvP(ScmObj x,ScmObj y)43 int Scm_EqvP(ScmObj x, ScmObj y)
44 {
45 /* For our implementation, only numbers need different treatment
46 than SCM_EQ. We first check flonums, or we'd have to FLONUM_ENSURE_MEM
47 before we pass them to Scm_NumEq.
48 */
49 if (SCM_NUMBERP(x)) {
50 if (SCM_NUMBERP(y)) {
51 /* Since flonums are the only "inexact real" type in Gauche,
52 we can safely reject the cases where either one is flonum and
53 another is not. */
54 if (SCM_FLONUMP(x)) {
55 if (SCM_FLONUMP(y)) {
56 return (SCM_FLONUM_VALUE(x) == SCM_FLONUM_VALUE(y));
57 } else {
58 return FALSE;
59 }
60 } else if (SCM_FLONUMP(y)) {
61 return FALSE;
62 }
63 /* More generic case. */
64 if ((SCM_EXACTP(x) && SCM_EXACTP(y))
65 || (SCM_INEXACTP(x) && SCM_INEXACTP(y))) {
66 return Scm_NumEq(x, y);
67 }
68 }
69 return FALSE;
70 }
71 return SCM_EQ(x, y);
72 }
73
74 /* Equal? needs to deal with circuler structures.
75 We adopt the algorithm in Adams&Dybvig's "Efficient Nondestructive
76 Equality Checking for Trees and Graphs",
77 Proceedings of ICFP 08, pp. 179-188.
78
79 It is much easier to write the algorithm in Scheme, but we don't want
80 the overhead of crossing C-Scheme boundary for trivial cases.
81 So we cover a simple cases (non-aggregates, user-defined objects and
82 flat lists/vectors) in C, and fall back to Scheme routine if we encounter
83 more complex structures.
84
85 Caveat: The cycle may involve user-defined objects. To detect such
86 cycle, we need to pass down the context info to ScmClass.compare
87 procedure and object-equal? method. This change would break
88 the backward compatibility, so we'll consider it in future versions.
89 For now, let such cyclic structures explode.
90 */
91
Scm_EqualP(ScmObj x,ScmObj y)92 int Scm_EqualP(ScmObj x, ScmObj y)
93 {
94 #define CHECK_AGGREGATE(a, b) \
95 do { \
96 if (SCM_PAIRP(a)) { \
97 if (SCM_PAIRP(b)) goto fallback; \
98 return FALSE; \
99 } \
100 if (SCM_VECTORP(a)) { \
101 if (SCM_VECTORP(b)) goto fallback; \
102 return FALSE; \
103 } \
104 if (!Scm_EqualP(a, b)) return FALSE; \
105 } while (0) \
106
107 if (SCM_EQ(x, y)) return TRUE;
108
109 if (SCM_NUMBERP(x)) {
110 if (!SCM_NUMBERP(y)) return FALSE;
111 return Scm_EqvP(x, y);
112 }
113 if (SCM_PAIRP(x)) {
114 if (!SCM_PAIRP(y)) return FALSE;
115 /* We loop on "spine" of lists, so that the typical long flat list
116 can be compared quickly. If we find nested lists/vectors, we
117 jump to Scheme routine. We adopt hare and tortoise to detect
118 loop in the CDR side. */
119 ScmObj xslow = x; ScmObj yslow = y;
120 int xcirc = FALSE; int ycirc = FALSE;
121 for (;;) {
122 ScmObj carx = SCM_CAR(x);
123 ScmObj cary = SCM_CAR(y);
124 CHECK_AGGREGATE(carx, cary);
125
126 x = SCM_CDR(x); y = SCM_CDR(y);
127 if (!SCM_PAIRP(x) || !SCM_PAIRP(y)) return Scm_EqualP(x, y);
128 carx = SCM_CAR(x); cary = SCM_CAR(y);
129
130 CHECK_AGGREGATE(carx, cary);
131
132 if (xslow == x) {
133 if (ycirc) return TRUE;
134 xcirc = TRUE;
135 }
136 if (yslow == y) {
137 if (xcirc) return TRUE;
138 ycirc = TRUE;
139 }
140
141 x = SCM_CDR(x); y = SCM_CDR(y);
142 if (!SCM_PAIRP(x) || !SCM_PAIRP(y)) return Scm_EqualP(x, y);
143 xslow = SCM_CDR(xslow); yslow = SCM_CDR(yslow);
144 }
145 }
146 if (SCM_VECTORP(x)) {
147 if (!SCM_VECTORP(y)) return FALSE;
148 ScmWord i = 0, len = SCM_VECTOR_SIZE(x);
149 if (SCM_VECTOR_SIZE(y) != len) return FALSE;
150 for (; i < len; i++) {
151 ScmObj xx = SCM_VECTOR_ELEMENT(x, i);
152 ScmObj yy = SCM_VECTOR_ELEMENT(y, i);
153 /* NB: If we detect nested structure in middle of vectors,
154 we run Scheme routine for the entire vector; so we'll test
155 equality of elements before the current one again. If
156 they are simple objects that's negligible, but there may
157 be objects of user-defined datatypes, for which object-equal?
158 could be expensive; we'll fix it in future. */
159 CHECK_AGGREGATE(xx, yy);
160 }
161 return TRUE;
162 }
163 if (SCM_STRINGP(x)) {
164 if (!SCM_STRINGP(y)) return FALSE;
165 return Scm_StringEqual(SCM_STRING(x), SCM_STRING(y));
166 }
167 /* EXPERIMENTAL: when identifier is compared by equal?,
168 we use its symbolic name to compare. This allows
169 comparing macro output with equal?, and also less confusing
170 when R5RS macro and legacy macro are mixed.
171 For "proper" comparison of identifiers keeping their semantics,
172 we need such procedures as free-identifier=? and bound-identifier=?
173 anyway, so this change of equal? won't have a negative impact, I hope.
174
175 NB: this operation come here instead of the beginning of this
176 procedure, since comparing identifiers are relatively rare so
177 we don't want to check idnetifier-ness every time.
178 */
179 if (SCM_IDENTIFIERP(x) || SCM_IDENTIFIERP(y)) {
180 if (SCM_IDENTIFIERP(x))
181 x = SCM_OBJ(Scm_UnwrapIdentifier(SCM_IDENTIFIER(x)));
182 if (SCM_IDENTIFIERP(y))
183 y = SCM_OBJ(Scm_UnwrapIdentifier(SCM_IDENTIFIER(y)));
184 return SCM_EQ(x, y);
185 }
186 /* End of EXPERIMENTAL code */
187
188 if (!SCM_HPTRP(x)) return (x == y);
189 ScmClass *cx = Scm_ClassOf(x);
190 ScmClass *cy = Scm_ClassOf(y);
191 if (cx == cy && cx->compare) return (cx->compare(x, y, TRUE) == 0);
192 else return FALSE;
193
194 fallback:
195 {
196 /* Fall back to Scheme version. */
197 static ScmObj equal_interleave_proc = SCM_UNDEFINED;
198 SCM_BIND_PROC(equal_interleave_proc, "%interleave-equal?",
199 Scm_GaucheInternalModule());
200 return !SCM_FALSEP(Scm_ApplyRec2(equal_interleave_proc, x, y));
201 }
202 #undef CHECK_AGGREGATE
203 }
204
Scm_EqualM(ScmObj x,ScmObj y,int mode)205 int Scm_EqualM(ScmObj x, ScmObj y, int mode)
206 {
207 switch (mode) {
208 case SCM_CMP_EQ:
209 return SCM_EQ(x, y);
210 case SCM_CMP_EQV:
211 return Scm_EqvP(x, y);
212 case SCM_CMP_EQUAL:
213 return Scm_EqualP(x, y);
214 }
215 return FALSE;
216 }
217
218 /*
219 * This is called from BF and BT instructions, right after we found
220 * #<undef> is used in boolean expression.
221 */
222
223 extern void Scm_DumpStackTrace(ScmVM*, ScmPort*);
224 extern void Scm_VMDump(ScmVM*);
225
Scm_VMUndefinedBool(ScmVM * vm)226 int Scm_VMUndefinedBool(ScmVM *vm)
227 {
228 if (SCM_VM_RUNTIME_FLAG_IS_SET(vm, SCM_CHECK_UNDEFINED_TEST)) {
229 Scm_Warn("#<undef> is used in boolean context.\n");
230 Scm_DumpStackTrace(vm, SCM_CURERR);
231 //Too verbose, but can be useful to track into precomp'd code
232 //Scm_VMDump(vm);
233 }
234 return FALSE; /* must return FALSE (meaning 'undefined is not #f') */
235 }
236