1 /* g/r.c
2 **
3 */
4 #include "all.h"
5
6 /* _frag_word(): fast fragment/branch prediction for top word.
7 */
8 static u3_weak
_frag_word(c3_w a_w,u3_noun b)9 _frag_word(c3_w a_w, u3_noun b)
10 {
11 c3_assert(0 != a_w);
12
13 {
14 c3_w dep_w = u3x_dep(a_w);
15
16 while ( dep_w ) {
17 if ( c3n == u3a_is_cell(b) ) {
18 return u3_none;
19 }
20 else {
21 u3a_cell* b_u = u3a_to_ptr(b);
22
23 b = *(((u3_noun*)&(b_u->hed)) + (1 & (a_w >> (dep_w - 1))));
24 dep_w--;
25 }
26 }
27 return b;
28 }
29 }
30
31 /* _frag_deep(): fast fragment/branch for deep words.
32 */
33 static u3_weak
_frag_deep(c3_w a_w,u3_noun b)34 _frag_deep(c3_w a_w, u3_noun b)
35 {
36 c3_w dep_w = 32;
37
38 while ( dep_w ) {
39 if ( c3n == u3a_is_cell(b) ) {
40 return u3_none;
41 }
42 else {
43 u3a_cell* b_u = u3a_to_ptr(b);
44
45 b = *(((u3_noun*)&(b_u->hed)) + (1 & (a_w >> (dep_w - 1))));
46 dep_w--;
47 }
48 }
49 return b;
50 }
51
52 /* u3r_at():
53 **
54 ** Return fragment (a) of (b), or u3_none if not applicable.
55 */
56 u3_weak
u3r_at(u3_atom a,u3_noun b)57 u3r_at(u3_atom a, u3_noun b)
58 {
59 c3_assert(u3_none != a);
60 c3_assert(u3_none != b);
61
62 u3t_on(far_o);
63
64 if ( 0 == a ) {
65 u3t_off(far_o);
66 return u3_none;
67 }
68
69 if ( _(u3a_is_cat(a)) ) {
70 u3t_off(far_o);
71 return _frag_word(a, b);
72 }
73 else {
74 if ( !_(u3a_is_pug(a)) ) {
75 u3t_off(far_o);
76 return u3_none;
77 }
78 else {
79 u3a_atom* a_u = u3a_to_ptr(a);
80 c3_w len_w = a_u->len_w;
81
82 b = _frag_word(a_u->buf_w[len_w - 1], b);
83 len_w -= 1;
84
85 while ( len_w ) {
86 b = _frag_deep(a_u->buf_w[len_w - 1], b);
87
88 if ( u3_none == b ) {
89 u3t_off(far_o);
90
91 return b;
92 } else {
93 len_w--;
94 }
95 }
96 u3t_off(far_o);
97
98 return b;
99 }
100 }
101 }
102
103 /* u3r_mean():
104 **
105 ** Attempt to deconstruct `a` by axis, noun pairs; 0 terminates.
106 ** Axes must be sorted in tree order.
107 */
108 struct _mean_pair {
109 c3_w axe_w;
110 u3_noun* som;
111 };
112
113 static c3_w
_mean_cut(c3_w len_w,struct _mean_pair * prs_m)114 _mean_cut(c3_w len_w,
115 struct _mean_pair* prs_m)
116 {
117 c3_w i_w, cut_t, cut_w;
118
119 cut_t = 0;
120 cut_w = 0;
121 for ( i_w = 0; i_w < len_w; i_w++ ) {
122 c3_w axe_w = prs_m[i_w].axe_w;
123
124 if ( (cut_t == 0) && (3 == u3x_cap(axe_w)) ) {
125 cut_t = 1;
126 cut_w = i_w;
127 }
128 prs_m[i_w].axe_w = u3x_mas(axe_w);
129 }
130 return cut_t ? cut_w : i_w;
131 }
132
133 static c3_o
_mean_extract(u3_noun som,c3_w len_w,struct _mean_pair * prs_m)134 _mean_extract(u3_noun som,
135 c3_w len_w,
136 struct _mean_pair* prs_m)
137 {
138 if ( len_w == 0 ) {
139 return c3y;
140 }
141 else if ( (len_w == 1) && (1 == prs_m[0].axe_w) ) {
142 *prs_m->som = som;
143 return c3y;
144 }
145 else {
146 if ( c3n == u3a_is_cell(som) ) {
147 return c3n;
148 } else {
149 c3_w cut_w = _mean_cut(len_w, prs_m);
150
151 return c3a
152 (_mean_extract(u3a_h(som), cut_w, prs_m),
153 _mean_extract(u3a_t(som), (len_w - cut_w), (prs_m + cut_w)));
154 }
155 }
156 }
157
158 c3_o
u3r_mean(u3_noun som,...)159 u3r_mean(u3_noun som,
160 ...)
161 {
162 va_list ap;
163 c3_w len_w;
164 struct _mean_pair* prs_m;
165
166 c3_assert(u3_none != som);
167
168 /* Count.
169 */
170 len_w = 0;
171 {
172 va_start(ap, som);
173 while ( 1 ) {
174 if ( 0 == va_arg(ap, c3_w) ) {
175 break;
176 }
177 va_arg(ap, u3_noun*);
178 len_w++;
179 }
180 va_end(ap);
181 }
182 prs_m = alloca(len_w * sizeof(struct _mean_pair));
183
184 /* Install.
185 */
186 {
187 c3_w i_w;
188
189 va_start(ap, som);
190 for ( i_w = 0; i_w < len_w; i_w++ ) {
191 prs_m[i_w].axe_w = va_arg(ap, c3_w);
192 prs_m[i_w].som = va_arg(ap, u3_noun*);
193 }
194 va_end(ap);
195 }
196
197 /* Extract.
198 */
199 return _mean_extract(som, len_w, prs_m);
200 }
201
202 static __inline__ c3_w
_mug_fnv(c3_w has_w)203 _mug_fnv(c3_w has_w)
204 {
205 return (has_w * ((c3_w)16777619));
206 }
207
208 static __inline__ c3_w
_mug_out(c3_w has_w)209 _mug_out(c3_w has_w)
210 {
211 return (has_w >> 31) ^ (has_w & 0x7fffffff);
212 }
213
214 static __inline__ c3_w
_mug_both(c3_w lef_w,c3_w rit_w)215 _mug_both(c3_w lef_w, c3_w rit_w)
216 {
217 c3_w bot_w = _mug_fnv(lef_w ^ _mug_fnv(rit_w));
218 c3_w out_w = _mug_out(bot_w);
219
220 if ( 0 != out_w ) {
221 return out_w;
222 }
223 else {
224 return _mug_both(lef_w, ++rit_w);
225 }
226 }
227
228 /* u3r_mug_both():
229 **
230 ** Join two mugs.
231 */
232 c3_w
u3r_mug_both(c3_w lef_w,c3_w rit_w)233 u3r_mug_both(c3_w lef_w, c3_w rit_w)
234 {
235 return _mug_both(lef_w, rit_w);
236 }
237
238 static __inline__ c3_w
_mug_bytes_in(c3_w off_w,c3_w nby_w,const c3_y * byt_y)239 _mug_bytes_in(c3_w off_w, c3_w nby_w, const c3_y* byt_y)
240 {
241 c3_w i_w;
242
243 for ( i_w = 0; i_w < nby_w; i_w++ ) {
244 off_w = _mug_fnv(off_w ^ byt_y[i_w]);
245 }
246 return off_w;
247 }
248
249 static c3_w
_mug_bytes(c3_w off_w,c3_w nby_w,const c3_y * byt_y)250 _mug_bytes(c3_w off_w, c3_w nby_w, const c3_y* byt_y)
251 {
252 c3_w has_w = _mug_bytes_in(off_w, nby_w, byt_y);
253 c3_w out_w = _mug_out(has_w);
254
255 if ( 0 != out_w ) {
256 return out_w;
257 }
258 else {
259 return _mug_bytes(++off_w, nby_w, byt_y);
260 }
261 }
262
263 static __inline__ c3_w
_mug_words_in(c3_w off_w,c3_w nwd_w,const c3_w * wod_w)264 _mug_words_in(c3_w off_w, c3_w nwd_w, const c3_w* wod_w)
265 {
266 if ( 0 == nwd_w ) {
267 return off_w;
268 } else {
269 c3_w i_w, x_w;
270
271 for ( i_w = 0; i_w < (nwd_w - 1); i_w++ ) {
272 x_w = wod_w[i_w];
273 {
274 c3_y a_y = (x_w & 0xff);
275 c3_y b_y = ((x_w >> 8) & 0xff);
276 c3_y c_y = ((x_w >> 16) & 0xff);
277 c3_y d_y = ((x_w >> 24) & 0xff);
278
279 off_w = _mug_fnv(off_w ^ a_y);
280 off_w = _mug_fnv(off_w ^ b_y);
281 off_w = _mug_fnv(off_w ^ c_y);
282 off_w = _mug_fnv(off_w ^ d_y);
283 }
284 }
285 x_w = wod_w[nwd_w - 1];
286
287 if ( x_w ) {
288 off_w = _mug_fnv(off_w ^ (x_w & 0xff));
289 x_w >>= 8;
290
291 if ( x_w ) {
292 off_w = _mug_fnv(off_w ^ (x_w & 0xff));
293 x_w >>= 8;
294
295 if ( x_w ) {
296 off_w = _mug_fnv(off_w ^ (x_w & 0xff));
297 x_w >>= 8;
298
299 if ( x_w ) {
300 off_w = _mug_fnv(off_w ^ (x_w & 0xff));
301 }
302 }
303 }
304 }
305 }
306 return off_w;
307 }
308
309 static c3_w
_mug_words(c3_w off_w,c3_w nwd_w,const c3_w * wod_w)310 _mug_words(c3_w off_w, c3_w nwd_w, const c3_w* wod_w)
311 {
312 c3_w has_w = _mug_words_in(off_w, nwd_w, wod_w);
313 c3_w out_w = _mug_out(has_w);
314
315 if ( 0 != out_w ) {
316 return out_w;
317 }
318 else {
319 return _mug_words(++off_w, nwd_w, wod_w);
320 }
321 }
322
323 /* u3r_mug():
324 **
325 ** Compute and/or recall the mug (31-bit FNV1a hash) of (a).
326 */
327 c3_w
u3r_mug(u3_noun veb)328 u3r_mug(u3_noun veb)
329 {
330 c3_assert(u3_none != veb);
331
332 if ( _(u3a_is_cat(veb)) ) {
333 c3_w x_w = veb;
334
335 return _mug_words(2166136261U, (veb ? 1 : 0), &x_w);
336 } else {
337 u3a_noun* veb_u = u3a_to_ptr(veb);
338
339 if ( veb_u->mug_w ) {
340 return veb_u->mug_w;
341 }
342 else {
343 if ( _(u3a_is_cell(veb)) ) {
344 u3a_cell* veb_u = u3a_to_ptr(veb);
345 u3_noun hed = veb_u->hed;
346 u3_noun tel = veb_u->tel;
347
348 veb_u->mug_w = u3r_mug_cell(hed, tel);
349 return veb_u->mug_w;
350 }
351 else {
352 u3a_atom* veb_u = u3a_to_ptr(veb);
353 c3_w len_w = veb_u->len_w;
354
355 veb_u->mug_w = _mug_words(2166136261U, len_w, veb_u->buf_w);
356 return veb_u->mug_w;
357 }
358 }
359 }
360 }
361
362 /* u3r_mug_words():
363 **
364 ** Compute the mug of `buf`, `len`, LSW first.
365 */
366 c3_w
u3r_mug_words(const c3_w * buf_w,c3_w len_w)367 u3r_mug_words(const c3_w *buf_w,
368 c3_w len_w)
369 {
370 return _mug_words(2166136261U, len_w, buf_w);
371 }
372
373 /* u3r_mug_d():
374 **
375 ** Compute the mug of `num`, LSW first.
376 */
377 c3_w
u3r_mug_d(c3_d num_d)378 u3r_mug_d(c3_d num_d)
379 {
380 c3_w buf_w[2];
381
382 buf_w[0] = (c3_w)(num_d & 0xffffffffULL);
383 buf_w[1] = (c3_w)(num_d >> 32ULL);
384
385 return u3r_mug_words(buf_w, 2);
386 }
387
388 /* u3r_mug_bytes():
389 **
390 ** Compute the mug of `buf`, `len`, LSW first.
391 */
392 c3_w
u3r_mug_bytes(const c3_y * buf_w,c3_w len_w)393 u3r_mug_bytes(const c3_y *buf_w,
394 c3_w len_w)
395 {
396 return _mug_bytes(2166136261U, len_w, buf_w);
397 }
398
399 /* u3r_mug_string():
400 **
401 ** Compute the mug of `a`, LSB first.
402 */
403 c3_w
u3r_mug_string(const c3_c * a_c)404 u3r_mug_string(const c3_c *a_c)
405 {
406 return _mug_bytes(2166136261U, strlen(a_c), (c3_y *)a_c);
407 }
408
409 /* u3r_mug_cell():
410 **
411 ** Compute the mug of the cell `[hed tel]`.
412 */
413 c3_w
u3r_mug_cell(u3_noun hed,u3_noun tel)414 u3r_mug_cell(u3_noun hed,
415 u3_noun tel)
416 {
417 c3_w lus_w = u3r_mug(hed);
418 c3_w biq_w = u3r_mug(tel);
419
420 return u3r_mug_both(lus_w, biq_w);
421 }
422
423 /* u3r_mug_trel():
424 **
425 ** Compute the mug of `[a b c]`.
426 */
427 c3_w
u3r_mug_trel(u3_noun a,u3_noun b,u3_noun c)428 u3r_mug_trel(u3_noun a,
429 u3_noun b,
430 u3_noun c)
431 {
432 return u3r_mug_both
433 (u3r_mug(a), u3r_mug_both(u3r_mug(b), u3r_mug(c)));
434 }
435
436 /* u3r_mug_qual():
437 **
438 ** Compute the mug of `[a b c d]`.
439 */
440 c3_w
u3r_mug_qual(u3_noun a,u3_noun b,u3_noun c,u3_noun d)441 u3r_mug_qual(u3_noun a,
442 u3_noun b,
443 u3_noun c,
444 u3_noun d)
445 {
446 return u3r_mug_both
447 (u3r_mug(a),
448 u3r_mug_both(u3r_mug(b),
449 u3r_mug_both(u3r_mug(c), u3r_mug(d))));
450 }
451
452 /* _sang_one(): unify but leak old.
453 */
454 static void
_sang_one(u3_noun * a,u3_noun * b)455 _sang_one(u3_noun* a, u3_noun* b)
456 {
457 if ( *a == *b ) {
458 return;
459 }
460 else {
461 c3_o asr_o = u3a_is_senior(u3R, *a);
462 c3_o bsr_o = u3a_is_senior(u3R, *b);
463
464 if ( _(asr_o) && _(bsr_o) ) {
465 // You shouldn't have let this happen. We don't want to
466 // descend down to a lower road and free there, because
467 // synchronization - though this could be revisited under
468 // certain circumstances.
469 //
470 return;
471 }
472 if ( _(asr_o) && !_(bsr_o) ){
473 // u3z(*b);
474 *b = *a;
475 }
476 if ( _(bsr_o) && !_(asr_o) ) {
477 // u3z(*a);
478 *a = *b;
479 }
480 if ( u3a_is_north(u3R) ) {
481 if ( *a <= *b ) {
482 u3k(*a);
483 // u3z(*b);
484 *b = *a;
485 } else {
486 u3k(*b);
487 // u3z(*a);
488 *a = *b;
489 }
490 }
491 else {
492 if ( *a >= *b ) {
493 u3k(*a);
494 // u3z(*b);
495 *b = *a;
496 } else {
497 u3k(*b);
498 // u3z(*a);
499 *a = *b;
500 }
501 }
502 }
503 }
504
505 #define SONG_NONE 0
506 #define SONG_HEAD 1
507 #define SONG_TAIL 2
508
509 typedef struct {
510 c3_y sat_y;
511 u3_noun a;
512 u3_noun b;
513 } eqframe;
514
515 static inline eqframe*
_eq_push(c3_ys mov,c3_ys off,u3_noun a,u3_noun b)516 _eq_push(c3_ys mov, c3_ys off, u3_noun a, u3_noun b)
517 {
518 u3R->cap_p += mov;
519 eqframe* cur = u3to(eqframe, u3R->cap_p + off);
520 cur->sat_y = SONG_NONE;
521 cur->a = a;
522 cur->b = b;
523 return cur;
524 }
525
526 static inline eqframe*
_eq_pop(c3_ys mov,c3_ys off)527 _eq_pop(c3_ys mov, c3_ys off)
528 {
529 u3R->cap_p -= mov;
530 return u3to(eqframe, u3R->cap_p + off);
531 }
532
533 /* _sing_one(): do not pick a unified pointer for identical (a) and (b).
534 */
535 static void
_sing_one(u3_noun * a,u3_noun * b)536 _sing_one(u3_noun* a, u3_noun* b)
537 {
538 // this space left intentionally blank
539 }
540
541 /* _sung_one(): pick a unified pointer for identical (a) and (b).
542 **
543 ** Assumes exclusive access to noun memory.
544 */
545 static void
_sung_one(u3_noun * a,u3_noun * b)546 _sung_one(u3_noun* a, u3_noun* b)
547 {
548
549 if ( *a == *b ) {
550 return;
551 } else {
552 u3_road* rod_u = u3R;
553 while ( 1 ) {
554 //
555 // we can't perform this kind of butchery on the home road,
556 // where asynchronous things can allocate.
557 //
558 if ( u3R == &u3H->rod_u ) {
559 break;
560 }
561 else {
562 c3_o asr_o = u3a_is_senior(u3R, *a);
563 c3_o bsr_o = u3a_is_senior(u3R, *b);
564
565 if ( _(asr_o) && _(bsr_o) ) {
566 //
567 // when unifying on a higher road, we can't free nouns,
568 // because we can't track junior nouns that point into
569 // that road.
570 //
571 // this is just an implementation issue -- we could set use
572 // counts to 0 without actually freeing. but the allocator
573 // would have to be actually designed for this.
574 //
575 // not freeing may generate spurious leaks, so we disable
576 // senior unification when debugging memory. this will
577 // cause a very slow boot process as the compiler compiles
578 // itself, constantly running into duplicates.
579 //
580 #ifdef U3_MEMORY_DEBUG
581 return;
582 #else
583 u3R = u3to(u3_road, u3R->par_p);
584 continue;
585 #endif
586 }
587
588 if ( _(asr_o) && !_(bsr_o) ){
589 if ( u3R == rod_u ) { u3z(*b); }
590 *b = *a;
591 }
592 if ( _(bsr_o) && !_(asr_o) ) {
593 if ( u3R == rod_u ) { u3z(*a); }
594 *a = *b;
595 }
596 if ( u3a_is_north(u3R) ) {
597 if ( *a <= *b ) {
598 u3k(*a);
599 if ( u3R == rod_u ) { u3z(*b); }
600 *b = *a;
601 } else {
602 u3k(*b);
603 if ( u3R == rod_u ) { u3z(*a); }
604 *a = *b;
605 }
606 }
607 else {
608 if ( *a >= *b ) {
609 u3k(*a);
610 if ( u3R == rod_u ) { u3z(*b); }
611 *b = *a;
612 } else {
613 u3k(*b);
614 if ( u3R == rod_u ) { u3z(*a); }
615 *a = *b;
616 }
617 }
618 break;
619 }
620 }
621 u3R = rod_u;
622 }
623 }
624
625 static inline c3_o
_song_atom(u3_atom a,u3_atom b)626 _song_atom(u3_atom a, u3_atom b)
627 {
628 u3a_atom* a_u = u3a_to_ptr(a);
629
630 if ( !_(u3a_is_atom(b)) ||
631 _(u3a_is_cat(a)) ||
632 _(u3a_is_cat(b)) )
633 {
634 return c3n;
635 }
636 else {
637 u3a_atom* b_u = u3a_to_ptr(b);
638
639 if ( a_u->mug_w &&
640 b_u->mug_w &&
641 (a_u->mug_w != b_u->mug_w) )
642 {
643 return c3n;
644 }
645 else {
646 c3_w w_rez = a_u->len_w;
647 c3_w w_mox = b_u->len_w;
648
649 if ( w_rez != w_mox ) {
650 return c3n;
651 }
652 else {
653 c3_w i_w;
654
655 for ( i_w = 0; i_w < w_rez; i_w++ ) {
656 if ( a_u->buf_w[i_w] != b_u->buf_w[i_w] ) {
657 return c3n;
658 }
659 }
660 }
661 }
662 }
663 return c3y;
664 }
665
666 /* _song_x_cape(): unifying equality with comparison deduplication
667 * (tightly coupled to _song_x)
668 */
669 static c3_o
_song_x_cape(c3_ys mov,c3_ys off,eqframe * fam,eqframe * don,u3p (u3h_root)har_p,void (* uni)(u3_noun *,u3_noun *))670 _song_x_cape(c3_ys mov, c3_ys off,
671 eqframe* fam, eqframe* don,
672 u3p(u3h_root) har_p,
673 void (*uni)(u3_noun*, u3_noun*))
674 {
675 u3_noun a, b, key;
676 u3_weak got;
677 u3a_cell* a_u;
678 u3a_cell* b_u;
679
680 while ( don != fam ) {
681 a = fam->a;
682 b = fam->b;
683 switch ( fam->sat_y ) {
684 case SONG_NONE:
685 if ( a == b ) {
686 break;
687 }
688 else if ( c3y == u3a_is_atom(a) ) {
689 if ( c3n == _song_atom(a, b) ) {
690 return c3n;
691 }
692 else {
693 break;
694 }
695 }
696 else if ( c3y == u3a_is_atom(b) ) {
697 return c3n;
698 }
699 else {
700 u3a_cell* a_u = u3a_to_ptr(a);
701 u3a_cell* b_u = u3a_to_ptr(b);
702
703 if ( a_u->mug_w &&
704 b_u->mug_w &&
705 (a_u->mug_w != b_u->mug_w) ) {
706 return c3n;
707 }
708 else {
709 key = u3nc(u3a_to_off(a), u3a_to_off(b));
710 u3t_off(euq_o);
711 got = u3h_get(har_p, key);
712 u3t_on(euq_o);
713 u3z(key);
714 if ( u3_none != got ) {
715 fam = _eq_pop(mov, off);
716 continue;
717 }
718 fam->sat_y = SONG_HEAD;
719 fam = _eq_push(mov, off, a_u->hed, b_u->hed);
720 continue;
721 }
722 }
723
724 case SONG_HEAD:
725 a_u = u3a_to_ptr(a);
726 b_u = u3a_to_ptr(b);
727 uni(&(a_u->hed), &(b_u->hed));
728 fam->sat_y = SONG_TAIL;
729 fam = _eq_push(mov, off, a_u->tel, b_u->tel);
730 continue;
731
732 case SONG_TAIL:
733 a_u = u3a_to_ptr(a);
734 b_u = u3a_to_ptr(b);
735 uni(&(a_u->tel), &(b_u->tel));
736 break;
737
738 default:
739 c3_assert(0);
740 break;
741 }
742
743 key = u3nc(u3a_to_off(a), u3a_to_off(b));
744 u3t_off(euq_o);
745 u3h_put(har_p, key, c3y);
746 u3t_on(euq_o);
747 u3z(key);
748 fam = _eq_pop(mov, off);
749 }
750
751 return c3y;
752 }
753
754 /* _song_x(): yes if a and b are the same noun, use uni to unify
755 */
756 static c3_o
_song_x(u3_noun a,u3_noun b,void (* uni)(u3_noun *,u3_noun *))757 _song_x(u3_noun a, u3_noun b, void (*uni)(u3_noun*, u3_noun*))
758 {
759 u3p(eqframe) empty = u3R->cap_p;
760
761 c3_y wis_y = c3_wiseof(eqframe);
762 c3_o nor_o = u3a_is_north(u3R);
763 c3_ys mov = ( c3y == nor_o ? -wis_y : wis_y );
764 c3_ys off = ( c3y == nor_o ? 0 : -wis_y );
765 c3_s ovr_s = 0;
766 eqframe* fam = _eq_push(mov, off, a, b);
767 eqframe* don = u3to(eqframe, empty + off);
768
769 u3a_cell* a_u;
770 u3a_cell* b_u;
771
772 while ( don != fam ) {
773 a = fam->a;
774 b = fam->b;
775 switch ( fam->sat_y ) {
776 case SONG_NONE:
777 if ( a == b ) {
778 break;
779 }
780 else if ( c3y == u3a_is_atom(a) ) {
781 if ( c3n == _song_atom(a, b) ) {
782 u3R->cap_p = empty;
783 return c3n;
784 }
785 else {
786 break;
787 }
788 }
789 else if ( c3y == u3a_is_atom(b) ) {
790 u3R->cap_p = empty;
791 return c3n;
792 }
793 else {
794 a_u = u3a_to_ptr(a);
795 b_u = u3a_to_ptr(b);
796
797 if ( a_u->mug_w &&
798 b_u->mug_w &&
799 (a_u->mug_w != b_u->mug_w) ) {
800 u3R->cap_p = empty;
801 return c3n;
802 }
803 else {
804 fam->sat_y = SONG_HEAD;
805 fam = _eq_push(mov, off, a_u->hed, b_u->hed);
806 continue;
807 }
808 }
809
810 case SONG_HEAD:
811 a_u = u3a_to_ptr(a);
812 b_u = u3a_to_ptr(b);
813 uni(&(a_u->hed), &(b_u->hed));
814 fam->sat_y = SONG_TAIL;
815 fam = _eq_push(mov, off, a_u->tel, b_u->tel);
816 continue;
817
818 case SONG_TAIL:
819 a_u = u3a_to_ptr(a);
820 b_u = u3a_to_ptr(b);
821 uni(&(a_u->tel), &(b_u->tel));
822 break;
823
824 default:
825 c3_assert(0);
826 break;
827 }
828
829 if ( 0 == ++ovr_s ) {
830 u3p(u3h_root) har_p = u3h_new();
831 c3_o ret_o = _song_x_cape(mov, off, fam, don, har_p, uni);
832 u3h_free(har_p);
833 u3R->cap_p = empty;
834 return ret_o;
835 }
836 fam = _eq_pop(mov, off);
837 }
838
839 return c3y;
840 }
841
842 /* u3r_sang(): yes iff (a) and (b) are the same noun, unifying equals.
843 */
844 c3_o
u3r_sang(u3_noun a,u3_noun b)845 u3r_sang(u3_noun a, u3_noun b)
846 {
847 c3_o ret_o;
848 u3t_on(euq_o);
849 ret_o = _song_x(a, b, &_sang_one);
850 u3t_off(euq_o);
851 return ret_o;
852 }
853
854 /* u3r_sing():
855 **
856 ** Yes iff (a) and (b) are the same noun.
857 */
858 c3_o
u3r_sing(u3_noun a,u3_noun b)859 u3r_sing(u3_noun a, u3_noun b)
860 {
861 #ifndef U3_MEMORY_DEBUG
862 if ( u3R->par_p ) {
863 return u3r_sang(a, b);
864 }
865 #endif
866 {
867 c3_o ret_o;
868
869 u3t_on(euq_o);
870 ret_o = _song_x(a, b, &_sing_one);
871 u3t_off(euq_o);
872
873 return ret_o;
874 }
875 }
876
877 /* u3r_sung(): yes iff (a) and (b) are the same noun, unifying equals.
878 */
879 c3_o
u3r_sung(u3_noun a,u3_noun b)880 u3r_sung(u3_noun a, u3_noun b)
881 {
882 c3_o ret_o;
883 u3t_on(euq_o);
884 ret_o = _song_x(a, b, &_sung_one);
885 u3t_off(euq_o);
886 return ret_o;
887 }
888
889 c3_o
u3r_fing(u3_noun a,u3_noun b)890 u3r_fing(u3_noun a,
891 u3_noun b)
892 {
893 return (a == b) ? c3y : c3n;
894 }
895
896 /* u3r_sing_cell():
897 **
898 ** Yes iff `[p q]` and `b` are the same noun.
899 */
900 c3_o
u3r_sing_cell(u3_noun p,u3_noun q,u3_noun b)901 u3r_sing_cell(u3_noun p,
902 u3_noun q,
903 u3_noun b)
904 {
905 return c3a(_(u3a_is_cell(b)),
906 c3a(u3r_sing(p, u3a_h(b)),
907 u3r_sing(q, u3a_t(b))));
908 }
909 c3_o
u3r_fing_cell(u3_noun p,u3_noun q,u3_noun b)910 u3r_fing_cell(u3_noun p,
911 u3_noun q,
912 u3_noun b)
913 {
914 return c3a(_(u3a_is_cell(b)),
915 c3a(u3r_fing(p, u3a_h(b)),
916 u3r_fing(q, u3a_t(b))));
917 }
918
919 /* u3r_sing_mixt():
920 **
921 ** Yes iff `[p q]` and `b` are the same noun.
922 */
923 c3_o
u3r_sing_mixt(const c3_c * p_c,u3_noun q,u3_noun b)924 u3r_sing_mixt(const c3_c* p_c,
925 u3_noun q,
926 u3_noun b)
927 {
928 return c3a(_(u3a_is_cell(b)),
929 c3a(u3r_sing_c(p_c, u3a_h(b)),
930 u3r_sing(q, u3a_t(b))));
931 }
932 c3_o
u3r_fing_mixt(const c3_c * p_c,u3_noun q,u3_noun b)933 u3r_fing_mixt(const c3_c* p_c,
934 u3_noun q,
935 u3_noun b)
936 {
937 return c3a(_(u3a_is_cell(b)),
938 c3a(u3r_sing_c(p_c, u3a_h(b)),
939 u3r_fing(q, u3a_t(b))));
940 }
941
942 /* u3r_sing_trel():
943 **
944 ** Yes iff `[p q r]` and `b` are the same noun.
945 */
946 c3_o
u3r_sing_trel(u3_noun p,u3_noun q,u3_noun r,u3_noun b)947 u3r_sing_trel(u3_noun p,
948 u3_noun q,
949 u3_noun r,
950 u3_noun b)
951 {
952 return c3a(_(u3a_is_cell(b)),
953 c3a(u3r_sing(p, u3a_h(b)),
954 u3r_sing_cell(q, r, u3a_t(b))));
955 }
956 c3_o
u3r_fing_trel(u3_noun p,u3_noun q,u3_noun r,u3_noun b)957 u3r_fing_trel(u3_noun p,
958 u3_noun q,
959 u3_noun r,
960 u3_noun b)
961 {
962 return c3a(_(u3a_is_cell(b)),
963 c3a(u3r_fing(p, u3a_h(b)),
964 u3r_fing_cell(q, r, u3a_t(b))));
965 }
966
967 /* u3r_sing_qual():
968 **
969 ** Yes iff `[p q r]` and `b` are the same noun.
970 */
971 c3_o
u3r_sing_qual(u3_noun p,u3_noun q,u3_noun r,u3_noun s,u3_noun b)972 u3r_sing_qual(u3_noun p,
973 u3_noun q,
974 u3_noun r,
975 u3_noun s,
976 u3_noun b)
977 {
978 return c3a(_(u3a_is_cell(b)),
979 c3a(u3r_sing(p, u3a_h(b)),
980 u3r_sing_trel(q, r, s, u3a_t(b))));
981 }
982 c3_o
u3r_fing_qual(u3_noun p,u3_noun q,u3_noun r,u3_noun s,u3_noun b)983 u3r_fing_qual(u3_noun p,
984 u3_noun q,
985 u3_noun r,
986 u3_noun s,
987 u3_noun b)
988 {
989 return c3a(_(u3a_is_cell(b)),
990 c3a(u3r_fing(p, u3a_h(b)),
991 u3r_fing_trel(q, r, s, u3a_t(b))));
992 }
993
994 /* u3r_nord():
995 **
996 ** Return 0, 1 or 2 if `a` is below, equal to, or above `b`.
997 */
998 u3_atom
u3r_nord(u3_noun a,u3_noun b)999 u3r_nord(u3_noun a,
1000 u3_noun b)
1001 {
1002 c3_assert(u3_none != a);
1003 c3_assert(u3_none != b);
1004
1005 if ( a == b ) {
1006 return 1;
1007 }
1008 else {
1009 if ( _(u3a_is_atom(a)) ) {
1010 if ( !_(u3a_is_atom(b)) ) {
1011 return 0;
1012 } else {
1013 if ( _(u3a_is_cat(a)) ) {
1014 if ( _(u3a_is_cat(b)) ) {
1015 return (a < b) ? 0 : 2;
1016 }
1017 else return 0;
1018 }
1019 else if ( _(u3a_is_cat(b)) ) {
1020 return 2;
1021 }
1022 else {
1023 u3a_atom* a_u = u3a_to_ptr(a);
1024 u3a_atom* b_u = u3a_to_ptr(b);
1025
1026 c3_w w_rez = a_u->len_w;
1027 c3_w w_mox = b_u->len_w;
1028
1029 if ( w_rez != w_mox ) {
1030 return (w_rez < w_mox) ? 0 : 2;
1031 }
1032 else {
1033 c3_w i_w;
1034
1035 for ( i_w = 0; i_w < w_rez; i_w++ ) {
1036 c3_w ai_w = a_u->buf_w[i_w];
1037 c3_w bi_w = b_u->buf_w[i_w];
1038
1039 if ( ai_w != bi_w ) {
1040 return (ai_w < bi_w) ? 0 : 2;
1041 }
1042 }
1043 return 1;
1044 }
1045 }
1046 }
1047 } else {
1048 if ( _(u3a_is_atom(b)) ) {
1049 return 2;
1050 } else {
1051 u3_atom c = u3r_nord(u3a_h(a), u3a_h(b));
1052
1053 if ( 1 == c ) {
1054 return u3r_nord(u3a_t(a), u3a_t(b));
1055 } else {
1056 return c;
1057 }
1058 }
1059 }
1060 }
1061 }
1062
1063 /* u3r_sing_c():
1064 **
1065 ** Yes iff (b) is the same noun as the C string a_c.
1066 */
1067 c3_o
u3r_sing_c(const c3_c * a_c,u3_noun b)1068 u3r_sing_c(const c3_c* a_c,
1069 u3_noun b)
1070 {
1071 c3_assert(u3_none != b);
1072
1073 if ( !_(u3a_is_atom(b)) ) {
1074 return c3n;
1075 }
1076 else {
1077 c3_w w_sof = strlen(a_c);
1078 c3_w i_w;
1079
1080 if ( w_sof != u3r_met(3, b) ) {
1081 return c3n;
1082 }
1083 for ( i_w = 0; i_w < w_sof; i_w++ ) {
1084 if ( u3r_byte(i_w, b) != a_c[i_w] ) {
1085 return c3n;
1086 }
1087 }
1088 return c3y;
1089 }
1090 }
1091
1092 /* u3r_bush():
1093 **
1094 ** Factor [a] as a bush [b.[p q] c].
1095 */
1096 c3_o
u3r_bush(u3_noun a,u3_noun * b,u3_noun * c)1097 u3r_bush(u3_noun a,
1098 u3_noun* b,
1099 u3_noun* c)
1100 {
1101 c3_assert(u3_none != a);
1102
1103 if ( _(u3a_is_atom(a)) ) {
1104 return c3n;
1105 }
1106 else {
1107 *b = u3a_h(a);
1108
1109 if ( _(u3a_is_atom(*b)) ) {
1110 return c3n;
1111 } else {
1112 *c = u3a_t(a);
1113 return c3y;
1114 }
1115 }
1116 }
1117
1118 /* u3r_cell():
1119 **
1120 ** Factor (a) as a cell (b c).
1121 */
1122 c3_o
u3r_cell(u3_noun a,u3_noun * b,u3_noun * c)1123 u3r_cell(u3_noun a,
1124 u3_noun* b,
1125 u3_noun* c)
1126 {
1127 c3_assert(u3_none != a);
1128
1129 if ( _(u3a_is_atom(a)) ) {
1130 return c3n;
1131 }
1132 else {
1133 if ( b ) *b = u3a_h(a);
1134 if ( c ) *c = u3a_t(a);
1135 return c3y;
1136 }
1137 }
1138
1139 /* u3r_p():
1140 **
1141 ** & [0] if [a] is of the form [b *c].
1142 */
1143 c3_o
u3r_p(u3_noun a,u3_noun b,u3_noun * c)1144 u3r_p(u3_noun a,
1145 u3_noun b,
1146 u3_noun* c)
1147 {
1148 u3_noun feg, nux;
1149
1150 if ( (c3y == u3r_cell(a, &feg, &nux)) &&
1151 (c3y == u3r_sing(feg, b)) )
1152 {
1153 *c = nux;
1154 return c3y;
1155 }
1156 else return c3n;
1157 }
1158
1159 /* u3r_pq():
1160 **
1161 ** & [0] if [a] is of the form [b *c d].
1162 */
1163 c3_o
u3r_pq(u3_noun a,u3_noun b,u3_noun * c,u3_noun * d)1164 u3r_pq(u3_noun a,
1165 u3_noun b,
1166 u3_noun* c,
1167 u3_noun* d)
1168 {
1169 u3_noun nux;
1170
1171 if ( (c3y == u3r_p(a, b, &nux)) &&
1172 (c3y == u3r_cell(nux, c, d)) )
1173 {
1174 return c3y;
1175 }
1176 else return c3n;
1177 }
1178
1179 /* u3r_pqr():
1180 **
1181 ** & [0] if [a] is of the form [b *c *d *e].
1182 */
1183 c3_o
u3r_pqr(u3_noun a,u3_noun b,u3_noun * c,u3_noun * d,u3_noun * e)1184 u3r_pqr(u3_noun a,
1185 u3_noun b,
1186 u3_noun* c,
1187 u3_noun* d,
1188 u3_noun* e)
1189 {
1190 u3_noun nux;
1191
1192 if ( (c3y == u3r_p(a, b, &nux)) &&
1193 (c3y == u3r_trel(nux, c, d, e)) )
1194 {
1195 return c3y;
1196 }
1197 else return c3n;
1198 }
1199
1200 /* u3r_pqrs():
1201 **
1202 ** & [0] if [a] is of the form [b *c *d *e *f].
1203 */
1204 c3_o
u3r_pqrs(u3_noun a,u3_noun b,u3_noun * c,u3_noun * d,u3_noun * e,u3_noun * f)1205 u3r_pqrs(u3_noun a,
1206 u3_noun b,
1207 u3_noun* c,
1208 u3_noun* d,
1209 u3_noun* e,
1210 u3_noun* f)
1211 {
1212 u3_noun nux;
1213
1214 if ( (c3y == u3r_p(a, b, &nux)) &&
1215 (c3y == u3r_qual(nux, c, d, e, f)) )
1216 {
1217 return c3y;
1218 }
1219 else return c3n;
1220 }
1221
1222 /* u3r_trel():
1223 **
1224 ** Factor (a) as a trel (b c d).
1225 */
1226 c3_o
u3r_trel(u3_noun a,u3_noun * b,u3_noun * c,u3_noun * d)1227 u3r_trel(u3_noun a,
1228 u3_noun *b,
1229 u3_noun *c,
1230 u3_noun *d)
1231 {
1232 u3_noun guf;
1233
1234 if ( (c3y == u3r_cell(a, b, &guf)) &&
1235 (c3y == u3r_cell(guf, c, d)) ) {
1236 return c3y;
1237 }
1238 else {
1239 return c3n;
1240 }
1241 }
1242
1243 /* u3r_qual():
1244 **
1245 ** Factor (a) as a qual (b c d e).
1246 */
1247 c3_o
u3r_qual(u3_noun a,u3_noun * b,u3_noun * c,u3_noun * d,u3_noun * e)1248 u3r_qual(u3_noun a,
1249 u3_noun* b,
1250 u3_noun* c,
1251 u3_noun* d,
1252 u3_noun* e)
1253 {
1254 u3_noun guf;
1255
1256 if ( (c3y == u3r_cell(a, b, &guf)) &&
1257 (c3y == u3r_trel(guf, c, d, e)) ) {
1258 return c3y;
1259 }
1260 else return c3n;
1261 }
1262
1263 /* u3r_quil():
1264 **
1265 ** Factor (a) as a quil (b c d e f).
1266 */
1267 c3_o
u3r_quil(u3_noun a,u3_noun * b,u3_noun * c,u3_noun * d,u3_noun * e,u3_noun * f)1268 u3r_quil(u3_noun a,
1269 u3_noun* b,
1270 u3_noun* c,
1271 u3_noun* d,
1272 u3_noun* e,
1273 u3_noun* f)
1274 {
1275 u3_noun guf;
1276
1277 if ( (c3y == u3r_cell(a, b, &guf)) &&
1278 (c3y == u3r_qual(guf, c, d, e, f)) ) {
1279 return c3y;
1280 }
1281 else return c3n;
1282 }
1283
1284 /* u3r_hext():
1285 **
1286 ** Factor (a) as a hext (b c d e f g)
1287 */
1288 c3_o
u3r_hext(u3_noun a,u3_noun * b,u3_noun * c,u3_noun * d,u3_noun * e,u3_noun * f,u3_noun * g)1289 u3r_hext(u3_noun a,
1290 u3_noun* b,
1291 u3_noun* c,
1292 u3_noun* d,
1293 u3_noun* e,
1294 u3_noun* f,
1295 u3_noun* g)
1296 {
1297 u3_noun guf;
1298
1299 if ( (c3y == u3r_cell(a, b, &guf)) &&
1300 (c3y == u3r_quil(guf, c, d, e, f, g)) ) {
1301 return c3y;
1302 }
1303 else return c3n;
1304 }
1305
1306 /* u3r_met():
1307 **
1308 ** Return the size of (b) in bits, rounded up to
1309 ** (1 << a_y).
1310 **
1311 ** For example, (a_y == 3) returns the size in bytes.
1312 */
1313 c3_w
u3r_met(c3_y a_y,u3_atom b)1314 u3r_met(c3_y a_y,
1315 u3_atom b)
1316 {
1317 c3_assert(u3_none != b);
1318 c3_assert(_(u3a_is_atom(b)));
1319
1320 if ( b == 0 ) {
1321 return 0;
1322 }
1323 else {
1324 /* gal_w: number of words besides (daz_w) in (b).
1325 ** daz_w: top word in (b).
1326 */
1327 c3_w gal_w;
1328 c3_w daz_w;
1329
1330 if ( _(u3a_is_cat(b)) ) {
1331 gal_w = 0;
1332 daz_w = b;
1333 }
1334 else {
1335 u3a_atom* b_u = u3a_to_ptr(b);
1336
1337 gal_w = (b_u->len_w) - 1;
1338 daz_w = b_u->buf_w[gal_w];
1339 }
1340
1341 switch ( a_y ) {
1342 case 0:
1343 case 1:
1344 case 2: {
1345 /* col_w: number of bits in (daz_w)
1346 ** bif_w: number of bits in (b)
1347 */
1348 c3_w bif_w, col_w;
1349
1350 col_w = c3_bits_word(daz_w);
1351 bif_w = col_w + (gal_w << 5);
1352
1353 return (bif_w + ((1 << a_y) - 1)) >> a_y;
1354 }
1355 case 3: {
1356 return (gal_w << 2)
1357 + ((daz_w >> 24) ? 4 : (daz_w >> 16) ? 3 : (daz_w >> 8) ? 2 : 1);
1358 }
1359 case 4: {
1360 return (gal_w << 1)
1361 + ((daz_w >> 16) ? 2 : 1);
1362 }
1363 default: {
1364 c3_y gow_y = (a_y - 5);
1365
1366 return ((gal_w + 1) + ((1 << gow_y) - 1)) >> gow_y;
1367 }
1368 }
1369 }
1370 }
1371
1372 /* u3r_bit():
1373 **
1374 ** Return bit (a_w) of (b).
1375 */
1376 c3_b
u3r_bit(c3_w a_w,u3_atom b)1377 u3r_bit(c3_w a_w,
1378 u3_atom b)
1379 {
1380 c3_assert(u3_none != b);
1381 c3_assert(_(u3a_is_atom(b)));
1382
1383 if ( _(u3a_is_cat(b)) ) {
1384 if ( a_w >= 31 ) {
1385 return 0;
1386 }
1387 else return (1 & (b >> a_w));
1388 }
1389 else {
1390 u3a_atom* b_u = u3a_to_ptr(b);
1391 c3_y vut_y = (a_w & 31);
1392 c3_w pix_w = (a_w >> 5);
1393
1394 if ( pix_w >= b_u->len_w ) {
1395 return 0;
1396 }
1397 else {
1398 c3_w nys_w = b_u->buf_w[pix_w];
1399
1400 return (1 & (nys_w >> vut_y));
1401 }
1402 }
1403 }
1404
1405 /* u3r_byte():
1406 **
1407 ** Return byte (a_w) of (b).
1408 */
1409 c3_y
u3r_byte(c3_w a_w,u3_atom b)1410 u3r_byte(c3_w a_w,
1411 u3_atom b)
1412 {
1413 c3_assert(u3_none != b);
1414 c3_assert(_(u3a_is_atom(b)));
1415
1416 if ( _(u3a_is_cat(b)) ) {
1417 if ( a_w > 3 ) {
1418 return 0;
1419 }
1420 else return (255 & (b >> (a_w << 3)));
1421 }
1422 else {
1423 u3a_atom* b_u = u3a_to_ptr(b);
1424 c3_y vut_y = (a_w & 3);
1425 c3_w pix_w = (a_w >> 2);
1426
1427 if ( pix_w >= b_u->len_w ) {
1428 return 0;
1429 }
1430 else {
1431 c3_w nys_w = b_u->buf_w[pix_w];
1432
1433 return (255 & (nys_w >> (vut_y << 3)));
1434 }
1435 }
1436 }
1437
1438 /* u3r_bytes():
1439 **
1440 ** Copy bytes (a_w) through (a_w + b_w - 1) from (d) to (c).
1441 */
1442 void
u3r_bytes(c3_w a_w,c3_w b_w,c3_y * c_y,u3_atom d)1443 u3r_bytes(c3_w a_w,
1444 c3_w b_w,
1445 c3_y* c_y,
1446 u3_atom d)
1447 {
1448 c3_assert(u3_none != d);
1449 c3_assert(_(u3a_is_atom(d)));
1450
1451 if ( _(u3a_is_cat(d)) ) {
1452 c3_w e_w = d >> (c3_min(a_w, 4) << 3);
1453 c3_w m_w = c3_min(b_w, 4);
1454 memcpy(c_y, (c3_y*)&e_w, m_w);
1455 if ( b_w > 4 ) {
1456 memset(c_y + 4, 0, b_w - 4);
1457 }
1458 }
1459 else {
1460 u3a_atom* d_u = u3a_to_ptr(d);
1461 c3_w n_w = d_u->len_w << 2;
1462 c3_y* x_y = (c3_y*)d_u->buf_w + a_w;
1463
1464 if ( a_w >= n_w ) {
1465 memset(c_y, 0, b_w);
1466 }
1467 else {
1468 c3_w z_w = c3_min(b_w, n_w - a_w);
1469 memcpy(c_y, x_y, z_w);
1470 if ( b_w > n_w - a_w ) {
1471 memset(c_y + z_w, 0, b_w + a_w - n_w);
1472 }
1473 }
1474 }
1475 }
1476
1477 /* u3r_mp():
1478 **
1479 ** Copy (b) into (a_mp).
1480 */
1481 void
u3r_mp(mpz_t a_mp,u3_atom b)1482 u3r_mp(mpz_t a_mp,
1483 u3_atom b)
1484 {
1485 c3_assert(u3_none != b);
1486 c3_assert(_(u3a_is_atom(b)));
1487
1488 if ( _(u3a_is_cat(b)) ) {
1489 mpz_init_set_ui(a_mp, b);
1490 }
1491 else {
1492 u3a_atom* b_u = u3a_to_ptr(b);
1493 c3_w len_w = b_u->len_w;
1494
1495 /* Slight deficiency in the GMP API.
1496 */
1497 c3_assert(!(len_w >> 27));
1498 mpz_init2(a_mp, len_w << 5);
1499
1500 /* Efficiency: horrible.
1501 */
1502 {
1503 c3_w *buf_w = alloca(len_w << 2);
1504 c3_w i_w;
1505
1506 for ( i_w=0; i_w < len_w; i_w++ ) {
1507 buf_w[i_w] = b_u->buf_w[i_w];
1508 }
1509 mpz_import(a_mp, len_w, -1, 4, 0, 0, buf_w);
1510 }
1511 }
1512 }
1513
1514 /* u3r_word():
1515 **
1516 ** Return word (a_w) of (b).
1517 */
1518 c3_w
u3r_word(c3_w a_w,u3_atom b)1519 u3r_word(c3_w a_w,
1520 u3_atom b)
1521 {
1522 c3_assert(u3_none != b);
1523 c3_assert(_(u3a_is_atom(b)));
1524
1525 if ( _(u3a_is_cat(b)) ) {
1526 if ( a_w > 0 ) {
1527 return 0;
1528 }
1529 else return b;
1530 }
1531 else {
1532 u3a_atom* b_u = u3a_to_ptr(b);
1533
1534 if ( a_w >= b_u->len_w ) {
1535 return 0;
1536 }
1537 else return b_u->buf_w[a_w];
1538 }
1539 }
1540
1541 /* u3r_chub():
1542 **
1543 ** Return double-word (a_w) of (b).
1544 */
1545 c3_d
u3r_chub(c3_w a_w,u3_atom b)1546 u3r_chub(c3_w a_w,
1547 u3_atom b)
1548 {
1549 c3_w wlo_w = u3r_word(a_w * 2, b);
1550 c3_w whi_w = u3r_word(1 + (a_w * 2), b);
1551
1552 return (((uint64_t)whi_w) << 32ULL) | ((uint64_t)wlo_w);
1553 }
1554
1555 /* u3r_words():
1556 **
1557 ** Copy words (a_w) through (a_w + b_w - 1) from (d) to (c).
1558 */
1559 void
u3r_words(c3_w a_w,c3_w b_w,c3_w * c_w,u3_atom d)1560 u3r_words(c3_w a_w,
1561 c3_w b_w,
1562 c3_w* c_w,
1563 u3_atom d)
1564 {
1565 c3_assert(u3_none != d);
1566 c3_assert(_(u3a_is_atom(d)));
1567
1568 if ( b_w == 0 ) {
1569 return;
1570 }
1571 if ( _(u3a_is_cat(d)) ) {
1572 if ( a_w == 0 ) {
1573 *c_w = d;
1574 memset((c3_y*)(c_w + 1), 0, (b_w - 1) << 2);
1575 }
1576 else {
1577 memset((c3_y*)c_w, 0, b_w << 2);
1578 }
1579 }
1580 else {
1581 u3a_atom* d_u = u3a_to_ptr(d);
1582 if ( a_w >= d_u->len_w ) {
1583 memset((c3_y*)c_w, 0, b_w << 2);
1584 }
1585 else {
1586 c3_w z_w = c3_min(b_w, d_u->len_w - a_w);
1587 c3_w* x_w = d_u->buf_w + a_w;
1588 memcpy((c3_y*)c_w, (c3_y*)x_w, z_w << 2);
1589 if ( b_w > d_u->len_w - a_w ) {
1590 memset((c3_y*)(c_w + z_w), 0, (b_w + a_w - d_u->len_w) << 2);
1591 }
1592 }
1593 }
1594 }
1595
1596 /* u3r_chop():
1597 **
1598 ** Into the bloq space of `met`, from position `fum` for a
1599 ** span of `wid`, to position `tou`, XOR from atom `src`
1600 ** into `dst_w`.
1601 */
1602 void
u3r_chop(c3_g met_g,c3_w fum_w,c3_w wid_w,c3_w tou_w,c3_w * dst_w,u3_atom src)1603 u3r_chop(c3_g met_g,
1604 c3_w fum_w,
1605 c3_w wid_w,
1606 c3_w tou_w,
1607 c3_w* dst_w,
1608 u3_atom src)
1609 {
1610 c3_w i_w;
1611 c3_w len_w;
1612 c3_w* buf_w;
1613
1614 c3_assert(u3_none != src);
1615 c3_assert(_(u3a_is_atom(src)));
1616
1617 if ( _(u3a_is_cat(src)) ) {
1618 len_w = src ? 1 : 0;
1619 buf_w = &src;
1620 }
1621 else {
1622 u3a_atom* src_u = u3a_to_ptr(src);
1623
1624 len_w = src_u->len_w;
1625 buf_w = src_u->buf_w;
1626 }
1627
1628 if ( met_g < 5 ) {
1629 c3_w san_w = (1 << met_g);
1630 c3_w mek_w = ((1 << san_w) - 1);
1631 c3_w baf_w = (fum_w << met_g);
1632 c3_w bat_w = (tou_w << met_g);
1633
1634 // XX: efficiency: poor. Iterate by words.
1635 //
1636 for ( i_w = 0; i_w < wid_w; i_w++ ) {
1637 c3_w waf_w = (baf_w >> 5);
1638 c3_g raf_g = (baf_w & 31);
1639 c3_w wat_w = (bat_w >> 5);
1640 c3_g rat_g = (bat_w & 31);
1641 c3_w hop_w;
1642
1643 hop_w = (waf_w >= len_w) ? 0 : buf_w[waf_w];
1644 hop_w = (hop_w >> raf_g) & mek_w;
1645
1646 dst_w[wat_w] ^= (hop_w << rat_g);
1647
1648 baf_w += san_w;
1649 bat_w += san_w;
1650 }
1651 }
1652 else {
1653 c3_g hut_g = (met_g - 5);
1654 c3_w san_w = (1 << hut_g);
1655 c3_w j_w;
1656
1657 for ( i_w = 0; i_w < wid_w; i_w++ ) {
1658 c3_w wuf_w = (fum_w + i_w) << hut_g;
1659 c3_w wut_w = (tou_w + i_w) << hut_g;
1660
1661 for ( j_w = 0; j_w < san_w; j_w++ ) {
1662 dst_w[wut_w + j_w] ^=
1663 ((wuf_w + j_w) >= len_w)
1664 ? 0
1665 : buf_w[wuf_w + j_w];
1666 }
1667 }
1668 }
1669 }
1670
1671 /* u3r_string(): `a` as malloced C string.
1672 */
1673 c3_c*
u3r_string(u3_atom a)1674 u3r_string(u3_atom a)
1675 {
1676 c3_w met_w = u3r_met(3, a);
1677 c3_c* str_c = c3_malloc(met_w + 1);
1678
1679 u3r_bytes(0, met_w, (c3_y*)str_c, a);
1680 str_c[met_w] = 0;
1681 return str_c;
1682 }
1683
1684 /* u3r_tape(): `a`, a list of bytes, as malloced C string.
1685 */
1686 c3_y*
u3r_tape(u3_noun a)1687 u3r_tape(u3_noun a)
1688 {
1689 u3_noun b;
1690 c3_w i_w;
1691 c3_y *a_y;
1692
1693 for ( i_w = 0, b=a; c3y == u3a_is_cell(b); i_w++, b=u3a_t(b) )
1694 ;
1695 a_y = c3_malloc(i_w + 1);
1696
1697 for ( i_w = 0, b=a; c3y == u3a_is_cell(b); i_w++, b=u3a_t(b) ) {
1698 a_y[i_w] = u3a_h(b);
1699 }
1700 a_y[i_w] = 0;
1701
1702 return a_y;
1703 }
1704
1705
1706 #if 0
1707
1708 /* Finalization mix for better avalanching.
1709 */
1710 static c3_w
1711 _mur_fmix(c3_w h_w)
1712 {
1713 h_w ^= h_w >> 16;
1714 h_w *= 0x85ebca6b;
1715 h_w ^= h_w >> 13;
1716 h_w *= 0xc2b2ae35;
1717 h_w ^= h_w >> 16;
1718
1719 return h_w;
1720 }
1721
1722 /* _mur_words(): raw MurmurHash3 on raw words.
1723 */
1724 static c3_w
1725 _mur_words(c3_w syd_w, const c3_w* key_w, c3_w len_w)
1726 {
1727 c3_w goc_w = syd_w;
1728 c3_w lig_w = 0xcc9e2d51;
1729 c3_w duf_w = 0x1b873593;
1730 c3_w i_w;
1731
1732 for ( i_w = 0; i_w < len_w; i_w++ ) {
1733 c3_w kop_w = key_w[i_w];
1734
1735 kop_w *= lig_w;
1736 kop_w = c3_rotw(15, kop_w);
1737 kop_w *= duf_w;
1738
1739 goc_w ^= kop_w;
1740 goc_w = c3_rotw(13, goc_w);
1741 goc_w = (goc_w * 5) + 0xe6546b64;
1742 }
1743 goc_w ^= len_w;
1744 goc_w = _mur_fmix(goc_w);
1745
1746 return goc_w;
1747 }
1748
1749 /* u3_mur_words(): 31-bit nonzero MurmurHash3 on raw words.
1750 */
1751 c3_w
1752 u3_mur_words(const c3_w* key_w, c3_w len_w)
1753 {
1754 c3_w syd_w = 0xcafebabe;
1755
1756 while ( 1 ) {
1757 c3_w haz_w = _mur_words(syd_w, key_w, len_w);
1758 c3_w ham_w = (haz_w >> 31) ^ (haz_w & 0x7fffffff);
1759
1760 if ( 0 != ham_w ) return ham_w;
1761 else syd_w++;
1762 }
1763 }
1764
1765 /* u3_mur_both():
1766 **
1767 ** Join two murs.
1768 */
1769 c3_w
1770 u3_mur_both(c3_w lef_w, c3_w rit_w)
1771 {
1772 c3_w ham_w = lef_w ^ (0x7fffffff ^ rit_w);
1773
1774 return u3_mur_words(&ham_w, (0 == ham_w) ? 0 : 1);
1775 }
1776
1777 /* u3_mur(): MurmurHash3 on a noun.
1778 */
1779 c3_w
1780 u3_mur(u3_noun veb)
1781 {
1782 if ( u3_fly_is_cat(veb) ) {
1783 return u3_mur_words(&veb, (0 == veb) ? 0 : 1);
1784 }
1785 else {
1786 c3_w mur_w;
1787
1788 if ( (mur_w=*u3_at_dog_mur(veb)) ) {
1789 return mur_w;
1790 }
1791
1792 if ( u3dog_is_pom(veb) ) {
1793 mur_w = u3_mur_both(u3_mur(u3h(veb)), u3_mur(u3t(veb)));
1794 }
1795 else {
1796 c3_w len_w = u3_met(5, veb);
1797 c3_w* buf_w = malloc(4 * len_w);
1798
1799 u3_words(0, len_w, buf_w, veb);
1800 mur_w = u3_mur_words(buf_w, len_w);
1801
1802 free(buf_w);
1803 }
1804
1805 *u3_at_dog_mur(veb) = mur_w;
1806 return mur_w;
1807 }
1808 }
1809
1810 /* u3_mur_string():
1811 **
1812 ** Compute the mur of `a`, LSB first.
1813 */
1814 c3_w
1815 u3_mur_string(const c3_c *a_c)
1816 {
1817 c3_w len_w = strlen(a_c);
1818 c3_w wor_w = ((len_w + 3) >> 2);
1819 c3_w* buf_w = alloca(4 * wor_w);
1820 c3_w i_w;
1821
1822 for ( i_w = 0; i_w < wor_w; i_w++ ) { buf_w[i_w] = 0; }
1823
1824 for ( i_w = 0; i_w < len_w; i_w++ ) {
1825 c3_w inx_w = (i_w >> 2);
1826 c3_w byt_w = (i_w & 3);
1827
1828 buf_w[inx_w] |= (a_c[i_w] << (8 * byt_w));
1829 }
1830 return u3_mur_words(buf_w, wor_w);
1831 }
1832
1833 /* u3_mur_cell():
1834 **
1835 ** Compute the mur of the cell `[hed tel]`.
1836 */
1837 c3_w
1838 u3_mur_cell(u3_noun hed,
1839 u3_noun tel)
1840 {
1841 c3_w lus_w = u3_mur(hed);
1842 c3_w biq_w = u3_mur(tel);
1843
1844 return u3_mur_both(lus_w, biq_w);
1845 }
1846
1847 /* u3_mur_trel():
1848 **
1849 ** Compute the mur of `[a b c]`.
1850 */
1851 c3_w
1852 u3_mur_trel(u3_noun a,
1853 u3_noun b,
1854 u3_noun c)
1855 {
1856 return u3_mur_both(u3_mur(a), u3_mur_both(u3_mur(b), u3_mur(c)));
1857 }
1858
1859 /* u3_mur_qual():
1860 **
1861 ** Compute the mur of `[a b c d]`.
1862 */
1863 c3_w
1864 u3_mur_qual(u3_noun a,
1865 u3_noun b,
1866 u3_noun c,
1867 u3_noun d)
1868 {
1869 return u3_mur_both(u3_mur(a),
1870 u3_mur_both(u3_mur(b),
1871 u3_mur_both(u3_mur(c), u3_mur(d))));
1872 }
1873 #endif
1874
1875