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: adtdefs.c *
12 * Last rev: *
13 * mods: *
14 * comments: abstract machine definitions *
15 * *
16 *************************************************************************/
17 #ifdef SCCS
18 static char SccsId[] = "%W% %G%";
19
20 #endif
21
22 #define ADTDEFS_C
23
24 #ifdef __SUNPRO_CC
25 #define inline
26 #endif
27
28 #include "Yap.h"
29 ADDR STD_PROTO(Yap_PreAllocCodeSpace, (void));
30 Prop STD_PROTO(PredPropByFunc,(Functor, Term));
31 Prop STD_PROTO(PredPropByAtom,(Atom, Term));
32 #include "Yatom.h"
33 #include "yapio.h"
34 #include <stdio.h>
35 #include <wchar.h>
36 #if HAVE_STRING_H
37 #include <string.h>
38 #endif
39
40 /* this routine must be run at least having a read lock on ae */
41 static Prop
GetFunctorProp(AtomEntry * ae,unsigned int arity)42 GetFunctorProp(AtomEntry *ae, unsigned int arity)
43 { /* look property list of atom a for kind */
44 FunctorEntry *pp;
45
46 pp = RepFunctorProp(ae->PropsOfAE);
47 while (!EndOfPAEntr(pp) &&
48 (!IsFunctorProperty(pp->KindOfPE) ||
49 pp->ArityOfFE != arity))
50 pp = RepFunctorProp(pp->NextOfPE);
51 return (AbsFunctorProp(pp));
52 }
53
54 /* vsc: We must guarantee that IsVarTerm(functor) returns true! */
55 static inline Functor
InlinedUnlockedMkFunctor(AtomEntry * ae,unsigned int arity)56 InlinedUnlockedMkFunctor(AtomEntry *ae, unsigned int arity)
57 {
58 FunctorEntry *p;
59 Prop p0;
60
61 p0 = GetFunctorProp(ae, arity);
62 if (p0 != NIL) {
63 return ((Functor) RepProp(p0));
64 }
65 p = (FunctorEntry *) Yap_AllocAtomSpace(sizeof(*p));
66 if (!p)
67 return NULL;
68 p->KindOfPE = FunctorProperty;
69 p->NameOfFE = AbsAtom(ae);
70 p->ArityOfFE = arity;
71 p->PropsOfFE = NIL;
72 p->NextOfPE = ae->PropsOfAE;
73 INIT_RWLOCK(p->FRWLock);
74 ae->PropsOfAE = AbsProp((PropEntry *) p);
75 return ((Functor) p);
76 }
77
78 Functor
Yap_UnlockedMkFunctor(AtomEntry * ae,unsigned int arity)79 Yap_UnlockedMkFunctor(AtomEntry *ae, unsigned int arity)
80 {
81 return(InlinedUnlockedMkFunctor(ae, arity));
82 }
83
84 /* vsc: We must guarantee that IsVarTerm(functor) returns true! */
85 Functor
Yap_MkFunctor(Atom ap,unsigned int arity)86 Yap_MkFunctor(Atom ap, unsigned int arity)
87 {
88 AtomEntry *ae = RepAtom(ap);
89 Functor f;
90
91 WRITE_LOCK(ae->ARWLock);
92 f = InlinedUnlockedMkFunctor(ae, arity);
93 WRITE_UNLOCK(ae->ARWLock);
94 return (f);
95 }
96
97 /* vsc: We must guarantee that IsVarTerm(functor) returns true! */
98 void
Yap_MkFunctorWithAddress(Atom ap,unsigned int arity,FunctorEntry * p)99 Yap_MkFunctorWithAddress(Atom ap, unsigned int arity, FunctorEntry *p)
100 {
101 AtomEntry *ae = RepAtom(ap);
102
103 WRITE_LOCK(ae->ARWLock);
104 p->KindOfPE = FunctorProperty;
105 p->NameOfFE = ap;
106 p->ArityOfFE = arity;
107 p->NextOfPE = RepAtom(ap)->PropsOfAE;
108 ae->PropsOfAE = AbsProp((PropEntry *) p);
109 WRITE_UNLOCK(ae->ARWLock);
110 }
111
112 inline static Atom
SearchInInvisible(char * atom)113 SearchInInvisible(char *atom)
114 {
115 AtomEntry *chain;
116
117 READ_LOCK(INVISIBLECHAIN.AERWLock);
118 chain = RepAtom(INVISIBLECHAIN.Entry);
119 while (!EndOfPAEntr(chain) && strcmp(chain->StrOfAE, atom) != 0) {
120 chain = RepAtom(chain->NextOfAE);
121 }
122 READ_UNLOCK(INVISIBLECHAIN.AERWLock);
123 if (EndOfPAEntr(chain))
124 return (NIL);
125 else
126 return(AbsAtom(chain));
127 }
128
129 static inline Atom
SearchAtom(unsigned char * p,Atom a)130 SearchAtom(unsigned char *p, Atom a) {
131 AtomEntry *ae;
132
133 /* search atom in chain */
134 while (a != NIL) {
135 ae = RepAtom(a);
136 if (strcmp(ae->StrOfAE, (const char *)p) == 0) {
137 return(a);
138 }
139 a = ae->NextOfAE;
140 }
141 return(NIL);
142 }
143
144 static inline Atom
SearchWideAtom(wchar_t * p,Atom a)145 SearchWideAtom(wchar_t *p, Atom a) {
146 AtomEntry *ae;
147
148 /* search atom in chain */
149 while (a != NIL) {
150 ae = RepAtom(a);
151 if (wcscmp((wchar_t *)ae->StrOfAE, p) == 0) {
152 return a;
153 }
154 a = ae->NextOfAE;
155 }
156 return(NIL);
157 }
158
159 static Atom
LookupAtom(char * atom)160 LookupAtom(char *atom)
161 { /* lookup atom in atom table */
162 register CELL hash;
163 register unsigned char *p;
164 Atom a, na;
165 AtomEntry *ae;
166
167 /* compute hash */
168 p = (unsigned char *)atom;
169 hash = HashFunction(p) % AtomHashTableSize;
170 /* we'll start by holding a read lock in order to avoid contention */
171 READ_LOCK(HashChain[hash].AERWLock);
172 a = HashChain[hash].Entry;
173 /* search atom in chain */
174 na = SearchAtom((unsigned char *)atom, a);
175 if (na != NIL) {
176 READ_UNLOCK(HashChain[hash].AERWLock);
177 return(na);
178 }
179 READ_UNLOCK(HashChain[hash].AERWLock);
180 /* we need a write lock */
181 WRITE_LOCK(HashChain[hash].AERWLock);
182 /* concurrent version of Yap, need to take care */
183 #if defined(YAPOR) || defined(THREADS)
184 if (a != HashChain[hash].Entry) {
185 a = HashChain[hash].Entry;
186 na = SearchAtom((unsigned char *)atom, a);
187 if (na != NIL) {
188 WRITE_UNLOCK(HashChain[hash].AERWLock);
189 return(na);
190 }
191 }
192 #endif
193 /* add new atom to start of chain */
194 ae = (AtomEntry *) Yap_AllocAtomSpace((sizeof *ae) + strlen(atom) + 1);
195 if (ae == NULL) {
196 WRITE_UNLOCK(HashChain[hash].AERWLock);
197 return NIL;
198 }
199 NOfAtoms++;
200 na = AbsAtom(ae);
201 ae->PropsOfAE = NIL;
202 if (ae->StrOfAE != atom)
203 strcpy(ae->StrOfAE, atom);
204 ae->NextOfAE = a;
205 HashChain[hash].Entry = na;
206 INIT_RWLOCK(ae->ARWLock);
207 WRITE_UNLOCK(HashChain[hash].AERWLock);
208 if (NOfAtoms > 2*AtomHashTableSize) {
209 Yap_signal(YAP_CDOVF_SIGNAL);
210 }
211 return na;
212 }
213
214 static Atom
LookupWideAtom(wchar_t * atom)215 LookupWideAtom(wchar_t *atom)
216 { /* lookup atom in atom table */
217 CELL hash;
218 wchar_t *p;
219 Atom a, na;
220 AtomEntry *ae;
221 UInt sz;
222 WideAtomEntry *wae;
223
224 /* compute hash */
225 p = atom;
226 hash = WideHashFunction(p) % WideAtomHashTableSize;
227 /* we'll start by holding a read lock in order to avoid contention */
228 READ_LOCK(WideHashChain[hash].AERWLock);
229 a = WideHashChain[hash].Entry;
230 /* search atom in chain */
231 na = SearchWideAtom(atom, a);
232 if (na != NIL) {
233 READ_UNLOCK(WideHashChain[hash].AERWLock);
234 return(na);
235 }
236 READ_UNLOCK(WideHashChain[hash].AERWLock);
237 /* we need a write lock */
238 WRITE_LOCK(WideHashChain[hash].AERWLock);
239 /* concurrent version of Yap, need to take care */
240 #if defined(YAPOR) || defined(THREADS)
241 if (a != WideHashChain[hash].Entry) {
242 a = WideHashChain[hash].Entry;
243 na = SearchWideAtom(atom, a);
244 if (na != NIL) {
245 WRITE_UNLOCK(WideHashChain[hash].AERWLock);
246 return na;
247 }
248 }
249 #endif
250 /* add new atom to start of chain */
251 sz = wcslen(atom);
252 ae = (AtomEntry *) Yap_AllocAtomSpace(sizeof(AtomEntry) + sizeof(wchar_t)*(sz + 1)+sizeof(WideAtomEntry));
253 if (ae == NULL) {
254 WRITE_UNLOCK(WideHashChain[hash].AERWLock);
255 return NIL;
256 }
257 wae = (WideAtomEntry *)(ae->StrOfAE+sizeof(wchar_t)*(sz + 1));
258 na = AbsAtom(ae);
259 ae->PropsOfAE = AbsWideAtomProp(wae);
260 wae->NextOfPE = NIL;
261 wae->KindOfPE = WideAtomProperty;
262 wae->SizeOfAtom = sz;
263 if (ae->StrOfAE != (char *)atom)
264 wcscpy((wchar_t *)(ae->StrOfAE), atom);
265 NOfAtoms++;
266 ae->NextOfAE = a;
267 WideHashChain[hash].Entry = na;
268 INIT_RWLOCK(ae->ARWLock);
269 WRITE_UNLOCK(WideHashChain[hash].AERWLock);
270 if (NOfWideAtoms > 2*WideAtomHashTableSize) {
271 Yap_signal(YAP_CDOVF_SIGNAL);
272 }
273 return na;
274 }
275
276 Atom
Yap_LookupMaybeWideAtom(wchar_t * atom)277 Yap_LookupMaybeWideAtom(wchar_t *atom)
278 { /* lookup atom in atom table */
279 wchar_t *p = atom, c;
280 size_t len = 0;
281 char *ptr, *ptr0;
282 Atom at;
283
284 while ((c = *p++)) {
285 if (c > 255) return LookupWideAtom(atom);
286 len++;
287 }
288 /* not really a wide atom */
289 p = atom;
290 ptr0 = ptr = Yap_AllocCodeSpace(len+1);
291 if (!ptr)
292 return NIL;
293 while ((*ptr++ = *p++));
294 at = LookupAtom(ptr0);
295 Yap_FreeCodeSpace(ptr0);
296 return at;
297 }
298
299 Atom
Yap_LookupMaybeWideAtomWithLength(wchar_t * atom,size_t len)300 Yap_LookupMaybeWideAtomWithLength(wchar_t *atom, size_t len)
301 { /* lookup atom in atom table */
302 wchar_t *p = atom, c;
303 size_t len0 = 0;
304 Atom at;
305 int wide = FALSE;
306
307 while ((c = *p++)) {
308 if (c > 255) wide = TRUE;
309 len0++;
310 if (len0 == len) break;
311 }
312 if (p[0] == '\0' && wide) return LookupWideAtom(atom);
313 else if (wide) {
314 wchar_t *ptr, *ptr0;
315 p = atom;
316 ptr0 = ptr = (wchar_t *)Yap_AllocCodeSpace(sizeof(wchar_t)*(len+1));
317 if (!ptr)
318 return NIL;
319 while (len--) {*ptr++ = *p++;}
320 ptr[0] = '\0';
321 at = LookupWideAtom(ptr0);
322 Yap_FreeCodeSpace((char *)ptr0);
323 return at;
324 } else {
325 char *ptr, *ptr0;
326 /* not really a wide atom */
327 p = atom;
328 ptr0 = ptr = Yap_AllocCodeSpace(len+1);
329 if (!ptr)
330 return NIL;
331 while (len--) {*ptr++ = *p++;}
332 ptr[0] = '\0';
333 at = LookupAtom(ptr0);
334 Yap_FreeCodeSpace(ptr0);
335 return at;
336 }
337 }
338
339 Atom
Yap_LookupAtom(char * atom)340 Yap_LookupAtom(char *atom)
341 { /* lookup atom in atom table */
342 return LookupAtom(atom);
343 }
344
345 Atom
Yap_LookupWideAtom(wchar_t * atom)346 Yap_LookupWideAtom(wchar_t *atom)
347 { /* lookup atom in atom table */
348 return LookupWideAtom(atom);
349 }
350
351 Atom
Yap_FullLookupAtom(char * atom)352 Yap_FullLookupAtom(char *atom)
353 { /* lookup atom in atom table */
354 Atom t;
355
356 if ((t = SearchInInvisible(atom)) != NIL) {
357 return (t);
358 }
359 return(LookupAtom(atom));
360 }
361
362 void
Yap_LookupAtomWithAddress(char * atom,AtomEntry * ae)363 Yap_LookupAtomWithAddress(char *atom, AtomEntry *ae)
364 { /* lookup atom in atom table */
365 register CELL hash;
366 register unsigned char *p;
367 Atom a;
368
369 /* compute hash */
370 p = (unsigned char *)atom;
371 hash = HashFunction(p) % AtomHashTableSize;
372 /* ask for a WRITE lock because it is highly unlikely we shall find anything */
373 WRITE_LOCK(HashChain[hash].AERWLock);
374 a = HashChain[hash].Entry;
375 /* search atom in chain */
376 if (SearchAtom(p, a) != NIL) {
377 Yap_Error(INTERNAL_ERROR,TermNil,"repeated initialisation for atom %s", ae);
378 WRITE_UNLOCK(HashChain[hash].AERWLock);
379 return;
380 }
381 /* add new atom to start of chain */
382 NOfAtoms++;
383 ae->NextOfAE = a;
384 HashChain[hash].Entry = AbsAtom(ae);
385 ae->PropsOfAE = NIL;
386 strcpy(ae->StrOfAE, atom);
387 INIT_RWLOCK(ae->ARWLock);
388 WRITE_UNLOCK(HashChain[hash].AERWLock);
389 }
390
391 void
Yap_ReleaseAtom(Atom atom)392 Yap_ReleaseAtom(Atom atom)
393 { /* Releases an atom from the hash chain */
394 register Int hash;
395 register unsigned char *p;
396 AtomEntry *inChain;
397 AtomEntry *ap = RepAtom(atom);
398 char *name = ap->StrOfAE;
399
400 /* compute hash */
401 p = (unsigned char *)name;
402 hash = HashFunction(p) % AtomHashTableSize;
403 WRITE_LOCK(HashChain[hash].AERWLock);
404 if (HashChain[hash].Entry == atom) {
405 NOfAtoms--;
406 HashChain[hash].Entry = ap->NextOfAE;
407 WRITE_UNLOCK(HashChain[hash].AERWLock);
408 return;
409 }
410 /* else */
411 inChain = RepAtom(HashChain[hash].Entry);
412 while (inChain->NextOfAE != atom)
413 inChain = RepAtom(inChain->NextOfAE);
414 WRITE_LOCK(inChain->ARWLock);
415 inChain->NextOfAE = ap->NextOfAE;
416 WRITE_UNLOCK(inChain->ARWLock);
417 WRITE_UNLOCK(HashChain[hash].AERWLock);
418 }
419
420 static Prop
GetAPropHavingLock(AtomEntry * ae,PropFlags kind)421 GetAPropHavingLock(AtomEntry *ae, PropFlags kind)
422 { /* look property list of atom a for kind */
423 PropEntry *pp;
424
425 pp = RepProp(ae->PropsOfAE);
426 while (!EndOfPAEntr(pp) && pp->KindOfPE != kind)
427 pp = RepProp(pp->NextOfPE);
428 return (AbsProp(pp));
429 }
430
431 Prop
Yap_GetAPropHavingLock(AtomEntry * ae,PropFlags kind)432 Yap_GetAPropHavingLock(AtomEntry *ae, PropFlags kind)
433 { /* look property list of atom a for kind */
434 return GetAPropHavingLock(ae,kind);
435 }
436
437 static Prop
GetAProp(Atom a,PropFlags kind)438 GetAProp(Atom a, PropFlags kind)
439 { /* look property list of atom a for kind */
440 AtomEntry *ae = RepAtom(a);
441 Prop out;
442
443 READ_LOCK(ae->ARWLock);
444 out = GetAPropHavingLock(ae, kind);
445 READ_UNLOCK(ae->ARWLock);
446 return (out);
447 }
448
449 Prop
Yap_GetAProp(Atom a,PropFlags kind)450 Yap_GetAProp(Atom a, PropFlags kind)
451 { /* look property list of atom a for kind */
452 return GetAProp(a,kind);
453 }
454
455 OpEntry *
Yap_GetOpPropForAModuleHavingALock(Atom a,Term mod)456 Yap_GetOpPropForAModuleHavingALock(Atom a, Term mod)
457 { /* look property list of atom a for kind */
458 AtomEntry *ae = RepAtom(a);
459 PropEntry *pp;
460
461 pp = RepProp(ae->PropsOfAE);
462 while (!EndOfPAEntr(pp) &&
463 (pp->KindOfPE != OpProperty ||
464 ((OpEntry *)pp)->OpModule != mod))
465 pp = RepProp(pp->NextOfPE);
466 if (EndOfPAEntr(pp)) {
467 return NULL;
468 }
469 return (OpEntry *)pp;
470 }
471
472 int
Yap_HasOp(Atom a)473 Yap_HasOp(Atom a)
474 { /* look property list of atom a for kind */
475 AtomEntry *ae = RepAtom(a);
476 PropEntry *pp;
477
478 READ_LOCK(ae->ARWLock);
479 pp = RepProp(ae->PropsOfAE);
480 while (!EndOfPAEntr(pp) &&
481 ( pp->KindOfPE != OpProperty))
482 pp = RepProp(pp->NextOfPE);
483 READ_UNLOCK(ae->ARWLock);
484 if (EndOfPAEntr(pp)) {
485 return FALSE;
486 } else {
487 return TRUE;
488 }
489 }
490
491 OpEntry *
Yap_GetOpProp(Atom a,op_type type)492 Yap_GetOpProp(Atom a, op_type type)
493 { /* look property list of atom a for kind */
494 AtomEntry *ae = RepAtom(a);
495 PropEntry *pp;
496 OpEntry *info = NULL;
497
498 READ_LOCK(ae->ARWLock);
499 pp = RepProp(ae->PropsOfAE);
500 while (!EndOfPAEntr(pp) &&
501 ( pp->KindOfPE != OpProperty ||
502 ((OpEntry *)pp)->OpModule != CurrentModule))
503 pp = RepProp(pp->NextOfPE);
504 if ((info = (OpEntry *)pp)) {
505 if ((type == INFIX_OP && !info->Infix) ||
506 (type == POSFIX_OP && !info->Posfix) ||
507 (type == PREFIX_OP && !info->Prefix))
508 pp = RepProp(NIL);
509 }
510 if (EndOfPAEntr(pp)) {
511 pp = RepProp(ae->PropsOfAE);
512 while (!EndOfPAEntr(pp) &&
513 ( pp->KindOfPE != OpProperty ||
514 ((OpEntry *)pp)->OpModule != PROLOG_MODULE))
515 pp = RepProp(pp->NextOfPE);
516 if ((info = (OpEntry *)pp)) {
517 if ((type == INFIX_OP && !info->Infix) ||
518 (type == POSFIX_OP && !info->Posfix) ||
519 (type == PREFIX_OP && !info->Prefix))
520 pp = RepProp(NIL);
521 }
522 }
523 if (!info) {
524 READ_UNLOCK(ae->ARWLock);
525 return NULL;
526 } else {
527 READ_LOCK(info->OpRWLock);
528 READ_UNLOCK(ae->ARWLock);
529 return info;
530 }
531 }
532
533
534 inline static Prop
GetPredPropByAtomHavingLock(AtomEntry * ae,Term cur_mod)535 GetPredPropByAtomHavingLock(AtomEntry* ae, Term cur_mod)
536 /* get predicate entry for ap/arity; create it if neccessary. */
537 {
538 Prop p0;
539
540 p0 = ae->PropsOfAE;
541 while (p0) {
542 PredEntry *pe = RepPredProp(p0);
543 if ( pe->KindOfPE == PEProp &&
544 (pe->ModuleOfPred == cur_mod || !pe->ModuleOfPred)) {
545 return(p0);
546 #if THREADS
547 /* Thread Local Predicates */
548 if (pe->PredFlags & ThreadLocalPredFlag) {
549 return AbsPredProp(Yap_GetThreadPred(pe));
550 }
551 #endif
552 }
553 p0 = pe->NextOfPE;
554 }
555 return(NIL);
556 }
557
558 Prop
Yap_GetPredPropByAtom(Atom at,Term cur_mod)559 Yap_GetPredPropByAtom(Atom at, Term cur_mod)
560 /* get predicate entry for ap/arity; create it if neccessary. */
561 {
562 Prop p0;
563 AtomEntry *ae = RepAtom(at);
564
565 READ_LOCK(ae->ARWLock);
566 p0 = GetPredPropByAtomHavingLock(ae, cur_mod);
567 READ_UNLOCK(ae->ARWLock);
568 return(p0);
569 }
570
571
572 inline static Prop
GetPredPropByAtomHavingLockInThisModule(AtomEntry * ae,Term cur_mod)573 GetPredPropByAtomHavingLockInThisModule(AtomEntry* ae, Term cur_mod)
574 /* get predicate entry for ap/arity; create it if neccessary. */
575 {
576 Prop p0;
577
578 p0 = ae->PropsOfAE;
579 while (p0) {
580 PredEntry *pe = RepPredProp(p0);
581 if ( pe->KindOfPE == PEProp && pe->ModuleOfPred == cur_mod ) {
582 #if THREADS
583 /* Thread Local Predicates */
584 if (pe->PredFlags & ThreadLocalPredFlag) {
585 return AbsPredProp(Yap_GetThreadPred(pe));
586 }
587 #endif
588 return(p0);
589 }
590 p0 = pe->NextOfPE;
591 }
592 return(NIL);
593 }
594
595 Prop
Yap_GetPredPropByAtomInThisModule(Atom at,Term cur_mod)596 Yap_GetPredPropByAtomInThisModule(Atom at, Term cur_mod)
597 /* get predicate entry for ap/arity; create it if neccessary. */
598 {
599 Prop p0;
600 AtomEntry *ae = RepAtom(at);
601
602 READ_LOCK(ae->ARWLock);
603 p0 = GetPredPropByAtomHavingLockInThisModule(ae, cur_mod);
604 READ_UNLOCK(ae->ARWLock);
605 return(p0);
606 }
607
608
609 Prop
Yap_GetPredPropByFunc(Functor f,Term cur_mod)610 Yap_GetPredPropByFunc(Functor f, Term cur_mod)
611 /* get predicate entry for ap/arity; */
612 {
613 Prop p0;
614
615 READ_LOCK(f->FRWLock);
616
617 p0 = GetPredPropByFuncHavingLock(f, cur_mod);
618 READ_UNLOCK(f->FRWLock);
619 return (p0);
620 }
621
622 Prop
Yap_GetPredPropByFuncInThisModule(Functor f,Term cur_mod)623 Yap_GetPredPropByFuncInThisModule(Functor f, Term cur_mod)
624 /* get predicate entry for ap/arity; */
625 {
626 Prop p0;
627
628 READ_LOCK(f->FRWLock);
629 p0 = GetPredPropByFuncHavingLock(f, cur_mod);
630 READ_UNLOCK(f->FRWLock);
631 return (p0);
632 }
633
634 Prop
Yap_GetPredPropHavingLock(Atom ap,unsigned int arity,Term mod)635 Yap_GetPredPropHavingLock(Atom ap, unsigned int arity, Term mod)
636 /* get predicate entry for ap/arity; */
637 {
638 Prop p0;
639 AtomEntry *ae = RepAtom(ap);
640 Functor f;
641
642 if (arity == 0) {
643 GetPredPropByAtomHavingLock(ae, mod);
644 }
645 f = InlinedUnlockedMkFunctor(ae, arity);
646 READ_LOCK(f->FRWLock);
647 p0 = GetPredPropByFuncHavingLock(f, mod);
648 READ_UNLOCK(f->FRWLock);
649 return (p0);
650 }
651
652 /* get expression entry for at/arity; */
653 Prop
Yap_GetExpProp(Atom at,unsigned int arity)654 Yap_GetExpProp(Atom at, unsigned int arity)
655 {
656 Prop p0;
657 AtomEntry *ae = RepAtom(at);
658 ExpEntry *p;
659
660 READ_LOCK(ae->ARWLock);
661 p = RepExpProp(p0 = ae->PropsOfAE);
662 while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
663 p = RepExpProp(p0 = p->NextOfPE);
664 READ_UNLOCK(ae->ARWLock);
665 return (p0);
666 }
667
668 /* get expression entry for at/arity, at is already locked; */
669 Prop
Yap_GetExpPropHavingLock(AtomEntry * ae,unsigned int arity)670 Yap_GetExpPropHavingLock(AtomEntry *ae, unsigned int arity)
671 {
672 Prop p0;
673 ExpEntry *p;
674
675 p = RepExpProp(p0 = ae->PropsOfAE);
676 while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
677 p = RepExpProp(p0 = p->NextOfPE);
678
679 return (p0);
680 }
681
682 static int
ExpandPredHash(void)683 ExpandPredHash(void)
684 {
685 UInt new_size = PredHashTableSize+PredHashIncrement;
686 PredEntry **oldp = PredHash;
687 PredEntry **np = (PredEntry **) Yap_AllocAtomSpace(sizeof(PredEntry **)*new_size);
688 UInt i;
689
690 if (!np) {
691 return FALSE;
692 }
693 for (i = 0; i < new_size; i++) {
694 np[i] = NULL;
695 }
696 for (i = 0; i < PredHashTableSize; i++) {
697 PredEntry *p = PredHash[i];
698
699 while (p) {
700 Prop nextp = p->NextOfPE;
701 UInt hsh = PRED_HASH(p->FunctorOfPred, p->ModuleOfPred, new_size);
702 p->NextOfPE = AbsPredProp(np[hsh]);
703 np[hsh] = p;
704 p = RepPredProp(nextp);
705 }
706 }
707 PredHashTableSize = new_size;
708 PredHash = np;
709 Yap_FreeAtomSpace((ADDR)oldp);
710 return TRUE;
711 }
712
713 /* fe is supposed to be locked */
714 Prop
Yap_NewPredPropByFunctor(FunctorEntry * fe,Term cur_mod)715 Yap_NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod)
716 {
717 PredEntry *p = (PredEntry *) Yap_AllocAtomSpace(sizeof(*p));
718
719 if (p == NULL) {
720 WRITE_UNLOCK(fe->FRWLock);
721 return NULL;
722 }
723 if (cur_mod == TermProlog)
724 p->ModuleOfPred = 0L;
725 else
726 p->ModuleOfPred = cur_mod;
727 if (fe->PropsOfFE) {
728 UInt hsh = PRED_HASH(fe, cur_mod, PredHashTableSize);
729
730 WRITE_LOCK(PredHashRWLock);
731 if (10*(PredsInHashTable+1) > 6*PredHashTableSize) {
732 if (!ExpandPredHash()) {
733 Yap_FreeCodeSpace((ADDR)p);
734 WRITE_UNLOCK(PredHashRWLock);
735 WRITE_UNLOCK(fe->FRWLock);
736 return NULL;
737 }
738 /* retry hashing */
739 hsh = PRED_HASH(fe, cur_mod, PredHashTableSize);
740 }
741 PredsInHashTable++;
742 if (p->ModuleOfPred == 0L) {
743 PredEntry *pe = RepPredProp(fe->PropsOfFE);
744
745 hsh = PRED_HASH(fe, pe->ModuleOfPred, PredHashTableSize);
746 /* should be the first one */
747 pe->NextOfPE = AbsPredProp(PredHash[hsh]);
748 PredHash[hsh] = pe;
749 fe->PropsOfFE = AbsPredProp(p);
750 } else {
751 p->NextOfPE = AbsPredProp(PredHash[hsh]);
752 PredHash[hsh] = p;
753 }
754 WRITE_UNLOCK(PredHashRWLock);
755 /* make sure that we have something here: note that this is not a valid pointer!! */
756 RepPredProp(fe->PropsOfFE)->NextOfPE = fe->PropsOfFE;
757 } else {
758 fe->PropsOfFE = AbsPredProp(p);
759 p->NextOfPE = NIL;
760 }
761 INIT_LOCK(p->PELock);
762 p->KindOfPE = PEProp;
763 p->ArityOfPE = fe->ArityOfFE;
764 p->cs.p_code.FirstClause = p->cs.p_code.LastClause = NULL;
765 p->cs.p_code.NOfClauses = 0;
766 p->PredFlags = 0L;
767 p->src.OwnerFile = AtomNil;
768 p->OpcodeOfPred = UNDEF_OPCODE;
769 p->CodeOfPred = p->cs.p_code.TrueCodeOfPred = (yamop *)(&(p->OpcodeOfPred));
770 p->cs.p_code.ExpandCode = EXPAND_OP_CODE;
771 p->TimeStampOfPred = 0L;
772 p->LastCallOfPred = LUCALL_ASSERT;
773 if (cur_mod == TermProlog)
774 p->ModuleOfPred = 0L;
775 else
776 p->ModuleOfPred = cur_mod;
777 Yap_NewModulePred(cur_mod, p);
778 INIT_LOCK(p->StatisticsForPred.lock);
779 p->StatisticsForPred.NOfEntries = 0;
780 p->StatisticsForPred.NOfHeadSuccesses = 0;
781 p->StatisticsForPred.NOfRetries = 0;
782 #ifdef TABLING
783 p->TableOfPred = NULL;
784 #endif /* TABLING */
785 #ifdef BEAM
786 p->beamTable = NULL;
787 #endif /* BEAM */
788 /* careful that they don't cross MkFunctor */
789 if (PRED_GOAL_EXPANSION_FUNC) {
790 if (fe->PropsOfFE &&
791 (RepPredProp(fe->PropsOfFE)->PredFlags & GoalExPredFlag)) {
792 p->PredFlags |= GoalExPredFlag;
793 }
794 }
795 p->FunctorOfPred = fe;
796 WRITE_UNLOCK(fe->FRWLock);
797 #ifdef LOW_PROF
798 if (ProfilerOn &&
799 Yap_OffLineProfiler) {
800 Yap_inform_profiler_of_clause((yamop *)&(p->OpcodeOfPred), (yamop *)(&(p->OpcodeOfPred)+1), p, 1);
801 if (!(p->PredFlags & (CPredFlag|AsmPredFlag))) {
802 Yap_inform_profiler_of_clause((yamop *)&(p->cs.p_code.ExpandCode), (yamop *)(&(p->cs.p_code.ExpandCode)+1), p, 1);
803 }
804 }
805 #endif /* LOW_PROF */
806 return AbsPredProp(p);
807 }
808
809 #if THREADS
810 Prop
Yap_NewThreadPred(PredEntry * ap)811 Yap_NewThreadPred(PredEntry *ap)
812 {
813 PredEntry *p = (PredEntry *) Yap_AllocAtomSpace(sizeof(*p));
814
815 if (p == NULL) {
816 return NIL;
817 }
818 INIT_LOCK(p->PELock);
819 p->KindOfPE = PEProp;
820 p->ArityOfPE = ap->ArityOfPE;
821 p->cs.p_code.FirstClause = p->cs.p_code.LastClause = NULL;
822 p->cs.p_code.NOfClauses = 0;
823 p->PredFlags = ap->PredFlags & ~(IndexedPredFlag|SpiedPredFlag);
824 p->src.OwnerFile = ap->src.OwnerFile;
825 p->OpcodeOfPred = UNDEF_OPCODE;
826 p->CodeOfPred = p->cs.p_code.TrueCodeOfPred = (yamop *)(&(p->OpcodeOfPred));
827 p->cs.p_code.ExpandCode = EXPAND_OP_CODE;
828 p->ModuleOfPred = ap->ModuleOfPred;
829 p->NextPredOfModule = NULL;
830 p->TimeStampOfPred = 0L;
831 p->LastCallOfPred = LUCALL_ASSERT;
832 INIT_LOCK(p->StatisticsForPred.lock);
833 p->StatisticsForPred.NOfEntries = 0;
834 p->StatisticsForPred.NOfHeadSuccesses = 0;
835 p->StatisticsForPred.NOfRetries = 0;
836 #ifdef TABLING
837 p->TableOfPred = NULL;
838 #endif /* TABLING */
839 #ifdef BEAM
840 p->beamTable = NULL;
841 #endif
842 /* careful that they don't cross MkFunctor */
843 p->NextOfPE = AbsPredProp(MY_ThreadHandle.local_preds);
844 MY_ThreadHandle.local_preds = p;
845 p->FunctorOfPred = ap->FunctorOfPred;
846 #ifdef LOW_PROF
847 if (ProfilerOn &&
848 Yap_OffLineProfiler) {
849 Yap_inform_profiler_of_clause((yamop *)&(p->OpcodeOfPred), (yamop *)(&(p->OpcodeOfPred)+1), p, 1);
850 if (!(p->PredFlags & (CPredFlag|AsmPredFlag))) {
851 Yap_inform_profiler_of_clause((yamop *)&(p->cs.p_code.ExpandCode), (yamop *)(&(p->cs.p_code.ExpandCode)+1), p, 1);
852 }
853 }
854 #endif /* LOW_PROF */
855 return AbsPredProp(p);
856 }
857 #endif
858
859 Prop
Yap_NewPredPropByAtom(AtomEntry * ae,Term cur_mod)860 Yap_NewPredPropByAtom(AtomEntry *ae, Term cur_mod)
861 {
862 Prop p0;
863 PredEntry *p = (PredEntry *) Yap_AllocAtomSpace(sizeof(*p));
864
865 /* Printf("entering %s:%s/0\n", RepAtom(AtomOfTerm(cur_mod))->StrOfAE, ae->StrOfAE); */
866
867 if (p == NULL) {
868 WRITE_UNLOCK(ae->ARWLock);
869 return NIL;
870 }
871 INIT_LOCK(p->PELock);
872 p->KindOfPE = PEProp;
873 p->ArityOfPE = 0;
874 p->cs.p_code.FirstClause = p->cs.p_code.LastClause = NULL;
875 p->cs.p_code.NOfClauses = 0;
876 p->PredFlags = 0L;
877 p->src.OwnerFile = AtomNil;
878 p->OpcodeOfPred = UNDEF_OPCODE;
879 p->cs.p_code.ExpandCode = EXPAND_OP_CODE;
880 p->CodeOfPred = p->cs.p_code.TrueCodeOfPred = (yamop *)(&(p->OpcodeOfPred));
881 if (cur_mod == TermProlog)
882 p->ModuleOfPred = 0;
883 else
884 p->ModuleOfPred = cur_mod;
885 Yap_NewModulePred(cur_mod, p);
886 INIT_LOCK(p->StatisticsForPred.lock);
887 p->StatisticsForPred.NOfEntries = 0;
888 p->StatisticsForPred.NOfHeadSuccesses = 0;
889 p->StatisticsForPred.NOfRetries = 0;
890 p->TimeStampOfPred = 0L;
891 p->LastCallOfPred = LUCALL_ASSERT;
892 #ifdef TABLING
893 p->TableOfPred = NULL;
894 #endif /* TABLING */
895 #ifdef BEAM
896 p->beamTable = NULL;
897 #endif
898 /* careful that they don't cross MkFunctor */
899 p->NextOfPE = ae->PropsOfAE;
900 if (PRED_GOAL_EXPANSION_FUNC) {
901 Prop p1 = ae->PropsOfAE;
902
903 while (p1) {
904 PredEntry *pe = RepPredProp(p1);
905
906 if (pe->KindOfPE == PEProp) {
907 if (pe->PredFlags & GoalExPredFlag) {
908 p->PredFlags |= GoalExPredFlag;
909 }
910 break;
911 }
912 p1 = pe->NextOfPE;
913 }
914 }
915 ae->PropsOfAE = p0 = AbsPredProp(p);
916 p->FunctorOfPred = (Functor)AbsAtom(ae);
917 WRITE_UNLOCK(ae->ARWLock);
918 #ifdef LOW_PROF
919 if (ProfilerOn &&
920 Yap_OffLineProfiler) {
921 Yap_inform_profiler_of_clause((yamop *)&(p->OpcodeOfPred), (yamop *)(&(p->OpcodeOfPred)+1), p, 1);
922 if (!(p->PredFlags & (CPredFlag|AsmPredFlag))) {
923 Yap_inform_profiler_of_clause((yamop *)&(p->cs.p_code.ExpandCode), (yamop *)(&(p->cs.p_code.ExpandCode)+1), p, 1);
924 }
925 }
926 #endif /* LOW_PROF */
927 return p0;
928 }
929
930 Prop
Yap_PredPropByFunctorNonThreadLocal(Functor f,Term cur_mod)931 Yap_PredPropByFunctorNonThreadLocal(Functor f, Term cur_mod)
932 /* get predicate entry for ap/arity; create it if neccessary. */
933 {
934 PredEntry *p;
935
936 WRITE_LOCK(f->FRWLock);
937 if (!(p = RepPredProp(f->PropsOfFE)))
938 return Yap_NewPredPropByFunctor(f,cur_mod);
939
940 if ((p->ModuleOfPred == cur_mod || !(p->ModuleOfPred))) {
941 WRITE_UNLOCK(f->FRWLock);
942 return AbsPredProp(p);
943 }
944 if (p->NextOfPE) {
945 UInt hash = PRED_HASH(f,cur_mod,PredHashTableSize);
946 READ_LOCK(PredHashRWLock);
947 p = PredHash[hash];
948
949 while (p) {
950 if (p->FunctorOfPred == f &&
951 p->ModuleOfPred == cur_mod)
952 {
953 READ_UNLOCK(PredHashRWLock);
954 WRITE_UNLOCK(f->FRWLock);
955 return AbsPredProp(p);
956 }
957 p = RepPredProp(p->NextOfPE);
958 }
959 READ_UNLOCK(PredHashRWLock);
960 }
961 return Yap_NewPredPropByFunctor(f,cur_mod);
962 }
963
964 Prop
Yap_PredPropByAtomNonThreadLocal(Atom at,Term cur_mod)965 Yap_PredPropByAtomNonThreadLocal(Atom at, Term cur_mod)
966 /* get predicate entry for ap/arity; create it if neccessary. */
967 {
968 Prop p0;
969 AtomEntry *ae = RepAtom(at);
970
971 WRITE_LOCK(ae->ARWLock);
972 p0 = ae->PropsOfAE;
973 while (p0) {
974 PredEntry *pe = RepPredProp(p0);
975 if ( pe->KindOfPE == PEProp &&
976 (pe->ModuleOfPred == cur_mod || !pe->ModuleOfPred)) {
977 WRITE_UNLOCK(ae->ARWLock);
978 return(p0);
979 }
980 p0 = pe->NextOfPE;
981 }
982 return Yap_NewPredPropByAtom(ae,cur_mod);
983 }
984
985
986
987 Term
Yap_GetValue(Atom a)988 Yap_GetValue(Atom a)
989 {
990 Prop p0 = GetAProp(a, ValProperty);
991 Term out;
992
993 if (p0 == NIL)
994 return (TermNil);
995 READ_LOCK(RepValProp(p0)->VRWLock);
996 out = RepValProp(p0)->ValueOfVE;
997 if (IsApplTerm(out)) {
998 Functor f = FunctorOfTerm(out);
999 if (f == FunctorDouble) {
1000 out = MkFloatTerm(FloatOfTerm(out));
1001 } else if (f == FunctorLongInt) {
1002 out = MkLongIntTerm(LongIntOfTerm(out));
1003 }
1004 #ifdef USE_GMP
1005 else {
1006 out = Yap_MkBigIntTerm(Yap_BigIntOfTerm(out));
1007 }
1008 #endif
1009 }
1010 READ_UNLOCK(RepValProp(p0)->VRWLock);
1011 return (out);
1012 }
1013
1014 void
Yap_PutValue(Atom a,Term v)1015 Yap_PutValue(Atom a, Term v)
1016 {
1017 AtomEntry *ae = RepAtom(a);
1018 Prop p0;
1019 ValEntry *p;
1020 Term t0;
1021
1022 WRITE_LOCK(ae->ARWLock);
1023 p0 = GetAPropHavingLock(ae, ValProperty);
1024 if (p0 != NIL) {
1025 p = RepValProp(p0);
1026 WRITE_LOCK(p->VRWLock);
1027 WRITE_UNLOCK(ae->ARWLock);
1028 } else {
1029 p = (ValEntry *) Yap_AllocAtomSpace(sizeof(ValEntry));
1030 if (p == NULL) {
1031 WRITE_UNLOCK(ae->ARWLock);
1032 return;
1033 }
1034 p->NextOfPE = RepAtom(a)->PropsOfAE;
1035 RepAtom(a)->PropsOfAE = AbsValProp(p);
1036 p->KindOfPE = ValProperty;
1037 p->ValueOfVE = TermNil;
1038 /* take care that the lock for the property will be inited even
1039 if someone else searches for the property */
1040 INIT_RWLOCK(p->VRWLock);
1041 WRITE_LOCK(p->VRWLock);
1042 WRITE_UNLOCK(ae->ARWLock);
1043 }
1044 t0 = p->ValueOfVE;
1045 if (IsFloatTerm(v)) {
1046 /* store a float in code space, so that we can access the property */
1047 union {
1048 Float f;
1049 CELL ar[sizeof(Float) / sizeof(CELL)];
1050 } un;
1051 CELL *pt, *iptr;
1052 unsigned int i;
1053
1054 un.f = FloatOfTerm(v);
1055 if (IsFloatTerm(t0)) {
1056 pt = RepAppl(t0);
1057 } else {
1058 if (IsApplTerm(t0)) {
1059 Yap_FreeCodeSpace((char *) (RepAppl(t0)));
1060 }
1061 pt = (CELL *) Yap_AllocAtomSpace(sizeof(CELL)*(1 + 2*sizeof(Float)/sizeof(CELL)));
1062 if (pt == NULL) {
1063 WRITE_UNLOCK(ae->ARWLock);
1064 return;
1065 }
1066 p->ValueOfVE = AbsAppl(pt);
1067 pt[0] = (CELL)FunctorDouble;
1068 }
1069
1070 iptr = pt+1;
1071 for (i = 0; i < sizeof(Float) / sizeof(CELL); i++) {
1072 *iptr++ = (CELL)un.ar[i];
1073 }
1074 } else if (IsLongIntTerm(v)) {
1075 CELL *pt;
1076 Int val = LongIntOfTerm(v);
1077
1078 if (IsLongIntTerm(t0)) {
1079 pt = RepAppl(t0);
1080 } else {
1081 if (IsApplTerm(t0)) {
1082 Yap_FreeCodeSpace((char *) (RepAppl(t0)));
1083 }
1084 pt = (CELL *) Yap_AllocAtomSpace(2*sizeof(CELL));
1085 if (pt == NULL) {
1086 WRITE_UNLOCK(ae->ARWLock);
1087 return;
1088 }
1089 p->ValueOfVE = AbsAppl(pt);
1090 pt[0] = (CELL)FunctorLongInt;
1091 }
1092 pt[1] = (CELL)val;
1093 #ifdef USE_GMP
1094 } else if (IsBigIntTerm(v)) {
1095 CELL *ap = RepAppl(v);
1096 Int sz =
1097 sizeof(MP_INT)+sizeof(CELL)+
1098 (((MP_INT *)(ap+1))->_mp_alloc*sizeof(mp_limb_t));
1099 CELL *pt = (CELL *) Yap_AllocAtomSpace(sz);
1100
1101 if (pt == NULL) {
1102 WRITE_UNLOCK(ae->ARWLock);
1103 return;
1104 }
1105 if (IsApplTerm(t0)) {
1106 Yap_FreeCodeSpace((char *) RepAppl(t0));
1107 }
1108 memcpy((void *)pt, (void *)ap, sz);
1109 p->ValueOfVE = AbsAppl(pt);
1110 #endif
1111 } else {
1112 if (IsApplTerm(t0)) {
1113 /* recover space */
1114 Yap_FreeCodeSpace((char *) (RepAppl(p->ValueOfVE)));
1115 }
1116 p->ValueOfVE = v;
1117 }
1118 WRITE_UNLOCK(p->VRWLock);
1119 }
1120
1121 Term
Yap_StringToList(char * s)1122 Yap_StringToList(char *s)
1123 {
1124 register Term t;
1125 register unsigned char *cp = (unsigned char *)s + strlen(s);
1126
1127 t = MkAtomTerm(AtomNil);
1128 while (cp > (unsigned char *)s) {
1129 t = MkPairTerm(MkIntTerm(*--cp), t);
1130 }
1131 return (t);
1132 }
1133
1134 Term
Yap_NStringToList(char * s,size_t len)1135 Yap_NStringToList(char *s, size_t len)
1136 {
1137 Term t;
1138 unsigned char *cp = (unsigned char *)s + len;
1139
1140 t = MkAtomTerm(AtomNil);
1141 while (cp > (unsigned char *)s) {
1142 t = MkPairTerm(MkIntegerTerm(*--cp), t);
1143 }
1144 return t;
1145 }
1146
1147 Term
Yap_WideStringToList(wchar_t * s)1148 Yap_WideStringToList(wchar_t *s)
1149 {
1150 Term t;
1151 wchar_t *cp = s + wcslen(s);
1152
1153 t = MkAtomTerm(AtomNil);
1154 while (cp > s) {
1155 t = MkPairTerm(MkIntegerTerm(*--cp), t);
1156 }
1157 return t;
1158 }
1159
1160 Term
Yap_NWideStringToList(wchar_t * s,size_t len)1161 Yap_NWideStringToList(wchar_t *s, size_t len)
1162 {
1163 Term t;
1164 wchar_t *cp = s + len;
1165
1166 t = MkAtomTerm(AtomNil);
1167 while (cp > s) {
1168 t = MkPairTerm(MkIntegerTerm(*--cp), t);
1169 }
1170 return t;
1171 }
1172
1173 Term
Yap_StringToDiffList(char * s,Term t)1174 Yap_StringToDiffList(char *s, Term t)
1175 {
1176 register unsigned char *cp = (unsigned char *)s + strlen(s);
1177
1178 t = Yap_Globalise(t);
1179 while (cp > (unsigned char *)s) {
1180 t = MkPairTerm(MkIntTerm(*--cp), t);
1181 }
1182 return t;
1183 }
1184
1185 Term
Yap_NStringToDiffList(char * s,Term t,size_t len)1186 Yap_NStringToDiffList(char *s, Term t, size_t len)
1187 {
1188 register unsigned char *cp = (unsigned char *)s + len;
1189
1190 t = Yap_Globalise(t);
1191 while (cp > (unsigned char *)s) {
1192 t = MkPairTerm(MkIntTerm(*--cp), t);
1193 }
1194 return t;
1195 }
1196
1197 Term
Yap_WideStringToDiffList(wchar_t * s,Term t)1198 Yap_WideStringToDiffList(wchar_t *s, Term t)
1199 {
1200 wchar_t *cp = s + wcslen(s);
1201
1202 t = Yap_Globalise(t);
1203 while (cp > s) {
1204 t = MkPairTerm(MkIntegerTerm(*--cp), t);
1205 }
1206 return t;
1207 }
1208
1209 Term
Yap_NWideStringToDiffList(wchar_t * s,Term t,size_t len)1210 Yap_NWideStringToDiffList(wchar_t *s, Term t, size_t len)
1211 {
1212 wchar_t *cp = s + len;
1213
1214 t = Yap_Globalise(t);
1215 while (cp > s) {
1216 t = MkPairTerm(MkIntegerTerm(*--cp), t);
1217 }
1218 return t;
1219 }
1220
1221 Term
Yap_StringToListOfAtoms(char * s)1222 Yap_StringToListOfAtoms(char *s)
1223 {
1224 register Term t;
1225 char so[2];
1226 register unsigned char *cp = (unsigned char *)s + strlen(s);
1227
1228 so[1] = '\0';
1229 t = MkAtomTerm(AtomNil);
1230 while (cp > (unsigned char *)s) {
1231 so[0] = *--cp;
1232 t = MkPairTerm(MkAtomTerm(LookupAtom(so)), t);
1233 }
1234 return t;
1235 }
1236
1237 Term
Yap_NStringToListOfAtoms(char * s,size_t len)1238 Yap_NStringToListOfAtoms(char *s, size_t len)
1239 {
1240 register Term t;
1241 char so[2];
1242 register unsigned char *cp = (unsigned char *)s + len;
1243
1244 so[1] = '\0';
1245 t = MkAtomTerm(AtomNil);
1246 while (cp > (unsigned char *)s) {
1247 so[0] = *--cp;
1248 t = MkPairTerm(MkAtomTerm(LookupAtom(so)), t);
1249 }
1250 return t;
1251 }
1252
1253 Term
Yap_WideStringToListOfAtoms(wchar_t * s)1254 Yap_WideStringToListOfAtoms(wchar_t *s)
1255 {
1256 register Term t;
1257 wchar_t so[2];
1258 wchar_t *cp = s + wcslen(s);
1259
1260 so[1] = '\0';
1261 t = MkAtomTerm(AtomNil);
1262 while (cp > s) {
1263 so[0] = *--cp;
1264 t = MkPairTerm(MkAtomTerm(LookupWideAtom(so)), t);
1265 }
1266 return t;
1267 }
1268
1269 Term
Yap_NWideStringToListOfAtoms(wchar_t * s,size_t len)1270 Yap_NWideStringToListOfAtoms(wchar_t *s, size_t len)
1271 {
1272 register Term t;
1273 wchar_t so[2];
1274 wchar_t *cp = s + len;
1275
1276 so[1] = '\0';
1277 t = MkAtomTerm(AtomNil);
1278 while (cp > s) {
1279 so[0] = *--cp;
1280 t = MkPairTerm(MkAtomTerm(LookupWideAtom(so)), t);
1281 }
1282 return t;
1283 }
1284
1285 Term
Yap_NWideStringToDiffListOfAtoms(wchar_t * s,Term t0,size_t len)1286 Yap_NWideStringToDiffListOfAtoms(wchar_t *s, Term t0, size_t len)
1287 {
1288 register Term t;
1289 wchar_t so[2];
1290 wchar_t *cp = s + len;
1291
1292 so[1] = '\0';
1293 t = Yap_Globalise(t0);
1294 while (cp > s) {
1295 so[0] = *--cp;
1296 t = MkPairTerm(MkAtomTerm(LookupWideAtom(so)), t);
1297 }
1298 return t;
1299 }
1300
1301 Term
Yap_ArrayToList(register Term * tp,int nof)1302 Yap_ArrayToList(register Term *tp, int nof)
1303 {
1304 register Term *pt = tp + nof;
1305 register Term t;
1306
1307 t = MkAtomTerm(AtomNil);
1308 while (pt > tp) {
1309 Term tm = *--pt;
1310 #if SBA
1311 if (tm == 0)
1312 t = MkPairTerm((CELL)pt, t);
1313 else
1314 #endif
1315 t = MkPairTerm(tm, t);
1316 }
1317 return (t);
1318 }
1319
1320 int
Yap_GetName(char * s,UInt max,Term t)1321 Yap_GetName(char *s, UInt max, Term t)
1322 {
1323 register Term Head;
1324 register Int i;
1325
1326 if (IsVarTerm(t) || !IsPairTerm(t))
1327 return FALSE;
1328 while (IsPairTerm(t)) {
1329 Head = HeadOfTerm(t);
1330 if (!IsNumTerm(Head))
1331 return (FALSE);
1332 i = IntOfTerm(Head);
1333 if (i < 0 || i > MAX_ISO_LATIN1)
1334 return FALSE;
1335 *s++ = i;
1336 t = TailOfTerm(t);
1337 if (--max == 0) {
1338 Yap_Error(FATAL_ERROR,t,"not enough space for GetName");
1339 }
1340 }
1341 *s = '\0';
1342 return TRUE;
1343 }
1344
1345 #ifdef SFUNC
1346
1347 Term
MkSFTerm(Functor f,int n,Term * a,empty_value)1348 MkSFTerm(Functor f, int n, Term *a, empty_value)
1349 {
1350 Term t, p = AbsAppl(H);
1351 int i;
1352
1353 *H++ = f;
1354 RESET_VARIABLE(H);
1355 ++H;
1356 for (i = 1; i <= n; ++i) {
1357 t = Derefa(a++);
1358 if (t != empty_value) {
1359 *H++ = i;
1360 *H++ = t;
1361 }
1362 }
1363 *H++ = 0;
1364 return (p);
1365 }
1366
1367 CELL *
ArgsOfSFTerm(Term t)1368 ArgsOfSFTerm(Term t)
1369 {
1370 CELL *p = RepAppl(t) + 1;
1371
1372 while (*p != (CELL) p)
1373 p = CellPtr(*p) + 1;
1374 return (p + 1);
1375 }
1376
1377 #endif
1378
1379 Int
Yap_NewSlots(int n)1380 Yap_NewSlots(int n)
1381 {
1382 Int old_slots = IntOfTerm(ASP[0]), oldn = n;
1383 while (n > 0) {
1384 RESET_VARIABLE(ASP);
1385 ASP--;
1386 n--;
1387 }
1388 ASP[0] = MkIntTerm(old_slots+oldn);
1389 CurSlot = LCL0-ASP;
1390 return((ASP+1)-LCL0);
1391 }
1392
1393 Int
Yap_InitSlot(Term t)1394 Yap_InitSlot(Term t)
1395 {
1396 Int old_slots = IntOfTerm(ASP[0]);
1397 *ASP = t;
1398 ASP--;
1399 CurSlot ++;
1400 ASP[0] = MkIntTerm(old_slots+1);
1401 return((ASP+1)-LCL0);
1402 }
1403
1404 int
Yap_RecoverSlots(int n)1405 Yap_RecoverSlots(int n)
1406 {
1407 Int old_slots = IntOfTerm(ASP[0]);
1408 if (old_slots - n < 0) {
1409 return FALSE;
1410 }
1411 ASP += n;
1412 CurSlot -= n;
1413 ASP[0] = MkIntTerm(old_slots-n);
1414 return TRUE;
1415 }
1416
1417 Term
Yap_GetFromSlot(Int slot)1418 Yap_GetFromSlot(Int slot)
1419 {
1420 return(Deref(LCL0[slot]));
1421 }
1422
1423 Term
Yap_GetPtrFromSlot(Int slot)1424 Yap_GetPtrFromSlot(Int slot)
1425 {
1426 return(LCL0[slot]);
1427 }
1428
1429 Term *
Yap_AddressFromSlot(Int slot)1430 Yap_AddressFromSlot(Int slot)
1431 {
1432 return(LCL0+slot);
1433 }
1434
1435 void
Yap_PutInSlot(Int slot,Term t)1436 Yap_PutInSlot(Int slot, Term t)
1437 {
1438 LCL0[slot] = t;
1439 }
1440
1441 static HoldEntry *
InitAtomHold(void)1442 InitAtomHold(void)
1443 {
1444 HoldEntry *x = (HoldEntry *)Yap_AllocAtomSpace(sizeof(struct hold_entry));
1445 if (x == NULL) {
1446 return NULL;
1447 }
1448 x->KindOfPE = HoldProperty;
1449 x->NextOfPE = NIL;
1450 x->RefsOfPE = 1;
1451 return x;
1452 }
1453
1454 int
Yap_AtomIncreaseHold(Atom at)1455 Yap_AtomIncreaseHold(Atom at)
1456 {
1457 AtomEntry *ae = RepAtom(at);
1458 HoldEntry *pp;
1459 Prop *opp = &(ae->PropsOfAE);
1460
1461 WRITE_LOCK(ae->ARWLock);
1462 pp = RepHoldProp(ae->PropsOfAE);
1463 while (!EndOfPAEntr(pp)
1464 && pp->KindOfPE != HoldProperty) {
1465 opp = &(pp->NextOfPE);
1466 pp = RepHoldProp(pp->NextOfPE);
1467 }
1468 if (!pp) {
1469 HoldEntry *new = InitAtomHold();
1470 if (!new) {
1471 WRITE_UNLOCK(ae->ARWLock);
1472 return FALSE;
1473 }
1474 *opp = AbsHoldProp(new);
1475 } else {
1476 pp->RefsOfPE++;
1477 }
1478 WRITE_UNLOCK(ae->ARWLock);
1479 return TRUE;
1480 }
1481
1482 int
Yap_AtomDecreaseHold(Atom at)1483 Yap_AtomDecreaseHold(Atom at)
1484 {
1485 AtomEntry *ae = RepAtom(at);
1486 HoldEntry *pp;
1487 Prop *opp = &(ae->PropsOfAE);
1488
1489 WRITE_LOCK(ae->ARWLock);
1490 pp = RepHoldProp(ae->PropsOfAE);
1491 while (!EndOfPAEntr(pp)
1492 && pp->KindOfPE != HoldProperty) {
1493 opp = &(pp->NextOfPE);
1494 pp = RepHoldProp(pp->NextOfPE);
1495 }
1496 if (!pp) {
1497 WRITE_UNLOCK(ae->ARWLock);
1498 return FALSE;
1499 }
1500 pp->RefsOfPE--;
1501 if (!pp->RefsOfPE) {
1502 *opp = pp->NextOfPE;
1503 Yap_FreeCodeSpace((ADDR)pp);
1504 }
1505 WRITE_UNLOCK(ae->ARWLock);
1506 return TRUE;
1507 }
1508
1509