1 /*************************************************************************
2 * *
3 * YAP Prolog *
4 * *
5 * Yap Prolog was developed at NCCUP - Universidade do Porto *
6 * *
7 * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
8 * *
9 **************************************************************************
10 * *
11 * File: sysbits.c *
12 * Last rev: 4/03/88 *
13 * mods: *
14 * comments: very much machine dependent routines *
15 * *
16 *************************************************************************/
17 #ifdef SCCS
18 static char SccsId[] = "%W% %G%";
19 #endif
20
21 /*
22 * In this routine we shall try to include the inevitably machine dependant
23 * routines. These include, for the moment : Time, A rudimentary form of
24 * signal handling, OS calls,
25 *
26 * Vitor Santos Costa, February 1987
27 *
28 */
29
30 /* windows.h does not like absmi.h, this
31 should fix it for now */
32 #include "absmi.h"
33 #include "yapio.h"
34 #include "alloc.h"
35 #include <math.h>
36 #if STDC_HEADERS
37 #include <stdlib.h>
38 #endif
39 #if HAVE_WINDOWS_H
40 #include <windows.h>
41 #endif
42 #if HAVE_SYS_TIME_H && !_MSC_VER
43 #include <sys/time.h>
44 #endif
45 #if HAVE_UNISTD_H
46 #include <unistd.h>
47 #endif
48 #if HAVE_SYS_WAIT_H && !defined(__MINGW32__) && !_MSC_VER
49 #include <sys/wait.h>
50 #endif
51 #if HAVE_STRING_H
52 #include <string.h>
53 #endif
54 #if !HAVE_STRNCAT
55 #define strncat(X,Y,Z) strcat(X,Y)
56 #endif
57 #if !HAVE_STRNCPY
58 #define strncpy(X,Y,Z) strcpy(X,Y)
59 #endif
60 #if HAVE_GETPWNAM
61 #include <pwd.h>
62 #endif
63 #if HAVE_SYS_STAT_H
64 #include <sys/stat.h>
65 #endif
66 #if HAVE_SYS_TYPES_H
67 #include <sys/types.h>
68 #endif
69 #if HAVE_FCNTL_H
70 #include <fcntl.h>
71 #endif
72 #if _MSC_VER || defined(__MINGW32__)
73 #include <windows.h>
74 /* required for DLL compatibility */
75 #if HAVE_DIRECT_H
76 #include <direct.h>
77 #endif
78 #include <io.h>
79 #else
80 #if HAVE_SYS_PARAM_H
81 #include <sys/param.h>
82 #endif
83 #endif
84 #if HAVE_FENV_H && !defined(__CYGWIN__) /* cygwin does not define FENV_H */
85 #include <fenv.h>
86 #endif
87 #if HAVE_READLINE_READLINE_H
88 #include <readline/readline.h>
89 #endif
90
91 STATIC_PROTO (void InitPageSize, (void));
92 STATIC_PROTO (void InitTime, (void));
93 STATIC_PROTO (void InitWTime, (void));
94 STATIC_PROTO (Int p_sh, (void));
95 STATIC_PROTO (Int p_shell, (void));
96 STATIC_PROTO (Int p_system, (void));
97 STATIC_PROTO (Int p_mv, (void));
98 STATIC_PROTO (Int p_cd, (void));
99 STATIC_PROTO (Int p_getcwd, (void));
100 STATIC_PROTO (Int p_dir_sp, (void));
101 STATIC_PROTO (void InitRandom, (void));
102 STATIC_PROTO (Int p_srandom, (void));
103 STATIC_PROTO (Int p_alarm, (void));
104 STATIC_PROTO (Int p_getenv, (void));
105 STATIC_PROTO (Int p_putenv, (void));
106 STATIC_PROTO (void set_fpu_exceptions, (int));
107 #ifdef MACYAP
108 STATIC_PROTO (int chdir, (char *));
109 /* #define signal skel_signal */
110 #endif /* MACYAP */
111
112 #if __simplescalar__
113 char yap_pwd[YAP_FILENAME_MAX];
114 #endif
115
116 STD_PROTO (void exit, (int));
117
118 #ifdef _WIN32
119 void
Yap_WinError(char * yap_error)120 Yap_WinError(char *yap_error)
121 {
122 char msg[256];
123 /* Error, we could not read time */
124 FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
125 NULL, GetLastError(),
126 MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), msg, 256,
127 NULL);
128 Yap_Error(OPERATING_SYSTEM_ERROR, TermNil, "%s at %s", msg, yap_error);
129 }
130 #endif /* _WIN32 */
131
132
133 #define is_valid_env_char(C) ( ((C) >= 'a' && (C) <= 'z') || ((C) >= 'A' && \
134 (C) <= 'Z') || (C) == '_' )
135
136
137 static int
is_directory(char * FileName)138 is_directory(char *FileName)
139 {
140 #ifdef _WIN32
141 DWORD dwAtts = GetFileAttributes(FileName);
142 if (dwAtts == INVALID_FILE_ATTRIBUTES)
143 return FALSE;
144 return (dwAtts & FILE_ATTRIBUTE_DIRECTORY);
145 #elif HAVE_LSTAT
146 struct stat buf;
147
148 if (lstat(FileName, &buf) == -1) {
149 /* return an error number */
150 return FALSE;
151 }
152 return S_ISDIR(buf.st_mode);
153 #else
154 return FALSE;
155 #endif
156 }
157
158 static int
dir_separator(int ch)159 dir_separator (int ch)
160 {
161 #ifdef MAC
162 return (ch == ':');
163 #elif ATARI || _MSC_VER
164 return (ch == '\\');
165 #elif defined(__MINGW32__) || defined(__CYGWIN__)
166 return (ch == '\\' || ch == '/');
167 #else
168 return (ch == '/');
169 #endif
170 }
171
172 int
Yap_dir_separator(int ch)173 Yap_dir_separator (int ch)
174 {
175 return dir_separator (ch);
176 }
177
178 #if _MSC_VER || defined(__MINGW32__)
179 #include <psapi.h>
180
181 char *libdir = NULL;
182 #endif
183
184 void
Yap_InitSysPath(void)185 Yap_InitSysPath(void) {
186 int len;
187 #if _MSC_VER || defined(__MINGW32__)
188 int dir_done = FALSE;
189 int commons_done = FALSE;
190 {
191 char *dir;
192 if ((dir = Yap_RegistryGetString("library"))) {
193 Yap_PutValue(AtomSystemLibraryDir,
194 MkAtomTerm(Yap_LookupAtom(dir)));
195 dir_done = TRUE;
196 }
197 if ((dir = Yap_RegistryGetString("prolog_commons"))) {
198 Yap_PutValue(AtomPrologCommonsDir,
199 MkAtomTerm(Yap_LookupAtom(dir)));
200 commons_done = TRUE;
201 }
202 }
203 if (dir_done && commons_done)
204 return;
205 #endif
206 strncpy(Yap_FileNameBuf, YAP_SHAREDIR, YAP_FILENAME_MAX);
207 #if _MSC_VER || defined(__MINGW32__)
208 {
209 DWORD fatts;
210 int buflen;
211 char *pt;
212
213 if ((fatts = GetFileAttributes(Yap_FileNameBuf)) == 0xFFFFFFFFL ||
214 !(fatts & FILE_ATTRIBUTE_DIRECTORY)) {
215 /* couldn't find it where it was supposed to be,
216 let's try using the executable */
217 if (!GetModuleFileNameEx( GetCurrentProcess(), NULL, Yap_FileNameBuf, YAP_FILENAME_MAX)) {
218 Yap_Error(OPERATING_SYSTEM_ERROR, TermNil, "could not find executable name");
219 /* do nothing */
220 return;
221 }
222 buflen = strlen(Yap_FileNameBuf);
223 pt = Yap_FileNameBuf+strlen(Yap_FileNameBuf);
224 while (*--pt != '\\') {
225 /* skip executable */
226 if (pt == Yap_FileNameBuf) {
227 Yap_Error(OPERATING_SYSTEM_ERROR, TermNil, "could not find executable name");
228 /* do nothing */
229 return;
230 }
231 }
232 while (*--pt != '\\') {
233 /* skip parent directory "bin\\" */
234 if (pt == Yap_FileNameBuf) {
235 Yap_Error(OPERATING_SYSTEM_ERROR, TermNil, "could not find executable name");
236 /* do nothing */
237 }
238 }
239 /* now, this is a possible location for the ROOT_DIR, let's look for a share directory here */
240 pt[1] = '\0';
241 /* grosse */
242 strncat(Yap_FileNameBuf,"lib\\Yap",YAP_FILENAME_MAX);
243 libdir = Yap_AllocCodeSpace(strlen(Yap_FileNameBuf)+1);
244 strncpy(libdir, Yap_FileNameBuf, strlen(Yap_FileNameBuf)+1);
245 pt[1] = '\0';
246 strncat(Yap_FileNameBuf,"share",YAP_FILENAME_MAX);
247 }
248 }
249 strncat(Yap_FileNameBuf,"\\", YAP_FILENAME_MAX);
250 #else
251 strncat(Yap_FileNameBuf,"/", YAP_FILENAME_MAX);
252 #endif
253 len = strlen(Yap_FileNameBuf);
254 strncat(Yap_FileNameBuf, "Yap", YAP_FILENAME_MAX);
255 #if _MSC_VER || defined(__MINGW32__)
256 if (!dir_done)
257 #endif
258 {
259 Yap_PutValue(AtomSystemLibraryDir,
260 MkAtomTerm(Yap_LookupAtom(Yap_FileNameBuf)));
261 }
262 #if _MSC_VER || defined(__MINGW32__)
263 if (!commons_done)
264 #endif
265 {
266 Yap_FileNameBuf[len] = '\0';
267 strncat(Yap_FileNameBuf, "PrologCommons", YAP_FILENAME_MAX);
268 Yap_PutValue(AtomPrologCommonsDir,
269 MkAtomTerm(Yap_LookupAtom(Yap_FileNameBuf)));
270 }
271 }
272
273 static Int
p_dir_sp(void)274 p_dir_sp (void)
275 {
276 #ifdef MAC
277 Term t = MkIntTerm(':');
278 #elif ATARI || _MSC_VER || defined(__MINGW32__)
279 Term t = MkIntTerm('\\');
280 #else
281 Term t = MkIntTerm('/');
282 #endif
283
284 return(Yap_unify_constant(ARG1,t));
285 }
286
287
288 static void
InitPageSize(void)289 InitPageSize(void)
290 {
291 #ifdef _WIN32
292 SYSTEM_INFO si;
293 GetSystemInfo(&si);
294 Yap_page_size = si.dwPageSize;
295 #elif HAVE_UNISTD_H
296 #if defined(__FreeBSD__) || defined(__DragonFly__)
297 Yap_page_size = getpagesize();
298 #elif defined(_AIX)
299 Yap_page_size = sysconf(_SC_PAGE_SIZE);
300 #elif !defined(_SC_PAGESIZE)
301 Yap_page_size = getpagesize();
302 #else
303 Yap_page_size = sysconf(_SC_PAGESIZE);
304 #endif
305 #else
306 bla bla
307 #endif
308 }
309
310 #ifdef SIMICS
311 #ifdef HAVE_GETRUSAGE
312 #undef HAVE_GETRUSAGE
313 #endif
314 #ifdef HAVE_TIMES
315 #undef HAVE_TIMES
316 #endif
317 #endif /* SIMICS */
318
319 #ifdef _WIN32
320 #if HAVE_GETRUSAGE
321 #undef HAVE_GETRUSAGE
322 #endif
323 #endif
324
325 #if HAVE_GETRUSAGE
326
327 #if HAVE_SYS_TIMES_H
328 #include <sys/times.h>
329 #endif
330 #if HAVE_SYS_RESOURCE_H
331 #include <sys/resource.h>
332 #endif
333
334 #if THREADS
335 #define StartOfTimes (*(MY_ThreadHandle.start_of_timesp))
336 #define last_time (*(MY_ThreadHandle.last_timep))
337
338 #else
339 /* since the point YAP was started */
340 static struct timeval StartOfTimes;
341
342 /* since last call to runtime */
343 static struct timeval last_time;
344 #endif
345 static struct timeval last_time_sys;
346 static struct timeval StartOfTimes_sys;
347
348 /* store user time in this variable */
349 static void
InitTime(void)350 InitTime (void)
351 {
352 struct rusage rusage;
353
354 #if THREADS
355 MY_ThreadHandle.start_of_timesp = (struct timeval *)malloc(sizeof(struct timeval));
356 MY_ThreadHandle.last_timep = (struct timeval *)malloc(sizeof(struct timeval));
357 #endif
358 getrusage(RUSAGE_SELF, &rusage);
359 last_time.tv_sec = StartOfTimes.tv_sec = rusage.ru_utime.tv_sec;
360 last_time.tv_usec = StartOfTimes.tv_usec = rusage.ru_utime.tv_usec;
361 last_time_sys.tv_sec = StartOfTimes_sys.tv_sec = rusage.ru_stime.tv_sec;
362 last_time_sys.tv_usec = StartOfTimes_sys.tv_usec = rusage.ru_stime.tv_usec;
363 }
364
365
366 UInt
Yap_cputime(void)367 Yap_cputime (void)
368 {
369 struct rusage rusage;
370
371 getrusage(RUSAGE_SELF, &rusage);
372 return((rusage.ru_utime.tv_sec - StartOfTimes.tv_sec)) * 1000 +
373 ((rusage.ru_utime.tv_usec - StartOfTimes.tv_usec) / 1000);
374 }
375
Yap_cputime_interval(Int * now,Int * interval)376 void Yap_cputime_interval(Int *now,Int *interval)
377 {
378 struct rusage rusage;
379
380 getrusage(RUSAGE_SELF, &rusage);
381 *now = (rusage.ru_utime.tv_sec - StartOfTimes.tv_sec) * 1000 +
382 (rusage.ru_utime.tv_usec - StartOfTimes.tv_usec) / 1000;
383 *interval = (rusage.ru_utime.tv_sec - last_time.tv_sec) * 1000 +
384 (rusage.ru_utime.tv_usec - last_time.tv_usec) / 1000;
385 last_time.tv_usec = rusage.ru_utime.tv_usec;
386 last_time.tv_sec = rusage.ru_utime.tv_sec;
387 }
388
Yap_systime_interval(Int * now,Int * interval)389 void Yap_systime_interval(Int *now,Int *interval)
390 {
391 struct rusage rusage;
392
393 getrusage(RUSAGE_SELF, &rusage);
394 *now = (rusage.ru_stime.tv_sec - StartOfTimes_sys.tv_sec) * 1000 +
395 (rusage.ru_stime.tv_usec - StartOfTimes_sys.tv_usec) / 1000;
396 *interval = (rusage.ru_stime.tv_sec - last_time_sys.tv_sec) * 1000 +
397 (rusage.ru_stime.tv_usec - last_time_sys.tv_usec) / 1000;
398 last_time_sys.tv_usec = rusage.ru_stime.tv_usec;
399 last_time_sys.tv_sec = rusage.ru_stime.tv_sec;
400 }
401
402 #elif defined(_WIN32)
403
404 #ifdef __GNUC__
405
406 /* This is stolen from the Linux kernel.
407 The problem is that mingw32 does not seem to have acces to div */
408 #ifndef do_div
409 #define do_div(n,base) ({ \
410 unsigned long __upper, __low, __high, __mod; \
411 asm("":"=a" (__low), "=d" (__high):"A" (n)); \
412 __upper = __high; \
413 if (__high) { \
414 __upper = __high % (base); \
415 __high = __high / (base); \
416 } \
417 asm("divl %2":"=a" (__low), "=d" (__mod):"rm" (base), "0" (__low), "1" (__upper)); \
418 asm("":"=A" (n):"a" (__low),"d" (__high)); \
419 __mod; \
420 })
421 #endif
422
423 #endif
424
425
426
427 #include <time.h>
428
429 static FILETIME StartOfTimes, last_time;
430
431 static FILETIME StartOfTimes_sys, last_time_sys;
432
433 static clock_t TimesStartOfTimes, Times_last_time;
434
435 /* store user time in this variable */
436 static void
InitTime(void)437 InitTime (void)
438 {
439 HANDLE hProcess = GetCurrentProcess();
440 FILETIME CreationTime, ExitTime, KernelTime, UserTime;
441 if (!GetProcessTimes(hProcess, &CreationTime, &ExitTime, &KernelTime, &UserTime)) {
442 /* WIN98 */
443 clock_t t;
444 t = clock ();
445 Times_last_time = TimesStartOfTimes = t;
446 } else {
447 last_time.dwLowDateTime = UserTime.dwLowDateTime;
448 last_time.dwHighDateTime = UserTime.dwHighDateTime;
449 StartOfTimes.dwLowDateTime = UserTime.dwLowDateTime;
450 StartOfTimes.dwHighDateTime = UserTime.dwHighDateTime;
451 last_time_sys.dwLowDateTime = KernelTime.dwLowDateTime;
452 last_time_sys.dwHighDateTime = KernelTime.dwHighDateTime;
453 StartOfTimes_sys.dwLowDateTime = KernelTime.dwLowDateTime;
454 StartOfTimes_sys.dwHighDateTime = KernelTime.dwHighDateTime;
455 }
456 }
457
458 #ifdef __GNUC__
459 static unsigned long long int
sub_utime(FILETIME t1,FILETIME t2)460 sub_utime(FILETIME t1, FILETIME t2)
461 {
462 ULARGE_INTEGER u[2];
463 memcpy((void *)u,(void *)&t1,sizeof(FILETIME));
464 memcpy((void *)(u+1),(void *)&t2,sizeof(FILETIME));
465 return
466 u[0].QuadPart - u[1].QuadPart;
467 }
468 #endif
469
470 UInt
Yap_cputime(void)471 Yap_cputime (void)
472 {
473 HANDLE hProcess = GetCurrentProcess();
474 FILETIME CreationTime, ExitTime, KernelTime, UserTime;
475 if (!GetProcessTimes(hProcess, &CreationTime, &ExitTime, &KernelTime, &UserTime)) {
476 clock_t t;
477 t = clock ();
478 return(((t - TimesStartOfTimes)*1000) / CLOCKS_PER_SEC);
479 } else {
480 #ifdef __GNUC__
481 unsigned long long int t =
482 sub_utime(UserTime,StartOfTimes);
483 do_div(t,10000);
484 return((Int)t);
485 #endif
486 #ifdef _MSC_VER
487 __int64 t = *(__int64 *)&UserTime - *(__int64 *)&StartOfTimes;
488 return((Int)(t/10000));
489 #endif
490 }
491 }
492
Yap_cputime_interval(Int * now,Int * interval)493 void Yap_cputime_interval(Int *now,Int *interval)
494 {
495 HANDLE hProcess = GetCurrentProcess();
496 FILETIME CreationTime, ExitTime, KernelTime, UserTime;
497 if (!GetProcessTimes(hProcess, &CreationTime, &ExitTime, &KernelTime, &UserTime)) {
498 clock_t t;
499 t = clock ();
500 *now = ((t - TimesStartOfTimes)*1000) / CLOCKS_PER_SEC;
501 *interval = (t - Times_last_time) * 1000 / CLOCKS_PER_SEC;
502 Times_last_time = t;
503 } else {
504 #ifdef __GNUC__
505 unsigned long long int t1 =
506 sub_utime(UserTime, StartOfTimes);
507 unsigned long long int t2 =
508 sub_utime(UserTime, last_time);
509 do_div(t1,10000);
510 *now = (Int)t1;
511 do_div(t2,10000);
512 *interval = (Int)t2;
513 #endif
514 #ifdef _MSC_VER
515 __int64 t1 = *(__int64 *)&UserTime - *(__int64 *)&StartOfTimes;
516 __int64 t2 = *(__int64 *)&UserTime - *(__int64 *)&last_time;
517 *now = (Int)(t1/10000);
518 *interval = (Int)(t2/10000);
519 #endif
520 last_time.dwLowDateTime = UserTime.dwLowDateTime;
521 last_time.dwHighDateTime = UserTime.dwHighDateTime;
522 }
523 }
524
Yap_systime_interval(Int * now,Int * interval)525 void Yap_systime_interval(Int *now,Int *interval)
526 {
527 HANDLE hProcess = GetCurrentProcess();
528 FILETIME CreationTime, ExitTime, KernelTime, UserTime;
529 if (!GetProcessTimes(hProcess, &CreationTime, &ExitTime, &KernelTime, &UserTime)) {
530 *now = *interval = 0; /* not available */
531 } else {
532 #ifdef __GNUC__
533 unsigned long long int t1 =
534 sub_utime(KernelTime, StartOfTimes_sys);
535 unsigned long long int t2 =
536 sub_utime(KernelTime, last_time_sys);
537 do_div(t1,10000);
538 *now = (Int)t1;
539 do_div(t2,10000);
540 *interval = (Int)t2;
541 #endif
542 #ifdef _MSC_VER
543 __int64 t1 = *(__int64 *)&KernelTime - *(__int64 *)&StartOfTimes_sys;
544 __int64 t2 = *(__int64 *)&KernelTime - *(__int64 *)&last_time_sys;
545 *now = (Int)(t1/10000);
546 *interval = (Int)(t2/10000);
547 #endif
548 last_time_sys.dwLowDateTime = KernelTime.dwLowDateTime;
549 last_time_sys.dwHighDateTime = KernelTime.dwHighDateTime;
550 }
551 }
552
553 #elif HAVE_TIMES
554
555 #if defined(_WIN32)
556
557 #include <time.h>
558
559 #define TicksPerSec CLOCKS_PER_SEC
560
561 #else
562
563 #if HAVE_SYS_TIMES_H
564 #include <sys/times.h>
565 #endif
566
567 #endif
568
569 #if defined(__sun__) && (defined(__svr4__) || defined(__SVR4))
570
571 #if HAVE_LIMITS_H
572 #include <limits.h>
573 #endif
574
575 #define TicksPerSec CLK_TCK
576 #endif
577
578 #if defined(__alpha) || defined(__FreeBSD__) || defined(__linux__) || defined(__DragonFly__)
579
580 #if HAVE_TIME_H
581 #include <time.h>
582 #endif
583
584 #define TicksPerSec sysconf(_SC_CLK_TCK)
585
586 #endif
587
588 #if !TMS_IN_SYS_TIME
589 #if HAVE_SYS_TIMES_H
590 #include <sys/times.h>
591 #endif
592 #endif
593
594 static clock_t StartOfTimes, last_time;
595
596 static clock_t StartOfTimes_sys, last_time_sys;
597
598 /* store user time in this variable */
599 static void
InitTime(void)600 InitTime (void)
601 {
602 struct tms t;
603 times (&t);
604 last_time = StartOfTimes = t.tms_utime;
605 last_time_sys = StartOfTimes_sys = t.tms_stime;
606 }
607
608 UInt
Yap_cputime(void)609 Yap_cputime (void)
610 {
611 struct tms t;
612 times(&t);
613 return((t.tms_utime - StartOfTimes)*1000 / TicksPerSec);
614 }
615
Yap_cputime_interval(Int * now,Int * interval)616 void Yap_cputime_interval(Int *now,Int *interval)
617 {
618 struct tms t;
619 times (&t);
620 *now = ((t.tms_utime - StartOfTimes)*1000) / TicksPerSec;
621 *interval = (t.tms_utime - last_time) * 1000 / TicksPerSec;
622 last_time = t.tms_utime;
623 }
624
Yap_systime_interval(Int * now,Int * interval)625 void Yap_systime_interval(Int *now,Int *interval)
626 {
627 struct tms t;
628 times (&t);
629 *now = ((t.tms_stime - StartOfTimes_sys)*1000) / TicksPerSec;
630 *interval = (t.tms_stime - last_time_sys) * 1000 / TicksPerSec;
631 last_time_sys = t.tms_stime;
632 }
633
634 #else /* HAVE_TIMES */
635
636 #ifdef SIMICS
637
638 #include <sys/time.h>
639
640 /* since the point YAP was started */
641 static struct timeval StartOfTimes;
642
643 /* since last call to runtime */
644 static struct timeval last_time;
645
646 /* store user time in this variable */
647 static void
InitTime(void)648 InitTime (void)
649 {
650 struct timeval tp;
651
652 gettimeofday(&tp,NULL);
653 last_time.tv_sec = StartOfTimes.tv_sec = tp.tv_sec;
654 last_time.tv_usec = StartOfTimes.tv_usec = tp.tv_usec;
655 }
656
657
658 UInt
Yap_cputime(void)659 Yap_cputime (void)
660 {
661 struct timeval tp;
662
663 gettimeofday(&tp,NULL);
664 if (StartOfTimes.tv_usec > tp.tv_usec)
665 return((tp.tv_sec - StartOfTimes.tv_sec - 1) * 1000 +
666 (StartOfTimes.tv_usec - tp.tv_usec) /1000);
667 else
668 return((tp.tv_sec - StartOfTimes.tv_sec)) * 1000 +
669 ((tp.tv_usec - StartOfTimes.tv_usec) / 1000);
670 }
671
Yap_cputime_interval(Int * now,Int * interval)672 void Yap_cputime_interval(Int *now,Int *interval)
673 {
674 struct timeval tp;
675
676 gettimeofday(&tp,NULL);
677 *now = (tp.tv_sec - StartOfTimes.tv_sec) * 1000 +
678 (tp.tv_usec - StartOfTimes.tv_usec) / 1000;
679 *interval = (tp.tv_sec - last_time.tv_sec) * 1000 +
680 (tp.tv_usec - last_time.tv_usec) / 1000;
681 last_time.tv_usec = tp.tv_usec;
682 last_time.tv_sec = tp.tv_sec;
683 }
684
Yap_systime_interval(Int * now,Int * interval)685 void Yap_systime_interval(Int *now,Int *interval)
686 {
687 *now = *interval = 0; /* not available */
688 }
689
690 #endif /* SIMICS */
691
692 #ifdef COMMENTED_OUT
693 /* This code is not working properly. I left it here to help future ports */
694 #ifdef MPW
695
696 #include <files.h>
697 #include <Events.h>
698
699 #define TicksPerSec 60.0
700
701 static double
real_cputime()702 real_cputime ()
703 {
704 return (((double) TickCount ()) / TicksPerSec);
705 }
706
707 #endif /* MPW */
708
709 #ifdef LATTICE
710
711 #include "osbind.h"
712
713 static long *ptime;
714
gettime()715 gettime ()
716 {
717 *ptime = *(long *) 0x462;
718 }
719
720 static double
real_cputime()721 real_cputime ()
722 {
723 long thetime;
724 ptime = &thetime;
725 xbios (38, gettime);
726 return (((double) thetime) / (Getrez () == 2 ? 70 : 60));
727 }
728
729 #endif /* LATTICE */
730
731 #ifdef M_WILLIAMS
732
733 #include <osbind.h>
734 #include <xbios.h>
735
736 static long *ptime;
737
738 static long
readtime()739 readtime ()
740 {
741 return (*((long *) 0x4ba));
742 }
743
744 static double
real_cputime()745 real_cputime ()
746 {
747 long time;
748
749 time = Supexec (readtime);
750 return (time / 200.0);
751 }
752
753 #endif /* M_WILLIAMS */
754
755 #ifdef LIGHT
756
757 #undef FALSE
758 #undef TRUE
759
760 #include <FileMgr.h>
761
762 #define TicksPerSec 60.0
763
764 static double
real_cputime()765 real_cputime ()
766 {
767 return (((double) TickCount ()) / TicksPerSec);
768 }
769
770 #endif /* LIGHT */
771
772 #endif /* COMMENTED_OUT */
773
774 #endif /* HAVE_GETRUSAGE */
775
776 #if HAVE_GETHRTIME
777
778 #if HAVE_TIME_H
779 #include <time.h>
780 #endif
781
782 /* since the point YAP was started */
783 static hrtime_t StartOfWTimes;
784
785 /* since last call to walltime */
786 #define LastWtime (*(hrtime_t *)ALIGN_YAPTYPE(LastWtimePtr,hrtime_t))
787
788 static void
InitWTime(void)789 InitWTime (void)
790 {
791 StartOfWTimes = gethrtime();
792 }
793
794 static void
InitLastWtime(void)795 InitLastWtime(void) {
796 /* ask for twice the space in order to guarantee alignment */
797 LastWtimePtr = (void *)Yap_AllocCodeSpace(2*sizeof(hrtime_t));
798 LastWtime = StartOfWTimes;
799 }
800
801 Int
Yap_walltime(void)802 Yap_walltime (void)
803 {
804 hrtime_t tp = gethrtime();
805 /* return time in milliseconds */
806 return((Int)((tp-StartOfWTimes)/((hrtime_t)1000000)));
807
808 }
809
Yap_walltime_interval(Int * now,Int * interval)810 void Yap_walltime_interval(Int *now,Int *interval)
811 {
812 hrtime_t tp = gethrtime();
813 /* return time in milliseconds */
814 *now = (Int)((tp-StartOfWTimes)/((hrtime_t)1000000));
815 *interval = (Int)((tp-LastWtime)/((hrtime_t)1000000));
816 LastWtime = tp;
817 }
818
819
820 #elif HAVE_GETTIMEOFDAY
821
822 /* since the point YAP was started */
823 static struct timeval StartOfWTimes;
824
825 /* since last call to walltime */
826 #define LastWtime (*(struct timeval *)LastWtimePtr)
827
828 /* store user time in this variable */
829 static void
InitWTime(void)830 InitWTime (void)
831 {
832 gettimeofday(&StartOfWTimes,NULL);
833 }
834
835 static void
InitLastWtime(void)836 InitLastWtime(void) {
837 LastWtimePtr = (void *)Yap_AllocCodeSpace(sizeof(struct timeval));
838 LastWtime.tv_usec = StartOfWTimes.tv_usec;
839 LastWtime.tv_sec = StartOfWTimes.tv_sec;
840 }
841
842
843 Int
Yap_walltime(void)844 Yap_walltime (void)
845 {
846 struct timeval tp;
847
848 gettimeofday(&tp,NULL);
849 if (StartOfWTimes.tv_usec > tp.tv_usec)
850 return((tp.tv_sec - StartOfWTimes.tv_sec - 1) * 1000 +
851 (StartOfWTimes.tv_usec - tp.tv_usec) /1000);
852 else
853 return((tp.tv_sec - StartOfWTimes.tv_sec)) * 1000 +
854 ((tp.tv_usec - LastWtime.tv_usec) / 1000);
855 }
856
Yap_walltime_interval(Int * now,Int * interval)857 void Yap_walltime_interval(Int *now,Int *interval)
858 {
859 struct timeval tp;
860
861 gettimeofday(&tp,NULL);
862 *now = (tp.tv_sec - StartOfWTimes.tv_sec) * 1000 +
863 (tp.tv_usec - StartOfWTimes.tv_usec) / 1000;
864 *interval = (tp.tv_sec - LastWtime.tv_sec) * 1000 +
865 (tp.tv_usec - LastWtime.tv_usec) / 1000;
866 LastWtime.tv_usec = tp.tv_usec;
867 LastWtime.tv_sec = tp.tv_sec;
868 }
869
870 #elif defined(_WIN32)
871
872 #include <sys/timeb.h>
873 #include <time.h>
874
875 /* since the point YAP was started */
876 static struct _timeb StartOfWTimes;
877
878 /* since last call to walltime */
879 #define LastWtime (*(struct timeb *)LastWtimePtr)
880
881 /* store user time in this variable */
882 static void
InitWTime(void)883 InitWTime (void)
884 {
885 _ftime(&StartOfWTimes);
886 }
887
888 static void
InitLastWtime(void)889 InitLastWtime(void) {
890 LastWtimePtr = (void *)Yap_AllocCodeSpace(sizeof(struct timeb));
891 LastWtime.time = StartOfWTimes.time;
892 LastWtime.millitm = StartOfWTimes.millitm;
893 }
894
895
896 Int
Yap_walltime(void)897 Yap_walltime (void)
898 {
899 struct _timeb tp;
900
901 _ftime(&tp);
902 if (StartOfWTimes.millitm > tp.millitm)
903 return((tp.time - StartOfWTimes.time - 1) * 1000 +
904 (StartOfWTimes.millitm - tp.millitm));
905 else
906 return((tp.time - StartOfWTimes.time)) * 1000 +
907 ((tp.millitm - LastWtime.millitm) / 1000);
908 }
909
Yap_walltime_interval(Int * now,Int * interval)910 void Yap_walltime_interval(Int *now,Int *interval)
911 {
912 struct _timeb tp;
913
914 _ftime(&tp);
915 *now = (tp.time - StartOfWTimes.time) * 1000 +
916 (tp.millitm - StartOfWTimes.millitm);
917 *interval = (tp.time - LastWtime.time) * 1000 +
918 (tp.millitm - LastWtime.millitm) ;
919 LastWtime.millitm = tp.millitm;
920 LastWtime.time = tp.time;
921 }
922
923 #elif HAVE_TIMES
924
925 static clock_t StartOfWTimes;
926
927 #define LastWtime (*(clock_t *)LastWtimePtr)
928
929 /* store user time in this variable */
930 static void
InitWTime(void)931 InitWTime (void)
932 {
933 StartOfWTimes = times(NULL);
934 }
935
936 static void
InitLastWtime(void)937 InitLastWtime(void) {
938 LastWtimePtr = (void *)Yap_AllocCodeSpace(sizeof(clock_t));
939 LastWtime = StartOfWTimes;
940 }
941
942 Int
Yap_walltime(void)943 Yap_walltime (void)
944 {
945 clock_t t;
946 t = times(NULL);
947 return ((t - StartOfWTimes)*1000 / TicksPerSec));
948 }
949
950 void Yap_walltime_interval(Int *now,Int *interval)
951 {
952 clock_t t;
953 t = times(NULL);
954 *now = ((t - StartOfWTimes)*1000) / TicksPerSec;
955 *interval = (t - LastWtime) * 1000 / TicksPerSec;
956 }
957
958 #endif /* HAVE_TIMES */
959
960 #if HAVE_TIME_H
961 #include <time.h>
962 #endif
963
964 unsigned int current_seed;
965
966 static void
967 InitRandom (void)
968 {
969 current_seed = (unsigned int) time (NULL);
970 #if HAVE_RANDOM
971 srandom (current_seed);
972 #elif HAVE_RAND
973 srand (current_seed);
974 #endif
975 }
976
977 STD_PROTO (extern int rand, (void));
978
979
980 double
981 Yap_random (void)
982 {
983 #if HAVE_RANDOM
984 /* extern long random (); */
985 return (((double) random ()) / 0x7fffffffL /* 2**31-1 */);
986 #elif HAVE_RAND
987 return (((double) (rand ()) / RAND_MAX));
988 #else
989 Yap_Error(SYSTEM_ERROR, TermNil,
990 "random not available in this configuration");
991 return (0.0);
992 #endif
993 }
994
995 static Int
996 p_srandom (void)
997 {
998 register Term t0 = Deref (ARG1);
999 if (IsVarTerm (t0)) {
1000 return(Yap_unify(ARG1,MkIntegerTerm((Int)current_seed)));
1001 }
1002 if(!IsNumTerm (t0))
1003 return (FALSE);
1004 if (IsIntTerm (t0))
1005 current_seed = (unsigned int) IntOfTerm (t0);
1006 else if (IsFloatTerm (t0))
1007 current_seed = (unsigned int) FloatOfTerm (t0);
1008 else
1009 current_seed = (unsigned int) LongIntOfTerm (t0);
1010 #if HAVE_RANDOM
1011 srandom(current_seed);
1012 #elif HAVE_RAND
1013 srand(current_seed);
1014
1015 #endif
1016 return (TRUE);
1017 }
1018
1019 #if HAVE_SIGNAL
1020
1021 #include <signal.h>
1022
1023 #ifdef MPW
1024 #define signal sigset
1025 #endif
1026
1027
1028 #ifdef MSH
1029
1030 #define SIGFPE SIGDIV
1031
1032 #endif
1033
1034 STATIC_PROTO (void InitSignals, (void));
1035
1036 #define PLSIG_PREPARED 0x01 /* signal is prepared */
1037 #define PLSIG_THROW 0x02 /* throw signal(num, name) */
1038 #define PLSIG_SYNC 0x04 /* call synchronously */
1039 #define PLSIG_NOFRAME 0x08 /* Do not create a Prolog frame */
1040
1041 #define SIG_PROLOG_OFFSET 32 /* Start of Prolog signals */
1042
1043 #define SIG_EXCEPTION (SIG_PROLOG_OFFSET+0)
1044 #ifdef O_ATOMGC
1045 #define SIG_ATOM_GC (SIG_PROLOG_OFFSET+1)
1046 #endif
1047 #define SIG_GC (SIG_PROLOG_OFFSET+2)
1048 #ifdef O_PLMT
1049 #define SIG_THREAD_SIGNAL (SIG_PROLOG_OFFSET+3)
1050 #endif
1051 #define SIG_FREECLAUSES (SIG_PROLOG_OFFSET+4)
1052 #define SIG_PLABORT (SIG_PROLOG_OFFSET+5)
1053
1054 static struct signame
1055 { int sig;
1056 const char *name;
1057 int flags;
1058 } signames[] =
1059 {
1060 #ifdef SIGHUP
1061 { SIGHUP, "hup", 0},
1062 #endif
1063 { SIGINT, "int", 0},
1064 #ifdef SIGQUIT
1065 { SIGQUIT, "quit", 0},
1066 #endif
1067 { SIGILL, "ill", 0},
1068 { SIGABRT, "abrt", 0},
1069 { SIGFPE, "fpe", PLSIG_THROW},
1070 #ifdef SIGKILL
1071 { SIGKILL, "kill", 0},
1072 #endif
1073 { SIGSEGV, "segv", 0},
1074 #ifdef SIGPIPE
1075 { SIGPIPE, "pipe", 0},
1076 #endif
1077 #ifdef SIGALRM
1078 { SIGALRM, "alrm", PLSIG_THROW},
1079 #endif
1080 { SIGTERM, "term", 0},
1081 #ifdef SIGUSR1
1082 { SIGUSR1, "usr1", 0},
1083 #endif
1084 #ifdef SIGUSR2
1085 { SIGUSR2, "usr2", 0},
1086 #endif
1087 #ifdef SIGCHLD
1088 { SIGCHLD, "chld", 0},
1089 #endif
1090 #ifdef SIGCONT
1091 { SIGCONT, "cont", 0},
1092 #endif
1093 #ifdef SIGSTOP
1094 { SIGSTOP, "stop", 0},
1095 #endif
1096 #ifdef SIGTSTP
1097 { SIGTSTP, "tstp", 0},
1098 #endif
1099 #ifdef SIGTTIN
1100 { SIGTTIN, "ttin", 0},
1101 #endif
1102 #ifdef SIGTTOU
1103 { SIGTTOU, "ttou", 0},
1104 #endif
1105 #ifdef SIGTRAP
1106 { SIGTRAP, "trap", 0},
1107 #endif
1108 #ifdef SIGBUS
1109 { SIGBUS, "bus", 0},
1110 #endif
1111 #ifdef SIGSTKFLT
1112 { SIGSTKFLT, "stkflt", 0},
1113 #endif
1114 #ifdef SIGURG
1115 { SIGURG, "urg", 0},
1116 #endif
1117 #ifdef SIGIO
1118 { SIGIO, "io", 0},
1119 #endif
1120 #ifdef SIGPOLL
1121 { SIGPOLL, "poll", 0},
1122 #endif
1123 #ifdef SIGXCPU
1124 { SIGXCPU, "xcpu", PLSIG_THROW},
1125 #endif
1126 #ifdef SIGXFSZ
1127 { SIGXFSZ, "xfsz", PLSIG_THROW},
1128 #endif
1129 #ifdef SIGVTALRM
1130 { SIGVTALRM, "vtalrm", PLSIG_THROW},
1131 #endif
1132 #ifdef SIGPROF
1133 { SIGPROF, "prof", 0},
1134 #endif
1135 #ifdef SIGPWR
1136 { SIGPWR, "pwr", 0},
1137 #endif
1138 { SIG_EXCEPTION, "prolog:exception", 0 },
1139 #ifdef SIG_ATOM_GC
1140 { SIG_ATOM_GC, "prolog:atom_gc", 0 },
1141 #endif
1142 { SIG_GC, "prolog:gc", 0 },
1143 #ifdef SIG_THREAD_SIGNAL
1144 { SIG_THREAD_SIGNAL, "prolog:thread_signal", 0 },
1145 #endif
1146
1147 { -1, NULL, 0}
1148 };
1149
1150 /* SWI emulation */
1151 int
1152 Yap_signal_index(const char *name)
1153 { struct signame *sn = signames;
1154 char tmp[12];
1155
1156 if ( strncmp(name, "SIG", 3) == 0 && strlen(name) < 12 )
1157 { char *p = (char *)name+3, *q = tmp;
1158 while ((*q++ = tolower(*p++))) {};
1159 name = tmp;
1160 }
1161
1162 for( ; sn->name; sn++ )
1163 { if ( !strcmp(sn->name, name) )
1164 return sn->sig;
1165 }
1166
1167 return -1;
1168 }
1169
1170 #if (defined(__svr4__) || defined(__SVR4))
1171
1172 #if HAVE_SIGINFO_H
1173 #include <siginfo.h>
1174 #endif
1175 #if HAVE_SYS_UCONTEXT_H
1176 #include <sys/ucontext.h>
1177 #endif
1178
1179 STATIC_PROTO (void HandleSIGSEGV, (int, siginfo_t *, ucontext_t *));
1180 STATIC_PROTO (void HandleMatherr, (int, siginfo_t *, ucontext_t *));
1181 STATIC_PROTO (void my_signal_info, (int, void (*)(int, siginfo_t *, ucontext_t *)));
1182 STATIC_PROTO (void my_signal, (int, void (*)(int, siginfo_t *, ucontext_t *)));
1183
1184 /* This routine believes there is a continuous space starting from the
1185 HeapBase and ending on TrailTop */
1186 static void
1187 HandleSIGSEGV(int sig, siginfo_t *sip, ucontext_t *uap)
1188 {
1189
1190 #if !USE_SYSTEM_MALLOC
1191 if (
1192 sip->si_code != SI_NOINFO &&
1193 sip->si_code == SEGV_MAPERR &&
1194 (void *)(sip->si_addr) > (void *)(Yap_HeapBase) &&
1195 (void *)(sip->si_addr) < (void *)(Yap_TrailTop+K64)) {
1196 Yap_growtrail(K64, TRUE);
1197 } else
1198 #endif
1199 {
1200 Yap_Error(FATAL_ERROR, TermNil,
1201 "likely bug in YAP, segmentation violation at %p", sip->si_addr);
1202 }
1203 }
1204
1205
1206 static void
1207 HandleMatherr(int sig, siginfo_t *sip, ucontext_t *uap)
1208 {
1209 yap_error_number error_no;
1210
1211 /* reset the registers so that we don't have trash in abstract machine */
1212
1213 switch(sip->si_code) {
1214 case FPE_INTDIV:
1215 error_no = EVALUATION_ERROR_ZERO_DIVISOR;
1216 break;
1217 case FPE_INTOVF:
1218 error_no = EVALUATION_ERROR_INT_OVERFLOW;
1219 break;
1220 case FPE_FLTDIV:
1221 error_no = EVALUATION_ERROR_ZERO_DIVISOR;
1222 break;
1223 case FPE_FLTOVF:
1224 error_no = EVALUATION_ERROR_FLOAT_OVERFLOW;
1225 break;
1226 case FPE_FLTUND:
1227 error_no = EVALUATION_ERROR_FLOAT_UNDERFLOW;
1228 break;
1229 case FPE_FLTRES:
1230 case FPE_FLTINV:
1231 case FPE_FLTSUB:
1232 default:
1233 error_no = EVALUATION_ERROR_UNDEFINED;
1234 }
1235 set_fpu_exceptions(0);
1236 Yap_Error(error_no, TermNil, "");
1237 }
1238
1239
1240 #if HAVE_SIGSEGV && !defined(THREADS)
1241 static void
1242 my_signal_info(int sig, void (*handler)(int, siginfo_t *, ucontext_t *))
1243 {
1244 struct sigaction sigact;
1245
1246 sigact.sa_handler = handler;
1247 sigemptyset(&sigact.sa_mask);
1248 sigact.sa_flags = SA_SIGINFO;
1249
1250 sigaction(sig,&sigact,NULL);
1251 }
1252 #endif
1253
1254 static void
1255 my_signal(int sig, void (*handler)(int, siginfo_t *, ucontext_t *))
1256 {
1257 struct sigaction sigact;
1258
1259 sigact.sa_handler=handler;
1260 sigemptyset(&sigact.sa_mask);
1261 sigact.sa_flags = 0;
1262 sigaction(sig,&sigact,NULL);
1263 }
1264
1265 #elif defined(__linux__)
1266
1267 STATIC_PROTO (RETSIGTYPE HandleMatherr, (int));
1268 STATIC_PROTO (RETSIGTYPE HandleSIGSEGV, (int,siginfo_t *,void *));
1269 STATIC_PROTO (void my_signal_info, (int, void (*)(int,siginfo_t *,void *)));
1270 STATIC_PROTO (void my_signal, (int, void (*)(int)));
1271
1272 /******** Handling floating point errors *******************/
1273
1274
1275 /* old code, used to work with matherror(), deprecated now:
1276 char err_msg[256];
1277 switch (x->type)
1278 {
1279 case DOMAIN:
1280 case SING:
1281 Yap_Error(EVALUATION_ERROR_UNDEFINED, TermNil, "%s", x->name);
1282 return(0);
1283 case OVERFLOW:
1284 Yap_Error(EVALUATION_ERROR_FLOAT_OVERFLOW, TermNil, "%s", x->name);
1285 return(0);
1286 case UNDERFLOW:
1287 Yap_Error(EVALUATION_ERROR_FLOAT_UNDERFLOW, TermNil, "%s", x->name);
1288 return(0);
1289 case PLOSS:
1290 case TLOSS:
1291 Yap_Error(EVALUATION_ERROR_UNDEFINED, TermNil, "%s(%g) = %g", x->name,
1292 x->arg1, x->retval);
1293 return(0);
1294 default:
1295 Yap_Error(EVALUATION_ERROR_UNDEFINED, TermNil, NULL);
1296 return(0);
1297 }
1298 */
1299
1300
1301 static RETSIGTYPE
1302 HandleMatherr(int sig)
1303 {
1304 #if HAVE_FETESTEXCEPT
1305
1306 /* This should work in Linux, but it doesn't seem to. */
1307
1308 int raised = fetestexcept(FE_ALL_EXCEPT);
1309
1310 if (raised & FE_OVERFLOW) {
1311 Yap_matherror = EVALUATION_ERROR_FLOAT_OVERFLOW;
1312 } else if (raised & (FE_INVALID|FE_INEXACT)) {
1313 Yap_matherror = EVALUATION_ERROR_UNDEFINED;
1314 } else if (raised & FE_DIVBYZERO) {
1315 Yap_matherror = EVALUATION_ERROR_ZERO_DIVISOR;
1316 } else if (raised & FE_UNDERFLOW) {
1317 Yap_matherror = EVALUATION_ERROR_FLOAT_UNDERFLOW;
1318 } else
1319 #endif
1320 Yap_matherror = EVALUATION_ERROR_UNDEFINED;
1321 /* something very bad happened on the way to the forum */
1322 set_fpu_exceptions(FALSE);
1323 Yap_Error(Yap_matherror, TermNil, "");
1324 }
1325
1326 static void
1327 SearchForTrailFault(siginfo_t *siginfo)
1328 {
1329 void *ptr = siginfo->si_addr;
1330
1331 /* If the TRAIL is very close to the top of mmaped allocked space,
1332 then we can try increasing the TR space and restarting the
1333 instruction. In the worst case, the system will
1334 crash again
1335 */
1336 #if OS_HANDLES_TR_OVERFLOW && !USE_SYSTEM_MALLOC
1337 if ((ptr > (void *)Yap_TrailTop-1024 &&
1338 TR < (tr_fr_ptr) Yap_TrailTop+(64*1024))) {
1339 if (!Yap_growtrail(64*1024, TRUE)) {
1340 Yap_Error(OUT_OF_TRAIL_ERROR, TermNil, "YAP failed to reserve %ld bytes in growtrail", K64);
1341 }
1342 /* just in case, make sure the OS keeps the signal handler. */
1343 /* my_signal_info(SIGSEGV, HandleSIGSEGV); */
1344 } else
1345 #endif /* OS_HANDLES_TR_OVERFLOW */
1346 {
1347 Yap_Error(FATAL_ERROR, TermNil,
1348 "tried to access illegal address %p!!!!", ptr);
1349 }
1350 }
1351
1352 #if HAVE_SIGSEGV && !defined(THREADS)
1353 static RETSIGTYPE
1354 HandleSIGSEGV(int sig, siginfo_t *siginfo, void *context)
1355 {
1356 if (Yap_PrologMode & ExtendStackMode) {
1357 Yap_Error(FATAL_ERROR, TermNil, "OS memory allocation crashed at address %p, bailing out\n",Yap_TrailTop);
1358 }
1359 SearchForTrailFault(siginfo);
1360 }
1361 #endif
1362
1363 static void
1364 my_signal_info(int sig, void (*handler)(int,siginfo_t *,void *))
1365 {
1366 struct sigaction sigact;
1367
1368 sigact.sa_sigaction = handler;
1369 sigemptyset(&sigact.sa_mask);
1370 #if HAVE_SIGINFO
1371 sigact.sa_flags = SA_SIGINFO;
1372 #else
1373 sigact.sa_flags = 0;
1374 #endif
1375
1376 sigaction(sig,&sigact,NULL);
1377 }
1378
1379 static void
1380 my_signal(int sig, void (*handler)(int))
1381 {
1382 struct sigaction sigact;
1383
1384 sigact.sa_handler=handler;
1385 sigemptyset(&sigact.sa_mask);
1386 sigact.sa_flags = 0;
1387
1388 sigaction(sig,&sigact,NULL);
1389 }
1390
1391 #else /* if not (defined(__svr4__) || defined(__SVR4)) */
1392
1393 STATIC_PROTO (RETSIGTYPE HandleMatherr, (int));
1394 STATIC_PROTO (RETSIGTYPE HandleSIGSEGV, (int));
1395 STATIC_PROTO (void my_signal_info, (int, void (*)(int)));
1396 STATIC_PROTO (void my_signal, (int, void (*)(int)));
1397
1398 /******** Handling floating point errors *******************/
1399
1400
1401 /* old code, used to work with matherror(), deprecated now:
1402 char err_msg[256];
1403 switch (x->type)
1404 {
1405 case DOMAIN:
1406 case SING:
1407 Yap_Error(EVALUATION_ERROR_UNDEFINED, TermNil, "%s", x->name);
1408 return(0);
1409 case OVERFLOW:
1410 Yap_Error(EVALUATION_ERROR_FLOAT_OVERFLOW, TermNil, "%s", x->name);
1411 return(0);
1412 case UNDERFLOW:
1413 Yap_Error(EVALUATION_ERROR_FLOAT_UNDERFLOW, TermNil, "%s", x->name);
1414 return(0);
1415 case PLOSS:
1416 case TLOSS:
1417 Yap_Error(EVALUATION_ERROR_UNDEFINED, TermNil, "%s(%g) = %g", x->name,
1418 x->arg1, x->retval);
1419 return(0);
1420 default:
1421 Yap_Error(EVALUATION_ERROR_UNDEFINED, TermNil, NULL);
1422 return(0);
1423 }
1424 */
1425
1426
1427 #if HAVE_FENV_H
1428 #include <fenv.h>
1429 #endif
1430
1431 static RETSIGTYPE
1432 HandleMatherr(int sig)
1433 {
1434 #if HAVE_FETESTEXCEPT
1435
1436 /* This should work in Linux, but it doesn't seem to. */
1437
1438 int raised = fetestexcept(FE_ALL_EXCEPT);
1439
1440 if (raised & FE_OVERFLOW) {
1441 Yap_matherror = EVALUATION_ERROR_FLOAT_OVERFLOW;
1442 } else if (raised & (FE_INVALID|FE_INEXACT)) {
1443 Yap_matherror = EVALUATION_ERROR_UNDEFINED;
1444 } else if (raised & FE_DIVBYZERO) {
1445 Yap_matherror = EVALUATION_ERROR_ZERO_DIVISOR;
1446 } else if (raised & FE_UNDERFLOW) {
1447 Yap_matherror = EVALUATION_ERROR_FLOAT_UNDERFLOW;
1448 } else
1449 #endif
1450 Yap_matherror = EVALUATION_ERROR_UNDEFINED;
1451 /* something very bad happened on the way to the forum */
1452 set_fpu_exceptions(FALSE);
1453 Yap_Error(Yap_matherror, TermNil, "");
1454 }
1455
1456 static void
1457 SearchForTrailFault(void)
1458 {
1459 /* If the TRAIL is very close to the top of mmaped allocked space,
1460 then we can try increasing the TR space and restarting the
1461 instruction. In the worst case, the system will
1462 crash again
1463 */
1464 #ifdef DEBUG
1465 /* fprintf(stderr,"Catching a sigsegv at %p with %p\n", TR, TrailTop); */
1466 #endif
1467 #if OS_HANDLES_TR_OVERFLOW && !USE_SYSTEM_MALLOC
1468 if ((TR > (tr_fr_ptr)Yap_TrailTop-1024 &&
1469 TR < (tr_fr_ptr)Yap_TrailTop+(64*1024))|| Yap_DBTrailOverflow()) {
1470 long trsize = K64;
1471
1472 while ((CELL)TR > (CELL)Yap_TrailTop+trsize) {
1473 trsize += K64;
1474 }
1475 if (!Yap_growtrail(trsize, TRUE)) {
1476 Yap_Error(OUT_OF_TRAIL_ERROR, TermNil, "YAP failed to reserve %ld bytes in growtrail", K64);
1477 }
1478 /* just in case, make sure the OS keeps the signal handler. */
1479 /* my_signal_info(SIGSEGV, HandleSIGSEGV); */
1480 } else
1481 #endif /* OS_HANDLES_TR_OVERFLOW */
1482 Yap_Error(INTERNAL_ERROR, TermNil,
1483 "likely bug in YAP, segmentation violation");
1484 }
1485
1486 static RETSIGTYPE
1487 HandleSIGSEGV(int sig)
1488 {
1489 if (Yap_PrologMode & ExtendStackMode) {
1490 Yap_Error(FATAL_ERROR, TermNil, "OS memory allocation crashed at address %p, bailing out\n",Yap_TrailTop);
1491 }
1492 SearchForTrailFault();
1493 }
1494
1495 #if HAVE_SIGACTION
1496
1497 static void
1498 my_signal_info(int sig, void (*handler)(int))
1499 {
1500 struct sigaction sigact;
1501
1502 sigact.sa_handler = handler;
1503 sigemptyset(&sigact.sa_mask);
1504 #if HAVE_SIGINFO
1505 sigact.sa_flags = SA_SIGINFO;
1506 #else
1507 sigact.sa_flags = 0;
1508 #endif
1509
1510 sigaction(sig,&sigact,NULL);
1511 }
1512
1513 static void
1514 my_signal(int sig, void (*handler)(int))
1515 {
1516 struct sigaction sigact;
1517
1518 sigact.sa_handler=handler;
1519 sigemptyset(&sigact.sa_mask);
1520 sigact.sa_flags = 0;
1521
1522 sigaction(sig,&sigact,NULL);
1523 }
1524
1525 #else
1526
1527 static void
1528 my_signal(int sig, void (*handler)(int))
1529 {
1530 signal(sig, handler);
1531 }
1532
1533 static void
1534 my_signal_info(sig, handler)
1535 int sig;
1536 void (*handler)(int);
1537 {
1538 if(signal(sig, handler) == SIG_ERR)
1539 exit(1);
1540 }
1541 #endif /* __linux__ */
1542
1543 #endif /* (defined(__svr4__) || defined(__SVR4)) */
1544
1545
1546 static int
1547 InteractSIGINT(int ch) {
1548 Yap_PrologMode |= AsyncIntMode;
1549 switch (ch) {
1550 case 'a':
1551 /* abort computation */
1552 if (Yap_PrologMode & (GCMode|ConsoleGetcMode|GrowStackMode|GrowHeapMode)) {
1553 Yap_PrologMode |= AbortMode;
1554 } else {
1555 Yap_Error(PURE_ABORT, TermNil, "abort from console");
1556 /* in case someone mangles the P register */
1557 }
1558 Yap_PrologMode &= ~AsyncIntMode;
1559 return -1;
1560 case 'b':
1561 /* continue */
1562 Yap_signal (YAP_BREAK_SIGNAL);
1563 Yap_PrologMode &= ~AsyncIntMode;
1564 return 1;
1565 case 'c':
1566 /* continue */
1567 return 1;
1568 case 'd':
1569 Yap_signal (YAP_DEBUG_SIGNAL);
1570 Yap_PrologMode &= ~AsyncIntMode;
1571 /* enter debug mode */
1572 return 1;
1573 case 'e':
1574 /* exit */
1575 Yap_PrologMode &= ~AsyncIntMode;
1576 Yap_exit(0);
1577 return -1;
1578 case 'g':
1579 /* exit */
1580 Yap_signal (YAP_STACK_DUMP_SIGNAL);
1581 Yap_PrologMode &= ~AsyncIntMode;
1582 return -1;
1583 case 't':
1584 /* start tracing */
1585 Yap_signal (YAP_TRACE_SIGNAL);
1586 Yap_PrologMode &= ~AsyncIntMode;
1587 return 1;
1588 #ifdef LOW_LEVEL_TRACER
1589 case 'T':
1590 toggle_low_level_trace();
1591 Yap_PrologMode &= ~AsyncIntMode;
1592 return 1;
1593 #endif
1594 case 's':
1595 /* show some statistics */
1596 Yap_signal (YAP_STATISTICS_SIGNAL);
1597 Yap_PrologMode &= ~AsyncIntMode;
1598 return 1;
1599 case EOF:
1600 Yap_PrologMode &= ~AsyncIntMode;
1601 return(0);
1602 break;
1603 case 'h':
1604 case '?':
1605 default:
1606 /* show an helpful message */
1607 fprintf(Yap_stderr, "Please press one of:\n");
1608 fprintf(Yap_stderr, " a for abort\n c for continue\n d for debug\n");
1609 fprintf(Yap_stderr, " e for exit\n g for stack dump\n s for statistics\n t for trace\n");
1610 fprintf(Yap_stderr, " b for break\n");
1611 Yap_PrologMode &= ~AsyncIntMode;
1612 return(0);
1613 }
1614 }
1615
1616 /*
1617 This function talks to the user about a signal. We assume we are in
1618 the context of the main Prolog thread (trivial in Unix, but hard in WIN32)
1619 */
1620 static int
1621 ProcessSIGINT(void)
1622 {
1623 int ch, out;
1624
1625 do {
1626 ch = Yap_GetCharForSIGINT();
1627 } while (!(out = InteractSIGINT(ch)));
1628 return(out);
1629 }
1630
1631 int
1632 Yap_ProcessSIGINT(void)
1633 {
1634 return ProcessSIGINT();
1635 }
1636
1637
1638 #if !_MSC_VER && !defined(__MINGW32__)
1639
1640 #if HAVE_SIGNAL
1641 static int snoozing = FALSE;
1642 #endif
1643
1644 /* This function is called from the signal handler to process signals.
1645 We assume we are within the context of the signal handler, whatever
1646 that might be
1647 */
1648 static RETSIGTYPE
1649 #if (defined(__svr4__) || defined(__SVR4))
1650 HandleSIGINT (int sig, siginfo_t *x, ucontext_t *y)
1651 #else
1652 HandleSIGINT (int sig)
1653 #endif
1654 {
1655 LOCK(SignalLock);
1656 my_signal(SIGINT, HandleSIGINT);
1657 /* do this before we act */
1658 #if HAVE_ISATTY
1659 if (!isatty(0) && !Yap_sockets_io) {
1660 UNLOCK(SignalLock);
1661 Yap_Error(INTERRUPT_ERROR,MkIntTerm(SIGINT),NULL);
1662 return;
1663 }
1664 #endif
1665 if (Yap_InterruptsDisabled) {
1666 UNLOCK(SignalLock);
1667 return;
1668 }
1669 if (Yap_PrologMode & (CritMode|ConsoleGetcMode)) {
1670 Yap_PrologMode |= InterruptMode;
1671 #if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H
1672 if (Yap_PrologMode & ConsoleGetcMode) {
1673 fprintf(stderr, "Action (h for help): ");
1674 rl_point = rl_end = 0;
1675 #if HAVE_RL_SET_PROMPT
1676 rl_set_prompt("Action (h for help): ");
1677 #endif
1678 }
1679 #endif
1680 UNLOCK(SignalLock);
1681 return;
1682 }
1683 #ifdef HAVE_SETBUF
1684 /* make sure we are not waiting for the end of line */
1685 YP_setbuf (stdin, NULL);
1686 #endif
1687 if (snoozing) {
1688 snoozing = FALSE;
1689 UNLOCK(SignalLock);
1690 return;
1691 }
1692 ProcessSIGINT();
1693 UNLOCK(SignalLock);
1694 }
1695 #endif
1696
1697 #if !defined(_WIN32)
1698 /* this routine is called if the system activated the alarm */
1699 static RETSIGTYPE
1700 #if (defined(__svr4__) || defined(__SVR4))
1701 HandleALRM (int s, siginfo_t *x, ucontext_t *y)
1702 #else
1703 HandleALRM(int s)
1704 #endif
1705 {
1706 my_signal (SIGALRM, HandleALRM);
1707 /* force the system to creep */
1708 Yap_signal (YAP_ALARM_SIGNAL);
1709 /* now, say what is going on */
1710 Yap_PutValue(AtomAlarm, MkAtomTerm(AtomTrue));
1711 }
1712 #endif
1713
1714
1715 #if !defined(_WIN32)
1716 /* this routine is called if the system activated the alarm */
1717 static RETSIGTYPE
1718 #if (defined(__svr4__) || defined(__SVR4))
1719 HandleVTALRM (int s, siginfo_t *x, ucontext_t *y)
1720 #else
1721 HandleVTALRM(int s)
1722 #endif
1723 {
1724 my_signal (SIGVTALRM, HandleVTALRM);
1725 /* force the system to creep */
1726 Yap_signal (YAP_VTALARM_SIGNAL);
1727 /* now, say what is going on */
1728 Yap_PutValue(AtomAlarm, MkAtomTerm(AtomTrue));
1729 }
1730 #endif
1731
1732
1733 /*
1734 * This function is called after a normal interrupt had been caught.
1735 * It allows 6 possibilities: abort, continue, trace, debug, help, exit.
1736 */
1737
1738 #if !defined(LIGHT) && !_MSC_VER && !defined(__MINGW32__) && !defined(LIGHT)
1739 static RETSIGTYPE
1740 #if (defined(__svr4__) || defined(__SVR4))
1741 ReceiveSignal (int s, siginfo_t *x, ucontext_t *y)
1742 #else
1743 ReceiveSignal (int s)
1744 #endif
1745 {
1746 switch (s)
1747 {
1748 #ifndef MPW
1749 case SIGFPE:
1750 set_fpu_exceptions(FALSE);
1751 Yap_Error (SYSTEM_ERROR, TermNil, "floating point exception ]");
1752 break;
1753 #endif
1754 #if !defined(LIGHT) && !defined(_WIN32)
1755 /* These signals are not handled by WIN32 and not the Macintosh */
1756 case SIGQUIT:
1757 case SIGKILL:
1758 Yap_Error(INTERRUPT_ERROR,MkIntTerm(s),NULL);
1759 #endif
1760 #ifdef SIGUSR1
1761 case SIGUSR1:
1762 /* force the system to creep */
1763 Yap_signal (YAP_USR1_SIGNAL);
1764 break;
1765 #endif /* defined(SIGUSR1) */
1766 #ifdef SIGUSR2
1767 case SIGUSR2:
1768 /* force the system to creep */
1769 Yap_signal (YAP_USR2_SIGNAL);
1770 break;
1771 #endif /* defined(SIGUSR2) */
1772 #ifdef SIGPIPE
1773 case SIGPIPE:
1774 /* force the system to creep */
1775 Yap_signal (YAP_PIPE_SIGNAL);
1776 break;
1777 #endif /* defined(SIGPIPE) */
1778 #ifdef SIGHUP
1779 case SIGHUP:
1780 /* force the system to creep */
1781 Yap_signal (YAP_HUP_SIGNAL);
1782 break;
1783 #endif /* defined(SIGHUP) */
1784 default:
1785 fprintf(Yap_stderr, "\n[ Unexpected signal ]\n");
1786 exit (EXIT_FAILURE);
1787 }
1788 }
1789 #endif
1790
1791 #if (_MSC_VER || defined(__MINGW32__))
1792 static BOOL WINAPI
1793 MSCHandleSignal(DWORD dwCtrlType) {
1794 if (Yap_InterruptsDisabled) {
1795 return FALSE;
1796 }
1797 switch(dwCtrlType) {
1798 case CTRL_C_EVENT:
1799 case CTRL_BREAK_EVENT:
1800 Yap_signal(YAP_ALARM_SIGNAL);
1801 Yap_PrologMode |= InterruptMode;
1802 return(TRUE);
1803 default:
1804 return(FALSE);
1805 }
1806 }
1807 #endif
1808
1809 /* SIGINT can cause problems, if caught before full initialization */
1810 static void
1811 InitSignals (void)
1812 {
1813 if (Yap_PrologShouldHandleInterrupts) {
1814 #if !defined(LIGHT) && !_MSC_VER && !defined(__MINGW32__) && !defined(LIGHT)
1815 my_signal (SIGQUIT, ReceiveSignal);
1816 my_signal (SIGKILL, ReceiveSignal);
1817 my_signal (SIGUSR1, ReceiveSignal);
1818 my_signal (SIGUSR2, ReceiveSignal);
1819 my_signal (SIGHUP, ReceiveSignal);
1820 my_signal (SIGALRM, HandleALRM);
1821 my_signal (SIGVTALRM, HandleVTALRM);
1822 #endif
1823 #ifdef SIGPIPE
1824 my_signal (SIGPIPE, ReceiveSignal);
1825 #endif
1826 #if _MSC_VER || defined(__MINGW32__)
1827 signal (SIGINT, SIG_IGN);
1828 SetConsoleCtrlHandler(MSCHandleSignal,TRUE);
1829 #else
1830 my_signal (SIGINT, HandleSIGINT);
1831 #endif
1832 #ifndef MPW
1833 my_signal (SIGFPE, HandleMatherr);
1834 #endif
1835 #if HAVE_SIGSEGV && !defined(THREADS)
1836 my_signal_info (SIGSEGV, HandleSIGSEGV);
1837 #endif
1838 #ifdef ACOW
1839 signal(SIGCHLD, SIG_IGN); /* avoid ghosts */
1840 #endif
1841 } else {
1842 #if OS_HANDLES_TR_OVERFLOW
1843 #if HAVE_SIGSEGV && !defined(THREADS)
1844 my_signal_info (SIGSEGV, HandleSIGSEGV);
1845 #endif
1846 #endif
1847 }
1848 }
1849
1850 #endif /* HAVE_SIGNAL */
1851
1852
1853 /* TrueFileName -> Finds the true name of a file */
1854
1855 #ifdef __MINGW32__
1856 #include <ctype.h>
1857 #endif
1858
1859 static int
1860 volume_header(char *file)
1861 {
1862 #if _MSC_VER || defined(__MINGW32__)
1863 char *ch = file;
1864 int c;
1865
1866 while ((c = ch[0]) != '\0') {
1867 if (isalnum(c)) ch++;
1868 else return(c == ':');
1869 }
1870 #endif
1871 return(FALSE);
1872 }
1873
1874 int
1875 Yap_volume_header(char *file)
1876 {
1877 return volume_header(file);
1878 }
1879
1880
1881 int Yap_getcwd(const char *buf, int len)
1882 {
1883 #if __simplescalar__
1884 /* does not implement getcwd */
1885 strncpy(Yap_buf,yap_pwd,len);
1886 #elif HAVE_GETCWD
1887 if (getcwd ((char *)buf, len) == NULL) {
1888 #if HAVE_STRERROR
1889 Yap_Error(OPERATING_SYSTEM_ERROR, ARG1, "%s in getcwd/1", strerror(errno));
1890 #else
1891 Yap_Error(OPERATING_SYSTEM_ERROR, ARG1, "error %d in getcwd/1", errno);
1892 #endif
1893 return FALSE;
1894 }
1895 #else
1896 if (getwd (buf) == NULL) {
1897 #if HAVE_STRERROR
1898 Yap_Error(OPERATING_SYSTEM_ERROR, ARG1, "%s in getcwd/1", strerror(errno));
1899 #else
1900 Yap_Error(OPERATING_SYSTEM_ERROR, ARG1, "in getcwd/1");
1901 #endif
1902 return FALSE;
1903 }
1904 #endif
1905 return TRUE;
1906 }
1907
1908 /******
1909 TODO: rewrite to use wordexp
1910 ****/
1911 static int
1912 TrueFileName (char *source, char *root, char *result, int in_lib)
1913 {
1914 char *work;
1915 char ares1[YAP_FILENAME_MAX];
1916
1917 result[0] = '\0';
1918 #if defined(__MINGW32__) || _MSC_VER
1919 /* step 0: replace / by \ */
1920 strncpy(ares1, source, YAP_FILENAME_MAX);
1921 {
1922 char *p = ares1, ch = p[0];
1923 while (ch != '\0') {
1924 if (ch == '/') p[0] = '\\';
1925 p++;
1926 ch = p[0];
1927 }
1928 }
1929 source = ares1;
1930 #endif
1931 /* step 1: eating home information */
1932 if (source[0] == '~') {
1933 if (dir_separator(source[1]) || source[1] == '\0')
1934 {
1935 char *s;
1936 source++;
1937 #if defined(_WIN32)
1938 s = getenv("HOMEDRIVE");
1939 if (s != NULL)
1940 strncpy (result, getenv ("HOMEDRIVE"), YAP_FILENAME_MAX);
1941 s = getenv("HOMEPATH");
1942 if (s != NULL)
1943 strncpy (result, s, YAP_FILENAME_MAX);
1944 #else
1945 s = getenv ("HOME");
1946 if (s != NULL)
1947 strncpy (result, s, YAP_FILENAME_MAX);
1948 #endif
1949 } else {
1950 #if HAVE_GETPWNAM
1951 struct passwd *user_passwd;
1952 char *res0 = result;
1953
1954 source++;
1955 while (!dir_separator((*res0 = *source)) && *res0 != '\0')
1956 res0++, source++;
1957 *res0++ = '\0';
1958 if ((user_passwd = getpwnam (result)) == NULL) {
1959 return FALSE;
1960 }
1961 strncpy (result, user_passwd->pw_dir, YAP_FILENAME_MAX);
1962 #else
1963 return FALSE;
1964 #endif
1965 }
1966 strncat (result, source, YAP_FILENAME_MAX);
1967 } else if (source[0] == '$') {
1968 /* follow SICStus expansion rules */
1969 int ch;
1970 char *s;
1971 char *res0 = source+1;
1972
1973 while ((ch = *res0) && is_valid_env_char (ch)) {
1974 res0++;
1975 }
1976 *res0 = '\0';
1977 if (!(s = (char *) getenv (source+1))) {
1978 return FALSE;
1979 }
1980 *res0 = ch;
1981 strncpy (result, s, YAP_FILENAME_MAX);
1982 strncat (result, res0, YAP_FILENAME_MAX);
1983 } else {
1984 strncpy (result, source, YAP_FILENAME_MAX);
1985 }
1986 /* step 3: get the full file name */
1987 if (!dir_separator(result[0]) && !volume_header(result)) {
1988 if (!Yap_getcwd(ares1, YAP_FILENAME_MAX))
1989 return FALSE;
1990 #if _MSC_VER || defined(__MINGW32__)
1991 strncat (ares1, "\\", YAP_FILENAME_MAX-1);
1992 #else
1993 strncat (ares1, "/", YAP_FILENAME_MAX-1);
1994 #endif
1995 if (root) {
1996 if (!dir_separator(root[0]) && !volume_header(root)) {
1997 strncat(ares1, root, YAP_FILENAME_MAX-1);
1998 } else {
1999 strncpy(ares1, root, YAP_FILENAME_MAX-1);
2000 }
2001 #if _MSC_VER || defined(__MINGW32__)
2002 strncat (ares1, "\\", YAP_FILENAME_MAX-1);
2003 #else
2004 strncat (ares1, "/", YAP_FILENAME_MAX-1);
2005 #endif
2006 }
2007 strncat (ares1, result, YAP_FILENAME_MAX-1);
2008 if (in_lib) {
2009 int tmpf;
2010 if ((tmpf = open(ares1, O_RDONLY)) < 0) {
2011 /* not in current directory, let us try the library */
2012 if (Yap_LibDir != NULL) {
2013 strncpy(Yap_FileNameBuf, Yap_LibDir, YAP_FILENAME_MAX);
2014 #if HAVE_GETENV
2015 } else {
2016 char *yap_env = getenv("YAPLIBDIR");
2017 if (yap_env != NULL) {
2018 strncpy(ares1, yap_env, YAP_FILENAME_MAX);
2019 #endif
2020 } else {
2021 #if _MSC_VER || defined(__MINGW32__)
2022 if (libdir)
2023 strncpy(ares1, libdir, YAP_FILENAME_MAX);
2024 else
2025 #endif
2026 strncpy(ares1, YAP_LIBDIR, YAP_FILENAME_MAX);
2027 }
2028 #if HAVE_GETENV
2029 }
2030 #endif
2031 #if _MSC_VER || defined(__MINGW32__)
2032 strncat(ares1,"\\", YAP_FILENAME_MAX-1);
2033 #else
2034 strncat(ares1,"/", YAP_FILENAME_MAX-1);
2035 #endif
2036 strncat(ares1,result, YAP_FILENAME_MAX-1);
2037 if ((tmpf = open(ares1, O_RDONLY)) >= 0) {
2038 close(tmpf);
2039 strncpy (result, ares1, YAP_FILENAME_MAX);
2040 }
2041 } else {
2042 strncpy (result, ares1, YAP_FILENAME_MAX);
2043 close(tmpf);
2044 }
2045 } else {
2046 strncpy (result, ares1, YAP_FILENAME_MAX);
2047 }
2048 }
2049 /* step 4: simplifying the file name */
2050 work = result;
2051 while (*work != '\0')
2052 {
2053 char *new_work, *next_work;
2054 if (*work++ != '.')
2055 continue;
2056 if (*work != '.')
2057 {
2058 if (!dir_separator(*work) || !dir_separator(work[-2]))
2059 continue;
2060 next_work = work + 1;
2061 new_work = --work;
2062 }
2063 else
2064 {
2065 if (!dir_separator(work[1]) || !dir_separator(work[-2]))
2066 continue;
2067 next_work = work + 2;
2068 work -= 2;
2069 if (work == result)
2070 return (FALSE);
2071 while (!dir_separator(*--work) && work != result);
2072 if (work == result && !dir_separator(work[0]))
2073 return (FALSE);
2074 new_work = ++work;
2075 }
2076 while ((*new_work++ = *next_work++)!=0);
2077 }
2078 if (work != result && dir_separator(work[-1])) {
2079 /* should only do this on result being a directory */
2080 int ch0 = work[-1];
2081 work--;
2082 work[0] = '\0';
2083 if (!is_directory(result)) {
2084 /* put it back: */
2085 work[0] = ch0;
2086 work++;
2087 }
2088 }
2089 return TRUE;
2090 }
2091
2092 int
2093 Yap_TrueFileName (char *source, char *result, int in_lib)
2094 {
2095 return TrueFileName (source, NULL, result, in_lib);
2096 }
2097
2098 static Int
2099 p_true_file_name (void)
2100 {
2101 Term t = Deref(ARG1);
2102
2103 if (IsVarTerm(t)) {
2104 Yap_Error(INSTANTIATION_ERROR,t,"argument to true_file_name unbound");
2105 return FALSE;
2106 }
2107 if (!IsAtomTerm(t)) {
2108 Yap_Error(TYPE_ERROR_ATOM,t,"argument to true_file_name");
2109 return FALSE;
2110 }
2111 TrueFileName (RepAtom(AtomOfTerm(t))->StrOfAE, NULL, Yap_FileNameBuf, FALSE);
2112 return Yap_unify(ARG2, MkAtomTerm(Yap_LookupAtom(Yap_FileNameBuf)));
2113 }
2114
2115 static Int
2116 p_true_file_name3 (void)
2117 {
2118 Term t = Deref(ARG1), t2 = Deref(ARG2);
2119 char *root = NULL;
2120
2121 if (IsVarTerm(t)) {
2122 Yap_Error(INSTANTIATION_ERROR,t,"argument to true_file_name unbound");
2123 return FALSE;
2124 }
2125 if (!IsAtomTerm(t)) {
2126 Yap_Error(TYPE_ERROR_ATOM,t,"argument to true_file_name");
2127 return FALSE;
2128 }
2129 if (!IsVarTerm(t2)) {
2130 if (!IsAtomTerm(t)) {
2131 Yap_Error(TYPE_ERROR_ATOM,t2,"argument to true_file_name");
2132 return FALSE;
2133 }
2134 root = RepAtom(AtomOfTerm(t2))->StrOfAE;
2135 }
2136 TrueFileName (RepAtom(AtomOfTerm(t))->StrOfAE, root, Yap_FileNameBuf, FALSE);
2137 return Yap_unify(ARG3, MkAtomTerm(Yap_LookupAtom(Yap_FileNameBuf)));
2138 }
2139
2140 static Int
2141 p_getcwd(void)
2142 {
2143 if (!Yap_getcwd(Yap_FileNameBuf, YAP_FILENAME_MAX))
2144 return FALSE;
2145 return Yap_unify(ARG1,MkAtomTerm(Yap_LookupAtom(Yap_FileNameBuf)));
2146 }
2147
2148 /* Executes $SHELL under Prolog */
2149
2150 static Int
2151 p_sh (void)
2152 { /* sh */
2153 #ifdef HAVE_SYSTEM
2154 char *shell;
2155 shell = (char *) getenv ("SHELL");
2156 if (shell == NULL)
2157 shell = "/bin/sh";
2158 if (system (shell) < 0) {
2159 #if HAVE_STRERROR
2160 Yap_Error(OPERATING_SYSTEM_ERROR, TermNil, "%s in sh/0", strerror(errno));
2161 #else
2162 Yap_Error(OPERATING_SYSTEM_ERROR, TermNil, "in sh/0");
2163 #endif
2164 return FALSE;
2165 }
2166 return TRUE;
2167 #else
2168 #ifdef MSH
2169 register char *shell;
2170 shell = "msh -i";
2171 system (shell);
2172 return (TRUE);
2173 #else
2174 Yap_Error(SYSTEM_ERROR,TermNil,"sh not available in this configuration");
2175 return(FALSE);
2176 #endif /* MSH */
2177 #endif
2178 }
2179
2180 static Int
2181 p_shell (void)
2182 { /* '$shell'(+SystCommand) */
2183 #if _MSC_VER || defined(__MINGW32__)
2184 Yap_Error(SYSTEM_ERROR,TermNil,"shell not available in this configuration");
2185 return FALSE;
2186 #else
2187 #if HAVE_SYSTEM
2188 char *shell;
2189 register int bourne = FALSE;
2190 Term t1 = Deref (ARG1);
2191
2192 shell = (char *) getenv ("SHELL");
2193 if (!strcmp (shell, "/bin/sh"))
2194 bourne = TRUE;
2195 if (shell == NIL)
2196 bourne = TRUE;
2197 /* Yap_CloseStreams(TRUE); */
2198 if (bourne)
2199 return system(RepAtom(AtomOfTerm(t1))->StrOfAE) == 0;
2200 else {
2201 int status = -1;
2202 int child = fork ();
2203
2204 if (child == 0) { /* let the children go */
2205 if (!execl (shell, shell, "-c", RepAtom(AtomOfTerm(t1))->StrOfAE , NULL)) {
2206 exit(-1);
2207 }
2208 exit(TRUE);
2209 }
2210 { /* put the father on wait */
2211 int result = child < 0 ||
2212 /* vsc:I am not sure this is used, Stevens say wait returns an integer.
2213 #if NO_UNION_WAIT
2214 */
2215 wait ((&status)) != child ||
2216 /*
2217 #else
2218 wait ((union wait *) (&status)) != child ||
2219 #endif
2220 */
2221 status == 0;
2222 return result;
2223 }
2224 }
2225 #else /* HAVE_SYSTEM */
2226 #ifdef MSH
2227 register char *shell;
2228 shell = "msh -i";
2229 /* Yap_CloseStreams(); */
2230 system (shell);
2231 return TRUE;
2232 #else
2233 Yap_Error (SYSTEM_ERROR,TermNil,"shell not available in this configuration");
2234 return FALSE;
2235 #endif
2236 #endif /* HAVE_SYSTEM */
2237 #endif /* _MSC_VER */
2238 }
2239
2240 static Int
2241 p_system (void)
2242 { /* '$system'(+SystCommand) */
2243 #ifdef HAVE_SYSTEM
2244 Term t1 = Deref (ARG1);
2245 char *s;
2246
2247 if (IsVarTerm(t1)) {
2248 Yap_Error(INSTANTIATION_ERROR,t1,"argument to system/1 unbound");
2249 return FALSE;
2250 } else if (IsAtomTerm(t1)) {
2251 s = RepAtom(AtomOfTerm(t1))->StrOfAE;
2252 } else {
2253 if (!Yap_GetName (Yap_FileNameBuf, YAP_FILENAME_MAX, t1)) {
2254 Yap_Error(TYPE_ERROR_ATOM,t1,"argument to system/1");
2255 return FALSE;
2256 }
2257 s = Yap_FileNameBuf;
2258 }
2259 /* Yap_CloseStreams(TRUE); */
2260 #if _MSC_VER
2261 _flushall();
2262 #endif
2263 if (system (s)) {
2264 #if HAVE_STRERROR
2265 Yap_Error(OPERATING_SYSTEM_ERROR,t1,"%s in system(%s)", strerror(errno), s);
2266 #else
2267 Yap_Error(OPERATING_SYSTEM_ERROR,t1,"in system(%s)", s);
2268 #endif
2269 return FALSE;
2270 }
2271 return TRUE;
2272 #else
2273 #ifdef MSH
2274 register char *shell;
2275 shell = "msh -i";
2276 /* Yap_CloseStreams(); */
2277 system (shell);
2278 return (TRUE);
2279 #undef command
2280 #else
2281 Yap_Error(SYSTEM_ERROR,TermNil,"sh not available in this machine");
2282 return(FALSE);
2283 #endif
2284 #endif /* HAVE_SYSTEM */
2285 }
2286
2287
2288
2289 /* Rename a file */
2290 static Int
2291 p_mv (void)
2292 { /* rename(+OldName,+NewName) */
2293 #if HAVE_LINK
2294 int r;
2295 char oldname[YAP_FILENAME_MAX], newname[YAP_FILENAME_MAX];
2296 Term t1 = Deref (ARG1);
2297 Term t2 = Deref (ARG2);
2298 if (IsVarTerm(t1)) {
2299 Yap_Error(INSTANTIATION_ERROR, t1, "first argument to rename/2 unbound");
2300 } else if (!IsAtomTerm(t1)) {
2301 Yap_Error(TYPE_ERROR_ATOM, t1, "first argument to rename/2 not atom");
2302 }
2303 if (IsVarTerm(t2)) {
2304 Yap_Error(INSTANTIATION_ERROR, t2, "second argument to rename/2 unbound");
2305 } else if (!IsAtomTerm(t2)) {
2306 Yap_Error(TYPE_ERROR_ATOM, t2, "second argument to rename/2 not atom");
2307 }
2308 TrueFileName (RepAtom(AtomOfTerm(t1))->StrOfAE, NULL, oldname, FALSE);
2309 TrueFileName (RepAtom(AtomOfTerm(t2))->StrOfAE, NULL, newname, FALSE);
2310 if ((r = link (oldname, newname)) == 0 && (r = unlink (oldname)) != 0)
2311 unlink (newname);
2312 if (r != 0) {
2313 #if HAVE_STRERROR
2314 Yap_Error(OPERATING_SYSTEM_ERROR,t2,"%s in rename(%s,%s)", strerror(errno),oldname,newname);
2315 #else
2316 Yap_Error(OPERATING_SYSTEM_ERROR,t2,"in rename(%s,%s)",oldname,newname);
2317 #endif
2318 return FALSE;
2319 }
2320 return TRUE;
2321 #else
2322 Yap_Error(SYSTEM_ERROR,TermNil,"rename/2 not available in this machine");
2323 return (FALSE);
2324 #endif
2325 }
2326
2327
2328 /* find the directory info from a file name */
2329 static Int
2330 p_file_directory_name (void)
2331 {
2332 Term t1 = Deref(ARG1);
2333 char *chp;
2334
2335 if (IsVarTerm(t1)) {
2336 Yap_Error(INSTANTIATION_ERROR, t1, "first arg of file_directory_name/2");
2337 return FALSE;
2338 }
2339 if (!IsAtomTerm(t1)) {
2340 Yap_Error(TYPE_ERROR_ATOM, t1, "first arg of file_directory_name/2");
2341 return FALSE;
2342 }
2343 TrueFileName (RepAtom(AtomOfTerm(t1))->StrOfAE, NULL, Yap_FileNameBuf, FALSE);
2344 chp = Yap_FileNameBuf+strlen(Yap_FileNameBuf);
2345 while (!dir_separator(*--chp) && chp != Yap_FileNameBuf);
2346 if (chp == Yap_FileNameBuf) {
2347 return Yap_unify(MkAtomTerm(AtomDot),ARG2);
2348 }
2349 *chp = '\0';
2350 return Yap_unify(MkAtomTerm(Yap_LookupAtom(Yap_FileNameBuf)),ARG2);
2351 }
2352
2353 /* Change the working directory */
2354 static Int
2355 p_cd (void)
2356 { /* cd(+NewD) */
2357 Term t1 = Deref (ARG1);
2358
2359 if (IsVarTerm(t1)) {
2360 Yap_Error(INSTANTIATION_ERROR,t1,"argument to cd/1 is not valid");
2361 return FALSE;
2362 } else if (IsAtomTerm(t1)) {
2363 TrueFileName (RepAtom(AtomOfTerm(t1))->StrOfAE, NULL, Yap_FileNameBuf2, FALSE);
2364 } else {
2365 if (t1 == TermNil)
2366 return TRUE;
2367 if (!Yap_GetName (Yap_FileNameBuf, YAP_FILENAME_MAX, t1)) {
2368 Yap_Error(TYPE_ERROR_ATOM,t1,"argument to cd/1 is not valid");
2369 return FALSE;
2370 }
2371 TrueFileName (Yap_FileNameBuf, NULL, Yap_FileNameBuf2, FALSE);
2372 }
2373 #if HAVE_CHDIR
2374 #if __simplescalar__
2375 strncpy(yap_pwd,Yap_FileNameBuf2,YAP_FILENAME_MAX);
2376 #endif
2377 if (chdir (Yap_FileNameBuf2) < 0) {
2378 #if HAVE_STRERROR
2379 Yap_Error(OPERATING_SYSTEM_ERROR, t1,
2380 "%s in cd(%s)", strerror(errno), Yap_FileNameBuf2);
2381 #else
2382 Yap_Error(OPERATING_SYSTEM_ERROR,t1," in cd(%s)", Yap_FileNameBuf2);
2383 #endif
2384 return FALSE;
2385 }
2386 return TRUE;
2387 #else
2388 #ifdef MACYAP
2389 return (!chdir (Yap_FileNameBuf2));
2390 #else
2391 Yap_Error(SYSTEM_ERROR,TermNil,"cd/1 not available in this machine");
2392 return FALSE;
2393 #endif
2394 #endif
2395 }
2396
2397 #ifdef MAC
2398
2399 void
2400 Yap_SetTextFile (name)
2401 char *name;
2402 {
2403 #ifdef MACC
2404 SetFileType (name, 'TEXT');
2405 SetFileSignature (name, 'EDIT');
2406 #else
2407 FInfo f;
2408 FInfo *p = &f;
2409 GetFInfo (name, 0, p);
2410 p->fdType = 'TEXT';
2411 #ifdef MPW
2412 if (mpwshell)
2413 p->fdCreator = 'MPS\0';
2414 #endif
2415 #ifndef LIGHT
2416 else
2417 p->fdCreator = 'EDIT';
2418 #endif
2419 SetFInfo (name, 0, p);
2420 #endif
2421 }
2422
2423 #endif
2424
2425
2426 /* return YAP's environment */
2427 static Int p_getenv(void)
2428 {
2429 #if HAVE_GETENV
2430 Term t1 = Deref(ARG1), to;
2431 char *s, *so;
2432
2433 if (IsVarTerm(t1)) {
2434 Yap_Error(INSTANTIATION_ERROR, t1,
2435 "first arg of getenv/2");
2436 return(FALSE);
2437 } else if (!IsAtomTerm(t1)) {
2438 Yap_Error(TYPE_ERROR_ATOM, t1,
2439 "first arg of getenv/2");
2440 return(FALSE);
2441 } else s = RepAtom(AtomOfTerm(t1))->StrOfAE;
2442 if ((so = getenv(s)) == NULL)
2443 return(FALSE);
2444 to = MkAtomTerm(Yap_LookupAtom(so));
2445 return(Yap_unify_constant(ARG2,to));
2446 #else
2447 Yap_Error(SYSTEM_ERROR, TermNil,
2448 "getenv not available in this configuration");
2449 return (FALSE);
2450 #endif
2451 }
2452
2453 /* set a variable in YAP's environment */
2454 static Int p_putenv(void)
2455 {
2456 #if HAVE_PUTENV
2457 Term t1 = Deref(ARG1), t2 = Deref(ARG2);
2458 char *s, *s2, *p0, *p;
2459
2460 if (IsVarTerm(t1)) {
2461 Yap_Error(INSTANTIATION_ERROR, t1,
2462 "first arg to putenv/2");
2463 return(FALSE);
2464 } else if (!IsAtomTerm(t1)) {
2465 Yap_Error(TYPE_ERROR_ATOM, t1,
2466 "first arg to putenv/2");
2467 return(FALSE);
2468 } else s = RepAtom(AtomOfTerm(t1))->StrOfAE;
2469 if (IsVarTerm(t2)) {
2470 Yap_Error(INSTANTIATION_ERROR, t1,
2471 "second arg to putenv/2");
2472 return(FALSE);
2473 } else if (!IsAtomTerm(t2)) {
2474 Yap_Error(TYPE_ERROR_ATOM, t2,
2475 "second arg to putenv/2");
2476 return(FALSE);
2477 } else s2 = RepAtom(AtomOfTerm(t2))->StrOfAE;
2478 while (!(p0 = p = Yap_AllocAtomSpace(strlen(s)+strlen(s2)+3))) {
2479 if (!Yap_growheap(FALSE, MinHeapGap, NULL)) {
2480 Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
2481 return FALSE;
2482 }
2483 }
2484 while ((*p++ = *s++) != '\0');
2485 p[-1] = '=';
2486 while ((*p++ = *s2++) != '\0');
2487 if (putenv(p0) == 0)
2488 return TRUE;
2489 #if HAVE_STRERROR
2490 Yap_Error(OPERATING_SYSTEM_ERROR, TermNil,
2491 "in putenv(%s)", strerror(errno), p0);
2492 #else
2493 Yap_Error(OPERATING_SYSTEM_ERROR, TermNil,
2494 "in putenv(%s)", p0);
2495 #endif
2496 return FALSE;
2497 #else
2498 Yap_Error(SYSTEM_ERROR, TermNil,
2499 "putenv not available in this configuration");
2500 return FALSE;
2501 #endif
2502 }
2503
2504 /* set a variable in YAP's environment */
2505 static Int p_file_age(void)
2506 {
2507 char *file_name = RepAtom(AtomOfTerm(Deref(ARG1)))->StrOfAE;
2508 if (strcmp(file_name,"user_input") == 0) {
2509 return(Yap_unify(ARG2,MkIntTerm(-1)));
2510 }
2511 #if HAVE_LSTAT
2512 {
2513 struct stat buf;
2514
2515 if (lstat(file_name, &buf) == -1) {
2516 /* file does not exist, but was opened? Return -1 */
2517 return(Yap_unify(ARG2, MkIntTerm(-1)));
2518 }
2519 return(Yap_unify(ARG2, MkIntegerTerm(buf.st_mtime)));
2520 }
2521 #elif defined(__MINGW32__) || _MSC_VER
2522 {
2523 struct _stat buf;
2524
2525 if (_stat(file_name, &buf) != 0) {
2526 /* return an error number */
2527 return(Yap_unify(ARG2, MkIntTerm(-1)));
2528 }
2529 return(Yap_unify(ARG2, MkIntegerTerm(buf.st_mtime)));
2530 }
2531 #else
2532 return(Yap_unify(ARG2, MkIntTerm(-1)));
2533 #endif
2534 }
2535
2536 /* wrapper for alarm system call */
2537 #if _MSC_VER || defined(__MINGW32__)
2538
2539 static DWORD WINAPI
2540 DoTimerThread(LPVOID targ)
2541 {
2542 Int *time = (Int *)targ;
2543 HANDLE htimer;
2544 LARGE_INTEGER liDueTime;
2545
2546 htimer = CreateWaitableTimer(NULL, FALSE, NULL);
2547 liDueTime.QuadPart = -10000000;
2548 liDueTime.QuadPart *= time[0];
2549 /* add time in usecs */
2550 liDueTime.QuadPart -= time[1]*10;
2551 /* Copy the relative time into a LARGE_INTEGER. */
2552 if (SetWaitableTimer(htimer, &liDueTime,0,NULL,NULL,0) == 0) {
2553 return(FALSE);
2554 }
2555 if (WaitForSingleObject(htimer, INFINITE) != WAIT_OBJECT_0)
2556 fprintf(stderr,"WaitForSingleObject failed (%ld)\n", GetLastError());
2557 Yap_signal (YAP_ALARM_SIGNAL);
2558 /* now, say what is going on */
2559 Yap_PutValue(AtomAlarm, MkAtomTerm(AtomTrue));
2560 ExitThread(1);
2561 #if _MSC_VER
2562 return(0L);
2563 #endif
2564 }
2565
2566 #endif
2567
2568 static Int
2569 p_alarm(void)
2570 {
2571 Term t = Deref(ARG1);
2572 Term t2 = Deref(ARG2);
2573 Int i1, i2;
2574 if (IsVarTerm(t)) {
2575 Yap_Error(INSTANTIATION_ERROR, t, "alarm/2");
2576 return(FALSE);
2577 }
2578 if (!IsIntegerTerm(t)) {
2579 Yap_Error(TYPE_ERROR_INTEGER, t, "alarm/2");
2580 return(FALSE);
2581 }
2582 if (IsVarTerm(t2)) {
2583 Yap_Error(INSTANTIATION_ERROR, t2, "alarm/2");
2584 return(FALSE);
2585 }
2586 if (!IsIntegerTerm(t2)) {
2587 Yap_Error(TYPE_ERROR_INTEGER, t2, "alarm/2");
2588 return(FALSE);
2589 }
2590 i1 = IntegerOfTerm(t);
2591 i2 = IntegerOfTerm(t2);
2592 if (i1 == 0 && i2 == 0) {
2593 LOCK(SignalLock);
2594 if (ActiveSignals & YAP_ALARM_SIGNAL) {
2595 ActiveSignals &= ~YAP_ALARM_SIGNAL;
2596 if (!ActiveSignals) {
2597 CreepFlag = CalculateStackGap();
2598 }
2599 }
2600 UNLOCK(SignalLock);
2601 }
2602 #if _MSC_VER || defined(__MINGW32__)
2603 {
2604 Term tout;
2605 Int time[2];
2606
2607 time[0] = i1;
2608 time[1] = i2;
2609
2610 if (time[0] != 0 && time[1] != 0) {
2611 DWORD dwThreadId;
2612 HANDLE hThread;
2613
2614 hThread = CreateThread(
2615 NULL, /* no security attributes */
2616 0, /* use default stack size */
2617 DoTimerThread, /* thread function */
2618 (LPVOID)time, /* argument to thread function */
2619 0, /* use default creation flags */
2620 &dwThreadId); /* returns the thread identifier */
2621
2622 /* Check the return value for success. */
2623 if (hThread == NULL) {
2624 Yap_WinError("trying to use alarm");
2625 }
2626 }
2627 tout = MkIntegerTerm(0);
2628 return Yap_unify(ARG3,tout) && Yap_unify(ARG4,MkIntTerm(0));
2629 }
2630 #elif HAVE_SETITIMER && !SUPPORT_CONDOR
2631 {
2632 struct itimerval new, old;
2633
2634 new.it_interval.tv_sec = 0;
2635 new.it_interval.tv_usec = 0;
2636 new.it_value.tv_sec = i1;
2637 new.it_value.tv_usec = i2;
2638 if (setitimer(ITIMER_REAL, &new, &old) < 0) {
2639 #if HAVE_STRERROR
2640 Yap_Error(OPERATING_SYSTEM_ERROR, ARG1, "setitimer: %s", strerror(errno));
2641 #else
2642 Yap_Error(OPERATING_SYSTEM_ERROR, ARG1, "setitimer %d", errno);
2643 #endif
2644 return FALSE;
2645 }
2646 return Yap_unify(ARG3,MkIntegerTerm(old.it_value.tv_sec)) &&
2647 Yap_unify(ARG4,MkIntegerTerm(old.it_value.tv_usec));
2648 }
2649 #elif HAVE_ALARM && !SUPPORT_CONDOR
2650 {
2651 Int left;
2652 Term tout;
2653
2654 left = alarm(i1);
2655 tout = MkIntegerTerm(left);
2656 return Yap_unify(ARG3,tout) && Yap_unify(ARG4,MkIntTerm(0)) ;
2657 }
2658 #else
2659 /* not actually trying to set the alarm */
2660 if (IntegerOfTerm(t) == 0)
2661 return TRUE;
2662 Yap_Error(SYSTEM_ERROR, TermNil,
2663 "alarm not available in this configuration");
2664 return FALSE;
2665 #endif
2666 }
2667
2668 static Int
2669 p_virtual_alarm(void)
2670 {
2671 Term t = Deref(ARG1);
2672 Term t2 = Deref(ARG2);
2673 if (IsVarTerm(t)) {
2674 Yap_Error(INSTANTIATION_ERROR, t, "alarm/2");
2675 return(FALSE);
2676 }
2677 if (!IsIntegerTerm(t)) {
2678 Yap_Error(TYPE_ERROR_INTEGER, t, "alarm/2");
2679 return(FALSE);
2680 }
2681 if (IsVarTerm(t2)) {
2682 Yap_Error(INSTANTIATION_ERROR, t2, "alarm/2");
2683 return(FALSE);
2684 }
2685 if (!IsIntegerTerm(t2)) {
2686 Yap_Error(TYPE_ERROR_INTEGER, t2, "alarm/2");
2687 return(FALSE);
2688 }
2689 #if _MSC_VER || defined(__MINGW32__)
2690 {
2691 Term tout;
2692 Int time[2];
2693
2694 time[0] = IntegerOfTerm(t);
2695 time[1] = IntegerOfTerm(t2);
2696
2697 if (time[0] != 0 && time[1] != 0) {
2698 DWORD dwThreadId;
2699 HANDLE hThread;
2700
2701 hThread = CreateThread(
2702 NULL, /* no security attributes */
2703 0, /* use default stack size */
2704 DoTimerThread, /* thread function */
2705 (LPVOID)time, /* argument to thread function */
2706 0, /* use default creation flags */
2707 &dwThreadId); /* returns the thread identifier */
2708
2709 /* Check the return value for success. */
2710 if (hThread == NULL) {
2711 Yap_WinError("trying to use alarm");
2712 }
2713 }
2714 tout = MkIntegerTerm(0);
2715 return Yap_unify(ARG3,tout) && Yap_unify(ARG4,MkIntTerm(0));
2716 }
2717 #elif HAVE_SETITIMER && !SUPPORT_CONDOR
2718 {
2719 struct itimerval new, old;
2720
2721 new.it_interval.tv_sec = 0;
2722 new.it_interval.tv_usec = 0;
2723 new.it_value.tv_sec = IntegerOfTerm(t);
2724 new.it_value.tv_usec = IntegerOfTerm(t2);
2725 if (setitimer(ITIMER_VIRTUAL, &new, &old) < 0) {
2726 #if HAVE_STRERROR
2727 Yap_Error(OPERATING_SYSTEM_ERROR, ARG1, "setitimer: %s", strerror(errno));
2728 #else
2729 Yap_Error(OPERATING_SYSTEM_ERROR, ARG1, "setitimer %d", errno);
2730 #endif
2731 return FALSE;
2732 }
2733 return Yap_unify(ARG3,MkIntegerTerm(old.it_value.tv_sec)) &&
2734 Yap_unify(ARG4,MkIntegerTerm(old.it_value.tv_usec));
2735 }
2736 #else
2737 /* not actually trying to set the alarm */
2738 if (IntegerOfTerm(t) == 0)
2739 return TRUE;
2740 Yap_Error(SYSTEM_ERROR, TermNil,
2741 "virtual_alarm not available in this configuration");
2742 return FALSE;
2743 #endif
2744 }
2745
2746 #if HAVE_FPU_CONTROL_H
2747 #include <fpu_control.h>
2748 #endif
2749
2750 /* by default Linux with glibc is IEEE compliant anyway..., but we will pretend it is not. */
2751 static void
2752 set_fpu_exceptions(int flag)
2753 {
2754 if (flag) {
2755 #if defined(__hpux)
2756 # if HAVE_FESETTRAPENABLE
2757 /* From HP-UX 11.0 onwards: */
2758 fesettrapenable(FE_INVALID|FE_DIVBYZERO|FE_OVERFLOW|FE_UNDERFLOW);
2759 # else
2760 /*
2761 Up until HP-UX 10.20:
2762 FP_X_INV invalid operation exceptions
2763 FP_X_DZ divide-by-zero exception
2764 FP_X_OFL overflow exception
2765 FP_X_UFL underflow exception
2766 FP_X_IMP imprecise (inexact result)
2767 FP_X_CLEAR simply zero to clear all flags
2768 */
2769 fpsetmask(FP_X_INV|FP_X_DZ|FP_X_OFL|FP_X_UFL);
2770 # endif
2771 #endif /* __hpux */
2772 #if HAVE_FPU_CONTROL_H && i386 && defined(__GNUC__)
2773 /* I shall ignore denormalization and precision errors */
2774 int v = _FPU_IEEE & ~(_FPU_MASK_IM|_FPU_MASK_ZM|_FPU_MASK_OM|_FPU_MASK_UM);
2775 _FPU_SETCW(v);
2776 #endif
2777 #if HAVE_FETESTEXCEPT
2778 feclearexcept(FE_ALL_EXCEPT);
2779 #endif
2780 my_signal (SIGFPE, HandleMatherr);
2781 } else {
2782 /* do IEEE arithmetic in the way the big boys do */
2783 #if defined(__hpux)
2784 # if HAVE_FESETTRAPENABLE
2785 fesettrapenable(FE_ALL_EXCEPT);
2786 # else
2787 fpsetmask(FP_X_CLEAR);
2788 # endif
2789 #endif /* __hpux */
2790 #if HAVE_FPU_CONTROL_H && i386 && defined(__GNUC__)
2791 /* this will probably not work in older releases of Linux */
2792 int v = _FPU_IEEE;
2793 _FPU_SETCW(v);
2794 #endif
2795 my_signal (SIGFPE, SIG_IGN);
2796 }
2797 }
2798
2799 void
2800 Yap_set_fpu_exceptions(int flag)
2801 {
2802 set_fpu_exceptions(flag);
2803 }
2804 static Int
2805 p_set_fpu_exceptions(void) {
2806 if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {
2807 set_fpu_exceptions(FALSE); /* can't make it work right */
2808 } else {
2809 set_fpu_exceptions(FALSE);
2810 }
2811 return(TRUE);
2812 }
2813
2814 static Int
2815 p_host_type(void) {
2816 Term out = MkAtomTerm(Yap_LookupAtom(HOST_ALIAS));
2817 return(Yap_unify(out,ARG1));
2818 }
2819
2820 static Int
2821 p_yap_home(void) {
2822 Term out = MkAtomTerm(Yap_LookupAtom(YAP_ROOTDIR));
2823 return(Yap_unify(out,ARG1));
2824 }
2825
2826 static Int
2827 p_env_separator(void) {
2828 #if defined(_WIN32)
2829 return Yap_unify(MkIntegerTerm(';'),ARG1);
2830 #else
2831 return Yap_unify(MkIntegerTerm(':'),ARG1);
2832 #endif
2833 }
2834
2835 /*
2836 * This is responsable for the initialization of all machine dependant
2837 * predicates
2838 */
2839 void
2840 Yap_InitSysbits (void)
2841 {
2842 #if __simplescalar__
2843 {
2844 char *pwd = getenv("PWD");
2845 strncpy(yap_pwd,pwd,YAP_FILENAME_MAX);
2846 }
2847 #endif
2848 InitPageSize();
2849 InitWTime ();
2850 InitRandom ();
2851 /* let the caller control signals as it sees fit */
2852 InitSignals ();
2853 }
2854
2855 void
2856 Yap_InitTime(void)
2857 {
2858 InitTime();
2859 }
2860
2861 void
2862 Yap_ReInitWallTime (void)
2863 {
2864 InitWTime();
2865 if (Yap_heap_regs->last_wtime != NULL)
2866 Yap_FreeCodeSpace(Yap_heap_regs->last_wtime);
2867 InitLastWtime();
2868 }
2869
2870 static Int
2871 p_first_signal(void)
2872 {
2873 LOCK(SignalLock);
2874 #ifdef THREADS
2875 pthread_mutex_lock(&(MY_ThreadHandle.tlock));
2876 #endif
2877 /* always do wakeups first, because you don't want to keep the
2878 non-backtrackable variable bad */
2879 if (ActiveSignals & YAP_WAKEUP_SIGNAL) {
2880 ActiveSignals &= ~YAP_WAKEUP_SIGNAL;
2881 #ifdef THREADS
2882 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2883 #endif
2884 UNLOCK(SignalLock);
2885 return Yap_unify(ARG1, MkAtomTerm(AtomSigWakeUp));
2886 }
2887 if (ActiveSignals & YAP_ITI_SIGNAL) {
2888 ActiveSignals &= ~YAP_ITI_SIGNAL;
2889 #ifdef THREADS
2890 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2891 #endif
2892 UNLOCK(SignalLock);
2893 return Yap_unify(ARG1, MkAtomTerm(AtomSigIti));
2894 }
2895 if (ActiveSignals & YAP_INT_SIGNAL) {
2896 ActiveSignals &= ~YAP_INT_SIGNAL;
2897 #ifdef THREADS
2898 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2899 #endif
2900 UNLOCK(SignalLock);
2901 return Yap_unify(ARG1, MkAtomTerm(AtomSigInt));
2902 }
2903 if (ActiveSignals & YAP_USR2_SIGNAL) {
2904 ActiveSignals &= ~YAP_USR2_SIGNAL;
2905 #ifdef THREADS
2906 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2907 #endif
2908 UNLOCK(SignalLock);
2909 return Yap_unify(ARG1, MkAtomTerm(AtomSigUsr2));
2910 }
2911 if (ActiveSignals & YAP_USR1_SIGNAL) {
2912 ActiveSignals &= ~YAP_USR1_SIGNAL;
2913 #ifdef THREADS
2914 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2915 #endif
2916 UNLOCK(SignalLock);
2917 return Yap_unify(ARG1, MkAtomTerm(AtomSigUsr1));
2918 }
2919 if (ActiveSignals & YAP_PIPE_SIGNAL) {
2920 ActiveSignals &= ~YAP_PIPE_SIGNAL;
2921 #ifdef THREADS
2922 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2923 #endif
2924 UNLOCK(SignalLock);
2925 return Yap_unify(ARG1, MkAtomTerm(AtomSigPipe));
2926 }
2927 if (ActiveSignals & YAP_HUP_SIGNAL) {
2928 ActiveSignals &= ~YAP_HUP_SIGNAL;
2929 #ifdef THREADS
2930 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2931 #endif
2932 UNLOCK(SignalLock);
2933 return Yap_unify(ARG1, MkAtomTerm(AtomSigHup));
2934 }
2935 if (ActiveSignals & YAP_ALARM_SIGNAL) {
2936 ActiveSignals &= ~YAP_ALARM_SIGNAL;
2937 UNLOCK(SignalLock);
2938 return Yap_unify(ARG1, MkAtomTerm(AtomSigAlarm));
2939 }
2940 if (ActiveSignals & YAP_VTALARM_SIGNAL) {
2941 ActiveSignals &= ~YAP_VTALARM_SIGNAL;
2942 UNLOCK(SignalLock);
2943 return Yap_unify(ARG1, MkAtomTerm(AtomSigVTAlarm));
2944 }
2945 if (ActiveSignals & YAP_DELAY_CREEP_SIGNAL) {
2946 ActiveSignals &= ~(YAP_CREEP_SIGNAL|YAP_DELAY_CREEP_SIGNAL);
2947 #ifdef THREADS
2948 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2949 #endif
2950 UNLOCK(SignalLock);
2951 return Yap_unify(ARG1, MkAtomTerm(AtomSigDelayCreep));
2952 }
2953 if (ActiveSignals & YAP_CREEP_SIGNAL) {
2954 ActiveSignals &= ~YAP_CREEP_SIGNAL;
2955 #ifdef THREADS
2956 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2957 #endif
2958 UNLOCK(SignalLock);
2959 return Yap_unify(ARG1, MkAtomTerm(AtomSigCreep));
2960 }
2961 if (ActiveSignals & YAP_TRACE_SIGNAL) {
2962 ActiveSignals &= ~YAP_TRACE_SIGNAL;
2963 #ifdef THREADS
2964 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2965 #endif
2966 UNLOCK(SignalLock);
2967 return Yap_unify(ARG1, MkAtomTerm(AtomSigTrace));
2968 }
2969 if (ActiveSignals & YAP_DEBUG_SIGNAL) {
2970 ActiveSignals &= ~YAP_DEBUG_SIGNAL;
2971 #ifdef THREADS
2972 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2973 #endif
2974 UNLOCK(SignalLock);
2975 return Yap_unify(ARG1, MkAtomTerm(AtomSigDebug));
2976 }
2977 if (ActiveSignals & YAP_BREAK_SIGNAL) {
2978 ActiveSignals &= ~YAP_BREAK_SIGNAL;
2979 #ifdef THREADS
2980 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2981 #endif
2982 UNLOCK(SignalLock);
2983 return Yap_unify(ARG1, MkAtomTerm(AtomSigBreak));
2984 }
2985 if (ActiveSignals & YAP_STACK_DUMP_SIGNAL) {
2986 ActiveSignals &= ~YAP_STACK_DUMP_SIGNAL;
2987 #ifdef THREADS
2988 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2989 #endif
2990 UNLOCK(SignalLock);
2991 return Yap_unify(ARG1, MkAtomTerm(AtomSigStackDump));
2992 }
2993 if (ActiveSignals & YAP_STATISTICS_SIGNAL) {
2994 ActiveSignals &= ~YAP_STATISTICS_SIGNAL;
2995 #ifdef THREADS
2996 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
2997 #endif
2998 UNLOCK(SignalLock);
2999 return Yap_unify(ARG1, MkAtomTerm(AtomSigStatistics));
3000 }
3001 if (ActiveSignals & YAP_FAIL_SIGNAL) {
3002 ActiveSignals &= ~YAP_FAIL_SIGNAL;
3003 #ifdef THREADS
3004 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
3005 #endif
3006 UNLOCK(SignalLock);
3007 return Yap_unify(ARG1, MkAtomTerm(AtomFail));
3008 }
3009 #ifdef THREADS
3010 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
3011 #endif
3012 UNLOCK(SignalLock);
3013 return FALSE;
3014 }
3015
3016 static Int
3017 p_continue_signals(void)
3018 {
3019 /* hack to force the signal anew */
3020 if (ActiveSignals & YAP_ITI_SIGNAL) {
3021 Yap_signal(YAP_ITI_SIGNAL);
3022 }
3023 if (ActiveSignals & YAP_INT_SIGNAL) {
3024 Yap_signal(YAP_INT_SIGNAL);
3025 }
3026 if (ActiveSignals & YAP_USR2_SIGNAL) {
3027 Yap_signal(YAP_USR2_SIGNAL);
3028 }
3029 if (ActiveSignals & YAP_USR1_SIGNAL) {
3030 Yap_signal(YAP_USR1_SIGNAL);
3031 }
3032 if (ActiveSignals & YAP_HUP_SIGNAL) {
3033 Yap_signal(YAP_HUP_SIGNAL);
3034 }
3035 if (ActiveSignals & YAP_ALARM_SIGNAL) {
3036 Yap_signal(YAP_ALARM_SIGNAL);
3037 }
3038 if (ActiveSignals & YAP_VTALARM_SIGNAL) {
3039 Yap_signal(YAP_VTALARM_SIGNAL);
3040 }
3041 if (ActiveSignals & YAP_CREEP_SIGNAL) {
3042 Yap_signal(YAP_CREEP_SIGNAL);
3043 }
3044 if (ActiveSignals & YAP_DELAY_CREEP_SIGNAL) {
3045 Yap_signal(YAP_DELAY_CREEP_SIGNAL|YAP_CREEP_SIGNAL);
3046 }
3047 if (ActiveSignals & YAP_TRACE_SIGNAL) {
3048 Yap_signal(YAP_TRACE_SIGNAL);
3049 }
3050 if (ActiveSignals & YAP_DEBUG_SIGNAL) {
3051 Yap_signal(YAP_DEBUG_SIGNAL);
3052 }
3053 if (ActiveSignals & YAP_BREAK_SIGNAL) {
3054 Yap_signal(YAP_BREAK_SIGNAL);
3055 }
3056 if (ActiveSignals & YAP_STACK_DUMP_SIGNAL) {
3057 Yap_signal(YAP_STACK_DUMP_SIGNAL);
3058 }
3059 if (ActiveSignals & YAP_STATISTICS_SIGNAL) {
3060 Yap_signal(YAP_STATISTICS_SIGNAL);
3061 }
3062 if (ActiveSignals & YAP_FAIL_SIGNAL) {
3063 Yap_signal(YAP_FAIL_SIGNAL);
3064 }
3065 #ifdef THREADS
3066 pthread_mutex_unlock(&(MY_ThreadHandle.tlock));
3067 #endif
3068 return TRUE;
3069 }
3070
3071 static Int
3072 p_unix(void)
3073 {
3074 #ifdef unix
3075 return TRUE;
3076 #else
3077 #ifdef __unix__
3078 return TRUE;
3079 #else
3080 #ifdef __APPLE__
3081 return TRUE;
3082 #else
3083 return FALSE;
3084 #endif
3085 #endif
3086 #endif
3087 }
3088
3089 static Int
3090 p_win32(void)
3091 {
3092 #ifdef _WIN32
3093 return TRUE;
3094 #else
3095 #ifdef __CYGWIN__
3096 return TRUE;
3097 #else
3098 return FALSE;
3099 #endif
3100 #endif
3101 }
3102
3103
3104 static Int
3105 p_enable_interrupts(void)
3106 {
3107 LOCK(SignalLock);
3108 Yap_InterruptsDisabled--;
3109 if (ActiveSignals && !Yap_InterruptsDisabled) {
3110 CreepFlag = Unsigned(LCL0);
3111 }
3112 UNLOCK(SignalLock);
3113 return TRUE;
3114 }
3115
3116 static Int
3117 p_disable_interrupts(void)
3118 {
3119 LOCK(SignalLock);
3120 Yap_InterruptsDisabled++;
3121 if (ActiveSignals) {
3122 CreepFlag = CalculateStackGap();
3123 }
3124 UNLOCK(SignalLock);
3125 return TRUE;
3126 }
3127
3128 static Int
3129 p_ld_path(void)
3130 {
3131 return Yap_unify(ARG1,MkAtomTerm(Yap_LookupAtom(YAP_LIBDIR)));
3132 }
3133
3134 static Int
3135 p_address_bits(void)
3136 {
3137 #if SIZEOF_INT_P==4
3138 return Yap_unify(ARG1,MkIntTerm(32));
3139 #else
3140 return Yap_unify(ARG1,MkIntTerm(64));
3141 #endif
3142 }
3143
3144
3145
3146 #ifdef _WIN32
3147
3148 /* This code is from SWI-Prolog by Jan Wielemaker */
3149
3150 #define wstreq(s,q) (wcscmp((s), (q)) == 0)
3151
3152 static HKEY
3153 reg_open_key(const wchar_t *which, int create)
3154 { HKEY key = HKEY_CURRENT_USER;
3155 DWORD disp;
3156 LONG rval;
3157
3158 while(*which)
3159 { wchar_t buf[256];
3160 wchar_t *s;
3161 HKEY tmp;
3162
3163 for(s=buf; *which && !(*which == '/' || *which == '\\'); )
3164 *s++ = *which++;
3165 *s = '\0';
3166 if ( *which )
3167 which++;
3168
3169 if ( wstreq(buf, L"HKEY_CLASSES_ROOT") )
3170 { key = HKEY_CLASSES_ROOT;
3171 continue;
3172 } else if ( wstreq(buf, L"HKEY_CURRENT_USER") )
3173 { key = HKEY_CURRENT_USER;
3174 continue;
3175 } else if ( wstreq(buf, L"HKEY_LOCAL_MACHINE") )
3176 { key = HKEY_LOCAL_MACHINE;
3177 continue;
3178 } else if ( wstreq(buf, L"HKEY_USERS") )
3179 { key = HKEY_USERS;
3180 continue;
3181 }
3182
3183 if ( RegOpenKeyExW(key, buf, 0L, KEY_READ, &tmp) == ERROR_SUCCESS )
3184 { RegCloseKey(key);
3185 key = tmp;
3186 continue;
3187 }
3188
3189 if ( !create )
3190 return NULL;
3191
3192 rval = RegCreateKeyExW(key, buf, 0, L"", 0,
3193 KEY_ALL_ACCESS, NULL, &tmp, &disp);
3194 RegCloseKey(key);
3195 if ( rval == ERROR_SUCCESS )
3196 key = tmp;
3197 else
3198 return NULL;
3199 }
3200
3201 return key;
3202 }
3203
3204 #define MAXREGSTRLEN 1024
3205
3206 static void
3207 recover_space(wchar_t *k, Atom At)
3208 {
3209 if (At->WStrOfAE != k)
3210 Yap_FreeCodeSpace((char *)k);
3211 }
3212
3213 static wchar_t *
3214 WideStringFromAtom(Atom KeyAt)
3215 {
3216 if (IsWideAtom(KeyAt)) {
3217 return KeyAt->WStrOfAE;
3218 } else {
3219 int len = strlen(KeyAt->StrOfAE);
3220 int sz = sizeof(wchar_t)*(len+1);
3221 char *chp = KeyAt->StrOfAE;
3222 wchar_t *kptr, *k;
3223
3224 k = (wchar_t *)Yap_AllocCodeSpace(sz);
3225 while (k == NULL) {
3226 if (!Yap_growheap(FALSE, sz, NULL)) {
3227 Yap_Error(OUT_OF_HEAP_ERROR, MkIntegerTerm(sz), "generating key in win_registry_get_value/3");
3228 return FALSE;
3229 }
3230 }
3231 kptr = k;
3232 while ((*kptr++ = *chp++));
3233 return k;
3234 }
3235 }
3236
3237 static Int
3238 p_win_registry_get_value(void)
3239 {
3240 DWORD type;
3241 BYTE data[MAXREGSTRLEN];
3242 DWORD len = sizeof(data);
3243 wchar_t *k, *name;
3244 HKEY key;
3245 Term Key = Deref(ARG1);
3246 Term Name = Deref(ARG2);
3247 Atom KeyAt, NameAt;
3248
3249 if (IsVarTerm(Key)) {
3250 Yap_Error(INSTANTIATION_ERROR,Key,"argument to win_registry_get_value unbound");
3251 return FALSE;
3252 }
3253 if (!IsAtomTerm(Key)) {
3254 Yap_Error(TYPE_ERROR_ATOM,Key,"argument to win_registry_get_value");
3255 return FALSE;
3256 }
3257 KeyAt = AtomOfTerm(Key);
3258 if (IsVarTerm(Name)) {
3259 Yap_Error(INSTANTIATION_ERROR,Key,"argument to win_registry_get_value unbound");
3260 return FALSE;
3261 }
3262 if (!IsAtomTerm(Name)) {
3263 Yap_Error(TYPE_ERROR_ATOM,Key,"argument to win_registry_get_value");
3264 return FALSE;
3265 }
3266 NameAt = AtomOfTerm(Name);
3267
3268 k = WideStringFromAtom(KeyAt);
3269 if ( !(key=reg_open_key(k, FALSE)) ) {
3270 Yap_Error(EXISTENCE_ERROR_KEY, Key, "argument to win_registry_get_value");
3271 recover_space(k, KeyAt);
3272 return FALSE;
3273 }
3274 name = WideStringFromAtom(NameAt);
3275
3276 if ( RegQueryValueExW(key, name, NULL, &type, data, &len) == ERROR_SUCCESS ) {
3277 RegCloseKey(key);
3278 switch(type) {
3279 case REG_SZ:
3280 recover_space(k, KeyAt);
3281 recover_space(name, NameAt);
3282 ((wchar_t *)data)[len] = '\0';
3283 return Yap_unify(MkAtomTerm(Yap_LookupMaybeWideAtom((wchar_t *)data)),ARG3);
3284 case REG_DWORD:
3285 recover_space(k, KeyAt);
3286 recover_space(name, NameAt);
3287 {
3288 DWORD *d = (DWORD *)data;
3289 return Yap_unify(MkIntegerTerm((Int)d[0]),ARG3);
3290 }
3291 default:
3292 recover_space(k, KeyAt);
3293 recover_space(name, NameAt);
3294 return FALSE;
3295 }
3296 }
3297 recover_space(k, KeyAt);
3298 recover_space(name, NameAt);
3299 return FALSE;
3300 }
3301
3302 char *
3303 Yap_RegistryGetString(char *name)
3304 {
3305 DWORD type;
3306 BYTE data[MAXREGSTRLEN];
3307 DWORD len = sizeof(data);
3308 HKEY key;
3309 char *ptr;
3310 int i;
3311
3312 #if SIZEOF_INT_P==8
3313 #define EXTRA "64"
3314 #else
3315 #define EXTRA ""
3316 #endif
3317 if ( (key=reg_open_key(L"HKEY_CURRENT_USER/SOFTWARE/YAP/Prolog" EXTRA "", FALSE)) &&
3318 (RegQueryValueEx(key, name, NULL, &type, data, &len) == ERROR_SUCCESS) ) {
3319 RegCloseKey(key);
3320 switch(type) {
3321 case REG_SZ:
3322 ptr = malloc(len+2);
3323 if (!ptr)
3324 return NULL;
3325 for (i=0; i<= len; i++)
3326 ptr[i] = data[i];
3327 ptr[len+1] = '\0';
3328 return ptr;
3329 default:
3330 return NULL;
3331 }
3332 } else if ( (key=reg_open_key(L"HKEY_LOCAL_MACHINE/SOFTWARE/YAP/Prolog" EXTRA "", FALSE)) &&
3333 (RegQueryValueEx(key, name, NULL, &type, data, &len) == ERROR_SUCCESS) ) {
3334 RegCloseKey(key);
3335 switch(type) {
3336 case REG_SZ:
3337 ptr = malloc(len+2);
3338 if (!ptr)
3339 return NULL;
3340 for (i=0; i<= len; i++)
3341 ptr[i] = data[i];
3342 ptr[len+1] = '\0';
3343 return ptr;
3344 default:
3345 return NULL;
3346 }
3347 }
3348 return NULL;
3349 }
3350
3351
3352 #endif
3353
3354 void
3355 Yap_InitSysPreds(void)
3356 {
3357 Term cm = CurrentModule;
3358
3359 /* can only do after heap is initialised */
3360 InitLastWtime();
3361 Yap_InitCPred ("srandom", 1, p_srandom, SafePredFlag);
3362 Yap_InitCPred ("sh", 0, p_sh, SafePredFlag|SyncPredFlag);
3363 Yap_InitCPred ("$shell", 1, p_shell, SafePredFlag|SyncPredFlag|HiddenPredFlag);
3364 Yap_InitCPred ("system", 1, p_system, SafePredFlag|SyncPredFlag);
3365 Yap_InitCPred ("rename", 2, p_mv, SafePredFlag|SyncPredFlag);
3366 Yap_InitCPred ("cd", 1, p_cd, SafePredFlag|SyncPredFlag|HiddenPredFlag);
3367 Yap_InitCPred ("$yap_home", 1, p_yap_home, SafePredFlag|SyncPredFlag|HiddenPredFlag);
3368 Yap_InitCPred ("getcwd", 1, p_getcwd, SafePredFlag|SyncPredFlag);
3369 Yap_InitCPred ("$dir_separator", 1, p_dir_sp, SafePredFlag|HiddenPredFlag);
3370 Yap_InitCPred ("$alarm", 4, p_alarm, SafePredFlag|SyncPredFlag|HiddenPredFlag);
3371 Yap_InitCPred ("$getenv", 2, p_getenv, SafePredFlag|HiddenPredFlag);
3372 Yap_InitCPred ("$putenv", 2, p_putenv, SafePredFlag|SyncPredFlag|HiddenPredFlag);
3373 Yap_InitCPred ("$file_age", 2, p_file_age, SafePredFlag|SyncPredFlag|HiddenPredFlag);
3374 Yap_InitCPred ("$set_fpu_exceptions", 0, p_set_fpu_exceptions, SafePredFlag|SyncPredFlag|HiddenPredFlag);
3375 Yap_InitCPred ("$first_signal", 1, p_first_signal, SafePredFlag|SyncPredFlag|HiddenPredFlag);
3376 Yap_InitCPred ("$host_type", 1, p_host_type, SafePredFlag|SyncPredFlag|HiddenPredFlag);
3377 Yap_InitCPred ("$continue_signals", 0, p_continue_signals, SafePredFlag|SyncPredFlag|HiddenPredFlag);
3378 Yap_InitCPred ("file_directory_name", 2, p_file_directory_name, SafePredFlag);
3379 Yap_InitCPred ("$env_separator", 1, p_env_separator, SafePredFlag);
3380 Yap_InitCPred ("$unix", 0, p_unix, SafePredFlag);
3381 Yap_InitCPred ("$win32", 0, p_win32, SafePredFlag);
3382 Yap_InitCPred ("$ld_path", 1, p_ld_path, SafePredFlag);
3383 Yap_InitCPred ("$address_bits", 1, p_address_bits, SafePredFlag);
3384 #ifdef _WIN32
3385 Yap_InitCPred ("win_registry_get_value", 3, p_win_registry_get_value,0);
3386 #endif
3387 CurrentModule = HACKS_MODULE;
3388 Yap_InitCPred ("virtual_alarm", 4, p_virtual_alarm, SafePredFlag|SyncPredFlag|HiddenPredFlag);
3389 Yap_InitCPred ("enable_interrupts", 0, p_enable_interrupts, SafePredFlag);
3390 Yap_InitCPred ("disable_interrupts", 0, p_disable_interrupts, SafePredFlag);
3391 CurrentModule = OPERATING_SYSTEM_MODULE;
3392 Yap_InitCPred ("true_file_name", 2, p_true_file_name, SyncPredFlag);
3393 Yap_InitCPred ("true_file_name", 3, p_true_file_name3, SyncPredFlag);
3394 CurrentModule = cm;
3395 }
3396
3397
3398 #ifdef VAX
3399
3400 /* avoid longjmp botch */
3401
3402 int vax_absmi_fp;
3403
3404 typedef struct
3405 {
3406 int eh;
3407 int flgs;
3408 int ap;
3409 int fp;
3410 int pc;
3411 int dummy1;
3412 int dummy2;
3413 int dummy3;
3414 int oldfp;
3415 int dummy4;
3416 int dummy5;
3417 int dummy6;
3418 int oldpc;
3419 }
3420
3421 *VaxFramePtr;
3422
3423
3424 VaxFixFrame (dummy)
3425 {
3426 int maxframes = 100;
3427 VaxFramePtr fp = (VaxFramePtr) (((int *) &dummy) - 6);
3428 while (--maxframes)
3429 {
3430 fp = (VaxFramePtr) fp->fp;
3431 if (fp->flgs == 0)
3432 {
3433 if (fp->oldfp >= ®S[6] && fp->oldfp < ®S[REG_SIZE])
3434 fp->oldfp = vax_absmi_fp;
3435 return;
3436 }
3437 }
3438 }
3439
3440 #endif
3441
3442
3443 #if defined(_WIN32)
3444
3445 #include <windows.h>
3446
3447 int WINAPI STD_PROTO(win_yap, (HANDLE, DWORD, LPVOID));
3448
3449 int WINAPI win_yap(HANDLE hinst, DWORD reason, LPVOID reserved)
3450 {
3451 switch (reason)
3452 {
3453 case DLL_PROCESS_ATTACH:
3454 break;
3455 case DLL_PROCESS_DETACH:
3456 break;
3457 case DLL_THREAD_ATTACH:
3458 break;
3459 case DLL_THREAD_DETACH:
3460 break;
3461 }
3462 return 1;
3463 }
3464 #endif
3465
3466 #if (defined(YAPOR) || defined(THREADS)) && !defined(USE_PTHREAD_LOCKING)
3467 #ifdef sparc
3468 void STD_PROTO(rw_lock_voodoo,(void));
3469
3470 void
3471 rw_lock_voodoo(void) {
3472 /* code taken from the Linux kernel, it handles shifting between locks */
3473 /* Read/writer locks, as usual this is overly clever to make it as fast as possible. */
3474 /* caches... */
3475 __asm__ __volatile__(
3476 "___rw_read_enter_spin_on_wlock:\n"
3477 " orcc %g2, 0x0, %g0\n"
3478 " be,a ___rw_read_enter\n"
3479 " ldstub [%g1 + 3], %g2\n"
3480 " b ___rw_read_enter_spin_on_wlock\n"
3481 " ldub [%g1 + 3], %g2\n"
3482 "___rw_read_exit_spin_on_wlock:\n"
3483 " orcc %g2, 0x0, %g0\n"
3484 " be,a ___rw_read_exit\n"
3485 " ldstub [%g1 + 3], %g2\n"
3486 " b ___rw_read_exit_spin_on_wlock\n"
3487 " ldub [%g1 + 3], %g2\n"
3488 "___rw_write_enter_spin_on_wlock:\n"
3489 " orcc %g2, 0x0, %g0\n"
3490 " be,a ___rw_write_enter\n"
3491 " ldstub [%g1 + 3], %g2\n"
3492 " b ___rw_write_enter_spin_on_wlock\n"
3493 " ld [%g1], %g2\n"
3494 "\n"
3495 " .globl ___rw_read_enter\n"
3496 "___rw_read_enter:\n"
3497 " orcc %g2, 0x0, %g0\n"
3498 " bne,a ___rw_read_enter_spin_on_wlock\n"
3499 " ldub [%g1 + 3], %g2\n"
3500 " ld [%g1], %g2\n"
3501 " add %g2, 1, %g2\n"
3502 " st %g2, [%g1]\n"
3503 " retl\n"
3504 " mov %g4, %o7\n"
3505 " .globl ___rw_read_exit\n"
3506 "___rw_read_exit:\n"
3507 " orcc %g2, 0x0, %g0\n"
3508 " bne,a ___rw_read_exit_spin_on_wlock\n"
3509 " ldub [%g1 + 3], %g2\n"
3510 " ld [%g1], %g2\n"
3511 " sub %g2, 0x1ff, %g2\n"
3512 " st %g2, [%g1]\n"
3513 " retl\n"
3514 " mov %g4, %o7\n"
3515 " .globl ___rw_write_enter\n"
3516 "___rw_write_enter:\n"
3517 " orcc %g2, 0x0, %g0\n"
3518 " bne ___rw_write_enter_spin_on_wlock\n"
3519 " ld [%g1], %g2\n"
3520 " andncc %g2, 0xff, %g0\n"
3521 " bne,a ___rw_write_enter_spin_on_wlock\n"
3522 " stb %g0, [%g1 + 3]\n"
3523 " retl\n"
3524 " mov %g4, %o7\n"
3525 );
3526 }
3527 #endif /* sparc */
3528
3529
3530 #endif /* YAPOR || THREADS */
3531