libguile/filesys.c

   1 /*      Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46 #include <stdio.h>
  47 #include "_scm.h"
  48 #include "genio.h"
  49 #include "smob.h"
  50 #include "feature.h"
  51 #include "fports.h"
  52 #include "iselect.h"
  53
  54 #include "scm_validate.h"
  55 #include "filesys.h"
  56
  57 \f
  58 #ifdef HAVE_IO_H
  59 #include <io.h>
  60 #endif
  61
  62 #ifdef TIME_WITH_SYS_TIME
  63 # include <sys/time.h>
  64 # include <time.h>
  65 #else
  66 # if HAVE_SYS_TIME_H
  67 #  include <sys/time.h>
  68 # else
  69 #  include <time.h>
  70 # endif
  71 #endif
  72
  73 #ifdef HAVE_UNISTD_H
  74 #include <unistd.h>
  75 #endif
  76
  77 #ifdef LIBC_H_WITH_UNISTD_H
  78 #include <libc.h>
  79 #endif
  80
  81 #ifdef HAVE_SYS_SELECT_H
  82 #include <sys/select.h>
  83 #endif
  84
  85 #ifdef HAVE_STRING_H
  86 #include <string.h>
  87 #endif
  88
  89 #include <sys/types.h>
  90 #include <sys/stat.h>
  91 #include <fcntl.h>
  92
  93 #include <pwd.h>
  94
  95
  96 #if HAVE_DIRENT_H
  97 # include <dirent.h>
  98 # define NAMLEN(dirent) strlen((dirent)->d_name)
  99 #else
 100 # define dirent direct
 101 # define NAMLEN(dirent) (dirent)->d_namlen
 102 # if HAVE_SYS_NDIR_H
 103 #  include <sys/ndir.h>
 104 # endif
 105 # if HAVE_SYS_DIR_H
 106 #  include <sys/dir.h>
 107 # endif
 108 # if HAVE_NDIR_H
 109 #  include <ndir.h>
 110 # endif
 111 #endif
 112
 113 /* Ultrix has S_IFSOCK, but no S_ISSOCK.  Ipe!  */
 114 #if defined (S_IFSOCK) && ! defined (S_ISSOCK)
 115 #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
 116 #endif
 117 \f
 118
 119
 120 \f
 121
 122 /* {Permissions}
 123  */
 124
 125 GUILE_PROC (scm_chown, "chown", 3, 0, 0,
 126             (SCM object, SCM owner, SCM group),
 127 "Change the ownership and group of the file referred to by @var{obj} to
 128 the integer userid values @var{owner} and @var{group}.  @var{obj} can be
 129 a string containing a file name or a port or integer file descriptor
 130 which is open on the file (in which case fchown is used as the underlying
 131 system call).  The return value
 132 is unspecified.
 133
 134 If @var{obj} is a symbolic link, either the
 135 ownership of the link or the ownership of the referenced file will be
 136 changed depending on the operating system (lchown is
 137 unsupported at present).  If @var{owner} or @var{group} is specified
 138 as @code{-1}, then that ID is not changed.")
 139 #define FUNC_NAME s_scm_chown
 140 {
 141   int rv;
 142   int fdes;
 143
 144   object = SCM_COERCE_OUTPORT (object);
 145
 146   SCM_VALIDATE_INT(2,owner);
 147   SCM_VALIDATE_INT(3,group);
 148   if (SCM_INUMP (object) || (SCM_OPFPORTP (object)))
 149     {
 150       if (SCM_INUMP (object))
 151         fdes = SCM_INUM (object);
 152       else
 153         fdes = SCM_FPORT_FDES (object);
 154       SCM_SYSCALL (rv = fchown (fdes, SCM_INUM (owner), SCM_INUM (group)));
 155     }
 156   else
 157     {
 158       SCM_ASSERT (SCM_ROSTRINGP (object),
 159                   object, SCM_ARG1, FUNC_NAME);
 160       SCM_COERCE_SUBSTR (object);
 161       SCM_SYSCALL (rv = chown (SCM_ROCHARS (object),
 162                                SCM_INUM (owner), SCM_INUM (group)));
 163     }
 164   if (rv == -1)
 165     SCM_SYSERROR;
 166   return SCM_UNSPECIFIED;
 167 }
 168 #undef FUNC_NAME
 169
 170
 171 GUILE_PROC (scm_chmod, "chmod", 2, 0, 0,
 172             (SCM object, SCM mode),
 173 "Changes the permissions of the file referred to by @var{obj}.
 174 @var{obj} can be a string containing a file name or a port or integer file
 175 descriptor which is open on a file (in which case @code{fchmod} is used
 176 as the underlying system call).
 177 @var{mode} specifies
 178 the new permissions as a decimal number, e.g., @code{(chmod "foo" #o755)}.
 179 The return value is unspecified.")
 180 #define FUNC_NAME s_scm_chmod
 181 {
 182   int rv;
 183   int fdes;
 184
 185   object = SCM_COERCE_OUTPORT (object);
 186
 187   SCM_VALIDATE_INT(2,mode);
 188   if (SCM_INUMP (object) || SCM_OPFPORTP (object))
 189     {
 190       if (SCM_INUMP (object))
 191         fdes = SCM_INUM (object);
 192       else
 193         fdes = SCM_FPORT_FDES (object);
 194       SCM_SYSCALL (rv = fchmod (fdes, SCM_INUM (mode)));
 195     }
 196   else
 197     {
 198       SCM_VALIDATE_ROSTRING(1,object);
 199       SCM_COERCE_SUBSTR (object);
 200       SCM_SYSCALL (rv = chmod (SCM_ROCHARS (object), SCM_INUM (mode)));
 201     }
 202   if (rv == -1)
 203     SCM_SYSERROR;
 204   return SCM_UNSPECIFIED;
 205 }
 206 #undef FUNC_NAME
 207
 208 GUILE_PROC (scm_umask, "umask", 0, 1, 0,
 209             (SCM mode),
 210 "If @var{mode} is omitted, retuns a decimal number representing the current
 211 file creation mask.  Otherwise the file creation mask is set to
 212 @var{mode} and the previous value is returned.
 213
 214 E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18.")
 215 #define FUNC_NAME s_scm_umask
 216 {
 217   mode_t mask;
 218   if (SCM_UNBNDP (mode))
 219     {
 220       mask = umask (0);
 221       umask (mask);
 222     }
 223   else
 224     {
 225       SCM_VALIDATE_INT(1,mode);
 226       mask = umask (SCM_INUM (mode));
 227     }
 228   return SCM_MAKINUM (mask);
 229 }
 230 #undef FUNC_NAME
 231
 232 \f
 233
 234 GUILE_PROC (scm_open_fdes, "open-fdes", 2, 1, 0,
 235             (SCM path, SCM flags, SCM mode),
 236 "Similar to @code{open} but returns a file descriptor instead of a
 237 port.")
 238 #define FUNC_NAME s_scm_open_fdes
 239 {
 240   int fd;
 241   int iflags;
 242   int imode;
 243
 244   SCM_VALIDATE_ROSTRING(1,path);
 245   SCM_COERCE_SUBSTR (path);
 246   SCM_VALIDATE_INT_COPY(2,flags,iflags);
 247   SCM_VALIDATE_INT_DEF_COPY(3,mode,0666,imode);
 248   SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags, imode));
 249   if (fd == -1)
 250     SCM_SYSERROR;
 251   return SCM_MAKINUM (fd);
 252 }
 253 #undef FUNC_NAME
 254
 255 GUILE_PROC (scm_open, "open", 2, 1, 0,
 256             (SCM path, SCM flags, SCM mode),
 257 "Open the file named by @var{path} for reading and/or writing.
 258 @var{flags} is an integer specifying how the file should be opened.
 259 @var{mode} is an integer specifying the permission bits of the file, if
 260 it needs to be created, before the umask is applied.  The default is 666
 261 (Unix itself has no default).
 262
 263 @var{flags} can be constructed by combining variables using @code{logior}.
 264 Basic flags are:
 265
 266 @defvar O_RDONLY
 267 Open the file read-only.
 268 @end defvar
 269 @defvar O_WRONLY
 270 Open the file write-only.
 271 @end defvar
 272 @defvar O_RDWR
 273 Open the file read/write.
 274 @end defvar
 275 @defvar O_APPEND
 276 Append to the file instead of truncating.
 277 @end defvar
 278 @defvar O_CREAT
 279 Create the file if it does not already exist.
 280 @end defvar
 281
 282 See the Unix documentation of the @code{open} system call
 283 for additional flags.")
 284 #define FUNC_NAME s_scm_open
 285 {
 286   SCM newpt;
 287   char *port_mode;
 288   int fd;
 289   int iflags;
 290
 291   fd = SCM_INUM (scm_open_fdes (path, flags, mode));
 292   SCM_VALIDATE_INT_COPY(2,flags,iflags);
 293   if (iflags & O_RDWR)
 294     {
 295       if (iflags & O_APPEND)
 296         port_mode = "a+";
 297       else if (iflags & O_CREAT)
 298         port_mode = "w+";
 299       else
 300         port_mode = "r+";
 301     }
 302   else {
 303     if (iflags & O_APPEND)
 304       port_mode = "a";
 305     else if (iflags & O_WRONLY)
 306       port_mode = "w";
 307     else
 308       port_mode = "r";
 309   }
 310   newpt = scm_fdes_to_port (fd, port_mode, path);
 311   return newpt;
 312 }
 313 #undef FUNC_NAME
 314
 315 GUILE_PROC (scm_close, "close", 1, 0, 0,
 316             (SCM fd_or_port),
 317 "Similar to close-port (@pxref{Generic Port Operations, close-port}),
 318 but also works on file descriptors.  A side
 319 effect of closing a file descriptor is that any ports using that file
 320 descriptor are moved to a different file descriptor and have
 321 their revealed counts set to zero.")
 322 #define FUNC_NAME s_scm_close
 323 {
 324   int rv;
 325   int fd;
 326
 327   fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
 328
 329   if (SCM_PORTP (fd_or_port))
 330     return scm_close_port (fd_or_port);
 331   SCM_VALIDATE_INT(1,fd_or_port);
 332   fd = SCM_INUM (fd_or_port);
 333   scm_evict_ports (fd);         /* see scsh manual.  */
 334   SCM_SYSCALL (rv = close (fd));
 335   /* following scsh, closing an already closed file descriptor is
 336      not an error.  */
 337   if (rv < 0 && errno != EBADF)
 338     SCM_SYSERROR;
 339   return SCM_NEGATE_BOOL(rv < 0);
 340 }
 341 #undef FUNC_NAME
 342
 343 \f
 344 /* {Files}
 345  */
 346
 347 SCM_SYMBOL (scm_sym_regular, "regular");
 348 SCM_SYMBOL (scm_sym_directory, "directory");
 349 #ifdef HAVE_S_ISLNK
 350 SCM_SYMBOL (scm_sym_symlink, "symlink");
 351 #endif
 352 SCM_SYMBOL (scm_sym_block_special, "block-special");
 353 SCM_SYMBOL (scm_sym_char_special, "char-special");
 354 SCM_SYMBOL (scm_sym_fifo, "fifo");
 355 SCM_SYMBOL (scm_sym_sock, "socket");
 356 SCM_SYMBOL (scm_sym_unknown, "unknown");
 357
 358 static SCM
 359 scm_stat2scm (struct stat *stat_temp)
 360 {
 361   SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED);
 362   SCM *ve = SCM_VELTS (ans);
 363
 364   ve[0] = scm_ulong2num ((unsigned long) stat_temp->st_dev);
 365   ve[1] = scm_ulong2num ((unsigned long) stat_temp->st_ino);
 366   ve[2] = scm_ulong2num ((unsigned long) stat_temp->st_mode);
 367   ve[3] = scm_ulong2num ((unsigned long) stat_temp->st_nlink);
 368   ve[4] = scm_ulong2num ((unsigned long) stat_temp->st_uid);
 369   ve[5] = scm_ulong2num ((unsigned long) stat_temp->st_gid);
 370 #ifdef HAVE_ST_RDEV
 371   ve[6] = scm_ulong2num ((unsigned long) stat_temp->st_rdev);
 372 #else
 373   ve[6] = SCM_BOOL_F;
 374 #endif
 375   ve[7] = scm_ulong2num ((unsigned long) stat_temp->st_size);
 376   ve[8] = scm_ulong2num ((unsigned long) stat_temp->st_atime);
 377   ve[9] = scm_ulong2num ((unsigned long) stat_temp->st_mtime);
 378   ve[10] = scm_ulong2num ((unsigned long) stat_temp->st_ctime);
 379 #ifdef HAVE_ST_BLKSIZE
 380   ve[11] = scm_ulong2num ((unsigned long) stat_temp->st_blksize);
 381 #else
 382   ve[11] = scm_ulong2num (4096L);
 383 #endif
 384 #ifdef HAVE_ST_BLOCKS
 385   ve[12] = scm_ulong2num ((unsigned long) stat_temp->st_blocks);
 386 #else
 387   ve[12] = SCM_BOOL_F;
 388 #endif
 389   {
 390     int mode = stat_temp->st_mode;
 391
 392     if (S_ISREG (mode))
 393       ve[13] = scm_sym_regular;
 394     else if (S_ISDIR (mode))
 395       ve[13] = scm_sym_directory;
 396 #ifdef HAVE_S_ISLNK
 397     else if (S_ISLNK (mode))
 398       ve[13] = scm_sym_symlink;
 399 #endif
 400     else if (S_ISBLK (mode))
 401       ve[13] = scm_sym_block_special;
 402     else if (S_ISCHR (mode))
 403       ve[13] = scm_sym_char_special;
 404     else if (S_ISFIFO (mode))
 405       ve[13] = scm_sym_fifo;
 406     else if (S_ISSOCK (mode))
 407       ve[13] = scm_sym_sock;
 408     else
 409       ve[13] = scm_sym_unknown;
 410
 411     ve[14] = SCM_MAKINUM ((~S_IFMT) & mode);
 412
 413     /* the layout of the bits in ve[14] is intended to be portable.
 414        If there are systems that don't follow the usual convention,
 415        the following could be used:
 416
 417        tmp = 0;
 418        if (S_ISUID & mode) tmp += 1;
 419        tmp <<= 1;
 420        if (S_IRGRP & mode) tmp += 1;
 421        tmp <<= 1;
 422        if (S_ISVTX & mode) tmp += 1;
 423        tmp <<= 1;
 424        if (S_IRUSR & mode) tmp += 1;
 425        tmp <<= 1;
 426        if (S_IWUSR & mode) tmp += 1;
 427        tmp <<= 1;
 428        if (S_IXUSR & mode) tmp += 1;
 429        tmp <<= 1;
 430        if (S_IWGRP & mode) tmp += 1;
 431        tmp <<= 1;
 432        if (S_IXGRP & mode) tmp += 1;
 433        tmp <<= 1;
 434        if (S_IROTH & mode) tmp += 1;
 435        tmp <<= 1;
 436        if (S_IWOTH & mode) tmp += 1;
 437        tmp <<= 1;
 438        if (S_IXOTH & mode) tmp += 1;
 439
 440        ve[14] = SCM_MAKINUM (tmp);
 441
 442        */
 443   }
 444
 445   return ans;
 446 }
 447
 448 GUILE_PROC (scm_stat, "stat", 1, 0, 0,
 449             (SCM object),
 450 "Returns an object containing various information
 451 about the file determined by @var{obj}.
 452 @var{obj} can be a string containing a file name or a port or integer file
 453 descriptor which is open on a file (in which case @code{fstat} is used
 454 as the underlying system call).
 455
 456 The object returned by @code{stat} can be passed as a single parameter
 457 to the following procedures, all of which return integers:
 458
 459 @table @code
 460 @item stat:dev
 461 The device containing the file.
 462 @item stat:ino
 463 The file serial number, which distinguishes this file from all other
 464 files on the same device.
 465 @item stat:mode
 466 The mode of the file.  This includes file type information
 467 and the file permission bits.  See @code{stat:type} and @code{stat:perms}
 468 below.
 469 @item stat:nlink
 470 The number of hard links to the file.
 471 @item stat:uid
 472 The user ID of the file's owner.
 473 @item stat:gid
 474 The group ID of the file.
 475 @item stat:rdev
 476 Device ID; this entry is defined only for character or block
 477 special files.
 478 @item stat:size
 479 The size of a regular file in bytes.
 480 @item stat:atime
 481 The last access time for the file.
 482 @item stat:mtime
 483 The last modification time for the file.
 484 @item stat:ctime
 485 The last modification time for the attributes of the file.
 486 @item stat:blksize
 487 The optimal block size for reading or writing the file, in bytes.
 488 @item stat:blocks
 489 The amount of disk space that the file occupies measured in units of
 490 512 byte blocks.
 491 @end table
 492
 493 In addition, the following procedures return the information
 494 from stat:mode in a more convenient form:
 495
 496 @table @code
 497 @item stat:type
 498 A symbol representing the type of file.  Possible values are
 499 regular, directory, symlink, block-special, char-special,
 500 fifo, socket and unknown
 501 @item stat:perms
 502 An integer representing the access permission bits.
 503 @end table")
 504 #define FUNC_NAME s_scm_stat
 505 {
 506   int rv;
 507   int fdes;
 508   struct stat stat_temp;
 509
 510   if (SCM_INUMP (object))
 511     SCM_SYSCALL (rv = fstat (SCM_INUM (object), &stat_temp));
 512   else
 513     {
 514       SCM_VALIDATE_NIM (1,object);
 515       if (SCM_ROSTRINGP (object))
 516         {
 517           SCM_COERCE_SUBSTR (object);
 518           SCM_SYSCALL (rv = stat (SCM_ROCHARS (object), &stat_temp));
 519         }
 520       else
 521         {
 522           object = SCM_COERCE_OUTPORT (object);
 523           SCM_ASSERT (SCM_OPFPORTP (object), object, SCM_ARG1, FUNC_NAME);
 524           fdes = SCM_FPORT_FDES (object);
 525           SCM_SYSCALL (rv = fstat (fdes, &stat_temp));
 526         }
 527     }
 528   if (rv == -1)
 529     {
 530       int en = errno;
 531
 532       scm_syserror_msg (FUNC_NAME, "%s: %S",
 533                         scm_listify (scm_makfrom0str (strerror (errno)),
 534                                      object,
 535                                      SCM_UNDEFINED),
 536                         en);
 537     }
 538   return scm_stat2scm (&stat_temp);
 539 }
 540 #undef FUNC_NAME
 541
 542 \f
 543 /* {Modifying Directories}
 544  */
 545
 546 GUILE_PROC (scm_link, "link", 2, 0, 0,
 547             (SCM oldpath, SCM newpath),
 548 "Creates a new name @var{path-to} in the file system for the file
 549 named by @var{path-from}.  If @var{path-from} is a symbolic link, the
 550 link may or may not be followed depending on the system.")
 551 #define FUNC_NAME s_scm_link
 552 {
 553   int val;
 554
 555   SCM_VALIDATE_ROSTRING(1,oldpath);
 556   if (SCM_SUBSTRP (oldpath))
 557     oldpath = scm_makfromstr (SCM_ROCHARS (oldpath),
 558                               SCM_ROLENGTH (oldpath), 0);
 559   SCM_VALIDATE_ROSTRING(2,newpath);
 560   if (SCM_SUBSTRP (newpath))
 561     newpath = scm_makfromstr (SCM_ROCHARS (newpath),
 562                               SCM_ROLENGTH (newpath), 0);
 563   SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath)));
 564   if (val != 0)
 565     SCM_SYSERROR;
 566   return SCM_UNSPECIFIED;
 567 }
 568 #undef FUNC_NAME
 569
 570
 571
 572 GUILE_PROC (scm_rename, "rename-file", 2, 0, 0,
 573             (SCM oldname, SCM newname),
 574 "Renames the file specified by @var{path-from} to @var{path-to}.
 575 The return value is unspecified.")
 576 #define FUNC_NAME s_scm_rename
 577 {
 578   int rv;
 579   SCM_VALIDATE_ROSTRING(1,oldname);
 580   SCM_VALIDATE_ROSTRING(2,newname);
 581   SCM_COERCE_SUBSTR (oldname);
 582   SCM_COERCE_SUBSTR (newname);
 583 #ifdef HAVE_RENAME
 584   SCM_SYSCALL (rv = rename (SCM_ROCHARS (oldname), SCM_ROCHARS (newname)));
 585 #else
 586   SCM_SYSCALL (rv = link (SCM_ROCHARS (oldname), SCM_ROCHARS (newname)));
 587   if (rv == 0)
 588     {
 589       SCM_SYSCALL (rv = unlink (SCM_ROCHARS (oldname)));;
 590       if (rv != 0)
 591         /* unlink failed.  remove new name */
 592         SCM_SYSCALL (unlink (SCM_ROCHARS (newname)));
 593     }
 594 #endif
 595   if (rv != 0)
 596     SCM_SYSERROR;
 597   return SCM_UNSPECIFIED;
 598 }
 599 #undef FUNC_NAME
 600
 601
 602 GUILE_PROC(scm_delete_file, "delete-file", 1, 0, 0,
 603            (SCM str),
 604 "Deletes (or \"unlinks\") the file specified by @var{path}.")
 605 #define FUNC_NAME s_scm_delete_file
 606 {
 607   int ans;
 608   SCM_VALIDATE_ROSTRING(1,str);
 609   SCM_COERCE_SUBSTR (str);
 610   SCM_SYSCALL (ans = unlink (SCM_ROCHARS (str)));
 611   if (ans != 0)
 612     SCM_SYSERROR;
 613   return SCM_UNSPECIFIED;
 614 }
 615 #undef FUNC_NAME
 616
 617 GUILE_PROC (scm_mkdir, "mkdir", 1, 1, 0,
 618             (SCM path, SCM mode),
 619 "Create a new directory named by @var{path}.  If @var{mode} is omitted
 620 then the permissions of the directory file are set using the current
 621 umask.  Otherwise they are set to the decimal value specified with
 622 @var{mode}.  The return value is unspecified.")
 623 #define FUNC_NAME s_scm_mkdir
 624 {
 625 #ifdef HAVE_MKDIR
 626   int rv;
 627   mode_t mask;
 628   SCM_VALIDATE_ROSTRING(1,path);
 629   SCM_COERCE_SUBSTR (path);
 630   if (SCM_UNBNDP (mode))
 631     {
 632       mask = umask (0);
 633       umask (mask);
 634       SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), 0777 ^ mask));
 635     }
 636   else
 637     {
 638       SCM_VALIDATE_INT(2,mode);
 639       SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), SCM_INUM (mode)));
 640     }
 641   if (rv != 0)
 642     SCM_SYSERROR;
 643   return SCM_UNSPECIFIED;
 644 #else
 645   SCM_SYSMISSING;
 646   /* not reached.  */
 647   return SCM_BOOL_F;
 648 #endif
 649 }
 650 #undef FUNC_NAME
 651
 652
 653 GUILE_PROC (scm_rmdir, "rmdir", 1, 0, 0,
 654             (SCM path),
 655 "Remove the existing directory named by @var{path}.  The directory must
 656 be empty for this to succeed.  The return value is unspecified.")
 657 #define FUNC_NAME s_scm_rmdir
 658 {
 659 #ifdef HAVE_RMDIR
 660   int val;
 661
 662   SCM_VALIDATE_ROSTRING(1,path);
 663   SCM_COERCE_SUBSTR (path);
 664   SCM_SYSCALL (val = rmdir (SCM_ROCHARS (path)));
 665   if (val != 0)
 666     SCM_SYSERROR;
 667   return SCM_UNSPECIFIED;
 668 #else
 669   SCM_SYSMISSING;
 670   /* not reached.  */
 671   return SCM_BOOL_F;
 672 #endif
 673 }
 674 #undef FUNC_NAME
 675
 676 \f
 677 /* {Examining Directories}
 678  */
 679
 680 long scm_tc16_dir;
 681
 682 GUILE_PROC (scm_directory_stream_p, "directory-stream?", 1, 0, 0,
 683             (SCM obj),
 684 "Returns a boolean indicating whether @var{object} is a directory stream
 685 as returned by @code{opendir}.")
 686 #define FUNC_NAME s_scm_directory_stream_p
 687 {
 688   return SCM_BOOL(SCM_DIRP (obj));
 689 }
 690 #undef FUNC_NAME
 691
 692 GUILE_PROC (scm_opendir, "opendir", 1, 0, 0,
 693             (SCM dirname),
 694 "Open the directory specified by @var{path} and return a directory
 695 stream.")
 696 #define FUNC_NAME s_scm_opendir
 697 {
 698   DIR *ds;
 699   SCM_VALIDATE_ROSTRING(1,dirname);
 700   SCM_COERCE_SUBSTR (dirname);
 701   SCM_SYSCALL (ds = opendir (SCM_ROCHARS (dirname)));
 702   if (ds == NULL)
 703     SCM_SYSERROR;
 704   SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_OPN, ds);
 705 }
 706 #undef FUNC_NAME
 707
 708
 709 GUILE_PROC (scm_readdir, "readdir", 1, 0, 0,
 710             (SCM port),
 711 "Return (as a string) the next directory entry from the directory stream
 712 @var{stream}.  If there is no remaining entry to be read then the
 713 end of file object is returned.")
 714 #define FUNC_NAME s_scm_readdir
 715 {
 716   struct dirent *rdent;
 717   SCM_VALIDATE_OPDIR(1,port);
 718   errno = 0;
 719   SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CDR (port)));
 720   if (errno != 0)
 721     SCM_SYSERROR;
 722   return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0)
 723           : SCM_EOF_VAL);
 724 }
 725 #undef FUNC_NAME
 726
 727
 728
 729 GUILE_PROC (scm_rewinddir, "rewinddir", 1, 0, 0,
 730             (SCM port),
 731 "Reset the directory port @var{stream} so that the next call to
 732 @code{readdir} will return the first directory entry.")
 733 #define FUNC_NAME s_scm_rewinddir
 734 {
 735   SCM_VALIDATE_OPDIR(1,port);
 736   rewinddir ((DIR *) SCM_CDR (port));
 737   return SCM_UNSPECIFIED;
 738 }
 739 #undef FUNC_NAME
 740
 741
 742
 743 GUILE_PROC (scm_closedir, "closedir", 1, 0, 0,
 744             (SCM port),
 745 "Close the directory stream @var{stream}.
 746 The return value is unspecified.")
 747 #define FUNC_NAME s_scm_closedir
 748 {
 749   int sts;
 750
 751   SCM_VALIDATE_DIR(1,port);
 752   if (SCM_CLOSEDP (port))
 753     {
 754       return SCM_UNSPECIFIED;
 755     }
 756   SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port)));
 757   if (sts != 0)
 758     SCM_SYSERROR;
 759   SCM_SETCAR (port, scm_tc16_dir);
 760   return SCM_UNSPECIFIED;
 761 }
 762 #undef FUNC_NAME
 763
 764
 765
 766
 767 static int
 768 scm_dir_print (SCM exp, SCM port, scm_print_state *pstate)
 769 {
 770   scm_puts ("#<", port);
 771   if (SCM_CLOSEDP (exp))
 772     scm_puts ("closed: ", port);
 773   scm_puts ("directory stream ", port);
 774   scm_intprint (SCM_CDR (exp), 16, port);
 775   scm_putc ('>', port);
 776   return 1;
 777 }
 778
 779
 780 static scm_sizet
 781 scm_dir_free (SCM p)
 782 {
 783   if (SCM_OPENP (p))
 784     closedir ((DIR *) SCM_CDR (p));
 785   return 0;
 786 }
 787
 788 \f
 789 /* {Navigating Directories}
 790  */
 791
 792
 793 GUILE_PROC (scm_chdir, "chdir", 1, 0, 0,
 794             (SCM str),
 795 "Change the current working directory to @var{path}.
 796 The return value is unspecified.")
 797 #define FUNC_NAME s_scm_chdir
 798 {
 799   int ans;
 800
 801   SCM_VALIDATE_ROSTRING(1,str);
 802   SCM_COERCE_SUBSTR (str);
 803   SCM_SYSCALL (ans = chdir (SCM_ROCHARS (str)));
 804   if (ans != 0)
 805     SCM_SYSERROR;
 806   return SCM_UNSPECIFIED;
 807 }
 808 #undef FUNC_NAME
 809
 810
 811
 812 GUILE_PROC (scm_getcwd, "getcwd", 0, 0, 0,
 813             (),
 814 "Returns the name of the current working directory.")
 815 #define FUNC_NAME s_scm_getcwd
 816 {
 817 #ifdef HAVE_GETCWD
 818   char *rv;
 819
 820   scm_sizet size = 100;
 821   char *wd;
 822   SCM result;
 823
 824   wd = scm_must_malloc (size, FUNC_NAME);
 825   while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
 826     {
 827       scm_must_free (wd);
 828       size *= 2;
 829       wd = scm_must_malloc (size, FUNC_NAME);
 830     }
 831   if (rv == 0)
 832     SCM_SYSERROR;
 833   result = scm_makfromstr (wd, strlen (wd), 0);
 834   scm_must_free (wd);
 835   return result;
 836 #else
 837   SCM_SYSMISSING;
 838   /* not reached.  */
 839   return SCM_BOOL_F;
 840 #endif
 841 }
 842 #undef FUNC_NAME
 843
 844 \f
 845
 846 static int
 847 set_element (SELECT_TYPE *set, SCM element, int arg)
 848 {
 849   int fd;
 850   element = SCM_COERCE_OUTPORT (element);
 851   if (SCM_OPFPORTP (element))
 852     fd = SCM_FPORT_FDES (element);
 853   else {
 854     SCM_ASSERT (SCM_INUMP (element), element, arg, "select");
 855     fd = SCM_INUM (element);
 856   }
 857   FD_SET (fd, set);
 858   return fd;
 859 }
 860
 861 static int
 862 fill_select_type (SELECT_TYPE *set, SCM list, int arg)
 863 {
 864   int max_fd = 0, fd;
 865   if (SCM_VECTORP (list))
 866     {
 867       int len = SCM_LENGTH (list);
 868       SCM *ve = SCM_VELTS (list);
 869
 870       while (len > 0)
 871         {
 872           fd = set_element (set, ve[len - 1], arg);
 873           if (fd > max_fd)
 874             max_fd = fd;
 875           len--;
 876         }
 877     }
 878   else
 879     {
 880       while (list != SCM_EOL)
 881         {
 882           fd = set_element (set, SCM_CAR (list), arg);
 883           if (fd > max_fd)
 884             max_fd = fd;
 885           list = SCM_CDR (list);
 886         }
 887     }
 888
 889   return max_fd;
 890 }
 891
 892 static SCM
 893 get_element (SELECT_TYPE *set, SCM element, SCM list)
 894 {
 895   element = SCM_COERCE_OUTPORT (element);
 896   if (SCM_OPFPORTP (element))
 897     {
 898       if (FD_ISSET (SCM_FPORT_FDES (element), set))
 899         list = scm_cons (element, list);
 900     }
 901   else if (SCM_INUMP (element))
 902     {
 903       if (FD_ISSET (SCM_INUM (element), set))
 904         list = scm_cons (element, list);
 905     }
 906   return list;
 907 }
 908
 909 static SCM
 910 retrieve_select_type (SELECT_TYPE *set, SCM list)
 911 {
 912   SCM answer_list = SCM_EOL;
 913
 914   if (SCM_VECTORP (list))
 915     {
 916       int len = SCM_LENGTH (list);
 917       SCM *ve = SCM_VELTS (list);
 918
 919       while (len > 0)
 920         {
 921           answer_list = get_element (set, ve[len - 1], answer_list);
 922           len--;
 923         }
 924       return scm_vector (answer_list);
 925     }
 926   else
 927     {
 928       /* list is a list.  */
 929       while (list != SCM_EOL)
 930         {
 931           answer_list = get_element (set, SCM_CAR (list), answer_list);
 932           list = SCM_CDR (list);
 933         }
 934       return answer_list;
 935     }
 936 }
 937
 938 /* Static helper functions above refer to s_scm_select directly as s_select */
 939 GUILE_PROC (scm_select, "select", 3, 2, 0,
 940             (SCM reads, SCM writes, SCM excepts, SCM secs, SCM usecs),
 941 "@var{reads}, @var{writes} and @var{excepts} can be lists or vectors: it
 942 doesn't matter which, but the corresponding object returned will be
 943 of the same type.
 944 Each element is a port or file descriptor on which to wait for
 945 readability, writeability
 946 or exceptional conditions respectively.  @var{secs} and @var{usecs}
 947 optionally specify a timeout: @var{secs} can be specified alone, as
 948 either an integer or a real number, or both @var{secs} and @var{usecs}
 949 can be specified as integers, in which case @var{usecs} is an additional
 950 timeout expressed in microseconds.
 951
 952 Buffered input or output data is (currently, but this may change)
 953 ignored: select uses the underlying file descriptor of a port
 954 (@code{char-ready?} will check input buffers, output buffers are
 955 problematic).
 956
 957 The return value is a list of subsets of the input lists or vectors for
 958 which the requested condition has been met.
 959
 960 It is not quite compatible with scsh's select: scsh checks port buffers,
 961 doesn't accept input lists or a microsecond timeout, returns multiple
 962 values instead of a list and has an additional select! interface.
 963 ")
 964 #define FUNC_NAME s_scm_select
 965 {
 966 #ifdef HAVE_SELECT
 967   struct timeval timeout;
 968   struct timeval * time_p;
 969   SELECT_TYPE read_set;
 970   SELECT_TYPE write_set;
 971   SELECT_TYPE except_set;
 972   int max_fd, fd;
 973   int sreturn;
 974
 975 #define assert_set(x, arg) \
 976   SCM_ASSERT (scm_ilength (x) >= 0 || (SCM_VECTORP (x)), \
 977               x, arg, FUNC_NAME)
 978   assert_set (reads, SCM_ARG1);
 979   assert_set (writes, SCM_ARG2);
 980   assert_set (excepts, SCM_ARG3);
 981 #undef assert_set
 982
 983   FD_ZERO (&read_set);
 984   FD_ZERO (&write_set);
 985   FD_ZERO (&except_set);
 986
 987   max_fd = fill_select_type (&read_set, reads, SCM_ARG1);
 988   fd = fill_select_type (&write_set, writes, SCM_ARG2);
 989   if (fd > max_fd)
 990     max_fd = fd;
 991   fd = fill_select_type (&except_set, excepts, SCM_ARG3);
 992   if (fd > max_fd)
 993     max_fd = fd;
 994
 995   if (SCM_UNBNDP (secs) || SCM_FALSEP (secs))
 996     time_p = 0;
 997   else
 998     {
 999       if (SCM_INUMP (secs))
1000         {
1001           timeout.tv_sec = SCM_INUM (secs);
1002           if (SCM_UNBNDP (usecs))
1003             timeout.tv_usec = 0;
1004           else
1005             {
1006               SCM_VALIDATE_INT(5,usecs);
1007               timeout.tv_usec = SCM_INUM (usecs);
1008             }
1009         }
1010       else
1011         {
1012           double fl = scm_num2dbl (secs, FUNC_NAME);
1013
1014           if (!SCM_UNBNDP (usecs))
1015             scm_wrong_type_arg (FUNC_NAME, 4, secs);
1016           if (fl > LONG_MAX)
1017             scm_out_of_range (FUNC_NAME, secs);
1018           timeout.tv_sec = (long) fl;
1019           timeout.tv_usec = (long) ((fl - timeout.tv_sec) * 1000000);
1020         }
1021       time_p = &timeout;
1022     }
1023
1024 #ifdef GUILE_ISELECT
1025   sreturn = scm_internal_select (max_fd + 1,
1026                                  &read_set, &write_set, &except_set, time_p);
1027 #else
1028   sreturn = select (max_fd + 1,
1029                     &read_set, &write_set, &except_set, time_p);
1030 #endif
1031   if (sreturn < 0)
1032     SCM_SYSERROR;
1033   return scm_listify (retrieve_select_type (&read_set, reads),
1034                       retrieve_select_type (&write_set, writes),
1035                       retrieve_select_type (&except_set, excepts),
1036                       SCM_UNDEFINED);
1037 #else
1038   SCM_SYSMISSING;
1039   /* not reached.  */
1040   return SCM_BOOL_F;
1041 #endif
1042 }
1043 #undef FUNC_NAME
1044
1045 \f
1046
1047 GUILE_PROC (scm_fcntl, "fcntl", 2, 0, 1,
1048             (SCM object, SCM cmd, SCM value),
1049 "Apply @var{command} to the specified file descriptor or the underlying
1050 file descriptor of the specified port.  @var{value} is an optional
1051 integer argument.
1052
1053 Values for @var{command} are:
1054
1055 @table @code
1056 @item F_DUPFD
1057 Duplicate a file descriptor
1058 @item F_GETFD
1059 Get flags associated with the file descriptor.
1060 @item F_SETFD
1061 Set flags associated with the file descriptor to @var{value}.
1062 @item F_GETFL
1063 Get flags associated with the open file.
1064 @item F_SETFL
1065 Set flags associated with the open file to @var{value}
1066 @item F_GETOWN
1067 Get the process ID of a socket's owner, for @code{SIGIO} signals.
1068 @item F_SETOWN
1069 Set the process that owns a socket to @var{value}, for @code{SIGIO} signals.
1070 @item FD_CLOEXEC
1071 The value used to indicate the "close on exec" flag with @code{F_GETFL} or
1072 @code{F_SETFL}.
1073 @end table")
1074 #define FUNC_NAME s_scm_fcntl
1075 {
1076   int rv;
1077   int fdes;
1078   int ivalue;
1079
1080   object = SCM_COERCE_OUTPORT (object);
1081
1082   SCM_VALIDATE_INT(2,cmd);
1083   if (SCM_OPFPORTP (object))
1084     fdes = SCM_FPORT_FDES (object);
1085   else
1086     {
1087       SCM_VALIDATE_INT(1,object);
1088       fdes = SCM_INUM (object);
1089     }
1090   if (SCM_NULLP (value))
1091     ivalue = 0;
1092   else
1093     {
1094       SCM_ASSERT (SCM_INUMP (SCM_CAR (value)), value, SCM_ARG3, FUNC_NAME);
1095       ivalue = SCM_INUM (SCM_CAR (value));
1096     }
1097   SCM_SYSCALL (rv = fcntl (fdes, SCM_INUM (cmd), ivalue));
1098   if (rv == -1)
1099     SCM_SYSERROR;
1100   return SCM_MAKINUM (rv);
1101 }
1102 #undef FUNC_NAME
1103
1104 GUILE_PROC (scm_fsync, "fsync", 1, 0, 0,
1105             (SCM object),
1106 "Copies any unwritten data for the specified output file descriptor to disk.
1107 If @var{port/fd} is a port, its buffer is flushed before the underlying
1108 file descriptor is fsync'd.
1109 The return value is unspecified.")
1110 #define FUNC_NAME s_scm_fsync
1111 {
1112   int fdes;
1113
1114   object = SCM_COERCE_OUTPORT (object);
1115
1116   if (SCM_OPFPORTP (object))
1117     {
1118       scm_flush (object);
1119       fdes = SCM_FPORT_FDES (object);
1120     }
1121   else
1122     {
1123       SCM_VALIDATE_INT(1,object);
1124       fdes = SCM_INUM (object);
1125     }
1126   if (fsync (fdes) == -1)
1127     SCM_SYSERROR;
1128   return SCM_UNSPECIFIED;
1129 }
1130 #undef FUNC_NAME
1131
1132 GUILE_PROC (scm_symlink, "symlink", 2, 0, 0,
1133             (SCM oldpath, SCM newpath),
1134 "Create a symbolic link named @var{path-to} with the value (i.e., pointing to)
1135 @var{path-from}.  The return value is unspecified.")
1136 #define FUNC_NAME s_scm_symlink
1137 {
1138 #ifdef HAVE_SYMLINK
1139   int val;
1140
1141   SCM_VALIDATE_ROSTRING(1,oldpath);
1142   SCM_VALIDATE_ROSTRING(2,newpath);
1143   SCM_COERCE_SUBSTR (oldpath);
1144   SCM_COERCE_SUBSTR (newpath);
1145   SCM_SYSCALL (val = symlink(SCM_ROCHARS(oldpath), SCM_ROCHARS(newpath)));
1146   if (val != 0)
1147     SCM_SYSERROR;
1148   return SCM_UNSPECIFIED;
1149 #else
1150   SCM_SYSMISSING;
1151   /* not reached.  */
1152   return SCM_BOOL_F;
1153 #endif
1154 }
1155 #undef FUNC_NAME
1156
1157
1158 GUILE_PROC (scm_readlink, "readlink", 1, 0, 0,
1159             (SCM path),
1160 "Returns the value of the symbolic link named by
1161 @var{path} (a string), i.e., the
1162 file that the link points to.")
1163 #define FUNC_NAME s_scm_readlink
1164 {
1165 #ifdef HAVE_READLINK
1166   int rv;
1167   int size = 100;
1168   char *buf;
1169   SCM result;
1170   SCM_VALIDATE_ROSTRING(1,path);
1171   SCM_COERCE_SUBSTR (path);
1172   buf = scm_must_malloc (size, FUNC_NAME);
1173   while ((rv = readlink (SCM_ROCHARS (path), buf, size)) == size)
1174     {
1175       scm_must_free (buf);
1176       size *= 2;
1177       buf = scm_must_malloc (size, FUNC_NAME);
1178     }
1179   if (rv == -1)
1180     SCM_SYSERROR;
1181   result = scm_makfromstr (buf, rv, 0);
1182   scm_must_free (buf);
1183   return result;
1184 #else
1185   SCM_SYSMISSING;
1186   /* not reached.  */
1187   return SCM_BOOL_F;
1188 #endif
1189 }
1190 #undef FUNC_NAME
1191
1192
1193 GUILE_PROC (scm_lstat, "lstat", 1, 0, 0,
1194             (SCM str),
1195 "Similar to @code{stat}, but does not follow symbolic links, i.e.,
1196 it will return information about a symbolic link itself, not the
1197 file it points to.  @var{path} must be a string.")
1198 #define FUNC_NAME s_scm_lstat
1199 {
1200 #ifdef HAVE_LSTAT
1201   int rv;
1202   struct stat stat_temp;
1203
1204   SCM_VALIDATE_ROSTRING(1,str);
1205   SCM_COERCE_SUBSTR (str);
1206   SCM_SYSCALL(rv = lstat(SCM_ROCHARS(str), &stat_temp));
1207   if (rv != 0)
1208     {
1209       int en = errno;
1210
1211       scm_syserror_msg (FUNC_NAME, "%s: %S",
1212                         scm_listify (scm_makfrom0str (strerror (errno)),
1213                                      str,
1214                                      SCM_UNDEFINED),
1215                         en);
1216     }
1217   return scm_stat2scm(&stat_temp);
1218 #else
1219   SCM_SYSMISSING;
1220   /* not reached.  */
1221   return SCM_BOOL_F;
1222 #endif
1223 }
1224 #undef FUNC_NAME
1225
1226
1227 GUILE_PROC (scm_copy_file, "copy-file", 2, 0, 0,
1228             (SCM oldfile, SCM newfile),
1229 "Copy the file specified by @var{path-from} to @var{path-to}.
1230 The return value is unspecified.")
1231 #define FUNC_NAME s_scm_copy_file
1232 {
1233   int oldfd, newfd;
1234   int n;
1235   char buf[BUFSIZ];
1236   struct stat oldstat;
1237
1238   SCM_VALIDATE_ROSTRING(1,oldfile);
1239   if (SCM_SUBSTRP (oldfile))
1240     oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_ROLENGTH (oldfile), 0);
1241   SCM_VALIDATE_ROSTRING(2,newfile);
1242   if (SCM_SUBSTRP (newfile))
1243     newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0);
1244   if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1)
1245     SCM_SYSERROR;
1246   oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY);
1247   if (oldfd == -1)
1248     SCM_SYSERROR;
1249
1250   /* use POSIX flags instead of 07777?.  */
1251   newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC,
1252                 oldstat.st_mode & 07777);
1253   if (newfd == -1)
1254     SCM_SYSERROR;
1255
1256   while ((n = read (oldfd, buf, sizeof buf)) > 0)
1257     if (write (newfd, buf, n) != n)
1258       {
1259         close (oldfd);
1260         close (newfd);
1261         SCM_SYSERROR;
1262       }
1263   close (oldfd);
1264   if (close (newfd) == -1)
1265     SCM_SYSERROR;
1266   return SCM_UNSPECIFIED;
1267 }
1268 #undef FUNC_NAME
1269
1270 \f
1271 /* Filename manipulation */
1272
1273 SCM scm_dot_string;
1274
1275 GUILE_PROC (scm_dirname, "dirname", 1, 0, 0,
1276             (SCM filename),
1277 "")
1278 #define FUNC_NAME s_scm_dirname
1279 {
1280   char *s;
1281   int i, len;
1282   SCM_VALIDATE_ROSTRING(1,filename);
1283   s = SCM_ROCHARS (filename);
1284   len = SCM_LENGTH (filename);
1285   i = len - 1;
1286   while (i >= 0 && s[i] == '/') --i;
1287   while (i >= 0 && s[i] != '/') --i;
1288   while (i >= 0 && s[i] == '/') --i;
1289   if (i < 0)
1290     {
1291       if (len > 0 && s[0] == '/')
1292         return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
1293       else
1294         return scm_dot_string;
1295     }
1296   else
1297     return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (i + 1));
1298 }
1299 #undef FUNC_NAME
1300
1301 GUILE_PROC (scm_basename, "basename", 1, 1, 0,
1302             (SCM filename, SCM suffix),
1303 "")
1304 #define FUNC_NAME s_scm_basename
1305 {
1306   char *f, *s = 0;
1307   int i, j, len, end;
1308   SCM_VALIDATE_ROSTRING(1,filename);
1309   SCM_ASSERT (SCM_UNBNDP (suffix)
1310               || (SCM_ROSTRINGP (suffix)),
1311               suffix,
1312               SCM_ARG2,
1313               FUNC_NAME);
1314   f = SCM_ROCHARS (filename);
1315   if (SCM_UNBNDP (suffix))
1316     j = -1;
1317   else
1318     {
1319       s = SCM_ROCHARS (suffix);
1320       j = SCM_LENGTH (suffix) - 1;
1321     }
1322   len = SCM_LENGTH (filename);
1323   i = len - 1;
1324   while (i >= 0 && f[i] == '/') --i;
1325   end = i;
1326   while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j;
1327   if (j == -1)
1328     end = i;
1329   while (i >= 0 && f[i] != '/') --i;
1330   if (i == end)
1331     {
1332       if (len > 0 && f[0] == '/')
1333         return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
1334       else
1335         return scm_dot_string;
1336     }
1337   else
1338     return scm_make_shared_substring (filename,
1339                                       SCM_MAKINUM (i + 1),
1340                                       SCM_MAKINUM (end + 1));
1341 }
1342 #undef FUNC_NAME
1343
1344
1345
1346 \f
1347
1348 void
1349 scm_init_filesys ()
1350 {
1351   scm_tc16_dir = scm_make_smob_type_mfpe ("directory", 0,
1352                                          NULL, scm_dir_free,scm_dir_print, NULL);
1353
1354   scm_dot_string = scm_permanent_object (scm_makfrom0str ("."));
1355
1356 #ifdef O_RDONLY
1357 scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY));
1358 #endif
1359 #ifdef O_WRONLY
1360 scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY));
1361 #endif
1362 #ifdef O_RDWR
1363 scm_sysintern ("O_RDWR", scm_long2num (O_RDWR));
1364 #endif
1365 #ifdef O_CREAT
1366 scm_sysintern ("O_CREAT", scm_long2num (O_CREAT));
1367 #endif
1368 #ifdef O_EXCL
1369 scm_sysintern ("O_EXCL", scm_long2num (O_EXCL));
1370 #endif
1371 #ifdef O_NOCTTY
1372 scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY));
1373 #endif
1374 #ifdef O_TRUNC
1375 scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC));
1376 #endif
1377 #ifdef O_APPEND
1378 scm_sysintern ("O_APPEND", scm_long2num (O_APPEND));
1379 #endif
1380 #ifdef O_NONBLOCK
1381 scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK));
1382 #endif
1383 #ifdef O_NDELAY
1384 scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY));
1385 #endif
1386 #ifdef O_SYNC
1387 scm_sysintern ("O_SYNC", scm_long2num (O_SYNC));
1388 #endif
1389
1390 #ifdef F_DUPFD
1391 scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD));
1392 #endif
1393 #ifdef F_GETFD
1394 scm_sysintern ("F_GETFD", scm_long2num (F_GETFD));
1395 #endif
1396 #ifdef F_SETFD
1397 scm_sysintern ("F_SETFD", scm_long2num (F_SETFD));
1398 #endif
1399 #ifdef F_GETFL
1400 scm_sysintern ("F_GETFL", scm_long2num (F_GETFL));
1401 #endif
1402 #ifdef F_SETFL
1403 scm_sysintern ("F_SETFL", scm_long2num (F_SETFL));
1404 #endif
1405 #ifdef F_GETOWN
1406 scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN));
1407 #endif
1408 #ifdef F_SETOWN
1409 scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN));
1410 #endif
1411 #ifdef FD_CLOEXEC
1412 scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC));
1413 #endif
1414
1415 #include "filesys.x"
1416 }