1 /*************************************************************************
2 * *
3 * YAP Prolog %W% %G% *
4 * Yap Prolog was developed at NCCUP - Universidade do Porto *
5 * *
6 * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
7 * *
8 **************************************************************************
9 * *
10 * File: TermExt.h *
11 * mods: *
12 * comments: Extensions to standard terms for YAP *
13 * version: $Id: TermExt.h,v 1.15 2008-03-25 22:03:13 vsc Exp $ *
14 *************************************************************************/
15
16 #ifdef USE_SYSTEM_MALLOC
17 #define SF_STORE (&(Yap_heap_regs->funcs))
18 #else
19 #define SF_STORE ((special_functors *)HEAP_INIT_BASE)
20 #endif
21
22 #ifdef USE_OFFSETS
23 #define AtomFoundVar ((Atom)(&(((special_functors *)(NULL))->AtFoundVar)))
24 #define AtomFreeTerm ((Atom)(&(((special_functors *)(NULL))->AtFreeTerm)))
25 #define AtomNil ((Atom)(&(((special_functors *)(NULL))->AtNil)))
26 #define AtomDot ((Atom)(&(((special_functors *)(NULL))->AtDot)))
27 #elif defined(THREADS)
28 #define AtomFoundVar AbsAtom(SF_STORE->AtFoundVar)
29 #define AtomFreeTerm AbsAtom(SF_STORE->AtFreeTerm)
30 #define AtomNil AbsAtom(SF_STORE->AtNil)
31 #define AtomDot AbsAtom(SF_STORE->AtDot)
32 #else
33 #define AtomFoundVar AbsAtom(&(SF_STORE->AtFoundVar))
34 #define AtomFreeTerm AbsAtom(&(SF_STORE->AtFreeTerm))
35 #define AtomNil AbsAtom(&(SF_STORE->AtNil))
36 #define AtomDot AbsAtom(&(SF_STORE->AtDot))
37 #endif
38
39 #define TermFoundVar MkAtomTerm(AtomFoundVar)
40 #define TermFreeTerm MkAtomTerm(AtomFreeTerm)
41 #define TermNil MkAtomTerm(AtomNil)
42 #define TermDot MkAtomTerm(AtomDot)
43
44 typedef enum
45 {
46 db_ref_e = sizeof (Functor *),
47 attvar_e = 2*sizeof (Functor *),
48 long_int_e = 3 * sizeof (Functor *),
49 big_int_e = 4 * sizeof (Functor *),
50 double_e = 5 * sizeof (Functor *)
51 }
52 blob_type;
53
54 #define FunctorDBRef ((Functor)(db_ref_e))
55 #define FunctorAttVar ((Functor)(attvar_e))
56 #define FunctorLongInt ((Functor)(long_int_e))
57 #define FunctorBigInt ((Functor)(big_int_e))
58 #define FunctorDouble ((Functor)(double_e))
59 #define EndSpecials (double_e+sizeof(Functor *))
60
61 inline EXTERN int IsAttVar (CELL *pt);
62
63 inline EXTERN int
IsAttVar(CELL * pt)64 IsAttVar (CELL *pt)
65 {
66 return (pt)[-1] == (CELL)attvar_e && pt < H;
67 }
68
69 typedef enum
70 {
71 BIG_INT = 0x01,
72 BIG_RATIONAL = 0x02,
73 BIG_FLOAT = 0x04,
74 EMPTY_ARENA = 0x10,
75 ARRAY_INT = 0x21,
76 ARRAY_FLOAT = 0x22,
77 CLAUSE_LIST = 0x40,
78 BLOB_STRING = 0x80, /* SWI style strings */
79 BLOB_WIDE_STRING = 0x81, /* SWI style strings */
80 EXTERNAL_BLOB = 0x100 /* for SWI emulation */
81 }
82 big_blob_type;
83
84 inline EXTERN blob_type BlobOfFunctor (Functor f);
85
86 inline EXTERN blob_type
BlobOfFunctor(Functor f)87 BlobOfFunctor (Functor f)
88 {
89 return (blob_type) (f);
90 }
91
92 typedef struct cp_frame {
93 CELL *original_cp;
94 CELL *start_cp;
95 CELL *end_cp;
96 CELL *to;
97 #ifdef RATIONAL_TREES
98 CELL oldv;
99 int ground;
100 #endif
101 } copy_frame;
102
103
104 #ifdef COROUTINING
105
106 typedef struct
107 {
108 /* what to do when someone tries to bind our term to someone else
109 in some predefined context */
110 void (*bind_op) (Term *, Term);
111 /* what to do if someone wants to copy our constraint */
112 int (*copy_term_op) (CELL *, struct cp_frame **, CELL *);
113 /* copy the constraint into a term and back */
114 Term (*to_term_op) (CELL *);
115 int (*term_to_op) (Term, Term);
116 /* op called to do marking in GC */
117 void (*mark_op) (CELL *);
118 } ext_op;
119
120 /* known delays */
121 typedef enum
122 {
123 empty_ext = 0 * sizeof (ext_op), /* default op, this should never be called */
124 attvars_ext = 1 * sizeof (ext_op) /* support for attributed variables */
125 /* add your own extensions here */
126 /* keep this one */
127 }
128 exts;
129
130
131 /* array with the ops for your favourite extensions */
132 extern ext_op attas[attvars_ext + 1];
133
134 #endif
135
136 /* make sure that these data structures are the first thing to be allocated
137 in the heap when we start the system */
138 #ifdef THREADS
139 typedef struct special_functors_struct
140 {
141 AtomEntry *AtFoundVar;
142 AtomEntry *AtFreeTerm;
143 AtomEntry *AtNil;
144 AtomEntry *AtDot;
145 } special_functors;
146 #else
147 typedef struct special_functors_struct
148 {
149 AtomEntry AtFoundVar;
150 char AtFoundVarChars[8];
151 AtomEntry AtFreeTerm;
152 char AtFreeTermChars[8];
153 AtomEntry AtNil;
154 char AtNilChars[8];
155 AtomEntry AtDot;
156 char AtDotChars[8];
157 }
158 special_functors;
159 #endif
160
161 inline EXTERN Float STD_PROTO (CpFloatUnaligned, (CELL *));
162
163 #if SIZEOF_DOUBLE == SIZEOF_LONG_INT
164
165 inline EXTERN Term MkFloatTerm (Float);
166
167 inline EXTERN Term
MkFloatTerm(Float dbl)168 MkFloatTerm (Float dbl)
169 {
170 return (Term) ((H[0] = (CELL) FunctorDouble, *(Float *) (H + 1) =
171 dbl, H[2] = EndSpecials, H +=
172 3, AbsAppl (H - 3)));
173 }
174
175
176 inline EXTERN Float FloatOfTerm (Term t);
177
178 inline EXTERN Float
FloatOfTerm(Term t)179 FloatOfTerm (Term t)
180 {
181 return (Float) (*(Float *) (RepAppl (t) + 1));
182 }
183
184
185
186 #define InitUnalignedFloat()
187
188 inline extern Float
CpFloatUnaligned(CELL * ptr)189 CpFloatUnaligned(CELL *ptr)
190 {
191 return *((Float *)ptr);
192 }
193
194 #else
195
196 #if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
197
198 inline EXTERN void STD_PROTO (AlignGlobalForDouble, (void));
199
200 #define DOUBLE_ALIGNED(ADDR) ((CELL)(ADDR) & 0x4)
201
202 #ifdef i386
203 inline EXTERN Float
CpFloatUnaligned(CELL * ptr)204 CpFloatUnaligned (CELL * ptr)
205 {
206 return *((Float *) (ptr + 1));
207 }
208
209 #else
210 /* first, need to address the alignment problem */
211 inline EXTERN Float
CpFloatUnaligned(CELL * ptr)212 CpFloatUnaligned (CELL * ptr)
213 {
214 union
215 {
216 Float f;
217 CELL d[2];
218 } u;
219 u.d[0] = ptr[1];
220 u.d[1] = ptr[2];
221 return (u.f);
222 }
223
224 #endif
225
226 inline EXTERN Term MkFloatTerm (Float);
227
228 inline EXTERN Term
MkFloatTerm(Float dbl)229 MkFloatTerm (Float dbl)
230 {
231 return (Term) ((AlignGlobalForDouble (), H[0] =
232 (CELL) FunctorDouble, *(Float *) (H + 1) = dbl, H[3] =
233 EndSpecials, H +=
234 4, AbsAppl (H - 4)));
235 }
236
237
238
239 inline EXTERN Float FloatOfTerm (Term t);
240
241 inline EXTERN Float
FloatOfTerm(Term t)242 FloatOfTerm (Term t)
243 {
244 return (Float) ((DOUBLE_ALIGNED (RepAppl (t)) ? *(Float *) (RepAppl (t) + 1)
245 : CpFloatUnaligned (RepAppl (t))));
246 }
247
248
249 /* no alignment problems for 64 bit machines */
250 #else
251 /* OOPS, YAP only understands Floats that are as large as cells or that
252 take two cells!!! */
253 #endif
254 #endif
255
256
257 inline EXTERN int IsFloatTerm (Term);
258
259 inline EXTERN int
IsFloatTerm(Term t)260 IsFloatTerm (Term t)
261 {
262 return (int) (IsApplTerm (t) && FunctorOfTerm (t) == FunctorDouble);
263 }
264
265
266
267
268 /* extern Functor FunctorLongInt; */
269
270 inline EXTERN Term MkLongIntTerm (Int);
271
272 inline EXTERN Term
MkLongIntTerm(Int i)273 MkLongIntTerm (Int i)
274 {
275 H[0] = (CELL) FunctorLongInt;
276 H[1] = (CELL) (i);
277 H[2] = EndSpecials;
278 H += 3;
279 return AbsAppl(H - 3);
280 }
281
282 inline EXTERN Int LongIntOfTerm (Term t);
283
284 inline EXTERN Int
LongIntOfTerm(Term t)285 LongIntOfTerm (Term t)
286 {
287 return (Int) (RepAppl (t)[1]);
288 }
289
290
291
292 inline EXTERN int IsLongIntTerm (Term);
293
294 inline EXTERN int
IsLongIntTerm(Term t)295 IsLongIntTerm (Term t)
296 {
297 return (int) (IsApplTerm (t) && FunctorOfTerm (t) == FunctorLongInt);
298 }
299
300
301
302 #ifdef USE_GMP
303
304 #include <stdio.h>
305
306 #include <gmp.h>
307
308 #else
309
310 typedef UInt mp_limb_t;
311
312 typedef struct {
313 Int _mp_size, _mp_alloc;
314 mp_limb_t *_mp_d;
315 } MP_INT;
316
317 typedef struct {
318 MP_INT _mp_num;
319 MP_INT _mp_den;
320 } MP_RAT;
321
322 #endif
323
324 inline EXTERN int IsBigIntTerm (Term);
325
326 inline EXTERN int
IsBigIntTerm(Term t)327 IsBigIntTerm (Term t)
328 {
329 return (int) (IsApplTerm (t) && FunctorOfTerm (t) == FunctorBigInt);
330 }
331
332 #ifdef USE_GMP
333
334 Term STD_PROTO (Yap_MkBigIntTerm, (MP_INT *));
335 MP_INT *STD_PROTO (Yap_BigIntOfTerm, (Term));
336
337 Term STD_PROTO (Yap_MkBigRatTerm, (MP_RAT *));
338 MP_RAT *STD_PROTO (Yap_BigRatOfTerm, (Term));
339
340 inline EXTERN void MPZ_SET (mpz_t, MP_INT *);
341
342 inline EXTERN void
MPZ_SET(mpz_t dest,MP_INT * src)343 MPZ_SET (mpz_t dest, MP_INT *src)
344 {
345 dest->_mp_size = src->_mp_size;
346 dest->_mp_alloc = src->_mp_alloc;
347 dest->_mp_d = src->_mp_d;
348 }
349
350 inline EXTERN int IsLargeIntTerm (Term);
351
352 inline EXTERN int
IsLargeIntTerm(Term t)353 IsLargeIntTerm (Term t)
354 {
355 return (int) (IsApplTerm (t)
356 && ((FunctorOfTerm (t) <= FunctorBigInt)
357 && (FunctorOfTerm (t) >= FunctorLongInt)));
358 }
359
360
361 inline EXTERN UInt Yap_SizeOfBigInt (Term);
362
363 inline EXTERN UInt
Yap_SizeOfBigInt(Term t)364 Yap_SizeOfBigInt (Term t)
365 {
366 CELL *pt = RepAppl(t)+1;
367 return 2+(sizeof(MP_INT)+
368 (((MP_INT *)pt)->_mp_alloc*sizeof(mp_limb_t)))/sizeof(CELL);
369 }
370
371
372
373 #else
374
375
376
377 inline EXTERN int IsLargeIntTerm (Term);
378
379 inline EXTERN int
IsLargeIntTerm(Term t)380 IsLargeIntTerm (Term t)
381 {
382 return (int) (IsApplTerm (t) && FunctorOfTerm (t) == FunctorLongInt);
383 }
384
385
386
387 #endif
388
389 typedef struct string_struct {
390 size_t len;
391 } blob_string_t;
392
393 Term STD_PROTO (Yap_MkBlobStringTerm, (const char *, size_t len));
394 Term STD_PROTO (Yap_MkBlobWideStringTerm, (const wchar_t *, size_t len));
395 char *STD_PROTO (Yap_BlobStringOfTerm, (Term));
396 wchar_t *STD_PROTO (Yap_BlobWideStringOfTerm, (Term));
397 char *STD_PROTO (Yap_BlobStringOfTermAndLength, (Term, size_t *));
398
399 inline EXTERN int IsBlobStringTerm (Term);
400
401 inline EXTERN int
IsBlobStringTerm(Term t)402 IsBlobStringTerm (Term t)
403 {
404 return (int) (IsApplTerm (t) &&
405 FunctorOfTerm (t) == FunctorBigInt &&
406 (RepAppl(t)[1] & BLOB_STRING) == BLOB_STRING);
407 }
408
409 inline EXTERN int IsWideBlobStringTerm (Term);
410
411 inline EXTERN int
IsWideBlobStringTerm(Term t)412 IsWideBlobStringTerm (Term t)
413 {
414 return (int) (IsApplTerm (t) &&
415 FunctorOfTerm (t) == FunctorBigInt &&
416 RepAppl(t)[1] == BLOB_WIDE_STRING);
417 }
418
419 /* extern Functor FunctorLongInt; */
420
421 inline EXTERN int IsLargeNumTerm (Term);
422
423 inline EXTERN int
IsLargeNumTerm(Term t)424 IsLargeNumTerm (Term t)
425 {
426 return (int) (IsApplTerm (t)
427 && ((FunctorOfTerm (t) <= FunctorDouble)
428 && (FunctorOfTerm (t) >= FunctorLongInt)));
429 }
430
431
432
433
434 inline EXTERN int IsNumTerm (Term);
435
436 inline EXTERN int
IsNumTerm(Term t)437 IsNumTerm (Term t)
438 {
439 return (int) ((IsIntTerm (t) || IsLargeNumTerm (t)));
440 }
441
442
443
444
445 inline EXTERN Int IsAtomicTerm (Term);
446
447 inline EXTERN Int
IsAtomicTerm(Term t)448 IsAtomicTerm (Term t)
449 {
450 return (Int) (IsAtomOrIntTerm (t) || IsLargeNumTerm (t));
451 }
452
453
454
455
456 inline EXTERN Int IsExtensionFunctor (Functor);
457
458 inline EXTERN Int
IsExtensionFunctor(Functor f)459 IsExtensionFunctor (Functor f)
460 {
461 return (Int) (f <= FunctorDouble);
462 }
463
464
465
466 inline EXTERN Int IsBlobFunctor (Functor);
467
468 inline EXTERN Int
IsBlobFunctor(Functor f)469 IsBlobFunctor (Functor f)
470 {
471 return (Int) ((f <= FunctorDouble && f >= FunctorDBRef));
472 }
473
474
475
476 inline EXTERN Int IsPrimitiveTerm (Term);
477
478 inline EXTERN Int
IsPrimitiveTerm(Term t)479 IsPrimitiveTerm (Term t)
480 {
481 return (Int) ((IsAtomOrIntTerm (t)
482 || (IsApplTerm (t) && IsBlobFunctor (FunctorOfTerm (t)))));
483 }
484
485 #ifdef TERM_EXTENSIONS
486
487
488 inline EXTERN Int IsAttachFunc (Functor);
489
490 inline EXTERN Int
IsAttachFunc(Functor f)491 IsAttachFunc (Functor f)
492 {
493 return (Int) (FALSE);
494 }
495
496
497
498
499 inline EXTERN Int IsAttachedTerm (Term);
500
501 inline EXTERN Int
IsAttachedTerm(Term t)502 IsAttachedTerm (Term t)
503 {
504 return (Int) ((IsVarTerm (t) && IsAttVar(VarOfTerm(t))));
505 }
506
507
508
509
510 inline EXTERN Int SafeIsAttachedTerm (Term);
511
512 inline EXTERN Int
SafeIsAttachedTerm(Term t)513 SafeIsAttachedTerm (Term t)
514 {
515 return (Int) (IsVarTerm (t) && IsAttVar(VarOfTerm(t)));
516 }
517
518
519
520
521 inline EXTERN exts ExtFromCell (CELL *);
522
523 inline EXTERN exts
ExtFromCell(CELL * pt)524 ExtFromCell (CELL * pt)
525 {
526 return attvars_ext;
527 }
528
529
530
531 #else
532
533
534 inline EXTERN Int IsAttachFunc (Functor);
535
536 inline EXTERN Int
IsAttachFunc(Functor f)537 IsAttachFunc (Functor f)
538 {
539 return (Int) (FALSE);
540 }
541
542
543
544
545 inline EXTERN Int IsAttachedTerm (Term);
546
547 inline EXTERN Int
IsAttachedTerm(Term t)548 IsAttachedTerm (Term t)
549 {
550 return (Int) (FALSE);
551 }
552
553
554
555
556 #endif
557
558 inline EXTERN int STD_PROTO (unify_extension, (Functor, CELL, CELL *, CELL));
559
560 EXTERN int STD_PROTO (unify_extension, (Functor, CELL, CELL *, CELL));
561
562 int STD_PROTO(Yap_gmp_tcmp_big_big,(Term, Term));
563
564 inline EXTERN int
unify_extension(Functor f,CELL d0,CELL * pt0,CELL d1)565 unify_extension (Functor f, CELL d0, CELL * pt0, CELL d1)
566 {
567 switch (BlobOfFunctor (f))
568 {
569 case db_ref_e:
570 return (d0 == d1);
571 case attvar_e:
572 return (d0 == d1);
573 case long_int_e:
574 return (pt0[1] == RepAppl (d1)[1]);
575 case big_int_e:
576 #ifdef USE_GMP
577 return (Yap_gmp_tcmp_big_big(d0,d1) == 0);
578 #else
579 return d0 == d1;
580 #endif /* USE_GMP */
581 case double_e:
582 {
583 CELL *pt1 = RepAppl (d1);
584 return (pt0[1] == pt1[1]
585 #if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
586 && pt0[2] == pt1[2]
587 #endif
588 );
589 }
590 }
591 return (FALSE);
592 }
593
594 static inline
Yap_IntP_key(CELL * pt)595 CELL Yap_IntP_key(CELL *pt)
596 {
597 #ifdef USE_GMP
598 if (((Functor)pt[-1] == FunctorBigInt)) {
599 MP_INT *b1 = Yap_BigIntOfTerm(AbsAppl(pt-1));
600 /* first cell in program */
601 CELL val = ((CELL *)(b1+1))[0];
602 return MkIntTerm(val & (MAX_ABS_INT-1));
603 }
604 #endif
605 return MkIntTerm(pt[0] & (MAX_ABS_INT-1));
606 }
607
608 static inline
Yap_Int_key(Term t)609 CELL Yap_Int_key(Term t)
610 {
611 return Yap_IntP_key(RepAppl(t)+1);
612 }
613
614 static inline
Yap_DoubleP_key(CELL * pt)615 CELL Yap_DoubleP_key(CELL *pt)
616 {
617 #if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
618 CELL val = pt[0]^pt[1];
619 #else
620 CELL val = pt[0];
621 #endif
622 return MkIntTerm(val & (MAX_ABS_INT-1));
623 }
624
625 static inline
Yap_Double_key(Term t)626 CELL Yap_Double_key(Term t)
627 {
628 return Yap_DoubleP_key(RepAppl(t)+1);
629 }
630
631