lib/os.c

   1 /* File: "os.c" */
   2
   3 /* Copyright (c) 1994-2011 by Marc Feeley, All Rights Reserved. */
   4
   5 /*
   6  * This module implements the operating system specific routines
   7  * including:
   8  *
   9  *  - OS specific initialization/finalization
  10  *  - process termination
  11  *  - error handling
  12  *  - conversion of error codes to error messages
  13  *  - low-level memory allocation
  14  *  - program startup
  15  *  - time management
  16  *  - process times (user time, system time and real time).
  17  *  - heartbeat interrupt handling
  18  *  - user interrupt handling
  19  *  - access to OS environment variables
  20  *  - shell command
  21  *  - dynamic loading
  22  *  - dynamic C compilation
  23  *  - floating point environment setup
  24  *  - virtual memory statistics
  25  *  - filesystem path expansion
  26  *  - formatting of source code position
  27  *  - operations on I/O devices
  28  */
  29
  30 #define ___INCLUDED_FROM_OS
  31 #define ___VERSION 406003
  32 #include "gambit.h"
  33
  34 #include "os_base.h"
  35 #include "os_time.h"
  36 #include "os_shell.h"
  37 #include "os_files.h"
  38 #include "os_dyn.h"
  39 #include "os_tty.h"
  40 #include "os_io.h"
  41 #include "setup.h"
  42 #include "mem.h"
  43 #include "c_intf.h"
  44
  45 /**********************************/
  46 #ifdef ___DEBUG
  47 #ifdef ___DEBUG_ALLOC_MEM_TRACE
  48 #define ___alloc_mem(bytes) ___alloc_mem_debug(bytes,__LINE__,__FILE__)
  49 #endif
  50 #endif
  51
  52
  53 /*---------------------------------------------------------------------------*/
  54
  55 #define NBELEMS(table)(sizeof (table) / sizeof (table[0]))
  56
  57
  58 /*---------------------------------------------------------------------------*/
  59
  60
  61 ___SCMOBJ ___setup_os_interrupt_handling ___PVOID
  62 {
  63   ___SCMOBJ e;
  64
  65   if ((e = ___setup_heartbeat_interrupt_handling ()) == ___FIX(___NO_ERR))
  66     {
  67       if ((e = ___setup_user_interrupt_handling ()) != ___FIX(___NO_ERR))
  68         ___cleanup_heartbeat_interrupt_handling ();
  69     }
  70
  71   return e;
  72 }
  73
  74 void ___cleanup_os_interrupt_handling ___PVOID
  75 {
  76   ___cleanup_user_interrupt_handling ();
  77   ___cleanup_heartbeat_interrupt_handling ();
  78 }
  79
  80 void ___disable_os_interrupts ___PVOID
  81 {
  82   ___disable_heartbeat_interrupts ();
  83   ___disable_user_interrupts ();
  84 }
  85
  86 void ___enable_os_interrupts ___PVOID
  87 {
  88   ___enable_user_interrupts ();
  89   ___enable_heartbeat_interrupts ();
  90 }
  91
  92
  93 /*---------------------------------------------------------------------------*/
  94
  95 /* Virtual memory statistics. */
  96
  97 void ___vm_stats
  98    ___P((long *minflt,
  99          long *majflt),
 100         (minflt,
 101          majflt)
 102 long *minflt;
 103 long *majflt;)
 104 {
 105 #ifndef USE_getrusage
 106
 107   *minflt = 0; /* can't get statistics... result is 0 */
 108   *majflt = 0;
 109
 110 #endif
 111
 112 #ifdef USE_getrusage
 113
 114   struct rusage ru;
 115
 116   if (getrusage (RUSAGE_SELF, &ru) == 0)
 117     {
 118       *minflt = ru.ru_minflt;
 119       *majflt = ru.ru_majflt;
 120     }
 121   else
 122     {
 123       *minflt = 0; /* can't get statistics... result is 0 */
 124       *majflt = 0;
 125     }
 126
 127 #endif
 128 }
 129
 130
 131 /*---------------------------------------------------------------------------*/
 132
 133 /* Formatting of source code position. */
 134
 135 char *___format_filepos
 136    ___P((char *path,
 137          long filepos,
 138          ___BOOL pinpoint),
 139         (path,
 140          filepos,
 141          pinpoint)
 142 char *path;
 143 long filepos;
 144 ___BOOL pinpoint;)
 145 {
 146 #ifdef USE_MACOS
 147
 148 #ifdef USE_mac_gui
 149
 150   if (pinpoint)
 151     mac_gui_highlight (path, filepos);
 152
 153 #endif
 154
 155 #endif
 156
 157   return 0; /* Use default format for displaying location */
 158 }
 159
 160
 161 /*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   */
 162
 163 /* Miscellaneous networking utilities. */
 164
 165 #ifdef USE_NETWORKING
 166
 167 #ifdef AF_INET6
 168 #define USE_IPV6
 169 #endif
 170
 171
 172 ___HIDDEN int network_family_decode
 173    ___P((int family),
 174         (family)
 175 int family;)
 176 {
 177   switch (family)
 178     {
 179 #ifdef PF_INET
 180     case -1:
 181       return PF_INET;
 182 #endif
 183
 184 #ifdef PF_INET6
 185     case -2:
 186       return PF_INET6;
 187 #endif
 188     }
 189
 190   return 0;
 191 }
 192
 193
 194 ___HIDDEN ___SCMOBJ network_family_encode
 195    ___P((int family),
 196         (family)
 197 int family;)
 198 {
 199   switch (family)
 200     {
 201 #ifdef PF_INET
 202     case PF_INET:
 203       return ___FIX(-1);
 204 #endif
 205
 206 #ifdef PF_INET6
 207     case PF_INET6:
 208       return ___FIX(-2);
 209 #endif
 210     }
 211
 212   return ___FIX(family);
 213 }
 214
 215
 216 ___HIDDEN int network_socktype_decode
 217    ___P((int socktype),
 218         (socktype)
 219 int socktype;)
 220 {
 221   switch (socktype)
 222     {
 223 #ifdef SOCK_STREAM
 224     case -1:
 225       return SOCK_STREAM;
 226 #endif
 227
 228 #ifdef SOCK_DGRAM
 229     case -2:
 230       return SOCK_DGRAM;
 231 #endif
 232
 233 #ifdef SOCK_RAW
 234     case -3:
 235       return SOCK_RAW;
 236 #endif
 237     }
 238
 239   return 0;
 240 }
 241
 242
 243 ___HIDDEN ___SCMOBJ network_socktype_encode
 244    ___P((int socktype),
 245         (socktype)
 246 int socktype;)
 247 {
 248   switch (socktype)
 249     {
 250 #ifdef SOCK_STREAM
 251     case SOCK_STREAM:
 252       return ___FIX(-1);
 253 #endif
 254
 255 #ifdef SOCK_DGRAM
 256     case SOCK_DGRAM:
 257       return ___FIX(-2);
 258 #endif
 259
 260 #ifdef SOCK_RAW
 261     case SOCK_RAW:
 262       return ___FIX(-3);
 263 #endif
 264     }
 265
 266   return ___FIX(socktype);
 267 }
 268
 269
 270 ___HIDDEN int network_protocol_decode
 271    ___P((int protocol),
 272         (protocol)
 273 int protocol;)
 274 {
 275   switch (protocol)
 276     {
 277 #ifdef IPPROTO_UDP
 278     case -1:
 279       return IPPROTO_UDP;
 280 #endif
 281
 282 #ifdef IPPROTO_TCP
 283     case -2:
 284       return IPPROTO_TCP;
 285 #endif
 286     }
 287
 288   return 0;
 289 }
 290
 291
 292 ___HIDDEN ___SCMOBJ network_protocol_encode
 293    ___P((int protocol),
 294         (protocol)
 295 int protocol;)
 296 {
 297   switch (protocol)
 298     {
 299 #ifdef IPPROTO_UDP
 300     case IPPROTO_UDP:
 301       return ___FIX(-1);
 302 #endif
 303
 304 #ifdef IPPROTO_TCP
 305     case IPPROTO_TCP:
 306       return ___FIX(-2);
 307 #endif
 308     }
 309
 310   return ___FIX(protocol);
 311 }
 312
 313
 314 ___SCMOBJ ___SCMOBJ_to_in_addr
 315    ___P((___SCMOBJ addr,
 316          struct in_addr *ia,
 317          int arg_num),
 318         (addr,
 319          ia,
 320          arg_num)
 321 ___SCMOBJ addr;
 322 struct in_addr *ia;
 323 int arg_num;)
 324 {
 325   if (addr == ___FAL)
 326     ia->s_addr = htonl (INADDR_ANY); /* wildcard address */
 327   else
 328     ia->s_addr = htonl ((___INT(___U8VECTORREF(addr,___FIX(0)))<<24) +
 329                         (___INT(___U8VECTORREF(addr,___FIX(1)))<<16) +
 330                         (___INT(___U8VECTORREF(addr,___FIX(2)))<<8) +
 331                         ___INT(___U8VECTORREF(addr,___FIX(3))));
 332
 333   return ___FIX(___NO_ERR);
 334 }
 335
 336
 337 ___SCMOBJ ___in_addr_to_SCMOBJ
 338    ___P((struct in_addr *ia,
 339          int arg_num),
 340         (ia,
 341          arg_num)
 342 struct in_addr *ia;
 343 int arg_num;)
 344 {
 345   unsigned long a;
 346   ___SCMOBJ result;
 347
 348   a = ntohl (ia->s_addr);
 349
 350   if (a == INADDR_ANY)
 351     result = ___FAL; /* wildcard address */
 352   else
 353     {
 354       result = ___alloc_scmobj (___sU8VECTOR, 4, ___STILL);
 355
 356       if (___FIXNUMP(result))
 357         return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+arg_num);
 358
 359
 360       ___U8VECTORSET(result,___FIX(0),___FIX((a>>24) & 0xff))
 361       ___U8VECTORSET(result,___FIX(1),___FIX((a>>16) & 0xff))
 362       ___U8VECTORSET(result,___FIX(2),___FIX((a>>8)  & 0xff))
 363       ___U8VECTORSET(result,___FIX(3),___FIX(a       & 0xff))
 364     }
 365
 366   return result;
 367 }
 368
 369
 370 #ifdef USE_IPV6
 371
 372 ___SCMOBJ ___SCMOBJ_to_in6_addr
 373    ___P((___SCMOBJ addr,
 374          struct in6_addr *ia,
 375          int arg_num),
 376         (addr,
 377          ia,
 378          arg_num)
 379 ___SCMOBJ addr;
 380 struct in6_addr *ia;
 381 int arg_num;)
 382 {
 383   int i;
 384
 385   if (addr == ___FAL)
 386     {
 387       /* wildcard address */
 388
 389       for (i=0; i<8; i++)
 390         {
 391           ia->s6_addr[i<<1] = 0;
 392           ia->s6_addr[(i<<1)+1] = 0;
 393         }
 394     }
 395   else
 396     {
 397       for (i=0; i<8; i++)
 398         {
 399           ___U16 x = ___INT(___U16VECTORREF(addr,___FIX(i)));
 400           ia->s6_addr[i<<1] = (x>>8) & 0xff;
 401           ia->s6_addr[(i<<1)+1] = x & 0xff;
 402         }
 403     }
 404
 405   return ___FIX(___NO_ERR);
 406 }
 407
 408
 409 ___SCMOBJ ___in6_addr_to_SCMOBJ
 410    ___P((struct in6_addr *ia,
 411          int arg_num),
 412         (ia,
 413          arg_num)
 414 struct in6_addr *ia;
 415 int arg_num;)
 416 {
 417   int i;
 418   ___SCMOBJ result;
 419
 420   for (i=0; i<16; i++)
 421     if (ia->s6_addr[i] != 0)
 422       break;
 423
 424   if (i == 16)
 425     result = ___FAL; /* wildcard address */
 426   else
 427     {
 428       result = ___alloc_scmobj (___sU16VECTOR, 8<<1, ___STILL);
 429
 430       if (___FIXNUMP(result))
 431         return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+arg_num);
 432
 433       for (i=0; i<8; i++)
 434         ___U16VECTORSET
 435           (result,
 436            ___FIX(i),
 437            ___FIX((___CAST(___U16,ia->s6_addr[i<<1])<<8) +
 438                   ia->s6_addr[(i<<1)+1]))
 439     }
 440
 441   return result;
 442 }
 443
 444 #endif
 445
 446
 447 ___SCMOBJ ___SCMOBJ_to_sockaddr
 448    ___P((___SCMOBJ addr,
 449          ___SCMOBJ port_num,
 450          struct sockaddr *sa,
 451          int *salen,
 452          int arg_num),
 453         (addr,
 454          port_num,
 455          sa,
 456          salen,
 457          arg_num)
 458 ___SCMOBJ addr;
 459 ___SCMOBJ port_num;
 460 struct sockaddr *sa;
 461 int *salen;
 462 int arg_num;)
 463 {
 464   ___SCMOBJ result;
 465   ___SCMOBJ ___temp; /* needed by the ___U8VECTORP and ___U16VECTORP macros */
 466
 467   if (addr == ___FAL || ___U8VECTORP(addr))
 468     {
 469       struct sockaddr_in *sa_in = ___CAST(struct sockaddr_in*,sa);
 470       *salen = sizeof (*sa_in);
 471       memset (sa_in, 0, sizeof (*sa_in));
 472       sa_in->sin_family = AF_INET;
 473       sa_in->sin_port = htons (___INT(port_num));
 474       result = ___SCMOBJ_to_in_addr (addr, &sa_in->sin_addr, arg_num);
 475     }
 476 #ifdef USE_IPV6
 477   else if (___U16VECTORP(addr))
 478     {
 479       struct sockaddr_in6 *sa_in6 = ___CAST(struct sockaddr_in6*,sa);
 480       *salen = sizeof (*sa_in6);
 481       memset (sa_in6, 0, sizeof (*sa_in6));
 482       sa_in6->sin6_family = AF_INET6;
 483       sa_in6->sin6_port = htons (___INT(port_num));
 484       result = ___SCMOBJ_to_in6_addr (addr, &sa_in6->sin6_addr, arg_num);
 485     }
 486 #endif
 487   else
 488     result = ___FIX(___UNKNOWN_ERR);
 489
 490   return result;
 491 }
 492
 493
 494 ___SCMOBJ ___sockaddr_to_SCMOBJ
 495    ___P((struct sockaddr *sa,
 496          int salen,
 497          int arg_num),
 498         (sa,
 499          salen,
 500          arg_num)
 501 struct sockaddr *sa;
 502 int salen;
 503 int arg_num;)
 504 {
 505   ___SCMOBJ result;
 506
 507   result = ___make_vector (4, ___FAL, ___STILL);
 508
 509   if (___FIXNUMP(result))
 510     return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+arg_num);
 511
 512   if (salen == sizeof (struct sockaddr_in))
 513     {
 514       struct sockaddr_in *sa_in = ___CAST(struct sockaddr_in*,sa);
 515       ___SCMOBJ addr = ___in_addr_to_SCMOBJ (&sa_in->sin_addr, arg_num);
 516
 517       if (___FIXNUMP(addr))
 518         {
 519           ___release_scmobj (result);
 520           return addr;
 521         }
 522
 523       ___FIELD(result,1) = network_family_encode (sa_in->sin_family);
 524       ___FIELD(result,2) = ___FIX(ntohs (sa_in->sin_port));
 525       ___FIELD(result,3) = addr;
 526       ___release_scmobj (addr);
 527     }
 528 #ifdef USE_IPV6
 529   else if (salen == sizeof (struct sockaddr_in6))
 530     {
 531       struct sockaddr_in6 *sa_in6 = ___CAST(struct sockaddr_in6*,sa);
 532       ___SCMOBJ addr = ___in6_addr_to_SCMOBJ (&sa_in6->sin6_addr, arg_num);
 533
 534       if (___FIXNUMP(addr))
 535         {
 536           ___release_scmobj (result);
 537           return addr;
 538         }
 539
 540       ___FIELD(result,1) = network_family_encode (sa_in6->sin6_family);
 541       ___FIELD(result,2) = ___FIX(ntohs (sa_in6->sin6_port));
 542       ___FIELD(result,3) = addr;
 543       ___release_scmobj (addr);
 544     }
 545 #endif
 546   else
 547     result = ___FAL;
 548
 549   ___release_scmobj (result);
 550
 551   return result;
 552 }
 553
 554
 555 ___SCMOBJ ___addr_to_SCMOBJ
 556    ___P((void *sa,
 557          int salen,
 558          int arg_num),
 559         (sa,
 560          salen,
 561          arg_num)
 562 void *sa;
 563 int salen;
 564 int arg_num;)
 565 {
 566   ___SCMOBJ result;
 567
 568   if (salen == 4)
 569     {
 570       struct in_addr *ia = ___CAST(struct in_addr*,sa);
 571       ___U32 a;
 572
 573       result = ___alloc_scmobj (___sU8VECTOR, 4, ___STILL);
 574
 575       if (___FIXNUMP(result))
 576         return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+arg_num);
 577
 578       a = ntohl (ia->s_addr);
 579
 580       ___U8VECTORSET(result,___FIX(0),___FIX((a>>24)&0xff))
 581       ___U8VECTORSET(result,___FIX(1),___FIX((a>>16)&0xff))
 582       ___U8VECTORSET(result,___FIX(2),___FIX((a>>8)&0xff))
 583       ___U8VECTORSET(result,___FIX(3),___FIX(a&0xff))
 584     }
 585 #ifdef USE_IPV6
 586   else if (salen == 16)
 587     {
 588       struct in6_addr *ia = ___CAST(struct in6_addr*,sa);
 589       int i;
 590
 591       result = ___alloc_scmobj (___sU16VECTOR, 8<<1, ___STILL);
 592
 593       if (___FIXNUMP(result))
 594         return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+arg_num);
 595
 596       for (i=0; i<8; i++)
 597         ___U16VECTORSET(result,
 598                         ___FIX(i),
 599                         ___FIX((___CAST(___U16,ia->s6_addr[i<<1])<<8)
 600                                +ia->s6_addr[(i<<1)+1]))
 601     }
 602 #endif
 603   else
 604     result = ___FAL;
 605
 606   ___release_scmobj (result);
 607
 608   return result;
 609 }
 610
 611 #endif
 612
 613
 614 /*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   */
 615
 616 /* Access to host information. */
 617
 618 #ifdef USE_getaddrinfo
 619
 620 ___HIDDEN int ai_flags_decode
 621    ___P((int flags),
 622         (flags)
 623 int flags;)
 624 {
 625   int ai_flags = 0;
 626
 627 #ifdef AI_PASSIVE
 628   if (flags & 1)
 629     ai_flags |= AI_PASSIVE;
 630 #endif
 631
 632 #ifdef AI_CANONNAME
 633   if (flags & 2)
 634     ai_flags |= AI_CANONNAME;
 635 #endif
 636
 637 #ifdef AI_NUMERICHOST
 638   if (flags & 4)
 639     ai_flags |= AI_NUMERICHOST;
 640 #endif
 641
 642 #ifdef AI_NUMERICSERV
 643   if (flags & 8)
 644     ai_flags |= AI_NUMERICSERV;
 645 #endif
 646
 647 #ifdef AI_ALL
 648   if (flags & 16)
 649     ai_flags |= AI_ALL;
 650 #endif
 651
 652 #ifdef AI_ADDRCONFIG
 653   if (flags & 32)
 654     ai_flags |= AI_ADDRCONFIG;
 655 #endif
 656
 657 #ifdef AI_V4MAPPED
 658   if (flags & 64)
 659     ai_flags |= AI_V4MAPPED;
 660 #endif
 661
 662   return ai_flags;
 663 }
 664
 665 #endif
 666
 667
 668 ___SCMOBJ ___os_address_infos
 669    ___P((___SCMOBJ host,
 670          ___SCMOBJ serv,
 671          ___SCMOBJ flags,
 672          ___SCMOBJ family,
 673          ___SCMOBJ socktype,
 674          ___SCMOBJ protocol),
 675         (host,
 676          serv,
 677          flags,
 678          family,
 679          socktype,
 680          protocol)
 681 ___SCMOBJ host;
 682 ___SCMOBJ serv;
 683 ___SCMOBJ flags;
 684 ___SCMOBJ family;
 685 ___SCMOBJ socktype;
 686 ___SCMOBJ protocol;)
 687 {
 688 #ifndef USE_getaddrinfo
 689
 690   return ___FIX(___UNIMPL_ERR);
 691
 692 #endif
 693
 694 #ifdef USE_getaddrinfo
 695
 696   ___SCMOBJ e;
 697   ___SCMOBJ vect;
 698   ___SCMOBJ lst;
 699   ___SCMOBJ tail;
 700   ___SCMOBJ x;
 701   ___SCMOBJ p;
 702   int i;
 703   char *chost = 0;
 704   char *cserv = 0;
 705
 706   struct addrinfo hints, *res, *res0;
 707   int code;
 708
 709   if ((e = ___SCMOBJ_to_CHARSTRING (host, &chost, 1))
 710       != ___FIX(___NO_ERR))
 711     return e;
 712
 713   if ((e = ___SCMOBJ_to_CHARSTRING (serv, &cserv, 2))
 714       != ___FIX(___NO_ERR))
 715     {
 716       ___release_string (chost);
 717       return e;
 718     }
 719
 720   memset (&hints, 0, sizeof (hints));
 721
 722   hints.ai_flags    = ai_flags_decode (___INT(flags));
 723   hints.ai_family   = network_family_decode (___INT(family));
 724   hints.ai_socktype = network_socktype_decode (___INT(socktype));
 725   hints.ai_protocol = network_protocol_decode (___INT(protocol));
 726
 727   code = getaddrinfo (chost, cserv, &hints, &res0);
 728
 729   if (code != 0)
 730     {
 731       e = err_code_from_gai_code (code);
 732       ___release_string (chost);
 733       ___release_string (cserv);
 734       return e;
 735     }
 736
 737   lst = ___NUL;
 738   tail = ___FAL;
 739
 740   for (res = res0; res != NULL; res = res->ai_next)
 741     {
 742       x = ___sockaddr_to_SCMOBJ (res->ai_addr,
 743                                  res->ai_addrlen,
 744                                  ___RETURN_POS);
 745
 746       if (___FIXNUMP(x))
 747         {
 748           ___release_scmobj (lst);
 749           freeaddrinfo (res0);
 750           return x;
 751         }
 752
 753       if (x != ___FAL)
 754         {
 755           vect = ___make_vector (5, ___FAL, ___STILL);
 756
 757           if (___FIXNUMP(vect))
 758             {
 759               ___release_scmobj (x);
 760               ___release_scmobj (lst);
 761               freeaddrinfo (res0);
 762               return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);
 763             }
 764
 765           ___FIELD(vect,1) = network_family_encode (res->ai_family);
 766           ___FIELD(vect,2) = network_socktype_encode (res->ai_socktype);
 767           ___FIELD(vect,3) = network_protocol_encode (res->ai_protocol);
 768           ___FIELD(vect,4) = x;
 769
 770           ___release_scmobj (x);
 771
 772           p = ___make_pair (vect, ___NUL, ___STILL);
 773
 774           ___release_scmobj (vect);
 775
 776           if (___FIXNUMP(p))
 777             {
 778               ___release_scmobj (lst);
 779               freeaddrinfo (res0);
 780               return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);
 781             }
 782
 783           if (lst == ___NUL)
 784             lst = p;
 785           else
 786             ___SETCDR(tail,p);
 787
 788           tail = p;
 789         }
 790     }
 791
 792   ___release_scmobj (lst);
 793
 794   freeaddrinfo (res0);
 795
 796   ___release_string (chost);
 797   ___release_string (cserv);
 798
 799   return lst;
 800
 801 #endif
 802 }
 803
 804
 805 ___SCMOBJ ___os_host_info
 806    ___P((___SCMOBJ host),
 807         (host)
 808 ___SCMOBJ host;)
 809 {
 810 #ifndef USE_gethostbyname
 811
 812   return ___FIX(___UNIMPL_ERR);
 813
 814 #endif
 815
 816 #ifdef USE_gethostbyname
 817
 818   ___SCMOBJ e;
 819   ___SCMOBJ vect;
 820   ___SCMOBJ lst;
 821   ___SCMOBJ x;
 822   ___SCMOBJ p;
 823   int i;
 824   struct hostent *he = 0;
 825   char *chost = 0;
 826
 827   ___SCMOBJ ___temp; /* needed by the ___U8VECTORP and ___U16VECTORP macros */
 828
 829 #ifdef USE_POSIX
 830
 831   errno = 0; /* in case the h_errno ends up being NETDB_SUCCESS
 832               * incorrectly which will be treated as NETDB_INTERNAL
 833               * (see err_code_from_h_errno)
 834               */
 835
 836 #endif
 837
 838 #ifdef USE_gethostbyaddr
 839
 840   if (___U8VECTORP(host))
 841     {
 842       struct in_addr ia;
 843
 844       if ((e = ___SCMOBJ_to_in_addr (host, &ia, 1)) != ___FIX(___NO_ERR))
 845         return e;
 846
 847       he = gethostbyaddr (___CAST(char*,&ia), 4, AF_INET);
 848     }
 849 #ifdef USE_IPV6
 850   else if (___U16VECTORP(host))
 851     {
 852       struct in6_addr ia;
 853
 854       if ((e = ___SCMOBJ_to_in6_addr (host, &ia, 1)) != ___FIX(___NO_ERR))
 855         return e;
 856
 857       he = gethostbyaddr (___CAST(char*,&ia), 16, AF_INET6);
 858     }
 859 #endif
 860   else
 861
 862 #endif
 863
 864     {
 865       /*
 866        * Convert the Scheme string to a C "char*" string.  If an
 867        * invalid character is seen then return an error.
 868        */
 869
 870       if ((e = ___SCMOBJ_to_NONNULLCHARSTRING (host, &chost, 1))
 871           != ___FIX(___NO_ERR))
 872         return e;
 873
 874 #ifdef USE_inet_pton
 875
 876       {
 877         struct in_addr ia;
 878
 879         if (inet_pton (AF_INET, chost, &ia) == 1)
 880           he = gethostbyaddr (___CAST(char*,&ia), 4, AF_INET);
 881       }
 882
 883 #ifdef USE_IPV6
 884
 885       if (he == 0)
 886         {
 887           struct in6_addr ia;
 888
 889           if (inet_pton (AF_INET6, chost, &ia) == 1)
 890             he = gethostbyaddr (___CAST(char*,&ia), 16, AF_INET6);
 891         }
 892
 893 #endif
 894
 895       if (he == 0)
 896
 897 #endif
 898
 899         {
 900           he = gethostbyname (chost);
 901         }
 902     }
 903
 904   if (he == 0)
 905     {
 906 #ifdef USE_POSIX
 907       e = err_code_from_h_errno ();
 908 #endif
 909
 910 #ifdef USE_WIN32
 911       e = err_code_from_WSAGetLastError ();
 912 #endif
 913     }
 914
 915   ___release_string (chost);
 916
 917   if (e != ___FIX(___NO_ERR))
 918     return e;
 919
 920   vect = ___make_vector (4, ___FAL, ___STILL);
 921
 922   if (___FIXNUMP(vect))
 923     return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);
 924
 925   /* convert h_name to string */
 926
 927   if ((e = ___CHARSTRING_to_SCMOBJ
 928              (___CAST(char*,he->h_name),
 929               &x,
 930               ___RETURN_POS))
 931       != ___FIX(___NO_ERR))
 932     {
 933       ___release_scmobj (vect);
 934       return e;
 935     }
 936
 937   ___FIELD(vect,1) = x;
 938   ___release_scmobj (x);
 939
 940   /* convert h_aliases to strings */
 941
 942   i = 0;
 943   while (he->h_aliases[i] != 0)
 944     i++;
 945
 946   lst = ___NUL;
 947   while (i-- > 0)
 948     {
 949       if ((e = ___CHARSTRING_to_SCMOBJ
 950                  (___CAST(char*,he->h_aliases[i]),
 951                   &x,
 952                   ___RETURN_POS))
 953           != ___FIX(___NO_ERR))
 954         {
 955           ___release_scmobj (lst);
 956           ___release_scmobj (vect);
 957           return e;
 958         }
 959
 960       p = ___make_pair (x, lst, ___STILL);
 961
 962       ___release_scmobj (x);
 963       ___release_scmobj (lst);
 964
 965       if (___FIXNUMP(p))
 966         {
 967           ___release_scmobj (vect);
 968           return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);
 969         }
 970
 971       lst = p;
 972     }
 973
 974   ___FIELD(vect,2) = lst;
 975   ___release_scmobj (lst);
 976
 977   /* convert h_addr_list to u8/u16vectors */
 978
 979   i = 0;
 980   while (he->h_addr_list[i] != 0)
 981     i++;
 982
 983   lst = ___NUL;
 984   while (i-- > 0)
 985     {
 986       switch (he->h_addrtype)
 987         {
 988         case AF_INET:
 989           {
 990             x = ___in_addr_to_SCMOBJ
 991                   (___CAST(struct in_addr*,he->h_addr_list[i]),
 992                    ___RETURN_POS);
 993             break;
 994           }
 995
 996 #ifdef USE_IPV6
 997         case AF_INET6:
 998           {
 999             x = ___in6_addr_to_SCMOBJ
1000                   (___CAST(struct in6_addr*,he->h_addr_list[i]),
1001                    ___RETURN_POS);
1002             break;
1003           }
1004
1005 #endif
1006
1007         default:
1008           continue; /* ignore unknown address families */
1009         }
1010
1011       if (___FIXNUMP(x))
1012         {
1013           ___release_scmobj (lst);
1014           ___release_scmobj (vect);
1015           return x;
1016         }
1017
1018       p = ___make_pair (x, lst, ___STILL);
1019
1020       ___release_scmobj (x);
1021       ___release_scmobj (lst);
1022
1023       if (___FIXNUMP(p))
1024         {
1025           ___release_scmobj (vect);
1026           return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);
1027         }
1028
1029       lst = p;
1030     }
1031
1032   ___FIELD(vect,3) = lst;
1033   ___release_scmobj (lst);
1034   ___release_scmobj (vect);
1035
1036   /* guarantee that at least one address is returned */
1037
1038   if (lst == ___NUL)
1039     return ___FIX(___H_ERRNO_ERR(NO_ADDRESS));
1040
1041   return vect;
1042
1043 #endif
1044 }
1045
1046
1047 ___SCMOBJ ___os_host_name ___PVOID
1048 {
1049 #ifndef USE_gethostname
1050
1051   return ___FIX(___UNIMPL_ERR);
1052
1053 #endif
1054
1055 #ifdef USE_gethostname
1056
1057 #define HOSTNAME_MAX_LEN 1024
1058
1059   ___SCMOBJ e;
1060   ___SCMOBJ result;
1061   char name[HOSTNAME_MAX_LEN];
1062
1063   if (gethostname (name, HOSTNAME_MAX_LEN) < 0)
1064     return err_code_from_errno ();
1065
1066   if ((e = ___NONNULLCHARSTRING_to_SCMOBJ (name, &result, ___RETURN_POS))
1067       != ___FIX(___NO_ERR))
1068     return e;
1069
1070   ___release_scmobj (result);
1071
1072   return result;
1073
1074 #endif
1075 }
1076
1077
1078 /*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   */
1079
1080 /* Access to service information. */
1081
1082 ___SCMOBJ ___os_service_info
1083    ___P((___SCMOBJ service,
1084          ___SCMOBJ protocol),
1085         (service,
1086          protocol)
1087 ___SCMOBJ service;
1088 ___SCMOBJ protocol;)
1089 {
1090 #ifndef USE_getservbyname
1091
1092   return ___FIX(___UNIMPL_ERR);
1093
1094 #endif
1095
1096 #ifdef USE_getservbyname
1097
1098   ___SCMOBJ e;
1099   ___SCMOBJ vect;
1100   ___SCMOBJ lst;
1101   ___SCMOBJ x;
1102   ___SCMOBJ p;
1103   int i;
1104   struct servent *se;
1105   char *cservice;
1106   char *cprotocol;
1107
1108   /*
1109    * Convert the Scheme string to a C "char*" string.  If an invalid
1110    * character is seen then return an error.
1111    */
1112
1113   if (!___FIXNUMP(service))
1114     if ((e = ___SCMOBJ_to_NONNULLCHARSTRING (service, &cservice, 1))
1115         != ___FIX(___NO_ERR))
1116       return e;
1117
1118   if ((e = ___SCMOBJ_to_CHARSTRING (protocol, &cprotocol, 2))
1119       != ___FIX(___NO_ERR))
1120     {
1121       if (!___FIXNUMP(service))
1122         ___release_string (cservice);
1123       return e;
1124     }
1125
1126 #ifdef USE_POSIX
1127
1128   errno = 0; /* in case the h_errno ends up being NETDB_SUCCESS
1129               * incorrectly which will be treated as NETDB_INTERNAL
1130               * (see err_code_from_h_errno)
1131               */
1132
1133 #endif
1134
1135   if (___FIXNUMP(service))
1136     se = getservbyport (htons (___INT(service)), cprotocol);
1137   else
1138     se = getservbyname (cservice, cprotocol);
1139
1140   if (se == 0)
1141     {
1142 #ifdef USE_POSIX
1143
1144       e = err_code_from_h_errno ();
1145
1146 #endif
1147
1148 #ifdef USE_WIN32
1149
1150       e = err_code_from_WSAGetLastError ();
1151
1152 #endif
1153     }
1154
1155   if (cprotocol != 0)
1156     ___release_string (cprotocol);
1157
1158   if (!___FIXNUMP(service))
1159     ___release_string (cservice);
1160
1161   if (e != ___FIX(___NO_ERR))
1162     return e;
1163
1164   vect = ___make_vector (5, ___FAL, ___STILL);
1165
1166   if (___FIXNUMP(vect))
1167     return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);/************/
1168
1169   /* convert s_name to string */
1170
1171   if ((e = ___CHARSTRING_to_SCMOBJ (se->s_name, &x, ___RETURN_POS))
1172       != ___FIX(___NO_ERR))
1173     {
1174       ___release_scmobj (vect);
1175       return e;
1176     }
1177
1178   ___FIELD(vect,1) = x;
1179   ___release_scmobj (x);
1180
1181   /* convert s_aliases to strings */
1182
1183   i = 0;
1184   while (se->s_aliases[i] != 0)
1185     i++;
1186
1187   lst = ___NUL;
1188   while (i-- > 0)
1189     {
1190       if ((e = ___CHARSTRING_to_SCMOBJ (se->s_aliases[i], &x, ___RETURN_POS))
1191           != ___FIX(___NO_ERR))
1192         {
1193           ___release_scmobj (lst);
1194           ___release_scmobj (vect);
1195           return e;
1196         }
1197
1198       p = ___make_pair (x, lst, ___STILL);
1199
1200       ___release_scmobj (x);
1201       ___release_scmobj (lst);
1202
1203       if (___FIXNUMP(p))
1204         {
1205           ___release_scmobj (vect);
1206           return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);/*******************/
1207         }
1208
1209       lst = p;
1210     }
1211
1212   ___FIELD(vect,2) = lst;
1213   ___release_scmobj (lst);
1214
1215   /* convert s_port to integer */
1216
1217   ___FIELD(vect,3) = ___FIX(ntohs (se->s_port));
1218
1219   /* convert s_name to string */
1220
1221   if ((e = ___CHARSTRING_to_SCMOBJ (se->s_proto, &x, ___RETURN_POS))
1222       != ___FIX(___NO_ERR))
1223     {
1224       ___release_scmobj (vect);
1225       return e;
1226     }
1227
1228   ___FIELD(vect,4) = x;
1229   ___release_scmobj (x);
1230
1231   ___release_scmobj (vect);
1232
1233   return vect;
1234
1235 #endif
1236 }
1237
1238
1239 /*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   */
1240
1241 /* Access to protocol information. */
1242
1243 ___SCMOBJ ___os_protocol_info
1244    ___P((___SCMOBJ protocol),
1245         (protocol)
1246 ___SCMOBJ protocol;)
1247 {
1248 #ifndef USE_getprotobyname
1249
1250   return ___FIX(___UNIMPL_ERR);
1251
1252 #endif
1253
1254 #ifdef USE_getprotobyname
1255
1256   ___SCMOBJ e = ___FIX(___NO_ERR);
1257   ___SCMOBJ vect;
1258   ___SCMOBJ lst;
1259   ___SCMOBJ x;
1260   ___SCMOBJ p;
1261   int i;
1262   struct protoent *pe;
1263   char *cprotocol;
1264
1265   /*
1266    * Convert the Scheme string to a C "char*" string.  If an invalid
1267    * character is seen then return an error.
1268    */
1269
1270   if (!___FIXNUMP(protocol))
1271     if ((e = ___SCMOBJ_to_NONNULLCHARSTRING (protocol, &cprotocol, 1))
1272         != ___FIX(___NO_ERR))
1273       return e;
1274
1275 #ifdef USE_POSIX
1276
1277   errno = 0; /* in case the h_errno ends up being NETDB_SUCCESS
1278               * incorrectly which will be treated as NETDB_INTERNAL
1279               * (see err_code_from_h_errno)
1280               */
1281
1282 #endif
1283
1284   if (___FIXNUMP(protocol))
1285     pe = getprotobynumber (___INT(protocol));
1286   else
1287     pe = getprotobyname (cprotocol);
1288
1289   if (pe == 0)
1290     {
1291 #ifdef USE_POSIX
1292
1293       e = err_code_from_h_errno ();
1294
1295 #endif
1296
1297 #ifdef USE_WIN32
1298
1299       e = err_code_from_WSAGetLastError ();
1300
1301 #endif
1302     }
1303
1304   if (!___FIXNUMP(protocol))
1305     ___release_string (cprotocol);
1306
1307   if (e != ___FIX(___NO_ERR))
1308     return e;
1309
1310   vect = ___make_vector (4, ___FAL, ___STILL);
1311
1312   if (___FIXNUMP(vect))
1313     return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);/************/
1314
1315   /* convert p_name to string */
1316
1317   if ((e = ___CHARSTRING_to_SCMOBJ (pe->p_name, &x, ___RETURN_POS))
1318       != ___FIX(___NO_ERR))
1319     {
1320       ___release_scmobj (vect);
1321       return e;
1322     }
1323
1324   ___FIELD(vect,1) = x;
1325   ___release_scmobj (x);
1326
1327   /* convert p_aliases to strings */
1328
1329   i = 0;
1330   while (pe->p_aliases[i] != 0)
1331     i++;
1332
1333   lst = ___NUL;
1334   while (i-- > 0)
1335     {
1336       if ((e = ___CHARSTRING_to_SCMOBJ (pe->p_aliases[i], &x, ___RETURN_POS))
1337           != ___FIX(___NO_ERR))
1338         {
1339           ___release_scmobj (lst);
1340           ___release_scmobj (vect);
1341           return e;
1342         }
1343
1344       p = ___make_pair (x, lst, ___STILL);
1345
1346       ___release_scmobj (x);
1347       ___release_scmobj (lst);
1348
1349       if (___FIXNUMP(p))
1350         {
1351           ___release_scmobj (vect);
1352           return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);/*******************/
1353         }
1354
1355       lst = p;
1356     }
1357
1358   ___FIELD(vect,2) = lst;
1359   ___release_scmobj (lst);
1360
1361   /* convert p_proto to integer */
1362
1363   ___FIELD(vect,3) = ___FIX(pe->p_proto);
1364
1365   ___release_scmobj (vect);
1366
1367   return vect;
1368
1369 #endif
1370 }
1371
1372
1373 /*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   */
1374
1375 /* Access to network information. */
1376
1377 ___SCMOBJ ___os_network_info
1378    ___P((___SCMOBJ network),
1379         (network)
1380 ___SCMOBJ network;)
1381 {
1382 #ifndef USE_getnetbyname
1383
1384   return ___FIX(___UNIMPL_ERR);
1385
1386 #else
1387
1388   return ___FIX(___UNIMPL_ERR);
1389
1390 #endif
1391 }
1392
1393
1394 /*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   */
1395
1396 /* Access to file information. */
1397
1398 ___SCMOBJ ___os_file_info
1399    ___P((___SCMOBJ path,
1400          ___SCMOBJ chase),
1401         (path,
1402          chase)
1403 ___SCMOBJ path;
1404 ___SCMOBJ chase;)
1405 {
1406   ___SCMOBJ e;
1407   ___SCMOBJ result;
1408   ___SCMOBJ x;
1409   void *cpath;
1410
1411 #ifndef USE_stat
1412 #ifndef USE_GetFileAttributesEx
1413
1414 #define ___INFO_PATH_CE_SELECT(latin1,utf8,ucs2,ucs4,wchar,native) native
1415
1416   if ((e = ___SCMOBJ_to_NONNULLSTRING
1417              (path,
1418               &cpath,
1419               1,
1420               ___CE(___INFO_PATH_CE_SELECT),
1421               0))
1422       == ___FIX(___NO_ERR))
1423     {
1424       ___FILE *check_exist = ___fopen (cpath, "r");
1425
1426       if (check_exist == 0)
1427         {
1428           e = fnf_or_err_code_from_errno ();
1429           ___release_string (cpath);
1430           return e;
1431         }
1432
1433       ___fclose (check_exist);
1434
1435       ___release_string (cpath);
1436
1437       result = ___make_vector (14, ___FAL, ___STILL);
1438
1439       if (___FIXNUMP(result))
1440         return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);/**********/
1441
1442       ___FIELD(result,1) = ___FIX(0); /* unknown type */
1443       ___FIELD(result,2) = ___FIX(0);
1444       ___FIELD(result,3) = ___FIX(0);
1445       ___FIELD(result,4) = ___FIX(0);
1446       ___FIELD(result,5) = ___FIX(0);
1447       ___FIELD(result,6) = ___FIX(0);
1448       ___FIELD(result,7) = ___FIX(0);
1449       ___FIELD(result,8) = ___FIX(0);
1450
1451       if ((e = ___F64_to_SCMOBJ (___CAST(___F64,NEG_INFINITY),
1452                                  &x,
1453                                  ___RETURN_POS))
1454           != ___FIX(___NO_ERR))
1455         {
1456           ___release_scmobj (result);
1457           return e;
1458         }
1459
1460       ___FIELD(result,9) = x;
1461       ___FIELD(result,10) = x;
1462       ___FIELD(result,11) = x;
1463       ___FIELD(result,12) = ___FIX(0);
1464       ___FIELD(result,13) = x;
1465
1466       ___release_scmobj (x);
1467
1468       ___release_scmobj (result);
1469
1470       return result;
1471     }
1472
1473 #endif
1474 #endif
1475
1476 #ifdef USE_stat
1477
1478 #define ___INFO_PATH_CE_SELECT(latin1,utf8,ucs2,ucs4,wchar,native) native
1479
1480   if ((e = ___SCMOBJ_to_NONNULLSTRING
1481              (path,
1482               &cpath,
1483               1,
1484               ___CE(___INFO_PATH_CE_SELECT),
1485               0))
1486       == ___FIX(___NO_ERR))
1487     {
1488       ___struct_stat s;
1489
1490       if (((chase == ___FAL)
1491            ? ___lstat (___CAST(___STRING_TYPE(___INFO_PATH_CE_SELECT),cpath), &s)
1492            : ___stat (___CAST(___STRING_TYPE(___INFO_PATH_CE_SELECT),cpath), &s))
1493           < 0)
1494         {
1495           e = fnf_or_err_code_from_errno ();
1496           ___release_string (cpath);
1497           return e;
1498         }
1499
1500       ___release_string (cpath);
1501
1502       result = ___make_vector (14, ___FAL, ___STILL);
1503
1504       if (___FIXNUMP(result))
1505         return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);/**********/
1506
1507       if (S_ISREG(s.st_mode))
1508         ___FIELD(result,1) = ___FIX(1);
1509       else if (S_ISDIR(s.st_mode))
1510         ___FIELD(result,1) = ___FIX(2);
1511       else if (S_ISCHR(s.st_mode))
1512         ___FIELD(result,1) = ___FIX(3);
1513       else if (S_ISBLK(s.st_mode))
1514         ___FIELD(result,1) = ___FIX(4);
1515       else if (S_ISFIFO(s.st_mode))
1516         ___FIELD(result,1) = ___FIX(5);
1517       else if (S_ISLNK(s.st_mode))
1518         ___FIELD(result,1) = ___FIX(6);
1519       else if (S_ISSOCK(s.st_mode))
1520         ___FIELD(result,1) = ___FIX(7);
1521       else
1522         ___FIELD(result,1) = ___FIX(0);
1523
1524       if ((e = ___ULONGLONG_to_SCMOBJ (___CAST(___ULONGLONG,s.st_dev),
1525                                        &x,
1526                                        ___RETURN_POS))
1527           != ___FIX(___NO_ERR))
1528         {
1529           ___release_scmobj (result);
1530           return e;
1531         }
1532
1533       ___FIELD(result,2) = x;
1534       ___release_scmobj (x);
1535
1536       if ((e = ___LONGLONG_to_SCMOBJ (___CAST(___LONGLONG,s.st_ino),
1537                                       &x,
1538                                       ___RETURN_POS))
1539           != ___FIX(___NO_ERR))
1540         {
1541           ___release_scmobj (result);
1542           return e;
1543         }
1544
1545       ___FIELD(result,3) = x;
1546       ___release_scmobj (x);
1547
1548       ___FIELD(result,4) =
1549         ___FIX(s.st_mode & (S_ISUID|S_ISGID|S_ISVTX|S_IRWXU|S_IRWXG|S_IRWXO));
1550
1551       if ((e = ___ULONGLONG_to_SCMOBJ (___CAST(___ULONGLONG,s.st_nlink),
1552                                        &x,
1553                                        ___RETURN_POS))
1554           != ___FIX(___NO_ERR))
1555         {
1556           ___release_scmobj (result);
1557           return e;
1558         }
1559
1560       ___FIELD(result,5) = x;
1561       ___release_scmobj (x);
1562
1563       ___FIELD(result,6) = ___FIX(s.st_uid);
1564
1565       ___FIELD(result,7) = ___FIX(s.st_gid);
1566
1567       if ((e = ___LONGLONG_to_SCMOBJ (___CAST(___LONGLONG,s.st_size),
1568                                       &x,
1569                                       ___RETURN_POS))
1570           != ___FIX(___NO_ERR))
1571         {
1572           ___release_scmobj (result);
1573           return e;
1574         }
1575
1576       ___FIELD(result,8) = x;
1577       ___release_scmobj (x);
1578
1579       if ((e = ___F64_to_SCMOBJ (___CAST(___F64,s.st_atime), &x, ___RETURN_POS))
1580           != ___FIX(___NO_ERR))
1581         {
1582           ___release_scmobj (result);
1583           return e;
1584         }
1585
1586       ___FIELD(result,9) = x;
1587       ___release_scmobj (x);
1588
1589       if ((e = ___F64_to_SCMOBJ (___CAST(___F64,s.st_mtime), &x, ___RETURN_POS))
1590           != ___FIX(___NO_ERR))
1591         {
1592           ___release_scmobj (result);
1593           return e;
1594         }
1595
1596       ___FIELD(result,10) = x;
1597       ___release_scmobj (x);
1598
1599       if ((e = ___F64_to_SCMOBJ (___CAST(___F64,s.st_ctime), &x, ___RETURN_POS))
1600           != ___FIX(___NO_ERR))
1601         {
1602           ___release_scmobj (result);
1603           return e;
1604         }
1605
1606       ___FIELD(result,11) = x;
1607       ___release_scmobj (x);
1608
1609 #ifndef FILE_ATTRIBUTE_READ_ONLY
1610 #define FILE_ATTRIBUTE_READ_ONLY 1
1611 #endif
1612
1613 #ifndef FILE_ATTRIBUTE_DIRECTORY
1614 #define FILE_ATTRIBUTE_DIRECTORY 16
1615 #endif
1616
1617 #ifndef FILE_ATTRIBUTE_NORMAL
1618 #define FILE_ATTRIBUTE_NORMAL 128
1619 #endif
1620
1621       ___FIELD(result,12) =
1622         ___FIX(S_ISDIR(s.st_mode)
1623                ? FILE_ATTRIBUTE_DIRECTORY
1624                : FILE_ATTRIBUTE_NORMAL);
1625
1626       if ((e = ___F64_to_SCMOBJ (___CAST(___F64,NEG_INFINITY),
1627                                  &x,
1628                                  ___RETURN_POS))
1629           != ___FIX(___NO_ERR))
1630         {
1631           ___release_scmobj (result);
1632           return e;
1633         }
1634
1635       ___FIELD(result,13) = x;
1636       ___release_scmobj (x);
1637
1638       ___release_scmobj (result);
1639
1640       return result;
1641     }
1642
1643 #endif
1644
1645 #ifdef USE_GetFileAttributesEx
1646
1647 #ifdef _UNICODE
1648 #define ___INFO_PATH_CE_SELECT(latin1,utf8,ucs2,ucs4,wchar,native) ucs2
1649 #else
1650 #define ___INFO_PATH_CE_SELECT(latin1,utf8,ucs2,ucs4,wchar,native) native
1651 #endif
1652
1653   if ((e = ___SCMOBJ_to_NONNULLSTRING
1654              (path,
1655               &cpath,
1656               1,
1657               ___CE(___INFO_PATH_CE_SELECT),
1658               0))
1659       == ___FIX(___NO_ERR))
1660     {
1661       WIN32_FILE_ATTRIBUTE_DATA fad;
1662
1663       if (!GetFileAttributesEx
1664              (___CAST(___STRING_TYPE(___INFO_PATH_CE_SELECT),cpath),
1665               GetFileExInfoStandard,
1666               &fad))
1667         {
1668           e = err_code_from_GetLastError ();
1669           ___release_string (cpath);
1670           return e;
1671         }
1672
1673       ___release_string (cpath);
1674
1675       result = ___make_vector (14, ___FAL, ___STILL);
1676
1677       if (___FIXNUMP(result))
1678         return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);/**********/
1679
1680       if (fad.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY)
1681         ___FIELD(result,1) = ___FIX(2);
1682       else
1683         ___FIELD(result,1) = ___FIX(1);
1684
1685       ___FIELD(result,2) = ___FIX(0);
1686       ___FIELD(result,3) = ___FIX(0);
1687
1688       if (fad.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
1689         ___FIELD(result,4) = ___FIX(0333);
1690       else
1691         ___FIELD(result,4) = ___FIX(0777);
1692
1693       ___FIELD(result,5) = ___FIX(1);
1694       ___FIELD(result,6) = ___FIX(0);
1695       ___FIELD(result,7) = ___FIX(0);
1696
1697       if ((e = ___U64_to_SCMOBJ
1698                  (___U64_from_UM32_UM32(fad.nFileSizeHigh,fad.nFileSizeLow),
1699                   &x,
1700                   ___RETURN_POS))
1701           != ___FIX(___NO_ERR))
1702         {
1703           ___release_scmobj (result);
1704           return e;
1705         }
1706
1707       ___FIELD(result,8) = x;
1708       ___release_scmobj (x);
1709
1710       if ((e = ___F64_to_SCMOBJ
1711                  (___CAST(___F64,FILETIME_TO_TIME(fad.ftLastAccessTime)),
1712                   &x,
1713                   ___RETURN_POS))
1714           != ___FIX(___NO_ERR))
1715         {
1716           ___release_scmobj (result);
1717           return e;
1718         }
1719
1720       ___FIELD(result,9) = x;
1721       ___release_scmobj (x);
1722
1723       if ((e = ___F64_to_SCMOBJ
1724                  (___CAST(___F64,FILETIME_TO_TIME(fad.ftLastWriteTime)),
1725                   &x,
1726                   ___RETURN_POS))
1727           != ___FIX(___NO_ERR))
1728         {
1729           ___release_scmobj (result);
1730           return e;
1731         }
1732
1733       ___FIELD(result,10) = x;
1734       ___FIELD(result,11) = x;
1735       ___release_scmobj (x);
1736
1737       ___FIELD(result,12) = ___FIX(fad.dwFileAttributes);
1738
1739       if ((e = ___F64_to_SCMOBJ
1740                  (___CAST(___F64,FILETIME_TO_TIME(fad.ftCreationTime)),
1741                   &x,
1742                   ___RETURN_POS))
1743           != ___FIX(___NO_ERR))
1744         {
1745           ___release_scmobj (result);
1746           return e;
1747         }
1748
1749       ___FIELD(result,13) = x;
1750       ___release_scmobj (x);
1751
1752       ___release_scmobj (result);
1753
1754       return result;
1755     }
1756
1757 #endif
1758
1759   return e;
1760 }
1761
1762
1763 /*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   */
1764
1765 /* Access to user information. */
1766
1767 ___SCMOBJ ___os_user_info
1768    ___P((___SCMOBJ user),
1769         (user)
1770 ___SCMOBJ user;)
1771 {
1772   ___SCMOBJ e = ___FIX(___NO_ERR);
1773   ___SCMOBJ result;
1774   ___SCMOBJ x;
1775   void *cuser = 0;
1776
1777 #ifndef USE_getpwnam
1778
1779   return ___FIX(___UNIMPL_ERR);
1780
1781 #endif
1782
1783 #ifdef USE_getpwnam
1784
1785   struct passwd *p;
1786
1787 #define ___USER_CE_SELECT(latin1,utf8,ucs2,ucs4,wchar,native) native
1788
1789   if (___FIXNUMP(user) ||
1790       (e = ___SCMOBJ_to_NONNULLSTRING
1791              (user,
1792               &cuser,
1793               1,
1794               ___CE(___USER_CE_SELECT),
1795               0))
1796       == ___FIX(___NO_ERR))
1797     {
1798       if (___FIXNUMP(user))
1799         {
1800           if ((p = getpwuid (___INT(user)))
1801               == 0)
1802             {
1803               e = err_code_from_errno ();
1804               return e;
1805             }
1806         }
1807       else
1808         {
1809           if ((p = getpwnam (___CAST(___STRING_TYPE(___USER_CE_SELECT),cuser)))
1810               == 0)
1811             {
1812               e = err_code_from_errno ();
1813               ___release_string (cuser);
1814               return e;
1815             }
1816
1817           ___release_string (cuser);
1818         }
1819
1820       result = ___make_vector (6, ___FAL, ___STILL);
1821
1822       if (___FIXNUMP(result))
1823         return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);/**********/
1824
1825       if ((e = ___NONNULLCHARSTRING_to_SCMOBJ
1826                  (p->pw_name,
1827                   &x,
1828                   ___RETURN_POS))
1829           != ___FIX(___NO_ERR))
1830         {
1831           ___release_scmobj (result);
1832           return e;
1833         }
1834
1835       ___FIELD(result,1) = x;
1836       ___release_scmobj (x);
1837
1838       ___FIELD(result,2) = ___FIX(p->pw_uid);
1839
1840       ___FIELD(result,3) = ___FIX(p->pw_gid);
1841
1842       if ((e = ___NONNULLCHARSTRING_to_SCMOBJ
1843                  (p->pw_dir,
1844                   &x,
1845                   ___RETURN_POS))
1846           != ___FIX(___NO_ERR))
1847         {
1848           ___release_scmobj (result);
1849           return e;
1850         }
1851
1852       ___FIELD(result,4) = x;
1853       ___release_scmobj (x);
1854
1855       if ((e = ___NONNULLCHARSTRING_to_SCMOBJ
1856                  (p->pw_shell,
1857                   &x,
1858                   ___RETURN_POS))
1859           != ___FIX(___NO_ERR))
1860         {
1861           ___release_scmobj (result);
1862           return e;
1863         }
1864
1865       ___FIELD(result,5) = x;
1866       ___release_scmobj (x);
1867
1868       ___release_scmobj (result);
1869
1870       return result;
1871     }
1872
1873 #endif
1874
1875   return e;
1876 }
1877
1878
1879 ___SCMOBJ ___os_user_name ___PVOID
1880 {
1881   ___SCMOBJ e;
1882   ___SCMOBJ result;
1883   ___UCS_2STRING cstr;
1884
1885 #ifdef USE_WIN32
1886
1887   static ___UCS_2 cvar[] =
1888   { 'U', 'S', 'E', 'R', 'N', 'A', 'M', 'E', '\0' };
1889
1890 #else
1891
1892   static ___UCS_2 cvar[] =
1893   { 'U', 'S', 'E', 'R', '\0' };
1894
1895 #endif
1896
1897   if ((e = ___getenv_UCS_2 (cvar, &cstr)) != ___FIX(___NO_ERR))
1898     result = e;
1899   else
1900     {
1901       if ((e = ___UCS_2STRING_to_SCMOBJ
1902                  (cstr,
1903                   &result,
1904                   ___RETURN_POS))
1905           != ___FIX(___NO_ERR))
1906         result = e;
1907       else
1908         ___release_scmobj (result);
1909
1910       if (cstr != 0)
1911         ___free_mem (cstr);
1912     }
1913
1914   return result;
1915 }
1916
1917
1918 /*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   */
1919
1920 /* Access to group information. */
1921
1922 ___SCMOBJ ___os_group_info
1923    ___P((___SCMOBJ group),
1924         (group)
1925 ___SCMOBJ group;)
1926 {
1927   ___SCMOBJ e = ___FIX(___NO_ERR);
1928   ___SCMOBJ result;
1929   ___SCMOBJ x;
1930   void *cgroup = 0;
1931
1932 #ifndef USE_getgrnam
1933
1934   return ___FIX(___UNIMPL_ERR);
1935
1936 #endif
1937
1938 #ifdef USE_getgrnam
1939
1940   struct group *g;
1941
1942 #define ___GROUP_CE_SELECT(latin1,utf8,ucs2,ucs4,wchar,native) native
1943
1944   if (___FIXNUMP(group) ||
1945       (e = ___SCMOBJ_to_NONNULLSTRING
1946              (group,
1947               &cgroup,
1948               1,
1949               ___CE(___GROUP_CE_SELECT),
1950               0))
1951       == ___FIX(___NO_ERR))
1952     {
1953       if (___FIXNUMP(group))
1954         {
1955           if ((g = getgrgid (___INT(group)))
1956               == 0)
1957             {
1958               e = err_code_from_errno ();
1959               return e;
1960             }
1961         }
1962       else
1963         {
1964           if ((g = getgrnam (___CAST(___STRING_TYPE(___GROUP_CE_SELECT),cgroup)))
1965               == 0)
1966             {
1967               e = err_code_from_errno ();
1968               ___release_string (cgroup);
1969               return e;
1970             }
1971
1972           ___release_string (cgroup);
1973         }
1974
1975       result = ___make_vector (3, ___FAL, ___STILL);
1976
1977       if (___FIXNUMP(result))
1978         return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+___RETURN_POS);/**********/
1979
1980       if ((e = ___NONNULLCHARSTRING_to_SCMOBJ
1981                  (g->gr_name,
1982                   &x,
1983                   ___RETURN_POS))
1984           != ___FIX(___NO_ERR))
1985         {
1986           ___release_scmobj (result);
1987           return e;
1988         }
1989
1990       ___FIELD(result,1) = x;
1991       ___release_scmobj (x);
1992
1993       ___FIELD(result,2) = ___FIX(g->gr_gid);
1994
1995       if ((e = ___NONNULLCHARSTRINGLIST_to_SCMOBJ
1996                  (g->gr_mem,
1997                   &x,
1998                   ___RETURN_POS))
1999           != ___FIX(___NO_ERR))
2000         {
2001           ___release_scmobj (result);
2002           return e;
2003         }
2004
2005       ___FIELD(result,3) = x;
2006       ___release_scmobj (x);
2007
2008       ___release_scmobj (result);
2009
2010       return result;
2011     }
2012
2013 #endif
2014
2015   return e;
2016 }
2017
2018
2019 /*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   */
2020
2021 /* Access to process information. */
2022
2023 ___SCMOBJ ___os_getpid ___PVOID
2024 {
2025 #ifndef USE_getpid
2026 #ifndef USE_GetCurrentProcessId
2027
2028   return ___FIX(0);
2029
2030 #endif
2031 #endif
2032
2033 #ifdef USE_getpid
2034
2035   return ___FIX(getpid());
2036
2037 #endif
2038
2039 #ifdef USE_GetCurrentProcessId
2040
2041   return ___FIX(GetCurrentProcessId());
2042
2043 #endif
2044 }
2045
2046
2047 ___SCMOBJ ___os_getppid ___PVOID
2048 {
2049 #ifndef USE_getppid
2050
2051   return ___FIX(0);
2052
2053 #endif
2054
2055 #ifdef USE_getppid
2056
2057   return ___FIX(getppid());
2058
2059 #endif
2060 }
2061
2062
2063 /*---------------------------------------------------------------------------*/
2064
2065 /* System type information. */
2066
2067
2068 #ifndef ___SYS_TYPE_CPU
2069 #define ___SYS_TYPE_CPU "unknown"
2070 #endif
2071
2072 #ifndef ___SYS_TYPE_VENDOR
2073 #define ___SYS_TYPE_VENDOR "unknown"
2074 #endif
2075
2076 #ifndef ___SYS_TYPE_OS
2077 #define ___SYS_TYPE_OS "unknown"
2078 #endif
2079
2080 #ifndef ___CONFIGURE_COMMAND
2081 #define ___CONFIGURE_COMMAND "unknown"
2082 #endif
2083
2084
2085 ___HIDDEN char *os_sys_type[] =
2086 { ___SYS_TYPE_CPU, ___SYS_TYPE_VENDOR, ___SYS_TYPE_OS, NULL };
2087
2088
2089 ___HIDDEN char *os_sys_type_string =
2090 ___SYS_TYPE_CPU "-" ___SYS_TYPE_VENDOR "-" ___SYS_TYPE_OS;
2091
2092
2093 ___HIDDEN char *configure_command_string = ___CONFIGURE_COMMAND;
2094
2095
2096 char **___os_system_type ___PVOID
2097 {
2098   return os_sys_type;
2099 }
2100
2101
2102 char *___os_system_type_string ___PVOID
2103 {
2104   return os_sys_type_string;
2105 }
2106
2107
2108 char *___os_configure_command_string ___PVOID
2109 {
2110   return configure_command_string;
2111 }
2112
2113
2114 /*---------------------------------------------------------------------------*/
2115
2116 /* C compilation environment information. */
2117
2118
2119 #ifndef ___OBJ_EXTENSION
2120 #define ___OBJ_EXTENSION ".obj"
2121 #endif
2122
2123 #ifndef ___EXE_EXTENSION
2124 #define ___EXE_EXTENSION ".exe"
2125 #endif
2126
2127 #ifndef ___BAT_EXTENSION
2128 #define ___BAT_EXTENSION ".bat"
2129 #endif
2130
2131
2132 ___HIDDEN char *os_obj_extension_string = ___OBJ_EXTENSION;
2133
2134 ___HIDDEN char *os_exe_extension_string = ___EXE_EXTENSION;
2135
2136 ___HIDDEN char *os_bat_extension_string = ___BAT_EXTENSION;
2137
2138
2139 char *___os_obj_extension_string ___PVOID
2140 {
2141   return os_obj_extension_string;
2142 }
2143
2144
2145 char *___os_exe_extension_string ___PVOID
2146 {
2147   return os_exe_extension_string;
2148 }
2149
2150
2151 char *___os_bat_extension_string ___PVOID
2152 {
2153   return os_bat_extension_string;
2154 }
2155
2156
2157 /*---------------------------------------------------------------------------*/
2158
2159
2160 ___HIDDEN void heartbeat_intr ___PVOID
2161 {
2162   /**** belongs elsewhere */
2163   ___raise_interrupt (___INTR_HEARTBEAT);
2164 }
2165
2166
2167 ___HIDDEN void user_intr ___PVOID
2168 {
2169   /**** belongs elsewhere */
2170   ___raise_interrupt (___INTR_USER);
2171 }
2172
2173
2174 ___HIDDEN void terminate_intr ___PVOID
2175 {
2176   /**** belongs elsewhere */
2177   ___raise_interrupt (___INTR_TERMINATE);
2178 }
2179
2180
2181 ___SCMOBJ ___setup_os ___PVOID
2182 {
2183   ___SCMOBJ e;
2184
2185   /*
2186    * To perform correct cleanup when the program terminates an
2187    * "atexit (___cleanup)" is performed in "setup_io" in certain
2188    * environments.  There must not be any possibility of program
2189    * termination through "exit (...)" between the "atexit (...)"
2190    * and the entry of "___setup_mem".  This guarantees that
2191    * "___cleanup" does not access dangling pointers.
2192    */
2193
2194   if ((e = ___setup_base_module ()) == ___FIX(___NO_ERR))
2195     {
2196       if ((e = ___setup_time_module (heartbeat_intr)) == ___FIX(___NO_ERR))
2197         {
2198           if ((e = ___setup_shell_module ()) == ___FIX(___NO_ERR))
2199             {
2200               if ((e = ___setup_files_module ()) == ___FIX(___NO_ERR))
2201                 {
2202                   if ((e = ___setup_dyn_module ()) == ___FIX(___NO_ERR))
2203                     {
2204                       if ((e = ___setup_tty_module (user_intr, terminate_intr)) == ___FIX(___NO_ERR))
2205                         {
2206                           if ((e = ___setup_io_module ()) == ___FIX(___NO_ERR))
2207                             {
2208 #ifdef USE_POSIX
2209                               ___set_signal_handler (SIGPIPE, SIG_IGN); /***** belongs elsewhere */
2210 #endif
2211                               return ___FIX(___NO_ERR);
2212                             }
2213                           ___cleanup_tty_module ();
2214                         }
2215                       ___cleanup_dyn_module ();
2216                     }
2217                   ___cleanup_files_module ();
2218                 }
2219               ___cleanup_shell_module ();
2220             }
2221           ___cleanup_time_module ();
2222         }
2223       ___cleanup_base_module ();
2224     }
2225
2226   return e;
2227 }
2228
2229
2230 void ___cleanup_os ___PVOID
2231 {
2232   ___cleanup_io_module ();
2233   ___cleanup_tty_module ();
2234   ___cleanup_dyn_module ();
2235   ___cleanup_files_module ();
2236   ___cleanup_shell_module ();
2237   ___cleanup_time_module ();
2238   ___cleanup_base_module ();
2239 }
2240
2241
2242 /*---------------------------------------------------------------------------*/