libguile/filesys.c

   1 /*      Copyright (C) 1996, 1997 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 \f
  42 #include <stdio.h>
  43 #include "_scm.h"
  44 #include "genio.h"
  45 #include "smob.h"
  46 #include "feature.h"
  47 #include "fports.h"
  48 #include "iselect.h"
  49
  50 #include "filesys.h"
  51 \f
  52 #ifdef TIME_WITH_SYS_TIME
  53 # include <sys/time.h>
  54 # include <time.h>
  55 #else
  56 # if HAVE_SYS_TIME_H
  57 #  include <sys/time.h>
  58 # else
  59 #  include <time.h>
  60 # endif
  61 #endif
  62
  63 #ifdef HAVE_UNISTD_H
  64 #include <unistd.h>
  65 #endif
  66
  67 #ifdef LIBC_H_WITH_UNISTD_H
  68 #include <libc.h>
  69 #endif
  70
  71 #ifdef HAVE_SYS_SELECT_H
  72 #include <sys/select.h>
  73 #endif
  74
  75 #ifdef HAVE_STRING_H
  76 #include <string.h>
  77 #endif
  78
  79 #include <sys/types.h>
  80 #include <sys/stat.h>
  81 #include <fcntl.h>
  82
  83 #include <pwd.h>
  84
  85
  86 #if HAVE_DIRENT_H
  87 # include <dirent.h>
  88 # define NAMLEN(dirent) strlen((dirent)->d_name)
  89 #else
  90 # define dirent direct
  91 # define NAMLEN(dirent) (dirent)->d_namlen
  92 # if HAVE_SYS_NDIR_H
  93 #  include <sys/ndir.h>
  94 # endif
  95 # if HAVE_SYS_DIR_H
  96 #  include <sys/dir.h>
  97 # endif
  98 # if HAVE_NDIR_H
  99 #  include <ndir.h>
 100 # endif
 101 #endif
 102
 103 /* Ultrix has S_IFSOCK, but no S_ISSOCK.  Ipe!  */
 104 #if defined (S_IFSOCK) && ! defined (S_ISSOCK)
 105 #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
 106 #endif
 107 \f
 108
 109
 110 \f
 111
 112 /* {Permissions}
 113  */
 114
 115 SCM_PROC (s_chown, "chown", 3, 0, 0, scm_chown);
 116
 117 SCM
 118 scm_chown (object, owner, group)
 119      SCM object;
 120      SCM owner;
 121      SCM group;
 122 {
 123   int rv;
 124   int fdes;
 125
 126   object = SCM_COERCE_OUTPORT (object);
 127
 128   SCM_ASSERT (SCM_INUMP (owner), owner, SCM_ARG2, s_chown);
 129   SCM_ASSERT (SCM_INUMP (group), group, SCM_ARG3, s_chown);
 130   SCM_DEFER_INTS;
 131   if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object)))
 132     {
 133       if (SCM_INUMP (object))
 134         fdes = SCM_INUM (object);
 135       else
 136         {
 137           fdes = fileno ((FILE *) SCM_STREAM (object));
 138           if (fdes == -1)
 139             scm_syserror (s_chown);
 140         }
 141       SCM_SYSCALL (rv = fchown (fdes, SCM_INUM (owner), SCM_INUM (group)));
 142     }
 143   else
 144     {
 145       SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object),
 146                   object, SCM_ARG1, s_chown);
 147       SCM_COERCE_SUBSTR (object);
 148       SCM_SYSCALL (rv = chown (SCM_ROCHARS (object),
 149                                SCM_INUM (owner), SCM_INUM (group)));
 150     }
 151   if (rv == -1)
 152     scm_syserror (s_chown);
 153   SCM_ALLOW_INTS;
 154   return SCM_UNSPECIFIED;
 155 }
 156
 157
 158 SCM_PROC (s_chmod, "chmod", 2, 0, 0, scm_chmod);
 159
 160 SCM
 161 scm_chmod (object, mode)
 162      SCM object;
 163      SCM mode;
 164 {
 165   int rv;
 166   int fdes;
 167
 168   object = SCM_COERCE_OUTPORT (object);
 169
 170   SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_chmod);
 171   SCM_DEFER_INTS;
 172   if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object)))
 173     {
 174       if (SCM_INUMP (object))
 175         fdes = SCM_INUM (object);
 176       else
 177         {
 178           fdes = fileno ((FILE *) SCM_STREAM (object));
 179           if (fdes == -1)
 180             scm_syserror (s_chmod);
 181         }
 182       SCM_SYSCALL (rv = fchmod (fdes, SCM_INUM (mode)));
 183     }
 184   else
 185     {
 186       SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object),
 187                   object, SCM_ARG1, s_chmod);
 188       SCM_COERCE_SUBSTR (object);
 189       SCM_SYSCALL (rv = chmod (SCM_ROCHARS (object), SCM_INUM (mode)));
 190     }
 191   if (rv == -1)
 192     scm_syserror (s_chmod);
 193   SCM_ALLOW_INTS;
 194   return SCM_UNSPECIFIED;
 195 }
 196
 197 SCM_PROC (s_umask, "umask", 0, 1, 0, scm_umask);
 198
 199 SCM
 200 scm_umask (mode)
 201      SCM mode;
 202 {
 203   mode_t mask;
 204   if (SCM_UNBNDP (mode))
 205     {
 206       mask = umask (0);
 207       umask (mask);
 208     }
 209   else
 210     {
 211       SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG1, s_umask);
 212       mask = umask (SCM_INUM (mode));
 213     }
 214   return SCM_MAKINUM (mask);
 215 }
 216
 217 \f
 218
 219 SCM_PROC (s_open_fdes, "open-fdes", 2, 1, 0, scm_open_fdes);
 220 SCM
 221 scm_open_fdes (SCM path, SCM flags, SCM mode)
 222 {
 223   int fd;
 224   int iflags;
 225   int imode;
 226
 227   SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1,
 228               s_open_fdes);
 229   SCM_COERCE_SUBSTR (path);
 230   iflags = scm_num2long (flags, (char *) SCM_ARG2, s_open_fdes);
 231
 232   SCM_DEFER_INTS;
 233   if (SCM_UNBNDP (mode))
 234     imode = 0666;
 235   else
 236     {
 237       SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG3, s_open_fdes);
 238       imode = SCM_INUM (mode);
 239     }
 240   SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags, imode));
 241   if (fd == -1)
 242     scm_syserror (s_open_fdes);
 243   SCM_ALLOW_INTS;
 244   return SCM_MAKINUM (fd);
 245 }
 246
 247 SCM_PROC (s_open, "open", 2, 1, 0, scm_open);
 248 SCM
 249 scm_open (SCM path, SCM flags, SCM mode)
 250 {
 251   SCM newpt;
 252   char *port_mode;
 253   int fd;
 254   FILE *f;
 255   int iflags;
 256
 257   fd = SCM_INUM (scm_open_fdes (path, flags, mode));
 258   iflags = scm_num2long (flags, (char *) SCM_ARG2, s_open_fdes);
 259   if (iflags & O_RDWR)
 260     port_mode = "r+";
 261   else {
 262     if (iflags & O_WRONLY)
 263       port_mode = "w";
 264     else
 265       port_mode = "r";
 266   }
 267   SCM_DEFER_INTS;
 268   f = fdopen (fd, port_mode);
 269   if (!f)
 270     {
 271       SCM_SYSCALL (close (fd));
 272       scm_syserror (s_open);
 273     }
 274   newpt = scm_stdio_to_port (f, port_mode, path);
 275   SCM_ALLOW_INTS;
 276
 277   return newpt;
 278 }
 279
 280 SCM_PROC (s_close, "close", 1, 0, 0, scm_close);
 281 SCM
 282 scm_close (SCM fd_or_port)
 283 {
 284   int rv;
 285   int fd;
 286
 287   fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
 288
 289   if (SCM_NIMP (fd_or_port) && SCM_PORTP (fd_or_port))
 290     return scm_close_port (fd_or_port);
 291   SCM_ASSERT (SCM_INUMP (fd_or_port), fd_or_port, SCM_ARG1, s_close);
 292   fd = SCM_INUM (fd_or_port);
 293   SCM_DEFER_INTS;
 294   scm_evict_ports (fd);         /* see scsh manual.  */
 295   SCM_SYSCALL (rv = close (fd));
 296   /* following scsh, closing an already closed file descriptor is
 297      not an error.  */
 298   if (rv < 0 && errno != EBADF)
 299     scm_syserror (s_close);
 300   SCM_ALLOW_INTS;
 301   return (rv < 0) ? SCM_BOOL_F : SCM_BOOL_T;
 302 }
 303
 304 \f
 305 /* {Files}
 306  */
 307
 308 SCM_SYMBOL (scm_sym_regular, "regular");
 309 SCM_SYMBOL (scm_sym_directory, "directory");
 310 SCM_SYMBOL (scm_sym_symlink, "symlink");
 311 SCM_SYMBOL (scm_sym_block_special, "block-special");
 312 SCM_SYMBOL (scm_sym_char_special, "char-special");
 313 SCM_SYMBOL (scm_sym_fifo, "fifo");
 314 SCM_SYMBOL (scm_sym_sock, "socket");
 315 SCM_SYMBOL (scm_sym_unknown, "unknown");
 316
 317 static SCM scm_stat2scm SCM_P ((struct stat *stat_temp));
 318
 319 static SCM
 320 scm_stat2scm (stat_temp)
 321      struct stat *stat_temp;
 322 {
 323   SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED);
 324   SCM *ve = SCM_VELTS (ans);
 325
 326   ve[0] = scm_ulong2num ((unsigned long) stat_temp->st_dev);
 327   ve[1] = scm_ulong2num ((unsigned long) stat_temp->st_ino);
 328   ve[2] = scm_ulong2num ((unsigned long) stat_temp->st_mode);
 329   ve[3] = scm_ulong2num ((unsigned long) stat_temp->st_nlink);
 330   ve[4] = scm_ulong2num ((unsigned long) stat_temp->st_uid);
 331   ve[5] = scm_ulong2num ((unsigned long) stat_temp->st_gid);
 332 #ifdef HAVE_ST_RDEV
 333   ve[6] = scm_ulong2num ((unsigned long) stat_temp->st_rdev);
 334 #else
 335   ve[6] = SCM_BOOL_F;
 336 #endif
 337   ve[7] = scm_ulong2num ((unsigned long) stat_temp->st_size);
 338   ve[8] = scm_ulong2num ((unsigned long) stat_temp->st_atime);
 339   ve[9] = scm_ulong2num ((unsigned long) stat_temp->st_mtime);
 340   ve[10] = scm_ulong2num ((unsigned long) stat_temp->st_ctime);
 341 #ifdef HAVE_ST_BLKSIZE
 342   ve[11] = scm_ulong2num ((unsigned long) stat_temp->st_blksize);
 343 #else
 344   ve[11] = scm_ulong2num (4096L);
 345 #endif
 346 #ifdef HAVE_ST_BLOCKS
 347   ve[12] = scm_ulong2num ((unsigned long) stat_temp->st_blocks);
 348 #else
 349   ve[12] = SCM_BOOL_F;
 350 #endif
 351   {
 352     int mode = stat_temp->st_mode;
 353
 354     if (S_ISREG (mode))
 355       ve[13] = scm_sym_regular;
 356     else if (S_ISDIR (mode))
 357       ve[13] = scm_sym_directory;
 358     else if (S_ISLNK (mode))
 359       ve[13] = scm_sym_symlink;
 360     else if (S_ISBLK (mode))
 361       ve[13] = scm_sym_block_special;
 362     else if (S_ISCHR (mode))
 363       ve[13] = scm_sym_char_special;
 364     else if (S_ISFIFO (mode))
 365       ve[13] = scm_sym_fifo;
 366     else if (S_ISSOCK (mode))
 367       ve[13] = scm_sym_sock;
 368     else
 369       ve[13] = scm_sym_unknown;
 370
 371     ve[14] = SCM_MAKINUM ((~S_IFMT) & mode);
 372
 373     /* the layout of the bits in ve[14] is intended to be portable.
 374        If there are systems that don't follow the usual convention,
 375        the following could be used:
 376
 377        tmp = 0;
 378        if (S_ISUID & mode) tmp += 1;
 379        tmp <<= 1;
 380        if (S_IRGRP & mode) tmp += 1;
 381        tmp <<= 1;
 382        if (S_ISVTX & mode) tmp += 1;
 383        tmp <<= 1;
 384        if (S_IRUSR & mode) tmp += 1;
 385        tmp <<= 1;
 386        if (S_IWUSR & mode) tmp += 1;
 387        tmp <<= 1;
 388        if (S_IXUSR & mode) tmp += 1;
 389        tmp <<= 1;
 390        if (S_IWGRP & mode) tmp += 1;
 391        tmp <<= 1;
 392        if (S_IXGRP & mode) tmp += 1;
 393        tmp <<= 1;
 394        if (S_IROTH & mode) tmp += 1;
 395        tmp <<= 1;
 396        if (S_IWOTH & mode) tmp += 1;
 397        tmp <<= 1;
 398        if (S_IXOTH & mode) tmp += 1;
 399
 400        ve[14] = SCM_MAKINUM (tmp);
 401
 402        */
 403   }
 404
 405   return ans;
 406 }
 407
 408 SCM_PROC (s_stat, "stat", 1, 0, 0, scm_stat);
 409
 410 SCM
 411 scm_stat (object)
 412      SCM object;
 413 {
 414   int rv;
 415   int fdes;
 416   struct stat stat_temp;
 417
 418   SCM_DEFER_INTS;
 419   if (SCM_INUMP (object))
 420     SCM_SYSCALL (rv = fstat (SCM_INUM (object), &stat_temp));
 421   else
 422     {
 423       SCM_ASSERT (SCM_NIMP (object), object, SCM_ARG1, s_stat);
 424       if (SCM_ROSTRINGP (object))
 425         {
 426           SCM_COERCE_SUBSTR (object);
 427           SCM_SYSCALL (rv = stat (SCM_ROCHARS (object), &stat_temp));
 428         }
 429       else
 430         {
 431           object = SCM_COERCE_OUTPORT (object);
 432           SCM_ASSERT (SCM_OPFPORTP (object), object, SCM_ARG1, s_stat);
 433           fdes = fileno ((FILE *) SCM_STREAM (object));
 434           if (fdes == -1)
 435             scm_syserror (s_stat);
 436           SCM_SYSCALL (rv = fstat (fdes, &stat_temp));
 437         }
 438     }
 439   if (rv == -1)
 440     {
 441       int en = errno;
 442
 443       scm_syserror_msg (s_stat, "%s: %S",
 444                         scm_listify (scm_makfrom0str (strerror (errno)),
 445                                      object,
 446                                      SCM_UNDEFINED),
 447                         en);
 448     }
 449   SCM_ALLOW_INTS;
 450   return scm_stat2scm (&stat_temp);
 451 }
 452
 453 \f
 454 /* {Modifying Directories}
 455  */
 456
 457 SCM_PROC (s_link, "link", 2, 0, 0, scm_link);
 458
 459 SCM
 460 scm_link (oldpath, newpath)
 461      SCM oldpath;
 462      SCM newpath;
 463 {
 464   int val;
 465
 466   SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath,
 467               SCM_ARG1, s_link);
 468   if (SCM_SUBSTRP (oldpath))
 469     oldpath = scm_makfromstr (SCM_ROCHARS (oldpath),
 470                               SCM_ROLENGTH (oldpath), 0);
 471   SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath,
 472               SCM_ARG2, s_link);
 473   if (SCM_SUBSTRP (newpath))
 474     newpath = scm_makfromstr (SCM_ROCHARS (newpath),
 475                               SCM_ROLENGTH (newpath), 0);
 476   SCM_DEFER_INTS;
 477   SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath)));
 478   if (val != 0)
 479     scm_syserror (s_link);
 480   SCM_ALLOW_INTS;
 481   return SCM_UNSPECIFIED;
 482 }
 483
 484
 485
 486 SCM_PROC (s_rename, "rename-file", 2, 0, 0, scm_rename);
 487
 488 SCM
 489 scm_rename (oldname, newname)
 490      SCM oldname;
 491      SCM newname;
 492 {
 493   int rv;
 494   SCM_ASSERT (SCM_NIMP (oldname) && SCM_ROSTRINGP (oldname), oldname, SCM_ARG1,
 495               s_rename);
 496   SCM_ASSERT (SCM_NIMP (newname) && SCM_ROSTRINGP (newname), newname, SCM_ARG2,
 497               s_rename);
 498   SCM_COERCE_SUBSTR (oldname);
 499   SCM_COERCE_SUBSTR (newname);
 500   SCM_DEFER_INTS;
 501 #ifdef HAVE_RENAME
 502   SCM_SYSCALL (rv = rename (SCM_ROCHARS (oldname), SCM_ROCHARS (newname)));
 503 #else
 504   SCM_SYSCALL (rv = link (SCM_ROCHARS (oldname), SCM_ROCHARS (newname)));
 505   if (rv == 0)
 506     {
 507       SCM_SYSCALL (rv = unlink (SCM_ROCHARS (oldname)));;
 508       if (rv != 0)
 509         /* unlink failed.  remove new name */
 510         SCM_SYSCALL (unlink (SCM_ROCHARS (newname)));
 511     }
 512 #endif
 513   if (rv != 0)
 514     scm_syserror (s_rename);
 515   SCM_ALLOW_INTS;
 516   return SCM_UNSPECIFIED;
 517 }
 518
 519
 520 SCM_PROC(s_delete_file, "delete-file", 1, 0, 0, scm_delete_file);
 521
 522 SCM
 523 scm_delete_file (str)
 524      SCM str;
 525 {
 526   int ans;
 527   SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1,
 528               s_delete_file);
 529   SCM_COERCE_SUBSTR (str);
 530   SCM_DEFER_INTS;
 531   SCM_SYSCALL (ans = unlink (SCM_ROCHARS (str)));
 532   if (ans != 0)
 533     scm_syserror (s_delete_file);
 534   SCM_ALLOW_INTS;
 535   return SCM_UNSPECIFIED;
 536 }
 537
 538 SCM_PROC (s_truncate_file, "truncate-file", 2, 0, 0, scm_truncate_file);
 539 SCM
 540 scm_truncate_file (SCM object, SCM size)
 541 {
 542   int rv;
 543   scm_sizet csize;
 544   int fdes;
 545
 546   object = SCM_COERCE_OUTPORT (object);
 547
 548   csize = (scm_sizet) scm_num2long (size, (char *) SCM_ARG2, s_truncate_file);
 549   SCM_DEFER_INTS;
 550   if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object)))
 551     {
 552       if (SCM_INUMP (object))
 553         fdes = SCM_INUM (object);
 554       else
 555         {
 556           fdes = fileno ((FILE *) SCM_STREAM (object));
 557           if (fdes == -1)
 558             scm_syserror (s_truncate_file);
 559         }
 560       SCM_SYSCALL (rv = ftruncate (fdes, csize));
 561     }
 562   else
 563     {
 564       SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object),
 565                   object, SCM_ARG1, s_chown);
 566       SCM_COERCE_SUBSTR (object);
 567       SCM_SYSCALL (rv = truncate (SCM_ROCHARS (object), csize));
 568     }
 569   if (rv == -1)
 570     scm_syserror (s_truncate_file);
 571   SCM_ALLOW_INTS;
 572   return SCM_UNSPECIFIED;
 573 }
 574
 575 SCM_PROC (s_mkdir, "mkdir", 1, 1, 0, scm_mkdir);
 576
 577 SCM
 578 scm_mkdir (path, mode)
 579      SCM path;
 580      SCM mode;
 581 {
 582 #ifdef HAVE_MKDIR
 583   int rv;
 584   mode_t mask;
 585   SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1,
 586               s_mkdir);
 587   SCM_COERCE_SUBSTR (path);
 588   SCM_DEFER_INTS;
 589   if (SCM_UNBNDP (mode))
 590     {
 591       mask = umask (0);
 592       umask (mask);
 593       SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), 0777 ^ mask));
 594     }
 595   else
 596     {
 597       SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_mkdir);
 598       SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), SCM_INUM (mode)));
 599     }
 600   if (rv != 0)
 601     scm_syserror (s_mkdir);
 602   SCM_ALLOW_INTS;
 603   return SCM_UNSPECIFIED;
 604 #else
 605   scm_sysmissing (s_mkdir);
 606   /* not reached.  */
 607   return SCM_BOOL_F;
 608 #endif
 609 }
 610
 611
 612 SCM_PROC (s_rmdir, "rmdir", 1, 0, 0, scm_rmdir);
 613
 614 SCM
 615 scm_rmdir (path)
 616      SCM path;
 617 {
 618 #ifdef HAVE_RMDIR
 619   int val;
 620
 621   SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1,
 622               s_rmdir);
 623   SCM_COERCE_SUBSTR (path);
 624   SCM_DEFER_INTS;
 625   SCM_SYSCALL (val = rmdir (SCM_ROCHARS (path)));
 626   if (val != 0)
 627     scm_syserror (s_rmdir);
 628   SCM_ALLOW_INTS;
 629   return SCM_UNSPECIFIED;
 630 #else
 631   scm_sysmissing (s_rmdir);
 632   /* not reached.  */
 633   return SCM_BOOL_F;
 634 #endif
 635 }
 636
 637 \f
 638 /* {Examining Directories}
 639  */
 640
 641 long scm_tc16_dir;
 642
 643 SCM_PROC (s_opendir, "opendir", 1, 0, 0, scm_opendir);
 644
 645 SCM
 646 scm_opendir (dirname)
 647      SCM dirname;
 648 {
 649   DIR *ds;
 650   SCM dir;
 651   SCM_ASSERT (SCM_NIMP (dirname) && SCM_ROSTRINGP (dirname), dirname, SCM_ARG1,
 652               s_opendir);
 653   SCM_COERCE_SUBSTR (dirname);
 654   SCM_NEWCELL (dir);
 655   SCM_DEFER_INTS;
 656   SCM_SYSCALL (ds = opendir (SCM_ROCHARS (dirname)));
 657   if (ds == NULL)
 658     scm_syserror (s_opendir);
 659   SCM_SETCAR (dir, scm_tc16_dir | SCM_OPN);
 660   SCM_SETCDR (dir, ds);
 661   SCM_ALLOW_INTS;
 662   return dir;
 663 }
 664
 665
 666 SCM_PROC (s_readdir, "readdir", 1, 0, 0, scm_readdir);
 667
 668 SCM
 669 scm_readdir (port)
 670      SCM port;
 671 {
 672   struct dirent *rdent;
 673   SCM_DEFER_INTS;
 674   SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_readdir);
 675   errno = 0;
 676   SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CDR (port)));
 677   SCM_ALLOW_INTS;
 678   if (errno != 0)
 679     scm_syserror (s_readdir);
 680   return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0)
 681           : SCM_EOF_VAL);
 682 }
 683
 684
 685
 686 SCM_PROC (s_rewinddir, "rewinddir", 1, 0, 0, scm_rewinddir);
 687
 688 SCM
 689 scm_rewinddir (port)
 690      SCM port;
 691 {
 692   SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_rewinddir);
 693   rewinddir ((DIR *) SCM_CDR (port));
 694   return SCM_UNSPECIFIED;
 695 }
 696
 697
 698
 699 SCM_PROC (s_closedir, "closedir", 1, 0, 0, scm_closedir);
 700
 701 SCM
 702 scm_closedir (port)
 703      SCM port;
 704 {
 705   int sts;
 706
 707   SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, SCM_ARG1, s_closedir);
 708   SCM_DEFER_INTS;
 709   if (SCM_CLOSEDP (port))
 710     {
 711       SCM_ALLOW_INTS;
 712       return SCM_UNSPECIFIED;
 713     }
 714   SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port)));
 715   if (sts != 0)
 716     scm_syserror (s_closedir);
 717   SCM_SETCAR (port, scm_tc16_dir);
 718   SCM_ALLOW_INTS;
 719   return SCM_UNSPECIFIED;
 720 }
 721
 722
 723
 724
 725 static int scm_dir_print SCM_P ((SCM sexp, SCM port, scm_print_state *pstate));
 726
 727 static int
 728 scm_dir_print (sexp, port, pstate)
 729      SCM sexp;
 730      SCM port;
 731      scm_print_state *pstate;
 732 {
 733   scm_prinport (sexp, port, "directory");
 734   return 1;
 735 }
 736
 737
 738 static scm_sizet scm_dir_free SCM_P ((SCM p));
 739
 740 static scm_sizet
 741 scm_dir_free (p)
 742      SCM p;
 743 {
 744   if (SCM_OPENP (p))
 745     closedir ((DIR *) SCM_CDR (p));
 746   return 0;
 747 }
 748
 749 static scm_smobfuns dir_smob = {0, scm_dir_free, scm_dir_print, 0};
 750
 751 \f
 752 /* {Navigating Directories}
 753  */
 754
 755
 756 SCM_PROC (s_chdir, "chdir", 1, 0, 0, scm_chdir);
 757
 758 SCM
 759 scm_chdir (str)
 760      SCM str;
 761 {
 762   int ans;
 763
 764   SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_chdir);
 765   SCM_COERCE_SUBSTR (str);
 766   SCM_DEFER_INTS;
 767   SCM_SYSCALL (ans = chdir (SCM_ROCHARS (str)));
 768   if (ans != 0)
 769     scm_syserror (s_chdir);
 770   SCM_ALLOW_INTS;
 771   return SCM_UNSPECIFIED;
 772 }
 773
 774
 775
 776 SCM_PROC (s_getcwd, "getcwd", 0, 0, 0, scm_getcwd);
 777
 778 SCM
 779 scm_getcwd ()
 780 {
 781 #ifdef HAVE_GETCWD
 782   char *rv;
 783
 784   scm_sizet size = 100;
 785   char *wd;
 786   SCM result;
 787
 788   SCM_DEFER_INTS;
 789   wd = scm_must_malloc (size, s_getcwd);
 790   while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
 791     {
 792       scm_must_free (wd);
 793       size *= 2;
 794       wd = scm_must_malloc (size, s_getcwd);
 795     }
 796   if (rv == 0)
 797     scm_syserror (s_getcwd);
 798   result = scm_makfromstr (wd, strlen (wd), 0);
 799   scm_must_free (wd);
 800   SCM_ALLOW_INTS;
 801   return result;
 802 #else
 803   scm_sysmissing (s_getcwd);
 804   /* not reached.  */
 805   return SCM_BOOL_F;
 806 #endif
 807 }
 808
 809 \f
 810
 811 SCM_PROC (s_select, "select", 3, 2, 0, scm_select);
 812
 813
 814 static int
 815 set_element (SELECT_TYPE *set, SCM element, int arg)
 816 {
 817   int fd;
 818   element = SCM_COERCE_OUTPORT (element);
 819   if (SCM_NIMP (element) && SCM_FPORTP (element) && SCM_OPPORTP (element))
 820     fd = fileno ((FILE *) SCM_STREAM (element));
 821   else {
 822     SCM_ASSERT (SCM_INUMP (element), element, arg, s_select);
 823     fd = SCM_INUM (element);
 824   }
 825   FD_SET (fd, set);
 826   return fd;
 827 }
 828
 829 static int
 830 fill_select_type (SELECT_TYPE *set, SCM list, int arg)
 831 {
 832   int max_fd = 0, fd;
 833   if (SCM_NIMP (list) && SCM_VECTORP (list))
 834     {
 835       int len = SCM_LENGTH (list);
 836       SCM *ve = SCM_VELTS (list);
 837
 838       while (len > 0)
 839         {
 840           fd = set_element (set, ve[len - 1], arg);
 841           if (fd > max_fd)
 842             max_fd = fd;
 843           len--;
 844         }
 845     }
 846   else
 847     {
 848       while (list != SCM_EOL)
 849         {
 850           fd = set_element (set, SCM_CAR (list), arg);
 851           if (fd > max_fd)
 852             max_fd = fd;
 853           list = SCM_CDR (list);
 854         }
 855     }
 856
 857   return max_fd;
 858 }
 859
 860 static SCM
 861 get_element (SELECT_TYPE *set, SCM element, SCM list)
 862 {
 863   element = SCM_COERCE_OUTPORT (element);
 864   if (SCM_NIMP (element) && SCM_FPORTP (element) && SCM_OPPORTP (element))
 865     {
 866       if (FD_ISSET (fileno ((FILE *)SCM_STREAM (element)), set))
 867         list = scm_cons (element, list);
 868     }
 869   else if (SCM_INUMP (element))
 870     {
 871       if (FD_ISSET (SCM_INUM (element), set))
 872         list = scm_cons (element, list);
 873     }
 874   return list;
 875 }
 876
 877 static SCM
 878 retrieve_select_type (SELECT_TYPE *set, SCM list)
 879 {
 880   SCM answer_list = SCM_EOL;
 881
 882   if (SCM_NIMP (list) && SCM_VECTORP (list))
 883     {
 884       int len = SCM_LENGTH (list);
 885       SCM *ve = SCM_VELTS (list);
 886
 887       while (len > 0)
 888         {
 889           answer_list = get_element (set, ve[len - 1], answer_list);
 890           len--;
 891         }
 892       return scm_vector (answer_list);
 893     }
 894   else
 895     {
 896       /* list is a list.  */
 897       while (list != SCM_EOL)
 898         {
 899           answer_list = get_element (set, SCM_CAR (list), answer_list);
 900           list = SCM_CDR (list);
 901         }
 902       return answer_list;
 903     }
 904 }
 905
 906
 907 SCM
 908 scm_select (reads, writes, excepts, secs, usecs)
 909      SCM reads;
 910      SCM writes;
 911      SCM excepts;
 912      SCM secs;
 913      SCM usecs;
 914 {
 915 #ifdef HAVE_SELECT
 916   struct timeval timeout;
 917   struct timeval * time_p;
 918   SELECT_TYPE read_set;
 919   SELECT_TYPE write_set;
 920   SELECT_TYPE except_set;
 921   int max_fd, fd;
 922   int sreturn;
 923
 924 #define assert_set(x, arg) \
 925   SCM_ASSERT (scm_ilength (x) > -1 || (SCM_NIMP (x) && SCM_VECTORP (x)), \
 926               x, arg, s_select)
 927   assert_set (reads, SCM_ARG1);
 928   assert_set (writes, SCM_ARG2);
 929   assert_set (excepts, SCM_ARG3);
 930 #undef assert_set
 931
 932   FD_ZERO (&read_set);
 933   FD_ZERO (&write_set);
 934   FD_ZERO (&except_set);
 935
 936   max_fd = fill_select_type (&read_set, reads, SCM_ARG1);
 937   fd = fill_select_type (&write_set, writes, SCM_ARG2);
 938   if (fd > max_fd)
 939     max_fd = fd;
 940   fd = fill_select_type (&except_set, excepts, SCM_ARG3);
 941   if (fd > max_fd)
 942     max_fd = fd;
 943
 944   if (SCM_UNBNDP (secs) || SCM_FALSEP (secs))
 945     time_p = 0;
 946   else
 947     {
 948       if (SCM_INUMP (secs))
 949         {
 950           timeout.tv_sec = SCM_INUM (secs);
 951           if (SCM_UNBNDP (usecs))
 952             timeout.tv_usec = 0;
 953           else
 954             {
 955               SCM_ASSERT (SCM_INUMP (usecs), usecs, SCM_ARG5, s_select);
 956
 957               timeout.tv_usec = SCM_INUM (usecs);
 958             }
 959         }
 960       else
 961         {
 962           double fl = scm_num2dbl (secs, s_select);
 963
 964           if (!SCM_UNBNDP (usecs))
 965             scm_wrong_type_arg (s_select, 4, secs);
 966           if (fl > LONG_MAX)
 967             scm_out_of_range (s_select, secs);
 968           timeout.tv_sec = (long) fl;
 969           timeout.tv_usec = (long) ((fl - timeout.tv_sec) * 1000000);
 970         }
 971       time_p = &timeout;
 972     }
 973
 974 #ifdef GUILE_ISELECT
 975   sreturn = scm_internal_select (max_fd + 1,
 976                                  &read_set, &write_set, &except_set, time_p);
 977 #else
 978   SCM_DEFER_INTS;
 979   sreturn = select (max_fd + 1,
 980                     &read_set, &write_set, &except_set, time_p);
 981   SCM_ALLOW_INTS;
 982 #endif
 983   if (sreturn < 0)
 984     scm_syserror (s_select);
 985   return scm_listify (retrieve_select_type (&read_set, reads),
 986                       retrieve_select_type (&write_set, writes),
 987                       retrieve_select_type (&except_set, excepts),
 988                       SCM_UNDEFINED);
 989 #else
 990   scm_sysmissing (s_select);
 991   /* not reached.  */
 992   return SCM_BOOL_F;
 993 #endif
 994 }
 995
 996 /* Check if FILE has characters waiting to be read.  */
 997
 998 #ifdef __IBMC__
 999 # define MSDOS
1000 #endif
1001 #ifdef MSDOS
1002 # ifndef GO32
1003 #  include <io.h>
1004 #  include <conio.h>
1005
1006 int
1007 scm_input_waiting_p (f, caller)
1008      FILE *f;
1009      char *caller;
1010 {
1011   if (feof (f))
1012     return 1;
1013   if (fileno (f) == fileno (stdin) && (isatty (fileno (stdin))))
1014     return kbhit ();
1015   return -1;
1016 }
1017
1018 # endif
1019 #else
1020 # ifdef _DCC
1021 #  include <ioctl.h>
1022 # else
1023 #  ifndef AMIGA
1024 #   ifndef vms
1025 #    ifdef MWC
1026 #     include <sys/io.h>
1027 #    else
1028 #     ifndef THINK_C
1029 #      ifndef ARM_ULIB
1030 #       include <sys/ioctl.h>
1031 #      endif
1032 #     endif
1033 #    endif
1034 #   endif
1035 #  endif
1036 # endif
1037
1038 int
1039 scm_input_waiting_p (f, caller)
1040      FILE *f;
1041      char *caller;
1042 {
1043   /* Can we return an end-of-file character? */
1044   if (feof (f))
1045     return 1;
1046
1047   /* Do we have characters in the stdio buffer? */
1048 # ifdef FILE_CNT_FIELD
1049   if (f->FILE_CNT_FIELD > 0)
1050     return 1;
1051 # else
1052 #  ifdef FILE_CNT_GPTR
1053   if (f->_gptr != f->_egptr)
1054     return 1;
1055 # else
1056 #   ifdef FILE_CNT_READPTR
1057   if (f->_IO_read_end != f->_IO_read_ptr)
1058     return 1;
1059 #   else
1060   Configure.in could not guess the name of the correct field in a FILE *.
1061   This function needs to be ported to your system.
1062   It should return zero iff no characters are waiting to be read.;
1063 #   endif
1064 #  endif
1065 # endif
1066
1067   /* Is the file prepared to deliver input? */
1068 # ifdef HAVE_SELECT
1069   {
1070     struct timeval timeout;
1071     SELECT_TYPE read_set;
1072     SELECT_TYPE write_set;
1073     SELECT_TYPE except_set;
1074     int fno = fileno ((FILE *)f);
1075
1076     FD_ZERO (&read_set);
1077     FD_ZERO (&write_set);
1078     FD_ZERO (&except_set);
1079
1080     FD_SET (fno, &read_set);
1081
1082     timeout.tv_sec = 0;
1083     timeout.tv_usec = 0;
1084
1085     SCM_DEFER_INTS;
1086     if (select (SELECT_SET_SIZE,
1087                 &read_set, &write_set, &except_set, &timeout)
1088         < 0)
1089       scm_syserror (caller);
1090     SCM_ALLOW_INTS;
1091     return FD_ISSET (fno, &read_set);
1092   }
1093 # else
1094 # ifdef FIONREAD
1095   {
1096     long remir;
1097     ioctl(fileno(f), FIONREAD, &remir);
1098     return remir;
1099   }
1100 #  else
1101   scm_misc_error ("char-ready?", "Not fully implemented on this platform",
1102                   SCM_EOL);
1103 #  endif
1104 # endif
1105 }
1106 #endif
1107
1108 \f
1109
1110 SCM_PROC (s_fcntl, "fcntl", 2, 0, 1, scm_fcntl);
1111 SCM
1112 scm_fcntl (SCM object, SCM cmd, SCM value)
1113 {
1114   int rv;
1115   int fdes;
1116   int ivalue;
1117
1118   object = SCM_COERCE_OUTPORT (object);
1119
1120   SCM_ASSERT (SCM_INUMP (cmd), cmd, SCM_ARG2, s_fcntl);
1121   if (SCM_NIMP (object) && SCM_OPFPORTP (object))
1122     fdes = fileno ((FILE *) SCM_STREAM (object));
1123   else
1124     {
1125       SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fcntl);
1126       fdes = SCM_INUM (object);
1127     }
1128   if (SCM_NULLP (value))
1129     ivalue = 0;
1130   else
1131     {
1132       SCM_ASSERT (SCM_INUMP (SCM_CAR (value)), value, SCM_ARG3, s_fcntl);
1133       ivalue = SCM_INUM (SCM_CAR (value));
1134     }
1135   SCM_DEFER_INTS;
1136   if (fdes != -1)
1137     SCM_SYSCALL (rv = fcntl (fdes, SCM_INUM (cmd), ivalue));
1138   else
1139     rv = 0;                     /* avoid compiler warning.  */
1140   if (rv == -1 || fdes == -1)
1141     scm_syserror (s_fcntl);
1142   SCM_ALLOW_INTS;
1143   return SCM_MAKINUM (rv);
1144 }
1145
1146 SCM_PROC (s_fsync, "fsync", 1, 0, 0, scm_fsync);
1147 SCM
1148 scm_fsync (SCM object)
1149 {
1150   int fdes;
1151
1152   object = SCM_COERCE_OUTPORT (object);
1153
1154   SCM_DEFER_INTS;
1155   if (SCM_NIMP (object) && SCM_OPFPORTP (object))
1156     {
1157       scm_force_output (object);
1158       fdes = fileno ((FILE *) SCM_STREAM (object));
1159       if (fdes == -1)
1160         scm_syserror (s_fsync);
1161     }
1162   else
1163     {
1164       SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fsync);
1165       fdes = SCM_INUM (object);
1166     }
1167   if (fsync (fdes) == -1)
1168     scm_syserror (s_fsync);
1169   SCM_ALLOW_INTS;
1170   return SCM_UNSPECIFIED;
1171 }
1172
1173 SCM_PROC (s_symlink, "symlink", 2, 0, 0, scm_symlink);
1174
1175 SCM
1176 scm_symlink(oldpath, newpath)
1177      SCM oldpath;
1178      SCM newpath;
1179 {
1180 #ifdef HAVE_SYMLINK
1181   int val;
1182
1183   SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1,
1184               s_symlink);
1185   SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, SCM_ARG2,
1186               s_symlink);
1187   SCM_COERCE_SUBSTR (oldpath);
1188   SCM_COERCE_SUBSTR (newpath);
1189   SCM_DEFER_INTS;
1190   SCM_SYSCALL (val = symlink(SCM_ROCHARS(oldpath), SCM_ROCHARS(newpath)));
1191   if (val != 0)
1192     scm_syserror (s_symlink);
1193   SCM_ALLOW_INTS;
1194   return SCM_UNSPECIFIED;
1195 #else
1196   scm_sysmissing (s_symlink);
1197   /* not reached.  */
1198   return SCM_BOOL_F;
1199 #endif
1200 }
1201
1202
1203 SCM_PROC (s_readlink, "readlink", 1, 0, 0, scm_readlink);
1204
1205 SCM
1206 scm_readlink(path)
1207   SCM path;
1208 {
1209 #ifdef HAVE_READLINK
1210   int rv;
1211   int size = 100;
1212   char *buf;
1213   SCM result;
1214   SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, (char *) SCM_ARG1,
1215               s_readlink);
1216   SCM_COERCE_SUBSTR (path);
1217   SCM_DEFER_INTS;
1218   buf = scm_must_malloc (size, s_readlink);
1219   while ((rv = readlink (SCM_ROCHARS (path), buf, size)) == size)
1220     {
1221       scm_must_free (buf);
1222       size *= 2;
1223       buf = scm_must_malloc (size, s_readlink);
1224     }
1225   if (rv == -1)
1226     scm_syserror (s_readlink);
1227   result = scm_makfromstr (buf, rv, 0);
1228   scm_must_free (buf);
1229   SCM_ALLOW_INTS;
1230   return result;
1231 #else
1232   scm_sysmissing (s_readlink);
1233   /* not reached.  */
1234   return SCM_BOOL_F;
1235 #endif
1236 }
1237
1238
1239 SCM_PROC (s_lstat, "lstat", 1, 0, 0, scm_lstat);
1240
1241 SCM
1242 scm_lstat(str)
1243   SCM str;
1244 {
1245 #ifdef HAVE_LSTAT
1246   int rv;
1247   struct stat stat_temp;
1248
1249   SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, (char *) SCM_ARG1,
1250               s_lstat);
1251   SCM_COERCE_SUBSTR (str);
1252   SCM_DEFER_INTS;
1253   SCM_SYSCALL(rv = lstat(SCM_ROCHARS(str), &stat_temp));
1254   if (rv != 0)
1255     {
1256       int en = errno;
1257
1258       scm_syserror_msg (s_lstat, "%s: %S",
1259                         scm_listify (scm_makfrom0str (strerror (errno)),
1260                                      str,
1261                                      SCM_UNDEFINED),
1262                         en);
1263     }
1264   SCM_ALLOW_INTS;
1265   return scm_stat2scm(&stat_temp);
1266 #else
1267   scm_sysmissing (s_lstat);
1268   /* not reached.  */
1269   return SCM_BOOL_F;
1270 #endif
1271 }
1272
1273
1274 SCM_PROC (s_copy_file, "copy-file", 2, 0, 0, scm_copy_file);
1275
1276 SCM
1277 scm_copy_file (oldfile, newfile)
1278      SCM oldfile;
1279      SCM newfile;
1280 {
1281   int oldfd, newfd;
1282   int n;
1283   char buf[BUFSIZ];             /* this space could be shared.  */
1284   struct stat oldstat;
1285
1286   SCM_ASSERT (SCM_NIMP (oldfile) && SCM_ROSTRINGP (oldfile), oldfile, SCM_ARG1, s_copy_file);
1287   if (SCM_SUBSTRP (oldfile))
1288     oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_ROLENGTH (oldfile), 0);
1289   SCM_ASSERT (SCM_NIMP (newfile) && SCM_ROSTRINGP (newfile), newfile, SCM_ARG2, s_copy_file);
1290   if (SCM_SUBSTRP (newfile))
1291     newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0);
1292   if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1)
1293     scm_syserror (s_copy_file);
1294   SCM_DEFER_INTS;
1295   oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY);
1296   if (oldfd == -1)
1297     scm_syserror (s_copy_file);
1298
1299   /* use POSIX flags instead of 07777?.  */
1300   newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC,
1301                 oldstat.st_mode & 07777);
1302   if (newfd == -1)
1303     scm_syserror (s_copy_file);
1304
1305   while ((n = read (oldfd, buf, sizeof buf)) > 0)
1306     if (write (newfd, buf, n) != n)
1307       {
1308         close (oldfd);
1309         close (newfd);
1310         scm_syserror (s_copy_file);
1311       }
1312   close (oldfd);
1313   if (close (newfd) == -1)
1314     scm_syserror (s_copy_file);
1315   SCM_ALLOW_INTS;
1316   return SCM_UNSPECIFIED;
1317 }
1318
1319 \f
1320 /* Filename manipulation */
1321
1322 SCM scm_dot_string;
1323
1324 SCM_PROC (s_dirname, "dirname", 1, 0, 0, scm_dirname);
1325
1326 SCM
1327 scm_dirname (SCM filename)
1328 {
1329   char *s;
1330   int i, len;
1331   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename),
1332               filename,
1333               SCM_ARG1,
1334               s_dirname);
1335   s = SCM_ROCHARS (filename);
1336   len = SCM_LENGTH (filename);
1337   i = len - 1;
1338   while (i >= 0 && s[i] == '/') --i;
1339   while (i >= 0 && s[i] != '/') --i;
1340   while (i >= 0 && s[i] == '/') --i;
1341   if (i < 0)
1342     {
1343       if (len > 0 && s[0] == '/')
1344         return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
1345       else
1346         return scm_dot_string;
1347     }
1348   else
1349     return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (i + 1));
1350 }
1351
1352 SCM_PROC (s_basename, "basename", 1, 1, 0, scm_basename);
1353
1354 SCM
1355 scm_basename (SCM filename, SCM suffix)
1356 {
1357   char *f, *s = 0;
1358   int i, j, len, end;
1359   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename),
1360               filename,
1361               SCM_ARG1,
1362               s_basename);
1363   SCM_ASSERT (SCM_UNBNDP (suffix)
1364               || (SCM_NIMP (suffix) && SCM_ROSTRINGP (suffix)),
1365               suffix,
1366               SCM_ARG2,
1367               s_basename);
1368   f = SCM_ROCHARS (filename);
1369   if (SCM_UNBNDP (suffix))
1370     j = -1;
1371   else
1372     {
1373       s = SCM_ROCHARS (suffix);
1374       j = SCM_LENGTH (suffix) - 1;
1375     }
1376   len = SCM_LENGTH (filename);
1377   i = len - 1;
1378   while (i >= 0 && f[i] == '/') --i;
1379   end = i;
1380   while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j;
1381   if (j == -1)
1382     end = i;
1383   while (i >= 0 && f[i] != '/') --i;
1384   if (i == end)
1385     {
1386       if (len > 0 && f[0] == '/')
1387         return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
1388       else
1389         return scm_dot_string;
1390     }
1391   else
1392     return scm_make_shared_substring (filename,
1393                                       SCM_MAKINUM (i + 1),
1394                                       SCM_MAKINUM (end + 1));
1395 }
1396
1397
1398
1399 \f
1400
1401 void
1402 scm_init_filesys ()
1403 {
1404   scm_add_feature ("i/o-extensions");
1405
1406   scm_tc16_dir = scm_newsmob (&dir_smob);
1407
1408   scm_dot_string = scm_permanent_object (scm_makfrom0str ("."));
1409
1410 #ifdef O_RDONLY
1411 scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY));
1412 #endif
1413 #ifdef O_WRONLY
1414 scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY));
1415 #endif
1416 #ifdef O_RDWR
1417 scm_sysintern ("O_RDWR", scm_long2num (O_RDWR));
1418 #endif
1419 #ifdef O_CREAT
1420 scm_sysintern ("O_CREAT", scm_long2num (O_CREAT));
1421 #endif
1422 #ifdef O_EXCL
1423 scm_sysintern ("O_EXCL", scm_long2num (O_EXCL));
1424 #endif
1425 #ifdef O_NOCTTY
1426 scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY));
1427 #endif
1428 #ifdef O_TRUNC
1429 scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC));
1430 #endif
1431 #ifdef O_APPEND
1432 scm_sysintern ("O_APPEND", scm_long2num (O_APPEND));
1433 #endif
1434 #ifdef O_NONBLOCK
1435 scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK));
1436 #endif
1437 #ifdef O_NDELAY
1438 scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY));
1439 #endif
1440 #ifdef O_SYNC
1441 scm_sysintern ("O_SYNC", scm_long2num (O_SYNC));
1442 #endif
1443
1444 #ifdef F_DUPFD
1445 scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD));
1446 #endif
1447 #ifdef F_GETFD
1448 scm_sysintern ("F_GETFD", scm_long2num (F_GETFD));
1449 #endif
1450 #ifdef F_SETFD
1451 scm_sysintern ("F_SETFD", scm_long2num (F_SETFD));
1452 #endif
1453 #ifdef F_GETFL
1454 scm_sysintern ("F_GETFL", scm_long2num (F_GETFL));
1455 #endif
1456 #ifdef F_SETFL
1457 scm_sysintern ("F_SETFL", scm_long2num (F_SETFL));
1458 #endif
1459 #ifdef F_GETOWN
1460 scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN));
1461 #endif
1462 #ifdef F_SETOWN
1463 scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN));
1464 #endif
1465 #ifdef FD_CLOEXEC
1466 scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC));
1467 #endif
1468
1469 #include "filesys.x"
1470 }