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) 2011-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 #ifdef __WINDOWS__
39 #include <winsock2.h>
40 #include <windows.h>
41 #include <process.h> /* getpid() */
42 #endif
43 #include "pl-incl.h"
44 #include "pl-arith.h"
45 #include "pl-tabling.h"
46 #include "pl-ctype.h"
47 #include <ctype.h>
48 #ifdef HAVE_SYS_TIME_H
49 #include <sys/time.h>
50 #endif
51 #include <time.h>
52
53
54 /*******************************
55 * PROLOG FLAG HANDLING *
56 *******************************/
57
58 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
59 ISO Prolog flags are properties of the running Prolog system. Some of
60 these flags can be set by the user, such as whether read/1 honours
61 character-escapes, whether garbage-collection is enabled, etc. Some are
62 global and read-only, such as whether the operating system is unix.
63
64 In the multi-threading version, Prolog flags have to be changed
65 thread-local. Therefore two flag-tables have been defined: a global one
66 which is used as long as there is only one thread, and a local one that
67 is used to write changes to after multiple threads exist. On thread
68 creation this table is copied from the parent and on destruction the
69 local table is destroyed. Note that the flag-mask for fast access
70 (truePrologFlag(*PLFLAG_)) is always copied to the local thread-data.
71
72 Altogether this module is a bit too complex, but I see little
73 alternative. I considered creating copy-on-write hash-tables, but in
74 combination to the table-enumator objects this proves very hard to
75 implement safely. Using plain Prolog is not a good option too: they are
76 used before we can use any Prolog at startup, predicates are not
77 thread-local and some of the prolog flags require very fast access from
78 C (the booleans in the mask).
79
80 Just using a local table and copy it on thread-creation would be an
81 option, but 90% of the prolog flags are read-only or never changed and
82 we want to be able to have a lot of flags and don't harm thread_create/3
83 too much.
84 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
85
86 static void setArgvPrologFlag(const char *flag, int argc, char **argv);
87 static void setTmpDirPrologFlag(void);
88 static void setTZPrologFlag(void);
89 static void setVersionPrologFlag(void);
90 static void initPrologFlagTable(void);
91
92
93 typedef struct _prolog_flag
94 { short flags; /* Type | Flags */
95 short index; /* index in PLFLAG_ mask */
96 union
97 { atom_t a; /* value as atom */
98 int64_t i; /* value as integer */
99 double f; /* value as float */
100 record_t t; /* value as term */
101 } value;
102 } prolog_flag;
103
104
105 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
106 C-interface for defining Prolog flags. Depending on the type, the
107 following arguments are to be provided:
108
109 FT_BOOL TRUE/FALSE, *PLFLAG_
110 FT_INTEGER intptr_t
111 FT_INT64 int64_t
112 FT_FLOAT double
113 FT_ATOM const char *
114 FT_TERM a term
115 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
116
117 static int
indexOfBoolMask(unsigned int mask)118 indexOfBoolMask(unsigned int mask)
119 { int i=1;
120
121 if ( !mask )
122 return -1;
123
124 while(!(mask & 0x1))
125 { i++;
126 mask >>= 1;
127 }
128 return i;
129 }
130
131
132 void
setPrologFlag(const char * name,int flags,...)133 setPrologFlag(const char *name, int flags, ...)
134 { GET_LD
135 atom_t an = PL_new_atom(name);
136 prolog_flag *f;
137 va_list args;
138 int type = (flags & FT_MASK);
139 int first_def = FALSE;
140
141 initPrologFlagTable();
142
143 if ( type == FT_INT64 )
144 flags = (flags & ~FT_MASK)|FT_INTEGER;
145
146 if ( (f = lookupHTable(GD->prolog_flag.table, (void *)an)) )
147 { assert((f->flags & FT_MASK) == (flags & FT_MASK));
148 if ( flags & FF_KEEP )
149 return;
150 } else
151 { f = allocHeapOrHalt(sizeof(*f));
152 f->index = -1;
153 f->flags = flags;
154 addNewHTable(GD->prolog_flag.table, (void *)an, f);
155 first_def = TRUE;
156 }
157
158 va_start(args, flags);
159 switch(type)
160 { case FT_BOOL:
161 { int val = va_arg(args, int);
162 unsigned int mask = va_arg(args, unsigned int);
163
164 if ( !first_def && mask && f->index < 0 ) /* type definition */
165 { f->index = indexOfBoolMask(mask);
166 val = (f->value.a == ATOM_true);
167 } else if ( first_def ) /* 1st definition */
168 { f->index = indexOfBoolMask(mask);
169 DEBUG(MSG_PROLOG_FLAG,
170 Sdprintf("Prolog flag %s at 0x%08lx\n", name, mask));
171 }
172
173 f->value.a = (val ? ATOM_true : ATOM_false);
174 if ( f->index >= 0 )
175 { mask = (unsigned int)1 << (f->index-1);
176
177 if ( val )
178 setPrologFlagMask(mask);
179 else
180 clearPrologFlagMask(mask);
181 }
182 break;
183 }
184 case FT_INTEGER:
185 { intptr_t val = va_arg(args, intptr_t);
186 f->value.i = val;
187 break;
188 }
189 case FT_FLOAT:
190 { double val = va_arg(args, double);
191 f->value.f = val;
192 break;
193 }
194 case FT_INT64:
195 { int64_t val = va_arg(args, int64_t);
196 f->value.i = val;
197 break;
198 }
199 case FT_ATOM:
200 { PL_chars_t text;
201
202 text.text.t = va_arg(args, char *);
203 text.encoding = ENC_UTF8;
204 text.storage = PL_CHARS_HEAP;
205 text.length = strlen(text.text.t);
206 text.canonical = FALSE;
207
208 f->value.a = textToAtom(&text); /* registered: ok */
209 PL_free_text(&text);
210
211 break;
212 }
213 case FT_TERM:
214 { term_t t = va_arg(args, term_t);
215
216 f->value.t = PL_record(t);
217 break;
218 }
219 default:
220 assert(0);
221 }
222 va_end(args);
223 }
224
225
226 static void
freePrologFlag(prolog_flag * f)227 freePrologFlag(prolog_flag *f)
228 { switch((f->flags & FT_MASK))
229 { case FT_TERM:
230 PL_erase(f->value.t);
231 break;
232 case FT_ATOM:
233 PL_unregister_atom(f->value.a);
234 break;
235 default:
236 ;
237 }
238
239 freeHeap(f, sizeof(*f));
240 }
241
242
243 #ifdef O_PLMT
244 static prolog_flag *
copy_prolog_flag(const prolog_flag * f)245 copy_prolog_flag(const prolog_flag *f)
246 { prolog_flag *copy = allocHeapOrHalt(sizeof(*copy));
247
248 *copy = *f;
249 switch((f->flags & FT_MASK))
250 { case FT_TERM:
251 copy->value.t = PL_duplicate_record(f->value.t);
252 break;
253 case FT_ATOM:
254 PL_register_atom(copy->value.a);
255 break;
256 default:
257 ;
258 }
259
260 return copy;
261 }
262
263
264 static void
copySymbolPrologFlagTable(void * name,void ** value)265 copySymbolPrologFlagTable(void *name, void **value)
266 { atom_t key = (atom_t)name;
267 prolog_flag *f = *value;
268
269 PL_register_atom(key);
270 *value = copy_prolog_flag(f);
271 }
272
273
274 static void
freeSymbolPrologFlagTable(void * name,void * value)275 freeSymbolPrologFlagTable(void *name, void *value)
276 { atom_t key = (atom_t)name;
277
278 PL_unregister_atom(key);
279 freePrologFlag(value);
280 }
281 #endif
282
283
284 int
setDoubleQuotes(atom_t a,unsigned int * flagp)285 setDoubleQuotes(atom_t a, unsigned int *flagp)
286 { GET_LD
287 unsigned int flags;
288
289 if ( a == ATOM_chars )
290 flags = DBLQ_CHARS;
291 else if ( a == ATOM_codes )
292 flags = 0;
293 else if ( a == ATOM_atom )
294 flags = DBLQ_ATOM;
295 else if ( a == ATOM_string )
296 flags = DBLQ_STRING;
297 else
298 { term_t value = PL_new_term_ref();
299
300 PL_put_atom(value, a);
301 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
302 ATOM_double_quotes, value);
303 }
304
305 *flagp &= ~DBLQ_MASK;
306 *flagp |= flags;
307
308 succeed;
309 }
310
311
312 int
setBackQuotes(atom_t a,unsigned int * flagp)313 setBackQuotes(atom_t a, unsigned int *flagp)
314 { GET_LD
315 unsigned int flags;
316
317 if ( a == ATOM_string )
318 flags = BQ_STRING;
319 else if ( a == ATOM_symbol_char )
320 flags = 0;
321 else if ( a == ATOM_codes )
322 flags = BQ_CODES;
323 else if ( a == ATOM_chars )
324 flags = BQ_CHARS;
325 else
326 { term_t value = PL_new_term_ref();
327
328 PL_put_atom(value, a);
329 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
330 ATOM_back_quotes, value);
331 }
332
333 *flagp &= ~BQ_MASK;
334 *flagp |= flags;
335
336 succeed;
337 }
338
339
340 int
setRationalSyntax(atom_t a,unsigned int * flagp)341 setRationalSyntax(atom_t a, unsigned int *flagp)
342 { GET_LD
343 unsigned int flags;
344
345 if ( a == ATOM_natural )
346 flags = RAT_NATURAL;
347 else if ( a == ATOM_compatibility )
348 flags = RAT_COMPAT;
349 else
350 { term_t value = PL_new_term_ref();
351
352 PL_put_atom(value, a);
353 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
354 ATOM_rational_syntax, value);
355 }
356
357 *flagp &= ~RAT_MASK;
358 *flagp |= flags;
359
360 succeed;
361 }
362
363
364
365 static int
setUnknown(term_t value,atom_t a,Module m)366 setUnknown(term_t value, atom_t a, Module m)
367 { unsigned int flags = m->flags & ~(UNKNOWN_MASK);
368
369 if ( a == ATOM_error )
370 flags |= UNKNOWN_ERROR;
371 else if ( a == ATOM_warning )
372 flags |= UNKNOWN_WARNING;
373 else if ( a == ATOM_fail )
374 flags |= UNKNOWN_FAIL;
375 else
376 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_unknown, value);
377
378 if ( !(flags&UNKNOWN_ERROR) && (m == MODULE_user || m == MODULE_system) )
379 { GET_LD
380
381 if ( m == MODULE_system && !SYSTEM_MODE )
382 { term_t key = PL_new_term_ref();
383
384 PL_put_atom(key, ATOM_unknown);
385 return PL_error(NULL, 0, NULL, ERR_PERMISSION,
386 ATOM_modify, ATOM_flag, key);
387 }
388
389 if ( !SYSTEM_MODE )
390 { if ( !printMessage(ATOM_warning, PL_CHARS, "unknown_in_module_user") )
391 return FALSE;
392 }
393 }
394
395 m->flags = flags;
396
397 return TRUE;
398 }
399
400
401 static int
setFileNameCaseHandling(atom_t a)402 setFileNameCaseHandling(atom_t a)
403 { GET_LD
404
405 if ( a == ATOM_case_sensitive )
406 { setPrologFlagMask(PLFLAG_FILE_CASE|PLFLAG_FILE_CASE_PRESERVING);
407 } else if ( a == ATOM_case_preserving )
408 { setPrologFlagMask(PLFLAG_FILE_CASE_PRESERVING);
409 clearPrologFlagMask(PLFLAG_FILE_CASE);
410 } else if ( a == ATOM_case_insensitive )
411 { clearPrologFlagMask(PLFLAG_FILE_CASE|PLFLAG_FILE_CASE_PRESERVING);
412 } else
413 { term_t value = PL_new_term_ref();
414
415 PL_put_atom(value, a);
416 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
417 ATOM_file_name_case_handling, value);
418 }
419
420 return TRUE;
421 }
422
423
424 static atom_t
currentFileNameCaseHandling(void)425 currentFileNameCaseHandling(void)
426 { GET_LD
427
428 switch ( LD->prolog_flag.mask.flags &
429 (PLFLAG_FILE_CASE|PLFLAG_FILE_CASE_PRESERVING) )
430 { case 0:
431 return ATOM_case_insensitive;
432 case PLFLAG_FILE_CASE_PRESERVING:
433 return ATOM_case_preserving;
434 case PLFLAG_FILE_CASE|PLFLAG_FILE_CASE_PRESERVING:
435 return ATOM_case_sensitive;
436 default:
437 return ATOM_unknown;
438 }
439 }
440
441
442 static int
setWriteAttributes(atom_t a)443 setWriteAttributes(atom_t a)
444 { GET_LD
445 int mask = writeAttributeMask(a);
446
447 if ( mask )
448 { LD->prolog_flag.write_attributes = mask;
449 succeed;
450 } else
451 { term_t value = PL_new_term_ref();
452
453 PL_put_atom(value, a);
454 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_write_attributes, value);
455 }
456 }
457
458
459 static int
setAccessLevelFromAtom(atom_t a)460 setAccessLevelFromAtom(atom_t a)
461 { GET_LD
462
463 if ( getAccessLevelMask(a, &LD->prolog_flag.access_level) )
464 { succeed;
465 } else
466 { term_t value = PL_new_term_ref();
467
468 PL_put_atom(value, a);
469 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_access_level, value);
470 }
471 }
472
473
474 static int
getOccursCheckMask(atom_t a,occurs_check_t * val)475 getOccursCheckMask(atom_t a, occurs_check_t *val)
476 { if ( a == ATOM_false )
477 { *val = OCCURS_CHECK_FALSE;
478 } else if ( a == ATOM_true )
479 { *val = OCCURS_CHECK_TRUE;
480 } else if ( a == ATOM_error )
481 { *val = OCCURS_CHECK_ERROR;
482 } else
483 fail;
484
485 succeed;
486 }
487
488
489 static int
setOccursCheck(atom_t a)490 setOccursCheck(atom_t a)
491 { GET_LD
492
493 if ( getOccursCheckMask(a, &LD->prolog_flag.occurs_check) )
494 { updateAlerted(LD);
495 succeed;
496 } else
497 { term_t value = PL_new_term_ref();
498
499 PL_put_atom(value, a);
500 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_occurs_check, value);
501 }
502 }
503
504
505 static int
setEncoding(atom_t a)506 setEncoding(atom_t a)
507 { GET_LD
508 IOENC enc = atom_to_encoding(a);
509
510 if ( enc == ENC_UNKNOWN )
511 { term_t value = PL_new_term_ref();
512
513 PL_put_atom(value, a);
514 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_encoding, value);
515 }
516
517 LD->encoding = enc;
518
519 succeed;
520 }
521
522
523 static int
setStreamTypeCheck(atom_t a)524 setStreamTypeCheck(atom_t a)
525 { GET_LD
526 st_check check;
527
528 if ( a == ATOM_false )
529 check = ST_FALSE;
530 else if ( a == ATOM_loose )
531 check = ST_LOOSE;
532 else if ( a == ATOM_true )
533 check = ST_TRUE;
534 else
535 { term_t value = PL_new_term_ref();
536
537 PL_put_atom(value, a);
538 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_stream_type_check, value);
539 }
540
541 LD->IO.stream_type_check = check;
542 return TRUE;
543 }
544
545
546 static int
setAutoload(atom_t a)547 setAutoload(atom_t a)
548 { GET_LD
549
550 if ( a == ATOM_false )
551 clearPrologFlagMask(PLFLAG_AUTOLOAD);
552 else if ( a == ATOM_explicit ||
553 a == ATOM_true ||
554 a == ATOM_user ||
555 a == ATOM_user_or_explicit )
556 setPrologFlagMask(PLFLAG_AUTOLOAD);
557 else
558 { term_t value = PL_new_term_ref();
559
560 PL_put_atom(value, a);
561 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_autoload, value);
562 }
563
564 return TRUE;
565 }
566
567
568 static int
propagateAutoload(term_t val ARG_LD)569 propagateAutoload(term_t val ARG_LD)
570 { if ( !GD->bootsession )
571 { predicate_t pred;
572 term_t av;
573
574 pred = PL_predicate("set_autoload", 1, "$autoload");
575 return ( (av=PL_new_term_refs(2)) &&
576 PL_put_term(av+0, val) &&
577 PL_call_predicate(NULL, PL_Q_PASS_EXCEPTION, pred, av) );
578 } else
579 { return TRUE;
580 }
581 }
582
583
584 #if O_XOS
585 typedef struct access_id
586 { char *name;
587 int value;
588 } access_id;
589
590 static const access_id access_id_list[] =
591 { { "access", XOS_ACCESS_ACCESS },
592 { "getfilesecurity", XOS_ACCESS_GETFILESECURITY },
593 { "openclose", XOS_ACCESS_OPENCLOSE },
594 { NULL, -1 }
595 };
596
597
598 static int
set_win_file_access_check(term_t a)599 set_win_file_access_check(term_t a)
600 { char *s;
601 const access_id *p;
602
603 if ( PL_get_chars(a, &s, CVT_ATOM) )
604 { for(p=access_id_list; p->name; p++)
605 { if ( strcmp(s, p->name) == 0 )
606 { _xos_set_win_file_access_check(p->value);
607 return TRUE;
608 }
609 }
610 }
611
612 return PL_domain_error("win_file_access_check", a);
613 }
614
615 static char*
get_win_file_access_check(void)616 get_win_file_access_check(void)
617 { const access_id *p;
618 int id = _xos_get_win_file_access_check();
619
620 for(p=access_id_list; p->name; p++)
621 { if ( p->value == id )
622 return p->name;
623 }
624 return "unknown";
625 }
626 #endif
627
628 static word
set_prolog_flag_unlocked(Module m,atom_t k,term_t value,int flags ARG_LD)629 set_prolog_flag_unlocked(Module m, atom_t k, term_t value, int flags ARG_LD)
630 { prolog_flag *f;
631 int rval = TRUE;
632
633 /* set existing Prolog flag */
634 #ifdef O_PLMT
635 if ( LD->prolog_flag.table &&
636 (f = lookupHTable(LD->prolog_flag.table, (void *)k)) )
637 { if ( flags & FF_KEEP )
638 return TRUE;
639 } else
640 #endif
641 if ( (f = lookupHTable(GD->prolog_flag.table, (void *)k)) )
642 { if ( flags & FF_KEEP )
643 return TRUE;
644 if ( (f->flags&FF_READONLY) && !(flags&FF_FORCE) )
645 { term_t key;
646
647 return ( (key = PL_new_term_ref()) &&
648 PL_put_atom(key, k) &&
649 PL_error(NULL, 0, NULL, ERR_PERMISSION,
650 ATOM_modify, ATOM_flag, key) );
651 }
652
653 if ( tbl_is_restraint_flag(k) )
654 return tbl_set_restraint_flag(value, k PASS_LD);
655 if ( is_arith_flag(k) )
656 return set_arith_flag(value, k PASS_LD);
657
658 #ifdef O_PLMT
659 if ( GD->statistics.threads_created > 1 )
660 { f = copy_prolog_flag(f);
661
662 if ( !LD->prolog_flag.table )
663 { LD->prolog_flag.table = newHTable(4);
664
665 LD->prolog_flag.table->copy_symbol = copySymbolPrologFlagTable;
666 LD->prolog_flag.table->free_symbol = freeSymbolPrologFlagTable;
667 }
668
669 addNewHTable(LD->prolog_flag.table, (void *)k, f);
670 PL_register_atom(k);
671 DEBUG(MSG_PROLOG_FLAG,
672 Sdprintf("Localised Prolog flag %s\n", PL_atom_chars(k)));
673 }
674 #endif
675 } else if ( !(flags & FF_NOCREATE) ) /* define new Prolog flag */
676 { prolog_flag *f;
677 atom_t a;
678 int64_t i;
679 double d;
680
681 anyway:
682 PL_register_atom(k);
683 f = allocHeapOrHalt(sizeof(*f));
684 f->index = -1;
685
686 switch( (flags & FT_MASK) )
687 { case FT_FROM_VALUE:
688 { if ( PL_get_atom(value, &a) )
689 { if ( a == ATOM_true || a == ATOM_false ||
690 a == ATOM_on || a == ATOM_off )
691 f->flags = FT_BOOL;
692 else
693 f->flags = FT_ATOM;
694 f->value.a = a;
695 PL_register_atom(a);
696 } else if ( PL_get_int64(value, &i) )
697 { f->flags = FT_INTEGER;
698 f->value.i = i;
699 } else if ( PL_get_float(value, &d) )
700 { f->flags = FT_FLOAT;
701 f->value.f = d;
702 } else
703 { f->flags = FT_TERM;
704 if ( !PL_is_ground(value) )
705 { PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
706 goto wrong_type;
707 }
708 if ( !(f->value.t = PL_record(value)) )
709 { freeHeap(f, sizeof(*f));
710 return FALSE;
711 }
712 }
713 break;
714 }
715 case FT_ATOM:
716 if ( !PL_get_atom_ex(value, &f->value.a) )
717 { wrong_type:
718 freeHeap(f, sizeof(*f));
719 return FALSE;
720 }
721 f->flags = FT_ATOM;
722 PL_register_atom(f->value.a);
723 break;
724 case FT_BOOL:
725 { int b;
726 if ( !PL_get_bool_ex(value, &b) )
727 goto wrong_type;
728 f->flags = FT_BOOL;
729 f->value.a = (b ? ATOM_true : ATOM_false);
730 break;
731 }
732 case FT_INTEGER:
733 if ( !PL_get_int64_ex(value, &f->value.i) )
734 goto wrong_type;
735 f->flags = FT_INTEGER;
736 break;
737 case FT_FLOAT:
738 if ( !PL_get_float_ex(value, &f->value.f) )
739 goto wrong_type;
740 f->flags = FT_FLOAT;
741 break;
742 case FT_TERM:
743 if ( !PL_is_ground(value) )
744 { PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
745 goto wrong_type;
746 }
747 if ( !(f->value.t = PL_record(value)) )
748 goto wrong_type;
749 f->flags = FT_TERM;
750 break;
751 }
752
753 if ( (flags & FF_READONLY) )
754 f->flags |= FF_READONLY;
755
756 addNewHTable(GD->prolog_flag.table, (void *)k, f);
757 if ( !(lookupHTable(GD->prolog_flag.table, (void *)k) == f) )
758 { freePrologFlag(f);
759 Sdprintf("OOPS; failed to set Prolog flag!?\n");
760 }
761
762 succeed;
763 } else
764 { atom_t how;
765
766 if ( PL_current_prolog_flag(ATOM_user_flags, PL_ATOM, &how) )
767 { if ( how == ATOM_error )
768 { term_t key;
769
770 return ( (key = PL_new_term_ref()) &&
771 PL_put_atom(key, k) &&
772 PL_error(NULL, 0, NULL, ERR_EXISTENCE,
773 ATOM_prolog_flag, key) );
774 } else if ( how == ATOM_warning )
775 Sdprintf("WARNING: Flag %s: new Prolog flags must be created using "
776 "create_prolog_flag/3\n", stringAtom(k));
777 }
778
779 goto anyway;
780 }
781
782 switch(f->flags & FT_MASK)
783 { case FT_BOOL:
784 { int val;
785
786 if ( !PL_get_bool_ex(value, &val) )
787 return FALSE;
788
789 /* deal with side-effects */
790 if ( k == ATOM_character_escapes )
791 { if ( val )
792 set(m, M_CHARESCAPE);
793 else
794 clear(m, M_CHARESCAPE);
795 } else if ( k == ATOM_var_prefix )
796 { if ( val )
797 set(m, M_VARPREFIX);
798 else
799 clear(m, M_VARPREFIX);
800 } else if ( k == ATOM_debug )
801 { if ( val )
802 { rval = debugmode(DBG_ALL, NULL);
803 } else
804 { rval = ( tracemode(FALSE, NULL) &&
805 debugmode(DBG_OFF, NULL) );
806 }
807 } else if ( k == ATOM_debugger_show_context )
808 { debugstatus.showContext = val;
809 #ifdef O_PLMT
810 } else if ( k == ATOM_threads )
811 { if ( val )
812 { rval = enableThreads(val);
813 PL_LOCK(L_PLFLAG);
814 } else
815 { PL_UNLOCK(L_PLFLAG);
816 rval = enableThreads(val);
817 }
818 if ( !rval )
819 break; /* don't change value */
820 #endif
821 } else if ( k == ATOM_tty_control )
822 { if ( val != (f->value.a == ATOM_true) )
823 { if ( !val && ttymodified )
824 { PopTty(Sinput, &ttytab, FALSE);
825 } else if ( val )
826 { setPrologFlagMask(PLFLAG_TTY_CONTROL);
827 PushTty(Sinput, &ttytab, TTY_SAVE);
828 }
829 }
830 } else if ( k == ATOM_protect_static_code )
831 { if ( val != (f->value.a == ATOM_true) && val == FALSE )
832 { term_t ex;
833
834 if ( (ex = PL_new_term_ref()) &&
835 PL_put_atom(ex, ATOM_protect_static_code) )
836 return PL_permission_error("set", "prolog_flag", ex);
837 return FALSE;
838 }
839 }
840 /* set the flag value */
841 if ( f->index > 0 )
842 { unsigned int mask = (unsigned int)1 << (f->index-1);
843
844 if ( val )
845 setPrologFlagMask(mask);
846 else
847 clearPrologFlagMask(mask);
848 }
849 f->value.a = (val ? ATOM_true : ATOM_false);
850
851 break;
852 }
853 case FT_ATOM:
854 { atom_t a;
855
856 if ( !PL_get_atom_ex(value, &a) )
857 return FALSE;
858
859 if ( k == ATOM_double_quotes )
860 { rval = setDoubleQuotes(a, &m->flags);
861 } else if ( k == ATOM_back_quotes )
862 { rval = setBackQuotes(a, &m->flags);
863 } else if ( k == ATOM_rational_syntax )
864 { rval = setRationalSyntax(a, &m->flags);
865 } else if ( k == ATOM_unknown )
866 { rval = setUnknown(value, a, m);
867 } else if ( k == ATOM_write_attributes )
868 { rval = setWriteAttributes(a);
869 } else if ( k == ATOM_occurs_check )
870 { rval = setOccursCheck(a);
871 } else if ( k == ATOM_access_level )
872 { rval = setAccessLevelFromAtom(a);
873 } else if ( k == ATOM_encoding )
874 { rval = setEncoding(a);
875 } else if ( k == ATOM_stream_type_check )
876 { rval = setStreamTypeCheck(a);
877 } else if ( k == ATOM_file_name_case_handling )
878 { rval = setFileNameCaseHandling(a);
879 } else if ( k == ATOM_autoload )
880 { rval = setAutoload(a);
881 #if O_XOS
882 } else if ( k == ATOM_win_file_access_check )
883 { rval = set_win_file_access_check(value);
884 #endif
885 }
886 if ( !rval )
887 fail;
888
889 if ( f->value.a != a )
890 { PL_unregister_atom(f->value.a);
891 f->value.a = a;
892 PL_register_atom(a);
893 }
894 break;
895 }
896 case FT_INTEGER:
897 { int64_t i;
898
899 if ( !PL_get_int64_ex(value, &i) )
900 return FALSE;
901 f->value.i = i;
902
903 #ifdef O_ATOMGC
904 if ( k == ATOM_agc_margin )
905 GD->atoms.margin = (size_t)i;
906 else
907 #endif
908 if ( k == ATOM_table_space )
909 { if ( !LD->tabling.node_pool )
910 LD->tabling.node_pool = new_alloc_pool("private_table_space", i);
911 else
912 LD->tabling.node_pool->limit = (size_t)i;
913 }
914 #ifdef O_PLMT
915 else if ( k == ATOM_shared_table_space )
916 { if ( !GD->tabling.node_pool )
917 { alloc_pool *pool = new_alloc_pool("shared_table_space", i);
918 if ( pool && !COMPARE_AND_SWAP_PTR(&GD->tabling.node_pool, NULL, pool) )
919 free_alloc_pool(pool);
920 } else
921 GD->tabling.node_pool->limit = (size_t)i;
922 }
923 #endif
924 else if ( k == ATOM_stack_limit )
925 { if ( !set_stack_limit((size_t)i) )
926 return FALSE;
927 } else if ( k == ATOM_string_stack_tripwire )
928 { LD->fli.string_buffers.tripwire = (unsigned int)i;
929 }
930 break;
931 }
932 case FT_FLOAT:
933 { double d;
934
935 if ( !PL_get_float_ex(value, &d) )
936 return FALSE;
937 f->value.f = d;
938 break;
939 }
940 case FT_TERM:
941 { if ( f->value.t )
942 PL_erase(f->value.t);
943 f->value.t = PL_record(value);
944 break;
945 }
946 default:
947 assert(0);
948 }
949
950 return rval;
951 }
952
953
954 int
set_prolog_flag(term_t key,term_t value,int flags)955 set_prolog_flag(term_t key, term_t value, int flags)
956 { GET_LD
957 atom_t k;
958 Module m = MODULE_parse;
959 int rc;
960
961 if ( !PL_strip_module(key, &m, key) ||
962 !PL_get_atom_ex(key, &k) )
963 return FALSE;
964
965 if ( k == ATOM_autoload && !propagateAutoload(value PASS_LD) )
966 return FALSE;
967
968 PL_LOCK(L_PLFLAG);
969 rc = set_prolog_flag_unlocked(m, k, value, flags PASS_LD);
970 PL_UNLOCK(L_PLFLAG);
971
972 return rc;
973 }
974
975 /** set_prolog_flag(+Key, +Value) is det.
976 */
977
978 static
979 PRED_IMPL("set_prolog_flag", 2, set_prolog_flag, PL_FA_ISO)
980 { return set_prolog_flag(A1, A2, FF_NOCREATE|FT_FROM_VALUE);
981 }
982
983
984 /** create_prolog_flag(+Key, +Value, +Options) is det.
985 */
986
987 static const opt_spec prolog_flag_options[] =
988 { { ATOM_type, OPT_ATOM },
989 { ATOM_access, OPT_ATOM },
990 { ATOM_keep, OPT_BOOL },
991 { NULL_ATOM, 0 }
992 };
993
994 static
995 PRED_IMPL("create_prolog_flag", 3, create_prolog_flag, PL_FA_ISO)
996 { PRED_LD
997 int flags = 0;
998 atom_t type = 0;
999 atom_t access = ATOM_read_write;
1000 int keep = FALSE;
1001
1002 if ( !scan_options(A3, 0, ATOM_prolog_flag_option, prolog_flag_options,
1003 &type, &access, &keep) )
1004 return FALSE;
1005
1006 if ( type == 0 )
1007 flags |= FT_FROM_VALUE;
1008 else if ( type == ATOM_boolean )
1009 flags |= FT_BOOL;
1010 else if ( type == ATOM_integer )
1011 flags |= FT_INTEGER;
1012 else if ( type == ATOM_float )
1013 flags |= FT_FLOAT;
1014 else if ( type == ATOM_atom )
1015 flags |= FT_ATOM;
1016 else if ( type == ATOM_term )
1017 flags |= FT_TERM;
1018 else
1019 { term_t a = PL_new_term_ref();
1020 PL_put_atom(a, type);
1021
1022 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_prolog_flag_type, a);
1023 }
1024
1025 if ( access == ATOM_read_only )
1026 flags |= FF_READONLY;
1027 else if ( access != ATOM_read_write )
1028 { term_t a = PL_new_term_ref();
1029 PL_put_atom(a, access);
1030 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_prolog_flag_access, a);
1031 }
1032
1033 if ( keep )
1034 flags |= FF_KEEP;
1035
1036 return set_prolog_flag(A1, A2, flags);
1037 }
1038
1039
1040 static prolog_flag *
lookupFlag(atom_t key)1041 lookupFlag(atom_t key)
1042 { GET_LD
1043 #ifdef O_PLMT
1044 prolog_flag *f = NULL;
1045
1046 if ( LD->prolog_flag.table &&
1047 (f = lookupHTable(LD->prolog_flag.table, (void *)key)) )
1048 { return f;
1049 } else
1050 #endif
1051 { return lookupHTable(GD->prolog_flag.table, (void *)key);
1052 }
1053 }
1054
1055
1056 int
PL_current_prolog_flag(atom_t name,int type,void * value)1057 PL_current_prolog_flag(atom_t name, int type, void *value)
1058 { prolog_flag *f;
1059
1060 if ( (f=lookupFlag(name)) )
1061 { switch(type)
1062 { case PL_ATOM:
1063 if ( (f->flags&FT_MASK) == FT_ATOM )
1064 { atom_t *vp = value;
1065 *vp = f->value.a;
1066 return TRUE;
1067 }
1068 return FALSE;
1069 case PL_INTEGER:
1070 if ( (f->flags&FT_MASK) == FT_INTEGER )
1071 { int64_t *vp = value;
1072 *vp = f->value.i;
1073 return TRUE;
1074 }
1075 return FALSE;
1076 case PL_FLOAT:
1077 if ( (f->flags&FT_MASK) == FT_FLOAT )
1078 { double *vp = value;
1079 *vp = f->value.f;
1080 return TRUE;
1081 }
1082 return FALSE;
1083 case PL_TERM:
1084 if ( (f->flags&FT_MASK) == FT_TERM )
1085 { term_t *vp = value;
1086 term_t t = *vp;
1087
1088 return PL_recorded(f->value.t, t);
1089 }
1090 return FALSE;
1091 }
1092 }
1093
1094 return FALSE;
1095 }
1096
1097
1098
1099 static int
unify_prolog_flag_value(Module m,atom_t key,prolog_flag * f,term_t val)1100 unify_prolog_flag_value(Module m, atom_t key, prolog_flag *f, term_t val)
1101 { GET_LD
1102
1103 if ( key == ATOM_character_escapes )
1104 { return PL_unify_bool(val, true(m, M_CHARESCAPE));
1105 } else if ( key == ATOM_var_prefix )
1106 { return PL_unify_bool(val, true(m, M_VARPREFIX));
1107 } else if ( key == ATOM_double_quotes )
1108 { atom_t v;
1109
1110 if ( true(m, DBLQ_CHARS) )
1111 v = ATOM_chars;
1112 else if ( true(m, DBLQ_ATOM) )
1113 v = ATOM_atom;
1114 else if ( true(m, DBLQ_STRING) )
1115 v = ATOM_string;
1116 else
1117 v = ATOM_codes;
1118
1119 return PL_unify_atom(val, v);
1120 } else if ( key == ATOM_back_quotes )
1121 { atom_t v;
1122
1123 if ( true(m, BQ_STRING) )
1124 v = ATOM_string;
1125 else if ( true(m, BQ_CODES) )
1126 v = ATOM_codes;
1127 else if ( true(m, BQ_CHARS) )
1128 v = ATOM_chars;
1129 else
1130 v = ATOM_symbol_char;
1131
1132 return PL_unify_atom(val, v);
1133 } else if ( key == ATOM_rational_syntax )
1134 { atom_t v;
1135
1136 switch(m->flags&RAT_MASK)
1137 { case RAT_NATURAL: v = ATOM_natural; break;
1138 case RAT_COMPAT: v = ATOM_compatibility; break;
1139 default: v = 0; assert(0);
1140 }
1141
1142 return PL_unify_atom(val, v);
1143 } else if ( key == ATOM_unknown )
1144 { atom_t v;
1145
1146 switch ( getUnknownModule(m) )
1147 { case UNKNOWN_ERROR:
1148 v = ATOM_error;
1149 break;
1150 case UNKNOWN_WARNING:
1151 v = ATOM_warning;
1152 break;
1153 case UNKNOWN_FAIL:
1154 v = ATOM_fail;
1155 break;
1156 default:
1157 assert(0);
1158 return FALSE;
1159 }
1160
1161 return PL_unify_atom(val, v);
1162 #ifdef O_PLMT
1163 } else if ( key == ATOM_system_thread_id )
1164 { return PL_unify_integer(val, system_thread_id(NULL));
1165 #endif
1166 } else if ( key == ATOM_debug )
1167 { return PL_unify_bool_ex(val, debugstatus.debugging);
1168 } else if ( key == ATOM_debugger_show_context )
1169 { return PL_unify_bool_ex(val, debugstatus.showContext);
1170 } else if ( key == ATOM_break_level )
1171 { int bl = currentBreakLevel();
1172
1173 if ( bl >= 0 )
1174 return PL_unify_integer(val, bl);
1175 return FALSE;
1176 } else if ( key == ATOM_access_level )
1177 { return PL_unify_atom(val, accessLevel());
1178 } else if ( key == ATOM_stack_limit )
1179 { return PL_unify_int64(val, LD->stacks.limit);
1180 } else if ( tbl_is_restraint_flag(key) )
1181 { return tbl_get_restraint_flag(val, key PASS_LD) == TRUE;
1182 } else if ( is_arith_flag(key) )
1183 { return get_arith_flag(val, key PASS_LD) == TRUE;
1184 }
1185
1186 switch(f->flags & FT_MASK)
1187 { case FT_BOOL:
1188 if ( f->index >= 0 )
1189 { unsigned int mask = (unsigned int)1 << (f->index-1);
1190
1191 return PL_unify_bool_ex(val, truePrologFlag(mask) != FALSE);
1192 }
1193 /*FALLTHROUGH*/
1194 case FT_ATOM:
1195 return PL_unify_atom(val, f->value.a);
1196 case FT_INTEGER:
1197 return PL_unify_int64(val, f->value.i);
1198 case FT_FLOAT:
1199 return PL_unify_float(val, f->value.f);
1200 case FT_TERM:
1201 { term_t tmp = PL_new_term_ref();
1202
1203 if ( PL_recorded(f->value.t, tmp) )
1204 return PL_unify(val, tmp);
1205 else
1206 return raiseStackOverflow(GLOBAL_OVERFLOW);
1207 }
1208 default:
1209 assert(0);
1210 fail;
1211 }
1212 }
1213
1214
1215 static int
unify_prolog_flag_access(prolog_flag * f,term_t access)1216 unify_prolog_flag_access(prolog_flag *f, term_t access)
1217 { GET_LD
1218
1219 if ( f->flags & FF_READONLY )
1220 return PL_unify_atom(access, ATOM_read);
1221 else
1222 return PL_unify_atom(access, ATOM_write);
1223 }
1224
1225
1226 static int
unify_prolog_flag_type(prolog_flag * f,term_t type)1227 unify_prolog_flag_type(prolog_flag *f, term_t type)
1228 { GET_LD
1229 atom_t a;
1230
1231 switch(f->flags & FT_MASK)
1232 { case FT_BOOL:
1233 a = ATOM_boolean;
1234 break;
1235 case FT_ATOM:
1236 a = ATOM_atom;
1237 break;
1238 case FT_INTEGER:
1239 a = ATOM_integer;
1240 break;
1241 case FT_FLOAT:
1242 a = ATOM_float;
1243 break;
1244 case FT_TERM:
1245 a = ATOM_term;
1246 break;
1247 default:
1248 assert(0);
1249 fail;
1250 }
1251
1252 return PL_unify_atom(type, a);
1253 }
1254
1255
1256 typedef struct
1257 { TableEnum table_enum;
1258 atom_t scope;
1259 int explicit_scope;
1260 Module module;
1261 } prolog_flag_enum;
1262
1263 word
pl_prolog_flag5(term_t key,term_t value,word scope,word access,word type,control_t h)1264 pl_prolog_flag5(term_t key, term_t value,
1265 word scope, word access, word type,
1266 control_t h)
1267 { GET_LD
1268 prolog_flag_enum *e;
1269 fid_t fid;
1270 Module module;
1271
1272 switch( ForeignControl(h) )
1273 { case FRG_FIRST_CALL:
1274 { atom_t k;
1275
1276 module = MODULE_parse;
1277 if ( !PL_strip_module(key, &module, key) )
1278 return FALSE;
1279
1280 if ( PL_get_atom(key, &k) )
1281 { prolog_flag *f;
1282
1283 #ifdef O_PLMT
1284 if ( LD->prolog_flag.table &&
1285 (f = lookupHTable(LD->prolog_flag.table, (void *)k)) )
1286 return unify_prolog_flag_value(module, k, f, value);
1287 #endif
1288 if ( (f = lookupHTable(GD->prolog_flag.table, (void *)k)) )
1289 { if ( unify_prolog_flag_value(module, k, f, value) &&
1290 (!access || unify_prolog_flag_access(f, access)) &&
1291 (!type || unify_prolog_flag_type(f, type)) )
1292 succeed;
1293 }
1294
1295 fail;
1296 } else if ( PL_is_variable(key) )
1297 { e = allocHeapOrHalt(sizeof(*e));
1298
1299 e->module = module;
1300
1301 if ( scope && PL_get_atom(scope, &e->scope) )
1302 { e->explicit_scope = TRUE;
1303 if ( !(e->scope == ATOM_local || e->scope == ATOM_global) )
1304 { freeHeap(e, sizeof(*e));
1305 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
1306 PL_new_atom("scope"), scope);
1307 }
1308 } else
1309 { e->explicit_scope = FALSE;
1310
1311 if ( LD->prolog_flag.table )
1312 e->scope = ATOM_local;
1313 else
1314 e->scope = ATOM_global;
1315 }
1316
1317 if ( e->scope == ATOM_local )
1318 e->table_enum = newTableEnum(LD->prolog_flag.table);
1319 else
1320 e->table_enum = newTableEnum(GD->prolog_flag.table);
1321
1322 break;
1323 } else
1324 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, key);
1325 }
1326 case FRG_REDO:
1327 e = ForeignContextPtr(h);
1328 break;
1329 case FRG_CUTTED:
1330 e = ForeignContextPtr(h);
1331 if ( e )
1332 { freeTableEnum(e->table_enum);
1333 freeHeap(e, sizeof(*e));
1334 }
1335 default:
1336 succeed;
1337 }
1338
1339 fid = PL_open_foreign_frame();
1340 PL_LOCK(L_PLFLAG);
1341 for(;;)
1342 { atom_t fn;
1343 prolog_flag *f;
1344 while( advanceTableEnum(e->table_enum, (void**)&fn, (void**)&f) )
1345 { if ( e->explicit_scope == FALSE &&
1346 e->scope == ATOM_global &&
1347 LD->prolog_flag.table &&
1348 lookupHTable(LD->prolog_flag.table, (void *)fn) )
1349 continue;
1350
1351 if ( PL_unify_atom(key, fn) &&
1352 unify_prolog_flag_value(e->module, fn, f, value) &&
1353 (!scope || PL_unify_atom(scope, e->scope)) &&
1354 (!access || unify_prolog_flag_access(f, access)) &&
1355 (!type || unify_prolog_flag_type(f, type)) )
1356 { PL_UNLOCK(L_PLFLAG);
1357 ForeignRedoPtr(e);
1358 }
1359 if ( exception_term )
1360 { exception_term = 0;
1361 setVar(*valTermRef(exception_bin));
1362 }
1363 PL_rewind_foreign_frame(fid);
1364 }
1365
1366 if ( e->scope == ATOM_local )
1367 { e->scope = ATOM_global;
1368 freeTableEnum(e->table_enum);
1369 e->table_enum = newTableEnum(GD->prolog_flag.table);
1370 } else
1371 break;
1372 }
1373 PL_UNLOCK(L_PLFLAG);
1374
1375 freeTableEnum(e->table_enum);
1376 freeHeap(e, sizeof(*e));
1377
1378 fail;
1379 }
1380
1381
1382 foreign_t
pl_prolog_flag(term_t name,term_t value,control_t h)1383 pl_prolog_flag(term_t name, term_t value, control_t h)
1384 { return pl_prolog_flag5(name, value, 0, 0, 0, h);
1385 }
1386
1387
1388 /*******************************
1389 * INITIALISE FEATURES *
1390 *******************************/
1391
1392 #ifndef SO_EXT
1393 #define SO_EXT "so"
1394 #endif
1395 #ifndef SO_PATH
1396 #define SO_PATH "LD_LIBRARY_PATH"
1397 #endif
1398 #ifndef C_LIBPLSO
1399 #define C_LIBPLSO ""
1400 #endif
1401
1402 static void
initPrologFlagTable(void)1403 initPrologFlagTable(void)
1404 { if ( !GD->prolog_flag.table )
1405 { initPrologThreads(); /* may be called before PL_initialise() */
1406
1407 GD->prolog_flag.table = newHTable(64);
1408 }
1409 }
1410
1411
1412 void
initPrologFlags(void)1413 initPrologFlags(void)
1414 { GET_LD
1415 setPrologFlag("iso", FT_BOOL, FALSE, PLFLAG_ISO);
1416 setPrologFlag("arch", FT_ATOM|FF_READONLY, PLARCH);
1417 #if __WINDOWS__
1418 setPrologFlag("windows", FT_BOOL|FF_READONLY, TRUE, 0);
1419 const char *wine_version;
1420 if ( (wine_version=PL_w32_running_under_wine()) )
1421 setPrologFlag("wine_version", FT_ATOM|FF_READONLY, wine_version, 0);
1422 #endif
1423 #if O_XOS
1424 setPrologFlag("win_file_access_check", FT_ATOM,
1425 get_win_file_access_check(), 0);
1426 #endif
1427 setPrologFlag("file_name_case_handling", FT_ATOM,
1428 stringAtom(currentFileNameCaseHandling()));
1429 setPrologFlag("version", FT_INTEGER|FF_READONLY, PLVERSION);
1430 setPrologFlag("dialect", FT_ATOM|FF_READONLY, "swi");
1431 if ( systemDefaults.home )
1432 setPrologFlag("home", FT_ATOM|FF_READONLY, systemDefaults.home);
1433 #ifdef PLSHAREDHOME
1434 setPrologFlag("shared_home", FT_ATOM|FF_READONLY, PLSHAREDHOME);
1435 #endif
1436 if ( GD->paths.executable )
1437 setPrologFlag("executable", FT_ATOM|FF_READONLY, GD->paths.executable);
1438 #if defined(HAVE_GETPID) || defined(EMULATE_GETPID)
1439 setPrologFlag("pid", FT_INTEGER|FF_READONLY, getpid());
1440 #endif
1441 setPrologFlag("optimise", FT_BOOL, GD->cmdline.optimise, PLFLAG_OPTIMISE);
1442 setPrologFlag("optimise_debug", FT_ATOM, "default", 0);
1443 setPrologFlag("generate_debug_info", FT_BOOL,
1444 truePrologFlag(PLFLAG_DEBUGINFO), PLFLAG_DEBUGINFO);
1445 setPrologFlag("protect_static_code", FT_BOOL, FALSE,
1446 PLFLAG_PROTECT_STATIC_CODE);
1447 setPrologFlag("last_call_optimisation", FT_BOOL, TRUE, PLFLAG_LASTCALL);
1448 setPrologFlag("warn_override_implicit_import", FT_BOOL, TRUE,
1449 PLFLAG_WARN_OVERRIDE_IMPLICIT_IMPORT);
1450 setPrologFlag("c_cc", FT_ATOM, C_CC);
1451 setPrologFlag("c_libs", FT_ATOM, C_LIBS);
1452 #ifdef C_LIBDIR
1453 setPrologFlag("c_libdir", FT_ATOM, C_LIBDIR);
1454 #endif
1455 setPrologFlag("c_libplso", FT_ATOM, C_LIBPLSO);
1456 setPrologFlag("c_ldflags", FT_ATOM, C_LDFLAGS);
1457 setPrologFlag("c_cflags", FT_ATOM, C_CFLAGS);
1458 setPrologFlag("tmp_dir", FT_ATOM, SWIPL_TMP_DIR);
1459 #if defined(O_LARGEFILES) || SIZEOF_LONG == 8
1460 setPrologFlag("large_files", FT_BOOL|FF_READONLY, TRUE, 0);
1461 #endif
1462 setPrologFlag("unload_foreign_libraries", FT_BOOL, FALSE, 0);
1463 setPrologFlag("gc", FT_BOOL, TRUE, PLFLAG_GC);
1464 setPrologFlag("trace_gc", FT_BOOL, FALSE, PLFLAG_TRACE_GC);
1465 #ifdef O_ATOMGC
1466 setPrologFlag("agc_margin",FT_INTEGER, GD->atoms.margin);
1467 #endif
1468 setPrologFlag("table_space", FT_INTEGER, GD->options.tableSpace);
1469 #ifdef O_PLMT
1470 setPrologFlag("shared_table_space", FT_INTEGER, GD->options.sharedTableSpace);
1471 #endif
1472 setPrologFlag("stack_limit", FT_INTEGER, LD->stacks.limit);
1473 #if defined(HAVE_DLOPEN) || defined(HAVE_SHL_LOAD) || defined(EMULATE_DLOPEN)
1474 setPrologFlag("open_shared_object", FT_BOOL|FF_READONLY, TRUE, 0);
1475 setPrologFlag("shared_object_extension", FT_ATOM|FF_READONLY, SO_EXT);
1476 setPrologFlag("shared_object_search_path", FT_ATOM|FF_READONLY, SO_PATH);
1477 #endif
1478 setPrologFlag("address_bits", FT_INTEGER|FF_READONLY, sizeof(void*)*8);
1479 #ifdef HAVE_POPEN
1480 setPrologFlag("pipe", FT_BOOL, TRUE, 0);
1481 #endif
1482 #ifdef O_PLMT
1483 setPrologFlag("threads", FT_BOOL, !GD->options.nothreads, 0);
1484 if ( GD->options.xpce >= 0 )
1485 setPrologFlag("xpce", FT_BOOL, GD->options.xpce, 0);
1486 setPrologFlag("system_thread_id", FT_INTEGER|FF_READONLY, 0, 0);
1487 setPrologFlag("gc_thread", FT_BOOL,
1488 !GD->options.nothreads &&
1489 truePrologFlag(PLFLAG_GCTHREAD), PLFLAG_GCTHREAD);
1490 #else
1491 setPrologFlag("threads", FT_BOOL|FF_READONLY, FALSE, 0);
1492 setPrologFlag("gc_thread", FT_BOOL|FF_READONLY, FALSE, PLFLAG_GCTHREAD);
1493 #endif
1494 #ifdef O_DDE
1495 setPrologFlag("dde", FT_BOOL|FF_READONLY, TRUE, 0);
1496 #endif
1497 #ifdef O_RUNTIME
1498 setPrologFlag("runtime", FT_BOOL|FF_READONLY, TRUE, 0);
1499 setPrologFlag("debug_on_error", FT_BOOL|FF_READONLY, FALSE,
1500 PLFLAG_DEBUG_ON_ERROR);
1501 setPrologFlag("report_error", FT_BOOL|FF_READONLY, FALSE,
1502 PLFLAG_REPORT_ERROR);
1503 #else
1504 setPrologFlag("debug_on_error", FT_BOOL, TRUE, PLFLAG_DEBUG_ON_ERROR);
1505 setPrologFlag("report_error", FT_BOOL, TRUE, PLFLAG_REPORT_ERROR);
1506 #endif
1507 setPrologFlag("break_level", FT_INTEGER|FF_READONLY, 0, 0);
1508 setPrologFlag("user_flags", FT_ATOM, "silent");
1509 setPrologFlag("editor", FT_ATOM, "default");
1510 setPrologFlag("debugger_show_context", FT_BOOL, FALSE, 0);
1511 setPrologFlag("autoload", FT_ATOM, "true");
1512 setPrologFlagMask(PLFLAG_AUTOLOAD);
1513 #ifndef O_GMP
1514 setPrologFlag("max_integer", FT_INT64|FF_READONLY, PLMAXINT);
1515 setPrologFlag("min_integer", FT_INT64|FF_READONLY, PLMININT);
1516 #endif
1517 setPrologFlag("max_tagged_integer", FT_INTEGER|FF_READONLY, PLMAXTAGGEDINT);
1518 setPrologFlag("min_tagged_integer", FT_INTEGER|FF_READONLY, PLMINTAGGEDINT);
1519 #ifdef O_GMP
1520 setPrologFlag("bounded", FT_BOOL|FF_READONLY, FALSE, 0);
1521 setPrologFlag("prefer_rationals", FT_BOOL, O_PREFER_RATIONALS, PLFLAG_RATIONAL);
1522 setPrologFlag("rational_syntax", FT_ATOM,
1523 O_RATIONAL_SYNTAX == RAT_NATURAL ? "natural" :
1524 "compatibility");
1525 #ifdef __GNU_MP__
1526 setPrologFlag("gmp_version", FT_INTEGER|FF_READONLY, __GNU_MP__);
1527 #endif
1528 #else
1529 setPrologFlag("bounded", FT_BOOL|FF_READONLY, TRUE, 0);
1530 #endif
1531 if ( (-3 / 2) == -2 )
1532 setPrologFlag("integer_rounding_function", FT_ATOM|FF_READONLY, "down");
1533 else
1534 setPrologFlag("integer_rounding_function", FT_ATOM|FF_READONLY, "toward_zero");
1535 setPrologFlag("max_arity", FT_ATOM|FF_READONLY, "unbounded");
1536 setPrologFlag("answer_format", FT_ATOM, "~p");
1537 setPrologFlag("colon_sets_calling_context", FT_BOOL|FF_READONLY, TRUE, 0);
1538 setPrologFlag("character_escapes", FT_BOOL, TRUE, PLFLAG_CHARESCAPE);
1539 setPrologFlag("var_prefix", FT_BOOL, FALSE, PLFLAG_VARPREFIX);
1540 setPrologFlag("char_conversion", FT_BOOL, FALSE, PLFLAG_CHARCONVERSION);
1541 #ifdef O_QUASIQUOTATIONS
1542 setPrologFlag("quasi_quotations", FT_BOOL, TRUE, PLFLAG_QUASI_QUOTES);
1543 #endif
1544 setPrologFlag("write_attributes", FT_ATOM, "ignore");
1545 setPrologFlag("stream_type_check", FT_ATOM, "loose");
1546 setPrologFlag("occurs_check", FT_ATOM, "false");
1547 setPrologFlag("access_level", FT_ATOM, "user");
1548 setPrologFlag("double_quotes", FT_ATOM,
1549 GD->options.traditional ? "codes" : "string");
1550 setPrologFlag("back_quotes", FT_ATOM,
1551 GD->options.traditional ? "symbol_char" : "codes");
1552 setPrologFlag("portable_vmi", FT_BOOL, TRUE, PLFLAG_PORTABLE_VMI);
1553 setPrologFlag("traditional", FT_BOOL|FF_READONLY, GD->options.traditional, 0);
1554 setPrologFlag("unknown", FT_ATOM, "error");
1555 setPrologFlag("debug", FT_BOOL, FALSE, 0);
1556 setPrologFlag("verbose", FT_ATOM|FF_KEEP, GD->options.silent ? "silent" : "normal");
1557 setPrologFlag("verbose_load", FT_ATOM, "silent");
1558 setPrologFlag("verbose_autoload", FT_BOOL, FALSE, 0);
1559 setPrologFlag("verbose_file_search", FT_BOOL, FALSE, 0);
1560 setPrologFlag("sandboxed_load", FT_BOOL, FALSE, 0);
1561 setPrologFlag("allow_variable_name_as_functor", FT_BOOL, FALSE,
1562 ALLOW_VARNAME_FUNCTOR);
1563 setPrologFlag("allow_dot_in_atom", FT_BOOL, FALSE,
1564 PLFLAG_DOT_IN_ATOM);
1565 setPrologFlag("toplevel_var_size", FT_INTEGER, 1000);
1566 setPrologFlag("toplevel_print_anon", FT_BOOL, TRUE, 0);
1567 setPrologFlag("toplevel_prompt", FT_ATOM, "~m~d~l~! ?- ");
1568 setPrologFlag("file_name_variables", FT_BOOL, FALSE, PLFLAG_FILEVARS);
1569 setPrologFlag("fileerrors", FT_BOOL, TRUE, PLFLAG_FILEERRORS);
1570 #ifdef O_DEBUG
1571 setPrologFlag("prolog_debug", FT_BOOL|FF_READONLY, TRUE, 0);
1572 #endif
1573 #ifdef __EMSCRIPTEN__
1574 setPrologFlag("emscripten", FT_BOOL|FF_READONLY, TRUE, 0);
1575 #else
1576 #ifdef __unix__
1577 setPrologFlag("unix", FT_BOOL|FF_READONLY, TRUE, 0);
1578 #endif
1579 #ifdef __APPLE__
1580 setPrologFlag("apple", FT_BOOL|FF_READONLY, TRUE, 0);
1581 #endif
1582 #ifdef __ANDROID__
1583 setPrologFlag("android", FT_BOOL|FF_READONLY, TRUE, 0);
1584 # ifdef __ANDROID_API__
1585 setPrologFlag("android_api",FT_INTEGER|FF_READONLY, __ANDROID_API__);
1586 # endif
1587 #endif
1588 #endif
1589
1590 setPrologFlag("encoding", FT_ATOM, stringAtom(encoding_to_atom(LD->encoding)));
1591
1592 setPrologFlag("tty_control", FT_BOOL,
1593 truePrologFlag(PLFLAG_TTY_CONTROL), PLFLAG_TTY_CONTROL);
1594 setPrologFlag("signals", FT_BOOL|FF_READONLY,
1595 truePrologFlag(PLFLAG_SIGNALS), PLFLAG_SIGNALS);
1596 setPrologFlag("packs", FT_BOOL, GD->cmdline.packs, 0);
1597
1598 #if defined(__WINDOWS__) && defined(_DEBUG)
1599 setPrologFlag("kernel_compile_mode", FT_ATOM|FF_READONLY, "debug");
1600 #endif
1601
1602 #if defined(BUILD_TIME) && defined(BUILD_DATE)
1603 setPrologFlag("compiled_at", FT_ATOM|FF_READONLY, BUILD_DATE ", " BUILD_TIME);
1604 #elif defined(__DATE__) && defined(__TIME__)
1605 setPrologFlag("compiled_at", FT_ATOM|FF_READONLY, __DATE__ ", " __TIME__);
1606 #endif
1607 setPrologFlag("error_ambiguous_stream_pair", FT_BOOL, FALSE,
1608 PLFLAG_ERROR_AMBIGUOUS_STREAM_PAIR);
1609 #ifdef O_MITIGATE_SPECTRE
1610 setPrologFlag("mitigate_spectre", FT_BOOL, FALSE, PLFLAG_MITIGATE_SPECTRE);
1611 #endif
1612 #ifdef POSIX_SHELL
1613 setPrologFlag("posix_shell", FT_ATOM, POSIX_SHELL);
1614 #endif
1615
1616 setPrologFlag("table_incremental", FT_BOOL, FALSE, PLFLAG_TABLE_INCREMENTAL);
1617 setPrologFlag("table_subsumptive", FT_BOOL, FALSE, 0);
1618 setPrologFlag("table_shared", FT_BOOL, FALSE, PLFLAG_TABLE_SHARED);
1619
1620 setTmpDirPrologFlag();
1621 setTZPrologFlag();
1622 setOSPrologFlags();
1623 setVersionPrologFlag();
1624 setArgvPrologFlag("os_argv", GD->cmdline.os_argc, GD->cmdline.os_argv);
1625 setArgvPrologFlag("argv", GD->cmdline.appl_argc, GD->cmdline.appl_argv);
1626 }
1627
1628
1629 static void
setTmpDirPrologFlag(void)1630 setTmpDirPrologFlag(void)
1631 { char envbuf[MAXPATHLEN];
1632 char *td = NULL;
1633
1634 #ifdef __unix__
1635 td=Getenv("TMP", envbuf, sizeof(envbuf));
1636 #elif __WINDOWS__
1637 td=Getenv("TEMP", envbuf, sizeof(envbuf));
1638 #endif
1639
1640 if (td == (char *) NULL)
1641 td = SWIPL_TMP_DIR;
1642
1643 setPrologFlag("tmp_dir", FT_ATOM, td);
1644 }
1645
1646 static void
setArgvPrologFlag(const char * flag,int argc,char ** argv)1647 setArgvPrologFlag(const char *flag, int argc, char **argv)
1648 { GET_LD
1649 fid_t fid = PL_open_foreign_frame();
1650 term_t e = PL_new_term_ref();
1651 term_t l = PL_new_term_ref();
1652 int n;
1653
1654 PL_put_nil(l);
1655 for(n=argc-1; n>= 0; n--)
1656 { PL_put_variable(e);
1657 if ( !PL_unify_chars(e, PL_ATOM|REP_FN, -1, argv[n]) ||
1658 !PL_cons_list(l, e, l) )
1659 fatalError("Could not set Prolog flag argv: not enough stack");
1660 }
1661
1662 setPrologFlag(flag, FT_TERM, l);
1663 PL_discard_foreign_frame(fid);
1664 }
1665
1666
1667 static void
setTZPrologFlag(void)1668 setTZPrologFlag(void)
1669 { tzset();
1670
1671 #ifdef _MSC_VER
1672 #define timezone _timezone
1673 #endif
1674
1675 setPrologFlag("timezone", FT_INTEGER|FF_READONLY, timezone);
1676 }
1677
1678
1679 static void
setVersionPrologFlag(void)1680 setVersionPrologFlag(void)
1681 { GET_LD
1682 fid_t fid = PL_open_foreign_frame();
1683 term_t t = PL_new_term_ref();
1684 term_t o = PL_new_term_ref();
1685 int major = PLVERSION/10000;
1686 int minor = (PLVERSION/100)%100;
1687 int patch = (PLVERSION%100);
1688
1689 PL_put_nil(o);
1690
1691 #ifdef PLVERSION_TAG
1692 { const char *tag = PLVERSION_TAG;
1693 if ( tag && *tag )
1694 { int rc;
1695 term_t tt;
1696
1697 rc = ( (tt=PL_new_term_ref()) &&
1698 PL_put_atom_chars(tt, tag) &&
1699 PL_cons_functor(tt, FUNCTOR_tag1, tt) &&
1700 PL_cons_functor(o, FUNCTOR_dot2, tt, o) );
1701 (void)rc;
1702 }
1703 }
1704 #endif
1705
1706 if ( !PL_unify_term(t,
1707 PL_FUNCTOR_CHARS, PLNAME, 4,
1708 PL_INT, major,
1709 PL_INT, minor,
1710 PL_INT, patch,
1711 PL_TERM, o) )
1712 sysError("Could not set version");
1713
1714 setPrologFlag("version_data", FF_READONLY|FT_TERM, t);
1715 PL_discard_foreign_frame(fid);
1716
1717 setGITVersion();
1718 }
1719
1720 static int
abi_version_dict(term_t dict)1721 abi_version_dict(term_t dict)
1722 { GET_LD
1723 const atom_t keys[] = { ATOM_foreign_interface,
1724 ATOM_record,
1725 ATOM_qlf,
1726 ATOM_qlf_min_load,
1727 ATOM_vmi,
1728 ATOM_built_in };
1729 term_t values = PL_new_term_refs(6);
1730
1731 return ( PL_unify_integer(values+0, PL_version(PL_VERSION_FLI)) &&
1732 PL_unify_integer(values+1, PL_version(PL_VERSION_REC)) &&
1733 PL_unify_integer(values+2, PL_version(PL_VERSION_QLF)) &&
1734 PL_unify_integer(values+3, PL_version(PL_VERSION_QLF_LOAD)) &&
1735 PL_unify_integer(values+4, PL_version(PL_VERSION_VM)) &&
1736 PL_unify_integer(values+5, PL_version(PL_VERSION_BUILT_IN)) &&
1737
1738 PL_put_dict(dict, ATOM_abi, 6, keys, values) );
1739 }
1740
1741
1742 void
setABIVersionPrologFlag(void)1743 setABIVersionPrologFlag(void)
1744 { GET_LD
1745 fid_t fid = PL_open_foreign_frame();
1746 term_t t = PL_new_term_ref();
1747
1748 if ( abi_version_dict(t) )
1749 setPrologFlag("abi_version", FF_READONLY|FT_TERM, t);
1750
1751 PL_discard_foreign_frame(fid);
1752 }
1753
1754
1755 void
cleanupPrologFlags(void)1756 cleanupPrologFlags(void)
1757 { if ( GD->prolog_flag.table )
1758 { Table t = GD->prolog_flag.table;
1759
1760 GD->prolog_flag.table = NULL;
1761 #ifdef O_PLMT
1762 t->free_symbol = freeSymbolPrologFlagTable;
1763 #else
1764 t->free_symbol = NULL;
1765 #endif
1766 destroyHTable(t);
1767 }
1768 }
1769
1770
1771
1772 /*******************************
1773 * PUBLISH PREDICATES *
1774 *******************************/
1775
1776 BeginPredDefs(prologflag)
1777 PRED_DEF("set_prolog_flag", 2, set_prolog_flag, PL_FA_ISO)
1778 PRED_DEF("create_prolog_flag", 3, create_prolog_flag, 0)
1779 EndPredDefs
1780