source: trunk/source/lisp-kernel/windows-calls.c @ 12714

Last change on this file since 12714 was 12714, checked in by palter, 10 years ago

Fix GET-INTERNAL-REAL-TIME on Windows. The kernel function wasn't properly
converting from microseconds to milliseconds, reducing the resolution
of GET-INTERNAL-REAL-TIME to 1 second.

New Win32 executable. Could someone please build an Win64 executable?

File size: 21.1 KB
Line 
1/*
2   Copyright (C) 2008, Clozure Associates and contributors,
3   This file is part of Clozure CL. 
4
5   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with Clozure CL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with Clozure CL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   Clozure CL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "x86-exceptions.h"
19#include <io.h>
20#include <unistd.h>
21#include <sys/fcntl.h>
22#include <errno.h>
23#include <sys/stat.h>
24#include <windows.h>
25#include <psapi.h>
26#include <dirent.h>
27#include <signal.h>
28#undef __argv
29#include <stdio.h>
30#include <math.h>
31
32#ifndef WIN_32
33#define _dosmaperr mingw_dosmaperr
34#else
35void
36_dosmaperr(unsigned long oserrno)
37{
38  switch(oserrno) {
39  case  ERROR_INVALID_FUNCTION:
40    errno = EINVAL;
41    break;
42  case ERROR_FILE_NOT_FOUND:
43    errno = ENOENT;
44    break;
45  case ERROR_PATH_NOT_FOUND:
46    errno = ENOENT;
47    break;
48  case  ERROR_TOO_MANY_OPEN_FILES:
49    errno = EMFILE;
50    break;
51  case  ERROR_ACCESS_DENIED:
52    errno = EACCES;
53    break;
54  case  ERROR_ARENA_TRASHED:
55    errno = ENOMEM;
56    break;
57  case  ERROR_NOT_ENOUGH_MEMORY:
58    errno = ENOMEM;
59    break;
60  case  ERROR_INVALID_BLOCK:
61    errno = ENOMEM;
62    break;
63  case  ERROR_BAD_ENVIRONMENT:
64    errno = E2BIG;
65    break;
66  case  ERROR_BAD_FORMAT:
67    errno = ENOEXEC;
68    break;
69  case  ERROR_INVALID_ACCESS:
70    errno = EINVAL;
71    break;
72  case  ERROR_INVALID_DATA:
73    errno = EINVAL;
74    break;
75  case  ERROR_INVALID_DRIVE:
76    errno = ENOENT;
77    break;
78  case  ERROR_CURRENT_DIRECTORY:
79    errno = EACCES;
80    break;
81  case  ERROR_NOT_SAME_DEVICE:
82    errno = EXDEV;
83    break;
84  case  ERROR_NO_MORE_FILES:
85    errno = ENOENT;
86    break;
87  case  ERROR_LOCK_VIOLATION:
88    errno = EACCES;
89    break;
90  case  ERROR_BAD_NETPATH:
91    errno = ENOENT;
92    break;
93  case  ERROR_NETWORK_ACCESS_DENIED:
94    errno = EACCES;
95    break;
96  case  ERROR_BAD_NET_NAME:
97    errno = ENOENT;
98    break;
99  case  ERROR_FILE_EXISTS:
100    errno = EEXIST;
101    break;
102  case  ERROR_CANNOT_MAKE:
103    errno = EACCES;
104    break;
105  case  ERROR_FAIL_I24:
106    errno = EACCES;
107    break;
108  case  ERROR_INVALID_PARAMETER:
109    errno = EINVAL;
110    break;
111  case  ERROR_NO_PROC_SLOTS:
112    errno = EAGAIN;
113    break;
114  case  ERROR_DRIVE_LOCKED:
115    errno = EACCES;
116    break;
117  case  ERROR_BROKEN_PIPE:
118    errno = EPIPE;
119    break;
120  case  ERROR_DISK_FULL:
121    errno = ENOSPC;
122    break;
123  case  ERROR_INVALID_TARGET_HANDLE:
124    errno = EBADF;
125    break;
126  case  ERROR_INVALID_HANDLE:
127    errno = EINVAL;
128    break;
129  case  ERROR_WAIT_NO_CHILDREN:
130    errno = ECHILD;
131    break;
132  case  ERROR_CHILD_NOT_COMPLETE:
133    errno = ECHILD;
134    break;
135  case  ERROR_DIRECT_ACCESS_HANDLE:
136    errno = EBADF;
137    break;
138  case  ERROR_NEGATIVE_SEEK:
139    errno = EINVAL;
140    break;
141  case  ERROR_SEEK_ON_DEVICE:   
142    errno = EACCES;
143    break;
144  case  ERROR_DIR_NOT_EMPTY:
145    errno = ENOTEMPTY;
146    break;
147  case  ERROR_NOT_LOCKED:
148    errno = EACCES;
149    break;
150  case  ERROR_BAD_PATHNAME:
151    errno = ENOENT;
152    break;
153  case  ERROR_MAX_THRDS_REACHED:
154    errno = EAGAIN;
155    break;
156  case  ERROR_LOCK_FAILED:
157    errno = EACCES;
158    break;
159  case  ERROR_ALREADY_EXISTS:
160    errno = EEXIST;
161    break;
162  case  ERROR_FILENAME_EXCED_RANGE:
163    errno = ENOENT;
164    break;
165  case  ERROR_NESTING_NOT_ALLOWED:
166    errno = EAGAIN;
167    break;
168  case  ERROR_NOT_ENOUGH_QUOTA:
169    errno = ENOMEM;
170    break;
171  case ERROR_OPERATION_ABORTED:
172    errno = EINTR;
173    break;
174  default:
175    errno = EINVAL;
176    break;
177  }
178}
179   
180#endif
181
182#define MAX_FD 32
183
184HANDLE
185lisp_open(wchar_t *path, int flag, int mode)
186{
187  HANDLE hfile;
188  DWORD dwDesiredAccess = 0;
189  DWORD dwShareMode = 0;
190  DWORD dwCreationDistribution = 0;
191  DWORD dwFlagsAndAttributes = 0;
192  SECURITY_ATTRIBUTES sa = {sizeof(SECURITY_ATTRIBUTES), NULL, TRUE};
193
194  dwShareMode = FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE;
195
196  if ((flag & _O_WRONLY) == _O_WRONLY) {
197    dwDesiredAccess |= GENERIC_WRITE | FILE_WRITE_DATA |
198      FILE_READ_ATTRIBUTES | FILE_WRITE_ATTRIBUTES;
199  } else if ((flag & _O_RDWR) == _O_RDWR) {
200    dwDesiredAccess |= GENERIC_WRITE|GENERIC_READ | FILE_READ_DATA |
201      FILE_WRITE_DATA | FILE_READ_ATTRIBUTES | FILE_WRITE_ATTRIBUTES;
202  } else {
203    dwDesiredAccess |= GENERIC_READ | FILE_READ_DATA | FILE_READ_ATTRIBUTES |
204      FILE_WRITE_ATTRIBUTES;
205  }
206   
207
208  if ((flag & (_O_CREAT | _O_EXCL)) == (_O_CREAT | _O_EXCL)) {
209    dwCreationDistribution |= CREATE_NEW;
210  } else if ((flag &  O_TRUNC) == O_TRUNC) {
211    if ((flag &  O_CREAT) ==  O_CREAT) {
212      dwCreationDistribution |= CREATE_ALWAYS;
213    } else if ((flag & O_RDONLY) != O_RDONLY) {
214      dwCreationDistribution |= TRUNCATE_EXISTING;
215    }
216  } else if ((flag & _O_APPEND) == _O_APPEND) {
217    dwCreationDistribution |= OPEN_EXISTING;
218  } else if ((flag &  _O_CREAT) == _O_CREAT) {
219    dwCreationDistribution |= OPEN_ALWAYS;
220  } else {
221    dwCreationDistribution |= OPEN_EXISTING;
222  }
223  if ((flag &  _O_RANDOM) == _O_RANDOM) {
224    dwFlagsAndAttributes |= FILE_FLAG_RANDOM_ACCESS;
225  }
226  if ((flag &  _O_SEQUENTIAL) == _O_SEQUENTIAL) {
227    dwFlagsAndAttributes |= FILE_FLAG_SEQUENTIAL_SCAN;
228  }
229
230  if ((flag &  _O_TEMPORARY) == _O_TEMPORARY) {
231    dwFlagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE;
232  }
233
234  if ((flag &  _O_SHORT_LIVED) == _O_SHORT_LIVED) {
235    dwFlagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE;
236  }
237
238  if (flag & _O_NOINHERIT) {
239    sa.bInheritHandle = FALSE;
240  }
241
242#if 0
243  dwFlagsAndAttributes |= FILE_FLAG_OVERLAPPED;
244#endif
245   
246
247  hfile = CreateFileW(path,
248                      dwDesiredAccess,
249                      dwShareMode,
250                      &sa,
251                      dwCreationDistribution,
252                      dwFlagsAndAttributes,
253                      NULL);
254  if (hfile == ((HANDLE)-1)) {
255    _dosmaperr(GetLastError());
256    return (HANDLE)-1;
257  }
258  return hfile;
259}
260
261int
262wopen(wchar_t *path, int flag, int mode)
263{
264  HANDLE h = lisp_open(path, flag, mode);
265
266  if (h == (HANDLE)-1) {
267    return -1;                  /* errno already set */
268  }
269  return  _open_osfhandle((intptr_t)h,0);
270}
271
272int
273lisp_close(HANDLE hfile)
274{
275  int err;
276
277  if (closesocket((SOCKET)hfile) == 0) {
278    return 0;
279  }
280
281  err = WSAGetLastError();
282  if (err != WSAENOTSOCK) {
283    _dosmaperr(err);
284    return -1;
285  }
286  if (CloseHandle(hfile)) {
287    return 0;
288  }
289  _dosmaperr(GetLastError());
290  return -1;
291}
292
293extern TCR *get_tcr(int);
294
295ssize_t
296lisp_standard_read(HANDLE hfile, void *buf, unsigned int count)
297{
298  HANDLE hevent;
299  OVERLAPPED overlapped;
300  DWORD err, nread, wait_result;
301  pending_io pending;
302  TCR *tcr;
303 
304 
305  memset(&overlapped,0,sizeof(overlapped));
306
307  if (GetFileType(hfile) == FILE_TYPE_DISK) {
308    overlapped.Offset = SetFilePointer(hfile, 0, &(overlapped.OffsetHigh), FILE_CURRENT);
309  }
310
311  tcr = (TCR *)get_tcr(1);
312  pending.h = hfile;
313  pending.o = &overlapped;
314  tcr->pending_io_info = &pending;
315  hevent = (HANDLE)(tcr->io_datum);
316  overlapped.hEvent = hevent;
317  ResetEvent(hevent);
318  if (ReadFile(hfile, buf, count, &nread, &overlapped)) {
319    tcr->pending_io_info = NULL;
320    return nread;
321  }
322
323  err = GetLastError();
324 
325  if (err == ERROR_HANDLE_EOF) {
326    tcr->pending_io_info = NULL;
327    return 0;
328  }
329
330  if (err != ERROR_IO_PENDING) {
331    _dosmaperr(err);
332    tcr->pending_io_info = NULL;
333    return -1;
334  }
335 
336  err = 0;
337 
338  /* We block here */   
339  wait_result = WaitForSingleObjectEx(hevent, INFINITE, true);
340
341
342
343  tcr->pending_io_info = NULL;
344  if (wait_result == WAIT_OBJECT_0) {
345    err = overlapped.Internal;
346    if (err == ERROR_HANDLE_EOF) {
347      return 0;
348    }
349    if (err) {
350      _dosmaperr(err);
351      return -1;
352    }
353    return overlapped.InternalHigh;
354  }
355
356  if (wait_result == WAIT_IO_COMPLETION) {
357    CancelIo(hfile);
358    errno = EINTR;
359    return -1;
360  }
361  err = GetLastError();
362 
363
364  switch (err) {
365  case ERROR_HANDLE_EOF: 
366    return 0;
367  default:
368    _dosmaperr(err);
369    return -1;
370  }
371}
372
373ssize_t
374pipe_read(HANDLE hfile, void *buf, unsigned int count)
375{
376  DWORD navail, err;;
377
378  do {
379    navail = 0;
380    if (PeekNamedPipe(hfile, NULL, 0, NULL, &navail, NULL) == 0) {
381      err = GetLastError();
382      if (err = ERROR_HANDLE_EOF) {
383        return 0;
384      } else {
385        _dosmaperr(err);
386        return -1;
387      }
388    }
389    if (navail != 0) {
390      return lisp_standard_read(hfile, buf, count);
391    }
392    if (SleepEx(50, TRUE) == WAIT_IO_COMPLETION) {
393      errno = EINTR;
394      return -1;
395    }
396  } while (1);
397}
398
399ssize_t
400console_read(HANDLE hfile, void *buf, unsigned int count)
401{
402  DWORD err, eventcount, i, n;
403  INPUT_RECORD ir;
404
405  do {
406    err = WaitForSingleObjectEx(hfile, INFINITE, TRUE);
407    switch (err) {
408    case WAIT_OBJECT_0:
409      eventcount = 0;
410      GetNumberOfConsoleInputEvents(hfile, &eventcount);
411      for (i = 0; i < eventcount; i++) {
412        PeekConsoleInput(hfile, &ir, 1, &n);
413        if (ir.EventType == KEY_EVENT) {
414          return lisp_standard_read(hfile, buf, count);
415        } else {
416          ReadConsoleInput(hfile, &ir, 1, &n);
417        }
418      }
419      break;
420    case WAIT_IO_COMPLETION:
421      errno = EINTR;
422      return -1;
423      break;
424    case WAIT_FAILED:
425      _dosmaperr(GetLastError());
426      return -1;
427      break;
428    }
429  } while (1);
430}
431
432ssize_t
433lisp_read(HANDLE hfile, void *buf, unsigned int count) {
434  switch(GetFileType(hfile)) {
435  case FILE_TYPE_CHAR:
436    return console_read(hfile, buf, count);
437    break;
438
439  case FILE_TYPE_PIPE:          /* pipe or one of these newfangled socket things */
440    {
441      int socktype, optlen = sizeof(int);
442      if ((getsockopt((SOCKET)hfile, SOL_SOCKET, SO_TYPE, (char *)&socktype, &optlen) != 0) && (GetLastError() == WSAENOTSOCK)) {
443        return pipe_read(hfile, buf, count);
444      }
445    }
446    /* It's a socket, fall through */
447   
448  case FILE_TYPE_DISK:
449    return lisp_standard_read(hfile, buf, count);
450    break;
451
452  default:
453    errno = EBADF;
454    return -1;
455  }
456}
457
458
459
460ssize_t
461lisp_write(HANDLE hfile, void *buf, ssize_t count)
462{
463  HANDLE hevent;
464  OVERLAPPED overlapped;
465  DWORD err, nwritten, wait_result;
466  pending_io pending;
467  TCR *tcr = (TCR *)get_tcr(1);
468
469  hevent = (HANDLE)tcr->io_datum;
470  if (hfile == (HANDLE)1) {
471    hfile = GetStdHandle(STD_OUTPUT_HANDLE);
472  } else if (hfile == (HANDLE) 2) {
473    hfile = GetStdHandle(STD_ERROR_HANDLE);
474  }
475
476
477  memset(&overlapped,0,sizeof(overlapped));
478
479  if (GetFileType(hfile) == FILE_TYPE_DISK) {
480    overlapped.Offset = SetFilePointer(hfile, 0, &(overlapped.OffsetHigh), FILE_CURRENT);
481  }
482
483
484  pending.h = hfile;
485  pending.o = &overlapped;
486  tcr->pending_io_info = &pending;
487  overlapped.hEvent = hevent;
488  ResetEvent(hevent);
489  if (WriteFile(hfile, buf, count, &nwritten, &overlapped)) {
490    tcr->pending_io_info = NULL;
491    return nwritten;
492  }
493 
494  err = GetLastError();
495  if (err != ERROR_IO_PENDING) {
496    _dosmaperr(err);
497    tcr->pending_io_info = NULL;
498    return -1;
499  }
500  err = 0;
501  wait_result = WaitForSingleObjectEx(hevent, INFINITE, true);
502  tcr->pending_io_info = NULL;
503  if (wait_result == WAIT_OBJECT_0) {
504    err = overlapped.Internal;
505    if (err) {
506      _dosmaperr(err);
507      return -1;
508    }
509    return overlapped.InternalHigh;
510  }
511  if (wait_result == WAIT_IO_COMPLETION) {
512    CancelIo(hfile);
513    errno = EINTR;
514    return -1;
515  }
516  err = GetLastError();
517  _dosmaperr(err);
518  return -1;
519}
520
521int
522lisp_fchmod(HANDLE hfile, int mode)
523{
524  errno = ENOSYS;
525  return -1;
526}
527
528__int64
529lisp_lseek(HANDLE hfile, __int64 offset, int whence)
530{
531  DWORD high, low;
532
533  high = ((__int64)offset)>>32;
534  low = offset & 0xffffffff;
535  low = SetFilePointer(hfile, low, &high, whence);
536  if (low != INVALID_SET_FILE_POINTER) {
537    return ((((__int64)high)<<32)|low);
538  }
539  _dosmaperr(GetLastError());
540  return -1;
541}
542
543#define ALL_USERS(f) ((f) | ((f)>> 3) | ((f >> 6)))
544#define STAT_READONLY ALL_USERS(_S_IREAD)
545#define STAT_READWRITE ALL_USERS((_S_IREAD|_S_IWRITE))
546int
547lisp_stat(wchar_t *path, struct __stat64 *buf)
548{
549  return _wstat64(path,buf);
550}
551
552#define UNIX_EPOCH_IN_WINDOWS_EPOCH  116444736000000000LL
553
554__time64_t
555filetime_to_unix_time(FILETIME *ft)
556{
557  __time64_t then = *((__time64_t *) ft);
558
559  then -= UNIX_EPOCH_IN_WINDOWS_EPOCH;
560  return then/10000000;
561}
562
563int
564lisp_fstat(HANDLE hfile, struct __stat64 *buf)
565{
566  int filetype;
567
568  filetype = GetFileType(hfile) & ~FILE_TYPE_REMOTE;
569
570  if (filetype == FILE_TYPE_UNKNOWN) {
571    errno = EBADF;
572    return -1;
573  }
574
575  memset(buf, 0, sizeof(*buf));
576  buf->st_nlink = 1;
577 
578  switch(filetype) {
579  case FILE_TYPE_CHAR:
580  case FILE_TYPE_PIPE:
581    if (filetype == FILE_TYPE_CHAR) {
582      buf->st_mode = _S_IFCHR;
583    } else {
584      buf->st_mode = _S_IFIFO;
585    }
586    break;
587  case FILE_TYPE_DISK:
588    {
589      BY_HANDLE_FILE_INFORMATION info;
590
591      if (!GetFileInformationByHandle(hfile, &info)) {
592        _dosmaperr(GetLastError());
593        return -1;
594      }
595
596      if (info.dwFileAttributes & FILE_ATTRIBUTE_READONLY) {
597        buf->st_mode = STAT_READONLY;
598      } else {
599        buf->st_mode = STAT_READWRITE;
600      }
601      buf->st_mode |= _S_IFREG;
602      buf->st_size = ((((__int64)(info.nFileSizeHigh))<<32LL) |
603                      ((__int64)(info.nFileSizeLow)));
604      buf->st_mtime = filetime_to_unix_time(&info.ftLastWriteTime);
605      buf->st_atime = filetime_to_unix_time(&info.ftLastAccessTime);
606      buf->st_ctime = filetime_to_unix_time(&info.ftCreationTime);
607    }
608    break;
609  case FILE_TYPE_UNKNOWN:
610  default:
611    errno = EBADF;
612    return -1;
613  }
614  return 0;
615}
616
617int
618lisp_futex(int *uaddr, int op, int val, void *timeout, int *uaddr2, int val3)
619{
620  errno = ENOSYS;
621  return -1;
622}
623
624
625__int64
626lisp_ftruncate(HANDLE hfile, off_t new_size)
627{
628  __int64 oldpos;
629
630
631  oldpos = lisp_lseek(hfile, 0, SEEK_END);
632  if (oldpos == -1) {
633    return 0;
634  }
635  if (oldpos < new_size) {
636    char buf[4096];
637    __int64 n = new_size-oldpos;
638    DWORD nwritten, to_write;
639
640    memset(buf,0,sizeof(buf));
641    while(n) {
642      if (n > 4096LL) {
643        to_write = 4096;
644      } else {
645        to_write = n;
646      }
647      if (!WriteFile(hfile,buf,to_write,&nwritten,NULL)) {
648        _dosmaperr(GetLastError());
649        return -1;
650      }
651      n -= nwritten;
652    }
653    return 0;
654  }
655  lisp_lseek(hfile, new_size, SEEK_SET);
656  if (SetEndOfFile(hfile)) {
657    return 0;
658  }
659  _dosmaperr(GetLastError());
660  return -1;
661}
662
663
664_WDIR *
665lisp_opendir(wchar_t *path)
666{
667  return _wopendir(path);
668}
669
670struct _wdirent *
671lisp_readdir(_WDIR *dir)
672{
673  return _wreaddir(dir);
674}
675
676__int64
677lisp_closedir(_WDIR *dir)
678{
679  return _wclosedir(dir);
680}
681
682int
683lisp_pipe(int fd[2])
684{
685  HANDLE input, output;
686  SECURITY_ATTRIBUTES sa;
687
688  sa.nLength= sizeof(SECURITY_ATTRIBUTES);
689  sa.lpSecurityDescriptor = NULL;
690  sa.bInheritHandle = TRUE;
691
692  if (!CreatePipe(&input, &output, &sa, 0))
693    {
694      wperror("CreatePipe");
695      return -1;
696    }
697  fd[0] = (int) ((intptr_t)input);
698  fd[1] = (int) ((intptr_t)output);
699  return 0;
700}
701
702int
703lisp_gettimeofday(struct timeval *tp, void *tzp)
704{
705  __time64_t now;
706
707  gettimeofday(tp,tzp);       /* trust it to get time zone right, at least */
708  GetSystemTimeAsFileTime((FILETIME*)&now);
709  now -= UNIX_EPOCH_IN_WINDOWS_EPOCH;
710  now /= 10000;               /* convert time to milliseconds */
711  tp->tv_sec = now/1000LL;
712  tp->tv_usec = 1000 * (now%1000LL); /* convert milliseconds to microseconds */
713  return 0;
714}
715
716int
717lisp_sigexit(int signum)
718{
719  signal(signum, SIG_DFL);
720  return raise(signum);
721}
722
723#ifdef WIN_64
724
725/* Make sure that the lisp calls these functions, when they do something */
726/* This code is taken from the 32-bit mingw library and is in the
727   public domain */
728double
729acosh(double x)
730{
731  if (isnan (x)) 
732    return x;
733
734  if (x < 1.0)
735    {
736      errno = EDOM;
737      return nan("");
738    }
739
740  if (x > 0x1p32)
741    /*  Avoid overflow (and unnecessary calculation when
742        sqrt (x * x - 1) == x). GCC optimizes by replacing
743        the long double M_LN2 const with a fldln2 insn.  */ 
744    return log (x) + 6.9314718055994530941723E-1L;
745
746  /* Since  x >= 1, the arg to log will always be greater than
747     the fyl2xp1 limit (approx 0.29) so just use logl. */ 
748  return log (x + sqrt((x + 1.0) * (x - 1.0)));
749}
750
751float
752acoshf(float x)
753{
754  if (isnan (x)) 
755    return x;
756  if (x < 1.0f)
757    {
758      errno = EDOM;
759      return nan("");
760    }
761
762 if (x > 0x1p32f)
763    /*  Avoid overflow (and unnecessary calculation when
764        sqrt (x * x - 1) == x). GCC optimizes by replacing
765        the long double M_LN2 const with a fldln2 insn.  */ 
766    return log (x) + 6.9314718055994530941723E-1L;
767
768  /* Since  x >= 1, the arg to log will always be greater than
769     the fyl2xp1 limit (approx 0.29) so just use logl. */ 
770  return log (x + sqrt((x + 1.0) * (x - 1.0)));
771}
772
773double
774asinh(double x)
775{
776  double z;
777  if (!isfinite (x))
778    return x;
779  z = fabs (x);
780
781  /* Avoid setting FPU underflow exception flag in x * x. */
782#if 0
783  if ( z < 0x1p-32)
784    return x;
785#endif
786
787  /* Use log1p to avoid cancellation with small x. Put
788     x * x in denom, so overflow is harmless.
789     asinh(x) = log1p (x + sqrt (x * x + 1.0) - 1.0)
790              = log1p (x + x * x / (sqrt (x * x + 1.0) + 1.0))  */
791
792  z = log1p (z + z * z / (sqrt (z * z + 1.0) + 1.0));
793
794  return ( x >= 0.0 ? z : -z);
795}
796
797float
798asinhf(float x)
799{
800  float z;
801  if (!isfinite (x))
802    return x;
803  z = fabsf (x);
804
805  /* Avoid setting FPU underflow exception flag in x * x. */
806#if 0
807  if ( z < 0x1p-32)
808    return x;
809#endif
810
811
812  /* Use log1p to avoid cancellation with small x. Put
813     x * x in denom, so overflow is harmless.
814     asinh(x) = log1p (x + sqrt (x * x + 1.0) - 1.0)
815              = log1p (x + x * x / (sqrt (x * x + 1.0) + 1.0))  */
816
817  z = log1p (z + z * z / (sqrt (z * z + 1.0) + 1.0));
818
819  return ( x >= 0.0 ? z : -z);
820}
821
822double
823atanh(double x)
824{
825  double z;
826  if (isnan (x))
827    return x;
828  z = fabs (x);
829  if (z == 1.0)
830    {
831      errno  = ERANGE;
832      return (x > 0 ? INFINITY : -INFINITY);
833    }
834  if (z > 1.0)
835    {
836      errno = EDOM;
837      return nan("");
838    }
839  /* Rearrange formula to avoid precision loss for small x.
840
841  atanh(x) = 0.5 * log ((1.0 + x)/(1.0 - x))
842           = 0.5 * log1p ((1.0 + x)/(1.0 - x) - 1.0)
843           = 0.5 * log1p ((1.0 + x - 1.0 + x) /(1.0 - x))
844           = 0.5 * log1p ((2.0 * x ) / (1.0 - x))  */
845  z = 0.5 * log1p ((z + z) / (1.0 - z));
846  return x >= 0 ? z : -z;
847}
848
849float
850atanhf(float x)
851{
852  float z;
853  if (isnan (x))
854    return x;
855  z = fabsf (x);
856  if (z == 1.0)
857    {
858      errno  = ERANGE;
859      return (x > 0 ? INFINITY : -INFINITY);
860    }
861  if ( z > 1.0)
862    {
863      errno = EDOM;
864      return nanf("");
865    }
866  /* Rearrange formula to avoid precision loss for small x.
867
868  atanh(x) = 0.5 * log ((1.0 + x)/(1.0 - x))
869           = 0.5 * log1p ((1.0 + x)/(1.0 - x) - 1.0)
870           = 0.5 * log1p ((1.0 + x - 1.0 + x) /(1.0 - x))
871           = 0.5 * log1p ((2.0 * x ) / (1.0 - x))  */
872  z = 0.5 * log1p ((z + z) / (1.0 - z));
873  return x >= 0 ? z : -z;
874}
875
876#endif
877
878typedef struct {
879  char *name;
880  void *addr;
881} math_fn_entry;
882
883
884math_fn_entry math_fn_entries [] = {
885  {"acos",acos},
886  {"acosf",acosf},
887  {"acosh",acosh},
888  {"acoshf",acoshf},
889  {"asin",asin},
890  {"asinf",asinf},
891  {"asinh",asinh},
892  {"asinhf",asinhf},
893  {"atan",atan},
894  {"atan2",atan2},
895  {"atan2f",atan2f},
896  {"atanf",atanf},
897  {"atanh",atanh},
898  {"atanhf",atanhf},
899  {"cos",cos},
900  {"cosf",cosf},
901  {"cosh",cosh},
902  {"coshf",coshf},
903  {"exp",exp},
904  {"expf",expf},
905  {"log",log},
906  {"logf",logf},
907  {"pow",pow},
908  {"powf",powf},
909  {"sin",sin},
910  {"sinf",sinf},
911  {"sinh",sinh},
912  {"sinhf",sinhf},
913  {"tan",tan},
914  {"tanf",tanf},
915  {"tanh",tanh},
916  {"tanhf",tanhf},
917  {NULL, 0}};
918
919void *
920lookup_math_fn(char *name)
921{
922  math_fn_entry *p = math_fn_entries;
923  char *entry_name;
924 
925  while ((entry_name = p->name) != NULL) {
926    if (!strcmp(name, entry_name)) {
927      return p->addr;
928    }
929    p++;
930  }
931  return NULL;
932}
933
934HMODULE *modules = NULL;
935DWORD cbmodules = 0;
936HANDLE find_symbol_lock = 0;
937
938void *
939windows_find_symbol(void *handle, char *name)
940{
941  void *addr;
942
943  if ((handle == ((void *)-2L)) ||
944      (handle == ((void *)-1L))) {
945    handle = NULL;
946  }
947  if (handle != NULL) {
948    addr = GetProcAddress(handle, name);
949  } else {
950    DWORD cbneeded,  have, i;
951    WaitForSingleObject(find_symbol_lock,INFINITE);
952
953    if (cbmodules == 0) {
954      cbmodules = 16 * sizeof(HANDLE);
955      modules = malloc(cbmodules);
956    }
957   
958    while (1) {
959      EnumProcessModules(GetCurrentProcess(),modules,cbmodules,&cbneeded);
960      if (cbmodules >= cbneeded) {
961        break;
962      }
963      cbmodules = cbneeded;
964      modules = realloc(modules,cbmodules);
965    }
966    have = cbneeded/sizeof(HANDLE);
967
968    for (i = 0; i < have; i++) {
969      addr = GetProcAddress(modules[i],name);
970
971      if (addr) {
972        break;
973      }
974    }
975    ReleaseMutex(find_symbol_lock);
976    if (addr) {
977      return addr;
978    }
979    return lookup_math_fn(name);
980  }
981}
982
983/* Note that we're using 8-bit strings here */
984
985void *
986windows_open_shared_library(char *path)
987{
988  HMODULE module = (HMODULE)0;
989
990  /* Try to open an existing module in a way that increments its
991     reference count without running any initialization code in
992     the dll. */
993  if (!GetModuleHandleExA(0,path,&module)) {
994    /* If that failed ... */
995    module = LoadLibraryA(path);
996  }
997  return (void *)module;
998}
999
1000
1001void
1002init_windows_io()
1003{
1004#ifdef WIN_32
1005  extern void init_win32_ldt(void);
1006  init_win32_ldt();
1007#endif
1008  find_symbol_lock = CreateMutex(NULL,false,NULL);
1009}
1010
1011void
1012init_winsock()
1013{
1014  WSADATA data;
1015
1016  WSAStartup((2<<8)|2,&data);
1017}
1018
Note: See TracBrowser for help on using the repository browser.