1 /*************************************************************************
2 * *
3 * YAP Prolog *
4 * *
5 * Yap Prolog was developed at NCCUP - Universidade do Porto *
6 * *
7 * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
8 * *
9 **************************************************************************
10 * *
11 * File: inlines.c *
12 * Last rev: *
13 * mods: *
14 * comments: C-version for inline code used in meta-calls *
15 * *
16 *************************************************************************/
17
18 #define IN_INLINES_C 1
19
20 #include "absmi.h"
21
22 #ifdef CUT_C
23 #include "cut_c.h"
24 #endif
25
26 STATIC_PROTO(Int p_atom, (void));
27 STATIC_PROTO(Int p_atomic, (void));
28 STATIC_PROTO(Int p_integer, (void));
29 STATIC_PROTO(Int p_nonvar, (void));
30 STATIC_PROTO(Int p_number, (void));
31 STATIC_PROTO(Int p_var, (void));
32 STATIC_PROTO(Int p_db_ref, (void));
33 STATIC_PROTO(Int p_primitive, (void));
34 STATIC_PROTO(Int p_compound, (void));
35 STATIC_PROTO(Int p_float, (void));
36 STATIC_PROTO(Int p_equal, (void));
37 STATIC_PROTO(Int p_dif, (void));
38 STATIC_PROTO(Int p_eq, (void));
39 STATIC_PROTO(Int p_arg, (void));
40 STATIC_PROTO(Int p_functor, (void));
41
42
43 static Int
p_atom(void)44 p_atom(void)
45 { /* atom(?) */
46 BEGD(d0);
47 d0 = ARG1;
48 deref_head(d0, atom_unk);
49 atom_nvar:
50 if (IsAtomTerm(d0)) {
51 return(TRUE);
52 }
53 else {
54 return(FALSE);
55 }
56
57 BEGP(pt0);
58 deref_body(d0, pt0, atom_unk, atom_nvar);
59 return(FALSE);
60 ENDP(pt0);
61 ENDD(d0);
62 }
63
64 static Int
p_atomic(void)65 p_atomic(void)
66 { /* atomic(?) */
67 BEGD(d0);
68 d0 = ARG1;
69 deref_head(d0, atomic_unk);
70 atomic_nvar:
71 if (IsAtomicTerm(d0)) {
72 return(TRUE);
73 }
74 else {
75 return(FALSE);
76 }
77
78 BEGP(pt0);
79 deref_body(d0, pt0, atomic_unk, atomic_nvar);
80 return(FALSE);
81 ENDP(pt0);
82 ENDD(d0);
83 }
84
85 static Int
p_integer(void)86 p_integer(void)
87 { /* integer(?,?) */
88 BEGD(d0);
89 d0 = ARG1;
90 deref_head(d0, integer_unk);
91 integer_nvar:
92 if (IsIntTerm(d0)) {
93 return(TRUE);
94 }
95 if (IsApplTerm(d0)) {
96 Functor f0 = FunctorOfTerm(d0);
97 if (IsExtensionFunctor(f0)) {
98 switch ((CELL)f0) {
99 case (CELL)FunctorLongInt:
100 #ifdef USE_GMP
101 case (CELL)FunctorBigInt:
102 #endif
103 return(TRUE);
104 default:
105 return(FALSE);
106 }
107 }
108 return(FALSE);
109 } else {
110 return(FALSE);
111 }
112
113 BEGP(pt0);
114 deref_body(d0, pt0, integer_unk, integer_nvar);
115 ENDP(pt0);
116 return(FALSE);
117 ENDD(d0);
118 }
119
120 static Int
p_number(void)121 p_number(void)
122 { /* number(?) */
123 BEGD(d0);
124 d0 = ARG1;
125 deref_head(d0, number_unk);
126 number_nvar:
127 if (IsIntTerm(d0)) {
128 return(TRUE);
129 }
130 if (IsApplTerm(d0)) {
131 Functor f0 = FunctorOfTerm(d0);
132 if (IsExtensionFunctor(f0)) {
133 switch ((CELL)f0) {
134 case (CELL)FunctorLongInt:
135 case (CELL)FunctorDouble:
136 #ifdef USE_GMP
137 case (CELL)FunctorBigInt:
138 #endif
139 return(TRUE);
140 default:
141 return(FALSE);
142 }
143 }
144 return(FALSE);
145 } else {
146 return(FALSE);
147 }
148
149 BEGP(pt0);
150 deref_body(d0, pt0, number_unk, number_nvar);
151 return(FALSE);
152 ENDP(pt0);
153 ENDD(d0);
154 }
155
156 static Int
p_db_ref(void)157 p_db_ref(void)
158 { /* db_reference(?,?) */
159 BEGD(d0);
160 d0 = ARG1;
161 deref_head(d0, db_ref_unk);
162 db_ref_nvar:
163 if (IsDBRefTerm(d0)) {
164 return(TRUE);
165 }
166 else {
167 return(FALSE);
168 }
169
170 BEGP(pt0);
171 deref_body(d0, pt0, db_ref_unk, db_ref_nvar);
172 return(FALSE);
173 ENDP(pt0);
174 ENDD(d0);
175 }
176
177 static Int
p_primitive(void)178 p_primitive(void)
179 { /* primitive(?) */
180 BEGD(d0);
181 d0 = ARG1;
182 deref_head(d0, primitive_unk);
183 primitive_nvar:
184 if (IsPrimitiveTerm(d0)) {
185 return(TRUE);
186 }
187 else {
188 return(FALSE);
189 }
190
191 BEGP(pt0);
192 deref_body(d0, pt0, primitive_unk, primitive_nvar);
193 return(FALSE);
194 ENDP(pt0);
195 ENDD(d0);
196 }
197
198 static Int
p_float(void)199 p_float(void)
200 { /* float(?) */
201 BEGD(d0);
202 d0 = ARG1;
203 deref_head(d0, float_unk);
204 float_nvar:
205 if (IsFloatTerm(d0)) {
206 return(TRUE);
207 }
208 else {
209 return(FALSE);
210 }
211
212 BEGP(pt0);
213 deref_body(d0, pt0, float_unk, float_nvar);
214 return(FALSE);
215 ENDP(pt0);
216 ENDD(d0);
217 }
218
219 static Int
p_compound(void)220 p_compound(void)
221 { /* compound(?) */
222 BEGD(d0);
223 d0 = ARG1;
224 deref_head(d0, compound_unk);
225 compound_nvar:
226 if (IsPairTerm(d0)) {
227 return(TRUE);
228 }
229 else if (IsApplTerm(d0)) {
230 if (IsExtensionFunctor(FunctorOfTerm(d0))) {
231 return(FALSE);
232 }
233 return(TRUE);
234 }
235 else {
236 return(FALSE);
237 }
238
239 BEGP(pt0);
240 deref_body(d0, pt0, compound_unk, compound_nvar);
241 return(FALSE);
242 ENDP(pt0);
243 ENDD(d0);
244 }
245
246 static Int
p_nonvar(void)247 p_nonvar(void)
248 { /* nonvar(?) */
249 BEGD(d0);
250 d0 = ARG1;
251 deref_head(d0, nonvar_unk);
252 nonvar_nvar:
253 return(TRUE);
254
255 BEGP(pt0);
256 deref_body(d0, pt0, nonvar_unk, nonvar_nvar);
257 return(FALSE);
258 ENDP(pt0);
259 ENDD(d0);
260 }
261
262 static Int
p_var(void)263 p_var(void)
264 { /* var(?) */
265 BEGD(d0);
266 d0 = ARG1;
267 deref_head(d0, var_unk);
268 var_nvar:
269 return(FALSE);
270
271 BEGP(pt0);
272 deref_body(d0, pt0, var_unk, var_nvar);
273 return(TRUE);
274 ENDP(pt0);
275 ENDD(d0);
276 }
277
278 static Int
p_equal(void)279 p_equal(void)
280 { /* ?=? */
281 return(Yap_IUnify(ARG1, ARG2));
282 }
283
284 static Int
eq(Term t1,Term t2)285 eq(Term t1, Term t2)
286 { /* ? == ? */
287 BEGD(d0);
288 d0 = t1;
289 deref_head(d0, p_eq_unk1);
290 p_eq_nvar1:
291 /* first argument is bound */
292 BEGD(d1);
293 d1 = t2;
294 deref_head(d1, p_eq_nvar1_unk2);
295 p_eq_nvar1_nvar2:
296 /* both arguments are bound */
297 if (d0 == d1) {
298 return(TRUE);
299 }
300 if (IsPairTerm(d0)) {
301 if (!IsPairTerm(d1)) {
302 return(FALSE);
303 }
304 return(iequ_complex(RepPair(d0)-1, RepPair(d0)+1,RepPair(d1)-1));
305 }
306 if (IsApplTerm(d0)) {
307 Functor f0 = FunctorOfTerm(d0);
308 Functor f1;
309 if (!IsApplTerm(d1)) {
310 return(FALSE);
311 }
312 f1 = FunctorOfTerm(d1);
313 if (f0 != f1) {
314 return(FALSE);
315 }
316 if (IsExtensionFunctor(f0)) {
317 switch ((CELL)f0) {
318 case (CELL)FunctorDBRef:
319 return (d0 == d1);
320 case (CELL)FunctorLongInt:
321 return(LongIntOfTerm(d0) == LongIntOfTerm(d1));
322 #ifdef USE_GMP
323 case (CELL)FunctorBigInt:
324 return (Yap_gmp_tcmp_big_big(d0, d1) == 0);
325 #endif
326 case (CELL)FunctorDouble:
327 return(FloatOfTerm(d0) == FloatOfTerm(d1));
328 default:
329 return(FALSE);
330 }
331 }
332 return(iequ_complex(RepAppl(d0), RepAppl(d0)+ArityOfFunctor(f0), RepAppl(d1)));
333 }
334 return(FALSE);
335
336 BEGP(pt0);
337 deref_body(d1, pt0, p_eq_nvar1_unk2, p_eq_nvar1_nvar2);
338 ENDP(pt0);
339 /* first argument is bound */
340 /* second argument is unbound */
341 /* I don't need to worry about co-routining because an
342 unbound variable may never be == to a constrained variable!! */
343 return(FALSE);
344 ENDD(d1);
345
346 BEGP(pt0);
347 deref_body(d0, pt0, p_eq_unk1, p_eq_nvar1);
348 BEGD(d1);
349 d1 = ARG2;
350 deref_head(d1, p_eq_var1_unk2);
351 p_eq_var1_nvar2:
352 /* I don't need to worry about co-routining because an
353 unbound variable may never be == to a constrained variable!! */
354 return(FALSE);
355
356 BEGP(pt1);
357 deref_body(d1, pt1, p_eq_var1_unk2, p_eq_var1_nvar2);
358 /* first argument is unbound */
359 /* second argument is unbound */
360 return(pt1 == pt0);
361 ENDP(pt1);
362 ENDD(d1);
363 ENDP(pt0);
364
365 ENDD(d0);
366 }
367
368 static Int
p_eq(void)369 p_eq(void)
370 { /* ? == ? */
371 return eq(ARG1,ARG2);
372 }
373
374 int
Yap_eq(Term t1,Term t2)375 Yap_eq(Term t1, Term t2)
376 { /* ? == ? */
377 return eq(t1,t2);
378 }
379
380 static Int
p_dif(void)381 p_dif(void)
382 { /* ? \= ? */
383 #if SHADOW_HB
384 register CELL *HBREG = HB;
385 #endif
386 BEGD(d0);
387 BEGD(d1);
388 d0 = ARG1;
389 deref_head(d0, dif_unk1);
390 dif_nvar1:
391 /* first argument is bound */
392 d1 = ARG2;
393 deref_head(d1, dif_nvar1_unk2);
394 dif_nvar1_nvar2:
395 /* both arguments are bound */
396 if (d0 == d1) {
397 return FALSE;
398 }
399 if (IsAtomOrIntTerm(d0) || IsAtomOrIntTerm(d1)) {
400 return TRUE;
401 } else {
402 #ifdef COROUTINING
403 /*
404 * We may wake up goals during our attempt to unify the
405 * two terms. If we are adding to the tail of a list of
406 * woken goals that should be ok, but otherwise we need
407 * to restore WokenGoals to its previous value.
408 */
409 CELL OldWokenGoals = Yap_ReadTimedVar(WokenGoals);
410 #endif
411 register tr_fr_ptr pt0;
412 /* store the old value of TR for clearing bindings */
413 pt0 = TR;
414 BEGCHO(pt1);
415 pt1 = B;
416 /* make B and HB point to H to guarantee all bindings will
417 * be trailed
418 */
419 HBREG = H;
420 B = (choiceptr) H;
421 B->cp_h = H;
422 SET_BB(B);
423 save_hb();
424 d0 = Yap_IUnify(d0, d1);
425 #ifdef COROUTINING
426 /* now restore Woken Goals to its old value */
427 Yap_UpdateTimedVar(WokenGoals, OldWokenGoals);
428 if (OldWokenGoals == TermNil) {
429 Yap_undo_signal(YAP_WAKEUP_SIGNAL);
430 }
431 #endif
432 /* restore B */
433 B = pt1;
434 SET_BB(PROTECT_FROZEN_B(pt1));
435 #ifdef COROUTINING
436 H = HBREG;
437 #endif
438 HBREG = B->cp_h;
439 /* untrail all bindings made by Yap_IUnify */
440 while (TR != pt0) {
441 BEGD(d1);
442 d1 = TrailTerm(--TR);
443 if (IsVarTerm(d1)) {
444 #if defined(SBA) && defined(YAPOR)
445 /* clean up the trail when we backtrack */
446 if (Unsigned((Int)(d1)-(Int)(H_FZ)) >
447 Unsigned((Int)(B_FZ)-(Int)(H_FZ))) {
448 RESET_VARIABLE(STACK_TO_SBA(d1));
449 } else
450 #endif
451 /* normal variable */
452 RESET_VARIABLE(d1);
453 #ifdef MULTI_ASSIGNMENT_VARIABLES
454 } else /* if (IsApplTerm(d1)) */ {
455 CELL *pt = RepAppl(d1);
456 /* AbsAppl means */
457 /* multi-assignment variable */
458 /* so the next cell is the old value */
459 #ifdef FROZEN_STACKS
460 pt[0] = TrailVal(--TR);
461 #else
462 pt[0] = TrailTerm(--TR);
463 TR--;
464 #endif /* FROZEN_STACKS */
465 #endif /* MULTI_ASSIGNMENT_VARIABLES */
466 }
467 ENDD(d1);
468 }
469 return !d0;
470 ENDP(pt0);
471 }
472
473 BEGP(pt0);
474 deref_body(d0, pt0, dif_unk1, dif_nvar1);
475 ENDP(pt0);
476 /* first argument is unbound */
477 return FALSE;
478
479 BEGP(pt0);
480 deref_body(d1, pt0, dif_nvar1_unk2, dif_nvar1_nvar2);
481 ENDP(pt0);
482 /* second argument is unbound */
483 return FALSE;
484 ENDD(d1);
485 ENDD(d0);
486 }
487
488 static Int
p_arg(void)489 p_arg(void)
490 { /* arg(?,?,?) */
491 #if SHADOW_HB
492 register CELL *HBREG = HB;
493 #endif
494 BEGD(d0);
495 d0 = ARG1;
496 deref_head(d0, arg_arg1_unk);
497 arg_arg1_nvar:
498 /* ARG1 is ok! */
499 if (IsIntTerm(d0))
500 d0 = IntOfTerm(d0);
501 else if (IsLongIntTerm(d0)) {
502 d0 = LongIntOfTerm(d0);
503 } else {
504 Yap_Error(TYPE_ERROR_INTEGER,d0,"arg 1 of arg/3");
505 return(FALSE);
506 }
507
508 /* d0 now got the argument we want */
509 BEGD(d1);
510 d1 = ARG2;
511 deref_head(d1, arg_arg2_unk);
512 arg_arg2_nvar:
513 /* d1 now got the structure we want to fetch the argument
514 * from */
515 if (IsApplTerm(d1)) {
516 BEGP(pt0);
517 pt0 = RepAppl(d1);
518 d1 = *pt0;
519 if (IsExtensionFunctor((Functor) d1)) {
520 return(FALSE);
521 }
522 save_hb();
523 if ((Int)d0 <= 0 ||
524 (Int)d0 > ArityOfFunctor((Functor) d1) ||
525 Yap_IUnify(pt0[d0], ARG3) == FALSE) {
526 /* don't complain here for Prolog compatibility
527 if ((Int)d0 <= 0) {
528 Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,
529 MkIntegerTerm(d0),"arg 1 of arg/3");
530 }
531 */
532 return(FALSE);
533 }
534 return(TRUE);
535 ENDP(pt0);
536 }
537 else if (IsPairTerm(d1)) {
538 BEGP(pt0);
539 pt0 = RepPair(d1);
540 if (d0 == 1) {
541 save_hb();
542 if (Yap_IUnify((CELL)pt0, ARG3) == FALSE) {
543 return(FALSE);
544 }
545 return(TRUE);
546 }
547 else if (d0 == 2) {
548 save_hb();
549 if (Yap_IUnify((CELL)(pt0+1), ARG3) == FALSE) {
550 return(FALSE);
551 }
552 return(TRUE);
553 }
554 else {
555 if ((Int)d0 < 0)
556 Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,
557 MkIntegerTerm(d0),"arg 1 of arg/3");
558 return(FALSE);
559 }
560 ENDP(pt0);
561 }
562 else {
563 /* Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); */
564 return(FALSE);
565 }
566
567 BEGP(pt0);
568 deref_body(d1, pt0, arg_arg2_unk, arg_arg2_nvar);
569 Yap_Error(INSTANTIATION_ERROR,(CELL)pt0,"arg 2 of arg/3");;
570 ENDP(pt0);
571 return(FALSE);
572 ENDD(d1);
573
574 BEGP(pt0);
575 deref_body(d0, pt0, arg_arg1_unk, arg_arg1_nvar);
576 Yap_Error(INSTANTIATION_ERROR,(CELL)pt0,"arg 1 of arg/3");;
577 ENDP(pt0);
578 return(FALSE);
579 ENDD(d0);
580
581 }
582
583 static Int
p_functor(void)584 p_functor(void) /* functor(?,?,?) */
585 {
586 #if SHADOW_HB
587 register CELL *HBREG;
588 #endif
589
590 restart:
591 #if SHADOW_HB
592 HBREG = HB;
593 #endif
594 BEGD(d0);
595 d0 = ARG1;
596 deref_head(d0, func_unk);
597 func_nvar:
598 /* A1 is bound */
599 BEGD(d1);
600 if (IsApplTerm(d0)) {
601 d1 = *RepAppl(d0);
602 if (IsExtensionFunctor((Functor) d1)) {
603 if (d1 == (CELL)FunctorDouble) {
604 d1 = MkIntTerm(0);
605 } else if (d1 == (CELL)FunctorLongInt) {
606 d1 = MkIntTerm(0);
607 } else
608 return(FALSE);
609 } else {
610 d0 = MkAtomTerm(NameOfFunctor((Functor) d1));
611 d1 = MkIntTerm(ArityOfFunctor((Functor) d1));
612 }
613 }
614 else if (IsPairTerm(d0)) {
615 d0 = TermDot;
616 d1 = MkIntTerm(2);
617 }
618 else {
619 d1 = MkIntTerm(0);
620 }
621 /* d1 and d0 now have the two arguments */
622 /* let's go and bind them */
623 {
624 register CELL arity = d1;
625
626 d1 = ARG2;
627 deref_head(d1, func_nvar_unk);
628 func_nvar_nvar:
629 /* A2 was bound */
630 if (d0 != d1) {
631 return(FALSE);
632 }
633 /* have to buffer ENDP and label */
634 d0 = arity;
635 goto func_bind_x3;
636
637 BEGP(pt0);
638 deref_body(d1, pt0, func_nvar_unk, func_nvar_nvar);
639 /* A2 is a variable, go and bind it */
640 BIND(pt0, d0, bind_func_nvar_var);
641 #ifdef COROUTINING
642 DO_TRAIL(pt0, d0);
643 if (IsAttVar(pt0)) Yap_WakeUp(pt0);
644 bind_func_nvar_var:
645 #endif
646 /* have to buffer ENDP and label */
647 d0 = arity;
648 ENDP(pt0);
649 /* now let's process A3 */
650
651 func_bind_x3:
652 d1 = ARG3;
653 deref_head(d1, func_nvar3_unk);
654 func_nvar3_nvar:
655 /* A3 was bound */
656 if (d0 != d1) {
657 return(FALSE);
658 }
659 /* Done */
660 return(TRUE);
661
662
663 BEGP(pt0);
664 deref_body(d1, pt0, func_nvar3_unk, func_nvar3_nvar);
665 /* A3 is a variable, go and bind it */
666 BIND(pt0, d0, bind_func_nvar3_var);
667 /* Done */
668 #ifdef COROUTINING
669 DO_TRAIL(pt0, d0);
670 if (IsAttVar(pt0)) Yap_WakeUp(pt0);
671 bind_func_nvar3_var:
672 #endif
673 return(TRUE);
674
675 ENDP(pt0);
676
677 }
678 ENDD(d1);
679
680 BEGP(pt0);
681 deref_body(d0, pt0, func_unk, func_nvar);
682 /* A1 is a variable */
683 /* We have to build the structure */
684 d0 = ARG2;
685 deref_head(d0, func_var_2unk);
686 func_var_2nvar:
687 /* we do, let's get the third argument */
688 BEGD(d1);
689 d1 = ARG3;
690 deref_head(d1, func_var_3unk);
691 func_var_3nvar:
692 /* Uuuff, the second and third argument are bound */
693 if (IsIntegerTerm(d1))
694 d1 = IntOfTerm(d1);
695 else {
696 if (IsBigIntTerm(d1)) {
697 Yap_Error(RESOURCE_ERROR_STACK, ARG3, "functor/3");
698 } else {
699 Yap_Error(TYPE_ERROR_INTEGER,ARG3,"functor/3");
700 }
701 return(FALSE);
702 }
703 if (!IsAtomicTerm(d0)) {
704 Yap_Error(TYPE_ERROR_ATOMIC,d0,"functor/3");
705 return(FALSE);
706 }
707 /* We made it!!!!! we got in d0 the name, in d1 the arity and
708 * in pt0 the variable to bind it to. */
709 if (d0 == TermDot && d1 == 2) {
710 RESET_VARIABLE(H);
711 RESET_VARIABLE(H+1);
712 d0 = AbsPair(H);
713 H += 2;
714 }
715 else if ((Int)d1 > 0) {
716 /* now let's build a compound term */
717 if (!IsAtomTerm(d0)) {
718 Yap_Error(TYPE_ERROR_ATOM,d0,"functor/3");
719 return(FALSE);
720 }
721 BEGP(pt1);
722 if (!IsAtomTerm(d0)) {
723 return(FALSE);
724 }
725 else
726 d0 = (CELL) Yap_MkFunctor(AtomOfTerm(d0), (Int) d1);
727 pt1 = H;
728 *pt1++ = d0;
729 d0 = AbsAppl(H);
730 if (pt1+d1 > ENV - CreepFlag) {
731 if (!Yap_gcl((1+d1)*sizeof(CELL), 3, ENV, gc_P(P,CP))) {
732 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
733 return FALSE;
734 }
735 goto restart;
736 }
737 while (d1-- > 0) {
738 RESET_VARIABLE(pt1);
739 pt1++;
740 }
741 /* done building the term */
742 H = pt1;
743 ENDP(pt1);
744 } else if ((Int)d1 < 0) {
745 Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,MkIntegerTerm(d1),"functor/3");
746 return(FALSE);
747 }
748 /* else if arity is 0 just pass d0 through */
749 /* Ding, ding, we made it */
750 BIND(pt0, d0, bind_func_var_3nvar);
751 #ifdef COROUTINING
752 DO_TRAIL(pt0, d0);
753 if (IsAttVar(pt0)) Yap_WakeUp(pt0);
754 bind_func_var_3nvar:
755 #endif
756 return(TRUE);
757
758
759 BEGP(pt1);
760 deref_body(d1, pt1, func_var_3unk, func_var_3nvar);
761 Yap_Error(INSTANTIATION_ERROR,(CELL)pt1,"functor/3");
762 ENDP(pt1);
763 /* Oops, third argument was unbound */
764 return(FALSE);
765 ENDD(d1);
766
767 BEGP(pt1);
768
769 deref_body(d0, pt1, func_var_2unk, func_var_2nvar);
770 Yap_Error(INSTANTIATION_ERROR,(CELL)pt1,"functor/3");
771 ENDP(pt1);
772 /* Oops, second argument was unbound too */
773 return(FALSE);
774 ENDP(pt0);
775 ENDD(d0);
776 }
777
778 static Int
p_cut_by(void)779 p_cut_by( void)
780 {
781 BEGD(d0);
782 d0 = ARG1;
783 deref_head(d0, cutby_x_unk);
784 cutby_x_nvar:
785 #if SBA
786 if (!IsIntegerTerm(d0)) {
787 #else
788 if (!IsIntTerm(d0)) {
789 #endif
790 return(FALSE);
791 }
792 BEGCHO(pt0);
793 #if SBA
794 pt0 = (choiceptr)IntegerOfTerm(d0);
795 #else
796 pt0 = (choiceptr)(LCL0-IntOfTerm(d0));
797 #endif
798 #ifdef CUT_C
799 {
800 while (POP_CHOICE_POINT(pt0))
801 {
802 POP_EXECUTE();
803 }
804 }
805 #endif /* CUT_C */
806 #ifdef YAPOR
807 CUT_prune_to(pt0);
808 #endif /* YAPOR */
809 /* find where to cut to */
810 if (pt0 > B) {
811 /* Wow, we're gonna cut!!! */
812 #ifdef TABLING
813 while (B->cp_b < pt0) {
814 B = B->cp_b;
815 }
816 abolish_incomplete_subgoals(B);
817 #endif /* TABLING */
818 B = pt0;
819 HB = B->cp_h;
820 Yap_TrimTrail();
821 }
822 ENDCHO(pt0);
823 return(TRUE);
824
825 BEGP(pt0);
826 deref_body(d0, pt0, cutby_x_unk, cutby_x_nvar);
827 /* never cut to a variable */
828 /* Abort */
829 return(FALSE);
830 ENDP(pt0);
831 ENDD(d0);
832 }
833
834 static Int
835 p_erroneous_call(void)
836 {
837 Yap_Error(SYSTEM_ERROR, TermNil, "bad call to internal built-in");
838 return(FALSE);
839 }
840
841 static Int
842 init_genarg(void)
843 { /* getarg(?Atom) */
844 Term t0 = Deref(ARG1);
845 Term t1 = Deref(ARG2);
846 CELL *pt, *end;
847 int res;
848 UInt arity;
849
850 if (!IsVarTerm(t0)) {
851 res = p_arg();
852 if (res) {
853 cut_succeed();
854 } else {
855 cut_fail();
856 }
857 }
858 if (IsVarTerm(t1)) {
859 Yap_Error(INSTANTIATION_ERROR,t1,"genarg/3");
860 return FALSE;
861 }
862 if (IsPrimitiveTerm(t1)) {
863 Yap_Error(TYPE_ERROR_COMPOUND,t1,"genarg/3");
864 return FALSE;
865 }
866 if (IsPairTerm(t1)) {
867 pt = RepPair(t1);
868 end = RepPair(t1)+1;
869 arity = 2;
870 } else {
871 arity = ArityOfFunctor(FunctorOfTerm(t1));
872 pt = RepAppl(t1);
873 end = pt+arity;
874 pt += 1;
875 }
876 res = Yap_unify(ARG1,MkIntTerm(1)) &&
877 Yap_unify(ARG3,pt[0]);
878 if (arity == 1) {
879 if (res) {
880 cut_succeed();
881 } else {
882 cut_fail();
883 }
884 }
885 EXTRA_CBACK_ARG(3,1) = (Term)(pt+1);
886 EXTRA_CBACK_ARG(3,2) = (Term)(end);
887 EXTRA_CBACK_ARG(3,3) = MkIntegerTerm(arity);
888 return res;
889 }
890
891 static Int
892 cont_genarg(void)
893 { /* genarg(?Atom) */
894 CELL *pt, *end;
895 int res;
896 UInt arity;
897
898 pt = (CELL *)EXTRA_CBACK_ARG(3,1);
899 end = (CELL *)EXTRA_CBACK_ARG(3,2);
900 arity = IntegerOfTerm(EXTRA_CBACK_ARG(3,3));
901 if (pt == end) {
902 res = Yap_unify(ARG1,MkIntegerTerm(arity)) &&
903 Yap_unify(ARG3,pt[0]);
904 if (res) {
905 cut_succeed();
906 } else {
907 cut_fail();
908 }
909 }
910 EXTRA_CBACK_ARG(3,1) = (Term)(pt+1);
911 return Yap_unify(ARG1,MkIntegerTerm(arity-(end-pt))) &&
912 Yap_unify(ARG3,pt[0]);
913 }
914
915
916 void
917 Yap_InitInlines(void)
918 {
919 Term cm = CurrentModule;
920 Yap_InitAsmPred("$$cut_by", 1, _cut_by, p_cut_by, SafePredFlag);
921 Yap_InitAsmPred("atom", 1, _atom, p_atom, SafePredFlag);
922 Yap_InitAsmPred("atomic", 1, _atomic, p_atomic, SafePredFlag);
923 Yap_InitAsmPred("integer", 1, _integer, p_integer, SafePredFlag);
924 Yap_InitAsmPred("nonvar", 1, _nonvar, p_nonvar, SafePredFlag);
925 Yap_InitAsmPred("number", 1, _number, p_number, SafePredFlag);
926 Yap_InitAsmPred("var", 1, _var, p_var, SafePredFlag);
927 Yap_InitAsmPred("db_reference", 1, _db_ref, p_db_ref, SafePredFlag);
928 Yap_InitAsmPred("primitive", 1, _primitive, p_primitive, SafePredFlag);
929 Yap_InitAsmPred("compound", 1, _compound, p_compound, SafePredFlag);
930 Yap_InitAsmPred("float", 1, _float, p_float, SafePredFlag);
931 Yap_InitAsmPred("=", 2, _equal, p_equal, SafePredFlag);
932 Yap_InitAsmPred("\\=", 2, _dif, p_dif, SafePredFlag);
933 Yap_InitAsmPred("==", 2, _eq, p_eq, SafePredFlag);
934 Yap_InitAsmPred("arg", 3, _arg, p_arg, SafePredFlag);
935 Yap_InitAsmPred("functor", 3, _functor, p_functor, 0);
936 Yap_InitAsmPred("$label_ctl", 2, _p_label_ctl, p_erroneous_call, SafePredFlag);
937 CurrentModule = ARG_MODULE;
938 Yap_InitCPredBack("genarg", 3, 3, init_genarg, cont_genarg,SafePredFlag);
939 CurrentModule = cm;
940 }
941
942