1 /*
2 * Predicates for equality and type tests, types, classes in CLISP
3 * Bruno Haible 1990-2005, 2017
4 * Sam Steingold 1998-2011
5 * German comments translated into English: Stefan Kain 2002-09-15
6 */
7
8 #include "lispbibl.c"
9 #include "arilev0.c" /* for R_sign */
10
11 /* UP: tests for equality of atoms EQL
12 eql(obj1,obj2)
13 > obj1,obj2: Lisp objects
14 < result: true, if objects are eql */
eql(object obj1,object obj2)15 modexp bool eql (object obj1, object obj2)
16 {
17 start:
18 if (eq(obj1,obj2))
19 return true; /* (EQ x y) ==> (EQL x y) */
20 /* otherwise EQL-equality is only possible, if both are numbers: */
21 #ifdef TYPECODES
22 if (!(numberp(obj1) && numberp(obj2)))
23 return false;
24 /* and the type of both has to match: */
25 if (typecode(obj1) != typecode(obj2))
26 return false;
27 switch (typecode(obj1))
28 #else
29 if (!(orecordp(obj1) && orecordp(obj2)))
30 return false;
31 if (Record_type(obj1) != Record_type(obj2))
32 return false;
33 switch (Record_type(obj1)) {
34 case_Rectype_Bignum_above;
35 case_Rectype_Ratio_above;
36 case_Rectype_Complex_above;
37 case_Rectype_Ffloat_above;
38 case_Rectype_Dfloat_above;
39 case_Rectype_Lfloat_above;
40 default: goto no;
41 }
42 switch (0)
43 #endif
44 {
45 case_bignum: { /* Bignums */
46 /* compare lengths: */
47 var uintC length1 = Bignum_length(obj1);
48 if (length1 != Bignum_length(obj2)) goto no;
49 /* compare digits: */
50 var uintD* ptr1 = &TheBignum(obj1)->data[0];
51 var uintD* ptr2 = &TheBignum(obj2)->data[0];
52 dotimespC(length1,length1, { if (!(*ptr1++ == *ptr2++)) goto no; });
53 }
54 return true;
55 case_ratio: /* Ratio */
56 /* numerator and denominator have to match:
57 (and (eql (numerator obj1) (numerator obj2))
58 (eql (denominator obj1) (denominator obj2))) */
59 if (!eql(TheRatio(obj1)->rt_num,TheRatio(obj2)->rt_num)) goto no;
60 /* return eql(TheRatio(obj1)->rt_den,TheRatio(obj2)->rt_den); */
61 obj1 = TheRatio(obj1)->rt_den; obj2 = TheRatio(obj2)->rt_den;
62 goto start;
63 case_complex: /* Complex */
64 /* real- and imaginary part have to match:
65 (and (eql (realpart obj1) (realpart obj2))
66 (eql (imagpart obj1) (imagpart obj2))) */
67 if (!eql(TheComplex(obj1)->c_real,TheComplex(obj2)->c_real)) goto no;
68 /* return eql(TheComplex(obj1)->c_imag,TheComplex(obj2)->c_imag); */
69 obj1 = TheComplex(obj1)->c_imag; obj2 = TheComplex(obj2)->c_imag;
70 goto start;
71 case_ffloat: /* Single-Floats */
72 #ifndef IMMEDIATE_FFLOAT
73 if (TheFfloat(obj1)->float_value == TheFfloat(obj2)->float_value)
74 return true;
75 else
76 #endif
77 goto no;
78 case_dfloat: /* Double-Floats */
79 #ifdef intQsize
80 if (TheDfloat(obj1)->float_value == TheDfloat(obj2)->float_value)
81 #else
82 if ((TheDfloat(obj1)->float_value.semhi ==
83 TheDfloat(obj2)->float_value.semhi)
84 && (TheDfloat(obj1)->float_value.mlo ==
85 TheDfloat(obj2)->float_value.mlo))
86 #endif
87 return true;
88 else
89 goto no;
90 case_lfloat: { /* Long-Floats */
91 /* compare lengths: */
92 var uintC len1 = Lfloat_length(obj1);
93 if (len1 != Lfloat_length(obj2)) goto no;
94 /* compare exponents: */
95 if (TheLfloat(obj1)->expo != TheLfloat(obj2)->expo) goto no;
96 /* compare signs: (LF_sign not usable here.) */
97 #ifdef TYPECODES
98 if (R_sign(as_object(as_oint(obj1) ^ as_oint(obj2))) < 0) goto no;
99 #else
100 if (Record_flags(obj1) != Record_flags(obj2)) goto no;
101 #endif
102 { /* compare digits: */
103 var uintD* ptr1 = &TheLfloat(obj1)->data[0];
104 var uintD* ptr2 = &TheLfloat(obj2)->data[0];
105 dotimespC(len1,len1, { if (!(*ptr1++ == *ptr2++)) goto no; });
106 }}
107 return true;
108 /* case_fixnum: */ /* Fixnums: should already have been EQ */
109 /* case_sfloat: */ /* Short-Floats: should already have been EQ */
110 default:
111 no: return false;
112 }
113 }
114
115 /* UP: tests for equality EQUAL
116 equal(obj1,obj2)
117 > obj1,obj2: Lisp objects
118 < result: true, if objects are EQUAL */
equal(object obj1,object obj2)119 modexp bool equal (object obj1, object obj2)
120 {
121 start:
122 if (eql(obj1,obj2))
123 return true; /* (EQL x y) ==> (EQUAL x y) */
124 /* otherwise EQUAL equality is only possible, if both are structured
125 types. Types have to match (including notsimple_bit): */
126 #ifdef TYPECODES
127 switch (typecode(obj1))
128 #else
129 if (consp(obj1)) {
130 goto case_cons;
131 } else if (orecordp(obj1)) {
132 goto case_orecord;
133 } else
134 goto no;
135 switch (0)
136 #endif
137 {
138 case_cons: /* compare conses recursively: */
139 if (!consp(obj2))
140 return false;
141 /* CAR and CDR must match:
142 (and (equal (car obj1) (car obj2)) (equal (cdr obj1) (cdr obj2))) */
143 check_SP();
144 if (!equal(Car(obj1),Car(obj2))) goto no;
145 /* return equal(Cdr(obj1),Cdr(obj2)); */
146 obj1 = Cdr(obj1); obj2 = Cdr(obj2);
147 goto start;
148 case_sbvector: case_obvector: /* compare bit vectors element-wise: */
149 if (!bit_vector_p(Atype_Bit,obj2))
150 return false;
151 { /* compare lengths: */
152 var uintL len1 = vector_length(obj1);
153 if (!(len1 == vector_length(obj2))) goto no;
154 if (len1 == 0)
155 return true;
156 { /* compare contents: */
157 var uintL index1 = 0;
158 var uintL index2 = 0;
159 var object sbv1 = array_displace_check(obj1,len1,&index1);
160 var object sbv2 = array_displace_check(obj2,len1,&index2);
161 /* sbvi is the data vector, indexi the index into the data vector
162 for obji (i=1,2). */
163 return bit_compare(sbv1,index1,sbv2,index2,len1);
164 }
165 }
166 case_string: /* compare strings element-wise: */
167 if (stringp(obj2)) {
168 /* compare lengths: */
169 var uintL len1 = vector_length(obj1);
170 if (len1 != vector_length(obj2)) goto no;
171 /* compare content: */
172 if (len1 != 0) {
173 var uintL index1 = 0;
174 var uintL index2 = 0;
175 var object ss1 = array_displace_check(obj1,len1,&index1);
176 var object ss2 = array_displace_check(obj2,len1,&index2);
177 /* ssi is the data vector, indexi the Index into the data vector
178 for obji (i=1,2). */
179 if (simple_nilarray_p(ss1) || simple_nilarray_p(ss2))
180 /* obj1 or obj2 has element type NIL. */
181 return eq(ss1,ss2);
182 else
183 return string_eqcomp(ss1,index1,ss2,index2,len1);
184 }
185 return true;
186 } else {
187 return (nil_vector_p(obj2) && vector_length(obj2) == 0
188 && vector_length(obj1) == 0);
189 }
190 case_ovector: /* (VECTOR NIL) is a STRING */
191 if ((Iarray_flags(obj1) & arrayflags_atype_mask) == Atype_NIL)
192 return (vector_length(obj1) == 0
193 && (stringp(obj2) || nil_vector_p(obj2))
194 && vector_length(obj2) == 0);
195 return false;
196 case_orecord:
197 switch (Record_type(obj1)) {
198 case_Rectype_obvector_above;
199 case_Rectype_Sbvector_above;
200 case_Rectype_string_above;
201 case_Rectype_ovector_above;
202 case Rectype_Pathname:
203 /* compare pathnames component-wise: */
204 if (!pathnamep(obj2)) goto no;
205 {
206 var gcv_object_t* ptr1 = &TheRecord(obj1)->recdata[0];
207 var gcv_object_t* ptr2 = &TheRecord(obj2)->recdata[0];
208 var uintC count;
209 check_SP();
210 #if !defined(PATHNAME_WIN32)
211 dotimespC(count,pathname_length, {
212 if (!equal(*ptr1++,*ptr2++)) goto no;
213 });
214 #else /* defined(PATHNAME_WIN32) */
215 /* pathname components consist of conses, simple-strings
216 and symbols. compare simple-strings case-insensitive: */
217 dotimespC(count,pathname_length, {
218 if (!equalp(*ptr1++,*ptr2++)) goto no; /* (omits no GC!) */
219 });
220 #endif
221 return true;
222 }
223 case Rectype_Logpathname:
224 /* compare logical pathnames component-wise, too: */
225 if (!logpathnamep(obj2)) goto no;
226 {
227 var gcv_object_t* ptr1 = &TheRecord(obj1)->recdata[0];
228 var gcv_object_t* ptr2 = &TheRecord(obj2)->recdata[0];
229 var uintC count;
230 check_SP();
231 dotimespC(count,logpathname_length, {
232 if (!equal(*ptr1++,*ptr2++)) goto no;
233 });
234 return true;
235 }
236 default: goto no;
237 }
238 /* otherwise, obj1 and obj2 are considered different. */
239 default: no:
240 return false;
241 }
242 }
243
244 /* UP: tests for laxer equality EQUALP
245 equalp(obj1,obj2)
246 > obj1,obj2: Lisp-objects
247 < result: true, if objects are equal */
248 global bool equalp (object obj1, object obj2);
249 /* Element-by-element comparisons for various vector types. count > 0. */
250 typedef bool elt_compare_t (object dv1, uintL index1,
251 object dv2, uintL index2, uintL count);
252 local elt_compare_t elt_compare_T_T;
253 local elt_compare_t elt_compare_T_Char;
254 local elt_compare_t elt_compare_T_Bit;
255 local elt_compare_t elt_compare_T_2Bit;
256 local elt_compare_t elt_compare_T_4Bit;
257 local elt_compare_t elt_compare_T_8Bit;
258 local elt_compare_t elt_compare_T_16Bit;
259 local elt_compare_t elt_compare_T_32Bit;
260 local elt_compare_t elt_compare_Char_Char;
261 local elt_compare_t elt_compare_Bit_Bit;
262 local elt_compare_t elt_compare_Bit_2Bit;
263 local elt_compare_t elt_compare_Bit_4Bit;
264 local elt_compare_t elt_compare_Bit_8Bit;
265 local elt_compare_t elt_compare_Bit_16Bit;
266 local elt_compare_t elt_compare_Bit_32Bit;
267 local elt_compare_t elt_compare_2Bit_2Bit;
268 local elt_compare_t elt_compare_2Bit_4Bit;
269 local elt_compare_t elt_compare_2Bit_8Bit;
270 local elt_compare_t elt_compare_2Bit_16Bit;
271 local elt_compare_t elt_compare_2Bit_32Bit;
272 local elt_compare_t elt_compare_4Bit_4Bit;
273 local elt_compare_t elt_compare_4Bit_8Bit;
274 local elt_compare_t elt_compare_4Bit_16Bit;
275 local elt_compare_t elt_compare_4Bit_32Bit;
276 local elt_compare_t elt_compare_8Bit_8Bit;
277 local elt_compare_t elt_compare_8Bit_16Bit;
278 local elt_compare_t elt_compare_8Bit_32Bit;
279 local elt_compare_t elt_compare_16Bit_16Bit;
280 local elt_compare_t elt_compare_16Bit_32Bit;
281 local elt_compare_t elt_compare_32Bit_32Bit;
282 local elt_compare_t elt_compare;
283
elt_compare_T_T(object dv1,uintL index1,object dv2,uintL index2,uintL count)284 local bool elt_compare_T_T (object dv1, uintL index1,
285 object dv2, uintL index2, uintL count)
286 {
287 check_SP();
288 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
289 var const gcv_object_t* ptr2 = &TheSvector(dv2)->data[index2];
290 dotimespL(count,count, {
291 if (!equalp(*ptr1++,*ptr2++)) goto no;
292 });
293 return true;
294 no: return false;
295 }
elt_compare_T_Char(object dv1,uintL index1,object dv2,uintL index2,uintL count)296 local bool elt_compare_T_Char (object dv1, uintL index1,
297 object dv2, uintL index2, uintL count)
298 {
299 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
300 SstringDispatch(dv2,X, {
301 var const cintX* ptr2 = &((SstringX)TheVarobject(dv2))->data[index2];
302 dotimespL(count,count, {
303 var object elt1 = *ptr1++;
304 var chart elt2 = as_chart(*ptr2++);
305 if (!(charp(elt1) && chareq(up_case(char_code(elt1)),up_case(elt2))))
306 goto no;
307 });
308 });
309 return true;
310 no: return false;
311 }
elt_compare_T_Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)312 local bool elt_compare_T_Bit (object dv1, uintL index1,
313 object dv2, uintL index2, uintL count)
314 {
315 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
316 var const uintB* ptr2 = &TheSbvector(dv2)->data[index2/8];
317 dotimespL(count,count, {
318 var object elt1 = *ptr1++;
319 var uintB elt2 = (*ptr2 >> ((~index2)%8)) & (bit(1)-1);
320 if (!eq(elt1,fixnum(elt2))) goto no;
321 index2++;
322 ptr2 += ((index2%8)==0);
323 });
324 return true;
325 no: return false;
326 }
elt_compare_T_2Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)327 local bool elt_compare_T_2Bit (object dv1, uintL index1,
328 object dv2, uintL index2, uintL count)
329 {
330 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
331 var const uintB* ptr2 = &TheSbvector(dv2)->data[index2/4];
332 dotimespL(count,count, {
333 var object elt1 = *ptr1++;
334 var uintB elt2 = (*ptr2 >> (2*((~index2)%4))) & (bit(2)-1);
335 if (!eq(elt1,fixnum(elt2))) goto no;
336 index2++;
337 ptr2 += ((index2%4)==0);
338 });
339 return true;
340 no: return false;
341 }
elt_compare_T_4Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)342 local bool elt_compare_T_4Bit (object dv1, uintL index1,
343 object dv2, uintL index2, uintL count)
344 {
345 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
346 var const uintB* ptr2 = &TheSbvector(dv2)->data[index2/2];
347 dotimespL(count,count, {
348 var object elt1 = *ptr1++;
349 var uintB elt2 = (*ptr2 >> (4*((~index2)%2))) & (bit(4)-1);
350 if (!eq(elt1,fixnum(elt2))) goto no;
351 index2++;
352 ptr2 += ((index2%2)==0);
353 });
354 return true;
355 no: return false;
356 }
elt_compare_T_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)357 local bool elt_compare_T_8Bit (object dv1, uintL index1,
358 object dv2, uintL index2, uintL count)
359 {
360 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
361 var const uintB* ptr2 = &TheSbvector(dv2)->data[index2];
362 dotimespL(count,count, {
363 var object elt1 = *ptr1++;
364 var uintB elt2 = *ptr2++;
365 if (!eq(elt1,fixnum(elt2))) goto no;
366 });
367 return true;
368 no: return false;
369 }
elt_compare_T_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)370 local bool elt_compare_T_16Bit (object dv1, uintL index1,
371 object dv2, uintL index2, uintL count)
372 {
373 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
374 var const uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
375 dotimespL(count,count, {
376 var object elt1 = *ptr1++;
377 var uint16 elt2 = *ptr2++;
378 if (!eq(elt1,fixnum(elt2))) goto no;
379 });
380 return true;
381 no: return false;
382 }
elt_compare_T_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)383 local bool elt_compare_T_32Bit (object dv1, uintL index1,
384 object dv2, uintL index2, uintL count)
385 {
386 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
387 var const uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
388 dotimespL(count,count, {
389 var object elt1 = *ptr1++;
390 var uint32 elt2 = *ptr2++;
391 if (!(uint32_p(elt1) && (I_to_uint32(elt1) == elt2)))
392 goto no;
393 });
394 return true;
395 no: return false;
396 }
397 #define elt_compare_Char_Char(dv1,index1,dv2,index2,count) \
398 string_eqcomp_ci(dv1,index1,dv2,index2,count)
399 #define elt_compare_Bit_Bit(dv1,index1,dv2,index2,count) \
400 bit_compare(dv1,index1,dv2,index2,count)
elt_compare_Bit_2Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)401 local bool elt_compare_Bit_2Bit (object dv1, uintL index1,
402 object dv2, uintL index2, uintL count)
403 {
404 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1/8];
405 var const uintB* ptr2 = &TheSbvector(dv2)->data[index2/4];
406 dotimespL(count,count, {
407 var uintB elt1 = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
408 var uintB elt2 = (*ptr2 >> (2*((~index2)%4))) & (bit(2)-1);
409 if (!(elt1 == elt2)) goto no;
410 index1++;
411 ptr1 += ((index1%8)==0);
412 index2++;
413 ptr2 += ((index2%4)==0);
414 });
415 return true;
416 no: return false;
417 }
elt_compare_Bit_4Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)418 local bool elt_compare_Bit_4Bit (object dv1, uintL index1,
419 object dv2, uintL index2, uintL count)
420 {
421 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1/8];
422 var const uintB* ptr2 = &TheSbvector(dv2)->data[index2/2];
423 dotimespL(count,count, {
424 var uintB elt1 = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
425 var uintB elt2 = (*ptr2 >> (4*((~index2)%2))) & (bit(4)-1);
426 if (!(elt1 == elt2)) goto no;
427 index1++;
428 ptr1 += ((index1%8)==0);
429 index2++;
430 ptr2 += ((index2%2)==0);
431 });
432 return true;
433 no: return false;
434 }
elt_compare_Bit_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)435 local bool elt_compare_Bit_8Bit (object dv1, uintL index1,
436 object dv2, uintL index2, uintL count)
437 {
438 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1/8];
439 var const uintB* ptr2 = &TheSbvector(dv2)->data[index2];
440 dotimespL(count,count, {
441 var uintB elt1 = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
442 if (!(elt1 == *ptr2++)) goto no;
443 index1++;
444 ptr1 += ((index1%8)==0);
445 });
446 return true;
447 no: return false;
448 }
elt_compare_Bit_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)449 local bool elt_compare_Bit_16Bit (object dv1, uintL index1,
450 object dv2, uintL index2, uintL count)
451 {
452 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1/8];
453 var const uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
454 dotimespL(count,count, {
455 var uintB elt1 = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
456 if (!(elt1 == *ptr2++)) goto no;
457 index1++;
458 ptr1 += ((index1%8)==0);
459 });
460 return true;
461 no: return false;
462 }
elt_compare_Bit_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)463 local bool elt_compare_Bit_32Bit (object dv1, uintL index1,
464 object dv2, uintL index2, uintL count)
465 {
466 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1/8];
467 var const uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
468 dotimespL(count,count, {
469 var uintB elt1 = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
470 if (!(elt1 == *ptr2++)) goto no;
471 index1++;
472 ptr1 += ((index1%8)==0);
473 });
474 return true;
475 no: return false;
476 }
477 #define elt_compare_2Bit_2Bit(dv1,index1,dv2,index2,count) \
478 bit_compare(dv1,index1<<1,dv2,index2<<1,count<<1)
elt_compare_2Bit_4Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)479 local bool elt_compare_2Bit_4Bit (object dv1, uintL index1,
480 object dv2, uintL index2, uintL count)
481 {
482 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1/4];
483 var const uintB* ptr2 = &TheSbvector(dv2)->data[index2/2];
484 dotimespL(count,count, {
485 var uintB elt1 = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
486 var uintB elt2 = (*ptr2 >> (4*((~index2)%2))) & (bit(4)-1);
487 if (!(elt1 == elt2)) goto no;
488 index1++;
489 ptr1 += ((index1%4)==0);
490 index2++;
491 ptr2 += ((index2%2)==0);
492 });
493 return true;
494 no: return false;
495 }
elt_compare_2Bit_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)496 local bool elt_compare_2Bit_8Bit (object dv1, uintL index1,
497 object dv2, uintL index2, uintL count)
498 {
499 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1/4];
500 var const uintB* ptr2 = &TheSbvector(dv2)->data[index2];
501 dotimespL(count,count, {
502 var uintB elt1 = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
503 if (!(elt1 == *ptr2++)) goto no;
504 index1++;
505 ptr1 += ((index1%4)==0);
506 });
507 return true;
508 no: return false;
509 }
elt_compare_2Bit_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)510 local bool elt_compare_2Bit_16Bit (object dv1, uintL index1,
511 object dv2, uintL index2, uintL count)
512 {
513 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1/4];
514 var const uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
515 dotimespL(count,count, {
516 var uintB elt1 = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
517 if (!(elt1 == *ptr2++)) goto no;
518 index1++;
519 ptr1 += ((index1%4)==0);
520 });
521 return true;
522 no: return false;
523 }
elt_compare_2Bit_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)524 local bool elt_compare_2Bit_32Bit (object dv1, uintL index1,
525 object dv2, uintL index2, uintL count)
526 {
527 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1/4];
528 var const uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
529 dotimespL(count,count, {
530 var uintB elt1 = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
531 if (!(elt1 == *ptr2++)) goto no;
532 index1++;
533 ptr1 += ((index1%4)==0);
534 });
535 return true;
536 no: return false;
537 }
538 #define elt_compare_4Bit_4Bit(dv1,index1,dv2,index2,count) \
539 bit_compare(dv1,index1<<2,dv2,index2<<2,count<<2)
elt_compare_4Bit_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)540 local bool elt_compare_4Bit_8Bit (object dv1, uintL index1,
541 object dv2, uintL index2, uintL count)
542 {
543 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1/2];
544 var const uintB* ptr2 = &TheSbvector(dv2)->data[index2];
545 dotimespL(count,count, {
546 var uintB elt1 = (*ptr1 >> (4*((~index1)%2))) & (bit(4)-1);
547 if (!(elt1 == *ptr2++)) goto no;
548 index1++;
549 ptr1 += ((index1%2)==0);
550 });
551 return true;
552 no: return false;
553 }
elt_compare_4Bit_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)554 local bool elt_compare_4Bit_16Bit (object dv1, uintL index1,
555 object dv2, uintL index2, uintL count)
556 {
557 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1/2];
558 var const uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
559 dotimespL(count,count, {
560 var uintB elt1 = (*ptr1 >> (4*((~index1)%2))) & (bit(4)-1);
561 if (!(elt1 == *ptr2++)) goto no;
562 index1++;
563 ptr1 += ((index1%2)==0);
564 });
565 return true;
566 no: return false;
567 }
elt_compare_4Bit_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)568 local bool elt_compare_4Bit_32Bit (object dv1, uintL index1,
569 object dv2, uintL index2, uintL count)
570 {
571 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1/2];
572 var const uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
573 dotimespL(count,count, {
574 var uintB elt1 = (*ptr1 >> (4*((~index1)%2))) & (bit(4)-1);
575 if (!(elt1 == *ptr2++)) goto no;
576 index1++;
577 ptr1 += ((index1%2)==0);
578 });
579 return true;
580 no: return false;
581 }
elt_compare_8Bit_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)582 local bool elt_compare_8Bit_8Bit (object dv1, uintL index1,
583 object dv2, uintL index2, uintL count)
584 {
585 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1];
586 var const uintB* ptr2 = &TheSbvector(dv2)->data[index2];
587 dotimespL(count,count, {
588 if (!(*ptr1++ == *ptr2++)) goto no;
589 });
590 return true;
591 no: return false;
592 }
elt_compare_8Bit_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)593 local bool elt_compare_8Bit_16Bit (object dv1, uintL index1,
594 object dv2, uintL index2, uintL count)
595 {
596 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1];
597 var const uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
598 dotimespL(count,count, {
599 if (!(*ptr1++ == *ptr2++)) goto no;
600 });
601 return true;
602 no: return false;
603 }
elt_compare_8Bit_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)604 local bool elt_compare_8Bit_32Bit (object dv1, uintL index1,
605 object dv2, uintL index2, uintL count)
606 {
607 var const uintB* ptr1 = &TheSbvector(dv1)->data[index1];
608 var const uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
609 dotimespL(count,count, {
610 if (!(*ptr1++ == *ptr2++)) goto no;
611 });
612 return true;
613 no: return false;
614 }
elt_compare_16Bit_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)615 local bool elt_compare_16Bit_16Bit (object dv1, uintL index1,
616 object dv2, uintL index2, uintL count)
617 {
618 var const uint16* ptr1 = &((uint16*)&TheSbvector(dv1)->data[0])[index1];
619 var const uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
620 dotimespL(count,count, {
621 if (!(*ptr1++ == *ptr2++)) goto no;
622 });
623 return true;
624 no: return false;
625 }
elt_compare_16Bit_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)626 local bool elt_compare_16Bit_32Bit (object dv1, uintL index1,
627 object dv2, uintL index2, uintL count)
628 {
629 var const uint16* ptr1 = &((uint16*)&TheSbvector(dv1)->data[0])[index1];
630 var const uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
631 dotimespL(count,count, {
632 if (!(*ptr1++ == *ptr2++)) goto no;
633 });
634 return true;
635 no: return false;
636 }
elt_compare_32Bit_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)637 local bool elt_compare_32Bit_32Bit (object dv1, uintL index1,
638 object dv2, uintL index2, uintL count)
639 {
640 var const uint32* ptr1 = &((uint32*)&TheSbvector(dv1)->data[0])[index1];
641 var const uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
642 dotimespL(count,count, {
643 if (!(*ptr1++ == *ptr2++)) goto no;
644 });
645 return true;
646 no: return false;
647 }
elt_compare(object dv1,uintL index1,object dv2,uintL index2,uintL count)648 local bool elt_compare (object dv1, uintL index1,
649 object dv2, uintL index2, uintL count)
650 {
651 switch (Array_type(dv1)) {
652 case Array_type_svector: /* Simple-Vector */
653 switch (Array_type(dv2)) {
654 case Array_type_svector: /* Simple-Vector */
655 return elt_compare_T_T(dv1,index1,dv2,index2,count);
656 case Array_type_sbvector: /* Simple-Bit-Vector */
657 return elt_compare_T_Bit(dv1,index1,dv2,index2,count);
658 case Array_type_sb2vector:
659 return elt_compare_T_2Bit(dv1,index1,dv2,index2,count);
660 case Array_type_sb4vector:
661 return elt_compare_T_4Bit(dv1,index1,dv2,index2,count);
662 case Array_type_sb8vector:
663 return elt_compare_T_8Bit(dv1,index1,dv2,index2,count);
664 case Array_type_sb16vector:
665 return elt_compare_T_16Bit(dv1,index1,dv2,index2,count);
666 case Array_type_sb32vector:
667 return elt_compare_T_32Bit(dv1,index1,dv2,index2,count);
668 case Array_type_sstring: /* Simple-String */
669 return elt_compare_T_Char(dv1,index1,dv2,index2,count);
670 case Array_type_snilvector: /* (VECTOR NIL) */
671 /* One can argue that comparing nonexistent elements should yield
672 an error, not false. */
673 /*error_nilarray_retrieve();*/
674 return false;
675 default: NOTREACHED;
676 }
677 case Array_type_sbvector: /* Simple-Bit-Vector */
678 switch (Array_type(dv2)) {
679 case Array_type_svector: /* Simple-Vector */
680 return elt_compare_T_Bit(dv2,index2,dv1,index1,count);
681 case Array_type_sbvector: /* Simple-Bit-Vector */
682 return elt_compare_Bit_Bit(dv1,index1,dv2,index2,count);
683 case Array_type_sb2vector:
684 return elt_compare_Bit_2Bit(dv1,index1,dv2,index2,count);
685 case Array_type_sb4vector:
686 return elt_compare_Bit_4Bit(dv1,index1,dv2,index2,count);
687 case Array_type_sb8vector:
688 return elt_compare_Bit_8Bit(dv1,index1,dv2,index2,count);
689 case Array_type_sb16vector:
690 return elt_compare_Bit_16Bit(dv1,index1,dv2,index2,count);
691 case Array_type_sb32vector:
692 return elt_compare_Bit_32Bit(dv1,index1,dv2,index2,count);
693 case Array_type_sstring: /* Simple-String */
694 return false; /* because count > 0 */
695 case Array_type_snilvector: /* (VECTOR NIL) */
696 /* One can argue that comparing nonexistent elements should yield
697 an error, not false. */
698 /*error_nilarray_retrieve();*/
699 return false;
700 default: NOTREACHED;
701 }
702 case Array_type_sb2vector:
703 switch (Array_type(dv2)) {
704 case Array_type_svector: /* Simple-Vector */
705 return elt_compare_T_2Bit(dv2,index2,dv1,index1,count);
706 case Array_type_sbvector: /* Simple-Bit-Vector */
707 return elt_compare_Bit_2Bit(dv2,index2,dv1,index1,count);
708 case Array_type_sb2vector:
709 return elt_compare_2Bit_2Bit(dv1,index1,dv2,index2,count);
710 case Array_type_sb4vector:
711 return elt_compare_2Bit_4Bit(dv1,index1,dv2,index2,count);
712 case Array_type_sb8vector:
713 return elt_compare_2Bit_8Bit(dv1,index1,dv2,index2,count);
714 case Array_type_sb16vector:
715 return elt_compare_2Bit_16Bit(dv1,index1,dv2,index2,count);
716 case Array_type_sb32vector:
717 return elt_compare_2Bit_32Bit(dv1,index1,dv2,index2,count);
718 case Array_type_sstring: /* Simple-String */
719 return false; /* because count > 0 */
720 case Array_type_snilvector: /* (VECTOR NIL) */
721 /* One can argue that comparing nonexistent elements should yield
722 an error, not false. */
723 /*error_nilarray_retrieve();*/
724 return false;
725 default: NOTREACHED;
726 }
727 case Array_type_sb4vector:
728 switch (Array_type(dv2)) {
729 case Array_type_svector: /* Simple-Vector */
730 return elt_compare_T_4Bit(dv2,index2,dv1,index1,count);
731 case Array_type_sbvector: /* Simple-Bit-Vector */
732 return elt_compare_Bit_4Bit(dv2,index2,dv1,index1,count);
733 case Array_type_sb2vector:
734 return elt_compare_2Bit_4Bit(dv2,index2,dv1,index1,count);
735 case Array_type_sb4vector:
736 return elt_compare_4Bit_4Bit(dv1,index1,dv2,index2,count);
737 case Array_type_sb8vector:
738 return elt_compare_4Bit_8Bit(dv1,index1,dv2,index2,count);
739 case Array_type_sb16vector:
740 return elt_compare_4Bit_16Bit(dv1,index1,dv2,index2,count);
741 case Array_type_sb32vector:
742 return elt_compare_4Bit_32Bit(dv1,index1,dv2,index2,count);
743 case Array_type_sstring: /* Simple-String */
744 return false; /* because count > 0 */
745 case Array_type_snilvector: /* (VECTOR NIL) */
746 /* One can argue that comparing nonexistent elements should yield
747 an error, not false. */
748 /*error_nilarray_retrieve();*/
749 return false;
750 default: NOTREACHED;
751 }
752 case Array_type_sb8vector:
753 switch (Array_type(dv2)) {
754 case Array_type_svector: /* Simple-Vector */
755 return elt_compare_T_8Bit(dv2,index2,dv1,index1,count);
756 case Array_type_sbvector: /* Simple-Bit-Vector */
757 return elt_compare_Bit_8Bit(dv2,index2,dv1,index1,count);
758 case Array_type_sb2vector:
759 return elt_compare_2Bit_8Bit(dv2,index2,dv1,index1,count);
760 case Array_type_sb4vector:
761 return elt_compare_4Bit_8Bit(dv2,index2,dv1,index1,count);
762 case Array_type_sb8vector:
763 return elt_compare_8Bit_8Bit(dv1,index1,dv2,index2,count);
764 case Array_type_sb16vector:
765 return elt_compare_8Bit_16Bit(dv1,index1,dv2,index2,count);
766 case Array_type_sb32vector:
767 return elt_compare_8Bit_32Bit(dv1,index1,dv2,index2,count);
768 case Array_type_sstring: /* Simple-String */
769 return false; /* because count > 0 */
770 case Array_type_snilvector: /* (VECTOR NIL) */
771 /* One can argue that comparing nonexistent elements should yield
772 an error, not false. */
773 /*error_nilarray_retrieve();*/
774 return false;
775 default: NOTREACHED;
776 }
777 case Array_type_sb16vector:
778 switch (Array_type(dv2)) {
779 case Array_type_svector: /* Simple-Vector */
780 return elt_compare_T_16Bit(dv2,index2,dv1,index1,count);
781 case Array_type_sbvector: /* Simple-Bit-Vector */
782 return elt_compare_Bit_16Bit(dv2,index2,dv1,index1,count);
783 case Array_type_sb2vector:
784 return elt_compare_2Bit_16Bit(dv2,index2,dv1,index1,count);
785 case Array_type_sb4vector:
786 return elt_compare_4Bit_16Bit(dv2,index2,dv1,index1,count);
787 case Array_type_sb8vector:
788 return elt_compare_8Bit_16Bit(dv2,index2,dv1,index1,count);
789 case Array_type_sb16vector:
790 return elt_compare_16Bit_16Bit(dv1,index1,dv2,index2,count);
791 case Array_type_sb32vector:
792 return elt_compare_16Bit_32Bit(dv1,index1,dv2,index2,count);
793 case Array_type_sstring: /* Simple-String */
794 return false; /* because count > 0 */
795 case Array_type_snilvector: /* (VECTOR NIL) */
796 /* One can argue that comparing nonexistent elements should yield
797 an error, not false. */
798 /*error_nilarray_retrieve();*/
799 return false;
800 default: NOTREACHED;
801 }
802 case Array_type_sb32vector:
803 switch (Array_type(dv2)) {
804 case Array_type_svector: /* Simple-Vector */
805 return elt_compare_T_32Bit(dv2,index2,dv1,index1,count);
806 case Array_type_sbvector: /* Simple-Bit-Vector */
807 return elt_compare_Bit_32Bit(dv2,index2,dv1,index1,count);
808 case Array_type_sb2vector:
809 return elt_compare_2Bit_32Bit(dv2,index2,dv1,index1,count);
810 case Array_type_sb4vector:
811 return elt_compare_4Bit_32Bit(dv2,index2,dv1,index1,count);
812 case Array_type_sb8vector:
813 return elt_compare_8Bit_32Bit(dv2,index2,dv1,index1,count);
814 case Array_type_sb16vector:
815 return elt_compare_16Bit_32Bit(dv2,index2,dv1,index1,count);
816 case Array_type_sb32vector:
817 return elt_compare_32Bit_32Bit(dv1,index1,dv2,index2,count);
818 case Array_type_sstring: /* Simple-String */
819 return false; /* because count > 0 */
820 case Array_type_snilvector: /* (VECTOR NIL) */
821 /* One can argue that comparing nonexistent elements should yield
822 an error, not false. */
823 /*error_nilarray_retrieve();*/
824 return false;
825 default: NOTREACHED;
826 }
827 case Array_type_sstring: /* Simple-String */
828 switch (Array_type(dv2)) {
829 case Array_type_svector: /* Simple-Vector */
830 return elt_compare_T_Char(dv2,index2,dv1,index1,count);
831 case Array_type_sbvector: /* Simple-Bit-Vector */
832 case Array_type_sb2vector:
833 case Array_type_sb4vector:
834 case Array_type_sb8vector:
835 case Array_type_sb16vector:
836 case Array_type_sb32vector:
837 return false; /* because count > 0 */
838 case Array_type_sstring: /* Simple-String */
839 return elt_compare_Char_Char(dv1,index1,dv2,index2,count);
840 case Array_type_snilvector: /* (VECTOR NIL) */
841 /* One can argue that comparing nonexistent elements should yield
842 an error, not false. */
843 /*error_nilarray_retrieve();*/
844 return false;
845 default: NOTREACHED;
846 }
847 case Array_type_snilvector: /* (VECTOR NIL) */
848 switch (Array_type(dv2)) {
849 case Array_type_svector: /* Simple-Vector */
850 case Array_type_sbvector: /* Simple-Bit-Vector */
851 case Array_type_sb2vector:
852 case Array_type_sb4vector:
853 case Array_type_sb8vector:
854 case Array_type_sb16vector:
855 case Array_type_sb32vector:
856 case Array_type_sstring: /* Simple-String */
857 /* One can argue that comparing nonexistent elements should yield
858 an error, not false. */
859 /*error_nilarray_retrieve();*/
860 return false;
861 case Array_type_snilvector: /* (VECTOR NIL) */
862 /* One can argue that comparing nonexistent elements should yield
863 an error, not true. But OTOH, we want (equalp (copy-seq x) x)
864 to return true without signalling an error. */
865 return true;
866 default: NOTREACHED;
867 }
868 default: NOTREACHED;
869 }
870 }
871 /* test for hash table equality under EQUALP:
872 <http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/HyperSpec/Body/fun_equalp.html>
873 EQUALP descends hash-tables by first comparing the count of entries and
874 the :test function; if those are the same, it compares the keys of the
875 tables using the :test function and then the values of the matching
876 keys using equalp recursively.
877 However, hash-tables with user-defined test are not compared this way;
878 they are EQUALP only if they are EQ. The reason is that a user-defined test
879 can trigger GC, thus the entry-by-entry comparison of hash-tables with user-
880 defined test can trigger GC. The consequences would be bad: 1. EQUALP could
881 trigger GC. 2. When a hash table table with EQUALP test has two keys which
882 are hash-tables with user-defined test and another key with a non-GC-invariant
883 hash code, a simple hash table lookup could trigger GC, which would
884 invalidate the hash table, which would require a rehash of the hash table,
885 which would again call EQUALP on the elements, etc. - endless recursion. */
hash_table_equalp(object ht1,object ht2)886 local bool hash_table_equalp (object ht1, object ht2)
887 {
888 var uintB flags1 = ht_test_code(record_flags(TheHashtable(ht1)));
889 var uintB flags2 = ht_test_code(record_flags(TheHashtable(ht2)));
890 /* Not same built-in test or a user-defined test? */
891 if (flags1 != flags2
892 || ht_test_code_user_p(flags1) /* || ht_test_code_user_p(flags2) */)
893 return false;
894 if (!eq(TheHashedAlist(TheHashtable(ht1)->ht_kvtable)->hal_count,
895 TheHashedAlist(TheHashtable(ht2)->ht_kvtable)->hal_count))
896 return false;
897 if (!eq(hash_table_weak_type(ht1),hash_table_weak_type(ht2)))
898 return false;
899 /* have to traverse keys */
900 { /* Look whether ht1 is contained in ht2. */
901 var uintL index = posfixnum_to_V(TheHashtable(ht1)->ht_maxcount);
902 var gcv_object_t* KVptr = TheHashedAlist(TheHashtable(ht1)->ht_kvtable)->hal_data;
903 for (; index > 0; KVptr += 3, index--)
904 if (!eq(KVptr[0],unbound)) {
905 var object value_in_ht2 = gethash(KVptr[0],ht2,false);
906 if (eq(value_in_ht2,nullobj) || !equalp(KVptr[1],value_in_ht2))
907 return false;
908 }
909 }
910 { /* Look whether ht2 is contained in ht1. */
911 var uintL index = posfixnum_to_V(TheHashtable(ht2)->ht_maxcount);
912 var gcv_object_t* KVptr = TheHashedAlist(TheHashtable(ht2)->ht_kvtable)->hal_data;
913 for (; index > 0; KVptr += 3, index--)
914 if (!eq(KVptr[0],unbound)) {
915 var object value_in_ht1 = gethash(KVptr[0],ht1,false);
916 if (eq(value_in_ht1,nullobj) || !equalp(KVptr[1],value_in_ht1))
917 return false;
918 }
919 }
920 return true;
921 }
922 /* Now EQUALP itself. */
equalp(object obj1,object obj2)923 modexp bool equalp (object obj1, object obj2)
924 {
925 start:
926 if (eq(obj1,obj2))
927 return true; /* (EQ x y) ==> (EQUALP x y) */
928 /* different cases according to the type of obj1: */
929 if (consp(obj1)) {
930 if (!consp(obj2)) return false;
931 /* compare conses recursively:
932 CAR and CDR must match:
933 (and (equalp (car obj1) (car obj2)) (equalp (cdr obj1) (cdr obj2))) */
934 check_SP();
935 if (!equalp(Car(obj1),Car(obj2))) return false;
936 /* return equalp(Cdr(obj1),Cdr(obj2)); */
937 obj1 = Cdr(obj1); obj2 = Cdr(obj2);
938 goto start;
939 } else if (symbolp(obj1)) { /* Symbol ? */
940 return false; /* yes -> should already have beend EQ to obj2 */
941 } else if (numberp(obj1)) {
942 if (!numberp(obj2)) return false;
943 /* compare numbers via = */
944 return number_equal(obj1,obj2);
945 } else {
946 #ifdef TYPECODES
947 switch (typecode(obj1))
948 #else
949 if (orecordp(obj1)) {
950 if (Record_type(obj1) < rectype_longlimit)
951 goto case_orecord;
952 else
953 goto case_lrecord;
954 } else if (charp(obj1)) {
955 goto case_char;
956 } else
957 return false;
958 switch (0)
959 #endif
960 {
961 case_bvector: /* bit-vector */
962 case_b2vector: /* 2bit-vector */
963 case_b4vector: /* 4bit-vector */
964 case_b8vector: /* 8bit-vector */
965 case_b16vector: /* 16bit-vector */
966 case_b32vector: /* 32bit-vector */
967 case_string: /* string */
968 case_vector: /* (VECTOR T) */
969 if (!vectorp(obj2)) return false;
970 /* obj1, obj2 both vectors. */
971 { /* compare lengths: */
972 var uintL len1 = vector_length(obj1);
973 if (len1 != vector_length(obj2)) return false;
974 /* compare lengths: */
975 if (len1 > 0) {
976 var uintL index1 = 0; /* start-index into obj1 data vector */
977 var uintL index2 = 0; /* start-index into obj2 data vector */
978 var object dv1 = array_displace_check(obj1,len1,&index1);
979 var object dv2 = array_displace_check(obj2,len1,&index2);
980 /* dvi is the data vector, indexi the index into the Data vector
981 for obji (i=1,2). */
982 return elt_compare(dv1,index1,dv2,index2,len1);
983 } else
984 return true;
985 }
986 case_mdarray: /* array of rank /=1 */
987 if (!mdarrayp(obj2)) return false;
988 /* obj1 and obj2 are arrays of rank /=1.
989 Their rank and their dimensions have to match, and
990 the elements are then compared like with vectors. */
991 { /* compare ranks: */
992 var uintC rank1 = Iarray_rank(obj1);
993 if (!(rank1 == Iarray_rank(obj2))) return false;
994 /* compare dimensions: */
995 if (rank1 > 0) {
996 var uintL* dimptr1 = &TheIarray(obj1)->dims[0];
997 if (Iarray_flags(obj1) & bit(arrayflags_dispoffset_bit))
998 dimptr1++;
999 var uintL* dimptr2 = &TheIarray(obj2)->dims[0];
1000 if (Iarray_flags(obj2) & bit(arrayflags_dispoffset_bit))
1001 dimptr2++;
1002 dotimespC(rank1,rank1, {
1003 if (!(*dimptr1++ == *dimptr2++)) return false;
1004 });
1005 }
1006 }
1007 { /* compare content: */
1008 var uintL len1 = TheIarray(obj1)->totalsize;
1009 /* as product of the dimensions,
1010 it has to be = TheIarray(obj2)->totalsize */
1011 if (len1 > 0) {
1012 var uintL index1 = 0; var uintL index2 = 0;
1013 var object dv1 = iarray_displace_check(obj1,len1,&index1);
1014 var object dv2 = iarray_displace_check(obj2,len1,&index2);
1015 /* dvi is the data vector, indexi the index into the data vector
1016 for obji (i=1,2). */
1017 return elt_compare(dv1,index1,dv2,index2,len1);
1018 } else
1019 return true;
1020 }
1021 #ifdef TYPECODES
1022 _case_structure
1023 _case_stream
1024 #endif
1025 case_orecord:
1026 /* record, structure, but not closure, instance.
1027 obj2 must have the same type as obj1, which is Record, and
1028 has to match in rectype and recflags and reclength with obj1.
1029 And all components have to be EQUALP. */
1030 switch (Record_type(obj1)) {
1031 case_Rectype_bvector_above;
1032 case_Rectype_b2vector_above;
1033 case_Rectype_b4vector_above;
1034 case_Rectype_b8vector_above;
1035 case_Rectype_b16vector_above;
1036 case_Rectype_b32vector_above;
1037 case_Rectype_string_above;
1038 case_Rectype_vector_above;
1039 case_Rectype_mdarray_above;
1040 case_Rectype_Closure_above;
1041 case_Rectype_Instance_above;
1042 case Rectype_Hashtable:
1043 if (!hash_table_p(obj2)) return false;
1044 return hash_table_equalp(obj1,obj2);
1045 default: ;
1046 }
1047 #ifdef TYPECODES
1048 if (typecode(obj1) != typecode(obj2)) return false;
1049 #else
1050 if (!orecordp(obj2)) return false;
1051 #endif
1052 { /* obj1 and obj2 both records. */
1053 var uintC len;
1054 if (Record_type(obj1) != Record_type(obj2)) return false;
1055 if (Record_flags(obj1) != Record_flags(obj2)) return false;
1056 if (Record_type(obj1) < rectype_limit) {
1057 if ((len=Srecord_length(obj1)) != Srecord_length(obj2)) return false;
1058 } else {
1059 if ((len=Xrecord_length(obj1)) != Xrecord_length(obj2)) return false;
1060 if (Xrecord_xlength(obj1) != Xrecord_xlength(obj2)) return false;
1061 }
1062 /* compare the elements recursively (also for PATHNAMEs): */
1063 check_SP();
1064 if (len > 0) {
1065 var gcv_object_t* ptr1 = &TheRecord(obj1)->recdata[0];
1066 var gcv_object_t* ptr2 = &TheRecord(obj2)->recdata[0];
1067 var uintC count;
1068 dotimespC(count,len, {
1069 if (!equalp(*ptr1++,*ptr2++)) return false;
1070 });
1071 }
1072 /* compare the recxlength extra-elements, too: */
1073 if (Record_type(obj1) >= rectype_limit) {
1074 var uintC xlen = Xrecord_xlength(obj1);
1075 if (xlen > 0) {
1076 var uintB* ptr1 = (uintB*)&TheRecord(obj1)->recdata[len];
1077 var uintB* ptr2 = (uintB*)&TheRecord(obj2)->recdata[len];
1078 dotimespC(xlen,xlen, { if (!(*ptr1++ == *ptr2++)) return false; } );
1079 }
1080 }
1081 }
1082 return true;
1083 case_lrecord:
1084 return false; /* should already have been EQ */
1085 case_closure: /* closure */
1086 return false; /* should already have been EQ */
1087 case_instance: /* instance */
1088 return false; /* should already have been EQ */
1089 case_char: /* character */
1090 if (!charp(obj2)) return false;
1091 /* obj1, obj2 both characters.
1092 comparison alike to CHAR-EQUAL: ignore bits and font,
1093 convert into upper case letters and then compare. */
1094 if (chareq(up_case(char_code(obj1)),up_case(char_code(obj2))))
1095 return true;
1096 else
1097 return false;
1098 #ifdef TYPECODES
1099 case_subr: /* SUBR */
1100 return false; /* should already have been EQ */
1101 case_system: /* SYSTEM, small-read-label, FRAME-pointer */
1102 return false; /* should already have been EQ */
1103 case_machine: /* machine pointer */
1104 return false; /* should already have been EQ */
1105 #endif
1106 default: NOTREACHED;
1107 }
1108 }
1109 }
1110
1111 LISPFUN(eq,SECFC(seclass_foldable,fastcmp_eq),2,0,norest,nokey,0,NIL)
1112 { /* (EQ obj1 obj2), CLTL p. 77 */
1113 VALUES_IF(eq(STACK_0,STACK_1)); skipSTACK(2);
1114 }
1115
1116 LISPFUN(eql,SECFC(seclass_foldable,fastcmp_eql),2,0,norest,nokey,0,NIL)
1117 { /* (EQL obj1 obj2), CLTL p. 78 */
1118 VALUES_IF(eql(STACK_0,STACK_1)); skipSTACK(2);
1119 }
1120
1121 LISPFUN(equal,SECFC(seclass_read,fastcmp_equal),2,0,norest,nokey,0,NIL)
1122 { /* (EQUAL obj1 obj2), CLTL p. 80 */
1123 VALUES_IF(equal(STACK_0,STACK_1)); skipSTACK(2);
1124 }
1125
1126 LISPFUN(equalp,SECFC(seclass_read,fastcmp_equalp),2,0,norest,nokey,0,NIL)
1127 { /* (EQUALP obj1 obj2), CLTL p. 81 */
1128 VALUES_IF(equalp(STACK_0,STACK_1)); skipSTACK(2);
1129 }
1130
1131 LISPFUNNF(consp,1)
1132 { /* (CONSP object), CLTL p. 74 */
1133 VALUES_IF(mconsp(STACK_0)); skipSTACK(1);
1134 }
1135
1136 LISPFUNNF(atom,1)
1137 { /* (ATOM object), CLTL p. 73 */
1138 VALUES_IF(matomp(STACK_0)); skipSTACK(1);
1139 }
1140
1141 LISPFUNNF(symbolp,1)
1142 { /* (SYMBOLP object), CLTL p. 73 */
1143 VALUES_IF(symbolp(STACK_0)); skipSTACK(1);
1144 }
1145
1146 LISPFUNNF(stringp,1)
1147 { /* (STRINGP object), CLTL p. 75 */
1148 VALUES_IF(stringp(STACK_0)); skipSTACK(1);
1149 }
1150
1151 LISPFUNNF(numberp,1)
1152 { /* (NUMBERP object), CLTL p. 74 */
1153 VALUES_IF(numberp(STACK_0)); skipSTACK(1);
1154 }
1155
1156 LISPFUNNR(compiled_function_p,1) {
1157 /* (COMPILED-FUNCTION-P object), CLTL p. 76 */
1158 var object arg = popSTACK();
1159 /* check for SUBR or compiled closure (excluding funcallable instances) or
1160 foreign function: */
1161 VALUES_IF(subrp(arg)
1162 || (cclosurep(arg) && !Closure_instancep(arg))
1163 || ffunctionp(arg));
1164 }
1165
1166 LISPFUNNR(pcompiled_function_p,1) {
1167 /* (SYS::%COMPILED-FUNCTION-P object) */
1168 var object arg = popSTACK();
1169 /* check for SUBR or compiled closure or foreign function: */
1170 VALUES_IF(subrp(arg) || cclosurep(arg) || ffunctionp(arg));
1171 }
1172
1173 LISPFUNNF(null,1)
1174 { /* (NULL object), CLTL p. 73 */
1175 VALUES_IF(nullp(STACK_0)); skipSTACK(1);
1176 }
1177
1178 LISPFUNNF(not,1)
1179 { /* (NOT object), CLTL p. 82 */
1180 VALUES_IF(nullp(STACK_0)); skipSTACK(1);
1181 }
1182
1183 LISPFUNNF(closurep,1)
1184 { /* (SYS::CLOSUREP object) */
1185 VALUES_IF(closurep(STACK_0)); skipSTACK(1);
1186 }
1187
1188 LISPFUNNF(listp,1)
1189 { /* (LISTP object), CLTL p. 74 */
1190 VALUES_IF(listp(STACK_0)); skipSTACK(1);
1191 }
1192
1193 /* (EXT:PROPER-LIST-P object) returns true if the object is a proper list,
1194 i.e. a list which is neither dotted nor circular, i.e. a list which ends
1195 in NIL. */
1196 LISPFUNNR(proper_list_p,1)
1197 {
1198 VALUES_IF(proper_list_p(STACK_0)); skipSTACK(1);
1199 }
1200
1201 LISPFUNNF(bytep,1)
1202 { /* (SYS::BYTEP object) */
1203 VALUES_IF(bytep(STACK_0)); skipSTACK(1);
1204 }
1205
1206 LISPFUNNF(integerp,1)
1207 { /* (INTEGERP object), CLTL p. 74 */
1208 VALUES_IF(integerp(STACK_0)); skipSTACK(1);
1209 }
1210
1211 LISPFUNNF(fixnump,1)
1212 { /* (SYS::FIXNUMP object) */
1213 VALUES_IF(fixnump(STACK_0)); skipSTACK(1);
1214 }
1215
1216 LISPFUNNF(rationalp,1)
1217 { /* (RATIONALP object), CLTL p. 74 */
1218 var object arg = popSTACK();
1219 if_rationalp(arg, { VALUES1(T); }, { VALUES1(NIL); } );
1220 }
1221
1222 LISPFUNNF(floatp,1)
1223 { /* (FLOATP object), CLTL p. 75 */
1224 VALUES_IF(floatp(STACK_0)); skipSTACK(1);
1225 }
1226
1227 LISPFUNNF(short_float_p,1)
1228 { /* (SYS::SHORT-FLOAT-P object) */
1229 VALUES_IF(short_float_p(STACK_0)); skipSTACK(1);
1230 }
1231
1232 LISPFUNNF(single_float_p,1)
1233 { /* (SYS::SINGLE-FLOAT-P object) */
1234 VALUES_IF(single_float_p(STACK_0)); skipSTACK(1);
1235 }
1236
1237 LISPFUNNF(double_float_p,1)
1238 { /* (SYS::DOUBLE-FLOAT-P object) */
1239 VALUES_IF(double_float_p(STACK_0)); skipSTACK(1);
1240 }
1241
1242 LISPFUNNF(long_float_p,1)
1243 { /* (SYS::LONG-FLOAT-P object) */
1244 VALUES_IF(long_float_p(STACK_0)); skipSTACK(1);
1245 }
1246
1247 LISPFUNNF(realp,1)
1248 { /* (REALP object), CLTL2 p. 101 */
1249 var object arg = popSTACK();
1250 if_realp(arg, { VALUES1(T); } , { VALUES1(NIL); } );
1251 }
1252
1253 LISPFUNNF(complexp,1)
1254 { /* (COMPLEXP object), CLTL p. 75 */
1255 VALUES_IF(complexp(STACK_0)); skipSTACK(1);
1256 }
1257
1258 /* (STREAMP object), CLTL p. 332 */
1259 /* Not seclass_foldable, because of Gray streams and CHANGE-CLASS. */
1260 LISPFUNNR(streamp,1)
1261 {
1262 VALUES_IF(streamp(STACK_0)); skipSTACK(1);
1263 }
1264
1265 LISPFUNNF(built_in_stream_p,1)
1266 { /* (SYS::BUILT-IN-STREAM-P object) */
1267 VALUES_IF(builtin_stream_p(STACK_0)); skipSTACK(1);
1268 }
1269
1270 LISPFUNNF(random_state_p,1)
1271 { /* (RANDOM-STATE-P object), CLTL p. 231 */
1272 VALUES_IF(random_state_p(STACK_0)); skipSTACK(1);
1273 }
1274
1275 LISPFUNNF(readtablep,1)
1276 { /* (READTABLEP object), CLTL p. 361 */
1277 VALUES_IF(readtablep(STACK_0)); skipSTACK(1);
1278 }
1279
1280 LISPFUNNF(hash_table_p,1)
1281 { /* (HASH-TABLE-P object), CLTL p. 284 */
1282 VALUES_IF(hash_table_p(STACK_0)); skipSTACK(1);
1283 }
1284
1285 LISPFUNNF(pathnamep,1)
1286 { /* (PATHNAMEP object), CLTL p. 416 */
1287 VALUES_IF(xpathnamep(STACK_0)); skipSTACK(1);
1288 }
1289
1290 LISPFUNNF(logical_pathname_p,1)
1291 { /* (SYS::LOGICAL-PATHNAME-P object) */
1292 VALUES_IF(logpathnamep(STACK_0)); skipSTACK(1);
1293 }
1294
1295 LISPFUNNF(characterp,1)
1296 { /* (CHARACTERP object), CLTL p. 75 */
1297 VALUES_IF(charp(STACK_0)); skipSTACK(1);
1298 }
1299
1300 LISPFUNNF(functionp,1)
1301 { /* (FUNCTIONP object), CLTL p. 76, CLtL2 p. 102-103 */
1302 var object arg = popSTACK();
1303 /* SUBR, closure, foreign function, [Symbol, Cons (LAMBDA . ...)]: */
1304 VALUES_IF(subrp(arg) || closurep(arg) || ffunctionp(arg));
1305 }
1306
1307 LISPFUNNF(packagep,1)
1308 { /* (PACKAGEP object), CLTL p. 76 */
1309 VALUES_IF(packagep(STACK_0)); skipSTACK(1);
1310 }
1311
1312 LISPFUNNF(arrayp,1)
1313 { /* (ARRAYP object), CLTL p. 76 */
1314 VALUES_IF(arrayp(STACK_0)); skipSTACK(1);
1315 }
1316
1317 LISPFUNNF(simple_array_p,1)
1318 { /* (SYSTEM::SIMPLE-ARRAY-P object) */
1319 var object arg = popSTACK();
1320 VALUES_IF(simplep(arg)
1321 || (arrayp(arg) /* other arrays, only if all flag bits = 0 */
1322 && ((Iarray_flags(arg)
1323 & (bit(arrayflags_adjustable_bit)
1324 | bit(arrayflags_fillp_bit)
1325 | bit(arrayflags_displaced_bit)
1326 | bit(arrayflags_dispoffset_bit) ))
1327 == 0)));
1328 }
1329
1330 LISPFUNNF(bit_vector_p,1)
1331 { /* (BIT-VECTOR-P object), CLTL p. 75 */
1332 VALUES_IF(bit_vector_p(Atype_Bit,STACK_0)); skipSTACK(1);
1333 }
1334
1335 LISPFUNNF(vectorp,1)
1336 { /* (VECTORP object), CLTL p. 75 */
1337 VALUES_IF(vectorp(STACK_0)); skipSTACK(1);
1338 }
1339
1340 LISPFUNNF(simple_vector_p,1)
1341 { /* (SIMPLE-VECTOR-P object), CLTL p. 75 */
1342 VALUES_IF(simple_vector_p(STACK_0)); skipSTACK(1);
1343 }
1344
1345 LISPFUNNF(simple_string_p,1)
1346 { /* (SIMPLE-STRING-P object), CLTL p. 75 */
1347 var object arg = popSTACK();
1348 VALUES_IF(simple_string_p(arg)
1349 || (stringp(arg)
1350 && ((Iarray_flags(arg)
1351 & (bit(arrayflags_adjustable_bit)
1352 | bit(arrayflags_fillp_bit)
1353 | bit(arrayflags_displaced_bit)
1354 | bit(arrayflags_dispoffset_bit) ))
1355 == 0)));
1356 }
1357
1358 LISPFUNNF(simple_bit_vector_p,1)
1359 { /* (SIMPLE-BIT-VECTOR-P object), CLTL p. 76 */
1360 VALUES_IF(simple_bit_vector_p(Atype_Bit,STACK_0)); skipSTACK(1);
1361 }
1362
1363 LISPFUNNR(type_of,1)
1364 { /* (TYPE-OF object), CLTL p. 52 */
1365 var object arg = popSTACK();
1366 #ifdef TYPECODES
1367 switch (typecode(arg))
1368 #else
1369 if (orecordp(arg)) {
1370 goto case_orecord;
1371 } else if (consp(arg)) {
1372 goto case_cons;
1373 } else if (immsubrp(arg)) {
1374 goto case_subr;
1375 } else if (charp(arg)) {
1376 goto case_char;
1377 } else if (fixnump(arg)) {
1378 goto case_fixnum;
1379 } else if (short_float_p(arg)) {
1380 goto case_sfloat;
1381 } else if (machinep(arg)) {
1382 goto case_machine;
1383 } else if (small_read_label_p(arg)) {
1384 goto case_small_read_label;
1385 } else if (systemp(arg)) {
1386 goto case_system;
1387 } else
1388 goto unknown;
1389 switch (0)
1390 #endif
1391 {
1392 case_cons: /* Cons -> CONS */
1393 { value1 = S(cons); break; }
1394 case_symbol: { /* Symbol -> SYMBOL or NULL or BOOLEAN or KEYWORD */
1395 value1 = (nullp(arg) ? S(null) :
1396 eq(arg,T) ? S(boolean) :
1397 eq(Symbol_package(arg),O(keyword_package)) ? S(keyword) :
1398 S(symbol));
1399 } break;
1400 case_machine: /* machine pointer -> ADDRESS */
1401 /* (If not TYPECODES, ADDRESS and FRAME-POINTER
1402 are not distinguishable.) */
1403 { value1 = S(address); break; }
1404 case_sbvector: /* Simple-Bit-Vector -> (SIMPLE-BIT-VECTOR dim0) */
1405 { pushSTACK(S(simple_bit_vector)); goto vectors; }
1406 case_obvector: /* Bit-Vector -> (BIT-VECTOR dim0) */
1407 { pushSTACK(S(bit_vector)); goto vectors; }
1408 case_sstring: /* Simple-String -> (SIMPLE-[BASE-]STRING dim0) */
1409 #if (base_char_code_limit == char_code_limit)
1410 { pushSTACK(S(simple_base_string)); goto vectors; }
1411 #else
1412 { pushSTACK(S(simple_string)); goto vectors; }
1413 #endif
1414 case_svector: /* Simple-Vector -> (SIMPLE-VECTOR dim0) */
1415 { pushSTACK(S(simple_vector)); goto vectors; }
1416 case_ostring: { /* other string */
1417 /* -> ([BASE-]STRING dim0) or (VECTOR NIL dim0) or (SIMPLE-ARRAY NIL (dim0)) */
1418 var bool simple =
1419 ((Iarray_flags(arg)
1420 & (bit(arrayflags_adjustable_bit)
1421 | bit(arrayflags_fillp_bit)
1422 | bit(arrayflags_displaced_bit)
1423 | bit(arrayflags_dispoffset_bit) ))
1424 == 0);
1425 switch (Iarray_flags(arg) & arrayflags_atype_mask) {
1426 case Atype_NIL: {
1427 pushSTACK(array_dimensions(arg)); /* list of dimensions */
1428 if (simple) {
1429 {
1430 var object new_cons = allocate_cons();
1431 Cdr(new_cons) = NIL; Car(new_cons) = popSTACK();
1432 pushSTACK(new_cons);
1433 }
1434 {
1435 var object new_cons = allocate_cons();
1436 Cdr(new_cons) = popSTACK(); Car(new_cons) = NIL;
1437 pushSTACK(new_cons);
1438 }
1439 {
1440 var object new_cons = allocate_cons();
1441 Cdr(new_cons) = popSTACK(); Car(new_cons) = S(simple_array);
1442 value1 = new_cons;
1443 }
1444 } else {
1445 {
1446 var object new_cons = allocate_cons();
1447 Cdr(new_cons) = popSTACK(); Car(new_cons) = NIL;
1448 pushSTACK(new_cons);
1449 }
1450 {
1451 var object new_cons = allocate_cons();
1452 Cdr(new_cons) = popSTACK(); Car(new_cons) = S(vector);
1453 value1 = new_cons;
1454 }
1455 }
1456 } break;
1457 case Atype_Char: {
1458 ASSERT(!simple);
1459 #if (base_char_code_limit == char_code_limit)
1460 pushSTACK(S(base_string)); goto vectors;
1461 #else
1462 pushSTACK(S(string)); goto vectors;
1463 #endif
1464 }
1465 default: NOTREACHED;
1466 }
1467 } break;
1468 vectors: { /* type of the vector in STACK_0 */
1469 pushSTACK(array_dimensions(arg)); /* list of dimensions */
1470 var object new_cons = allocate_cons();
1471 Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK();
1472 value1 = new_cons;
1473 } break;
1474 case_ovector: { /* other general-vector */
1475 /* -> (SIMPLE-ARRAY T (dim0)) or (VECTOR T dim0) */
1476 var bool simple =
1477 ((Iarray_flags(arg)
1478 & (bit(arrayflags_adjustable_bit)
1479 | bit(arrayflags_fillp_bit)
1480 | bit(arrayflags_displaced_bit)
1481 | bit(arrayflags_dispoffset_bit) ))
1482 == 0);
1483 pushSTACK(array_dimensions(arg)); /* list of dimensions */
1484 if (simple) {
1485 {
1486 var object new_cons = allocate_cons();
1487 Cdr(new_cons) = NIL; Car(new_cons) = popSTACK();
1488 pushSTACK(new_cons);
1489 }
1490 {
1491 var object new_cons = allocate_cons();
1492 Cdr(new_cons) = popSTACK(); Car(new_cons) = T;
1493 pushSTACK(new_cons);
1494 }
1495 {
1496 var object new_cons = allocate_cons();
1497 Cdr(new_cons) = popSTACK(); Car(new_cons) = S(simple_array);
1498 value1 = new_cons;
1499 }
1500 } else {
1501 {
1502 var object new_cons = allocate_cons();
1503 Cdr(new_cons) = popSTACK(); Car(new_cons) = T;
1504 pushSTACK(new_cons);
1505 }
1506 {
1507 var object new_cons = allocate_cons();
1508 Cdr(new_cons) = popSTACK(); Car(new_cons) = S(vector);
1509 value1 = new_cons;
1510 }
1511 }
1512 } break;
1513 case_sb2vector: /* simple Byte-Vector -> (SIMPLE-ARRAY (UNSIGNED-BYTE n) (dim0)) */
1514 case_sb4vector:
1515 case_sb8vector:
1516 case_sb16vector:
1517 case_sb32vector:
1518 { pushSTACK(S(simple_array)); goto arrays; }
1519 case_ob2vector: /* other Byte-Vector -> ([SIMPLE-]ARRAY (UNSIGNED-BYTE n) (dim0)) */
1520 case_ob4vector:
1521 case_ob8vector:
1522 case_ob16vector:
1523 case_ob32vector:
1524 case_mdarray: { /* other Array -> ([SIMPLE-]ARRAY eltype dims) */
1525 pushSTACK( ((Iarray_flags(arg)
1526 & ( bit(arrayflags_adjustable_bit)
1527 | bit(arrayflags_fillp_bit)
1528 | bit(arrayflags_displaced_bit)
1529 | bit(arrayflags_dispoffset_bit)))
1530 == 0)
1531 ? S(simple_array)
1532 : S(array));
1533 } goto arrays;
1534 arrays: {
1535 pushSTACK(arg);
1536 pushSTACK(array_dimensions(arg)); /* list of dimensions */
1537 STACK_1 = array_element_type(STACK_1); /* eltype */
1538 value1 = listof(3);
1539 } break;
1540 case_closure: { /* Closure */
1541 /* -> COMPILED-FUNCTION or FUNCTION or a subclass of
1542 FUNCALLABLE-STANDARD-OBJECT */
1543 if (Closure_instancep(arg))
1544 goto instances;
1545 if (simple_bit_vector_p(Atype_8Bit,TheClosure(arg)->clos_codevec)) {
1546 /* compiled Closure */
1547 value1 = S(compiled_function);
1548 } else {
1549 /* interpreted Closure */
1550 value1 = S(function);
1551 }
1552 } break;
1553 case_structure: { /* Structure -> type of the Structure */
1554 var object type = TheStructure(arg)->structure_types;
1555 /* (name_1 ... name_i-1 name_i). type is name_1. */
1556 value1 = Car(type);
1557 } break;
1558 case_stream: /* Stream -> STREAM or according to Stream-type */
1559 switch (TheStream(arg)->strmtype) {
1560 case strmtype_file: { value1 = S(file_stream); break; }
1561 case strmtype_synonym: { value1 = S(synonym_stream); break; }
1562 case strmtype_broad: { value1 = S(broadcast_stream); break; }
1563 case strmtype_concat: { value1 = S(concatenated_stream); break; }
1564 case strmtype_twoway: { value1 = S(two_way_stream); break; }
1565 case strmtype_echo: { value1 = S(echo_stream); break; }
1566 case strmtype_str_in:
1567 case strmtype_str_out:
1568 case strmtype_str_push: { value1 = S(string_stream); break; }
1569 default: { value1 = S(stream); break; }
1570 }
1571 break;
1572 case_orecord: case_lrecord: /* OtherRecord -> PACKAGE, ... */
1573 switch (Record_type(arg)) {
1574 case_Rectype_Symbol_above;
1575 case_Rectype_Sbvector_above;
1576 case_Rectype_Sb2vector_above;
1577 case_Rectype_Sb4vector_above;
1578 case_Rectype_Sb8vector_above;
1579 case_Rectype_Sb16vector_above;
1580 case_Rectype_Sb32vector_above;
1581 case_Rectype_Sstring_above;
1582 case_Rectype_Svector_above;
1583 case_Rectype_ostring_above;
1584 case_Rectype_ovector_above;
1585 case_Rectype_obvector_above;
1586 case_Rectype_ob2vector_above;
1587 case_Rectype_ob4vector_above;
1588 case_Rectype_ob8vector_above;
1589 case_Rectype_ob16vector_above;
1590 case_Rectype_ob32vector_above;
1591 case_Rectype_mdarray_above;
1592 case_Rectype_Closure_above;
1593 case_Rectype_Structure_above;
1594 case_Rectype_Stream_above;
1595 case_Rectype_Instance_above;
1596 case_Rectype_Bignum_above;
1597 case_Rectype_Ratio_above;
1598 case_Rectype_Ffloat_above;
1599 case_Rectype_Dfloat_above;
1600 case_Rectype_Lfloat_above;
1601 case_Rectype_Complex_above;
1602 case_Rectype_Subr_above;
1603 case Rectype_Hashtable: /* Hash-Table */
1604 { value1 = S(hash_table); break; }
1605 case Rectype_Package: /* Package */
1606 { value1 = S(package); break; }
1607 case Rectype_Readtable: /* Readtable */
1608 { value1 = S(readtable); break; }
1609 case Rectype_Pathname: /* Pathname */
1610 { value1 = S(pathname); break; }
1611 case Rectype_Logpathname: /* Logical Pathname */
1612 { value1 = S(logical_pathname); break; }
1613 case Rectype_Random_State: /* Random-State */
1614 { value1 = S(random_state); break; }
1615 case Rectype_Byte: /* Byte */
1616 { value1 = S(byte); break; }
1617 case Rectype_Fsubr: /* Fsubr -> SPECIAL-OPERATOR */
1618 { value1 = S(special_operator); break; }
1619 case Rectype_Loadtimeeval: /* Load-Time-Eval */
1620 { value1 = S(load_time_eval); break; }
1621 case Rectype_Symbolmacro: /* Symbol-Macro */
1622 { value1 = S(symbol_macro); break; }
1623 case Rectype_GlobalSymbolmacro: /* Global-Symbol-Macro */
1624 { value1 = S(global_symbol_macro); break; }
1625 case Rectype_Macro: /* Macro */
1626 { value1 = S(macro); break; }
1627 case Rectype_FunctionMacro: /* FunctionMacro */
1628 { value1 = S(function_macro); break; }
1629 case Rectype_BigReadLabel: /* BigReadLabel -> READ-LABEL */
1630 { value1 = S(read_label); break; }
1631 case Rectype_Encoding: /* Encoding */
1632 { value1 = S(encoding); break; }
1633 #ifdef FOREIGN
1634 case Rectype_Fpointer: /* Foreign-Pointer-wrapping */
1635 { value1 = S(foreign_pointer); break; }
1636 #endif
1637 #ifdef DYNAMIC_FFI
1638 case Rectype_Faddress: /* Foreign-Address */
1639 { value1 = S(foreign_address); break; }
1640 case Rectype_Fvariable: /* Foreign-Variable */
1641 { value1 = S(foreign_variable); break; }
1642 case Rectype_Ffunction: /* Foreign-Function */
1643 { value1 = S(foreign_function); break; }
1644 #endif
1645 case Rectype_Weakpointer: /* Weak-Pointer */
1646 { value1 = S(weak_pointer); break; }
1647 case Rectype_MutableWeakList: /* mutable Weak-List */
1648 { value1 = S(weak_list); break; }
1649 case Rectype_MutableWeakAlist: /* mutable Weak-Alist */
1650 { value1 = S(weak_alist); break; }
1651 case Rectype_Weakmapping: /* Weak-Mapping */
1652 { value1 = S(weak_mapping); break; }
1653 case Rectype_Finalizer: /* Finalizer (should not occur) */
1654 { value1 = S(finalizer); break; }
1655 #ifdef SOCKET_STREAMS
1656 case Rectype_Socket_Server: /* Socket-Server */
1657 { value1 = S(socket_server); break; }
1658 #endif
1659 #ifdef MULTITHREAD
1660 case Rectype_Thread: { value1 = S(thread); break; }
1661 case Rectype_Mutex: { value1 = S(mutex); break; }
1662 case Rectype_Exemption: { value1 = S(exemption); break; }
1663 #endif
1664 #ifdef YET_ANOTHER_RECORD
1665 case Rectype_Yetanother: /* Yetanother -> YET-ANOTHER */
1666 { value1 = S(yet_another); break; }
1667 #endif
1668 case Rectype_WeakList: /* Weak-List */
1669 { value1 = S(internal_weak_list); break; }
1670 case Rectype_WeakAnd: /* Weak-And-Relation */
1671 { value1 = S(weak_and_relation); break; }
1672 case Rectype_WeakOr: /* Weak-Or-Relation */
1673 { value1 = S(weak_or_relation); break; }
1674 case Rectype_WeakAndMapping: /* Weak-And-Mapping */
1675 { value1 = S(weak_and_mapping); break; }
1676 case Rectype_WeakOrMapping: /* Weak-Or-Mapping */
1677 { value1 = S(weak_or_mapping); break; }
1678 case Rectype_WeakAlist_Key:
1679 case Rectype_WeakAlist_Value:
1680 case Rectype_WeakAlist_Either:
1681 case Rectype_WeakAlist_Both: /* Weak-Alist */
1682 { value1 = S(internal_weak_alist); break; }
1683 case Rectype_WeakHashedAlist_Key:
1684 case Rectype_WeakHashedAlist_Value:
1685 case Rectype_WeakHashedAlist_Either:
1686 case Rectype_WeakHashedAlist_Both: /* Weak-Hashed-Alist */
1687 { value1 = S(internal_weak_hashed_alist); break; }
1688 default: goto unknown;
1689 }
1690 break;
1691 instances:
1692 case_instance: { /* Instance -> name of the class or the class itself */
1693 /* (CLtL2 p. 781 top) */
1694 var object arg_forwarded = arg;
1695 instance_un_realloc(arg_forwarded);
1696 /*instance_update(arg,arg_forwarded); - not needed since we don't access a slot */
1697 var object cv = TheInstance(arg_forwarded)->inst_class_version;
1698 var object clas = TheClassVersion(cv)->cv_newest_class;
1699 var object name = TheClass(clas)->classname;
1700 value1 = (eq(get(name,S(closclass)),clas)
1701 /* (GET name 'CLOS::CLOSCLASS) = class ? */
1702 ? name : clas);
1703 }
1704 break;
1705 case_char: /* Character -> STANDARD-CHAR or BASE-CHAR or CHARACTER */
1706 #if (base_char_code_limit < char_code_limit)
1707 if (as_cint(char_code(arg)) >= base_char_code_limit) {
1708 value1 = S(character); break;
1709 }
1710 #endif
1711 if (standard_cint_p(as_cint(char_code(arg))))
1712 value1 = S(standard_char);
1713 else
1714 value1 = S(base_char);
1715 break;
1716 case_subr: /* SUBR -> COMPILED-FUNCTION */
1717 { value1 = S(compiled_function); break; }
1718 #ifdef TYPECODES
1719 case_system: /* -> FRAME-POINTER, READ-LABEL, SYSTEM-INTERNAL */
1720 if (!wbit_test(as_oint(arg),0+oint_addr_shift))
1721 value1 = S(frame_pointer);
1722 else
1723 if (!wbit_test(as_oint(arg),oint_data_len-1+oint_addr_shift))
1724 value1 = S(read_label);
1725 else
1726 value1 = S(system_internal);
1727 break;
1728 #else
1729 case_small_read_label: /* -> READ-LABEL */
1730 { value1 = S(read_label); break; }
1731 case_system: /* -> SYSTEM-INTERNAL */
1732 { value1 = S(system_internal); break; }
1733 #endif
1734 /* due to the rule 1 in
1735 <http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/HyperSpec/Body/fun_type-of.html>,
1736 we must have (TYPEP X Y) ==> (SUBTYPEP (TYPE-OF X) Y)
1737 for all "built-in types" Y as listed in table 4-2 in
1738 <http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/HyperSpec/Body/sec_4-2-3.html>
1739 if X is a FIXNUM or a BIGNUM and Y is UNSIGNED-BYTE,
1740 this means that TYPE-OF must distinguish between positive
1741 and negative integers: */
1742 case_fixnum: { /* Fixnum -> BIT or FIXNUM+ or FIXNUM- */
1743 value1 = (eq(arg,Fixnum_0) || eq(arg,Fixnum_1) ? (object)S(bit)
1744 : positivep(arg) ? (object)O(type_posfixnum)
1745 : (object)O(type_negfixnum));
1746 } break;
1747 case_bignum: { /* Bignum -> BIGNUM+ or BIGNUM- */
1748 value1 = positivep(arg) ? O(type_posbignum) : O(type_negbignum);
1749 } break;
1750 case_ratio: /* Ratio -> RATIO */
1751 { value1 = S(ratio); break; }
1752 case_sfloat: /* Short-Float -> SHORT-FLOAT */
1753 { value1 = S(short_float); break; }
1754 case_ffloat: /* Single-Float -> SINGLE-FLOAT */
1755 { value1 = S(single_float); break; }
1756 case_dfloat: /* Double-Float -> DOUBLE-FLOAT */
1757 { value1 = S(double_float); break; }
1758 case_lfloat: /* Long-Float -> LONG-FLOAT */
1759 { value1 = S(long_float); break; }
1760 case_complex: /* Complex -> COMPLEX */
1761 { value1 = S(complex); break; }
1762 default:
1763 unknown: /* unknown type */
1764 pushSTACK(S(type_of));
1765 error(serious_condition,GETTEXT("~S: unidentifiable type!!!"));
1766 }
1767 mv_count=1;
1768 }
1769
1770 LISPFUNN(defclos,6)
1771 { /* (CLOS::%DEFCLOS <standard-class>-version <structure-class>-version
1772 <built-in-class>-version <defined-class> <potential-class>
1773 built-in-classes)
1774 sets the data needed for CLOS::CLASS-P and CLOS:CLASS-OF. */
1775 /* for CLOS::CLASS-P : */
1776 O(class_version_standard_class) = STACK_5;
1777 O(class_version_structure_class) = STACK_4;
1778 O(class_version_built_in_class) = STACK_3;
1779 O(class_defined_class) = STACK_2;
1780 O(class_potential_class) = STACK_1;
1781 /* for CLOS:CLASS-OF : */
1782 {
1783 var gcv_object_t* ptr1 = &TheSvector(STACK_0)->data[0];
1784 var gcv_object_t* ptr2 = &O(class_array);
1785 var uintC count;
1786 dotimesC(count,Svector_length(STACK_0), { /* = &O(class_vector)-&O(class_array)+1 */
1787 *ptr2++ = *ptr1++;
1788 });
1789 }
1790 value1 = NIL; mv_count=0; skipSTACK(6);
1791 }
1792
1793 LISPFUNNR(potential_class_p,1)
1794 { /* (CLOS::POTENTIAL-CLASS-P object) tests, if an object is a class or
1795 a forward-referenced class. */
1796 var object obj = popSTACK();
1797 if_potential_class_p(obj, { value1 = T; }, { value1 = NIL; }); mv_count=1;
1798 }
1799
1800 LISPFUNNR(defined_class_p,1)
1801 { /* (CLOS::DEFINED-CLASS-P object) tests, if an object is a class,
1802 excluding forward-referenced classes. */
1803 var object obj = popSTACK();
1804 if_defined_class_p(obj, { value1 = T; }, { value1 = NIL; }); mv_count=1;
1805 }
1806
1807 /* (CLOS:CLASS-OF object), CLTL2 p. 822,783
1808 Doesn't trigger GC. */
1809 LISPFUNNR(class_of,1)
1810 {
1811 var object arg = popSTACK();
1812 #ifdef TYPECODES
1813 switch (typecode(arg))
1814 #else
1815 if (orecordp(arg)) {
1816 goto case_orecord;
1817 } else if (consp(arg)) {
1818 goto case_cons;
1819 } else if (immsubrp(arg)) {
1820 goto case_subr;
1821 } else if (charp(arg)) {
1822 goto case_char;
1823 } else if (fixnump(arg)) {
1824 goto case_integer;
1825 } else if (short_float_p(arg)) {
1826 goto case_float;
1827 } else if (machinep(arg)) {
1828 goto case_machine;
1829 } else if (small_read_label_p(arg)) {
1830 goto case_system;
1831 } else if (systemp(arg)) {
1832 goto case_system;
1833 } else { goto unknown; }
1834 switch (0)
1835 #endif
1836 {
1837 instances:
1838 case_instance: { /* instance -> its class */
1839 var object arg_forwarded = arg;
1840 instance_un_realloc(arg_forwarded);
1841 /*instance_update(arg,arg_forwarded); - not needed since we don't access a slot */
1842 var object cv = TheInstance(arg_forwarded)->inst_class_version;
1843 value1 = TheClassVersion(cv)->cv_newest_class;
1844 break;
1845 }
1846 case_structure: { /* Structure -> type of the structure or <t> */
1847 var object type = TheStructure(arg)->structure_types;
1848 /* (name_1 ... name_i-1 name_i). type is name_1. */
1849 while (consp(type)) {
1850 var object name = Car(type);
1851 var object clas = get(name,S(closclass)); /* (GET name 'CLOS::CLOSCLASS) */
1852 if_defined_class_p(clas, { value1 = clas; goto done; }, ; );
1853 type = Cdr(type);
1854 }
1855 value1 = O(class_t); break;
1856 }
1857 case_cons: /* Cons -> <cons> */
1858 { value1 = O(class_cons); break; }
1859 case_symbol: /* Symbol -> <symbol> or <null> */
1860 { value1 = (nullp(arg) ? O(class_null) : O(class_symbol)); break; }
1861 case_sstring: case_ostring: /* String -> <string> */
1862 { value1 = O(class_string); break; }
1863 case_sbvector: case_obvector: /* Bit-Vector -> <bit-vector> */
1864 { value1 = O(class_bit_vector); break; }
1865 case_sb2vector: case_ob2vector: /* Byte-Vector -> <vector> */
1866 case_sb4vector: case_ob4vector:
1867 case_sb8vector: case_ob8vector:
1868 case_sb16vector: case_ob16vector:
1869 case_sb32vector: case_ob32vector:
1870 case_svector: case_ovector: /* General-Vector -> <vector> */
1871 { value1 = O(class_vector); break; }
1872 case_mdarray: /* other Array -> <array> */
1873 { value1 = O(class_array); break; }
1874 case_closure: /* Closure -> <function> or a subclass of
1875 <funcallable-standard-object> */
1876 if (Closure_instancep(arg))
1877 goto instances;
1878 case_subr: /* SUBR -> <function> */
1879 { value1 = O(class_function); break; }
1880 case_stream: /* Stream -> <stream> or according to Stream-type */
1881 switch (TheStream(arg)->strmtype) {
1882 case strmtype_file: { value1 = O(class_file_stream); break; }
1883 case strmtype_synonym: { value1 = O(class_synonym_stream); break; }
1884 case strmtype_broad: { value1 = O(class_broadcast_stream); break; }
1885 case strmtype_concat: { value1 = O(class_concatenated_stream); break; }
1886 case strmtype_twoway: { value1 = O(class_two_way_stream); break; }
1887 case strmtype_echo: { value1 = O(class_echo_stream); break; }
1888 case strmtype_str_in:
1889 case strmtype_str_out:
1890 case strmtype_str_push: { value1 = O(class_string_stream); break; }
1891 default: { value1 = O(class_stream); break; }
1892 }
1893 break;
1894 case_orecord: case_lrecord: /* OtherRecord -> <package>, ... */
1895 switch (Record_type(arg)) {
1896 case_Rectype_Instance_above;
1897 case_Rectype_Structure_above;
1898 case_Rectype_Symbol_above;
1899 case_Rectype_Sstring_above;
1900 case_Rectype_ostring_above;
1901 case_Rectype_Sbvector_above;
1902 case_Rectype_obvector_above;
1903 case_Rectype_Sb2vector_above;
1904 case_Rectype_ob2vector_above;
1905 case_Rectype_Sb4vector_above;
1906 case_Rectype_ob4vector_above;
1907 case_Rectype_Sb8vector_above;
1908 case_Rectype_ob8vector_above;
1909 case_Rectype_Sb16vector_above;
1910 case_Rectype_ob16vector_above;
1911 case_Rectype_Sb32vector_above;
1912 case_Rectype_ob32vector_above;
1913 case_Rectype_Svector_above;
1914 case_Rectype_ovector_above;
1915 case_Rectype_mdarray_above;
1916 case_Rectype_Closure_above;
1917 case_Rectype_Stream_above;
1918 case_Rectype_integer_above;
1919 case_Rectype_Ratio_above;
1920 case_Rectype_float_above;
1921 case_Rectype_Complex_above;
1922 case_Rectype_Subr_above;
1923 case Rectype_Hashtable: /* Hash-Table */
1924 { value1 = O(class_hash_table); break; }
1925 case Rectype_Package: /* Package */
1926 { value1 = O(class_package); break; }
1927 case Rectype_Readtable: /* Readtable */
1928 { value1 = O(class_readtable); break; }
1929 case Rectype_Pathname: /* Pathname */
1930 { value1 = O(class_pathname); break; }
1931 case Rectype_Logpathname: /* Logical Pathname */
1932 { value1 = O(class_logical_pathname); break; }
1933 case Rectype_Random_State: /* Random-State */
1934 { value1 = O(class_random_state); break; }
1935 case Rectype_Byte: /* Byte -> <t> */
1936 case Rectype_Fsubr: /* Fsubr -> <t> */
1937 case Rectype_Loadtimeeval: /* Load-Time-Eval -> <t> */
1938 case Rectype_Symbolmacro: /* Symbol-Macro -> <t> */
1939 case Rectype_GlobalSymbolmacro: /* Global-Symbol-Macro -> <t> */
1940 case Rectype_Macro: /* Macro -> <t> */
1941 case Rectype_FunctionMacro: /* FunctionMacro -> <t> */
1942 case Rectype_BigReadLabel: /* BigReadLabel -> <t> */
1943 case Rectype_Encoding: /* Encoding -> <t> */
1944 #ifdef FOREIGN
1945 case Rectype_Fpointer: /* Foreign-Pointer-Wrapping -> <t> */
1946 #endif
1947 #ifdef DYNAMIC_FFI
1948 case Rectype_Faddress: /* Foreign-Address -> <t> */
1949 case Rectype_Fvariable: /* Foreign-Variable -> <t> */
1950 #endif
1951 case Rectype_Weakpointer: /* Weak-Pointer -> <t> */
1952 case Rectype_MutableWeakList: /* mutable Weak-List -> <t> */
1953 case Rectype_MutableWeakAlist: /* mutable Weak-Alist -> <t> */
1954 case Rectype_Weakmapping: /* Weak-Mapping -> <t> */
1955 case Rectype_Finalizer: /* Finalizer -> <t> */
1956 #ifdef SOCKET_STREAMS
1957 case Rectype_Socket_Server: /* Socket-Server -> <t> */
1958 #endif
1959 #ifdef MULTITHREAD
1960 case Rectype_Thread: /* Thread -> <t> */
1961 case Rectype_Mutex: /* Mutex -> <t> */
1962 case Rectype_Exemption: /* Exemption -> <t> */
1963 #endif
1964 #ifdef YET_ANOTHER_RECORD
1965 case Rectype_Yetanother: /* Yetanother -> <t> */
1966 #endif
1967 case Rectype_WeakList: /* Weak-List -> <t> */
1968 case Rectype_WeakAnd: /* Weak-And-Relation -> <t> */
1969 case Rectype_WeakOr: /* Weak-Or-Relation -> <t> */
1970 case Rectype_WeakAndMapping: /* Weak-And-Mapping -> <t> */
1971 case Rectype_WeakOrMapping: /* Weak-Or-Mapping -> <t> */
1972 case Rectype_WeakAlist_Key: /* Weak-Alist -> <t> */
1973 case Rectype_WeakAlist_Value: /* Weak-Alist -> <t> */
1974 case Rectype_WeakAlist_Either: /* Weak-Alist -> <t> */
1975 case Rectype_WeakAlist_Both: /* Weak-Alist -> <t> */
1976 case Rectype_WeakHashedAlist_Key: /* Weak-Hashed-Alist -> <t> */
1977 case Rectype_WeakHashedAlist_Value: /* Weak-Hashed-Alist -> <t> */
1978 case Rectype_WeakHashedAlist_Either: /* Weak-Hashed-Alist -> <t> */
1979 case Rectype_WeakHashedAlist_Both: /* Weak-Hashed-Alist -> <t> */
1980 { value1 = O(class_t); break; }
1981 #ifdef DYNAMIC_FFI
1982 case Rectype_Ffunction: /* Foreign-Function -> <function> */
1983 { value1 = O(class_function); break; }
1984 #endif
1985 default: goto unknown;
1986 }
1987 break;
1988 case_char: /* Character -> <character> */
1989 { value1 = O(class_character); break; }
1990 case_machine: /* machine pointer -> <t> */
1991 case_system: /* -> <t> */
1992 { value1 = O(class_t); break; }
1993 case_integer: /* Integer -> <integer> */
1994 { value1 = O(class_integer); break; }
1995 case_ratio: /* Ratio -> <ratio> */
1996 { value1 = O(class_ratio); break; }
1997 case_float: /* Float -> <float> */
1998 { value1 = O(class_float); break; }
1999 case_complex: /* Complex -> <complex> */
2000 { value1 = O(class_complex); break; }
2001 default:
2002 unknown: /* unknown type */
2003 pushSTACK(S(class_of));
2004 error(serious_condition,GETTEXT("~S: unidentifiable type!!!"));
2005 }
2006 if_defined_class_p(value1, ; , {
2007 pushSTACK(value1);
2008 pushSTACK(S(class_of));
2009 error(error_condition,
2010 GETTEXT("~S: type ~S does not correspond to a class"));
2011 });
2012 done:
2013 mv_count=1;
2014 }
2015
2016 LISPFUN(find_class,seclass_default,1,2,norest,nokey,0,NIL)
2017 { /* (CLOS:FIND-CLASS symbol [errorp [environment]]), CLTL2 p. 843
2018 (defun find-class (symbol &optional (errorp t) environment)
2019 (declare (ignore environment)) ; what is the meaning of that environment?
2020 (unless (symbolp symbol)
2021 (error-of-type 'type-error
2022 (ENGLISH "~S: argument ~S is not a symbol")
2023 'find-class symbol))
2024 (let ((class (get symbol 'CLOS::CLASS)))
2025 (if (not (defined-class-p class))
2026 (if errorp
2027 (error-of-type 'error
2028 (ENGLISH "~S: ~S does not name a class")
2029 'find-class symbol)
2030 nil)
2031 class))) */
2032 STACK_2 = check_symbol(STACK_2);
2033 var object clas = get(STACK_2,S(closclass)); /* (GET symbol 'CLOS::CLOSCLASS) */
2034 if_defined_class_p(clas, { value1 = clas; } , {
2035 if (!nullp(STACK_1)) {
2036 pushSTACK(STACK_2);
2037 pushSTACK(S(find_class));
2038 error(error_condition,GETTEXT("~S: ~S does not name a class"));
2039 }
2040 value1 = NIL;
2041 });
2042 mv_count=1;
2043 skipSTACK(3);
2044 }
2045
2046 /* typep_class(obj,clas)
2047 > obj: an object
2048 > clas: a class object
2049 < true if the object is an instance of the class, false otherwise
2050 clobbers value1, mv_count */
typep_class(object obj,object clas)2051 modexp bool typep_class (object obj, object clas) {
2052 pushSTACK(obj); C_class_of();
2053 var object objclass = value1;
2054 /* Look whether clas is a superclass of objclass.
2055 Equivalent to (CLOS::SUBCLASSP objclass clas), just a bit faster. */
2056 if (srecord_length(TheClass(objclass)) > built_in_class_length) {
2057 /* Make a distinction between <semi-standard-class> and <structure-class>:
2058 Is (class-current-version class) a vector, or is (class-names class)
2059 a cons? */
2060 if (matomp(TheClass(objclass)->current_version)) {
2061 /* <semi-standard-class>. */
2062 if (nullp(TheClass(objclass)->precedence_list)) /* not yet finalized? */
2063 NOTREACHED; /* shouldn't happen because obj is already an instance */
2064 var object superclasses_table = TheClass(objclass)->all_superclasses;
2065 if (TheHashtable(superclasses_table)->ht_size > 7)
2066 return !eq(gethash(clas,superclasses_table,false),nullobj);
2067 /* Few superclasses -> not worth a hash table access. */
2068 } else {
2069 /* <structure-class>. */
2070 /* There are few superclasses. Not worth a hash table access. */
2071 }
2072 }
2073 #if 0
2074 return !nullp(memq(clas,TheClass(objclass)->precedence_list));
2075 #else /* inlined, for performance */
2076 var object l;
2077 for (l = TheClass(objclass)->precedence_list; consp(l); l = Cdr(l))
2078 if (eq(Car(l),clas))
2079 return true;
2080 return false;
2081 #endif
2082 }
2083
2084 /* (CLOS::TYPEP-CLASS object class)
2085 == (TYPEP object class) == (CLOS::SUBCLASSP (CLASS-OF object) class) */
2086 LISPFUNN(typep_class,2)
2087 {
2088 var object clas = popSTACK();
2089 if_defined_class_p(clas, ; , error_class(clas); );
2090 VALUES_IF(typep_class(popSTACK(),clas));
2091 }
2092
2093 /* typep_classname(obj,classname)
2094 > obj: an object
2095 > classname: a symbol expected to name a class with "proper name" classname
2096 < true if the object is an instance of the class, false otherwise
2097 clobbers value1, mv_count */
typep_classname(object obj,object classname)2098 modexp bool typep_classname (object obj, object classname) {
2099 pushSTACK(obj); C_class_of();
2100 var object objclass = value1;
2101 /* Look whether classname names a superclass of objclass.
2102 Equivalent to (CLOS::SUBCLASSP objclass (find-class classname)),
2103 just a bit faster. */
2104 if (srecord_length(TheClass(objclass)) > built_in_class_length) {
2105 /* Make a distinction between <semi-standard-class> and <structure-class>:
2106 Is (class-current-version class) a vector, or is (class-names class)
2107 a cons? */
2108 if (matomp(TheClass(objclass)->current_version)) {
2109 /* <semi-standard-class>. */
2110 if (nullp(TheClass(objclass)->precedence_list)) /* not yet finalized? */
2111 NOTREACHED; /* shouldn't happen because obj is already an instance */
2112 var object superclasses_table = TheClass(objclass)->all_superclasses;
2113 if (TheHashtable(superclasses_table)->ht_size > 7) {
2114 var object clas = get(classname,S(closclass));
2115 return !eq(gethash(clas,superclasses_table,false),nullobj);
2116 }
2117 /* Few superclasses -> not worth a hash table access. */
2118 } else {
2119 /* <structure-class>. */
2120 /* There are few superclasses. Not worth a hash table access. */
2121 var object objclassnames = TheClass(objclass)->current_version;
2122 #if 0
2123 return !nullp(memq(classname,objclassnames));
2124 #else /* inlined, for performance */
2125 var object l;
2126 for (l = objclassnames; consp(l); l = Cdr(l))
2127 if (eq(Car(l),classname))
2128 return true;
2129 return false;
2130 #endif
2131 }
2132 }
2133 var object l;
2134 for (l = TheClass(objclass)->precedence_list; consp(l); l = Cdr(l))
2135 if (eq(TheClass(Car(l))->classname,classname))
2136 return true;
2137 return false;
2138 }
2139
2140
2141 /* UP: expand all DEFTYPE definitions in the type spec
2142 (recursively, unless once_p is true)
2143 > type_spec: Lisp object
2144 < result: the expansion (when not a deftyped type, returns the argument)
2145 can trigger GC */
expand_deftype(object type_spec,bool once_p)2146 global maygc object expand_deftype (object type_spec, bool once_p) {
2147 var uintV max_depth =
2148 (posfixnump(Symbol_value(S(deftype_depth_limit)))
2149 ? posfixnum_to_V(Symbol_value(S(deftype_depth_limit)))
2150 : posfixnum_to_V(Symbol_value(S(most_positive_fixnum))));
2151 pushSTACK(type_spec);
2152 start:
2153 if (max_depth > 0) max_depth--;
2154 else { /* too many nested DEFTYPEs */
2155 /* type_spec is already on the stack */
2156 pushSTACK(TheSubr(subr_self)->name);
2157 error(error_condition,GETTEXT("~S: type definition for ~S exceeds depth limit, maybe recursive"));
2158 }
2159 if (symbolp(type_spec)) { /* (GET type-spec 'DEFTYPE-EXPANDER) */
2160 var object expander = get(type_spec,S(deftype_expander));
2161 if (boundp(expander)) {
2162 pushSTACK(type_spec);
2163 pushSTACK(expander);
2164 var object new_cons = allocate_cons();
2165 expander = popSTACK();
2166 Car(new_cons) = popSTACK(); /* new_cons = (list type-spec) */
2167 pushSTACK(new_cons); funcall(expander,1); /* call expander */
2168 type_spec = value1; /* use the return value as the new type-spec */
2169 if (!once_p) goto start;
2170 }
2171 } else if (mconsp(type_spec) && symbolp(Car(type_spec))) {
2172 /* (GET (CAR type-spec) 'DEFTYPE-EXPANDER) */
2173 var object expander = get(Car(type_spec),S(deftype_expander));
2174 if (boundp(expander)) {
2175 pushSTACK(type_spec); funcall(expander,1); /* call expander */
2176 type_spec = value1; /* use the return value as the new type-spec */
2177 if (!once_p) goto start;
2178 }
2179 }
2180 skipSTACK(1);
2181 return type_spec;
2182 }
2183
2184 LISPFUN(expand_deftype,seclass_default,1,1,norest,nokey,0,NIL)
2185 /* (SYS::EXPAND-DEFTYPE type-spec &optional once-p)
2186 ==> expanded, user-defined-p */
2187 {
2188 var object once_p = popSTACK();
2189 VALUES2(expand_deftype(STACK_0,!missingp(once_p)),
2190 eq(STACK_0,value1) ? NIL : T);
2191 skipSTACK(1);
2192 }
2193
2194 /* UP: coerce STACK_1 to result_type (a sequence).
2195 check that the result is of type type.
2196 set value1 to the result.
2197 can trigger GC */
coerce_sequence_check(object type,object result_type)2198 local maygc Values coerce_sequence_check (object type, object result_type) {
2199 pushSTACK(type);
2200 /* make new sequence: */
2201 var object new_seq = (coerce_sequence(STACK_2,result_type,true),value1);
2202 /* and re-check with TYPEP: */
2203 pushSTACK(new_seq); pushSTACK(STACK_(0+1)); STACK_(0+2) = new_seq;
2204 funcall(S(typep),2); /* (TYPEP new_seq type) */
2205 if (!nullp(value1)) { /* yes -> new_seq is the value */
2206 value1 = popSTACK();
2207 } else { /* does not match because of SIMPLE-... -> copy new_seq: */
2208 funcall(L(copy_seq),1); /* (COPY-SEQ new_seq) */
2209 }
2210 }
2211
2212 LISPFUNNS(coerce,2)
2213 /* (COERCE object result-type), CLTL p. 51
2214 Method:
2215 (TYPEP object result-type) -> return object
2216 first, expand deftype in result-type
2217 result-type -- a type symbol:
2218 type = T -> return object
2219 type = CHARACTER, STRING-CHAR -> call COERCE_CHAR
2220 type = BASE-CHAR -> call COERCE_CHAR and check
2221 type = FLOAT, SHORT-FLOAT, SINGLE-FLOAT, DOUBLE-FLOAT, LONG-FLOAT ->
2222 use arithmetic conversion
2223 type = COMPLEX -> check for being a number
2224 type = FUNCTION -> function name or lambda expression --> function
2225 type = ARRAY, SIMPLE-ARRAY, VECTOR, SIMPLE-VECTOR, STRING, SIMPLE-STRING,
2226 BASE-STRING, SIMPLE-BASE-STRING, BIT-VECTOR, SIMPLE-BIT-VECTOR ->
2227 [adjust result-type to the object as below??]
2228 convert with COERCE-SEQUENCE, check with TYPEP, and
2229 copy with COPY-SEQ.
2230 otherwise convert with COERCE-SEQUENCE
2231 result-type -- a cons with symbol TYPE as CAR:
2232 type = AND -> (coerce object (second result-type)), check with TYPEP
2233 type = FLOAT, SHORT-FLOAT, SINGLE-FLOAT, DOUBLE-FLOAT, LONG-FLOAT ->
2234 use arithmetic conversion, then check with TYPEP
2235 type = COMPLEX -> check for being a number
2236 coerce Re to (second result-type).
2237 coerce Im to (or (third result-type) (second result-type))
2238 then call COMPLEX.
2239 type = ARRAY, SIMPLE-ARRAY, VECTOR, SIMPLE-VECTOR, STRING, SIMPLE-STRING,
2240 BASE-STRING, SIMPLE-BASE-STRING, BIT-VECTOR, SIMPLE-BIT-VECTOR ->
2241 result-type an object anpassen, convert with COERCE-SEQUENCE
2242 (element-type indicated in result-type is also processed),
2243 check type and possibly copy with COPY-SEQ
2244 check the result-type.
2245 otherwise Error. */
2246 {
2247 /* (TYPEP object result-type): */
2248 pushSTACK(STACK_1); pushSTACK(STACK_(0+1)); funcall(S(typep),2);
2249 if (!nullp(value1)) { /* object as the value */
2250 return_object:
2251 VALUES1(STACK_1); skipSTACK(2); return;
2252 }
2253 STACK_0 = expand_deftype(STACK_0,false);
2254 if_defined_class_p(STACK_0, { STACK_0 = TheClass(STACK_0)->classname; },);
2255 /* stack layout: object, result-type. */
2256 if (matomp(STACK_0)) {
2257 if (!symbolp(STACK_0)) goto error_type;
2258 /* result-type is a symbol */
2259 var object result_type = STACK_0;
2260 if (eq(result_type,T)) /* result-type = T ? */
2261 goto return_object; /* yes -> object as the value */
2262 if (eq(result_type,S(character)) || eq(result_type,S(string_char))
2263 #if (base_char_code_limit == char_code_limit)
2264 || eq(result_type,S(base_char))
2265 #endif
2266 ) { /* result-type = CHARACTER or STRING-CHAR [or BASE-CHAR] ? */
2267 /* try to convert object to character */
2268 var object as_char = coerce_char(STACK_1);
2269 if (nullp(as_char)) {
2270 pushSTACK(STACK_1); /* TYPE-ERROR slot DATUM */
2271 pushSTACK(O(type_designator_character)); /* TYPE-ERROR slot EXPECTED-TYPE */
2272 goto error_object;
2273 }
2274 VALUES1(as_char); skipSTACK(2); return;
2275 }
2276 #if (base_char_code_limit < char_code_limit)
2277 if (eq(result_type,S(base_char))) { /* result-type = BASE-CHAR ? */
2278 /* try to convert object to character */
2279 var object as_char = coerce_char(STACK_1);
2280 if (!base_char_p(as_char)) {
2281 pushSTACK(STACK_1); /* TYPE-ERROR slot DATUM */
2282 pushSTACK(O(type_designator_base_char)); /* TYPE-ERROR slot EXPECTED-TYPE */
2283 goto error_object;
2284 }
2285 VALUES1(as_char); skipSTACK(2); return;
2286 }
2287 #endif
2288 if ( eq(result_type,S(float)) /* FLOAT ? */
2289 || eq(result_type,S(short_float)) /* SHORT-FLOAT ? */
2290 || eq(result_type,S(single_float)) /* SINGLE-FLOAT ? */
2291 || eq(result_type,S(double_float)) /* DOUBLE-FLOAT ? */
2292 || eq(result_type,S(long_float)) /* LONG-FLOAT ? */
2293 ) { /* convert object to float: */
2294 VALUES1(coerce_float(STACK_1,result_type));
2295 skipSTACK(2); return;
2296 }
2297 if (eq(result_type,S(complex))) { /* COMPLEX ? */
2298 if (!numberp(STACK_1)) { /* object must be a number */
2299 pushSTACK(STACK_1); /* TYPE-ERROR slot DATUM */
2300 pushSTACK(S(number)); /* TYPE-ERROR slot EXPECTED-TYPE */
2301 goto error_object;
2302 }
2303 if (!N_floatp(STACK_1))
2304 goto return_object;
2305 VALUES1(F_complex_C(STACK_1));
2306 skipSTACK(2); return;
2307 }
2308 if (eq(result_type,S(function))) { /* FUNCTION ? */
2309 /* viz. coerce_function() */
2310 var object fun = STACK_1;
2311 if (funnamep(fun)) { /* Symbol or (SETF symbol) ? */
2312 VALUES1(sym_function(fun,NIL)); /* global function definition */
2313 if (!functionp(value1)) {
2314 if (functionmacrop(value1))
2315 VALUES1(TheFunctionMacro(value1)->functionmacro_function);
2316 else
2317 VALUES1(check_fdefinition(fun,S(coerce)));
2318 }
2319 skipSTACK(2); return;
2320 }
2321 if (!(consp(fun) && eq(Car(fun),S(lambda)))) { /* object must be a lambda expression */
2322 pushSTACK(fun); /* TYPE-ERROR slot DATUM */
2323 pushSTACK(O(type_designator_function)); /* TYPE-ERROR slot EXPECTED-TYPE */
2324 goto error_object;
2325 }
2326 /* empty environment for get_closure: */
2327 var gcv_environment_t* env;
2328 make_STACK_env(NIL,NIL,NIL,NIL,O(top_decl_env), env = );
2329 /* build closure with lambdabody = (cdr fun), name = :LAMBDA : */
2330 VALUES1(get_closure(Cdr(fun),S(Klambda),false,env));
2331 skipSTACK(2+5); return;
2332 }
2333 if ( eq(result_type,S(array)) /* ARRAY ? */
2334 || eq(result_type,S(simple_array)) /* SIMPLE-ARRAY ? */
2335 || eq(result_type,S(vector)) /* VECTOR ? */
2336 || eq(result_type,S(simple_vector)) /* SIMPLE-VECTOR ? */
2337 || eq(result_type,S(string)) || eq(result_type,S(cs_string)) /* STRING ? */
2338 || eq(result_type,S(simple_string)) /* SIMPLE-STRING ? */
2339 || eq(result_type,S(base_string)) /* BASE-STRING ? */
2340 || eq(result_type,S(simple_base_string)) /* SIMPLE-BASE-STRING ? */
2341 || eq(result_type,S(bit_vector)) /* BIT-VECTOR ? */
2342 || eq(result_type,S(simple_bit_vector)) /* SIMPLE-BIT-VECTOR ? */
2343 ) { /* adapt result-type to the type of object */
2344 if (eq(result_type,S(array)) || eq(result_type,S(vector))) { /* ARRAY or VECTOR ? */
2345 if (vectorp(STACK_1)) /* already a vector? */
2346 goto return_object; /* -> is a vector and array */
2347 } else if (eq(result_type,S(simple_array))) { /* SIMPLE-ARRAY ? */
2348 if (simplep(STACK_1)) /* already a simple-array? */
2349 goto return_object;
2350 if (stringp(STACK_1)) /* object is a string */
2351 result_type = S(simple_string); /* -> result-type := SIMPLE-STRING */
2352 else if (bit_vector_p(Atype_Bit,STACK_1)) /* object is a bit-vector */
2353 result_type = S(simple_bit_vector); /* -> result-type := SIMPLE-BIT-VECTOR */
2354 /* treat byte-vectors here!?? */
2355 }
2356 coerce_sequence_check(result_type,result_type);
2357 skipSTACK(2); return;
2358 }
2359 /* result-type is some other symbol */
2360 /* (coerce-sequence object result-type) */
2361 coerce_sequence(STACK_1,STACK_0,false);
2362 if (eq(value1,nullobj)) { /* failed! */
2363 pushSTACK(STACK_1); /* TYPE-ERROR slot DATUM (object) */
2364 pushSTACK(STACK_(0+1)); /* TYPE-ERROR slot EXPECTED-TYPE (result-type) */
2365 goto error_object;
2366 }
2367 skipSTACK(2); return;
2368 } else {
2369 /* result-type is a cons */
2370 var object result_type = STACK_0;
2371 var object type = Car(result_type);
2372 if (!symbolp(type)) goto error_type; /* must be a symbol */
2373 if (eq(type,S(and))) { /* (AND ...) ? */
2374 if (matomp(Cdr(result_type))) /* (AND) */
2375 goto return_object; /* treat like T */
2376 /* call (COERCE object (second result-type)): */
2377 pushSTACK(STACK_1); pushSTACK(Car(Cdr(result_type)));
2378 funcall(L(coerce),2);
2379 check_return: /* check new-object in value1 and then return it as value: */
2380 pushSTACK(value1); /* save new-object */
2381 /* check (TYPEP new-object result-type): */
2382 pushSTACK(value1); pushSTACK(STACK_(0+1+1)); funcall(S(typep),2);
2383 if (nullp(value1)) {
2384 /* STACK_0 = new-object, TYPE-ERROR slot DATUM */
2385 pushSTACK(STACK_(0+1)); /* TYPE-ERROR slot EXPECTED-TYPE */
2386 goto error_object;
2387 } else {
2388 VALUES1(STACK_0); skipSTACK(3); return; /* new-object */
2389 }
2390 }
2391 if ( eq(type,S(float)) /* FLOAT ? */
2392 || eq(type,S(short_float)) /* SHORT-FLOAT ? */
2393 || eq(type,S(single_float)) /* SINGLE-FLOAT ? */
2394 || eq(type,S(double_float)) /* DOUBLE-FLOAT ? */
2395 || eq(type,S(long_float)) /* LONG-FLOAT ? */
2396 ) { /* convert object to float */
2397 value1 = coerce_float(STACK_1,type);
2398 goto check_return; /* and check against result-type */
2399 }
2400 if (eq(type,S(complex))) { /* COMPLEX ? */
2401 if (!numberp(STACK_1)) { /* object must be a number */
2402 pushSTACK(STACK_1); /* TYPE-ERROR slot DATUM */
2403 pushSTACK(S(number)); /* TYPE-ERROR slot EXPECTED-TYPE */
2404 goto error_object;
2405 }
2406 if (!mconsp(Cdr(result_type))) goto error_type; /* (rest result-type) must be a cons */
2407 result_type = Cdr(result_type);
2408 var object rtype = Car(result_type); /* type of Re */
2409 var object itype = /* type of Im, defaults to rtype */
2410 (mconsp(Cdr(result_type)) ? (object)Car(Cdr(result_type)) : rtype);
2411 pushSTACK(rtype); pushSTACK(itype);
2412 /* get Re and coerce to rtype: */
2413 pushSTACK(STACK_(1+2)); funcall(L(realpart),1);
2414 pushSTACK(value1); pushSTACK(STACK_(1+1)); funcall(L(coerce),2);
2415 STACK_1 = value1;
2416 /* get Im and coerce to itype: */
2417 pushSTACK(STACK_(1+2)); funcall(L(imagpart),1);
2418 pushSTACK(value1); pushSTACK(STACK_(0+1)); funcall(L(coerce),2);
2419 STACK_0 = value1;
2420 /* call COMPLEX on it: */
2421 funcall(L(complex),2);
2422 skipSTACK(2); return;
2423 }
2424 if ( eq(type,S(array)) /* ARRAY ? */
2425 || eq(type,S(simple_array)) /* SIMPLE-ARRAY ? */
2426 || eq(type,S(vector)) /* VECTOR ? */
2427 || eq(type,S(simple_vector)) /* SIMPLE-VECTOR ? */
2428 || eq(type,S(string)) || eq(type,S(cs_string)) /* STRING ? */
2429 || eq(type,S(simple_string)) /* SIMPLE-STRING ? */
2430 || eq(type,S(base_string)) /* BASE-STRING ? */
2431 || eq(type,S(simple_base_string)) /* SIMPLE-BASE-STRING ? */
2432 || eq(type,S(bit_vector)) /* BIT-VECTOR ? */
2433 || eq(type,S(simple_bit_vector)) /* SIMPLE-BIT-VECTOR ? */
2434 ) { /* adapt result-type to the type of object */
2435 if (eq(type,S(array)) || eq(type,S(simple_array))
2436 || eq(type,S(vector))) { /* [SIMPLE-]ARRAY or VECTOR ? */
2437 var object type2 = Cdr(result_type);
2438 if (nullp(type2)) goto adjust_eltype;
2439 if (!consp(type2)) goto error_type;
2440 /* avoid error: jump to label 'adjust_eltype' crosses initialization
2441 in g++ 4.2 */
2442 var bool type2_star; { type2_star = eq(Car(type2),S(star)); }
2443 if (type2_star) { /* element-type = * (unspecified) ? */
2444 type2 = Cdr(type2);
2445 adjust_eltype: /* here type2 = (cddr result-type) */
2446 /* replace with a suitable element type: */
2447 pushSTACK(type2);
2448 pushSTACK(type);
2449 if (arrayp(STACK_(1+2)))
2450 pushSTACK(array_element_type(STACK_(1+2)));
2451 else
2452 pushSTACK(T);
2453 result_type = listof(2);
2454 type = Car(result_type);
2455 Cdr(Cdr(result_type)) = popSTACK();
2456 }
2457 }
2458 coerce_sequence_check(type,result_type);
2459 goto check_return;
2460 }
2461 /* (coerce-sequence object result-type) */
2462 coerce_sequence(STACK_1,STACK_0,false);
2463 if (eq(value1,nullobj)) { /* failed! */
2464 /* If we got here, we know that type is valid, datum is not of that type
2465 and we cannot do the coersion. */
2466 pushSTACK(STACK_1); /* TYPE-ERROR slot DATUM (object) */
2467 pushSTACK(STACK_(0+1)); /* TYPE-ERROR slot EXPECTED-TYPE (result-type) */
2468 goto error_object;
2469 }
2470 skipSTACK(2); return;
2471 }
2472 error_type: {
2473 /* due to the TYPEP call which checks result-type this should never
2474 happen result-type in STACK_0 */
2475 pushSTACK(S(coerce));
2476 error(error_condition,GETTEXT("~S: invalid type specification ~S"));
2477 }
2478 error_object:
2479 /* stack layout: object, result-type, type-error-datum,
2480 type-error-expected-type. */
2481 pushSTACK(STACK_2); /* result-type */
2482 pushSTACK(STACK_(3+1)); /* object */
2483 pushSTACK(S(coerce));
2484 error(type_error,GETTEXT("~S: ~S cannot be coerced to type ~S"));
2485 }
2486
2487 /* =========================================================================
2488 * Heap statistics */
2489
2490 /* Notification from defstruct.lisp and clos.lisp. */
2491 LISPFUNN(note_new_structure_class,0)
2492 {
2493 O(structure_class_count_max) = fixnum_inc(O(structure_class_count_max),1);
2494 }
2495 LISPFUNN(note_new_standard_class,0)
2496 {
2497 O(standard_class_count_max) = fixnum_inc(O(standard_class_count_max),1);
2498 }
2499 /* These two ..._count_max variables are provided so that we can do heap
2500 statistics in one pass, without risking a GC, and without a pre-pass which
2501 determines the number of occurring types.
2502
2503 (SYSTEM::HEAP-STATISTICS)
2504 returns a vector containing statistics records about current heap usage
2505 for each type:
2506 stat = #( ... (classname num-instances . num-bytes) ...)
2507
2508 (SYSTEM::GC-STATISTICS)
2509 returns a list, with one element for each GC (the first for the last GC,
2510 the second for the second-to-last, etc.), where each element is a vector
2511 containing statistics records about what the GC could reclaim of each type:
2512 statlist = ( #( ... (classname num-instances . num-bytes) ...) ...)
2513
2514 Since GC statistics is a burden on each GC, we perform it only when needed,
2515 i.e. while the variable SYSTEM::*GC-STATISTICS* is bound to a value > 0.
2516 When SYSTEM::*GC-STATISTICS* is 0, no statistics are gathered, but old ones
2517 are still kept. When SYSTEM::*GC-STATISTICS* is negative, no statistics are
2518 gathered, and old statistics are thrown away.
2519
2520 The data is gathered in three areas: one for built-in types, one for
2521 structure types (an AVL tree, indexed by structure name), one for
2522 standard-class types (an AVL tree, indexed by the class). While the data
2523 is being gathered, symbols and classes are pushed onto the STACK, but no
2524 heap allocation takes place. */
2525
2526 typedef struct {
2527 const gcv_object_t* name; /* pointer to a GC-safe object (e.g. in the STACK) */
2528 sintL n_instances; /* number of instances */
2529 sintM n_bytes; /* number of bytes */
2530 } hs_record_t;
2531
2532 /* The type of an object for statistics purposes is a little more detailed
2533 than CLASS-OF, but, unlike TYPE-OF, nonparametric. */
2534 enum { /* The values of this enumeration are 0,1,2,...
2535 When you change this, update LISPOBJ(hs_...) in constobj.d! */
2536 enum_hs_t,
2537 enum_hs_cons,
2538 enum_hs_null,
2539 enum_hs_symbol,
2540 enum_hs_simple_bit_vector,
2541 enum_hs_simple_2bit_vector,
2542 enum_hs_simple_4bit_vector,
2543 enum_hs_simple_8bit_vector,
2544 enum_hs_simple_16bit_vector,
2545 enum_hs_simple_32bit_vector,
2546 enum_hs_simple_nilvector,
2547 enum_hs_simple_string,
2548 enum_hs_simple_vector,
2549 enum_hs_bit_vector,
2550 enum_hs_2bit_vector,
2551 enum_hs_4bit_vector,
2552 enum_hs_8bit_vector,
2553 enum_hs_16bit_vector,
2554 enum_hs_32bit_vector,
2555 enum_hs_nilvector,
2556 enum_hs_string,
2557 enum_hs_vector,
2558 enum_hs_simple_array,
2559 enum_hs_array,
2560 enum_hs_function,
2561 enum_hs_file_stream,
2562 enum_hs_synonym_stream,
2563 enum_hs_broadcast_stream,
2564 enum_hs_concatenated_stream,
2565 enum_hs_two_way_stream,
2566 enum_hs_echo_stream,
2567 enum_hs_string_stream,
2568 enum_hs_stream,
2569 enum_hs_hash_table,
2570 enum_hs_package,
2571 enum_hs_readtable,
2572 enum_hs_pathname,
2573 enum_hs_logical_pathname,
2574 enum_hs_random_state,
2575 enum_hs_byte,
2576 enum_hs_special_operator,
2577 enum_hs_load_time_eval,
2578 enum_hs_symbol_macro,
2579 enum_hs_global_symbol_macro,
2580 enum_hs_macro,
2581 enum_hs_function_macro,
2582 enum_hs_big_read_label,
2583 enum_hs_encoding,
2584 #ifdef FOREIGN
2585 enum_hs_foreign_pointer,
2586 #endif
2587 #ifdef DYNAMIC_FFI
2588 enum_hs_foreign_address,
2589 enum_hs_foreign_variable,
2590 enum_hs_foreign_function,
2591 #endif
2592 #ifdef HAVE_SMALL_SSTRING
2593 enum_hs_realloc_simple_string,
2594 #endif
2595 enum_hs_realloc_instance,
2596 enum_hs_weakpointer,
2597 enum_hs_weak_list,
2598 enum_hs_weak_alist,
2599 enum_hs_weakmapping,
2600 enum_hs_finalizer,
2601 #ifdef SOCKET_STREAMS
2602 enum_hs_socket_server,
2603 #endif
2604 #ifdef MULTITHREAD
2605 enum_hs_thread,
2606 enum_hs_mutex,
2607 enum_hs_exemption,
2608 #endif
2609 #ifdef YET_ANOTHER_RECORD
2610 enum_hs_yetanother,
2611 #endif
2612 enum_hs_internal_weak_list,
2613 enum_hs_weak_and_relation,
2614 enum_hs_weak_or_relation,
2615 enum_hs_weak_and_mapping,
2616 enum_hs_weak_or_mapping,
2617 enum_hs_internal_weak_alist,
2618 enum_hs_internal_weak_hashed_alist,
2619 enum_hs_system_function,
2620 enum_hs_bignum,
2621 enum_hs_ratio,
2622 #ifndef IMMEDIATE_FFLOAT
2623 enum_hs_single_float,
2624 #endif
2625 enum_hs_double_float,
2626 enum_hs_long_float,
2627 enum_hs_complex,
2628 enum_hs_dummy
2629 };
2630
2631 /* Need an AVL tree for rapidly associating a hs_record_t to its name. */
2632
2633 #define AVLID heapstat
2634 #define AVL_ELEMENT hs_record_t
2635 #define AVL_EQUAL(element1,element2) (eq(*(element1).name,*(element2).name))
2636 #define AVL_KEY object
2637 #define AVL_KEYOF(element) (*(element).name)
2638 #define AVL_SIGNED_INT soint
2639 #define AVL_COMPARE(key1,key2) (soint)(as_oint(key1)-as_oint(key2))
2640 #define NO_AVL_MEMBER
2641 #define NO_AVL_INSERT
2642 #define NO_AVL_DELETE
2643 #define NO_AVL_DELETE1
2644 #define NO_AVL_LEAST
2645 #define NO_AVL_MOVE
2646 #define NO_AVL_SORT
2647 #include "avl.c"
2648 #include "avl.c" /* This defines the NODE type. */
2649
2650 typedef struct {
2651 NODE* tree;
2652 uintL count;
2653 NODE* free_nodes;
2654 uintL free_count;
2655 } hs_sorted_t;
2656
2657 typedef struct {
2658 bool decrementing; /* incrementing or decrementing */
2659 hs_sorted_t structure_classes;
2660 hs_sorted_t standard_classes;
2661 hs_record_t builtins[(int)enum_hs_dummy];
2662 } hs_locals_t;
2663
2664 /* Initialize a hs_locals_t.
2665 NB: This does stack allocation on the caller's stack. */
2666 #define init_hs_locals(locals) \
2667 var DYNAMIC_ARRAY(free_room,NODE, (locals.structure_classes.free_count = posfixnum_to_V(O(structure_class_count_max))) + (locals.standard_classes.free_count = posfixnum_to_V(O(standard_class_count_max)))); \
2668 init_hs_locals_rest(&locals,free_room);
2669 #define done_hs_locals(locals) \
2670 FREE_DYNAMIC_ARRAY(free_room);
2671
init_hs_locals_rest(hs_locals_t * locals,NODE * free_room)2672 local void init_hs_locals_rest (hs_locals_t* locals, NODE* free_room)
2673 {
2674 locals->decrementing = false;
2675 /* Initialize all counters to 0. */
2676 locals->structure_classes.tree = EMPTY;
2677 locals->standard_classes.tree = EMPTY;
2678 locals->structure_classes.count = 0;
2679 locals->standard_classes.count = 0;
2680 locals->structure_classes.free_nodes = &free_room[0];
2681 locals->standard_classes.free_nodes = &free_room[locals->structure_classes.free_count];
2682 {
2683 var uintC count;
2684 var hs_record_t* ptr = &locals->builtins[0];
2685 var const gcv_object_t* optr = &O(hs_t);
2686 dotimesC(count,(uintC)enum_hs_dummy, {
2687 ptr->name = optr;
2688 ptr->n_instances = 0;
2689 ptr->n_bytes = 0;
2690 ptr++; optr++;
2691 });
2692 }
2693 /* Prepare for STACK allocation. */
2694 get_space_on_STACK(sizeof(gcv_object_t) * (locals->structure_classes.free_count + locals->standard_classes.free_count));
2695 }
2696
2697 /* This is the function we pass to map_heap_objects(). */
heap_statistics_mapper(void * arg,object obj,uintM bytelen)2698 local void heap_statistics_mapper (void* arg, object obj, uintM bytelen)
2699 {
2700 var hs_locals_t* locals = (hs_locals_t*)arg;
2701 var hs_record_t* pighole; /* `pighole' stands for `pigeon-hole' */
2702 #ifdef TYPECODES
2703 switch (typecode(obj))
2704 #else
2705 if (orecordp(obj)) {
2706 goto case_orecord;
2707 } else if (consp(obj)) {
2708 goto case_cons;
2709 } else if (immsubrp(obj)) {
2710 goto case_subr;
2711 } else
2712 switch (0)
2713 #endif
2714 {
2715 instances:
2716 case_instance: { /* instance */
2717 if (record_flags(TheInstance(obj)) & instflags_forwarded_B) {
2718 pighole = &locals->builtins[(int)enum_hs_realloc_instance];
2719 break;
2720 }
2721 var object cv = TheInstance(obj)->inst_class_version;
2722 var object clas = TheClassVersion(cv)->cv_newest_class;
2723 var NODE* found = AVL(AVLID,member0)(clas,locals->standard_classes.tree);
2724 if (found == (NODE*)NULL) {
2725 if (locals->standard_classes.free_count == 0) { /* shouldn't happen */
2726 pighole = &locals->builtins[(int)enum_hs_t]; break;
2727 }
2728 locals->standard_classes.free_count--;
2729 found = locals->standard_classes.free_nodes++;
2730 pushSTACK(clas);
2731 found->nodedata.value.name = &STACK_0;
2732 found->nodedata.value.n_instances = 0;
2733 found->nodedata.value.n_bytes = 0;
2734 locals->standard_classes.tree = AVL(AVLID,insert1)(found,locals->standard_classes.tree);
2735 locals->standard_classes.count++;
2736 }
2737 pighole = &found->nodedata.value;
2738 break;
2739 }
2740 case_structure: { /* Structure */
2741 var object name = Car(TheStructure(obj)->structure_types);
2742 var NODE* found = AVL(AVLID,member0)(name,locals->structure_classes.tree);
2743 if (found == (NODE*)NULL) {
2744 if (locals->structure_classes.free_count == 0) { /* shouldn't happen */
2745 pighole = &locals->builtins[(int)enum_hs_t]; break;
2746 }
2747 locals->structure_classes.free_count--;
2748 found = locals->structure_classes.free_nodes++;
2749 pushSTACK(name);
2750 found->nodedata.value.name = &STACK_0;
2751 found->nodedata.value.n_instances = 0;
2752 found->nodedata.value.n_bytes = 0;
2753 locals->structure_classes.tree = AVL(AVLID,insert1)(found,locals->structure_classes.tree);
2754 locals->structure_classes.count++;
2755 }
2756 pighole = &found->nodedata.value;
2757 break;
2758 }
2759 case_cons: /* Cons */
2760 pighole = &locals->builtins[(int)enum_hs_cons];
2761 break;
2762 case_symbol: /* Symbol */
2763 if (nullp(obj))
2764 pighole = &locals->builtins[(int)enum_hs_null];
2765 else
2766 pighole = &locals->builtins[(int)enum_hs_symbol];
2767 break;
2768 case_sbvector: /* Simple-Bit-Vector */
2769 pighole = &locals->builtins[(int)enum_hs_simple_bit_vector];
2770 break;
2771 case_sb2vector: /* Simple-2Bit-Vector */
2772 pighole = &locals->builtins[(int)enum_hs_simple_2bit_vector];
2773 break;
2774 case_sb4vector: /* Simple-4Bit-Vector */
2775 pighole = &locals->builtins[(int)enum_hs_simple_4bit_vector];
2776 break;
2777 case_sb8vector: /* Simple-8Bit-Vector */
2778 pighole = &locals->builtins[(int)enum_hs_simple_8bit_vector];
2779 break;
2780 case_sb16vector: /* Simple-16Bit-Vector */
2781 pighole = &locals->builtins[(int)enum_hs_simple_16bit_vector];
2782 break;
2783 case_sb32vector: /* Simple-32Bit-Vector */
2784 pighole = &locals->builtins[(int)enum_hs_simple_32bit_vector];
2785 break;
2786 case_sstring: /* Simple-String */
2787 #ifdef HAVE_SMALL_SSTRING
2788 if (sstring_reallocatedp(TheSstring(obj))) {
2789 pighole = &locals->builtins[(int)enum_hs_realloc_simple_string];
2790 break;
2791 }
2792 #endif
2793 pighole = &locals->builtins[(int)enum_hs_simple_string];
2794 break;
2795 case_svector: /* Simple-Vector */
2796 pighole = &locals->builtins[(int)enum_hs_simple_vector];
2797 break;
2798 case_obvector: /* other Bit-Vector */
2799 pighole = &locals->builtins[(int)enum_hs_bit_vector];
2800 break;
2801 case_ob2vector: /* other 2Bit-Vector */
2802 pighole = &locals->builtins[(int)enum_hs_2bit_vector];
2803 break;
2804 case_ob4vector: /* other 4Bit-Vector */
2805 pighole = &locals->builtins[(int)enum_hs_4bit_vector];
2806 break;
2807 case_ob8vector: /* other 8Bit-Vector */
2808 pighole = &locals->builtins[(int)enum_hs_8bit_vector];
2809 break;
2810 case_ob16vector: /* other 16Bit-Vector */
2811 pighole = &locals->builtins[(int)enum_hs_16bit_vector];
2812 break;
2813 case_ob32vector: /* other 32Bit-Vector */
2814 pighole = &locals->builtins[(int)enum_hs_32bit_vector];
2815 break;
2816 case_ostring: /* other String */
2817 if ((Iarray_flags(obj) & arrayflags_atype_mask) == Atype_NIL) {
2818 if ((Iarray_flags(obj)
2819 & ( bit(arrayflags_adjustable_bit)
2820 | bit(arrayflags_fillp_bit)
2821 | bit(arrayflags_displaced_bit)
2822 | bit(arrayflags_dispoffset_bit)))
2823 == 0)
2824 pighole = &locals->builtins[(int)enum_hs_simple_nilvector];
2825 else
2826 pighole = &locals->builtins[(int)enum_hs_nilvector];
2827 } else
2828 pighole = &locals->builtins[(int)enum_hs_string];
2829 break;
2830 case_ovector: /* other general-vector */
2831 pighole = &locals->builtins[(int)enum_hs_vector];
2832 break;
2833 case_mdarray: /* other Array */
2834 if ((Iarray_flags(obj)
2835 & ( bit(arrayflags_adjustable_bit)
2836 | bit(arrayflags_fillp_bit)
2837 | bit(arrayflags_displaced_bit)
2838 | bit(arrayflags_dispoffset_bit)))
2839 == 0)
2840 pighole = &locals->builtins[(int)enum_hs_simple_array];
2841 else
2842 pighole = &locals->builtins[(int)enum_hs_array];
2843 break;
2844 case_closure: /* Closure */
2845 if (Closure_instancep(obj))
2846 goto instances;
2847 pighole = &locals->builtins[(int)enum_hs_function];
2848 break;
2849 case_stream: /* Stream */
2850 switch (TheStream(obj)->strmtype) {
2851 case strmtype_file:
2852 pighole = &locals->builtins[(int)enum_hs_file_stream]; break;
2853 case strmtype_synonym:
2854 pighole = &locals->builtins[(int)enum_hs_synonym_stream]; break;
2855 case strmtype_broad:
2856 pighole = &locals->builtins[(int)enum_hs_broadcast_stream]; break;
2857 case strmtype_concat:
2858 pighole = &locals->builtins[(int)enum_hs_concatenated_stream]; break;
2859 case strmtype_twoway:
2860 pighole = &locals->builtins[(int)enum_hs_two_way_stream]; break;
2861 case strmtype_echo:
2862 pighole = &locals->builtins[(int)enum_hs_echo_stream]; break;
2863 case strmtype_str_in:
2864 case strmtype_str_out:
2865 case strmtype_str_push:
2866 pighole = &locals->builtins[(int)enum_hs_string_stream]; break;
2867 default:
2868 pighole = &locals->builtins[(int)enum_hs_stream]; break;
2869 }
2870 break;
2871 case_orecord: case_lrecord: /* OtherRecord */
2872 switch (Record_type(obj)) {
2873 case_Rectype_Instance_above;
2874 case_Rectype_Structure_above;
2875 case_Rectype_Symbol_above;
2876 case_Rectype_Sbvector_above;
2877 case_Rectype_Sb2vector_above;
2878 case_Rectype_Sb4vector_above;
2879 case_Rectype_Sb8vector_above;
2880 case_Rectype_Sb16vector_above;
2881 case_Rectype_Sb32vector_above;
2882 case_Rectype_Sstring_above;
2883 case_Rectype_Svector_above;
2884 case_Rectype_obvector_above;
2885 case_Rectype_ob2vector_above;
2886 case_Rectype_ob4vector_above;
2887 case_Rectype_ob8vector_above;
2888 case_Rectype_ob16vector_above;
2889 case_Rectype_ob32vector_above;
2890 case_Rectype_ostring_above;
2891 case_Rectype_ovector_above;
2892 case_Rectype_mdarray_above;
2893 case_Rectype_Closure_above;
2894 case_Rectype_Stream_above;
2895 case_Rectype_Bignum_above;
2896 case_Rectype_Ratio_above;
2897 case_Rectype_Ffloat_above;
2898 case_Rectype_Dfloat_above;
2899 case_Rectype_Lfloat_above;
2900 case_Rectype_Complex_above;
2901 case_Rectype_Subr_above;
2902 case Rectype_Hashtable: /* Hash-Table */
2903 pighole = &locals->builtins[(int)enum_hs_hash_table]; break;
2904 case Rectype_Package: /* Package */
2905 pighole = &locals->builtins[(int)enum_hs_package]; break;
2906 case Rectype_Readtable: /* Readtable */
2907 pighole = &locals->builtins[(int)enum_hs_readtable]; break;
2908 case Rectype_Pathname: /* Pathname */
2909 pighole = &locals->builtins[(int)enum_hs_pathname]; break;
2910 case Rectype_Logpathname: /* Logical Pathname */
2911 pighole = &locals->builtins[(int)enum_hs_logical_pathname]; break;
2912 case Rectype_Random_State: /* Random-State */
2913 pighole = &locals->builtins[(int)enum_hs_random_state]; break;
2914 case Rectype_Byte: /* Byte */
2915 pighole = &locals->builtins[(int)enum_hs_byte]; break;
2916 case Rectype_Fsubr: /* Fsubr */
2917 pighole = &locals->builtins[(int)enum_hs_special_operator]; break;
2918 case Rectype_Loadtimeeval: /* Load-Time-Eval */
2919 pighole = &locals->builtins[(int)enum_hs_load_time_eval]; break;
2920 case Rectype_Symbolmacro: /* Symbol-Macro */
2921 pighole = &locals->builtins[(int)enum_hs_symbol_macro]; break;
2922 case Rectype_GlobalSymbolmacro: /* Global-Symbol-Macro */
2923 pighole = &locals->builtins[(int)enum_hs_global_symbol_macro]; break;
2924 case Rectype_Macro: /* Macro */
2925 pighole = &locals->builtins[(int)enum_hs_macro]; break;
2926 case Rectype_FunctionMacro: /* FunctionMacro */
2927 pighole = &locals->builtins[(int)enum_hs_function_macro]; break;
2928 case Rectype_BigReadLabel: /* BigReadLabel */
2929 pighole = &locals->builtins[(int)enum_hs_big_read_label]; break;
2930 case Rectype_Encoding: /* Encoding */
2931 pighole = &locals->builtins[(int)enum_hs_encoding]; break;
2932 #ifdef FOREIGN
2933 case Rectype_Fpointer: /* Foreign-Pointer-Wrapping */
2934 pighole = &locals->builtins[(int)enum_hs_foreign_pointer]; break;
2935 #endif
2936 #ifdef DYNAMIC_FFI
2937 case Rectype_Faddress: /* Foreign-Address */
2938 pighole = &locals->builtins[(int)enum_hs_foreign_address]; break;
2939 case Rectype_Fvariable: /* Foreign-Variable */
2940 pighole = &locals->builtins[(int)enum_hs_foreign_variable]; break;
2941 case Rectype_Ffunction: /* Foreign-Function */
2942 pighole = &locals->builtins[(int)enum_hs_foreign_function]; break;
2943 #endif
2944 case Rectype_Weakpointer: /* Weak-Pointer */
2945 pighole = &locals->builtins[(int)enum_hs_weakpointer]; break;
2946 case Rectype_MutableWeakList: /* mutable Weak-List */
2947 pighole = &locals->builtins[(int)enum_hs_weak_list]; break;
2948 case Rectype_MutableWeakAlist: /* mutable Weak-Alist */
2949 pighole = &locals->builtins[(int)enum_hs_weak_alist]; break;
2950 case Rectype_Weakmapping: /* Weak-Mapping */
2951 pighole = &locals->builtins[(int)enum_hs_weakmapping]; break;
2952 case Rectype_Finalizer: /* Finalizer */
2953 pighole = &locals->builtins[(int)enum_hs_finalizer]; break;
2954 #ifdef SOCKET_STREAMS
2955 case Rectype_Socket_Server: /* Socket-Server */
2956 pighole = &locals->builtins[(int)enum_hs_socket_server]; break;
2957 #endif
2958 #ifdef MULTITHREAD
2959 case Rectype_Thread:
2960 pighole = &locals->builtins[(int)enum_hs_thread]; break;
2961 case Rectype_Mutex:
2962 pighole = &locals->builtins[(int)enum_hs_mutex]; break;
2963 case Rectype_Exemption:
2964 pighole = &locals->builtins[(int)enum_hs_exemption]; break;
2965 #endif
2966 #ifdef YET_ANOTHER_RECORD
2967 case Rectype_Yetanother: /* Yetanother */
2968 pighole = &locals->builtins[(int)enum_hs_yetanother]; break;
2969 #endif
2970 case Rectype_WeakList: /* Weak-List */
2971 pighole = &locals->builtins[(int)enum_hs_internal_weak_list]; break;
2972 case Rectype_WeakAnd: /* Weak-And-Relation */
2973 pighole = &locals->builtins[(int)enum_hs_weak_and_relation]; break;
2974 case Rectype_WeakOr: /* Weak-Or-Relation */
2975 pighole = &locals->builtins[(int)enum_hs_weak_or_relation]; break;
2976 case Rectype_WeakAndMapping: /* Weak-And-Mapping */
2977 pighole = &locals->builtins[(int)enum_hs_weak_and_mapping]; break;
2978 case Rectype_WeakOrMapping: /* Weak-Or-Mapping */
2979 pighole = &locals->builtins[(int)enum_hs_weak_or_mapping]; break;
2980 case Rectype_WeakAlist_Key:
2981 case Rectype_WeakAlist_Value:
2982 case Rectype_WeakAlist_Either:
2983 case Rectype_WeakAlist_Both: /* Weak-Alist */
2984 pighole = &locals->builtins[(int)enum_hs_internal_weak_alist]; break;
2985 case Rectype_WeakHashedAlist_Key:
2986 case Rectype_WeakHashedAlist_Value:
2987 case Rectype_WeakHashedAlist_Either:
2988 case Rectype_WeakHashedAlist_Both: /* Weak-Hashed-Alist */
2989 pighole = &locals->builtins[(int)enum_hs_internal_weak_hashed_alist]; break;
2990 default:
2991 pighole = &locals->builtins[(int)enum_hs_t]; break;
2992 }
2993 break;
2994 case_subr: /* SUBR */
2995 pighole = &locals->builtins[(int)enum_hs_system_function];
2996 break;
2997 case_bignum: /* Bignum */
2998 pighole = &locals->builtins[(int)enum_hs_bignum];
2999 break;
3000 case_ratio: /* Ratio */
3001 pighole = &locals->builtins[(int)enum_hs_ratio];
3002 break;
3003 #ifndef IMMEDIATE_FFLOAT
3004 case_ffloat: /* Single-Float */
3005 pighole = &locals->builtins[(int)enum_hs_single_float];
3006 break;
3007 #endif
3008 case_dfloat: /* Double-Float */
3009 pighole = &locals->builtins[(int)enum_hs_double_float];
3010 break;
3011 case_lfloat: /* Long-Float */
3012 pighole = &locals->builtins[(int)enum_hs_long_float];
3013 break;
3014 case_complex: /* Complex */
3015 pighole = &locals->builtins[(int)enum_hs_complex];
3016 break;
3017 default:
3018 pighole = &locals->builtins[(int)enum_hs_t]; break;
3019 }
3020 if (locals->decrementing) {
3021 pighole->n_instances -= 1;
3022 pighole->n_bytes -= bytelen;
3023 } else {
3024 pighole->n_instances += 1;
3025 pighole->n_bytes += bytelen;
3026 }
3027 }
3028
3029 /* Creates a statistics record for the objects of a given type.
3030 can trigger GC */
heap_statistics_record(object type,sintL n_instances,sintM n_bytes)3031 local maygc object heap_statistics_record (object type, sintL n_instances, sintM n_bytes) {
3032 pushSTACK(type);
3033 pushSTACK(L_to_I(n_instances));
3034 pushSTACK(sintM_to_I(n_bytes));
3035 var object hsr = make_list(2);
3036 Cdr(Cdr(hsr)) = popSTACK();
3037 Car(Cdr(hsr)) = popSTACK();
3038 Car(hsr) = popSTACK();
3039 return hsr;
3040 }
3041
3042 /* Creates a vector containing the heap statistics result,
3043 and pushes it onto the STACK.
3044 can trigger GC */
heap_statistics_result(hs_locals_t * locals)3045 local maygc void heap_statistics_result (hs_locals_t* locals)
3046 {
3047 /* Allocate result vector. */
3048 var uintL length = (uintL)enum_hs_dummy
3049 + locals->structure_classes.count
3050 + locals->standard_classes.count;
3051 pushSTACK(allocate_vector(length));
3052 var gcv_object_t* result_ = &STACK_0;
3053 /* Fill result vector. */
3054 var uintL i = 0;
3055 {
3056 var uintC count;
3057 var hs_record_t* ptr = &locals->builtins[0];
3058 dotimesC(count,(uintC)enum_hs_dummy, {
3059 var object hsr =
3060 heap_statistics_record(*ptr->name,ptr->n_instances,ptr->n_bytes);
3061 TheSvector(*result_)->data[i] = hsr;
3062 ptr++; i++;
3063 });
3064 }
3065 {
3066 var uintL count = locals->structure_classes.count;
3067 if (count > 0) {
3068 var NODE* ptr = locals->structure_classes.free_nodes;
3069 dotimespL(count,count, {
3070 --ptr;
3071 var object hsr =
3072 heap_statistics_record(*ptr->nodedata.value.name,
3073 ptr->nodedata.value.n_instances,
3074 ptr->nodedata.value.n_bytes);
3075 TheSvector(*result_)->data[i] = hsr;
3076 i++;
3077 });
3078 }
3079 }
3080 {
3081 var uintL count = locals->standard_classes.count;
3082 if (count > 0) {
3083 var NODE* ptr = locals->standard_classes.free_nodes;
3084 dotimespL(count,count, {
3085 --ptr;
3086 var object hsr =
3087 heap_statistics_record(TheClass(*ptr->nodedata.value.name)->classname,
3088 ptr->nodedata.value.n_instances,
3089 ptr->nodedata.value.n_bytes);
3090 TheSvector(*result_)->data[i] = hsr;
3091 i++;
3092 });
3093 }
3094 }
3095 }
3096
3097 LISPFUNN(heap_statistics,0)
3098 {
3099 var hs_locals_t locals;
3100 init_hs_locals(locals);
3101 /* Walk through memory. */
3102 map_heap_objects(&heap_statistics_mapper,&locals);
3103 /* Allocate and fill result vector. */
3104 heap_statistics_result(&locals);
3105 /* Done. */
3106 VALUES1(popSTACK());
3107 skipSTACK(locals.structure_classes.count + locals.standard_classes.count);
3108 done_hs_locals(locals);
3109 }
3110
3111 LISPFUNN(gc_statistics,0)
3112 {
3113 VALUES1(O(gc_statistics_list));
3114 }
3115
3116 /* UP: keeps statistics on the action of a GC.
3117 with_gc_statistics(fun);
3118 > fun: function, that triggers a GC */
with_gc_statistics(gc_function_t * fun)3119 global void with_gc_statistics (gc_function_t* fun) {
3120 var object flag = Symbol_value(S(gc_statistics_star));
3121 if (!posfixnump(flag)) {
3122 /* No need to do statistics, throw old ones away. */
3123 O(gc_statistics_list) = NIL; fun();
3124 } else if (eq(flag,Fixnum_0)) {
3125 /* No need to do statistics, but keep old ones. */
3126 fun();
3127 } else {
3128 /* Do statistics. */
3129 var hs_locals_t locals;
3130 init_hs_locals(locals);
3131 /* Walk through memory. */
3132 map_heap_objects(&heap_statistics_mapper,&locals);
3133 #ifdef DEBUG_SPVW
3134 fprintf(stderr,"[%lu] with_gc_statistics: starting a GC...",(unsigned long)gc_count);
3135 #endif
3136 /* Now do the GC. */
3137 fun();
3138 #ifdef DEBUG_SPVW
3139 fprintf(stderr,"done [%ld]\n",(long)free_space());
3140 #endif
3141 /* Walk through memory again, this time decrementing. */
3142 locals.decrementing = true;
3143 map_heap_objects(&heap_statistics_mapper,&locals);
3144 /* Now if in the following allocation requests, a GC occurs, we
3145 might mix up the order of the records in O(gc_statistics_list),
3146 but that's not relevant.
3147 But if memory is full, we might be called recursively. A recursive
3148 depth of 1 is OK (that's normal), but a greater recursion depth
3149 is a sign of an infinite recursion. In this case we rebind
3150 SYSTEM::*GC-STATISTICS* to 0. */
3151 var bool danger = false;
3152 dynamic_bind(S(recurse_count_gc_statistics),fixnum_inc(Symbol_value(S(recurse_count_gc_statistics)),1)); /* increase sys::*recurse-count-gc-statistics* */
3153 if (!posfixnump(Symbol_value(S(recurse_count_gc_statistics)))) /* should be a Fixnum >=0 */
3154 Symbol_value(S(recurse_count_gc_statistics)) = Fixnum_0; /* otherwise emergency correction */
3155 if (posfixnum_to_V(Symbol_value(S(recurse_count_gc_statistics))) > 3) {
3156 /* recursion depth too big. */
3157 danger = true;
3158 dynamic_bind(S(gc_statistics_star),Fixnum_0);
3159 }
3160 /* Allocate and fill result vector. */
3161 heap_statistics_result(&locals);
3162 { /* Push it onto O(gc_statistics_list). */
3163 var object new_cons = allocate_cons();
3164 Car(new_cons) = popSTACK(); Cdr(new_cons) = O(gc_statistics_list);
3165 O(gc_statistics_list) = new_cons;
3166 }
3167 /* Done. */
3168 if (danger) { dynamic_unbind(S(gc_statistics_star)); }
3169 dynamic_unbind(S(recurse_count_gc_statistics));
3170 skipSTACK(locals.structure_classes.count + locals.standard_classes.count);
3171 done_hs_locals(locals);
3172 }
3173 }
3174
statistics_statistics(uintL svector_instances,uintL svector_bytes,uintL cons_instances)3175 local Values statistics_statistics (uintL svector_instances,
3176 uintL svector_bytes, uintL cons_instances)
3177 {
3178 {
3179 var object hsr = make_list(2);
3180 Car(hsr) = O(hs_simple_vector);
3181 Car(Cdr(hsr)) = fixnum(svector_instances);
3182 Cdr(Cdr(hsr)) = fixnum(svector_bytes);
3183 pushSTACK(hsr);
3184 }
3185 {
3186 var object hsr = make_list(2);
3187 Car(hsr) = O(hs_cons);
3188 Car(Cdr(hsr)) = fixnum(cons_instances);
3189 Cdr(Cdr(hsr)) = fixnum(cons_instances*sizeof(cons_));
3190 pushSTACK(hsr);
3191 }
3192 VALUES1(vectorof(2));
3193 }
3194
3195 LISPFUNN(list_statistics,1)
3196 { /* (SYSTEM::LIST-STATISTICS list)
3197 Return statistics about how much a list uses. */
3198 statistics_statistics(0,0,llength(popSTACK()));
3199 }
3200
3201 LISPFUNN(heap_statistics_statistics,1)
3202 { /* (SYSTEM::HEAP-STATISTICS-STATISTICS statistics)
3203 Return statistics about how much a statistics vector uses. */
3204 var object obj = popSTACK();
3205 ASSERT(simple_vector_p(obj));
3206 statistics_statistics(1,varobject_bytelength(obj),Svector_length(obj)*2);
3207 }
3208
3209 LISPFUNN(gc_statistics_statistics,2)
3210 { /* (SYSTEM::GC-STATISTICS-STATISTICS statlist1 statlist2)
3211 Return statistics about how much the GC statistics used up between two calls
3212 to the function SYSTEM::GC-STATISTICS. */
3213 var object statlist2 = popSTACK();
3214 var object statlist1 = popSTACK();
3215 var uintL svector_instances = 0;
3216 var uintL svector_bytes = 0;
3217 var uintL cons_instances = 0;
3218 while (consp(statlist2) && !eq(statlist2,statlist1)) {
3219 var object obj = Car(statlist2);
3220 ASSERT(simple_vector_p(obj));
3221 svector_instances += 1;
3222 svector_bytes += varobject_bytelength(obj);
3223 cons_instances += 1 + Svector_length(obj)*2;
3224 statlist2 = Cdr(statlist2);
3225 }
3226 statistics_statistics(svector_instances,svector_bytes,cons_instances);
3227 }
3228