1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 1996-2020, University of Amsterdam
7 VU University Amsterdam
8 CWI, Amsterdam
9 All rights reserved.
10
11 Redistribution and use in source and binary forms, with or without
12 modification, are permitted provided that the following conditions
13 are met:
14
15 1. Redistributions of source code must retain the above copyright
16 notice, this list of conditions and the following disclaimer.
17
18 2. Redistributions in binary form must reproduce the above copyright
19 notice, this list of conditions and the following disclaimer in
20 the documentation and/or other materials provided with the
21 distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
24 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
25 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
26 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
27 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
28 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
29 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
30 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
31 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34 POSSIBILITY OF SUCH DAMAGE.
35 */
36
37 /*#define O_DEBUG 1*/
38 #include "pl-incl.h"
39 #include "os/pl-ctype.h"
40 #include "os/pl-utf8.h"
41 #include "os/pl-text.h"
42 #include "pl-codelist.h"
43 #include <errno.h>
44
45 #ifdef __SANITIZE_ADDRESS__
46 #include <sanitizer/lsan_interface.h>
47 #endif
48
49 #include <limits.h>
50 #if !defined(LLONG_MAX)
51 #define LLONG_MAX 9223372036854775807LL
52 #define LLONG_MIN (-LLONG_MAX - 1LL)
53 #endif
54
55 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
56 SWI-Prolog new-style foreign-language interface. This new foreign
57 interface is a mix of the old interface using the ideas on term-handles
58 from Quintus Prolog. Term-handles are integers (uintptr_t), describing
59 the offset of the term-location relative to the base of the local stack.
60
61 If a C-function has to store intermediate results, it can do so by
62 creating a new term-reference using PL_new_term_ref(). This functions
63 allocates a cell on the local stack and returns the offset.
64
65 While a foreign function is on top of the stack, the local stacks looks
66 like this:
67
68 | <-- lTop
69 -----------------------------------------------
70 | Allocated term-refs using PL_new_term_ref() |
71 -----------------------------------------------
72 | reserved for #term-refs (1) |
73 -----------------------------------------------
74 | foreign-function arguments (term-refs) |
75 -----------------------------------------------
76 | Local frame of foreign function |
77 -----------------------------------------------
78
79 On a call-back to Prolog using PL_call(), etc., (1) is filled with the
80 number of term-refs allocated. This information (stored as a tagged
81 Prolog int) is used by the garbage collector to update the stack frames.
82 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
83
84 #if O_DEBUG || defined(O_MAINTENANCE)
85 #ifndef O_CHECK_TERM_REFS
86 #define O_CHECK_TERM_REFS 1
87 #endif
88 #endif
89
90 #define setHandle(h, w) (*valTermRef(h) = (w))
91 #define valHandleP(h) valTermRef(h)
92 #define VALID_INT_ARITY(a) \
93 { if ( arity < 0 || arity > INT_MAX ) \
94 fatalError("Arity out of range: %lld", (int64_t)arity); \
95 } while(0);
96
97 #define VALID_TERM_ARITY(arity) \
98 do { if ( (ssize_t)arity < 0 ) \
99 return raiseStackOverflow(GLOBAL_OVERFLOW); } while(0)
100
101 static int unify_int64_ex__LD(term_t t, int64_t i, int ex ARG_LD);
102 static int PL_get_uint__LD(term_t t, unsigned int *i ARG_LD);
103
104 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
105 Deduce the value to store a copy of the contents of p. This is a *very*
106 frequent operation. There are a couple of options to realise it.
107 Basically, we can choose between simple dereferencing and returning the
108 value or create a new reference. In the latter case, we are a bit unlucky,
109 as we could also have returned the last reference.
110
111 Second, we can opt for inlining or not. Especially in the latter
112 variation, which is a bit longer, a function might actually be faster.
113 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
114
115 word
linkVal__LD(Word p ARG_LD)116 linkVal__LD(Word p ARG_LD)
117 { word w = *p;
118
119 while( isRef(w) )
120 { p = unRef(w);
121 if ( needsRef(*p) )
122 return w;
123 w = *p;
124 }
125
126 if ( unlikely(needsRef(w)) )
127 return makeRef(p);
128
129 DEBUG(CHK_ATOM_GARBAGE_COLLECTED, assert(w != ATOM_garbage_collected));
130
131 return w;
132 }
133
134
135 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
136 term_t pushWordAsTermRef(Word p)
137 popTermRef()
138
139 These two functions are used to create a term-ref from a `Word'. This is
140 typically needed for calling PL_error(). In many cases there is no
141 foreign environment around, which makes that we cannot call
142 PL_new_term_ref(). These functions use the tmp-references, shared with
143 PushPtr()/PopPtr() (see pl-incl.h). Push and pop *must* match.
144
145 Note that this protects creating a term-ref if there is no environment.
146 However, the function called still must either not use term-references
147 or must create an environment.
148 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
149
150 term_t
pushWordAsTermRef__LD(Word p ARG_LD)151 pushWordAsTermRef__LD(Word p ARG_LD)
152 { int i = LD->tmp.top++;
153 term_t t = LD->tmp.h[i];
154
155 assert(i<TMP_PTR_SIZE);
156 setHandle(t, linkVal(p));
157
158 return t;
159 }
160
161 void
popTermRef__LD(ARG1_LD)162 popTermRef__LD(ARG1_LD)
163 { int i = --LD->tmp.top;
164
165 assert(i>=0);
166 setVar(*valTermRef(LD->tmp.h[i]));
167 }
168
169
170 /* bArgVar(Word ap, Word vp) unifies a pointer into a struct with a
171 pointer to a value. This is the same as the B_ARGVAR instruction
172 and used to push terms for e.g., A_ADD_FC
173 */
174
175 void
bArgVar(Word ap,Word vp ARG_LD)176 bArgVar(Word ap, Word vp ARG_LD)
177 { deRef(vp);
178
179 if ( isVar(*vp) )
180 { if ( ap < vp )
181 { setVar(*ap);
182 Trail(vp, makeRefG(ap));
183 } else
184 { *ap = makeRefG(vp);
185 }
186 } else if ( isAttVar(*vp) )
187 { *ap = makeRefG(vp);
188 } else
189 { *ap = *vp;
190 }
191 }
192
193 /*******************************
194 * CREATE/RESET *
195 *******************************/
196
197 term_t
PL_new_term_refs__LD(int n ARG_LD)198 PL_new_term_refs__LD(int n ARG_LD)
199 { Word t;
200 term_t r;
201 int i;
202 FliFrame fr;
203
204 if ( !ensureLocalSpace(n*sizeof(word)) )
205 return 0;
206
207 t = (Word)lTop;
208 r = consTermRef(t);
209
210 for(i=0; i<n; i++)
211 setVar(*t++);
212 lTop = (LocalFrame)t;
213 fr = fli_context;
214 fr->size += n;
215 #ifdef O_CHECK_TERM_REFS
216 { int s = (int)((Word) lTop - (Word)(fr+1));
217 assert(s == fr->size);
218 }
219 #endif
220
221 return r;
222 }
223
224
225 static inline term_t
new_term_ref(ARG1_LD)226 new_term_ref(ARG1_LD)
227 { Word t;
228 term_t r;
229 FliFrame fr;
230
231 t = (Word)lTop;
232 r = consTermRef(t);
233 setVar(*t++);
234
235 lTop = (LocalFrame)t;
236 fr = fli_context;
237 fr->size++;
238 #ifdef O_CHECK_TERM_REFS
239 { int s = (int)((Word) lTop - (Word)(fr+1));
240 assert(s == fr->size);
241 }
242 #endif
243
244 return r;
245 }
246
247
248 term_t
PL_new_term_ref__LD(ARG1_LD)249 PL_new_term_ref__LD(ARG1_LD)
250 { if ( !ensureLocalSpace(sizeof(word)) )
251 return 0;
252
253 return new_term_ref(PASS_LD1);
254 }
255
256
257 term_t
PL_new_term_ref_noshift__LD(ARG1_LD)258 PL_new_term_ref_noshift__LD(ARG1_LD)
259 { if ( unlikely(addPointer(lTop, sizeof(word)) > (void*) lMax) )
260 return 0;
261 return new_term_ref(PASS_LD1);
262 }
263
264
265 #undef PL_new_term_ref
266 #undef PL_new_term_refs
267
268 term_t
PL_new_term_refs(int n)269 PL_new_term_refs(int n)
270 { GET_LD
271
272 if ( (void*)fli_context <= (void*)environment_frame )
273 fatalError("PL_new_term_refs(): No foreign environment");
274
275 return PL_new_term_refs__LD(n PASS_LD);
276 }
277
278
279 term_t
PL_new_term_ref()280 PL_new_term_ref()
281 { GET_LD
282
283 if ( (void*)fli_context <= (void*)environment_frame )
284 fatalError("PL_new_term_ref(): No foreign environment");
285
286 return PL_new_term_ref__LD(PASS_LD1);
287 }
288
289
290 /* PL_new_nil_ref() is for compatibility with SICStus and other
291 prologs that create the initial term-reference as [] instead of
292 using a variable.
293 */
294
295 term_t
PL_new_nil_ref(void)296 PL_new_nil_ref(void)
297 { GET_LD
298 term_t t;
299
300 if ( (void*)fli_context <= (void*)environment_frame )
301 fatalError("PL_new_term_ref(): No foreign environment");
302
303 if ( (t=PL_new_term_ref__LD(PASS_LD1)) )
304 setHandle(t, ATOM_nil);
305
306 return t;
307 }
308
309
310 #define PL_new_term_ref() PL_new_term_ref__LD(PASS_LD1)
311 #define PL_new_term_refs(n) PL_new_term_refs__LD(n PASS_LD)
312
313
314 void
PL_reset_term_refs__LD(term_t r ARG_LD)315 PL_reset_term_refs__LD(term_t r ARG_LD)
316 { FliFrame fr = fli_context;
317
318 lTop = (LocalFrame) valTermRef(r);
319 fr->size = (int)((Word) lTop - (Word)addPointer(fr, sizeof(struct fliFrame)));
320 DEBUG(0, assert(fr->size >= 0));
321 }
322
323 term_t
PL_copy_term_ref__LD(term_t from ARG_LD)324 PL_copy_term_ref__LD(term_t from ARG_LD)
325 { Word t, p2;
326 term_t r;
327 FliFrame fr;
328
329 if ( !ensureLocalSpace(sizeof(word)) )
330 return 0;
331
332 t = (Word)lTop;
333 r = consTermRef(t);
334 p2 = valHandleP(from);
335
336 *t = linkVal(p2);
337 lTop = (LocalFrame)(t+1);
338 fr = fli_context;
339 fr->size++;
340 DEBUG(CHK_SECURE,
341 { int s = (Word) lTop - (Word)(fr+1);
342 assert(s == fr->size);
343 });
344
345 return r;
346 }
347
348 #undef PL_reset_term_refs
349 #undef PL_copy_term_ref
350
351 void
PL_reset_term_refs(term_t r)352 PL_reset_term_refs(term_t r)
353 { GET_LD
354
355 PL_reset_term_refs__LD(r PASS_LD);
356 }
357
358 term_t
PL_copy_term_ref(term_t from)359 PL_copy_term_ref(term_t from)
360 { GET_LD
361
362 return PL_copy_term_ref__LD(from PASS_LD);
363 }
364
365 #define PL_reset_term_refs(t) PL_reset_term_refs__LD(t PASS_LD)
366 #define PL_copy_term_ref(t) PL_copy_term_ref__LD(t PASS_LD)
367
368
369 /*******************************
370 * UNIFICATION *
371 *******************************/
372
373 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
374 unifyAtomic(p, a) unifies a term, represented by a pointer to it, with
375 an atomic value. It is intended for foreign language functions.
376
377 May call GC/SHIFT
378 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
379
380 static bool
unifyAtomic(term_t t,word w ARG_LD)381 unifyAtomic(term_t t, word w ARG_LD)
382 { Word p = valHandleP(t);
383
384 for(;;)
385 { if ( canBind(*p) )
386 { if ( !hasGlobalSpace(0) )
387 { int rc;
388
389 if ( (rc=ensureGlobalSpace(0, ALLOW_GC)) != TRUE )
390 return raiseStackOverflow(rc);
391 p = valHandleP(t);
392 deRef(p);
393 }
394
395 bindConst(p, w);
396 succeed;
397 }
398
399 if ( isRef(*p) )
400 { p = unRef(*p);
401 continue;
402 }
403
404 if ( *p == w )
405 succeed;
406
407 if ( isIndirect(w) && isIndirect(*p) )
408 return equalIndirect(w, *p);
409
410 fail;
411 }
412 }
413
414 /*******************************
415 * ATOMS *
416 *******************************/
417
418 atom_t
PL_new_atom(const char * s)419 PL_new_atom(const char *s)
420 { if ( !GD->initialised )
421 initAtoms();
422
423 return (atom_t) lookupAtom(s, strlen(s));
424 }
425
426
427 atom_t
PL_new_atom_nchars(size_t len,const char * s)428 PL_new_atom_nchars(size_t len, const char *s)
429 { if ( !GD->initialised )
430 initAtoms();
431
432 if ( len == (size_t)-1 )
433 len = strlen(s);
434
435 return (atom_t) lookupAtom(s, len);
436 }
437
438
439 atom_t
PL_new_atom_mbchars(int flags,size_t len,const char * s)440 PL_new_atom_mbchars(int flags, size_t len, const char *s)
441 { PL_chars_t text;
442 atom_t a;
443
444 if ( len == (size_t)-1 )
445 len = strlen(s);
446
447 text.text.t = (char*)s;
448 text.encoding = ((flags&REP_UTF8) ? ENC_UTF8 : \
449 (flags&REP_MB) ? ENC_ANSI : ENC_ISO_LATIN_1);
450 text.length = len;
451 text.canonical = FALSE;
452 text.storage = PL_CHARS_HEAP;
453
454 a = textToAtom(&text);
455 PL_free_text(&text);
456
457 return a;
458 }
459
460
461
462 functor_t
PL_new_functor_sz(atom_t f,size_t arity)463 PL_new_functor_sz(atom_t f, size_t arity)
464 { if ( !GD->initialised )
465 initFunctors();
466
467 return lookupFunctorDef(f, arity);
468 }
469
470 #undef PL_new_functor
471 functor_t
PL_new_functor(atom_t f,int arity)472 PL_new_functor(atom_t f, int arity)
473 { if ( arity >= 0 )
474 return PL_new_functor_sz(f, arity);
475 fatalError("Arity out of range: %d", arity);
476 return 0;
477 }
478 #define PL_new_functor(n,a) PL_new_functor_sz(n,a)
479
480
481 atom_t
PL_functor_name(functor_t f)482 PL_functor_name(functor_t f)
483 { return nameFunctor(f);
484 }
485
486
487 size_t
PL_functor_arity_sz(functor_t f)488 PL_functor_arity_sz(functor_t f)
489 { return arityFunctor(f);
490 }
491
492 #undef PL_functor_arity
493 int
PL_functor_arity(functor_t f)494 PL_functor_arity(functor_t f)
495 { size_t arity = arityFunctor(f);
496
497 VALID_INT_ARITY(arity);
498 return (int)arity;
499 }
500 #define PL_functor_arity(f) PL_functor_arity_sz(f)
501
502
503 /*******************************
504 * WIDE CHARACTER SUPPORT *
505 *******************************/
506
507 static int compareUCSAtom(atom_t h1, atom_t h2);
508 static int saveUCSAtom(atom_t a, IOSTREAM *fd);
509 static atom_t loadUCSAtom(IOSTREAM *fd);
510
511 static PL_blob_t ucs_atom =
512 { PL_BLOB_MAGIC,
513 PL_BLOB_UNIQUE|PL_BLOB_TEXT|PL_BLOB_WCHAR,
514 /* unique representation of text */
515 "ucs_text",
516 NULL, /* release */
517 compareUCSAtom, /* compare */
518 writeUCSAtom, /* write */
519 NULL, /* acquire */
520 saveUCSAtom, /* save load to/from .qlf files */
521 loadUCSAtom
522 };
523
524
525 static void
initUCSAtoms(void)526 initUCSAtoms(void)
527 { PL_register_blob_type(&ucs_atom);
528 }
529
530
531 int
isUCSAtom(Atom a)532 isUCSAtom(Atom a)
533 { return a->type == &ucs_atom;
534 }
535
536
537 atom_t
lookupUCSAtom(const pl_wchar_t * s,size_t len)538 lookupUCSAtom(const pl_wchar_t *s, size_t len)
539 { int new;
540
541 return lookupBlob((const char *)s, len*sizeof(pl_wchar_t),
542 &ucs_atom, &new);
543 }
544
545
546 atom_t
PL_new_atom_wchars(size_t len,const wchar_t * s)547 PL_new_atom_wchars(size_t len, const wchar_t *s)
548 { PL_chars_t txt;
549 atom_t a;
550
551 if ( !GD->initialised )
552 initAtoms();
553
554 if ( len == (size_t)-1 )
555 len = wcslen(s);
556
557 txt.text.w = (wchar_t*)s;
558 txt.length = len;
559 txt.encoding = ENC_WCHAR;
560 txt.storage = PL_CHARS_HEAP;
561 txt.canonical = FALSE;
562
563 a = textToAtom(&txt);
564 PL_free_text(&txt);
565
566 return a;
567 }
568
569
570 int
get_atom_ptr_text(Atom a,PL_chars_t * text)571 get_atom_ptr_text(Atom a, PL_chars_t *text)
572 { if ( false(a->type, PL_BLOB_TEXT) )
573 fail; /* non-textual atom */
574 if ( a->type == &ucs_atom )
575 { text->text.w = (pl_wchar_t *) a->name;
576 text->length = a->length / sizeof(pl_wchar_t);
577 text->encoding = ENC_WCHAR;
578 } else
579 { text->text.t = a->name;
580 text->length = a->length;
581 text->encoding = ENC_ISO_LATIN_1;
582 }
583 text->storage = PL_CHARS_HEAP;
584 text->canonical = TRUE;
585
586 succeed;
587 }
588
589
590 int
get_atom_text(atom_t atom,PL_chars_t * text)591 get_atom_text(atom_t atom, PL_chars_t *text)
592 { Atom a = atomValue(atom);
593
594 return get_atom_ptr_text(a, text);
595 }
596
597
598 int
get_string_text(word w,PL_chars_t * text ARG_LD)599 get_string_text(word w, PL_chars_t *text ARG_LD)
600 { if ( isBString(w) )
601 { text->text.t = getCharsString(w, &text->length);
602 text->encoding = ENC_ISO_LATIN_1;
603 } else
604 { text->text.w = getCharsWString(w, &text->length);
605 text->encoding = ENC_WCHAR;
606 }
607 text->storage = PL_CHARS_STACK;
608 text->canonical = TRUE;
609
610 succeed;
611 }
612
613
614 static int
compareUCSAtom(atom_t h1,atom_t h2)615 compareUCSAtom(atom_t h1, atom_t h2)
616 { Atom a1 = atomValue(h1);
617 Atom a2 = atomValue(h2);
618 const pl_wchar_t *s1 = (const pl_wchar_t*)a1->name;
619 const pl_wchar_t *s2 = (const pl_wchar_t*)a2->name;
620 size_t len = a1->length < a2->length ? a1->length : a2->length;
621
622 len /= sizeof(pl_wchar_t);
623
624 for( ; len-- > 0; s1++, s2++)
625 { if ( *s1 != *s2 )
626 { int d = *s1 - *s2;
627
628 return d<0 ? CMP_LESS : d>0 ? CMP_GREATER : CMP_EQUAL;
629 }
630 }
631
632 return a1->length > a2->length ? CMP_GREATER :
633 a1->length == a2->length ? CMP_EQUAL : CMP_LESS;
634 }
635
636
637 static int
saveUCSAtom(atom_t atom,IOSTREAM * fd)638 saveUCSAtom(atom_t atom, IOSTREAM *fd)
639 { Atom a = atomValue(atom);
640 const pl_wchar_t *s = (const pl_wchar_t*)a->name;
641 size_t len = a->length/sizeof(pl_wchar_t);
642
643 wicPutStringW(s, len, fd);
644
645 return TRUE;
646 }
647
648
649 static atom_t
loadUCSAtom(IOSTREAM * fd)650 loadUCSAtom(IOSTREAM *fd)
651 { pl_wchar_t buf[256];
652 pl_wchar_t *w;
653 size_t len;
654 atom_t a;
655
656 w = wicGetStringUTF8(fd, &len, buf, sizeof(buf)/sizeof(pl_wchar_t));
657 a = lookupUCSAtom(w, len);
658
659 if ( w != buf )
660 PL_free(w);
661
662 return a;
663 }
664
665
666 int
PL_unify_wchars(term_t t,int flags,size_t len,const pl_wchar_t * s)667 PL_unify_wchars(term_t t, int flags, size_t len, const pl_wchar_t *s)
668 { PL_chars_t text;
669 int rc;
670
671 if ( len == (size_t)-1 )
672 len = wcslen(s);
673
674 text.text.w = (pl_wchar_t *)s;
675 text.encoding = ENC_WCHAR;
676 text.storage = PL_CHARS_HEAP;
677 text.length = len;
678 text.canonical = FALSE;
679
680 rc = PL_unify_text(t, 0, &text, flags);
681 PL_free_text(&text);
682
683 return rc;
684 }
685
686
687 int
PL_unify_wchars_diff(term_t t,term_t tail,int flags,size_t len,const pl_wchar_t * s)688 PL_unify_wchars_diff(term_t t, term_t tail, int flags,
689 size_t len, const pl_wchar_t *s)
690 { PL_chars_t text;
691 int rc;
692
693 if ( len == (size_t)-1 )
694 len = wcslen(s);
695
696 text.text.w = (pl_wchar_t *)s;
697 text.encoding = ENC_WCHAR;
698 text.storage = PL_CHARS_HEAP;
699 text.length = len;
700 text.canonical = FALSE;
701
702 rc = PL_unify_text(t, tail, &text, flags);
703 PL_free_text(&text);
704
705 return rc;
706 }
707
708
709 size_t
PL_utf8_strlen(const char * s,size_t len)710 PL_utf8_strlen(const char *s, size_t len)
711 { return utf8_strlen(s, len);
712 }
713
714
715 /*******************************
716 * GET ATOM TEXT *
717 *******************************/
718
719 const char *
PL_atom_chars(atom_t a)720 PL_atom_chars(atom_t a)
721 { return (const char *) stringAtom(a);
722 }
723
724
725 const char *
PL_atom_nchars(atom_t a,size_t * len)726 PL_atom_nchars(atom_t a, size_t *len)
727 { Atom x = atomValue(a);
728
729 if ( x->type != &ucs_atom )
730 { if ( len )
731 *len = x->length;
732
733 return x->name;
734 } else
735 return NULL;
736 }
737
738
739 const wchar_t *
PL_atom_wchars(atom_t a,size_t * len)740 PL_atom_wchars(atom_t a, size_t *len)
741 { Atom x = atomValue(a);
742
743 if ( x->type == &ucs_atom )
744 { if ( len )
745 *len = x->length / sizeof(pl_wchar_t);
746
747 return (const wchar_t *)x->name;
748 } else if ( true(x->type, PL_BLOB_TEXT) )
749 { Buffer b = findBuffer(BUF_STACK);
750 const char *s = (const char*)x->name;
751 const char *e = &s[x->length];
752
753 for(; s<e; s++)
754 { addBuffer(b, *s, wchar_t);
755 }
756 addBuffer(b, 0, wchar_t);
757
758 if ( len )
759 *len = x->length;
760
761 return baseBuffer(b, const wchar_t);
762 } else
763 return NULL;
764 }
765
766
767 int
charCode(word w)768 charCode(word w)
769 { if ( isAtom(w) )
770 { Atom a = atomValue(w);
771
772 if ( a->length == 1 && true(a->type, PL_BLOB_TEXT) )
773 return a->name[0] & 0xff;
774 if ( a->length == sizeof(pl_wchar_t) && a->type == &ucs_atom )
775 { pl_wchar_t *p = (pl_wchar_t*)a->name;
776
777 return p[0];
778 }
779 }
780
781 return -1;
782 }
783
784
785 /*******************************
786 * QUINTUS/SICSTUS WRAPPER *
787 *******************************/
788
789 static int sp_encoding = REP_UTF8;
790
791 void
SP_set_state(int state)792 SP_set_state(int state)
793 { GET_LD
794
795 LD->fli.SP_state = state;
796 }
797
798
799 int
SP_get_state(void)800 SP_get_state(void)
801 { GET_LD
802
803 return LD->fli.SP_state;
804 }
805
806
807 int
PL_cvt_encoding(void)808 PL_cvt_encoding(void)
809 { return sp_encoding;
810 }
811
812 int
PL_cvt_set_encoding(int enc)813 PL_cvt_set_encoding(int enc)
814 { switch(enc)
815 { case REP_ISO_LATIN_1:
816 case REP_UTF8:
817 case REP_MB:
818 sp_encoding = enc;
819 return TRUE;
820 }
821
822 return FALSE;
823 }
824
825 #define REP_SP (sp_encoding)
826
827 #ifndef SCHAR_MIN
828 #define SCHAR_MIN -128
829 #define SCHAR_MAX 127
830 #endif
831 #ifndef UCHAR_MAX
832 #define UCHAR_MAX 255
833 #endif
834
835 #ifndef SHORT_MIN
836 #define SHORT_MIN -32768
837 #define SHORT_MAX 32767
838 #define USHORT_MAX (SHORT_MAX*2+1)
839 #endif
840
841 static bool
_PL_cvt_i_char(term_t p,char * c,int mn,int mx)842 _PL_cvt_i_char(term_t p, char *c, int mn, int mx)
843 { GET_LD
844 int i;
845 PL_chars_t txt;
846
847 if ( PL_get_integer(p, &i) && i >= mn && i <= mx )
848 { *c = (char)i;
849 return TRUE;
850 } else if ( PL_get_text(p, &txt, CVT_ATOM|CVT_STRING|CVT_LIST) )
851 { if ( txt.length == 1 && txt.encoding == ENC_ISO_LATIN_1 )
852 { *c = txt.text.t[0];
853 return TRUE; /* can never be allocated */
854 }
855 PL_free_text(&txt);
856 }
857
858 if ( PL_is_integer(p) )
859 return PL_representation_error(mn < 0 ? "char" : "uchar");
860
861 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, p);
862 }
863
864
865 bool
PL_cvt_i_char(term_t p,char * c)866 PL_cvt_i_char(term_t p, char *c)
867 { return _PL_cvt_i_char(p, c, SCHAR_MIN, SCHAR_MAX);
868 }
869
870 bool
PL_cvt_i_uchar(term_t p,unsigned char * c)871 PL_cvt_i_uchar(term_t p, unsigned char *c)
872 { return _PL_cvt_i_char(p, (char *)c, 0, UCHAR_MAX);
873 }
874
875
876 static bool
_PL_cvt_i_short(term_t p,short * s,int mn,int mx)877 _PL_cvt_i_short(term_t p, short *s, int mn, int mx)
878 { GET_LD
879 int i;
880
881 if ( PL_get_integer(p, &i) &&
882 i >= mn && i <= mx )
883 { *s = (short)i;
884 return TRUE;
885 }
886
887 if ( PL_is_integer(p) )
888 return PL_representation_error(mn < 0 ? "short" : "ushort");
889
890 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, p);
891 }
892
893 bool
PL_cvt_i_short(term_t p,short * s)894 PL_cvt_i_short(term_t p, short *s)
895 { return _PL_cvt_i_short(p, s, SHORT_MIN, SHORT_MAX);
896 }
897
898 bool
PL_cvt_i_ushort(term_t p,unsigned short * s)899 PL_cvt_i_ushort(term_t p, unsigned short *s)
900 { return _PL_cvt_i_short(p, (short *)s, 0, USHORT_MAX);
901 }
902
903 bool
PL_cvt_i_int(term_t p,int * c)904 PL_cvt_i_int(term_t p, int *c)
905 { return PL_get_integer_ex(p, c);
906 }
907
908 bool
PL_cvt_i_uint(term_t t,unsigned int * c)909 PL_cvt_i_uint(term_t t, unsigned int *c)
910 { GET_LD
911
912 if ( PL_get_uint__LD(t, c PASS_LD) )
913 return TRUE;
914
915 if ( PL_is_integer(t) )
916 return PL_representation_error("uint");
917
918 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t);
919 }
920
921 bool
PL_cvt_i_long(term_t p,long * c)922 PL_cvt_i_long(term_t p, long *c)
923 { return PL_get_long_ex(p, c);
924 }
925
926 bool
PL_cvt_i_ulong(term_t p,unsigned long * c)927 PL_cvt_i_ulong(term_t p, unsigned long *c)
928 {
929 #if SIZEOF_LONG == 8
930 return PL_cvt_i_uint64(p, (uint64_t *)c);
931 #else
932 return PL_cvt_i_uint(p, (unsigned int*)c);
933 #endif
934 }
935
936 bool
PL_cvt_i_int64(term_t p,int64_t * c)937 PL_cvt_i_int64(term_t p, int64_t *c)
938 { return PL_get_int64_ex(p, c);
939 }
940
941 bool
PL_cvt_i_uint64(term_t p,uint64_t * c)942 PL_cvt_i_uint64(term_t p, uint64_t *c)
943 { GET_LD
944 return PL_get_uint64_ex__LD(p, c PASS_LD);
945 }
946
947 bool
PL_cvt_i_size_t(term_t p,size_t * c)948 PL_cvt_i_size_t(term_t p, size_t *c)
949 { GET_LD
950 return PL_get_size_ex(p, c);
951 }
952
953
954 bool
PL_cvt_i_float(term_t p,double * c)955 PL_cvt_i_float(term_t p, double *c)
956 { return PL_get_float_ex(p, c);
957 }
958
959
960 bool
PL_cvt_i_single(term_t p,float * c)961 PL_cvt_i_single(term_t p, float *c)
962 { double f;
963
964 if ( PL_get_float_ex(p, &f) )
965 { *c = (float)f;
966 succeed;
967 }
968
969 fail;
970 }
971
972
973 bool
PL_cvt_i_string(term_t p,char ** c)974 PL_cvt_i_string(term_t p, char **c)
975 { return PL_get_chars(p, c, CVT_ATOM|CVT_STRING|CVT_EXCEPTION|REP_SP);
976 }
977
978
979 bool
PL_cvt_i_codes(term_t p,char ** c)980 PL_cvt_i_codes(term_t p, char **c)
981 { return PL_get_chars(p, c, CVT_LIST|CVT_EXCEPTION|REP_SP);
982 }
983
984
985 bool
PL_cvt_i_atom(term_t p,atom_t * c)986 PL_cvt_i_atom(term_t p, atom_t *c)
987 { GET_LD
988
989 return PL_get_atom_ex(p, c);
990 }
991
992
993 bool
PL_cvt_i_address(term_t p,void * address)994 PL_cvt_i_address(term_t p, void *address)
995 { void **addrp = address;
996
997 return PL_get_pointer_ex(p, addrp);
998 }
999
1000
1001 bool
PL_cvt_o_int64(int64_t c,term_t p)1002 PL_cvt_o_int64(int64_t c, term_t p)
1003 { GET_LD
1004 return unify_int64_ex__LD(p, c, TRUE PASS_LD);
1005 }
1006
1007
1008 bool
PL_cvt_o_float(double c,term_t p)1009 PL_cvt_o_float(double c, term_t p)
1010 { return PL_unify_float(p, c);
1011 }
1012
1013
1014 bool
PL_cvt_o_single(float c,term_t p)1015 PL_cvt_o_single(float c, term_t p)
1016 { return PL_unify_float(p, c);
1017 }
1018
1019
1020 bool
PL_cvt_o_string(const char * c,term_t p)1021 PL_cvt_o_string(const char *c, term_t p)
1022 { return PL_unify_chars(p, PL_ATOM|REP_SP, (size_t)-1, c);
1023 }
1024
1025
1026 bool
PL_cvt_o_codes(const char * c,term_t p)1027 PL_cvt_o_codes(const char *c, term_t p)
1028 { return PL_unify_chars(p, PL_CODE_LIST|REP_SP, (size_t)-1, c);
1029 }
1030
1031
1032 bool
PL_cvt_o_atom(atom_t c,term_t p)1033 PL_cvt_o_atom(atom_t c, term_t p)
1034 { GET_LD
1035 return PL_unify_atom(p, c);
1036 }
1037
1038
1039 bool
PL_cvt_o_address(void * address,term_t p)1040 PL_cvt_o_address(void *address, term_t p)
1041 { GET_LD
1042 return PL_unify_pointer(p, address);
1043 }
1044
1045
1046 /*******************************
1047 * COMPARE *
1048 *******************************/
1049
1050 int /* TBD: how to report error? */
PL_compare(term_t t1,term_t t2)1051 PL_compare(term_t t1, term_t t2)
1052 { GET_LD
1053 Word p1 = valHandleP(t1);
1054 Word p2 = valHandleP(t2);
1055
1056 return compareStandard(p1, p2, FALSE PASS_LD); /* -1, 0, 1 */
1057 }
1058
1059
1060 int
PL_same_compound(term_t t1,term_t t2)1061 PL_same_compound(term_t t1, term_t t2)
1062 { GET_LD
1063 word w1 = valHandle(t1);
1064 word w2 = valHandle(t2);
1065
1066 return isTerm(w1) && w1==w2 ? TRUE : FALSE;
1067 }
1068
1069
1070 /*******************************
1071 * CONS-* *
1072 *******************************/
1073
1074 static inline void
bindConsVal(Word to,Word p ARG_LD)1075 bindConsVal(Word to, Word p ARG_LD)
1076 { deRef(p);
1077
1078 if ( canBind(*p) )
1079 { if ( to < p && !isAttVar(*p) )
1080 { setVar(*to);
1081 *p = makeRefG(to);
1082 } else
1083 *to = makeRef(p);
1084 } else
1085 *to = *p;
1086 }
1087
1088
1089 int
PL_cons_functor(term_t h,functor_t fd,...)1090 PL_cons_functor(term_t h, functor_t fd, ...)
1091 { GET_LD
1092 size_t arity = arityFunctor(fd);
1093
1094 if ( arity == 0 )
1095 { setHandle(h, nameFunctor(fd));
1096 } else
1097 { va_list args;
1098 Word a, t;
1099
1100 VALID_TERM_ARITY(arity);
1101
1102 if ( !hasGlobalSpace(1+arity) )
1103 { int rc;
1104
1105 if ( (rc=ensureGlobalSpace(1+arity, ALLOW_GC)) != TRUE )
1106 return raiseStackOverflow(rc);
1107 }
1108
1109 a = t = gTop;
1110 gTop += 1+arity;
1111 va_start(args, fd);
1112 *a = fd;
1113 while( arity-- > 0 )
1114 { term_t r = va_arg(args, term_t);
1115
1116 bindConsVal(++a, valHandleP(r) PASS_LD);
1117 }
1118 setHandle(h, consPtr(t, TAG_COMPOUND|STG_GLOBAL));
1119 va_end(args);
1120 }
1121
1122 return TRUE;
1123 }
1124
1125
1126 int
PL_cons_functor_v(term_t h,functor_t fd,term_t a0)1127 PL_cons_functor_v(term_t h, functor_t fd, term_t a0)
1128 { GET_LD
1129 size_t arity = arityFunctor(fd);
1130
1131 if ( arity == 0 )
1132 { setHandle(h, nameFunctor(fd));
1133 } else
1134 { Word t, a, ai;
1135
1136 VALID_TERM_ARITY(arity);
1137
1138 if ( !hasGlobalSpace(1+arity) )
1139 { int rc;
1140
1141 if ( (rc=ensureGlobalSpace(1+arity, ALLOW_GC)) != TRUE )
1142 return raiseStackOverflow(rc);
1143 }
1144
1145 a = t = gTop;
1146 gTop += 1+arity;
1147
1148 ai = valHandleP(a0);
1149 *a = fd;
1150 while( arity-- > 0 )
1151 bindConsVal(++a, ai++ PASS_LD);
1152
1153 setHandle(h, consPtr(t, TAG_COMPOUND|STG_GLOBAL));
1154 }
1155
1156 return TRUE;
1157 }
1158
1159
1160 int
PL_cons_list__LD(term_t l,term_t head,term_t tail ARG_LD)1161 PL_cons_list__LD(term_t l, term_t head, term_t tail ARG_LD)
1162 { Word a;
1163
1164 if ( !hasGlobalSpace(3) )
1165 { int rc;
1166
1167 if ( (rc=ensureGlobalSpace(3, ALLOW_GC)) != TRUE )
1168 return raiseStackOverflow(rc);
1169 }
1170
1171 a = gTop;
1172 gTop += 3;
1173 a[0] = FUNCTOR_dot2;
1174 bindConsVal(&a[1], valHandleP(head) PASS_LD);
1175 bindConsVal(&a[2], valHandleP(tail) PASS_LD);
1176
1177 setHandle(l, consPtr(a, TAG_COMPOUND|STG_GLOBAL));
1178
1179 return TRUE;
1180 }
1181
1182
1183 #undef PL_cons_list
1184 int
PL_cons_list(term_t l,term_t head,term_t tail)1185 PL_cons_list(term_t l, term_t head, term_t tail)
1186 { GET_LD
1187 return PL_cons_list__LD(l, head, tail PASS_LD);
1188 }
1189 #define PL_cons_list(l, h, t) PL_cons_list__LD(l, h, t PASS_LD)
1190
1191 /* PL_cons_list_v() creates a list from a vector of term-references
1192 */
1193
1194 int
PL_cons_list_v(term_t list,size_t count,term_t elems)1195 PL_cons_list_v(term_t list, size_t count, term_t elems)
1196 { GET_LD
1197
1198 if ( count > 0 )
1199 { Word p;
1200
1201 if ( !hasGlobalSpace(3*count) )
1202 { int rc;
1203
1204 if ( (rc=ensureGlobalSpace(3*count, ALLOW_GC)) != TRUE )
1205 return raiseStackOverflow(rc);
1206 }
1207
1208 p = gTop;
1209 for( ; count-- > 0; p += 3, elems++ )
1210 { p[0] = FUNCTOR_dot2;
1211 bindConsVal(&p[1], valHandleP(elems) PASS_LD);
1212 if ( count > 0 )
1213 { p[2] = consPtr(&p[3], TAG_COMPOUND|STG_GLOBAL);
1214 } else
1215 { p[2] = ATOM_nil;
1216 }
1217 }
1218
1219 setHandle(list, consPtr(gTop, TAG_COMPOUND|STG_GLOBAL));
1220 gTop = p;
1221 } else
1222 { setHandle(list, ATOM_nil);
1223 }
1224
1225 return TRUE;
1226 }
1227
1228 /*******************************
1229 * GET-* *
1230 *******************************/
1231
1232 static const int type_map[8] = { PL_VARIABLE,
1233 PL_VARIABLE, /* attributed variable */
1234 PL_FLOAT,
1235 PL_INTEGER,
1236 PL_STRING,
1237 PL_ATOM,
1238 PL_TERM, /* TAG_COMPOUND */
1239 -1 /* TAG_REFERENCE */
1240 };
1241
1242 int
PL_get_term_value(term_t t,term_value_t * val)1243 PL_get_term_value(term_t t, term_value_t *val)
1244 { GET_LD
1245 word w = valHandle(t);
1246 int rval = type_map[tag(w)];
1247
1248 switch(rval)
1249 { case PL_VARIABLE:
1250 break;
1251 case PL_INTEGER:
1252 val->i = valInteger(w); /* TBD: Handle MPZ integers? */
1253 break;
1254 case PL_FLOAT:
1255 val->f = valFloat(w);
1256 break;
1257 case PL_ATOM:
1258 val->a = (atom_t)w;
1259 if ( !isTextAtom(val->a) )
1260 { if ( val->a == ATOM_nil )
1261 return PL_NIL;
1262 else
1263 return PL_BLOB;
1264 }
1265 break;
1266 case PL_STRING:
1267 val->s = getCharsString(w, NULL);
1268 break;
1269 case PL_TERM:
1270 { FunctorDef fd = valueFunctor(functorTerm(w));
1271 val->t.name = fd->name;
1272 val->t.arity = fd->arity;
1273 if ( fd->functor == FUNCTOR_dot2 )
1274 return PL_LIST_PAIR;
1275 if ( val->t.name == ATOM_dict )
1276 return PL_DICT;
1277 break;
1278 }
1279 default:
1280 assert(0);
1281 }
1282
1283 return rval;
1284 }
1285
1286
1287 int
PL_get_bool(term_t t,int * b)1288 PL_get_bool(term_t t, int *b)
1289 { GET_LD
1290 word w = valHandle(t);
1291
1292 if ( isAtom(w) )
1293 { if ( w == ATOM_true || w == ATOM_on )
1294 { *b = TRUE;
1295 succeed;
1296 } else if ( w == ATOM_false || w == ATOM_off )
1297 { *b = FALSE;
1298 succeed;
1299 }
1300 }
1301
1302 fail;
1303 }
1304
1305
1306 int
PL_get_atom__LD(term_t t,atom_t * a ARG_LD)1307 PL_get_atom__LD(term_t t, atom_t *a ARG_LD)
1308 { word w = valHandle(t);
1309
1310 if ( isAtom(w) )
1311 { *a = (atom_t) w;
1312 succeed;
1313 }
1314 fail;
1315 }
1316
1317
1318 #undef PL_get_atom
1319 int
PL_get_atom(term_t t,atom_t * a)1320 PL_get_atom(term_t t, atom_t *a)
1321 { GET_LD
1322 return PL_get_atom__LD(t, a PASS_LD);
1323 }
1324 #define PL_get_atom(t, a) PL_get_atom__LD(t, a PASS_LD)
1325
1326
1327 int
PL_get_atom_chars(term_t t,char ** s)1328 PL_get_atom_chars(term_t t, char **s)
1329 { GET_LD
1330 word w = valHandle(t);
1331
1332 if ( isAtom(w) )
1333 { Atom a = atomValue(w);
1334
1335 if ( true(a->type, PL_BLOB_TEXT) )
1336 { *s = a->name;
1337 succeed;
1338 }
1339 }
1340
1341 fail;
1342 }
1343
1344
1345 int
PL_get_atom_nchars(term_t t,size_t * len,char ** s)1346 PL_get_atom_nchars(term_t t, size_t *len, char **s)
1347 { GET_LD
1348 word w = valHandle(t);
1349
1350 if ( isAtom(w) )
1351 { Atom a = atomValue(w);
1352
1353 if ( true(a->type, PL_BLOB_TEXT) )
1354 { *s = a->name;
1355 *len = a->length;
1356
1357 succeed;
1358 }
1359 }
1360
1361 fail;
1362 }
1363
1364
1365 #ifdef O_STRING
1366 int
PL_get_string(term_t t,char ** s,size_t * len)1367 PL_get_string(term_t t, char **s, size_t *len)
1368 { GET_LD
1369 word w = valHandle(t);
1370
1371 if ( isString(w) )
1372 { char *tmp = getCharsString(w, len);
1373
1374 if ( tmp )
1375 { *s = tmp;
1376 succeed;
1377 } /* fails on wide-character string */
1378 }
1379 fail;
1380 }
1381 #endif
1382
1383
1384 int
PL_get_list_nchars(term_t l,size_t * length,char ** s,unsigned int flags)1385 PL_get_list_nchars(term_t l, size_t *length, char **s, unsigned int flags)
1386 { Buffer b;
1387 CVT_result result;
1388
1389 if ( (b = codes_or_chars_to_buffer(l, flags, FALSE, &result)) )
1390 { char *r;
1391 size_t len = entriesBuffer(b, char);
1392
1393 if ( length )
1394 *length = len;
1395 addBuffer(b, EOS, char);
1396 r = baseBuffer(b, char);
1397
1398 if ( flags & BUF_MALLOC )
1399 { *s = PL_malloc(len+1);
1400 memcpy(*s, r, len+1);
1401 unfindBuffer(b, flags);
1402 } else
1403 *s = r;
1404
1405 succeed;
1406 }
1407
1408 fail;
1409 }
1410
1411
1412 int
PL_get_list_chars(term_t l,char ** s,unsigned flags)1413 PL_get_list_chars(term_t l, char **s, unsigned flags)
1414 { return PL_get_list_nchars(l, NULL, s, flags);
1415 }
1416
1417
1418 int
PL_get_wchars(term_t l,size_t * length,pl_wchar_t ** s,unsigned flags)1419 PL_get_wchars(term_t l, size_t *length, pl_wchar_t **s, unsigned flags)
1420 { GET_LD
1421 PL_chars_t text;
1422
1423 if ( !PL_get_text(l, &text, flags) )
1424 return FALSE;
1425
1426 PL_promote_text(&text);
1427 PL_save_text(&text, flags);
1428
1429 if ( length )
1430 *length = text.length;
1431 *s = text.text.w;
1432
1433 return TRUE;
1434 }
1435
1436
1437 int
PL_get_nchars(term_t l,size_t * length,char ** s,unsigned flags)1438 PL_get_nchars(term_t l, size_t *length, char **s, unsigned flags)
1439 { GET_LD
1440 PL_chars_t text;
1441
1442 if ( !PL_get_text(l, &text, flags) )
1443 return FALSE;
1444
1445 if ( PL_mb_text(&text, flags) )
1446 { PL_save_text(&text, flags);
1447
1448 if ( length )
1449 *length = text.length;
1450 *s = text.text.t;
1451
1452 return TRUE;
1453 } else
1454 { PL_free_text(&text);
1455
1456 return FALSE;
1457 }
1458 }
1459
1460
1461 int
PL_get_chars(term_t t,char ** s,unsigned flags)1462 PL_get_chars(term_t t, char **s, unsigned flags)
1463 { return PL_get_nchars(t, NULL, s, flags);
1464 }
1465
1466
1467 int
PL_get_text_as_atom(term_t t,atom_t * a,int flags)1468 PL_get_text_as_atom(term_t t, atom_t *a, int flags)
1469 { GET_LD
1470 word w = valHandle(t);
1471 PL_chars_t text;
1472
1473 if ( isAtom(w) )
1474 { *a = (atom_t) w;
1475 return TRUE;
1476 }
1477
1478 if ( PL_get_text(t, &text, flags) )
1479 { atom_t ta = textToAtom(&text);
1480
1481 PL_free_text(&text);
1482 if ( ta )
1483 { *a = ta;
1484 return TRUE;
1485 }
1486 }
1487
1488 return FALSE;
1489 }
1490
1491
1492
1493 char *
PL_quote(int chr,const char * s)1494 PL_quote(int chr, const char *s)
1495 { Buffer b = findBuffer(BUF_STACK);
1496
1497 addBuffer(b, (char)chr, char);
1498 for(; *s; s++)
1499 { if ( *s == chr )
1500 addBuffer(b, (char)chr, char);
1501 addBuffer(b, *s, char);
1502 }
1503 addBuffer(b, (char)chr, char);
1504 addBuffer(b, EOS, char);
1505
1506 return baseBuffer(b, char);
1507 }
1508
1509
1510 int
PL_get_integer__LD(term_t t,int * i ARG_LD)1511 PL_get_integer__LD(term_t t, int *i ARG_LD)
1512 { word w = valHandle(t);
1513
1514 if ( isTaggedInt(w) )
1515 { intptr_t val = valInt(w);
1516
1517 if ( val > INT_MAX || val < INT_MIN )
1518 fail;
1519 *i = (int)val;
1520 succeed;
1521 }
1522 #if SIZEOF_VOIDP < 8
1523 if ( isBignum(w) )
1524 { int64_t val = valBignum(w);
1525
1526 if ( val > INT_MAX || val < INT_MIN )
1527 fail;
1528
1529 *i = (int)val;
1530 succeed;
1531 }
1532 #endif
1533 #ifndef O_GMP
1534 if ( isFloat(w) )
1535 { double f = valFloat(w);
1536 int l;
1537
1538 #ifdef DOUBLE_TO_LONG_CAST_RAISES_SIGFPE
1539 if ( f > (double)INT_MAX || f < (double)INT_MIN )
1540 fail;
1541 #endif
1542
1543 l = (int)f;
1544 if ( (double)l == f )
1545 { *i = l;
1546 succeed;
1547 }
1548 }
1549 #endif
1550 fail;
1551 }
1552
1553
1554 #undef PL_get_integer
1555 int
PL_get_integer(term_t t,int * i)1556 PL_get_integer(term_t t, int *i)
1557 { GET_LD
1558 return PL_get_integer__LD(t, i PASS_LD);
1559 }
1560 #define PL_get_integer(t, i) PL_get_integer__LD(t, i PASS_LD)
1561
1562
1563 static int
PL_get_uint__LD(term_t t,unsigned int * i ARG_LD)1564 PL_get_uint__LD(term_t t, unsigned int *i ARG_LD)
1565 { word w = valHandle(t);
1566
1567 if ( isTaggedInt(w) )
1568 { intptr_t val = valInt(w);
1569
1570 if ( val < 0 || val > UINT_MAX )
1571 fail;
1572 *i = (unsigned int)val;
1573 succeed;
1574 }
1575 #if SIZEOF_VOIDP < 8
1576 if ( isBignum(w) )
1577 { int64_t val = valBignum(w);
1578
1579 if ( val < 0 || val > UINT_MAX )
1580 fail;
1581
1582 *i = (unsigned int)val;
1583 succeed;
1584 }
1585 #endif
1586 #ifndef O_GMP
1587 if ( isFloat(w) )
1588 { double f = valFloat(w);
1589 unsigned int l;
1590
1591 #ifdef DOUBLE_TO_LONG_CAST_RAISES_SIGFPE
1592 if ( f > (double)UINT_MAX || f < 0.0 )
1593 fail;
1594 #endif
1595
1596 l = (unsigned int)f;
1597 if ( (double)l == f )
1598 { *i = l;
1599 succeed;
1600 }
1601 }
1602 #endif
1603 fail;
1604 }
1605
1606
1607 int
PL_get_long__LD(term_t t,long * i ARG_LD)1608 PL_get_long__LD(term_t t, long *i ARG_LD)
1609 { word w = valHandle(t);
1610
1611 if ( isTaggedInt(w) )
1612 { intptr_t val = valInt(w);
1613
1614 if ( val > LONG_MAX || val < LONG_MIN )
1615 fail;
1616 *i = (long)val;
1617 succeed;
1618 }
1619 if ( isBignum(w) )
1620 { int64_t val = valBignum(w);
1621
1622 if ( val > LONG_MAX || val < LONG_MIN )
1623 fail;
1624
1625 *i = (long)val;
1626 succeed;
1627 }
1628 if ( isFloat(w) )
1629 { double f = valFloat(w);
1630 long l;
1631
1632 #ifdef DOUBLE_TO_LONG_CAST_RAISES_SIGFPE
1633 if ( f > (double)LONG_MAX || f < (double)LONG_MIN )
1634 fail;
1635 #endif
1636
1637 l = (long) f;
1638 if ( (double)l == f )
1639 { *i = l;
1640 succeed;
1641 }
1642 }
1643 fail;
1644 }
1645
1646
1647 #undef PL_get_long
1648 int
PL_get_long(term_t t,long * i)1649 PL_get_long(term_t t, long *i)
1650 { GET_LD
1651 return PL_get_long__LD(t, i PASS_LD);
1652 }
1653 #define PL_get_long(t, i) PL_get_long__LD(t, i PASS_LD)
1654
1655
1656 int
PL_get_int64__LD(term_t t,int64_t * i ARG_LD)1657 PL_get_int64__LD(term_t t, int64_t *i ARG_LD)
1658 { word w = valHandle(t);
1659
1660 if ( isTaggedInt(w) )
1661 { *i = valInt(w);
1662 succeed;
1663 }
1664 if ( isBignum(w) )
1665 { *i = valBignum(w);
1666 succeed;
1667 }
1668 if ( isFloat(w) )
1669 { double f = valFloat(w);
1670 int64_t l;
1671
1672 #ifdef DOUBLE_TO_LONG_CAST_RAISES_SIGFPE
1673 if ( !((f >= LLONG_MAX) && (f <= LLONG_MIN)) )
1674 fail;
1675 #endif
1676
1677 l = (int64_t) f;
1678 if ( (double)l == f )
1679 { *i = l;
1680 succeed;
1681 }
1682 }
1683
1684 fail;
1685 }
1686
1687
1688 #undef PL_get_int64
1689 int
PL_get_int64(term_t t,int64_t * i)1690 PL_get_int64(term_t t, int64_t *i)
1691 { GET_LD
1692 return PL_get_int64__LD(t, i PASS_LD);
1693 }
1694 #define PL_get_int64(t, i) PL_get_int64__LD(t, i PASS_LD)
1695
1696
1697 int
PL_get_intptr(term_t t,intptr_t * i)1698 PL_get_intptr(term_t t, intptr_t *i)
1699 { GET_LD
1700 #if SIZEOF_LONG != SIZEOF_VOIDP && SIZEOF_VOIDP == 8
1701 return PL_get_int64(t, i);
1702 #else
1703 return PL_get_long(t, (long*)i);
1704 #endif
1705 }
1706
1707
1708 int
PL_get_uintptr(term_t t,size_t * i)1709 PL_get_uintptr(term_t t, size_t *i)
1710 { GET_LD
1711 int64_t val;
1712
1713 if ( !PL_get_int64(t, &val) )
1714 return FALSE;
1715
1716 if ( val < 0 )
1717 return FALSE;
1718 #if SIZEOF_VOIDP < 8
1719 #if SIZEOF_LONG == SIZEOF_VOIDP
1720 if ( val > (int64_t)ULONG_MAX )
1721 return FALSE;
1722 #endif
1723 #endif
1724
1725 *i = (size_t)val;
1726
1727 return TRUE;
1728 }
1729
1730
1731 int
PL_is_inf(term_t t)1732 PL_is_inf(term_t t)
1733 { GET_LD
1734 atom_t a;
1735
1736 if ( PL_get_atom(t, &a) &&
1737 (a == ATOM_inf || a == ATOM_infinite) )
1738 succeed;
1739
1740 fail;
1741 }
1742
1743
1744 int
PL_get_float(term_t t,double * f)1745 PL_get_float(term_t t, double *f)
1746 { GET_LD
1747 word w = valHandle(t);
1748
1749 if ( isFloat(w) )
1750 { *f = valFloat(w);
1751 return TRUE;
1752 }
1753 if ( isRational(w) )
1754 { number n;
1755 int rc;
1756
1757 get_rational(w, &n);
1758 if ( (rc=promoteToFloatNumber(&n)) )
1759 *f = n.value.f;
1760 else
1761 PL_clear_exception();
1762
1763 clearNumber(&n);
1764
1765 return rc;
1766 }
1767
1768 return FALSE;
1769 }
1770
1771
1772 #ifdef _MSC_VER
1773 #define ULL(x) x ## ui64
1774 #else
1775 #define ULL(x) x ## ULL
1776 #endif
1777
1778 int
PL_get_pointer__LD(term_t t,void ** ptr ARG_LD)1779 PL_get_pointer__LD(term_t t, void **ptr ARG_LD)
1780 { int64_t p;
1781
1782 if ( PL_get_int64(t, &p) )
1783 {
1784 #if SIZEOF_VOIDP == 4
1785 if ( p & ULL(0xffffffff00000000) )
1786 fail;
1787 #endif
1788
1789 *ptr = intToPointer((uintptr_t)p);
1790
1791 succeed;
1792 }
1793
1794 fail;
1795 }
1796
1797
1798 #undef PL_get_pointer
1799 int
PL_get_pointer(term_t t,void ** ptr)1800 PL_get_pointer(term_t t, void **ptr)
1801 { GET_LD
1802 return PL_get_pointer__LD(t, ptr PASS_LD);
1803 }
1804 #define PL_get_pointer(t, ptr) PL_get_pointer__LD(t, ptr PASS_LD)
1805
1806
1807
1808 int
PL_get_name_arity_sz__LD(term_t t,atom_t * name,size_t * arity ARG_LD)1809 PL_get_name_arity_sz__LD(term_t t, atom_t *name, size_t *arity ARG_LD)
1810 { word w = valHandle(t);
1811
1812 if ( isTerm(w) )
1813 { FunctorDef fd = valueFunctor(functorTerm(w));
1814
1815 if ( name )
1816 *name = fd->name;
1817 if ( arity )
1818 *arity = fd->arity;
1819 succeed;
1820 }
1821 if ( isTextAtom(w) )
1822 { if ( name )
1823 *name = (atom_t)w;
1824 if ( arity )
1825 *arity = 0;
1826 succeed;
1827 }
1828
1829 fail;
1830 }
1831
1832
1833 #undef PL_get_name_arity_sz
1834 int
PL_get_name_arity_sz(term_t t,atom_t * name,size_t * arity)1835 PL_get_name_arity_sz(term_t t, atom_t *name, size_t *arity)
1836 { GET_LD
1837 return PL_get_name_arity_sz__LD(t, name, arity PASS_LD);
1838 }
1839 #define PL_get_name_arity_sz(t,n,a) PL_get_name_arity_sz__LD(t,n,a PASS_LD)
1840
1841
1842 int
PL_get_compound_name_arity_sz(term_t t,atom_t * name,size_t * arity)1843 PL_get_compound_name_arity_sz(term_t t, atom_t *name, size_t *arity)
1844 { GET_LD
1845 word w = valHandle(t);
1846
1847 if ( isTerm(w) )
1848 { FunctorDef fd = valueFunctor(functorTerm(w));
1849
1850 if ( name )
1851 *name = fd->name;
1852 if ( arity )
1853 *arity = fd->arity;
1854 succeed;
1855 }
1856
1857 fail;
1858 }
1859
1860 #undef PL_get_name_arity
1861 int
PL_get_name_arity(term_t t,atom_t * name,int * arityp)1862 PL_get_name_arity(term_t t, atom_t *name, int *arityp)
1863 { GET_LD
1864 size_t arity;
1865
1866 if ( !PL_get_name_arity_sz(t, name, &arity) )
1867 return FALSE;
1868 VALID_INT_ARITY(arity);
1869 *arityp = (int)arity;
1870 return TRUE;
1871 }
1872 #define PL_get_name_arity(t,n,a) PL_get_name_arity_sz(t,n,a)
1873
1874 #undef PL_get_compound_name_arity
1875 int
PL_get_compound_name_arity(term_t t,atom_t * name,int * arityp)1876 PL_get_compound_name_arity(term_t t, atom_t *name, int *arityp)
1877 { size_t arity;
1878
1879 if ( !PL_get_compound_name_arity_sz(t, name, &arity) )
1880 return FALSE;
1881 VALID_INT_ARITY(arity);
1882 *arityp = (int)arity;
1883 return TRUE;
1884 }
1885 #define PL_get_compound_name_arity(t,n,a) PL_get_compound_name_arity_sz(t,n,a)
1886
1887
1888 int
PL_get_functor__LD(term_t t,functor_t * f ARG_LD)1889 PL_get_functor__LD(term_t t, functor_t *f ARG_LD)
1890 { word w = valHandle(t);
1891
1892 if ( isTerm(w) )
1893 { *f = functorTerm(w);
1894 succeed;
1895 }
1896 if ( isCallableAtom(w) || isReservedSymbol(w) )
1897 { *f = lookupFunctorDef(w, 0);
1898 succeed;
1899 }
1900
1901 fail;
1902 }
1903
1904
1905 #undef PL_get_functor
1906 int
PL_get_functor(term_t t,functor_t * f)1907 PL_get_functor(term_t t, functor_t *f)
1908 { GET_LD
1909 return PL_get_functor__LD(t, f PASS_LD);
1910 }
1911 #define PL_get_functor(t, f) PL_get_functor__LD(t, f PASS_LD)
1912
1913 int
PL_get_module(term_t t,module_t * m)1914 PL_get_module(term_t t, module_t *m)
1915 { GET_LD
1916 atom_t a;
1917
1918 if ( PL_get_atom(t, &a) )
1919 { *m = lookupModule(a);
1920 succeed;
1921 }
1922
1923 fail;
1924 }
1925
1926
1927 #undef _PL_get_arg /* undo global definition */
1928 int
_PL_get_arg_sz(size_t index,term_t t,term_t a)1929 _PL_get_arg_sz(size_t index, term_t t, term_t a)
1930 { GET_LD
1931 word w = valHandle(t);
1932 Functor f = (Functor)valPtr(w);
1933 Word p = &f->arguments[index-1];
1934
1935 setHandle(a, linkVal(p));
1936 return TRUE;
1937 }
1938 int
_PL_get_arg(int index,term_t t,term_t a)1939 _PL_get_arg(int index, term_t t, term_t a)
1940 { if ( index >= 0 )
1941 { _PL_get_arg_sz(index, t, a);
1942 return TRUE;
1943 } else
1944 fatalError("Arity out of range: %d", a);
1945 }
1946 #define _PL_get_arg(i, t, a) _PL_get_arg__LD(i, t, a PASS_LD)
1947
1948
1949 int
_PL_get_arg__LD(size_t index,term_t t,term_t a ARG_LD)1950 _PL_get_arg__LD(size_t index, term_t t, term_t a ARG_LD)
1951 { word w = valHandle(t);
1952 Functor f = (Functor)valPtr(w);
1953 Word p = &f->arguments[index-1];
1954
1955 setHandle(a, linkVal(p));
1956 return TRUE;
1957 }
1958
1959
1960 int
PL_get_arg_sz(size_t index,term_t t,term_t a)1961 PL_get_arg_sz(size_t index, term_t t, term_t a)
1962 { GET_LD
1963 word w = valHandle(t);
1964
1965 if ( isTerm(w) && index > 0 )
1966 { Functor f = (Functor)valPtr(w);
1967 size_t arity = arityFunctor(f->definition);
1968
1969 if ( --index < arity )
1970 { Word p = &f->arguments[index];
1971
1972 setHandle(a, linkVal(p));
1973 succeed;
1974 }
1975 }
1976
1977 fail;
1978 }
1979
1980 #undef PL_get_arg
1981 int
PL_get_arg(int index,term_t t,term_t a)1982 PL_get_arg(int index, term_t t, term_t a)
1983 { if ( index >= 0 )
1984 return PL_get_arg_sz(index, t, a);
1985 fatalError("Index out of range: %d", index);
1986 return FALSE;
1987 }
1988 #define PL_get_arg(i,t,a) PL_get_arg_sz(i,t,a)
1989
1990 #ifdef O_ATTVAR
1991 int
PL_get_attr(term_t t,term_t a)1992 PL_get_attr(term_t t, term_t a)
1993 { GET_LD
1994 return PL_get_attr__LD(t, a PASS_LD);
1995 }
1996 #endif
1997
1998
1999 int
PL_get_list__LD(term_t l,term_t h,term_t t ARG_LD)2000 PL_get_list__LD(term_t l, term_t h, term_t t ARG_LD)
2001 { word w = valHandle(l);
2002
2003 if ( isList(w) )
2004 { Word a = argTermP(w, 0);
2005
2006 setHandle(h, linkVal(a++));
2007 setHandle(t, linkVal(a));
2008
2009 succeed;
2010 }
2011
2012 fail;
2013 }
2014
2015
2016 #undef PL_get_list
2017 int
PL_get_list(term_t l,term_t h,term_t t)2018 PL_get_list(term_t l, term_t h, term_t t)
2019 { GET_LD
2020 return PL_get_list__LD(l, h, t PASS_LD);
2021 }
2022 #define PL_get_list(l, h, t) PL_get_list__LD(l, h, t PASS_LD)
2023
2024
2025 int
PL_get_head(term_t l,term_t h)2026 PL_get_head(term_t l, term_t h)
2027 { GET_LD
2028 word w = valHandle(l);
2029
2030 if ( isList(w) )
2031 { Word a = argTermP(w, 0);
2032 setHandle(h, linkVal(a));
2033 succeed;
2034 }
2035
2036 fail;
2037 }
2038
2039
2040 int
PL_get_tail(term_t l,term_t t)2041 PL_get_tail(term_t l, term_t t)
2042 { GET_LD
2043 word w = valHandle(l);
2044
2045 if ( isList(w) )
2046 { Word a = argTermP(w, 1);
2047 setHandle(t, linkVal(a));
2048 succeed;
2049 }
2050 fail;
2051 }
2052
2053
2054 int
PL_get_nil(term_t l)2055 PL_get_nil(term_t l)
2056 { GET_LD
2057 word w = valHandle(l);
2058
2059 if ( isNil(w) )
2060 succeed;
2061
2062 fail;
2063 }
2064
2065
2066 int
PL_skip_list(term_t list,term_t tail,size_t * len)2067 PL_skip_list(term_t list, term_t tail, size_t *len)
2068 { GET_LD
2069 intptr_t length;
2070 Word l = valTermRef(list);
2071 Word t;
2072
2073 length = skip_list(l, &t PASS_LD);
2074 if ( len )
2075 *len = length;
2076 if ( tail )
2077 { Word t2 = valTermRef(tail);
2078
2079 setVar(*t2);
2080 unify_ptrs(t2, t, 0 PASS_LD);
2081 }
2082
2083 if ( isNil(*t) )
2084 return PL_LIST;
2085 else if ( isVar(*t) )
2086 return PL_PARTIAL_LIST;
2087 else if ( isList(*t) )
2088 return PL_CYCLIC_TERM;
2089 else
2090 return PL_NOT_A_LIST;
2091 }
2092
2093
2094 int
_PL_get_xpce_reference(term_t t,xpceref_t * ref)2095 _PL_get_xpce_reference(term_t t, xpceref_t *ref)
2096 { GET_LD
2097 word w = valHandle(t);
2098 functor_t fd;
2099
2100 if ( !isTerm(w) )
2101 fail;
2102
2103 fd = valueTerm(w)->definition;
2104 if ( fd == FUNCTOR_xpceref1 ) /* @ref */
2105 { Word p = argTermP(w, 0);
2106
2107 do
2108 { if ( isTaggedInt(*p) )
2109 { ref->type = PL_INTEGER;
2110 ref->value.i = valInt(*p);
2111
2112 goto ok;
2113 }
2114 if ( isTextAtom(*p) )
2115 { ref->type = PL_ATOM;
2116 ref->value.a = (atom_t) *p;
2117
2118 goto ok;
2119 }
2120 if ( isBignum(*p) )
2121 { ref->type = PL_INTEGER;
2122 ref->value.i = (intptr_t)valBignum(*p);
2123
2124 goto ok;
2125 }
2126 } while(isRef(*p) && (p = unRef(*p)));
2127
2128 return -1; /* error! */
2129
2130 ok:
2131 succeed;
2132 }
2133
2134 fail;
2135 }
2136
2137
2138 /*******************************
2139 * IS-* *
2140 *******************************/
2141
2142 int
PL_is_variable__LD(term_t t ARG_LD)2143 PL_is_variable__LD(term_t t ARG_LD)
2144 { word w = valHandle(t);
2145
2146 return canBind(w) ? TRUE : FALSE;
2147 }
2148
2149
2150 #undef PL_is_variable
2151 int
PL_is_variable(term_t t)2152 PL_is_variable(term_t t)
2153 { GET_LD
2154 word w = valHandle(t);
2155
2156 return canBind(w) ? TRUE : FALSE;
2157 }
2158 #define PL_is_variable(t) PL_is_variable__LD(t PASS_LD)
2159
2160
2161 int
PL_is_atom__LD(term_t t ARG_LD)2162 PL_is_atom__LD(term_t t ARG_LD)
2163 { word w = valHandle(t);
2164
2165 if ( isTextAtom(w) )
2166 return TRUE;
2167
2168 return FALSE;
2169 }
2170
2171
2172 #undef PL_is_atom
2173 int
PL_is_atom(term_t t)2174 PL_is_atom(term_t t)
2175 { GET_LD
2176
2177 return PL_is_atom__LD(t PASS_LD);
2178 }
2179 #define PL_is_atom(t) PL_is_atom__LD(t PASS_LD)
2180
2181
2182 int
PL_is_blob(term_t t,PL_blob_t ** type)2183 PL_is_blob(term_t t, PL_blob_t **type)
2184 { GET_LD
2185 word w = valHandle(t);
2186
2187 if ( isAtom(w) )
2188 { if ( type )
2189 { Atom a = atomValue(w);
2190 *type = a->type;
2191 }
2192
2193 return TRUE;
2194 }
2195
2196 return FALSE;
2197 }
2198
2199
2200 int
PL_is_attvar(term_t t)2201 PL_is_attvar(term_t t)
2202 { GET_LD
2203 word w = valHandle(t);
2204
2205 return isAttVar(w) ? TRUE : FALSE;
2206 }
2207
2208
2209 int
PL_is_integer(term_t t)2210 PL_is_integer(term_t t)
2211 { GET_LD
2212 word w = valHandle(t);
2213
2214 return isInteger(w) ? TRUE : FALSE;
2215 }
2216
2217
2218 int
PL_is_float(term_t t)2219 PL_is_float(term_t t)
2220 { GET_LD
2221 word w = valHandle(t);
2222
2223 return isFloat(w) ? TRUE : FALSE;
2224 }
2225
2226
2227 int
PL_is_rational(term_t t)2228 PL_is_rational(term_t t)
2229 { GET_LD
2230 word w = valHandle(t);
2231
2232 return isRational(w);
2233 }
2234
2235
2236 int
PL_is_compound(term_t t)2237 PL_is_compound(term_t t)
2238 { GET_LD
2239 word w = valHandle(t);
2240
2241 return isTerm(w) ? TRUE : FALSE;
2242 }
2243
2244
2245 int
isCallable(word w ARG_LD)2246 isCallable(word w ARG_LD)
2247 { if ( isTerm(w) )
2248 { Functor f = valueTerm(w);
2249 FunctorDef fd = valueFunctor(f->definition);
2250 Atom ap = atomValue(fd->name);
2251
2252 if ( true(ap->type, PL_BLOB_TEXT) || fd->name == ATOM_nil )
2253 return TRUE;
2254 if ( ap->type == &_PL_closure_blob )
2255 { closure *c = (closure*)ap->name;
2256
2257 if ( c->def.functor->arity == fd->arity )
2258 return TRUE;
2259 }
2260
2261 return FALSE;
2262 }
2263
2264 return isTextAtom(w) != 0;
2265 }
2266
2267 int
PL_is_callable(term_t t)2268 PL_is_callable(term_t t)
2269 { GET_LD
2270
2271 return isCallable(valHandle(t) PASS_LD);
2272 }
2273
2274
2275 int
PL_is_functor__LD(term_t t,functor_t f ARG_LD)2276 PL_is_functor__LD(term_t t, functor_t f ARG_LD)
2277 { word w = valHandle(t);
2278
2279 if ( hasFunctor(w, f) )
2280 succeed;
2281
2282 fail;
2283 }
2284
2285
2286 #undef PL_is_functor
2287 int
PL_is_functor(term_t t,functor_t f)2288 PL_is_functor(term_t t, functor_t f)
2289 { GET_LD
2290 word w = valHandle(t);
2291
2292 if ( hasFunctor(w, f) )
2293 succeed;
2294
2295 fail;
2296 }
2297 #define PL_is_functor(t, f) PL_is_functor__LD(t, f PASS_LD)
2298
2299
2300 int
PL_is_list(term_t t)2301 PL_is_list(term_t t)
2302 { GET_LD
2303 word w = valHandle(t);
2304
2305 return (isList(w) || isNil(w)) ? TRUE : FALSE;
2306 }
2307
2308
2309 int
PL_is_pair(term_t t)2310 PL_is_pair(term_t t)
2311 { GET_LD
2312 word w = valHandle(t);
2313
2314 return !!isList(w);
2315 }
2316
2317
2318 int
PL_is_atomic__LD(term_t t ARG_LD)2319 PL_is_atomic__LD(term_t t ARG_LD)
2320 { word w = valHandle(t);
2321
2322 return !!isAtomic(w);
2323 }
2324
2325
2326 #undef PL_is_atomic
2327 int
PL_is_atomic(term_t t)2328 PL_is_atomic(term_t t)
2329 { GET_LD
2330 word w = valHandle(t);
2331
2332 return !!isAtomic(w);
2333 }
2334 #define PL_is_atomic(t) PL_is_atomic__LD(t PASS_LD)
2335
2336
2337 int
PL_is_number(term_t t)2338 PL_is_number(term_t t)
2339 { GET_LD
2340 word w = valHandle(t);
2341
2342 return !!isNumber(w);
2343 }
2344
2345
2346 #ifdef O_STRING
2347 int
PL_is_string(term_t t)2348 PL_is_string(term_t t)
2349 { GET_LD
2350 word w = valHandle(t);
2351
2352 return !!isString(w);
2353 }
2354
2355 int
PL_unify_string_chars(term_t t,const char * s)2356 PL_unify_string_chars(term_t t, const char *s)
2357 { GET_LD
2358 word str = globalString(strlen(s), (char *)s);
2359
2360 if ( str )
2361 return unifyAtomic(t, str PASS_LD);
2362
2363 return FALSE;
2364 }
2365
2366 int
PL_unify_string_nchars(term_t t,size_t len,const char * s)2367 PL_unify_string_nchars(term_t t, size_t len, const char *s)
2368 { GET_LD
2369 word str = globalString(len, s);
2370
2371 if ( str )
2372 return unifyAtomic(t, str PASS_LD);
2373
2374 return FALSE;
2375 }
2376 #endif /*O_STRING*/
2377
2378
2379 /*******************************
2380 * PUT-* *
2381 *******************************/
2382
2383 int
PL_put_variable__LD(term_t t ARG_LD)2384 PL_put_variable__LD(term_t t ARG_LD)
2385 { Word p = valTermRef(t);
2386
2387 setVar(*p);
2388 return TRUE;
2389 }
2390
2391
2392 #undef PL_put_variable
2393 int
PL_put_variable(term_t t)2394 PL_put_variable(term_t t)
2395 { GET_LD
2396
2397 return PL_put_variable__LD(t PASS_LD);
2398 }
2399 #define PL_put_variable(t) PL_put_variable__LD(t PASS_LD)
2400
2401
2402 int
PL_put_atom__LD(term_t t,atom_t a ARG_LD)2403 PL_put_atom__LD(term_t t, atom_t a ARG_LD)
2404 { setHandle(t, a);
2405 return TRUE;
2406 }
2407
2408
2409 #undef PL_put_atom
2410 int
PL_put_atom(term_t t,atom_t a)2411 PL_put_atom(term_t t, atom_t a)
2412 { GET_LD
2413 setHandle(t, a);
2414 return TRUE;
2415 }
2416 #define PL_put_atom(t, a) PL_put_atom__LD(t, a PASS_LD)
2417
2418
2419 int
PL_put_bool(term_t t,int val)2420 PL_put_bool(term_t t, int val)
2421 { GET_LD
2422
2423 PL_put_atom__LD(t, val ? ATOM_true : ATOM_false PASS_LD);
2424 return TRUE;
2425 }
2426
2427
2428 int
PL_put_atom_chars(term_t t,const char * s)2429 PL_put_atom_chars(term_t t, const char *s)
2430 { GET_LD
2431 atom_t a = lookupAtom(s, strlen(s));
2432
2433 setHandle(t, a);
2434 PL_unregister_atom(a);
2435
2436 return TRUE;
2437 }
2438
2439
2440 int
PL_put_atom_nchars(term_t t,size_t len,const char * s)2441 PL_put_atom_nchars(term_t t, size_t len, const char *s)
2442 { GET_LD
2443 atom_t a = lookupAtom(s, len);
2444
2445 if ( len == (size_t)-1 )
2446 len = strlen(s);
2447
2448 setHandle(t, a);
2449 PL_unregister_atom(a);
2450
2451 return TRUE;
2452 }
2453
2454
2455 int
PL_put_string_chars(term_t t,const char * s)2456 PL_put_string_chars(term_t t, const char *s)
2457 { GET_LD
2458 word w = globalString(strlen(s), s);
2459
2460 if ( w )
2461 { setHandle(t, w);
2462 return TRUE;
2463 }
2464
2465 return FALSE;
2466 }
2467
2468
2469 int
PL_put_string_nchars(term_t t,size_t len,const char * s)2470 PL_put_string_nchars(term_t t, size_t len, const char *s)
2471 { GET_LD
2472 word w = globalString(len, s);
2473
2474 if ( w )
2475 { setHandle(t, w);
2476 return TRUE;
2477 }
2478
2479 return FALSE;
2480 }
2481
2482
2483 int
PL_put_chars(term_t t,int flags,size_t len,const char * s)2484 PL_put_chars(term_t t, int flags, size_t len, const char *s)
2485 { GET_LD
2486 PL_chars_t text;
2487 word w = 0;
2488 int rc = FALSE;
2489
2490 if ( len == (size_t)-1 )
2491 len = strlen(s);
2492
2493 text.text.t = (char*)s;
2494 text.encoding = ((flags&REP_UTF8) ? ENC_UTF8 : \
2495 (flags&REP_MB) ? ENC_ANSI : ENC_ISO_LATIN_1);
2496 text.length = len;
2497 text.canonical = FALSE;
2498 text.storage = PL_CHARS_HEAP;
2499
2500 flags &= ~(REP_UTF8|REP_MB|REP_ISO_LATIN_1);
2501
2502 if ( flags == PL_ATOM )
2503 w = textToAtom(&text);
2504 else if ( flags == PL_STRING )
2505 w = textToString(&text);
2506 else if ( flags == PL_CODE_LIST || flags == PL_CHAR_LIST )
2507 { PL_put_variable(t);
2508 rc = PL_unify_text(t, 0, &text, flags);
2509 } else
2510 assert(0);
2511
2512 if ( w )
2513 { setHandle(t, w);
2514 rc = TRUE;
2515 }
2516
2517 PL_free_text(&text);
2518
2519 return rc;
2520 }
2521
2522
2523 int
PL_put_list_ncodes(term_t t,size_t len,const char * chars)2524 PL_put_list_ncodes(term_t t, size_t len, const char *chars)
2525 { GET_LD
2526
2527 if ( len == 0 )
2528 { setHandle(t, ATOM_nil);
2529 } else
2530 { Word p = allocGlobal(len*3);
2531
2532 if ( !p )
2533 return FALSE;
2534
2535 setHandle(t, consPtr(p, TAG_COMPOUND|STG_GLOBAL));
2536
2537 for( ; len-- != 0; chars++)
2538 { *p++ = FUNCTOR_dot2;
2539 *p++ = consInt((intptr_t)*chars & 0xff);
2540 *p = consPtr(p+1, TAG_COMPOUND|STG_GLOBAL);
2541 p++;
2542 }
2543 p[-1] = ATOM_nil;
2544 }
2545
2546 return TRUE;
2547 }
2548
2549
2550 int
PL_put_list_codes(term_t t,const char * chars)2551 PL_put_list_codes(term_t t, const char *chars)
2552 { return PL_put_list_ncodes(t, strlen(chars), chars);
2553 }
2554
2555
2556 int
PL_put_list_nchars(term_t t,size_t len,const char * chars)2557 PL_put_list_nchars(term_t t, size_t len, const char *chars)
2558 { GET_LD
2559
2560 if ( len == 0 )
2561 { setHandle(t, ATOM_nil);
2562 } else
2563 { Word p = allocGlobal(len*3);
2564
2565 if ( !p )
2566 return FALSE;
2567
2568 setHandle(t, consPtr(p, TAG_COMPOUND|STG_GLOBAL));
2569
2570 for( ; len-- != 0 ; chars++)
2571 { *p++ = FUNCTOR_dot2;
2572 *p++ = codeToAtom(*chars & 0xff);
2573 *p = consPtr(p+1, TAG_COMPOUND|STG_GLOBAL);
2574 p++;
2575 }
2576 p[-1] = ATOM_nil;
2577 }
2578
2579 return TRUE;
2580 }
2581
2582
2583 int
PL_put_list_chars(term_t t,const char * chars)2584 PL_put_list_chars(term_t t, const char *chars)
2585 { return PL_put_list_nchars(t, strlen(chars), chars);
2586 }
2587
2588
2589 int
PL_put_int64__LD(term_t t,int64_t i ARG_LD)2590 PL_put_int64__LD(term_t t, int64_t i ARG_LD)
2591 { word w = consInt(i);
2592
2593 if ( valInt(w) != i &&
2594 put_int64(&w, i, ALLOW_GC PASS_LD) != TRUE )
2595 return FALSE;
2596
2597 setHandle(t, w);
2598 return TRUE;
2599 }
2600
2601
2602 int
PL_put_integer__LD(term_t t,long i ARG_LD)2603 PL_put_integer__LD(term_t t, long i ARG_LD)
2604 { return PL_put_int64__LD(t, i PASS_LD);
2605 }
2606
2607
2608 int
PL_put_intptr__LD(term_t t,intptr_t i ARG_LD)2609 PL_put_intptr__LD(term_t t, intptr_t i ARG_LD)
2610 { return PL_put_int64__LD(t, i PASS_LD);
2611 }
2612
2613
2614 int
PL_put_int64(term_t t,int64_t i)2615 PL_put_int64(term_t t, int64_t i)
2616 { GET_LD
2617
2618 return PL_put_int64__LD(t, i PASS_LD);
2619 }
2620
2621 int
PL_put_uint64(term_t t,uint64_t i)2622 PL_put_uint64(term_t t, uint64_t i)
2623 { GET_LD
2624 word w;
2625 int rc;
2626
2627 switch ( (rc=put_uint64(&w, i, ALLOW_GC PASS_LD)) )
2628 { case TRUE:
2629 return setHandle(t, w);
2630 case LOCAL_OVERFLOW:
2631 return PL_representation_error("uint64_t");
2632 default:
2633 return raiseStackOverflow(rc);
2634 }
2635 }
2636
2637
2638 #undef PL_put_integer
2639 int
PL_put_integer(term_t t,long i)2640 PL_put_integer(term_t t, long i)
2641 { GET_LD
2642 return PL_put_int64__LD(t, i PASS_LD);
2643 }
2644 #define PL_put_integer(t, i) PL_put_integer__LD(t, i PASS_LD)
2645
2646
2647 int
_PL_put_number__LD(term_t t,Number n ARG_LD)2648 _PL_put_number__LD(term_t t, Number n ARG_LD)
2649 { word w;
2650 int rc;
2651
2652 if ( (rc=put_number(&w, n, ALLOW_GC PASS_LD)) == TRUE )
2653 { setHandle(t, w);
2654 return TRUE;
2655 } else
2656 { return raiseStackOverflow(rc);
2657 }
2658 }
2659
2660
2661 int
PL_put_pointer(term_t t,void * ptr)2662 PL_put_pointer(term_t t, void *ptr)
2663 { GET_LD
2664 uint64_t i = pointerToInt(ptr);
2665
2666 return PL_put_int64__LD(t, (int64_t)i PASS_LD);
2667 }
2668
2669
2670 int
PL_put_float(term_t t,double f)2671 PL_put_float(term_t t, double f)
2672 { GET_LD
2673 word w;
2674 int rc;
2675
2676 if ( (rc=put_double(&w, f, ALLOW_GC PASS_LD)) == TRUE )
2677 { setHandle(t, w);
2678 return TRUE;
2679 }
2680
2681 return raiseStackOverflow(rc);
2682 }
2683
2684
2685 int
PL_put_functor(term_t t,functor_t f)2686 PL_put_functor(term_t t, functor_t f)
2687 { GET_LD
2688 size_t arity = arityFunctor(f);
2689
2690 if ( arity == 0 )
2691 { setHandle(t, nameFunctor(f));
2692 } else
2693 { Word a;
2694
2695 VALID_TERM_ARITY(arity);
2696 if ( !(a = allocGlobal(1 + arity)) )
2697 return FALSE;
2698 setHandle(t, consPtr(a, TAG_COMPOUND|STG_GLOBAL));
2699 *a++ = f;
2700 while(arity-- > 0)
2701 setVar(*a++);
2702 }
2703
2704 return TRUE;
2705 }
2706
2707
2708 int
PL_put_list(term_t l)2709 PL_put_list(term_t l)
2710 { GET_LD
2711 Word a = allocGlobal(3);
2712
2713 if ( a )
2714 { setHandle(l, consPtr(a, TAG_COMPOUND|STG_GLOBAL));
2715 *a++ = FUNCTOR_dot2;
2716 setVar(*a++);
2717 setVar(*a);
2718 return TRUE;
2719 }
2720
2721 return FALSE;
2722 }
2723
2724
2725 int
PL_put_nil(term_t l)2726 PL_put_nil(term_t l)
2727 { GET_LD
2728 setHandle(l, ATOM_nil);
2729
2730 return TRUE;
2731 }
2732
2733
2734 int
PL_put_term__LD(term_t t1,term_t t2 ARG_LD)2735 PL_put_term__LD(term_t t1, term_t t2 ARG_LD)
2736 { Word p2 = valHandleP(t2);
2737
2738 setHandle(t1, linkVal(p2));
2739 return TRUE;
2740 }
2741
2742
2743 #undef PL_put_term
2744 int
PL_put_term(term_t t1,term_t t2)2745 PL_put_term(term_t t1, term_t t2)
2746 { GET_LD
2747 Word p2 = valHandleP(t2);
2748
2749 setHandle(t1, linkVal(p2));
2750 return TRUE;
2751 }
2752 #define PL_put_term(t1, t2) PL_put_term__LD(t1, t2 PASS_LD)
2753
2754
2755 int
_PL_put_xpce_reference_i(term_t t,uintptr_t i)2756 _PL_put_xpce_reference_i(term_t t, uintptr_t i)
2757 { GET_LD
2758 Word p;
2759 word w;
2760
2761 if ( !hasGlobalSpace(2+2+WORDS_PER_INT64) )
2762 { int rc;
2763
2764 if ( (rc=ensureGlobalSpace(2+2+WORDS_PER_INT64, ALLOW_GC)) != TRUE )
2765 return raiseStackOverflow(rc);
2766 }
2767
2768 w = consInt(i);
2769 if ( valInt(w) != i )
2770 put_int64(&w, i, 0 PASS_LD);
2771
2772 p = gTop;
2773 gTop += 2;
2774 setHandle(t, consPtr(p, TAG_COMPOUND|STG_GLOBAL));
2775 *p++ = FUNCTOR_xpceref1;
2776 *p++ = w;
2777
2778 return TRUE;
2779 }
2780
2781
2782 int
_PL_put_xpce_reference_a(term_t t,atom_t name)2783 _PL_put_xpce_reference_a(term_t t, atom_t name)
2784 { GET_LD
2785 Word a = allocGlobal(2);
2786
2787 if ( a )
2788 { setHandle(t, consPtr(a, TAG_COMPOUND|STG_GLOBAL));
2789 *a++ = FUNCTOR_xpceref1;
2790 *a++ = name;
2791 return TRUE;
2792 }
2793 return FALSE;
2794 }
2795
2796
2797 /*******************************
2798 * UNIFY *
2799 *******************************/
2800
2801 int
PL_unify_atom__LD(term_t t,atom_t a ARG_LD)2802 PL_unify_atom__LD(term_t t, atom_t a ARG_LD)
2803 { return unifyAtomic(t, a PASS_LD);
2804 }
2805
2806 #undef PL_unify_atom
2807 int
PL_unify_atom(term_t t,atom_t a)2808 PL_unify_atom(term_t t, atom_t a)
2809 { GET_LD
2810 return unifyAtomic(t, a PASS_LD);
2811 }
2812 #define PL_unify_atom(t, a) PL_unify_atom__LD(t, a PASS_LD)
2813
2814
2815 int
PL_unify_compound(term_t t,functor_t f)2816 PL_unify_compound(term_t t, functor_t f)
2817 { GET_LD
2818 Word p = valHandleP(t);
2819 size_t arity = arityFunctor(f);
2820
2821 deRef(p);
2822 if ( canBind(*p) )
2823 { size_t needed = (1+arity);
2824 Word a;
2825 word to;
2826
2827 VALID_TERM_ARITY(arity);
2828 if ( !hasGlobalSpace(needed) )
2829 { int rc;
2830
2831 if ( (rc=ensureGlobalSpace(needed, ALLOW_GC)) != TRUE )
2832 return raiseStackOverflow(rc);
2833 p = valHandleP(t); /* reload: may have shifted */
2834 deRef(p);
2835 }
2836
2837 a = gTop;
2838 to = consPtr(a, TAG_COMPOUND|STG_GLOBAL);
2839
2840 gTop += 1+arity;
2841 *a = f;
2842 while( arity-- > 0 )
2843 setVar(*++a);
2844
2845 bindConst(p, to);
2846
2847 succeed;
2848 } else
2849 { return hasFunctor(*p, f);
2850 }
2851 }
2852
2853
2854 int
PL_unify_functor__LD(term_t t,functor_t f ARG_LD)2855 PL_unify_functor__LD(term_t t, functor_t f ARG_LD)
2856 { Word p = valHandleP(t);
2857 size_t arity = arityFunctor(f);
2858
2859 deRef(p);
2860 if ( canBind(*p) )
2861 { size_t needed = (1+arity);
2862
2863 VALID_TERM_ARITY(arity);
2864 if ( !hasGlobalSpace(needed) )
2865 { int rc;
2866
2867 if ( (rc=ensureGlobalSpace(needed, ALLOW_GC)) != TRUE )
2868 return raiseStackOverflow(rc);
2869 p = valHandleP(t); /* reload: may have shifted */
2870 deRef(p);
2871 }
2872
2873 if ( arity == 0 )
2874 { word name = nameFunctor(f);
2875 bindConst(p, name);
2876 } else
2877 { Word a = gTop;
2878 word to = consPtr(a, TAG_COMPOUND|STG_GLOBAL);
2879
2880 gTop += 1+arity;
2881 *a = f;
2882 while( arity-- > 0 )
2883 setVar(*++a);
2884
2885 bindConst(p, to);
2886 }
2887
2888 succeed;
2889 } else
2890 { if ( arity == 0 )
2891 { if ( *p == nameFunctor(f) )
2892 succeed;
2893 } else
2894 { if ( hasFunctor(*p, f) )
2895 succeed;
2896 }
2897
2898 fail;
2899 }
2900 }
2901
2902
2903 #undef PL_unify_functor
2904
2905 int
PL_unify_functor(term_t t,functor_t f)2906 PL_unify_functor(term_t t, functor_t f)
2907 { GET_LD
2908
2909 return PL_unify_functor__LD(t, f PASS_LD);
2910 }
2911
2912 #define PL_unify_functor(t, f) PL_unify_functor__LD(t, f PASS_LD)
2913
2914 int
PL_unify_atom_chars(term_t t,const char * chars)2915 PL_unify_atom_chars(term_t t, const char *chars)
2916 { GET_LD
2917 atom_t a = lookupAtom(chars, strlen(chars));
2918 int rval = unifyAtomic(t, a PASS_LD);
2919
2920 PL_unregister_atom(a);
2921
2922 return rval;
2923 }
2924
2925
2926 int
PL_unify_atom_nchars(term_t t,size_t len,const char * chars)2927 PL_unify_atom_nchars(term_t t, size_t len, const char *chars)
2928 { GET_LD
2929 atom_t a = lookupAtom(chars, len);
2930 int rval = unifyAtomic(t, a PASS_LD);
2931
2932 PL_unregister_atom(a);
2933
2934 return rval;
2935 }
2936
2937
2938 static atom_t
uncachedCodeToAtom(int chrcode)2939 uncachedCodeToAtom(int chrcode)
2940 { if ( chrcode < 256 )
2941 { char tmp[1];
2942
2943 tmp[0] = (char)chrcode;
2944 return lookupAtom(tmp, 1);
2945 } else
2946 { pl_wchar_t tmp[1];
2947 int new;
2948
2949 tmp[0] = chrcode;
2950
2951 return lookupBlob((const char *)tmp, sizeof(pl_wchar_t),
2952 &ucs_atom, &new);
2953 }
2954 }
2955
2956
2957 atom_t
codeToAtom(int chrcode)2958 codeToAtom(int chrcode)
2959 { atom_t a;
2960
2961 if ( chrcode == EOF )
2962 return ATOM_end_of_file;
2963
2964 assert(chrcode >= 0);
2965
2966 if ( chrcode < (1<<15) )
2967 { int page = chrcode / 256;
2968 int entry = chrcode % 256;
2969 atom_t *pv;
2970
2971 if ( !(pv=GD->atoms.for_code[page]) )
2972 { pv = PL_malloc(256*sizeof(atom_t));
2973
2974 memset(pv, 0, 256*sizeof(atom_t));
2975 GD->atoms.for_code[page] = pv;
2976 }
2977
2978 if ( !(a=pv[entry]) )
2979 { a = pv[entry] = uncachedCodeToAtom(chrcode);
2980 }
2981 } else
2982 { a = uncachedCodeToAtom(chrcode);
2983 }
2984
2985 return a;
2986 }
2987
2988
2989 void
cleanupCodeToAtom(void)2990 cleanupCodeToAtom(void)
2991 { int page;
2992 atom_t **pv;
2993
2994 for(page=0, pv=GD->atoms.for_code; page<256; page++)
2995 { if ( *pv )
2996 { void *ptr = *pv;
2997 *pv = NULL;
2998 PL_free(ptr);
2999 }
3000 }
3001 }
3002
3003
3004 int
PL_unify_list_ncodes(term_t l,size_t len,const char * chars)3005 PL_unify_list_ncodes(term_t l, size_t len, const char *chars)
3006 { GET_LD
3007 if ( PL_is_variable(l) )
3008 { term_t tmp = PL_new_term_ref();
3009
3010 return (PL_put_list_ncodes(tmp, len, chars) &&
3011 PL_unify(l, tmp));
3012 } else
3013 { term_t head = PL_new_term_ref();
3014 term_t t = PL_copy_term_ref(l);
3015 int rval;
3016
3017 for( ; len-- != 0; chars++ )
3018 { if ( !PL_unify_list(t, head, t) ||
3019 !PL_unify_integer(head, (int)*chars & 0xff) )
3020 fail;
3021 }
3022
3023 rval = PL_unify_nil(t);
3024 PL_reset_term_refs(head);
3025
3026 return rval;
3027 }
3028 }
3029
3030
3031 int
PL_unify_list_codes(term_t l,const char * chars)3032 PL_unify_list_codes(term_t l, const char *chars)
3033 { return PL_unify_list_ncodes(l, strlen(chars), chars);
3034 }
3035
3036
3037 int
PL_unify_list_nchars(term_t l,size_t len,const char * chars)3038 PL_unify_list_nchars(term_t l, size_t len, const char *chars)
3039 { GET_LD
3040 if ( PL_is_variable(l) )
3041 { term_t tmp = PL_new_term_ref();
3042
3043 return (PL_put_list_nchars(tmp, len, chars) &&
3044 PL_unify(l, tmp));
3045 } else
3046 { term_t head = PL_new_term_ref();
3047 term_t t = PL_copy_term_ref(l);
3048 int rval;
3049
3050 for( ; len-- != 0; chars++ )
3051 { if ( !PL_unify_list(t, head, t) ||
3052 !PL_unify_atom(head, codeToAtom(*chars & 0xff)) )
3053 fail;
3054 }
3055
3056 rval = PL_unify_nil(t);
3057 PL_reset_term_refs(head);
3058
3059 return rval;
3060 }
3061 }
3062
3063
3064 int
PL_unify_list_chars(term_t l,const char * chars)3065 PL_unify_list_chars(term_t l, const char *chars)
3066 { return PL_unify_list_nchars(l, strlen(chars), chars);
3067 }
3068
3069
3070 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3071 flags: bitwise or of type and representation
3072
3073 Types: PL_ATOM, PL_STRING, PL_CODE_LIST, PL_CHAR_LIST
3074 Representation: REP_ISO_LATIN_1, REP_UTF8, REP_MB
3075 Extra: PL_DIFF_LIST
3076 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3077
3078 int
PL_unify_chars(term_t t,int flags,size_t len,const char * s)3079 PL_unify_chars(term_t t, int flags, size_t len, const char *s)
3080 { PL_chars_t text;
3081 term_t tail;
3082 int rc;
3083
3084 if ( len == (size_t)-1 )
3085 len = strlen(s);
3086
3087 text.text.t = (char *)s;
3088 text.encoding = ((flags&REP_UTF8) ? ENC_UTF8 : \
3089 (flags&REP_MB) ? ENC_ANSI : ENC_ISO_LATIN_1);
3090 text.storage = PL_CHARS_HEAP;
3091 text.length = len;
3092 text.canonical = FALSE;
3093
3094 flags &= ~(REP_UTF8|REP_MB|REP_ISO_LATIN_1);
3095
3096 if ( (flags & PL_DIFF_LIST) )
3097 { tail = t+1;
3098 flags &= (~PL_DIFF_LIST);
3099 } else
3100 { tail = 0;
3101 }
3102
3103 rc = PL_unify_text(t, tail, &text, flags);
3104 PL_free_text(&text);
3105
3106 return rc;
3107 }
3108
3109
3110 static int
unify_int64_ex__LD(term_t t,int64_t i,int ex ARG_LD)3111 unify_int64_ex__LD(term_t t, int64_t i, int ex ARG_LD)
3112 { word w = consInt(i);
3113 Word p = valHandleP(t);
3114
3115 deRef(p);
3116
3117 if ( canBind(*p) )
3118 { if ( !hasGlobalSpace(2+WORDS_PER_INT64) )
3119 { int rc;
3120
3121 if ( (rc=ensureGlobalSpace(2+WORDS_PER_INT64, ALLOW_GC)) != TRUE )
3122 return raiseStackOverflow(rc);
3123 p = valHandleP(t);
3124 deRef(p);
3125 }
3126
3127 if ( valInt(w) != i )
3128 put_int64(&w, i, 0 PASS_LD);
3129
3130 bindConst(p, w);
3131 succeed;
3132 }
3133
3134 if ( w == *p && valInt(w) == i )
3135 succeed;
3136
3137 if ( isBignum(*p) )
3138 return valBignum(*p) == i;
3139
3140 if ( ex && !isInteger(*p) )
3141 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t);
3142
3143 fail;
3144 }
3145
3146
3147 int
PL_unify_int64_ex__LD(term_t t,int64_t i ARG_LD)3148 PL_unify_int64_ex__LD(term_t t, int64_t i ARG_LD)
3149 { return unify_int64_ex__LD(t, i, TRUE PASS_LD);
3150 }
3151
3152 int
PL_unify_int64__LD(term_t t,int64_t i ARG_LD)3153 PL_unify_int64__LD(term_t t, int64_t i ARG_LD)
3154 { return unify_int64_ex__LD(t, i, FALSE PASS_LD);
3155 }
3156
3157 int
PL_unify_uint64(term_t t,uint64_t i)3158 PL_unify_uint64(term_t t, uint64_t i)
3159 { GET_LD
3160
3161 if ( (int64_t)i >= 0 )
3162 { return unify_int64_ex__LD(t, i, TRUE PASS_LD);
3163 } else if ( PL_is_variable(t) )
3164 { word w;
3165 int rc;
3166
3167 switch ( (rc=put_uint64(&w, i, ALLOW_GC PASS_LD)) )
3168 { case TRUE:
3169 return unifyAtomic(t, w PASS_LD);
3170 case LOCAL_OVERFLOW:
3171 return PL_representation_error("uint64_t");
3172 default:
3173 return raiseStackOverflow(rc);
3174 }
3175 } else
3176 { number n;
3177
3178 if ( PL_get_number(t, &n) )
3179 { switch(n.type)
3180 { case V_INTEGER:
3181 return FALSE; /* we have a too big integer */
3182 #ifdef O_GMP
3183 case V_MPZ:
3184 { uint64_t v;
3185
3186 if ( mpz_to_uint64(n.value.mpz, &v) == 0 )
3187 return v == i;
3188 }
3189 #endif
3190 default:
3191 break;
3192 }
3193 }
3194
3195 return FALSE;
3196 }
3197 }
3198
3199 int
PL_unify_integer__LD(term_t t,intptr_t i ARG_LD)3200 PL_unify_integer__LD(term_t t, intptr_t i ARG_LD)
3201 { word w = consInt(i);
3202
3203 if ( valInt(w) == i )
3204 return unifyAtomic(t, w PASS_LD);
3205
3206 return unify_int64_ex__LD(t, i, FALSE PASS_LD);
3207 }
3208
3209
3210 #undef PL_unify_integer
3211 int
PL_unify_integer(term_t t,intptr_t i)3212 PL_unify_integer(term_t t, intptr_t i)
3213 { GET_LD
3214 return unify_int64_ex__LD(t, i, FALSE PASS_LD);
3215 }
3216 #define PL_unify_integer(t, i) PL_unify_integer__LD(t, i PASS_LD)
3217
3218 #undef PL_unify_int64
3219 int
PL_unify_int64(term_t t,int64_t i)3220 PL_unify_int64(term_t t, int64_t i)
3221 { GET_LD
3222
3223 return unify_int64_ex__LD(t, i, FALSE PASS_LD);
3224 }
3225 #define PL_unify_int64(t, i) PL_unify_int64__LD(t, i PASS_LD)
3226
3227 int
PL_unify_pointer__LD(term_t t,void * ptr ARG_LD)3228 PL_unify_pointer__LD(term_t t, void *ptr ARG_LD)
3229 { uint64_t i = pointerToInt(ptr);
3230
3231 return unify_int64_ex__LD(t, (int64_t)i, FALSE PASS_LD);
3232 }
3233
3234
3235 #undef PL_unify_pointer
3236 int
PL_unify_pointer(term_t t,void * ptr)3237 PL_unify_pointer(term_t t, void *ptr)
3238 { GET_LD
3239
3240 return PL_unify_pointer__LD(t, ptr PASS_LD);
3241 }
3242 #define PL_unify_pointer(t, ptr) PL_unify_pointer__LD(t, ptr PASS_LD)
3243
3244
3245 int
PL_unify_float(term_t t,double f)3246 PL_unify_float(term_t t, double f)
3247 { GET_LD
3248 Word p = valHandleP(t);
3249
3250 deRef(p);
3251
3252 if ( canBind(*p) )
3253 { word w;
3254
3255 if ( !hasGlobalSpace(2+WORDS_PER_DOUBLE) )
3256 { int rc;
3257
3258 if ( (rc=ensureGlobalSpace(2+WORDS_PER_DOUBLE, ALLOW_GC)) != TRUE )
3259 return raiseStackOverflow(rc);
3260 p = valHandleP(t);
3261 deRef(p);
3262 }
3263
3264 put_double(&w, f, ALLOW_CHECKED PASS_LD);
3265 bindConst(p, w);
3266 succeed;
3267 }
3268
3269 if ( isFloat(*p) && valFloat(*p) == f )
3270 succeed;
3271
3272 fail;
3273 }
3274
3275
3276 int
PL_unify_bool(term_t t,int val)3277 PL_unify_bool(term_t t, int val)
3278 { GET_LD
3279
3280 return PL_unify_atom(t, val ? ATOM_true : ATOM_false);
3281 }
3282
3283
3284 int
PL_unify_arg_sz(size_t index,term_t t,term_t a)3285 PL_unify_arg_sz(size_t index, term_t t, term_t a)
3286 { GET_LD
3287 word w = valHandle(t);
3288
3289 if ( isTerm(w) &&
3290 index > 0 &&
3291 index <= arityFunctor(functorTerm(w)) )
3292 { Word p = argTermP(w, index-1);
3293 Word p2 = valHandleP(a);
3294
3295 return unify_ptrs(p, p2, ALLOW_GC|ALLOW_SHIFT PASS_LD);
3296 }
3297
3298 fail;
3299 }
3300
3301 #undef PL_unify_arg
3302 int
PL_unify_arg(int index,term_t t,term_t a)3303 PL_unify_arg(int index, term_t t, term_t a)
3304 { if ( index >= 0 )
3305 return PL_unify_arg_sz(index, t, a);
3306 fatalError("Index out of range: %d", index);
3307 return FALSE;
3308 }
3309 #define PL_unify_arg(i,t,a) PL_unify_arg_sz(i,t,a)
3310
3311 int
PL_unify_list__LD(term_t l,term_t h,term_t t ARG_LD)3312 PL_unify_list__LD(term_t l, term_t h, term_t t ARG_LD)
3313 { Word p = valHandleP(l);
3314
3315 deRef(p);
3316
3317 if ( canBind(*p) )
3318 { Word a;
3319 word c;
3320
3321 if ( !hasGlobalSpace(3) )
3322 { int rc;
3323
3324 if ( (rc=ensureGlobalSpace(3, ALLOW_GC)) != TRUE )
3325 return raiseStackOverflow(rc);
3326 p = valHandleP(l); /* reload: may have shifted */
3327 deRef(p);
3328 }
3329
3330 a = gTop;
3331 gTop += 3;
3332
3333 c = consPtr(a, TAG_COMPOUND|STG_GLOBAL);
3334 *a++ = FUNCTOR_dot2;
3335 setVar(*a);
3336 setHandle(h, makeRefG(a));
3337 setVar(*++a);
3338 setHandle(t, makeRefG(a));
3339
3340 bindConst(p, c);
3341 } else if ( isList(*p) )
3342 { Word a = argTermP(*p, 0);
3343
3344 setHandle(h, linkVal(a++));
3345 setHandle(t, linkVal(a));
3346 } else
3347 fail;
3348
3349 succeed;
3350 }
3351
3352
3353 #undef PL_unify_list
3354 int
PL_unify_list(term_t l,term_t h,term_t t)3355 PL_unify_list(term_t l, term_t h, term_t t)
3356 { GET_LD
3357
3358 return PL_unify_list__LD(l, h, t PASS_LD);
3359 }
3360 #define PL_unify_list(l, h, t) PL_unify_list__LD(l, h, t PASS_LD)
3361
3362
3363 int
PL_unify_nil(term_t l)3364 PL_unify_nil(term_t l)
3365 { GET_LD
3366 return unifyAtomic(l, ATOM_nil PASS_LD);
3367 }
3368
3369
3370 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3371 PL_unify_termv(term_t t, va_list args)
3372
3373 This is really complicated. There appears to be no portable way to write
3374 a recursive function using va_list as argument, each call pulling some
3375 arguments from the list, as va_list can be any type, including an array
3376 of dynamic unspecified size. So, our only option is to avoid recursion
3377 and do everything by hand. Luckily I was raised in the days Dijkstra
3378 couldn't cope with recursion and explained you could always translate it
3379 into normal loops :-)
3380
3381 Best implementation for the agenda would be alloca(), but alloca() has
3382 several portability problems of its own, so we will go for using buffers
3383 as defined in pl-buffer.h.
3384 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3385
3386 typedef struct
3387 { enum
3388 { w_term, /* Agenda is a term */
3389 w_list /* agenda is a list */
3390 } type;
3391 union
3392 { struct
3393 { term_t term; /* term for which to do work on */
3394 size_t arity; /* arity of the term */
3395 size_t arg; /* current argument */
3396 } term;
3397 struct
3398 { term_t tail; /* tail of list */
3399 int len; /* elements left */
3400 } list;
3401 } value;
3402 } work;
3403
3404
3405 int
PL_unify_termv__LD(term_t t ARG_LD,va_list args)3406 PL_unify_termv__LD(term_t t ARG_LD, va_list args)
3407 { term_t tsave = PL_new_term_refs(0); /* save for reclaim */
3408 tmp_buffer buf;
3409 int tos = 0; /* Top-of-stack */
3410 int rval;
3411 int op;
3412
3413 if ( !(t = PL_copy_term_ref(t)) )
3414 return FALSE;
3415 initBuffer(&buf);
3416
3417 cont:
3418 switch((op=va_arg(args, int)))
3419 { case PL_VARIABLE:
3420 rval = TRUE;
3421 break;
3422 case PL_ATOM:
3423 rval = PL_unify_atom(t, va_arg(args, atom_t));
3424 break;
3425 case PL_BOOL:
3426 { int v = va_arg(args, int);
3427 rval = PL_unify_atom(t, v ? ATOM_true : ATOM_false);
3428 break;
3429 }
3430 case PL_SHORT:
3431 case PL_INT:
3432 rval = PL_unify_integer(t, va_arg(args, int));
3433 break;
3434 case PL_INTEGER:
3435 case PL_LONG:
3436 rval = PL_unify_integer(t, va_arg(args, long));
3437 break;
3438 case PL_INT64:
3439 rval = PL_unify_int64(t, va_arg(args, int64_t));
3440 break;
3441 case PL_INTPTR:
3442 { int64_t i = va_arg(args, intptr_t);
3443 rval = PL_unify_int64(t, i);
3444 break;
3445 }
3446 case PL_POINTER:
3447 rval = PL_unify_pointer(t, va_arg(args, void *));
3448 break;
3449 case PL_FLOAT:
3450 case PL_DOUBLE:
3451 rval = PL_unify_float(t, va_arg(args, double));
3452 break;
3453 case PL_STRING:
3454 rval = PL_unify_string_chars(t, va_arg(args, const char *));
3455 break;
3456 case PL_TERM:
3457 rval = PL_unify(t, va_arg(args, term_t));
3458 break;
3459 case PL_CHARS:
3460 rval = PL_unify_atom_chars(t, va_arg(args, const char *));
3461 break;
3462 case PL_NCHARS:
3463 { size_t len = va_arg(args, size_t);
3464 const char *s = va_arg(args, const char *);
3465
3466 rval = PL_unify_atom_nchars(t, len, s);
3467 break;
3468 }
3469 case PL_UTF8_CHARS:
3470 case PL_UTF8_STRING:
3471 { PL_chars_t txt;
3472
3473 txt.text.t = va_arg(args, char *);
3474 txt.length = strlen(txt.text.t);
3475 txt.storage = PL_CHARS_HEAP;
3476 txt.encoding = ENC_UTF8;
3477 txt.canonical = FALSE;
3478
3479 rval = PL_unify_text(t, 0, &txt,
3480 op == PL_UTF8_STRING ? PL_STRING : PL_ATOM);
3481 PL_free_text(&txt);
3482
3483 break;
3484 }
3485 case PL_NUTF8_CHARS:
3486 case PL_NUTF8_CODES:
3487 case PL_NUTF8_STRING:
3488 { PL_chars_t txt;
3489
3490 txt.length = va_arg(args, size_t);
3491 txt.text.t = va_arg(args, char *);
3492 txt.storage = PL_CHARS_HEAP;
3493 txt.encoding = ENC_UTF8;
3494 txt.canonical = FALSE;
3495
3496 rval = PL_unify_text(t, 0, &txt,
3497 op == PL_NUTF8_CHARS ? PL_ATOM :
3498 op == PL_NUTF8_CODES ? PL_CODE_LIST :
3499 PL_STRING);
3500 PL_free_text(&txt);
3501
3502 break;
3503 }
3504 case PL_NWCHARS:
3505 case PL_NWCODES:
3506 case PL_NWSTRING:
3507 { PL_chars_t txt;
3508
3509 txt.length = va_arg(args, size_t);
3510 txt.text.w = va_arg(args, wchar_t *);
3511 txt.storage = PL_CHARS_HEAP;
3512 txt.encoding = ENC_WCHAR;
3513 txt.canonical = FALSE;
3514
3515 if ( txt.length == (size_t)-1 )
3516 txt.length = wcslen(txt.text.w );
3517
3518 rval = PL_unify_text(t, 0, &txt,
3519 op == PL_NWCHARS ? PL_ATOM :
3520 op == PL_NWCODES ? PL_CODE_LIST :
3521 PL_STRING);
3522 PL_free_text(&txt);
3523
3524 break;
3525 }
3526 case PL_MBCHARS:
3527 case PL_MBCODES:
3528 case PL_MBSTRING:
3529 { PL_chars_t txt;
3530
3531 txt.text.t = va_arg(args, char *);
3532 txt.length = strlen(txt.text.t);
3533 txt.storage = PL_CHARS_HEAP;
3534 txt.encoding = ENC_ANSI;
3535 txt.canonical = FALSE;
3536
3537 rval = PL_unify_text(t, 0, &txt,
3538 op == PL_MBCHARS ? PL_ATOM :
3539 op == PL_MBCODES ? PL_CODE_LIST :
3540 PL_STRING);
3541 PL_free_text(&txt);
3542
3543 break;
3544 }
3545 { functor_t ft;
3546 size_t arity;
3547
3548 case PL_FUNCTOR_CHARS:
3549 { const char *s = va_arg(args, const char *);
3550 atom_t a = PL_new_atom(s);
3551
3552 arity = va_arg(args, int);
3553 ft = PL_new_functor(a, arity);
3554 PL_unregister_atom(a);
3555 goto common_f;
3556 }
3557 case PL_FUNCTOR:
3558 { work w;
3559
3560 ft = va_arg(args, functor_t);
3561 arity = arityFunctor(ft);
3562
3563 common_f:
3564 if ( !PL_unify_functor(t, ft) )
3565 goto failout;
3566
3567 w.type = w_term;
3568 if ( !(w.value.term.term = PL_copy_term_ref(t)) )
3569 return FALSE;
3570 w.value.term.arg = 0;
3571 w.value.term.arity = arity;
3572 addBuffer(&buf, w, work);
3573 tos++;
3574
3575 rval = TRUE;
3576 break;
3577 }
3578 }
3579 case PL_LIST:
3580 { work w;
3581
3582 w.type = w_list;
3583 if ( !(w.value.list.tail = PL_copy_term_ref(t)) )
3584 return FALSE;
3585 w.value.list.len = va_arg(args, int);
3586
3587 addBuffer(&buf, w, work);
3588 tos++;
3589
3590 rval = TRUE;
3591 break;
3592 }
3593 case _PL_PREDICATE_INDICATOR:
3594 { predicate_t proc = va_arg(args, predicate_t);
3595
3596 rval = unify_definition(MODULE_user, t, proc->definition,
3597 0, GP_HIDESYSTEM|GP_NAMEARITY);
3598 break;
3599 }
3600 default:
3601 PL_warning("Format error in PL_unify_term()");
3602 goto failout;
3603 }
3604
3605 if ( rval )
3606 { while( tos > 0 )
3607 { work *w = &baseBuffer(&buf, work)[tos-1];
3608
3609 switch( w->type )
3610 { case w_term:
3611 if ( w->value.term.arg < w->value.term.arity )
3612 { _PL_get_arg(++w->value.term.arg,
3613 w->value.term.term, t);
3614 goto cont;
3615 } else
3616 { tos--;
3617 seekBuffer(&buf, tos, work);
3618 break;
3619 }
3620 case w_list:
3621 { if ( w->value.list.len > 0 )
3622 { if ( PL_unify_list(w->value.list.tail, t, w->value.list.tail) )
3623 { w->value.list.len--;
3624 goto cont;
3625 }
3626 } else if ( PL_unify_nil(w->value.list.tail) )
3627 { tos--;
3628 seekBuffer(&buf, tos, work);
3629 } else
3630 goto failout;
3631 }
3632 }
3633 }
3634
3635 PL_reset_term_refs(tsave);
3636 discardBuffer(&buf);
3637 return TRUE;
3638 }
3639
3640 failout:
3641 PL_reset_term_refs(tsave);
3642 discardBuffer(&buf);
3643
3644 return FALSE;
3645 }
3646
3647 int
PL_unify_termv(term_t t,va_list args)3648 PL_unify_termv(term_t t, va_list args)
3649 { GET_LD
3650
3651 return PL_unify_termv__LD(t PASS_LD, args);
3652 }
3653
3654
3655 int
PL_unify_term__LD(term_t t ARG_LD,...)3656 PL_unify_term__LD(term_t t ARG_LD, ...)
3657 { va_list args;
3658 int rval;
3659
3660 #if defined(O_PLMT) || defined(O_MULTIPLE_ENGINES)
3661 va_start(args, LOCAL_LD);
3662 #else
3663 va_start(args, t);
3664 #endif
3665 rval = PL_unify_termv__LD(t PASS_LD, args);
3666 va_end(args);
3667
3668 return rval;
3669 }
3670
3671
3672 #undef PL_unify_term
3673 int
PL_unify_term(term_t t,...)3674 PL_unify_term(term_t t, ...)
3675 { GET_LD
3676 va_list args;
3677 int rval;
3678
3679 va_start(args, t);
3680 rval = PL_unify_termv__LD(t PASS_LD, args);
3681 va_end(args);
3682
3683 return rval;
3684 }
3685 #define PL_unify_term(t, ...) PL_unify_term__LD(t PASS_LD, __VA_ARGS__)
3686
3687 static inline word
put_xpce_ref_arg(xpceref_t * ref ARG_LD)3688 put_xpce_ref_arg(xpceref_t *ref ARG_LD)
3689 { if ( ref->type == PL_INTEGER )
3690 { word w = consInt(ref->value.i);
3691
3692 if ( valInt(w) != ref->value.i )
3693 put_int64(&w, ref->value.i, 0 PASS_LD);
3694
3695 return w;
3696 }
3697
3698 return ref->value.a;
3699 }
3700
3701
3702 int
_PL_unify_xpce_reference(term_t t,xpceref_t * ref)3703 _PL_unify_xpce_reference(term_t t, xpceref_t *ref)
3704 { GET_LD
3705 Word p;
3706
3707 if ( !hasGlobalSpace(2+2+WORDS_PER_INT64) )
3708 { int rc;
3709
3710 if ( (rc=ensureGlobalSpace(2+2+WORDS_PER_INT64, ALLOW_GC)) != TRUE )
3711 return raiseStackOverflow(rc);
3712 }
3713
3714 p = valHandleP(t);
3715
3716 do
3717 { if ( canBind(*p) )
3718 { Word a;
3719 word c;
3720
3721 a = gTop;
3722 gTop += 2;
3723 c = consPtr(a, TAG_COMPOUND|STG_GLOBAL);
3724
3725 *a++ = FUNCTOR_xpceref1;
3726 *a++ = put_xpce_ref_arg(ref PASS_LD);
3727
3728 bindConst(p, c);
3729 succeed;
3730 }
3731 if ( hasFunctor(*p, FUNCTOR_xpceref1) )
3732 { Word a = argTermP(*p, 0);
3733
3734 deRef(a);
3735 if ( canBind(*a) )
3736 { word c = put_xpce_ref_arg(ref PASS_LD);
3737
3738 bindConst(a, c);
3739 succeed;
3740 } else
3741 { if ( ref->type == PL_INTEGER )
3742 return ( isInteger(*a) &&
3743 valInteger(*a) == ref->value.i );
3744 else
3745 return *a == ref->value.a;
3746 }
3747 }
3748 } while ( isRef(*p) && (p = unRef(*p)) );
3749
3750 fail;
3751 }
3752
3753
3754 /*******************************
3755 * ATOMIC (INTERNAL) *
3756 *******************************/
3757
3758 #undef _PL_unify_atomic
3759
3760 PL_atomic_t
_PL_get_atomic(term_t t)3761 _PL_get_atomic(term_t t)
3762 { GET_LD
3763 return valHandle(t);
3764 }
3765
3766
3767 int
_PL_unify_atomic(term_t t,PL_atomic_t a)3768 _PL_unify_atomic(term_t t, PL_atomic_t a)
3769 { GET_LD
3770 return unifyAtomic(t, a PASS_LD);
3771 }
3772
3773
3774 void
_PL_put_atomic(term_t t,PL_atomic_t a)3775 _PL_put_atomic(term_t t, PL_atomic_t a)
3776 { GET_LD
3777 setHandle(t, a);
3778 }
3779
3780 #define _PL_unify_atomic(t, a) PL_unify_atom__LD(t, a PASS_LD)
3781
3782
3783 /*******************************
3784 * BLOBS *
3785 *******************************/
3786
3787 int
PL_unify_blob(term_t t,void * blob,size_t len,PL_blob_t * type)3788 PL_unify_blob(term_t t, void *blob, size_t len, PL_blob_t *type)
3789 { GET_LD
3790 int new;
3791 atom_t a = lookupBlob(blob, len, type, &new);
3792 int rval = unifyAtomic(t, a PASS_LD);
3793
3794 PL_unregister_atom(a);
3795
3796 return rval;
3797 }
3798
3799
3800 int
PL_put_blob(term_t t,void * blob,size_t len,PL_blob_t * type)3801 PL_put_blob(term_t t, void *blob, size_t len, PL_blob_t *type)
3802 { GET_LD
3803 int new;
3804 atom_t a = lookupBlob(blob, len, type, &new);
3805
3806 setHandle(t, a);
3807 PL_unregister_atom(a);
3808
3809 return new;
3810 }
3811
3812
3813 int
PL_get_blob(term_t t,void ** blob,size_t * len,PL_blob_t ** type)3814 PL_get_blob(term_t t, void **blob, size_t *len, PL_blob_t **type)
3815 { GET_LD
3816 word w = valHandle(t);
3817
3818 if ( isAtom(w) )
3819 { Atom a = atomValue(w);
3820
3821 if ( blob )
3822 *blob = a->name;
3823 if ( len )
3824 *len = a->length;
3825 if ( type )
3826 *type = a->type;
3827
3828 succeed;
3829 }
3830
3831 fail;
3832 }
3833
3834
3835 void *
PL_blob_data(atom_t a,size_t * len,PL_blob_t ** type)3836 PL_blob_data(atom_t a, size_t *len, PL_blob_t **type)
3837 { Atom x = atomValue(a);
3838
3839 if ( len )
3840 *len = x->length;
3841 if ( type )
3842 *type = x->type;
3843
3844 return x->name;
3845 }
3846
3847
3848 /*******************************
3849 * DICT *
3850 *******************************/
3851
3852 int
PL_put_dict(term_t t,atom_t tag,size_t len,const atom_t * keys,term_t values)3853 PL_put_dict(term_t t, atom_t tag,
3854 size_t len, const atom_t *keys, term_t values)
3855 { GET_LD
3856 Word p, p0;
3857 size_t size = len*2+2;
3858
3859 if ( (p0=p=allocGlobal(size)) )
3860 { *p++ = dict_functor(len);
3861 if ( tag )
3862 { if ( isAtom(tag) )
3863 { *p++ = tag;
3864 } else
3865 { invalid:
3866 gTop -= size;
3867 return -1;
3868 }
3869 } else
3870 { setVar(*p++);
3871 }
3872
3873 for(; len-- > 0; keys++, values++)
3874 { *p++ = linkVal(valTermRef(values));
3875 if ( is_dict_key(*keys) )
3876 *p++ = *keys;
3877 else
3878 goto invalid;
3879 }
3880
3881 if ( dict_order(p0, TRUE PASS_LD) )
3882 { setHandle(t, consPtr(p0, TAG_COMPOUND|STG_GLOBAL));
3883 DEBUG(CHK_SECURE, checkStacks(NULL));
3884 return TRUE;
3885 }
3886
3887 gTop -= size;
3888 return -2;
3889 }
3890
3891 return FALSE;
3892 }
3893
3894
3895 /*******************************
3896 * TYPE *
3897 *******************************/
3898
3899
3900 int
PL_term_type(term_t t)3901 PL_term_type(term_t t)
3902 { GET_LD
3903 word w = valHandle(t);
3904 int t0 = type_map[tag(w)];
3905
3906 switch(t0)
3907 { case PL_ATOM:
3908 { if ( isTextAtom(w) )
3909 return t0;
3910 if ( w == ATOM_nil )
3911 return PL_NIL;
3912 return PL_BLOB;
3913 }
3914 case PL_INTEGER:
3915 { return (isInteger(w) ? PL_INTEGER : PL_RATIONAL);
3916 }
3917 case PL_TERM:
3918 { functor_t f = valueTerm(w)->definition;
3919 FunctorDef fd = valueFunctor(f);
3920
3921 if ( f == FUNCTOR_dot2 )
3922 return PL_LIST_PAIR;
3923 if ( fd->name == ATOM_dict )
3924 return PL_DICT;
3925 }
3926 /*FALLTHROUGH*/
3927 default:
3928 return t0;
3929 }
3930 }
3931
3932
3933 /*******************************
3934 * UNIFY *
3935 *******************************/
3936
3937
3938
3939 int
PL_unify__LD(term_t t1,term_t t2 ARG_LD)3940 PL_unify__LD(term_t t1, term_t t2 ARG_LD)
3941 { Word p1 = valHandleP(t1);
3942 Word p2 = valHandleP(t2);
3943
3944 return unify_ptrs(p1, p2, ALLOW_GC|ALLOW_SHIFT PASS_LD);
3945 }
3946
3947 #undef PL_unify
3948
3949 int
PL_unify(term_t t1,term_t t2)3950 PL_unify(term_t t1, term_t t2)
3951 { GET_LD
3952
3953 return PL_unify__LD(t1, t2 PASS_LD);
3954 }
3955
3956 #define PL_unify(t1, t2) PL_unify__LD(t1, t2 PASS_LD)
3957
3958 /*
3959 * Unify an output argument. Only deals with the simple case
3960 * where the output argument is unbound and the value is bound.
3961 */
3962
3963 int
PL_unify_output__LD(term_t t1,term_t t2 ARG_LD)3964 PL_unify_output__LD(term_t t1, term_t t2 ARG_LD)
3965 { Word p1 = valHandleP(t1);
3966 Word p2 = valHandleP(t2);
3967
3968 deRef(p1);
3969 deRef(p2);
3970 if ( canBind(*p1) && !canBind(*p2) &&
3971 hasGlobalSpace(0) )
3972 { bindConst(p1, *p2);
3973 return TRUE;
3974 } else
3975 { return unify_ptrs(p1, p2, ALLOW_GC|ALLOW_SHIFT PASS_LD);
3976 }
3977 }
3978
3979
3980
3981 /*******************************
3982 * MODULES *
3983 *******************************/
3984
3985 int
PL_strip_module__LD(term_t raw,module_t * m,term_t plain,int flags ARG_LD)3986 PL_strip_module__LD(term_t raw, module_t *m, term_t plain, int flags ARG_LD)
3987 { Word p = valTermRef(raw);
3988
3989 deRef(p);
3990 if ( hasFunctor(*p, FUNCTOR_colon2) )
3991 { if ( !(p = stripModule(p, m, flags PASS_LD)) )
3992 return FALSE;
3993 setHandle(plain, linkVal(p));
3994 } else
3995 { if ( *m == NULL )
3996 *m = environment_frame ? contextModule(environment_frame)
3997 : MODULE_user;
3998 if ( raw != plain )
3999 setHandle(plain, linkVal(p));
4000 }
4001
4002 return TRUE;
4003 }
4004
4005 #undef PL_strip_module
4006 int
PL_strip_module(term_t raw,module_t * m,term_t plain)4007 PL_strip_module(term_t raw, module_t *m, term_t plain)
4008 { GET_LD
4009 return PL_strip_module__LD(raw, m, plain, 0 PASS_LD);
4010 }
4011 #define PL_strip_module(q, m, t) PL_strip_module__LD(q, m, t, 0 PASS_LD)
4012
4013 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4014 PL_strip_module_ex() is similar to PL_strip_module(), but returns an
4015 error if it encounters a term <m>:<t>, where <m> is not an atom.
4016 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4017
4018 int
PL_strip_module_ex__LD(term_t raw,module_t * m,term_t plain ARG_LD)4019 PL_strip_module_ex__LD(term_t raw, module_t *m, term_t plain ARG_LD)
4020 { Word p = valTermRef(raw);
4021
4022 deRef(p);
4023 if ( hasFunctor(*p, FUNCTOR_colon2) )
4024 { if ( !(p = stripModule(p, m, 0 PASS_LD)) )
4025 return FALSE;
4026 if ( hasFunctor(*p, FUNCTOR_colon2) )
4027 { Word a1 = argTermP(*p, 0);
4028 deRef(a1);
4029 setHandle(plain, needsRef(*a1) ? makeRef(a1) : *a1);
4030 return PL_type_error("module", plain);
4031 }
4032 setHandle(plain, linkVal(p));
4033 } else
4034 { if ( *m == NULL )
4035 *m = environment_frame ? contextModule(environment_frame)
4036 : MODULE_user;
4037 setHandle(plain, needsRef(*p) ? makeRef(p) : *p);
4038 }
4039
4040 return TRUE;
4041 }
4042
4043 module_t
PL_context(void)4044 PL_context(void)
4045 { GET_LD
4046 return environment_frame ? contextModule(environment_frame)
4047 : MODULE_user;
4048 }
4049
4050 atom_t
PL_module_name(Module m)4051 PL_module_name(Module m)
4052 { return (atom_t) m->name;
4053 }
4054
4055 module_t
PL_new_module(atom_t name)4056 PL_new_module(atom_t name)
4057 { GET_LD
4058 return lookupModule(name);
4059 }
4060
4061 int
PL_qualify(term_t raw,term_t qualified)4062 PL_qualify(term_t raw, term_t qualified)
4063 { GET_LD
4064 Module m = NULL;
4065 term_t mname;
4066
4067 if ( !(mname = PL_new_term_ref()) ||
4068 !PL_strip_module(raw, &m, qualified) )
4069 return FALSE;
4070
4071 setHandle(mname, m->name);
4072
4073 return PL_cons_functor(qualified, FUNCTOR_colon2, mname, qualified);
4074 }
4075
4076
4077 /*******************************
4078 * PREDICATES *
4079 *******************************/
4080
4081 predicate_t
PL_pred(functor_t functor,module_t module)4082 PL_pred(functor_t functor, module_t module)
4083 { if ( module == NULL )
4084 module = PL_context();
4085
4086 return lookupProcedure(functor, module);
4087 }
4088
4089
4090 predicate_t
PL_predicate(const char * name,int arity,const char * module)4091 PL_predicate(const char *name, int arity, const char *module)
4092 { Module m;
4093 atom_t a = lookupAtom(name, strlen(name));
4094 functor_t f = lookupFunctorDef(a, arity);
4095
4096 PL_unregister_atom(a);
4097
4098 if ( module )
4099 { GET_LD
4100 a = lookupAtom(module, strlen(module));
4101 m = lookupModule(a);
4102 PL_unregister_atom(a);
4103 } else
4104 m = PL_context();
4105
4106 return PL_pred(f, m);
4107 }
4108
4109
4110 predicate_t
_PL_predicate(const char * name,int arity,const char * module,predicate_t * bin)4111 _PL_predicate(const char *name, int arity, const char *module,
4112 predicate_t *bin)
4113 { if ( !*bin )
4114 *bin = PL_predicate(name, arity, module);
4115
4116 return *bin;
4117 }
4118
4119
4120 int
PL_predicate_info(predicate_t pred,atom_t * name,size_t * arity,module_t * m)4121 PL_predicate_info(predicate_t pred, atom_t *name, size_t *arity, module_t *m)
4122 { Definition def = pred->definition;
4123
4124 if ( name )
4125 *name = def->functor->name;
4126 if ( arity )
4127 *arity = def->functor->arity;
4128 if ( m )
4129 *m = def->module;
4130
4131 return TRUE;
4132 }
4133
4134
4135 /*******************************
4136 * CALLING *
4137 *******************************/
4138
4139 int
PL_call_predicate(Module ctx,int flags,predicate_t pred,term_t h0)4140 PL_call_predicate(Module ctx, int flags, predicate_t pred, term_t h0)
4141 { int rval;
4142 qid_t qid;
4143
4144 if ( (qid = PL_open_query(ctx, flags, pred, h0)) )
4145 { int r1 = PL_next_solution(qid);
4146 int r2 = PL_cut_query(qid);
4147
4148 rval = (r1 && r2); /* do not inline; we *must* execute PL_cut_query() */
4149 } else
4150 rval = FALSE;
4151
4152 return rval;
4153 }
4154
4155
4156 int
PL_call(term_t t,Module m)4157 PL_call(term_t t, Module m)
4158 { return callProlog(m, t, PL_Q_NORMAL, NULL);
4159 }
4160
4161
4162 /********************************
4163 * FOREIGNS RETURN *
4164 ********************************/
4165
4166 foreign_t
_PL_retry(intptr_t v)4167 _PL_retry(intptr_t v)
4168 { ForeignRedoInt(v);
4169 }
4170
4171
4172 foreign_t
_PL_retry_address(void * v)4173 _PL_retry_address(void *v)
4174 { if ( (uintptr_t)v & FRG_REDO_MASK )
4175 PL_fatal_error("PL_retry_address(%p): bad alignment", v);
4176
4177 ForeignRedoPtr(v);
4178 }
4179
4180
4181 intptr_t
PL_foreign_context(control_t h)4182 PL_foreign_context(control_t h)
4183 { return ForeignContextInt(h);
4184 }
4185
4186 void *
PL_foreign_context_address(control_t h)4187 PL_foreign_context_address(control_t h)
4188 { return ForeignContextPtr(h);
4189 }
4190
4191
4192 int
PL_foreign_control(control_t h)4193 PL_foreign_control(control_t h)
4194 { return ForeignControl(h);
4195 }
4196
4197 predicate_t /* = Procedure */
PL_foreign_context_predicate(control_t h)4198 PL_foreign_context_predicate(control_t h)
4199 { GET_LD
4200 Definition def = h->predicate;
4201
4202 return isCurrentProcedure(def->functor->functor, def->module);
4203 }
4204
4205 static int
has_emergency_space(void * sv,size_t needed)4206 has_emergency_space(void *sv, size_t needed)
4207 { Stack s = (Stack) sv;
4208 ssize_t lacking = ((char*)s->top + needed) - (char*)s->max;
4209
4210 if ( lacking <= 0 )
4211 return TRUE;
4212 if ( lacking < s->spare )
4213 { s->max = (char*)s->max + lacking;
4214 s->spare -= lacking;
4215 return TRUE;
4216 }
4217
4218 return FALSE;
4219 }
4220
4221
4222 static int
copy_exception(term_t ex,term_t bin ARG_LD)4223 copy_exception(term_t ex, term_t bin ARG_LD)
4224 { fid_t fid;
4225
4226 if ( (fid=PL_open_foreign_frame()) )
4227 { if ( duplicate_term(ex, bin PASS_LD) )
4228 { ok:
4229 PL_close_foreign_frame(fid);
4230 return TRUE;
4231 } else
4232 { PL_rewind_foreign_frame(fid);
4233 PL_clear_exception();
4234 LD->exception.processing = TRUE;
4235
4236 if ( PL_is_functor(ex, FUNCTOR_error2) )
4237 { term_t arg, av;
4238
4239 if ( (arg = PL_new_term_ref()) &&
4240 (av = PL_new_term_refs(2)) &&
4241 PL_get_arg(1, ex, arg) &&
4242 duplicate_term(arg, av+0 PASS_LD) &&
4243 PL_cons_functor_v(bin, FUNCTOR_error2, av) )
4244 { Sdprintf("WARNING: Removed error context due to stack overflow\n");
4245 goto ok;
4246 }
4247 } else if ( has_emergency_space(&LD->stacks.global, 5*sizeof(word)) )
4248 { Word p = gTop;
4249
4250 Sdprintf("WARNING: cannot raise exception; raising global overflow\n");
4251 p[0] = FUNCTOR_error2; /* see (*) above */
4252 p[1] = consPtr(&p[3], TAG_COMPOUND|STG_GLOBAL);
4253 p[2] = ATOM_global;
4254 p[3] = FUNCTOR_resource_error1;
4255 p[4] = ATOM_stack;
4256 gTop += 5;
4257
4258 *valTermRef(bin) = consPtr(p, TAG_COMPOUND|STG_GLOBAL);
4259 goto ok;
4260 }
4261 }
4262 PL_close_foreign_frame(fid);
4263 }
4264
4265 Sdprintf("WARNING: mapped exception to abort due to stack overflow\n");
4266 PL_put_atom(bin, ATOM_aborted);
4267 return TRUE;
4268 }
4269
4270
4271 except_class
classify_exception_p__LD(Word p ARG_LD)4272 classify_exception_p__LD(Word p ARG_LD)
4273 { deRef(p);
4274 if ( isVar(*p) )
4275 { return EXCEPT_NONE;
4276 } else if ( isAtom(*p) )
4277 { if ( *p == ATOM_aborted )
4278 return EXCEPT_ABORT;
4279 if ( *p == ATOM_time_limit_exceeded )
4280 return EXCEPT_TIMEOUT;
4281 } else if ( hasFunctor(*p, FUNCTOR_error2) )
4282 { p = argTermP(*p, 0);
4283 deRef(p);
4284
4285 if ( isAtom(*p) )
4286 { if ( *p == ATOM_resource_error )
4287 return EXCEPT_RESOURCE;
4288 }
4289
4290 return EXCEPT_ERROR;
4291 }
4292
4293 return EXCEPT_OTHER;
4294 }
4295
4296
4297 except_class
classify_exception__LD(term_t exception ARG_LD)4298 classify_exception__LD(term_t exception ARG_LD)
4299 { Word p;
4300
4301 if ( !exception )
4302 return EXCEPT_NONE;
4303
4304 p = valTermRef(exception);
4305 return classify_exception_p(p);
4306 }
4307
4308
4309 int
PL_raise_exception(term_t exception)4310 PL_raise_exception(term_t exception)
4311 { GET_LD
4312
4313 assert(valTermRef(exception) < (Word)lTop);
4314
4315 if ( PL_is_variable(exception) ) /* internal error */
4316 fatalError("Cannot throw variable exception");
4317
4318 #if O_DEBUG
4319 save_backtrace("exception");
4320 #endif
4321
4322 LD->exception.processing = TRUE;
4323 if ( !PL_same_term(exception, exception_bin) ) /* re-throwing */
4324 { except_class co = classify_exception(exception_bin);
4325 except_class cn = classify_exception(exception);
4326
4327 if ( cn >= co )
4328 { if ( cn == EXCEPT_RESOURCE )
4329 enableSpareStacks();
4330 setVar(*valTermRef(exception_bin));
4331 copy_exception(exception, exception_bin PASS_LD);
4332 if ( !PL_is_atom(exception_bin) )
4333 freezeGlobal(PASS_LD1);
4334 }
4335 }
4336 exception_term = exception_bin;
4337
4338 return FALSE;
4339 }
4340
4341
4342 int
PL_throw(term_t exception)4343 PL_throw(term_t exception)
4344 { GET_LD
4345
4346 PL_raise_exception(exception);
4347 if ( LD->exception.throw_environment )
4348 longjmp(LD->exception.throw_environment->exception_jmp_env, 1);
4349
4350 fail;
4351 }
4352
4353
4354 int
PL_rethrow(void)4355 PL_rethrow(void)
4356 { GET_LD
4357
4358 if ( LD->exception.throw_environment )
4359 longjmp(LD->exception.throw_environment->exception_jmp_env, 1);
4360
4361 fail;
4362 }
4363
4364
4365 void
PL_clear_exception(void)4366 PL_clear_exception(void)
4367 { GET_LD
4368
4369 if ( exception_term )
4370 { resumeAfterException(TRUE, LD->outofstack);
4371 LD->outofstack = NULL;
4372 }
4373 }
4374
4375
4376 void
PL_clear_foreign_exception(LocalFrame fr)4377 PL_clear_foreign_exception(LocalFrame fr)
4378 { GET_LD
4379 term_t ex = PL_exception(0);
4380 fid_t fid;
4381
4382 #ifdef O_PLMT
4383 { int tid = PL_thread_self();
4384 atom_t alias;
4385 const pl_wchar_t *name = L"";
4386
4387 if ( PL_get_thread_alias(tid, &alias) )
4388 name = PL_atom_wchars(alias, NULL);
4389
4390 Sdprintf("Thread %d (%Ws): foreign predicate %s did not clear exception: \n\t",
4391 tid, name, predicateName(fr->predicate));
4392 #if O_DEBUG
4393 print_backtrace_named("exception");
4394 #endif
4395 }
4396 #else
4397 Sdprintf("Foreign predicate %s did not clear exception: ",
4398 predicateName(fr->predicate));
4399 #endif
4400
4401 if ( (fid=PL_open_foreign_frame()) )
4402 { PL_write_term(Serror, ex, 1200, PL_WRT_NEWLINE);
4403 PL_close_foreign_frame(fid);
4404 }
4405
4406 PL_clear_exception();
4407 }
4408
4409
4410
4411 /********************************
4412 * REGISTERING FOREIGNS *
4413 *********************************/
4414
4415 #define extensions_loaded (GD->foreign._loaded)
4416
4417 static void
notify_registered_foreign(functor_t fd,Module m)4418 notify_registered_foreign(functor_t fd, Module m)
4419 { if ( GD->initialised )
4420 { GET_LD
4421 fid_t cid;
4422
4423 if ( (cid = PL_open_foreign_frame()) )
4424 { term_t argv = PL_new_term_refs(2);
4425 predicate_t pred = _PL_predicate("$foreign_registered", 2, "system",
4426 &GD->procedures.foreign_registered2);
4427
4428 PL_put_atom(argv+0, m->name);
4429 if ( !(PL_put_functor(argv+1, fd) &&
4430 PL_call_predicate(MODULE_system, PL_Q_NODEBUG, pred, argv)) )
4431 ; /*Sdprintf("Failed to notify new foreign predicate\n");*/
4432 /*note that the hook may not be defined*/
4433 PL_discard_foreign_frame(cid);
4434 }
4435 }
4436 }
4437
4438
4439 static predicate_t
bindForeign(Module m,const char * name,int arity,Func f,int flags)4440 bindForeign(Module m, const char *name, int arity, Func f, int flags)
4441 { GET_LD
4442 Procedure proc;
4443 Definition def;
4444 functor_t fdef;
4445 atom_t aname;
4446
4447 aname = PL_new_atom(name);
4448
4449 fdef = lookupFunctorDef(aname, arity);
4450 if ( !(proc = lookupProcedureToDefine(fdef, m)) )
4451 { warning("PL_register_foreign(): attempt to redefine "
4452 "a system predicate: %s:%s",
4453 PL_atom_chars(m->name), functorName(fdef));
4454 return NULL;
4455 }
4456 def = proc->definition;
4457 if ( def->module != m || def->impl.any.defined )
4458 { DEBUG(MSG_PROC, Sdprintf("Abolish %s from %s\n",
4459 procedureName(proc), PL_atom_chars(m->name)));
4460 abolishProcedure(proc, m);
4461 def = proc->definition;
4462 }
4463
4464 if ( def->impl.any.defined )
4465 PL_linger(def->impl.any.defined); /* Dubious: what if a clause list? */
4466 def->impl.foreign.function = f;
4467 def->flags &= ~(P_DYNAMIC|P_THREAD_LOCAL|P_TRANSPARENT|P_NONDET|P_VARARG);
4468 def->flags |= (P_FOREIGN|TRACE_ME);
4469
4470 if ( m == MODULE_system || SYSTEM_MODE )
4471 set(def, P_LOCKED|HIDE_CHILDS);
4472
4473 if ( (flags & PL_FA_NOTRACE) ) clear(def, TRACE_ME);
4474 if ( (flags & PL_FA_TRANSPARENT) ) set(def, P_TRANSPARENT);
4475 if ( (flags & PL_FA_NONDETERMINISTIC) ) set(def, P_NONDET);
4476 if ( (flags & PL_FA_VARARGS) ) set(def, P_VARARG);
4477
4478 createForeignSupervisor(def, f);
4479 notify_registered_foreign(fdef, m);
4480
4481 return proc;
4482 }
4483
4484
4485 static Module
resolveModule(const char * module)4486 resolveModule(const char *module)
4487 { if ( !GD->initialised ) /* Before PL_initialise()! */
4488 initModules();
4489
4490 if (module)
4491 return PL_new_module(PL_new_atom(module));
4492 else
4493 { GET_LD
4494 return (HAS_LD && environment_frame ? contextModule(environment_frame)
4495 : MODULE_user);
4496 }
4497 }
4498
4499 void
bindExtensions(const char * module,const PL_extension * ext)4500 bindExtensions(const char *module, const PL_extension *ext)
4501 { Module m = resolveModule(module);
4502
4503 for(; ext->predicate_name; ext++)
4504 { bindForeign(m, ext->predicate_name, ext->arity,
4505 ext->function, ext->flags);
4506 }
4507 }
4508
4509 void
PL_register_extensions_in_module(const char * module,const PL_extension * e)4510 PL_register_extensions_in_module(const char *module, const PL_extension *e)
4511 { if ( extensions_loaded )
4512 bindExtensions(module, e);
4513 else
4514 rememberExtensions(module, e);
4515 }
4516
4517
4518 void
PL_register_extensions(const PL_extension * e)4519 PL_register_extensions(const PL_extension *e)
4520 { PL_register_extensions_in_module(NULL, e);
4521 }
4522
4523
4524 static int
register_foreignv(const char * module,const char * name,int arity,Func f,int flags,va_list args)4525 register_foreignv(const char *module,
4526 const char *name, int arity, Func f, int flags,
4527 va_list args)
4528 { if ( extensions_loaded )
4529 { Module m = resolveModule(module);
4530 predicate_t p = bindForeign(m, name, arity, f, flags);
4531
4532 if ( p && (flags&PL_FA_META) )
4533 PL_meta_predicate(p, va_arg(args, char*));
4534
4535 return (p != NULL);
4536 } else
4537 { PL_extension ext[2];
4538 ext->predicate_name = (char *)name;
4539 ext->arity = (short)arity;
4540 ext->function = f;
4541 ext->flags = (short)flags;
4542 ext[1].predicate_name = NULL;
4543 rememberExtensions(module, ext);
4544
4545 return TRUE;
4546 }
4547 }
4548
4549
4550 int
PL_register_foreign_in_module(const char * module,const char * name,int arity,Func f,int flags,...)4551 PL_register_foreign_in_module(const char *module,
4552 const char *name, int arity, Func f, int flags, ...)
4553 { va_list args;
4554 int rc;
4555
4556 va_start(args, flags);
4557 rc = register_foreignv(module, name, arity, f, flags, args);
4558 va_end(args);
4559
4560 return rc;
4561 }
4562
4563
4564 int
PL_register_foreign(const char * name,int arity,Func f,int flags,...)4565 PL_register_foreign(const char *name, int arity, Func f, int flags, ...)
4566 { va_list args;
4567 int rc;
4568
4569 va_start(args, flags);
4570 rc = register_foreignv(NULL, name, arity, f, flags, args);
4571 va_end(args);
4572
4573 return rc;
4574 }
4575
4576 /* deprecated */
4577 void
PL_load_extensions(const PL_extension * ext)4578 PL_load_extensions(const PL_extension *ext)
4579 { PL_register_extensions_in_module(NULL, ext);
4580 }
4581
4582
4583 /*******************************
4584 * EMBEDDING PROLOG *
4585 *******************************/
4586
4587 int
PL_toplevel(void)4588 PL_toplevel(void)
4589 { atom_t a = PL_new_atom("$toplevel");
4590 int rval = prologToplevel(a);
4591
4592 PL_unregister_atom(a);
4593
4594 return rval;
4595 }
4596
4597
4598 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4599 The system may be compiled using AddressSanitizer
4600 (https://github.com/google/sanitizers/wiki/AddressSanitizer) which is
4601 supported by GCC and Clang. Do do so, use
4602
4603 cmake -DCMAKE_BUILD_TYPE=Sanitize
4604
4605 See cmake/BuildType.cmake for details.
4606
4607 Currently SWI-Prolog does not reclaim all memory on edit, even not if
4608 cleanupProlog() is called with reclaim_memory set to TRUE. The docs says
4609 we can use __lsan_disable() just before exit to avoid the leak check,
4610 but this doesn't seem to work (Ubuntu 18.04). What does work is defining
4611 __asan_default_options(), providing an alternative to the environment
4612 variable LSAN_OPTIONS=.
4613 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4614
4615 static int
haltProlog(int status)4616 haltProlog(int status)
4617 { int reclaim_memory = FALSE;
4618
4619 #if defined(GC_DEBUG) || defined(O_DEBUG) || defined(__SANITIZE_ADDRESS__)
4620 reclaim_memory = TRUE;
4621 #endif
4622
4623 if ( cleanupProlog(status, reclaim_memory) )
4624 { run_on_halt(&GD->os.exit_hooks, status);
4625
4626 #if 0 && defined(__SANITIZE_ADDRESS__)
4627 // Disabled as this doesn't work
4628 Sdprintf("About to exit\n");
4629 __lsan_do_leak_check();
4630 Sdprintf("Done checking\n");
4631 __lsan_disable();
4632 #endif
4633
4634 return TRUE;
4635 }
4636
4637 return FALSE;
4638 }
4639
4640 int
PL_halt(int status)4641 PL_halt(int status)
4642 { if ( haltProlog(status) )
4643 exit(status);
4644
4645 return FALSE;
4646 }
4647
4648 #ifndef SIGABRT
4649 #define SIGABRT 6 /* exit 134 --> aborted */
4650 #endif
4651
4652 void
PL_abort_process(void)4653 PL_abort_process(void)
4654 { haltProlog(128+SIGABRT);
4655 abort();
4656 }
4657
4658 /*******************************
4659 * RESOURCES *
4660 *******************************/
4661
4662
4663 IOSTREAM *
PL_open_resource(Module m,const char * name,const char * rc_class,const char * mode)4664 PL_open_resource(Module m,
4665 const char *name, const char *rc_class,
4666 const char *mode)
4667 { GET_LD
4668 IOSTREAM *s = NULL;
4669 fid_t fid;
4670 static predicate_t MTOK_pred;
4671 term_t t0;
4672
4673 (void)rc_class;
4674
4675 if ( !m )
4676 m = MODULE_user;
4677 if ( !MTOK_pred )
4678 MTOK_pred = PL_predicate("c_open_resource", 3, "$rc");
4679
4680 if ( !(fid = PL_open_foreign_frame()) )
4681 { errno = ENOENT;
4682 return s;
4683 }
4684 t0 = PL_new_term_refs(3);
4685 PL_put_atom_chars(t0+0, name);
4686 PL_put_atom_chars(t0+1, mode);
4687
4688 if ( !PL_call_predicate(m, PL_Q_CATCH_EXCEPTION, MTOK_pred, t0) ||
4689 !PL_get_stream_handle(t0+2, &s) )
4690 errno = ENOENT;
4691
4692 PL_discard_foreign_frame(fid);
4693 return s;
4694 }
4695
4696
4697 /********************************
4698 * SIGNALS *
4699 *********************************/
4700
4701 int
PL_raise(int sig)4702 PL_raise(int sig)
4703 { GET_LD
4704
4705 return raiseSignal(LD, sig);
4706 }
4707
4708
4709 int
PL_pending__LD(int sig ARG_LD)4710 PL_pending__LD(int sig ARG_LD)
4711 { if ( sig > 0 && sig <= MAXSIGNAL && HAS_LD )
4712 { int off = (sig-1)/32;
4713 int mask = 1 << ((sig-1)%32);
4714
4715 return (LD->signal.pending[off] & mask) ? TRUE : FALSE;
4716 }
4717
4718 return -1;
4719 }
4720
4721
4722 int
PL_clearsig__LD(int sig ARG_LD)4723 PL_clearsig__LD(int sig ARG_LD)
4724 { if ( sig > 0 && sig <= MAXSIGNAL && HAS_LD )
4725 { int off = (sig-1)/32;
4726 int mask = 1 << ((sig-1)%32);
4727
4728 ATOMIC_AND(&LD->signal.pending[off], ~mask);
4729 updateAlerted(LD);
4730 return TRUE;
4731 }
4732
4733 return FALSE;
4734 }
4735
4736 /********************************
4737 * RESET (ABORTS) *
4738 ********************************/
4739
4740 struct abort_handle
4741 { AbortHandle next; /* Next handle */
4742 PL_abort_hook_t function; /* The handle itself */
4743 };
4744
4745 #define abort_head (LD->fli._abort_head)
4746 #define abort_tail (LD->fli._abort_tail)
4747
4748 void
PL_abort_hook(PL_abort_hook_t func)4749 PL_abort_hook(PL_abort_hook_t func)
4750 { GET_LD
4751 AbortHandle h = (AbortHandle) allocHeapOrHalt(sizeof(struct abort_handle));
4752 h->next = NULL;
4753 h->function = func;
4754
4755 if ( abort_head == NULL )
4756 { abort_head = abort_tail = h;
4757 } else
4758 { abort_tail->next = h;
4759 abort_tail = h;
4760 }
4761 }
4762
4763
4764 int
PL_abort_unhook(PL_abort_hook_t func)4765 PL_abort_unhook(PL_abort_hook_t func)
4766 { GET_LD
4767 AbortHandle h = abort_head;
4768
4769 for(; h; h = h->next)
4770 { if ( h->function == func )
4771 { h->function = NULL;
4772 return TRUE;
4773 }
4774 }
4775
4776 return FALSE;
4777 }
4778
4779
4780 void
resetForeign(void)4781 resetForeign(void)
4782 { GET_LD
4783 AbortHandle h = abort_head;
4784
4785 for(; h; h = h->next)
4786 if ( h->function )
4787 (*h->function)();
4788 }
4789
4790
4791 /********************************
4792 * FOREIGN INITIALISE *
4793 ********************************/
4794
4795 struct initialise_handle
4796 { InitialiseHandle next; /* Next handle */
4797 PL_initialise_hook_t function; /* The handle itself */
4798 };
4799
4800 #define initialise_head (GD->foreign.initialise_head)
4801 #define initialise_tail (GD->foreign.initialise_tail)
4802
4803 void
PL_initialise_hook(PL_initialise_hook_t func)4804 PL_initialise_hook(PL_initialise_hook_t func)
4805 { InitialiseHandle h = initialise_head;
4806
4807 for(; h; h = h->next)
4808 { if ( h->function == func )
4809 return; /* already there */
4810 }
4811
4812 h = malloc(sizeof(struct initialise_handle));
4813 if ( !h )
4814 outOfCore();
4815
4816 h->next = NULL;
4817 h->function = func;
4818
4819 if ( initialise_head == NULL )
4820 { initialise_head = initialise_tail = h;
4821 } else
4822 { initialise_tail->next = h;
4823 initialise_tail = h;
4824 }
4825 }
4826
4827
4828 void
initialiseForeign(int argc,char ** argv)4829 initialiseForeign(int argc, char **argv)
4830 { InitialiseHandle h = initialise_head;
4831
4832 for(; h; h = h->next)
4833 (*h->function)(argc, argv);
4834 }
4835
4836
4837 void
cleanupInitialiseHooks(void)4838 cleanupInitialiseHooks(void)
4839 { InitialiseHandle h, next;
4840
4841 for(h=initialise_head; h; h=next)
4842 { next = h->next;
4843 free(h);
4844 }
4845
4846 initialise_head = initialise_tail = NULL;
4847 }
4848
4849
4850
4851 /*******************************
4852 * PROMPT *
4853 *******************************/
4854
4855 void
PL_prompt1(const char * s)4856 PL_prompt1(const char *s)
4857 { prompt1(lookupAtom(s, strlen(s)));
4858 }
4859
4860
4861 int
PL_ttymode(IOSTREAM * s)4862 PL_ttymode(IOSTREAM *s)
4863 { GET_LD
4864
4865 if ( s == Suser_input )
4866 { if ( !truePrologFlag(PLFLAG_TTY_CONTROL) ) /* -tty in effect */
4867 return PL_NOTTY;
4868 if ( Sttymode(s) == TTY_RAW ) /* get_single_char/1 and friends */
4869 return PL_RAWTTY;
4870 return PL_COOKEDTTY; /* cooked (readline) input */
4871 } else
4872 return PL_NOTTY;
4873 }
4874
4875
4876 void
PL_prompt_next(int fd)4877 PL_prompt_next(int fd)
4878 { GET_LD
4879
4880 if ( fd == 0 )
4881 LD->prompt.next = TRUE;
4882 }
4883
4884
4885 char *
PL_prompt_string(int fd)4886 PL_prompt_string(int fd)
4887 { GET_LD
4888 IOSTREAM *s;
4889
4890 if ( (s=Suser_input) && fd == Sfileno(s) )
4891 { atom_t a = PrologPrompt(); /* TBD: deal with UTF-8 */
4892
4893 if ( a )
4894 { PL_chars_t txt;
4895
4896 if ( get_atom_text(a, &txt) )
4897 { if ( txt.encoding == ENC_ISO_LATIN_1 )
4898 return txt.text.t;
4899 }
4900 }
4901 }
4902
4903 return NULL;
4904 }
4905
4906
4907 void
PL_add_to_protocol(const char * buf,size_t n)4908 PL_add_to_protocol(const char *buf, size_t n)
4909 { protocol(buf, n);
4910 }
4911
4912
4913 /*******************************
4914 * DISPATCHING *
4915 *******************************/
4916
4917 PL_dispatch_hook_t
PL_dispatch_hook(PL_dispatch_hook_t hook)4918 PL_dispatch_hook(PL_dispatch_hook_t hook)
4919 { PL_dispatch_hook_t old = GD->foreign.dispatch_events;
4920
4921 GD->foreign.dispatch_events = hook;
4922 return old;
4923 }
4924
4925
4926 #if defined(HAVE_SELECT) && !defined(__WINDOWS__)
4927 #if defined(HAVE_POLL_H) && defined(HAVE_POLL)
4928 #include <poll.h>
4929 #elif defined(HAVE_SYS_SELECT_H)
4930 #include <sys/select.h>
4931 #endif
4932
4933 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4934 Note that this is used to integrate X11 event-dispatching into the
4935 SWI-Prolog toplevel. Integration of event-handling in Windows is
4936 achieved through the plterm DLL (see win32/console). For this reason we
4937 do never want this code in Windows.
4938 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4939
4940 static int
input_on_fd(int fd)4941 input_on_fd(int fd)
4942 {
4943 #ifdef HAVE_POLL
4944 struct pollfd fds[1];
4945
4946 fds[0].fd = fd;
4947 fds[0].events = POLLIN;
4948
4949 return poll(fds, 1, 0) != 0;
4950 #else
4951 fd_set rfds;
4952 struct timeval tv;
4953
4954 #if defined(FD_SETSIZE) && !defined(__WINDOWS__)
4955 if ( fd >= FD_SETSIZE )
4956 { Sdprintf("input_on_fd(%d) > FD_SETSIZE\n", fd);
4957 return 1;
4958 }
4959 #endif
4960
4961 FD_ZERO(&rfds);
4962 FD_SET(fd, &rfds);
4963 tv.tv_sec = 0;
4964 tv.tv_usec = 0;
4965
4966 return select(fd+1, &rfds, NULL, NULL, &tv) != 0;
4967 #endif
4968 }
4969
4970 #else
4971 #define input_on_fd(fd) 1
4972 #endif
4973
4974
4975 int
PL_dispatch(int fd,int wait)4976 PL_dispatch(int fd, int wait)
4977 { if ( wait == PL_DISPATCH_INSTALLED )
4978 return GD->foreign.dispatch_events ? TRUE : FALSE;
4979
4980 if ( GD->foreign.dispatch_events && PL_thread_self() == 1 )
4981 { if ( wait == PL_DISPATCH_WAIT )
4982 { while( !input_on_fd(fd) )
4983 { if ( PL_handle_signals() < 0 )
4984 return FALSE;
4985 (*GD->foreign.dispatch_events)(fd);
4986 }
4987 } else
4988 { (*GD->foreign.dispatch_events)(fd);
4989 if ( PL_handle_signals() < 0 )
4990 return FALSE;
4991 }
4992 }
4993
4994 return TRUE;
4995 }
4996
4997
4998 /*******************************
4999 * RECORDED DATABASE *
5000 *******************************/
5001
5002 record_t
PL_record(term_t t)5003 PL_record(term_t t)
5004 { GET_LD
5005
5006 return compileTermToHeap(t, R_DUPLICATE);
5007 }
5008
5009
5010 int
PL_recorded(record_t r,term_t t)5011 PL_recorded(record_t r, term_t t)
5012 { GET_LD
5013
5014 return copyRecordToGlobal(t, r, ALLOW_GC PASS_LD) == TRUE;
5015 }
5016
5017
5018 void
PL_erase(record_t r)5019 PL_erase(record_t r)
5020 { freeRecord(r);
5021 }
5022
5023
5024 record_t
PL_duplicate_record(record_t r)5025 PL_duplicate_record(record_t r)
5026 { if ( true(r, R_DUPLICATE) )
5027 { r->references++;
5028 return r;
5029 } else
5030 return NULL;
5031 }
5032
5033
5034 /*******************************
5035 * PROLOG FLAGS *
5036 *******************************/
5037
5038 int
PL_set_prolog_flag(const char * name,int type,...)5039 PL_set_prolog_flag(const char *name, int type, ...)
5040 { GET_LD
5041 va_list args;
5042 int rval = TRUE;
5043 int flags = (type & FF_MASK);
5044 fid_t fid;
5045 term_t av;
5046
5047 va_start(args, type);
5048 if ( HAS_LD &&
5049 GD->io_initialised && /* setupProlog() finished */
5050 (fid = PL_open_foreign_frame()) &&
5051 (av = PL_new_term_refs(2)) )
5052 { PL_put_atom_chars(av+0, name);
5053 switch(type & ~FF_MASK)
5054 { case PL_BOOL:
5055 { int val = va_arg(args, int);
5056
5057 rval = ( PL_put_bool(av+1, val) &&
5058 set_prolog_flag(av+0, av+1, FT_BOOL|flags) );
5059 break;
5060 }
5061 case PL_ATOM:
5062 { const char *v = va_arg(args, const char *);
5063
5064 rval = ( PL_put_atom_chars(av+1, v) &&
5065 set_prolog_flag(av+0, av+1, FT_ATOM|flags) );
5066 break;
5067 }
5068 case PL_INTEGER:
5069 { intptr_t v = va_arg(args, intptr_t);
5070
5071 rval = ( PL_put_integer(av+1, v) &&
5072 set_prolog_flag(av+0, av+1, FT_INTEGER|flags) );
5073 break;
5074 }
5075 default:
5076 rval = FALSE;
5077 }
5078 PL_close_foreign_frame(fid);
5079 } else
5080 { initPrologThreads();
5081
5082 switch(type & ~FF_MASK)
5083 { case PL_BOOL:
5084 { int val = va_arg(args, int);
5085
5086 setPrologFlag(name, FT_BOOL|flags, val, 0);
5087 break;
5088 }
5089 case PL_ATOM:
5090 { const char *v = va_arg(args, const char *);
5091 if ( !GD->initialised )
5092 initAtoms();
5093 setPrologFlag(name, FT_ATOM|flags, v);
5094 break;
5095 }
5096 case PL_INTEGER:
5097 { intptr_t v = va_arg(args, intptr_t);
5098 setPrologFlag(name, FT_INTEGER|flags, v);
5099 break;
5100 }
5101 default:
5102 rval = FALSE;
5103 }
5104 }
5105 va_end(args);
5106
5107 return rval;
5108 }
5109
5110
5111 /********************************
5112 * WARNINGS *
5113 *********************************/
5114
5115 int
PL_warning(const char * fm,...)5116 PL_warning(const char *fm, ...)
5117 { va_list args;
5118
5119 va_start(args, fm);
5120 vwarning(fm, args);
5121 va_end(args);
5122
5123 fail;
5124 }
5125
5126 void
PL_fatal_error(const char * fm,...)5127 PL_fatal_error(const char *fm, ...)
5128 { va_list args;
5129
5130 va_start(args, fm);
5131 vfatalError(fm, args);
5132 va_end(args);
5133 }
5134
5135
5136 /********************************
5137 * ACTIONS *
5138 *********************************/
5139
5140 int
PL_action(int action,...)5141 PL_action(int action, ...)
5142 { int rval = TRUE;
5143 va_list args;
5144
5145 va_start(args, action);
5146
5147 switch(action)
5148 { case PL_ACTION_TRACE:
5149 rval = (int)pl_trace();
5150 break;
5151 case PL_ACTION_DEBUG:
5152 debugmode(DBG_ALL, NULL);
5153 break;
5154 case PL_ACTION_BACKTRACE:
5155 #ifdef O_DEBUGGER
5156 { GET_LD
5157 int a = va_arg(args, int);
5158
5159 if ( gc_status.active )
5160 { Sfprintf(Serror,
5161 "\n[Cannot print stack while in %ld-th garbage collection]\n",
5162 LD->gc.stats.totals.collections);
5163 rval = FALSE;
5164 break;
5165 }
5166 if ( GD->bootsession || !GD->initialised )
5167 { Sfprintf(Serror,
5168 "\n[Cannot print stack while initialising]\n");
5169 rval = FALSE;
5170 break;
5171 }
5172 PL_backtrace(a, 0);
5173 }
5174 #else
5175 warning("No Prolog backtrace in runtime version");
5176 rval = FALSE;
5177 #endif
5178 break;
5179 case PL_ACTION_BREAK:
5180 rval = (int)pl_break();
5181 break;
5182 case PL_ACTION_HALT:
5183 { int a = va_arg(args, int);
5184
5185 PL_halt(a);
5186 rval = FALSE;
5187 break;
5188 }
5189 case PL_ACTION_ABORT:
5190 rval = (int)abortProlog();
5191 break;
5192 case PL_ACTION_GUIAPP:
5193 { int guiapp = va_arg(args, int);
5194 GD->os.gui_app = guiapp;
5195 break;
5196 }
5197 case PL_ACTION_TRADITIONAL:
5198 setTraditional();
5199 break;
5200 case PL_ACTION_WRITE:
5201 { GET_LD
5202 char *s = va_arg(args, char *);
5203 rval = Sfputs(s, Scurout) < 0 ? FALSE : TRUE;
5204 break;
5205 }
5206 case PL_ACTION_FLUSH:
5207 { GET_LD
5208 rval = Sflush(Scurout);
5209 break;
5210 }
5211 case PL_ACTION_ATTACH_CONSOLE:
5212 {
5213 #ifdef O_PLMT
5214 rval = attachConsole();
5215 #else
5216 rval = FALSE;
5217 #endif
5218 break;
5219 }
5220 case PL_GMP_SET_ALLOC_FUNCTIONS:
5221 {
5222 #ifdef O_GMP
5223 int set = va_arg(args, int);
5224
5225 if ( !GD->gmp.initialised )
5226 { GD->gmp.keep_alloc_functions = !set;
5227 initGMP();
5228 } else
5229 { rval = FALSE;
5230 }
5231 #else
5232 rval = FALSE;
5233 #endif
5234 break;
5235 }
5236 default:
5237 sysError("PL_action(): Illegal action: %d", action);
5238 /*NOTREACHED*/
5239 rval = FALSE;
5240 }
5241
5242 va_end(args);
5243
5244 return rval;
5245 }
5246
5247 /********************************
5248 * QUERY PROLOG *
5249 *********************************/
5250
5251 intptr_t
PL_query(int query)5252 PL_query(int query)
5253 { switch(query)
5254 { case PL_QUERY_ARGC:
5255 return (intptr_t) GD->cmdline.appl_argc;
5256 case PL_QUERY_ARGV:
5257 return (intptr_t) GD->cmdline.appl_argv;
5258 case PL_QUERY_MAX_INTEGER:
5259 case PL_QUERY_MIN_INTEGER:
5260 fail; /* cannot represent (anymore) */
5261 case PL_QUERY_MAX_TAGGED_INT:
5262 return PLMAXTAGGEDINT;
5263 case PL_QUERY_MIN_TAGGED_INT:
5264 return PLMINTAGGEDINT;
5265 case PL_QUERY_GETC:
5266 PopTty(Sinput, &ttytab, FALSE); /* restore terminal mode */
5267 return (intptr_t) Sgetchar(); /* normal reading */
5268 case PL_QUERY_VERSION:
5269 return PLVERSION;
5270 case PL_QUERY_MAX_THREADS:
5271 #ifdef O_PLMT
5272 Sdprintf("PL_query(PL_QUERY_MAX_THREADS) is no longer supported\n");
5273 return 100000;
5274 #else
5275 return 1;
5276 #endif
5277 case PL_QUERY_ENCODING:
5278 { GET_LD
5279
5280 if ( HAS_LD )
5281 return LD->encoding;
5282 return PL_local_data.encoding; /* Default: of main thread? */
5283 }
5284 case PL_QUERY_USER_CPU: /* User CPU in milliseconds */
5285 { double cpu = CpuTime(CPU_USER);
5286 return (intptr_t)(cpu*1000.0);
5287 }
5288 case PL_QUERY_HALTING:
5289 { return (GD->cleaning == CLN_NORMAL ? FALSE : TRUE);
5290 }
5291 default:
5292 sysError("PL_query: Illegal query: %d", query);
5293 /*NOTREACHED*/
5294 fail;
5295 }
5296 }
5297
5298
5299 /*******************************
5300 * LICENSE *
5301 *******************************/
5302
5303 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5304 Register the current module using the license restrictions that apply for
5305 it.
5306 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5307
5308 static struct license
5309 { char *license_id;
5310 char *module_id;
5311 struct license *next;
5312 } *pre_registered;
5313
5314
5315 void
PL_license(const char * license,const char * module)5316 PL_license(const char *license, const char *module)
5317 { GET_LD
5318
5319 if ( GD->initialised )
5320 { fid_t fid = PL_open_foreign_frame();
5321 predicate_t pred = PL_predicate("license", 2, "system");
5322 term_t av = PL_new_term_refs(2);
5323
5324 PL_put_atom_chars(av+0, license);
5325 PL_put_atom_chars(av+1, module);
5326
5327 PL_call_predicate(NULL, PL_Q_NORMAL, pred, av);
5328
5329 PL_discard_foreign_frame(fid);
5330 } else
5331 { struct license *l = allocHeapOrHalt(sizeof(*l));
5332
5333 l->license_id = store_string(license);
5334 l->module_id = store_string(module);
5335 l->next = pre_registered;
5336 pre_registered = l;
5337 }
5338 }
5339
5340
5341 void
registerForeignLicenses(void)5342 registerForeignLicenses(void)
5343 { struct license *l, *next;
5344
5345 for(l=pre_registered; l; l=next)
5346 { next = l->next;
5347
5348 PL_license(l->license_id, l->module_id);
5349 remove_string(l->license_id);
5350 remove_string(l->module_id);
5351 freeHeap(l, sizeof(*l));
5352 }
5353
5354 pre_registered = NULL;
5355 }
5356
5357
5358 /*******************************
5359 * VERSION *
5360 *******************************/
5361
5362 unsigned int
PL_version(int which)5363 PL_version(int which)
5364 { switch(which)
5365 { case PL_VERSION_SYSTEM: return PLVERSION;
5366 case PL_VERSION_FLI: return PL_FLI_VERSION;
5367 case PL_VERSION_REC: return PL_REC_VERSION;
5368 case PL_VERSION_QLF: return PL_QLF_VERSION;
5369 case PL_VERSION_QLF_LOAD: return PL_QLF_LOADVERSION;
5370 case PL_VERSION_VM: return VM_SIGNATURE;
5371 case PL_VERSION_BUILT_IN: return GD->foreign.signature;
5372 default: return 0;
5373 }
5374 }
5375
5376
5377 /*******************************
5378 * INIT *
5379 *******************************/
5380
5381 void
initForeign(void)5382 initForeign(void)
5383 { initUCSAtoms();
5384 }
5385