lib/os_base.c

   1 /* File: "os_base.c" */
   2
   3 /* Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved. */
   4
   5 /*
   6  * This module implements the most basic operating system services.
   7  */
   8
   9 #define ___INCLUDED_FROM_OS_BASE
  10 #define ___VERSION 406003
  11 #include "gambit.h"
  12
  13 #include "os_base.h"
  14 #include "setup.h"
  15
  16
  17 /*---------------------------------------------------------------------------*/
  18
  19
  20 ___base_module ___base_mod =
  21 {
  22   0
  23
  24 #ifdef ___DEBUG
  25   ,
  26   0,
  27   0,
  28   0
  29 #ifdef ___DEBUG_ALLOC_MEM_TRACE
  30   ,
  31   0,
  32   0
  33 #endif
  34 #endif
  35
  36 #ifdef ___BASE_MODULE_INIT
  37   ___BASE_MODULE_INIT
  38 #endif
  39 };
  40
  41
  42 /*---------------------------------------------------------------------------*/
  43
  44 /* Standard I/O emulation */
  45
  46
  47 ___FILE *___fopen
  48    ___P((const char *path,
  49          const char *mode),
  50         (path,
  51          mode)
  52 const char *path;
  53 const char *mode;)
  54 {
  55   return fopen (path, mode);
  56 }
  57
  58
  59 int ___fclose
  60    ___P((___FILE *stream),
  61         (stream)
  62 ___FILE *stream;)
  63 {
  64   return fclose (stream);
  65 }
  66
  67
  68 size_t ___fread
  69    ___P((void *ptr,
  70          size_t size,
  71          size_t nmemb,
  72          ___FILE *stream),
  73         (ptr,
  74          size,
  75          nmemb,
  76          stream)
  77 void *ptr;
  78 size_t size;
  79 size_t nmemb;
  80 ___FILE *stream;)
  81 {
  82   return fread (ptr, size, nmemb, stream);
  83 }
  84
  85
  86 size_t ___fwrite
  87    ___P((const void *ptr,
  88          size_t size,
  89          size_t nmemb,
  90          ___FILE *stream),
  91         (ptr,
  92          size,
  93          nmemb,
  94          stream)
  95 const void *ptr;
  96 size_t size;
  97 size_t nmemb;
  98 ___FILE *stream;)
  99 {
 100   return fwrite (ptr, size, nmemb, stream);
 101 }
 102
 103
 104 int ___fflush
 105    ___P((___FILE *stream),
 106         (stream)
 107 ___FILE *stream;)
 108 {
 109   return fflush (stream);
 110 }
 111
 112
 113 #ifdef ___DEBUG
 114
 115 #include <stdarg.h>
 116
 117 int ___printf
 118    ___P((const char *format,
 119          ...),
 120         (format, ...)
 121 const char *format;)
 122 {
 123   va_list ap;
 124   int result;
 125   ___FILE *stream = ___base_mod.debug;
 126
 127   if (stream == NULL)
 128     stream = ___stderr;
 129
 130   va_start (ap, format);
 131   result = vfprintf (stream, format, ap);
 132   va_end (ap);
 133
 134   ___fflush (stream);
 135
 136   return result;
 137 }
 138
 139 #endif
 140
 141
 142 /*---------------------------------------------------------------------------*/
 143
 144 /* Memory allocation. */
 145
 146
 147 void *___alloc_mem
 148    ___P((unsigned long bytes),
 149         (bytes)
 150 unsigned long bytes;)
 151 {
 152   void *ptr;
 153
 154 #ifdef ___DEBUG
 155 #ifdef USE_WIN32
 156
 157   InterlockedIncrement (&___base_mod.alloc_mem_calls);
 158
 159 #else
 160
 161   ___base_mod.alloc_mem_calls++;
 162
 163 #endif
 164 #endif
 165
 166 #ifdef USE_TempNewHandle
 167
 168   if (___base_mod.setup && ___base_mod.has_OSDispatch)
 169     {
 170       OSErr e;
 171       Ptr p;
 172       Handle h = TempNewHandle (sizeof (Handle) + bytes, &err);
 173       if (e != noErr || h == 0)
 174         return 0;
 175       HLock (h);
 176       p = *h;
 177       *___CAST(Handle*,p) = h;
 178       ptr = p + sizeof (Handle);
 179     }
 180   else
 181     ptr = malloc (bytes);
 182
 183 #else
 184
 185   ptr = malloc (bytes);
 186
 187 #endif
 188
 189   return ptr;
 190 }
 191
 192
 193 void ___free_mem
 194    ___P((void *ptr),
 195         (ptr)
 196 void *ptr;)
 197 {
 198 #ifdef ___DEBUG
 199 #ifdef ___DEBUG_ALLOC_MEM_TRACE
 200   ___printf ("%p FREED\n", ptr);
 201 #endif
 202 #endif
 203
 204 #ifdef ___DEBUG
 205 #ifdef USE_WIN32
 206
 207   InterlockedIncrement (&___base_mod.free_mem_calls);
 208
 209 #else
 210
 211   ___base_mod.free_mem_calls++;
 212
 213 #endif
 214 #endif
 215
 216 #ifdef USE_TempNewHandle
 217
 218   if (___base_mod.setup && ___base_mod.has_OSDispatch)
 219     {
 220       OSErr e;
 221       Handle h = *___CAST(Handle*,___CAST(Ptr,ptr) - sizeof (Handle));
 222       HUnlock (h);
 223       TempDisposeHandle (h, &e);
 224     }
 225   else
 226     free (ptr);
 227
 228 #else
 229
 230   free (ptr);
 231
 232 #endif
 233 }
 234
 235
 236 #ifdef ___DEBUG
 237 #ifdef ___DEBUG_ALLOC_MEM_TRACE
 238
 239
 240 void * ___alloc_mem_debug
 241    ___P((unsigned long bytes,
 242          int lineno,
 243          char *file),
 244         (bytes,
 245          lineno,
 246          file)
 247 unsigned long bytes;
 248 int lineno;
 249 char *file;)
 250 {
 251   void *ptr;
 252
 253   ptr = ___alloc_mem (bytes);
 254
 255   if (file != 0)
 256     ___printf ("%p (%lu bytes) ALLOCATED AT \"%s\"@%d.1\n",
 257                ptr,
 258                bytes,
 259                file,
 260                lineno);
 261   else
 262     ___printf ("%p (%lu bytes) ALLOCATED\n", ptr, bytes);
 263
 264   return ptr;
 265 }
 266
 267
 268 #endif
 269 #endif
 270
 271
 272 void *___alloc_mem_code
 273    ___P((unsigned long bytes),
 274         (bytes)
 275 unsigned long bytes;)
 276 {
 277 #ifndef USE_mmap
 278 #ifndef USE_VirtualAlloc
 279
 280   return NULL;
 281
 282 #endif
 283 #endif
 284
 285 #ifdef USE_mmap
 286
 287   ___BOOL executable = 1;
 288
 289   void* ptr = mmap (0,
 290                     bytes + sizeof (long),
 291                     PROT_READ | PROT_WRITE | (executable ? PROT_EXEC : 0),
 292                     MAP_PRIVATE | MAP_ANON,
 293                     -1,
 294                     0);
 295
 296   if (ptr == MAP_FAILED)
 297     return NULL;
 298
 299   *___CAST(long*,ptr) = bytes;
 300
 301   return ___CAST(long*,ptr)+1;
 302
 303 #endif
 304
 305 #ifdef USE_VirtualAlloc
 306
 307   ___BOOL executable = 1;
 308
 309   void *ptr = VirtualAlloc (NULL,
 310                             bytes,
 311                             MEM_COMMIT,
 312                             (executable
 313                              ? PAGE_EXECUTE_READWRITE
 314                              : PAGE_READWRITE));
 315
 316   return ptr;
 317
 318 #endif
 319 }
 320
 321
 322 void ___free_mem_code
 323    ___P((void *ptr),
 324         (ptr)
 325 void *ptr;)
 326 {
 327 #ifndef USE_mmap
 328 #ifndef USE_VirtualAlloc
 329
 330 #endif
 331 #endif
 332
 333 #ifdef USE_mmap
 334
 335   long* p = ___CAST(long*,ptr)-1;
 336
 337   munmap (p, *p + sizeof (long));
 338
 339 #endif
 340
 341 #ifdef USE_VirtualAlloc
 342
 343   VirtualFree (ptr, 0, MEM_RELEASE);
 344
 345 #endif
 346 }
 347
 348
 349 /*---------------------------------------------------------------------------*/
 350
 351 /* Program startup */
 352
 353
 354 /*
 355  * ___main_char, ___main_UCS_2, and ___winmain are variants of main
 356  * entry points which differ in the format of the arguments; the first
 357  * two are always compiled in since they could be useful on all
 358  * systems for embedding of Gambit.
 359  */
 360
 361
 362 /* To keep command line and runtime flag information around: */
 363
 364 ___program_startup_info_struct ___program_startup_info =
 365 {
 366   0, /* argument vector */
 367   0  /* runtime flag string */
 368
 369 #ifdef ___OS_WIN32
 370   ,
 371   NULL,
 372   NULL,
 373   NULL,
 374   0
 375 #endif
 376 };
 377
 378
 379 ___EXP_FUNC(int,___main_char)
 380   ___P((int argc,
 381         char *argv[],
 382         ___mod_or_lnk (*linker)(___global_state_struct*),
 383         char *script_line),
 384        (argc,
 385         argv,
 386         linker,
 387         script_line)
 388 int argc;
 389 char *argv[];
 390 ___mod_or_lnk (*linker)();
 391 char *script_line;)
 392 {
 393   int result;
 394
 395   if (___setup_base_module () != ___FIX(___NO_ERR))
 396     result = ___EXIT_CODE_OSERR;
 397   else
 398     {
 399       if (___NONNULLCHARSTRINGLIST_to_NONNULLUCS_2STRINGLIST
 400             (argv,
 401              &___program_startup_info.argv)
 402           != ___FIX(___NO_ERR))
 403         result = ___EXIT_CODE_SOFTWARE;
 404       else
 405         {
 406           if (___CHARSTRING_to_UCS_2STRING
 407                 (script_line,
 408                  &___program_startup_info.script_line)
 409               != ___FIX(___NO_ERR))
 410             result = ___EXIT_CODE_SOFTWARE;
 411           else
 412             {
 413               result = ___main (linker);
 414
 415               ___free_UCS_2STRING (___program_startup_info.script_line);
 416             }
 417
 418           ___free_NONNULLUCS_2STRINGLIST (___program_startup_info.argv);
 419         }
 420
 421       ___cleanup_base_module ();
 422     }
 423
 424   return result;
 425 }
 426
 427
 428 ___EXP_FUNC(int,___main_UCS_2)
 429   ___P((int argc,
 430         ___UCS_2STRING argv[],
 431         ___mod_or_lnk (*linker)(___global_state_struct*),
 432         char *script_line),
 433        (argc,
 434         argv,
 435         linker,
 436         script_line)
 437 int argc;
 438 ___UCS_2STRING argv[];
 439 ___mod_or_lnk (*linker)();
 440 char *script_line;)
 441 {
 442   int result;
 443
 444   if (___setup_base_module () != ___FIX(___NO_ERR))
 445     result = ___EXIT_CODE_OSERR;
 446   else
 447     {
 448       ___program_startup_info.argv = argv;
 449
 450       if (___CHARSTRING_to_UCS_2STRING
 451             (script_line,
 452              &___program_startup_info.script_line)
 453           != ___FIX(___NO_ERR))
 454         result = ___EXIT_CODE_SOFTWARE;
 455       else
 456         {
 457           result = ___main (linker);
 458
 459           ___free_UCS_2STRING (___program_startup_info.script_line);
 460         }
 461
 462       ___cleanup_base_module ();
 463     }
 464
 465   return result;
 466 }
 467
 468
 469 #ifdef ___OS_WIN32
 470
 471
 472 #ifdef _UNICODE
 473 #define ___CMDLINE_CE_SELECT(latin1,utf8,ucs2,ucs4,wchar,native) ucs2
 474 #else
 475 #define ___CMDLINE_CE_SELECT(latin1,utf8,ucs2,ucs4,wchar,native) native
 476 #endif
 477
 478
 479 ___HIDDEN ___SCMOBJ parse_windows_command_line
 480    ___P((___STRING_TYPE(___CMDLINE_CE_SELECT) cmdline,
 481          ___UCS_2STRING **argv_return),
 482         (cmdline,
 483          argv_return)
 484 ___STRING_TYPE(___CMDLINE_CE_SELECT) cmdline;
 485 ___UCS_2STRING **argv_return;)
 486 {
 487   int argc = 0;
 488   ___UCS_2STRING *argv = 0;
 489   ___UCS_2STRING args = 0;
 490   int total_arg_len = 0;
 491   int pass;
 492
 493   for (pass=0; pass<2; pass++)
 494     {
 495       int in_double_quotes;
 496       int nb_backslashes;
 497       ___STRING_TYPE(___CMDLINE_CE_SELECT) p;
 498       ___CHAR_TYPE(___CMDLINE_CE_SELECT) c;
 499
 500       if (pass != 0)
 501         {
 502           if ((argv = ___CAST(___UCS_2STRING*,
 503                               ___alloc_mem ((argc + 1)
 504                                             * sizeof (___UCS_2STRING)))) == 0)
 505             return ___FIX(___HEAP_OVERFLOW_ERR);
 506
 507           if (total_arg_len > 0)
 508             {
 509               if ((args = ___CAST(___UCS_2STRING,
 510                                   ___alloc_mem (total_arg_len
 511                                                 * sizeof (___UCS_2)))) == 0)
 512                 {
 513                   ___free_mem (argv);
 514                   return ___FIX(___HEAP_OVERFLOW_ERR);
 515                 }
 516             }
 517         }
 518
 519       total_arg_len = 0;
 520       argc = 0;
 521       p = cmdline;
 522
 523       for (;;)
 524         {
 525           while ((c = *p) != '\0' && c <= ' ')
 526             p++;
 527
 528           if (c == '\0')
 529             break;
 530
 531           in_double_quotes = 0;
 532           nb_backslashes = 0;
 533
 534           if (pass != 0)
 535             argv[argc] = args;
 536
 537           while ((c = *p) != '\0' && (in_double_quotes || c > ' '))
 538             {
 539               if (c == '\\')
 540                 nb_backslashes++;
 541               else
 542                 {
 543                   if (c != '"')
 544                     nb_backslashes = (nb_backslashes<<1) + 1;
 545                   else
 546                     {
 547                       if ((nb_backslashes & 1) == 0)
 548                         in_double_quotes ^= 1;
 549 #ifndef PROCESS_PROGRAM_LIKE_OTHER_ARGS
 550                       if (argc == 0)
 551                         nb_backslashes = (nb_backslashes<<1) + 1;
 552 #endif
 553                     }
 554
 555                   total_arg_len += ((nb_backslashes+1)>>1);
 556
 557                   if (pass != 0)
 558                     {
 559                       while (nb_backslashes > 1)
 560                         {
 561                           *args++ = '\\';
 562                           nb_backslashes -= 2;
 563                         }
 564                       if (nb_backslashes != 0)
 565                         *args++ = c;
 566                     }
 567
 568                   nb_backslashes = 0;
 569                 }
 570               p++;
 571             }
 572
 573           total_arg_len += nb_backslashes+1;
 574
 575           if (pass != 0)
 576             {
 577               while (nb_backslashes-- > 0)
 578                 *args++ = '\\';
 579               *args++ = '\0';
 580             }
 581
 582           argc++;
 583         }
 584     }
 585
 586   argv[argc] = 0;
 587
 588   *argv_return = argv;
 589
 590   return ___FIX(___NO_ERR);
 591 }
 592
 593
 594 ___HIDDEN void free_windows_command_line
 595    ___P((___UCS_2STRING *argv),
 596         (argv)
 597 ___UCS_2STRING *argv;)
 598 {
 599   if (argv[0] != 0)
 600     ___free_mem (argv[0]);
 601
 602   ___free_mem (argv);
 603 }
 604
 605
 606 ___EXP_FUNC(int,___winmain)
 607   ___P((HINSTANCE hInstance,
 608         HINSTANCE hPrevInstance,
 609         LPSTR lpCmdLine,
 610         int nCmdShow,
 611         ___mod_or_lnk (*linker)(___global_state_struct*),
 612         char *script_line),
 613        (hInstance,
 614         hPrevInstance,
 615         lpCmdLine,
 616         nCmdShow,
 617         linker,
 618         script_line)
 619 HINSTANCE hInstance;
 620 HINSTANCE hPrevInstance;
 621 LPSTR lpCmdLine;
 622 int nCmdShow;
 623 ___mod_or_lnk (*linker)(___global_state_struct*);
 624 char *script_line;)
 625 {
 626   int result;
 627
 628   if (___setup_base_module () != ___FIX(___NO_ERR))
 629     result = ___EXIT_CODE_OSERR;
 630   else
 631     {
 632       /*********************************/
 633 #if 0
 634       AllocConsole( );  /* Create Console Window */
 635       freopen(_T("CONIN$"),_T("rb"),stdin);   /* reopen stdin handle as console window input */
 636       freopen(_T("CONOUT$"),_T("wb"),stdout); /* reopen stout handle as console window output */
 637       freopen(_T("CONOUT$"),_T("wb"),stderr); /* reopen stderr handle as console window output */
 638 #endif
 639
 640       if (parse_windows_command_line
 641             (GetCommandLine (),
 642              &___program_startup_info.argv)
 643           != ___FIX(___NO_ERR))
 644         result = ___EXIT_CODE_SOFTWARE;
 645       else
 646         {
 647           if (___CHARSTRING_to_UCS_2STRING
 648                 (script_line,
 649                  &___program_startup_info.script_line)
 650               != ___FIX(___NO_ERR))
 651             result = ___EXIT_CODE_SOFTWARE;
 652           else
 653             {
 654               ___program_startup_info.hInstance     = hInstance;
 655               ___program_startup_info.hPrevInstance = hPrevInstance;
 656               ___program_startup_info.lpCmdLine     = lpCmdLine;
 657               ___program_startup_info.nCmdShow      = nCmdShow;
 658
 659               result = ___main (linker);
 660
 661               ___free_UCS_2STRING (___program_startup_info.script_line);
 662             }
 663
 664           free_windows_command_line (___program_startup_info.argv);
 665         }
 666
 667       ___cleanup_base_module ();
 668     }
 669
 670   return result;
 671 }
 672
 673
 674 #endif
 675
 676
 677 /*---------------------------------------------------------------------------*/
 678
 679 /* Process termination. */
 680
 681
 682 void ___exit_process
 683    ___P((int status),
 684         (status)
 685 int status;)
 686 {
 687   exit (status);
 688 }
 689
 690
 691 /*---------------------------------------------------------------------------*/
 692
 693 /* Error handling. */
 694
 695
 696 void ___fatal_error
 697    ___P((char **msgs),
 698         (msgs)
 699 char **msgs;)
 700 {
 701   if (___setup_params.fatal_error != 0)
 702     ___setup_params.fatal_error (msgs);
 703   else
 704     {
 705       char *new_msgs[100];
 706       int i;
 707       new_msgs[0] = "*** FATAL ERROR -- ";
 708       for (i=0; i<100-2; i++)
 709         {
 710           if (msgs[i] == 0)
 711             break;
 712           new_msgs[i+1] = msgs[i];
 713         }
 714       new_msgs[i+1] = "\n";
 715       new_msgs[i+2] = 0;
 716       ___display_error (new_msgs);
 717     }
 718
 719   ___exit_process (___EXIT_CODE_SOFTWARE);
 720 }
 721
 722
 723 void ___display_error
 724    ___P((char **msgs),
 725         (msgs)
 726 char **msgs;)
 727 {
 728   if (___setup_params.display_error != 0)
 729     ___setup_params.display_error (msgs);
 730   else if (___DEBUG_SETTINGS_LEVEL(___setup_params.debug_settings) > 0)
 731     {
 732       while (*msgs != 0)
 733         {
 734           char *msg = *msgs++;
 735           int len = 0;
 736           while (msg[len] != '\0')
 737             len++;
 738           ___fwrite (msg, 1, len, ___stderr); /* ignore error */
 739         }
 740     }
 741 }
 742
 743
 744 /* Conversion of OS error codes to Scheme error codes. */
 745
 746
 747 ___HIDDEN char *error_number_to_string
 748    ___P((int code),
 749         (code)
 750 int code;)
 751 {
 752   static char txt[] = "Error code ";
 753   static char buf[sizeof (txt) + 20]; /* -2^63 is 20 characters in decimal */
 754   char *p1 = buf + sizeof (buf);
 755   char *p2;
 756   int n;
 757
 758   if (code < 0)
 759     n = code;
 760   else
 761     n = -code;
 762
 763   *--p1 = '\0';
 764
 765   do
 766     {
 767       *--p1 = '0' + (n/10 * 10 - n);
 768       n /= 10;
 769     } while (n != 0);
 770
 771   if (code < 0)
 772     *--p1 = '-';
 773
 774   p2 = txt + sizeof (txt) - 1;
 775
 776   while (p2 != txt)
 777     *--p1 = *--p2;
 778
 779   return p1;
 780 }
 781
 782
 783 #ifdef USE_errno
 784
 785
 786 ___HIDDEN char *errno_to_string
 787    ___P((int code),
 788         (code)
 789 int code;)
 790 {
 791 #ifdef USE_strerror
 792
 793   return strerror (code);
 794
 795 #else
 796
 797   return error_number_to_string (code);
 798
 799 #endif
 800 }
 801
 802
 803 #ifdef ___DEBUG
 804 ___SCMOBJ ___err_code_from_errno_debug
 805    ___P((int lineno,
 806          char *file),
 807         (lineno,
 808          file)
 809 int lineno;
 810 char *file;)
 811 #else
 812 ___SCMOBJ ___err_code_from_errno ___PVOID
 813 #endif
 814 {
 815   int e = errno;
 816
 817 #ifdef ___DEBUG
 818   ___printf ("*** OS ERROR AT \"%s\"@%d.1 -- errno=%d (%s)\n",
 819              file,
 820              lineno,
 821              e,
 822              errno_to_string (e));
 823 #endif
 824
 825   if (e == 0)
 826     return ___FIX(___UNKNOWN_ERR);
 827
 828   return ___FIX(___ERRNO_ERR(e));
 829 }
 830
 831
 832 #endif
 833
 834
 835 #ifdef USE_h_errno
 836
 837
 838 ___HIDDEN const char *h_errno_to_string
 839    ___P((int code),
 840         (code)
 841 int code;)
 842 {
 843 #ifdef USE_hstrerror
 844
 845   return hstrerror (code);
 846
 847 #else
 848
 849   static char *h_errno_messages[] =
 850   {
 851     "Resolver Error 0 (no error)",
 852     "Unknown host",
 853     "Host name lookup failure",
 854     "Unknown server error",
 855     "No address associated with name"
 856   };
 857
 858   if (code >= 0 && code <= 4)
 859     return h_errno_messages[code];
 860
 861   return "Unknown resolver error";
 862
 863 #endif
 864 }
 865
 866
 867 #ifdef ___DEBUG
 868 ___SCMOBJ ___err_code_from_h_errno_debug
 869    ___P((int lineno,
 870          char *file),
 871         (lineno,
 872          file)
 873 int lineno;
 874 char *file;)
 875 #else
 876 ___SCMOBJ ___err_code_from_h_errno ___PVOID
 877 #endif
 878 {
 879   int e = h_errno;
 880
 881 #ifdef ___DEBUG
 882   ___printf ("*** OS ERROR AT \"%s\"@%d.1 -- h_errno=%d (%s)\n",
 883              file,
 884              lineno,
 885              e,
 886              h_errno_to_string (e));
 887 #endif
 888
 889   if (e == NETDB_INTERNAL)
 890     return err_code_from_errno ();
 891
 892 #ifdef NETDB_WORKS_PROPERLY
 893
 894   if (e == NETDB_SUCCESS)
 895     return ___FIX(___UNKNOWN_ERR);
 896
 897 #else
 898
 899   /*
 900    * Linux sometimes returns NETDB_SUCCESS when it should return
 901    * NETDB_INTERNAL.
 902    */
 903
 904   if (e == NETDB_SUCCESS)
 905     return err_code_from_errno ();
 906
 907 #endif
 908
 909   return ___FIX(___H_ERRNO_ERR(e));
 910 }
 911
 912
 913 #endif
 914
 915
 916 #ifdef USE_getaddrinfo
 917
 918
 919 ___HIDDEN const char *gai_code_to_string
 920    ___P((int code),
 921         (code)
 922 int code;)
 923 {
 924   return gai_strerror (code);
 925 }
 926
 927
 928 #ifdef ___DEBUG
 929 ___SCMOBJ ___err_code_from_gai_code_debug
 930    ___P((int code,
 931          int lineno,
 932          char *file),
 933         (code,
 934          lineno,
 935          file)
 936 int code;
 937 int lineno;
 938 char *file;)
 939 #else
 940 ___SCMOBJ ___err_code_from_gai_code
 941    ___P((int code),
 942         (code)
 943 int code;)
 944 #endif
 945 {
 946   ___ERR_CODE e;
 947
 948 #ifdef EAI_SYSTEM
 949   if (code == EAI_SYSTEM)
 950     e = err_code_from_errno ();
 951   else
 952 #endif
 953
 954     e = ___GAI_CODE_ERR(code);
 955
 956 #ifdef ___DEBUG
 957   ___printf ("*** OS ERROR AT \"%s\"@%d.1 -- gai_code=%d (%s)\n",
 958              file,
 959              lineno,
 960              code,
 961              gai_code_to_string (code));
 962 #endif
 963
 964   return ___FIX(e);
 965 }
 966
 967
 968 #endif
 969
 970
 971 #ifdef USE_GetLastError
 972
 973
 974 #ifdef ___DEBUG
 975 ___SCMOBJ ___err_code_from_GetLastError_debug
 976    ___P((int lineno,
 977          char *file),
 978         (lineno,
 979          file)
 980 int lineno;
 981 char *file;)
 982 #else
 983 ___SCMOBJ ___err_code_from_GetLastError ___PVOID
 984 #endif
 985 {
 986   DWORD e = GetLastError ();
 987
 988 #ifdef ___DEBUG
 989   char buf[___ERR_MAX_LENGTH+1];
 990   DWORD len = FormatMessageA
 991                 (FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_MAX_WIDTH_MASK,
 992                  NULL,
 993                  e,
 994                  MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT),
 995                  buf,
 996                  ___ERR_MAX_LENGTH,
 997                  NULL);
 998   ___printf ("*** OS ERROR AT \"%s\"@%d.1 -- GetLastError=%d (%s)\n",
 999              file,
1000              lineno,
1001              ___CAST(int,e),
1002              buf);
1003 #endif
1004
1005   if (e == NO_ERROR)
1006     return ___FIX(___UNKNOWN_ERR);
1007
1008   if (e == ERROR_FILE_NOT_FOUND || e == ERROR_PATH_NOT_FOUND)
1009     return ___ERR_CODE_ENOENT;
1010
1011   return ___FIX(___WIN32_ERR(e));
1012 }
1013
1014
1015 #endif
1016
1017
1018 #ifdef USE_WSAGetLastError
1019
1020
1021 #ifdef ___DEBUG
1022 ___SCMOBJ ___err_code_from_WSAGetLastError_debug
1023    ___P((int lineno,
1024          char *file),
1025         (lineno,
1026          file)
1027 int lineno;
1028 char *file;)
1029 #else
1030 ___SCMOBJ ___err_code_from_WSAGetLastError ___PVOID
1031 #endif
1032 {
1033   DWORD e = WSAGetLastError ();
1034
1035 #ifdef ___DEBUG
1036   char buf[___ERR_MAX_LENGTH+1];
1037   DWORD len = FormatMessageA
1038                 (FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_MAX_WIDTH_MASK,
1039                  NULL,
1040                  e,
1041                  MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT),
1042                  buf,
1043                  ___ERR_MAX_LENGTH,
1044                  NULL);
1045   ___printf ("*** OS ERROR AT \"%s\"@%d.1 -- WSAGetLastError=%d (%s)\n",
1046              file,
1047              lineno,
1048              ___CAST(int,e),
1049              buf);
1050 #endif
1051
1052   if (e == NO_ERROR)
1053     return ___FIX(___UNKNOWN_ERR);
1054
1055   if (e == WSAEWOULDBLOCK)
1056     return ___ERR_CODE_EAGAIN;
1057
1058   return ___FIX(___WIN32_ERR(e));
1059 }
1060
1061
1062 #endif
1063
1064
1065 #ifdef USE_OSErr
1066
1067
1068 ___HIDDEN char *OSErr_to_string
1069    ___P((int code),
1070         (code)
1071 int code;)
1072 {
1073   return error_number_to_string (code);
1074 }
1075
1076
1077 #ifdef ___DEBUG
1078 ___SCMOBJ ___err_code_from_OSErr_debug
1079    ___P((OSErr e,
1080          char *file,
1081          int lineno),
1082         (e,
1083          lineno,
1084          file)
1085 OSErr e;
1086 int lineno;
1087 char *file;)
1088 #else
1089 ___SCMOBJ ___err_code_from_OSErr
1090    ___P((OSErr e),
1091         (e)
1092 OSErr e;)
1093 #endif
1094 {
1095 #ifdef ___DEBUG
1096   ___printf ("*** OS ERROR AT \"%s\"@%d.1 -- OSErr=%d (%s)\n",
1097              file,
1098              lineno,
1099              e,
1100              OSErr_to_string (e));
1101 #endif
1102
1103   if (e == noErr)
1104     return ___FIX(___UNKNOWN_ERR);
1105
1106   return ___FIX(___OSERR_ERR(e));
1107 }
1108
1109
1110 #endif
1111
1112
1113 /* Conversion of Scheme error codes to error messages. */
1114
1115
1116 ___HIDDEN char *c_type_name_table[] =
1117 {
1118   "int8",
1119   "unsigned-int8",
1120   "int16",
1121   "unsigned-int16",
1122   "int32",
1123   "unsigned-int32",
1124   "int64",
1125   "unsigned-int64",
1126   "float32",
1127   "float64",
1128   "char",
1129   "signed-char",
1130   "unsigned-char",
1131   "ISO-8859-1",
1132   "UCS-2",
1133   "UCS-4",
1134   "wchar_t",
1135   "short",
1136   "unsigned-short",
1137   "int",
1138   "unsigned-int",
1139   "long",
1140   "unsigned-long",
1141   "long-long",
1142   "unsigned-long-long",
1143   "float",
1144   "double",
1145   "struct",
1146   "union",
1147   "type",
1148   "pointer",
1149   "nonnull-pointer",
1150   "function",
1151   "nonnull-function",
1152   "bool",
1153   "char-string",
1154   "nonnull-char-string",
1155   "nonnull-char-string-list",
1156   "ISO-8859-1-string",
1157   "nonnull-ISO-8859-1-string",
1158   "nonnull-ISO-8859-1-string-list",
1159   "UTF-8-string",
1160   "nonnull-UTF-8-string",
1161   "nonnull-UTF-8-string-list",
1162   "UTF-16-string",
1163   "nonnull-UTF-16-string",
1164   "nonnull-UTF-16-string-list",
1165   "UCS-2-string",
1166   "nonnull-UCS-2-string",
1167   "nonnull-UCS-2-string-list",
1168   "UCS-4-string",
1169   "nonnull-UCS-4-string",
1170   "nonnull-UCS-4-string-list",
1171   "wchar_t-string",
1172   "nonnull-wchar_t-string",
1173   "nonnull-wchar_t-string-list",
1174   "VARIANT",
1175   "(heap overflow)"
1176 };
1177
1178
1179 #ifdef USE_WIN32
1180 #ifdef _UNICODE
1181 #define ___ERR_CODE_CE_SELECT(latin1,utf8,ucs2,ucs4,wchar,native) ucs2
1182 #else
1183 #define ___ERR_CODE_CE_SELECT(latin1,utf8,ucs2,ucs4,wchar,native) native
1184 #endif
1185 #endif
1186
1187 #ifndef ___ERR_CODE_CE_SELECT
1188 #define ___ERR_CODE_CE_SELECT(latin1,utf8,ucs2,ucs4,wchar,native) native
1189 #endif
1190
1191
1192 ___HIDDEN void append_charstring
1193    ___P((___STRING_TYPE(___ERR_CODE_CE_SELECT) buf,
1194          int *pos,
1195          const char *str),
1196         (buf,
1197          pos,
1198          str)
1199 ___STRING_TYPE(___ERR_CODE_CE_SELECT) buf;
1200 int *pos;
1201 const char *str;)
1202 {
1203   int i = 0;
1204   int p = *pos;
1205
1206   while (str[i] != '\0')
1207     {
1208       if (p >= ___ERR_MAX_LENGTH)
1209         break;
1210       buf[p++] = ___CAST(___CHAR_TYPE(___ERR_CODE_CE_SELECT),
1211                          ___CAST(unsigned char,str[i++]));
1212     }
1213
1214   buf[p] = 0;
1215
1216   *pos = p;
1217 }
1218
1219
1220 ___SCMOBJ ___os_err_code_to_string
1221    ___P((___SCMOBJ err),
1222         (err)
1223 ___SCMOBJ err;)
1224 {
1225   ___SCMOBJ e;
1226   ___SCMOBJ result;
1227   ___ERR_CODE err_code = ___INT(err);
1228   int facility = ___ERR_CODE_FACILITY(err_code);
1229   ___CHAR_TYPE(___ERR_CODE_CE_SELECT) buf[___ERR_MAX_LENGTH+1];
1230   int pos = 0;
1231
1232   buf[0] = 0;
1233
1234   if (facility >= ___ERR_CODE_FACILITY_SYSTEM)
1235     {
1236       /* System specific error code */
1237
1238       if (err_code == ___UNWIND_C_STACK)
1239         append_charstring (buf, &pos, "C stack can't be unwound further");
1240       else if (err_code == ___SFUN_HEAP_OVERFLOW_ERR)
1241         append_charstring (buf, &pos, "Heap overflow while allocating stack marker");
1242       else if (err_code == ___IMPL_LIMIT_ERR)
1243         append_charstring (buf, &pos, "Implementation limit encountered");
1244       else if (err_code == ___UNIMPL_ERR)
1245         append_charstring (buf, &pos, "Unimplemented operation");
1246       else if (err_code == ___HEAP_OVERFLOW_ERR)
1247         append_charstring (buf, &pos, "Heap overflow");
1248       else if (err_code == ___CLOSED_DEVICE_ERR)
1249         append_charstring (buf, &pos, "Device is closed");
1250       else if (err_code == ___INVALID_OP_ERR)
1251         append_charstring (buf, &pos, "Invalid operation");
1252       else if (err_code == ___MODULE_VERSION_TOO_OLD_ERR)
1253         append_charstring (buf, &pos, "Module was compiled with an older version of the compiler");
1254       else if (err_code == ___MODULE_VERSION_TOO_NEW_ERR)
1255         append_charstring (buf, &pos, "Module was compiled with a newer version of the compiler");
1256       else if (err_code == ___MODULE_ALREADY_LOADED_ERR)
1257         append_charstring (buf, &pos, "Can't load a given object file more than once");
1258       else if (err_code == ___DYNAMIC_LOADING_NOT_AVAILABLE_ERR)
1259         append_charstring (buf, &pos, "Dynamic loading is not available on this platform");
1260       else if (err_code == ___DYNAMIC_LOADING_LOOKUP_ERR)
1261         append_charstring (buf, &pos, "The object file did not contain the required function");
1262       else if ((err_code >= ___STOC_BASE && err_code <= ___STOC_MAX) ||
1263                (err_code >= ___CTOS_BASE && err_code <= ___CTOS_MAX))
1264         {
1265           int arg_num, c_type_index;
1266           char *dir;
1267           if (err_code <= ___STOC_MAX)
1268             {
1269               arg_num = (err_code-___STOC_BASE) & ((1<<7)-1);
1270               c_type_index = (err_code-___STOC_BASE) >> 7;
1271               dir = "to C";
1272             }
1273           else
1274             {
1275               arg_num = (err_code-___CTOS_BASE) & ((1<<7)-1);
1276               c_type_index = (err_code-___CTOS_BASE) >> 7;
1277               dir = "from C";
1278             }
1279           if (arg_num == ___RETURN_POS)
1280             append_charstring (buf, &pos, "Can't convert result ");
1281           else if (arg_num == 0)
1282             append_charstring (buf, &pos, "Can't convert ");
1283           else
1284             {
1285               char digit[2];
1286               int d = 1;
1287
1288               while (d < arg_num/10)
1289                 d *= 10;
1290
1291               append_charstring (buf, &pos, "(Argument ");
1292
1293               digit[1] = '\0';
1294               while (d > 0)
1295                 {
1296                   digit[0] = (arg_num / d % 10) + '0';
1297                   append_charstring (buf, &pos, digit);
1298                   d /= 10;
1299                 }
1300
1301               append_charstring (buf, &pos, ") Can't convert ");
1302             }
1303           append_charstring (buf, &pos, dir);
1304           append_charstring (buf, &pos, " ");
1305           append_charstring (buf, &pos, c_type_name_table[c_type_index]);
1306         }
1307       else
1308         append_charstring (buf, &pos, "Unknown error");
1309     }
1310   else if (facility >= ___ERR_CODE_FACILITY_MACOS)
1311     {
1312       /* MACOS error code */
1313
1314       append_charstring (buf, &pos, "Unknown MACOS error");
1315     }
1316   else if (facility >= ___ERR_CODE_FACILITY_ERRNO)
1317     {
1318       /* ANSI-C errno error code */
1319
1320 #ifdef USE_errno
1321
1322       char *msg = errno_to_string (___ERRNO_FROM_ERR_CODE(err_code));
1323
1324       if (msg == NULL)
1325         msg = "Unknown error";
1326
1327       append_charstring (buf, &pos, msg);
1328
1329 #endif
1330     }
1331   else if (facility >= ___ERR_CODE_FACILITY_H_ERRNO)
1332     {
1333       /* netdb h_errno error code */
1334
1335 #ifdef USE_h_errno
1336
1337       const char *msg = h_errno_to_string (___H_ERRNO_FROM_ERR_CODE(err_code));
1338
1339       if (msg == NULL)
1340         msg = "Unknown error";
1341
1342       append_charstring (buf, &pos, msg);
1343
1344 #endif
1345     }
1346   else if (facility >= ___ERR_CODE_FACILITY_GAI_CODE)
1347     {
1348       /* getaddressinfo error code */
1349
1350 #ifdef USE_getaddrinfo
1351
1352       const char *msg = gai_code_to_string (___GAI_CODE_FROM_ERR_CODE(err_code));
1353
1354       if (msg == NULL)
1355         msg = "Unknown error";
1356
1357       append_charstring (buf, &pos, msg);
1358
1359 #endif
1360     }
1361   else
1362     {
1363       /* Windows HRESULT error code */
1364
1365 #ifdef USE_FormatMessage
1366
1367       DWORD len =
1368         FormatMessage (FORMAT_MESSAGE_FROM_SYSTEM |
1369                        FORMAT_MESSAGE_MAX_WIDTH_MASK,
1370                        NULL,
1371                        ___WIN32_FROM_ERR_CODE(err_code),
1372                        MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT),
1373                        buf,
1374                        ___ERR_MAX_LENGTH,
1375                        NULL);
1376
1377       if (len == 0)
1378         buf[0] = 0;
1379
1380 #endif
1381     }
1382
1383   if ((e = ___NONNULLSTRING_to_SCMOBJ
1384              (buf,
1385               &result,
1386               ___RETURN_POS,
1387               ___CE(___ERR_CODE_CE_SELECT)))
1388       != ___FIX(___NO_ERR))
1389     result = e;
1390   else
1391     ___release_scmobj (result);
1392
1393   return result;
1394 }
1395
1396
1397 /*---------------------------------------------------------------------------*/
1398
1399 /* Floating point environment setup. */
1400
1401
1402 ___HIDDEN void setup_fp ___PVOID
1403 {
1404 #ifdef USE_get_fpc_csr
1405
1406   /* Enable denormalized numbers. */
1407
1408   union fpc_csr csr;
1409
1410   csr.fc_word = get_fpc_csr ();
1411   csr.fc_struct.flush = 0;
1412   set_fpc_csr (csr.fc_word);
1413
1414 #endif
1415
1416 #ifdef USE_control87
1417
1418 #ifdef __LCC__
1419
1420 #define FP_EXC_MASK _MCW_EM
1421 #define FP_EXC_CW \
1422 (_EM_INVALID+_EM_ZERODIVIDE+_EM_OVERFLOW+_EM_UNDERFLOW+_EM_INEXACT+_EM_DENORMAL)
1423
1424   _control87 (FP_EXC_CW, FP_EXC_MASK);
1425
1426 #else
1427
1428 #define FP_EXC_MASK MCW_EM
1429 #define FP_EXC_CW \
1430 (EM_INVALID+EM_ZERODIVIDE+EM_OVERFLOW+EM_UNDERFLOW+EM_INEXACT+EM_DENORMAL)
1431
1432   _control87 (FP_EXC_CW, FP_EXC_MASK);
1433
1434 #endif
1435
1436 #endif
1437
1438 #ifdef USE__FPU_SETCW
1439
1440 #define FPU_CW \
1441 (_FPU_MASK_IM+_FPU_MASK_ZM+_FPU_MASK_OM+_FPU_MASK_UM+_FPU_MASK_PM+ \
1442 _FPU_MASK_DM+_FPU_DOUBLE+_FPU_RC_NEAREST)
1443
1444   fpu_control_t cw = FPU_CW;
1445   _FPU_SETCW (cw);
1446
1447 #endif
1448 }
1449
1450
1451 ___HIDDEN void cleanup_fp ___PVOID
1452 {
1453 }
1454
1455
1456 /*---------------------------------------------------------------------------*/
1457
1458 /* Interrupt handling. */
1459
1460
1461 #ifdef USE_POSIX
1462
1463
1464 void ___set_signal_handler
1465    ___P((int sig,
1466          void (*handler) ___P((int sig),())),
1467         (sig,
1468          handler)
1469 int sig;
1470 void (*handler) ___P((int sig),());)
1471 {
1472 #ifdef USE_sigaction
1473   struct sigaction act;
1474   act.sa_handler = handler;
1475   act.sa_flags = 0;
1476 #ifdef SA_INTERRUPT
1477   act.sa_flags |= SA_INTERRUPT;
1478 #endif
1479   sigemptyset (&act.sa_mask);
1480   sigaction (sig, &act, 0);
1481 #endif
1482
1483 #ifdef USE_signal
1484   signal (sig, handler);
1485 #endif
1486 }
1487
1488
1489 #endif
1490
1491
1492 /*---------------------------------------------------------------------------*/
1493
1494 /* Basic OS services module initialization/finalization. */
1495
1496
1497 #ifdef USE_CLASSIC_MACOS
1498
1499
1500 #define test_bit(n,i) ((n)&(1<<(i)))
1501
1502
1503 ___HIDDEN TrapType get_trap_type
1504    ___P((short trap_num),
1505         (trap_num)
1506 short trap_num;)
1507 {
1508   /* OS traps start with A0, Tool traps with A8 or AA. */
1509
1510   if (trap_num & 0x0800)
1511     return ToolTrap;
1512   else
1513     return OSTrap;
1514 }
1515
1516
1517 ___HIDDEN short nb_toolbox_traps ___PVOID
1518 {
1519   /* InitGraf (trap $A86E) is always implemented. */
1520
1521   if (NGetTrapAddress (0xA86E, ToolTrap) == NGetTrapAddress (0xAA6E, ToolTrap))
1522     return (0x200);
1523   else
1524     return (0x400);
1525 }
1526
1527
1528 ___HIDDEN ___BOOL trap_exists
1529   ___P((short trap_num),
1530        (trap_num)
1531 short trap_num;)
1532 {
1533   TrapType typ = get_trap_type (trap_num);
1534   if ((typ == ToolTrap) && ((trap_num &= 0x07FF) >= nb_toolbox_traps ()))
1535     return 0;
1536   return (NGetTrapAddress (_Unimplemented, ToolTrap) !=
1537           NGetTrapAddress (trap_num, typ));
1538 }
1539
1540
1541 #endif
1542
1543
1544 ___SCMOBJ ___setup_base_module ___PVOID
1545 {
1546   if (___base_mod.refcount == 0)
1547     {
1548 #ifdef USE_CLASSIC_MACOS
1549
1550       long response;
1551
1552       ___base_mod.has_GetUTCDateTime = trap_exists (_UTCDateTime);
1553       ___base_mod.has_GetDateTime = trap_exists (_GetDateTime);
1554       ___base_mod.has_ReadLocation = trap_exists (_ReadLocation);
1555       ___base_mod.has_Delay = trap_exists (_Delay);
1556       ___base_mod.has_IdleUpdate = trap_exists (_IdleUpdate);
1557       ___base_mod.has_WaitNextEvent = trap_exists (_WaitNextEvent);
1558       ___base_mod.has_OSDispatch = trap_exists (_OSDispatch);
1559
1560       ___base_mod.has_FindFolder =
1561         (Gestalt (gestaltFindFolderAttr, &response) == noErr &&
1562          test_bit (response, gestaltFindFolderPresent));
1563
1564       ___base_mod.has_AliasMgr =
1565         (Gestalt (gestaltAliasMgrAttr, &response) == noErr &&
1566          test_bit (response, gestaltAliasMgrPresent));
1567
1568       ___base_mod.has_AppleEvents =
1569         (Gestalt (gestaltAppleEventsAttr, &response) == noErr &&
1570          test_bit (response, gestaltAppleEventsPresent));
1571
1572 #endif
1573
1574 #ifdef ___DEBUG
1575
1576       ___base_mod.debug = NULL;
1577
1578 #ifdef USE_POSIX
1579 #if 1
1580       ___base_mod.debug = ___fopen ("console", "w");
1581 #else
1582       ___base_mod.debug = ___fopen ("/dev/console", "w");
1583 #endif
1584 #endif
1585
1586 #ifdef USE_WIN32
1587       ___base_mod.debug = ___fopen ("con:", "w");
1588 #endif
1589
1590       if (___base_mod.debug == NULL)
1591         ___base_mod.debug = ___stderr;
1592
1593       ___printf ("*** START OF DEBUGGING TRACES\n");
1594
1595       ___base_mod.alloc_mem_calls = 0;
1596       ___base_mod.free_mem_calls = 0;
1597
1598 #endif
1599
1600       setup_fp ();
1601     }
1602
1603   ___base_mod.refcount++;
1604
1605   return ___FIX(___NO_ERR);
1606 }
1607
1608
1609 void ___cleanup_base_module ___PVOID
1610 {
1611   if (--___base_mod.refcount == 0)
1612     {
1613       cleanup_fp ();
1614
1615 #ifdef ___DEBUG
1616
1617       if (___base_mod.alloc_mem_calls != ___base_mod.free_mem_calls)
1618         {
1619           ___printf ("*** MEMORY LEAK: alloc_mem_calls = %ld  free_mem_calls = %ld\n",
1620                      ___base_mod.alloc_mem_calls,
1621                      ___base_mod.free_mem_calls);
1622         }
1623
1624       if (___base_mod.debug != ___stdout)
1625         ___fclose (___base_mod.debug);
1626
1627 #endif
1628     }
1629 }
1630
1631
1632 /*---------------------------------------------------------------------------*/