diff --git a/NEWS b/NEWS index b68e77b9a..1c59a03b6 100644 --- a/NEWS +++ b/NEWS @@ -65,6 +65,15 @@ was successfully closed, while #f means it was already closed. It is also now possible for these procedures to raise an exception if an error occurs (some errors from write can be delayed until close.) +** the first argument to chmod, fcntl, ftell and fseek can now be a +file descriptor. + +** the third argument to fcntl is now optional. + +** the first argument to chown can now be a file descriptor or a port. + +** the argument to stat can now be a port. + ** The following new procedures have been added (most use scsh interfaces): @@ -119,6 +128,14 @@ If VALUE is `#f', removes NAME from the environment. Otherwise adds the string NAME=VALUE to the environment, replacing any previous value for NAME. +** truncate-file OBJ SIZE + Truncates the file referred to by OBJ to at most SIZE bytes. OBJ + can be a string containing a file name or an integer file + descriptor or port open for output on the file. The underlying + system calls are `truncate' and `ftruncate'. + + The return value is unspecified. + ** setvbuf PORT MODE [SIZE] Set the buffering mode for PORT. MODE can be: `_IONBF' @@ -139,9 +156,53 @@ value for NAME. size. Procedures e.g., *Note open-file: File Ports, which accept a mode string allow `0' to be added to request an unbuffered port. -** primitive-exit [STATUS] -Terminates the current process without unwinding the Scheme stack. -This would usually be used after a fork. +** fsync PORT/FD + Copies any unwritten data for the specified output file descriptor + to disk. If PORT/FD is a port, its buffer is flushed before the + underlying file descriptor is fsync'd. The return value is + unspecified. + +** open-fdes PATH FLAGS [MODES] + Similar to `open' but returns a file descriptor instead of a port. + +** procedure: execle PATH ENV [ARG] ... + Similar to `execl', but the environment of the new process is + specified by ENV, which must be a list of strings as returned by + the `environ' procedure. + + This procedure is currently implemented using the `execve' system + call, but we call it `execle' because of its Scheme calling + interface. + +** procedure: primitive-exit [STATUS] + Terminate the current process without unwinding the Scheme stack. + This is would typically be useful after a fork. The exit status + is STATUS if supplied, otherwise zero. + +** procedure: times + Returns an object with information about real and processor time. + The following procedures accept such an object as an argument and + return a selected component: + + `tms:clock' + The current real time, expressed as time units relative to an + arbitrary base. + + `tms:utime' + The CPU time units used by the calling process. + + `tms:stime' + The CPU time units used by the system on behalf of the + calling process. + + `tms:cutime' + The CPU time units used by terminated child processes of the + calling process, whose status has been collected (e.g., using + `waitpid'). + + `tms:cstime' + Similarly, the CPU times units used by the system on behalf of + terminated child processes. * Changes to the gh_ interface diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 42a9cac00..80581235f 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +Sat Aug 16 18:44:24 1997 Gary Houston + + * boot-9.scm: define tms accessors: clock, utime, stime, cutime, + cstime. + Thu Aug 14 19:55:37 1997 Mikael Djurfeldt * emacs.scm (emacs-load): Something has changed in the reader so diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index ec6ed2272..85f406f53 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -760,6 +760,12 @@ (define (set-tm:gmtoff obj val) (vector-set! obj 9 val)) (define (set-tm:zone obj val) (vector-set! obj 10 val)) +(define (tms:clock obj) (vector-ref obj 0)) +(define (tms:utime obj) (vector-ref obj 1)) +(define (tms:stime obj) (vector-ref obj 2)) +(define (tms:cutime obj) (vector-ref obj 3)) +(define (tms:cstime obj) (vector-ref obj 4)) + (define (file-position . args) (apply ftell args)) (define (file-set-position . args) (apply fseek args)) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2771382db..e48f5abbe 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,34 @@ +Sat Aug 16 18:42:15 1997 Gary Houston + + * stime.h: prototype for scm_times. + * stime.c (scm_times): new procedure. + * ioext.c (scm_fseek): if the first argument is a file descriptor + call lseek. + (scm_ftell): if the first argument is a file descriptor call lseek + (sic). + * filesys.h: prototypes for scm_open_fdes, scm_fsync. + * filesys.c (scm_chmod): if the first argument is a file descriptor, + call fchmod. + (scm_chown): if the first argument is a port or file descriptor, + call fchown. + (scm_truncate_file): new procedure. + Add DEFER/ALLOW INTS to a few other procedures. + (scm_fsync): new procedure. + (scm_open_fdes): new procedure. + (scm_open): use scm_open_fdes. If mode isn't specified, 666 will + now be used. + (scm_fcntl): the first argument can now be a file descriptor. The + third argument is now optional. + + * posix.c (scm_execl, scm_execlp): make the filename argument + compulsory, since omitting it causes SEGV. + (scm_sync): return unspecified instead of #f. + (scm_execle): new procedure. + (environ_list_to_c): new procedure. + (scm_environ): use environ_list_to_c. disable interrupts. + (scm_convert_exec_args): take pos and subr arguments and + improve error checking. + 1997-08-14 Mikael Djurfeldt * stacks.c (scm_make_stack), coop-threads.c, mit-pthreads.c diff --git a/libguile/filesys.c b/libguile/filesys.c index b2b13244a..8be71a562 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -131,22 +131,40 @@ SCM_PROC (s_chown, "chown", 3, 0, 0, scm_chown); SCM -scm_chown (path, owner, group) - SCM path; +scm_chown (object, owner, group) + SCM object; SCM owner; SCM group; { - int val; + int rv; + int fdes; - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_chown); SCM_ASSERT (SCM_INUMP (owner), owner, SCM_ARG2, s_chown); SCM_ASSERT (SCM_INUMP (group), group, SCM_ARG3, s_chown); - - SCM_COERCE_SUBSTR (path); - SCM_SYSCALL (val = chown (SCM_ROCHARS (path), - SCM_INUM (owner), SCM_INUM (group))); - if (val != 0) + SCM_DEFER_INTS; + if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object))) + { + if (SCM_INUMP (object)) + fdes = SCM_INUM (object); + else + { + fdes = fileno ((FILE *) SCM_STREAM (object)); + if (fdes == -1) + scm_syserror (s_chown); + } + SCM_SYSCALL (rv = fchown (fdes, SCM_INUM (owner), SCM_INUM (group))); + } + else + { + SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object), + object, SCM_ARG1, s_chown); + SCM_COERCE_SUBSTR (object); + SCM_SYSCALL (rv = chown (SCM_ROCHARS (object), + SCM_INUM (owner), SCM_INUM (group))); + } + if (rv == -1) scm_syserror (s_chown); + SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } @@ -154,27 +172,37 @@ scm_chown (path, owner, group) SCM_PROC (s_chmod, "chmod", 2, 0, 0, scm_chmod); SCM -scm_chmod (port_or_path, mode) - SCM port_or_path; +scm_chmod (object, mode) + SCM object; SCM mode; { int rv; + int fdes; + SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_chmod); - SCM_ASSERT (SCM_NIMP (port_or_path), port_or_path, SCM_ARG1, s_chmod); - if (SCM_ROSTRINGP (port_or_path)) + SCM_DEFER_INTS; + if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object))) { - SCM_COERCE_SUBSTR (port_or_path); - SCM_SYSCALL (rv = chmod (SCM_ROCHARS (port_or_path), SCM_INUM (mode))); + if (SCM_INUMP (object)) + fdes = SCM_INUM (object); + else + { + fdes = fileno ((FILE *) SCM_STREAM (object)); + if (fdes == -1) + scm_syserror (s_chmod); + } + SCM_SYSCALL (rv = fchmod (fdes, SCM_INUM (mode))); } else { - SCM_ASSERT (SCM_OPFPORTP (port_or_path), port_or_path, SCM_ARG1, s_chmod); - rv = fileno ((FILE *)SCM_STREAM (port_or_path)); - if (rv != -1) - SCM_SYSCALL (rv = fchmod (rv, SCM_INUM (mode))); + SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object), + object, SCM_ARG1, s_chmod); + SCM_COERCE_SUBSTR (object); + SCM_SYSCALL (rv = chmod (SCM_ROCHARS (object), SCM_INUM (mode))); } - if (rv != 0) + if (rv == -1) scm_syserror (s_chmod); + SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } @@ -200,36 +228,46 @@ scm_umask (mode) -SCM_PROC (s_open, "open", 2, 1, 0, scm_open); - +SCM_PROC (s_open_fdes, "open-fdes", 2, 1, 0, scm_open_fdes); SCM -scm_open (path, flags, mode) - SCM path; - SCM flags; - SCM mode; +scm_open_fdes (SCM path, SCM flags, SCM mode) { int fd; - SCM newpt; - FILE *f; - char *port_mode; int iflags; + int imode; - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_open); - iflags = scm_num2long (flags, (char *) SCM_ARG2, s_open); - - if (SCM_SUBSTRP (path)) - path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); + SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, + s_open_fdes); + SCM_COERCE_SUBSTR (path); + iflags = scm_num2long (flags, (char *) SCM_ARG2, s_open_fdes); SCM_DEFER_INTS; if (SCM_UNBNDP (mode)) - SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags)); + imode = 0666; else { - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG3, s_open); - SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags, SCM_INUM (mode))); + SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG3, s_open_fdes); + imode = SCM_INUM (mode); } + SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags, imode)); if (fd == -1) - scm_syserror (s_open); + scm_syserror (s_open_fdes); + SCM_ALLOW_INTS; + return SCM_MAKINUM (fd); +} + +SCM_PROC (s_open, "open", 2, 1, 0, scm_open); +SCM +scm_open (SCM path, SCM flags, SCM mode) +{ + SCM newpt; + char *port_mode; + int fd; + FILE *f; + int iflags; + + fd = SCM_INUM (scm_open_fdes (path, flags, mode)); + iflags = scm_num2long (flags, (char *) SCM_ARG2, s_open_fdes); SCM_NEWCELL (newpt); if (iflags & O_RDWR) port_mode = "r+"; @@ -239,6 +277,7 @@ scm_open (path, flags, mode) else port_mode = "r"; } + SCM_DEFER_INTS; f = fdopen (fd, port_mode); if (!f) { @@ -390,40 +429,44 @@ scm_stat2scm (stat_temp) SCM_PROC (s_stat, "stat", 1, 0, 0, scm_stat); SCM -scm_stat (file) - SCM file; +scm_stat (object) + SCM object; { - int rv = 1; + int rv; + int fdes; struct stat stat_temp; - if (SCM_INUMP (file)) - SCM_SYSCALL (rv = fstat (SCM_INUM (file), &stat_temp)); - else + SCM_DEFER_INTS; + if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object))) { - SCM_ASSERT (SCM_NIMP (file), file, SCM_ARG1, s_stat); - if (SCM_FPORTP (file)) - SCM_SYSCALL (rv = fstat (fileno ((FILE *) SCM_STREAM (file)), - &stat_temp)); + if (SCM_INUMP (object)) + fdes = SCM_INUM (object); else { - SCM_ASSERT (SCM_ROSTRINGP (file), file, SCM_ARG1, s_stat); - if (SCM_SUBSTRP (file)) - file = scm_makfromstr (SCM_ROCHARS (file), - SCM_ROLENGTH (file), - 0); - SCM_SYSCALL (rv = stat (SCM_CHARS (file), &stat_temp)); + fdes = fileno ((FILE *) SCM_STREAM (object)); + if (fdes == -1) + scm_syserror (s_stat); } + SCM_SYSCALL (rv = fstat (fdes, &stat_temp)); } - if (rv != 0) + else + { + SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object), + object, SCM_ARG1, s_stat); + SCM_COERCE_SUBSTR (object); + SCM_SYSCALL (rv = stat (SCM_ROCHARS (object), &stat_temp)); + } + if (rv == -1) { int en = errno; scm_syserror_msg (s_stat, "%s: %S", scm_listify (scm_makfrom0str (strerror (errno)), - file, + object, SCM_UNDEFINED), en); } + SCM_ALLOW_INTS; return scm_stat2scm (&stat_temp); } @@ -441,15 +484,21 @@ scm_link (oldpath, newpath) { int val; - SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1, s_link); + SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, + SCM_ARG1, s_link); if (SCM_SUBSTRP (oldpath)) - oldpath = scm_makfromstr (SCM_ROCHARS (oldpath), SCM_ROLENGTH (oldpath), 0); - SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, SCM_ARG2, s_link); + oldpath = scm_makfromstr (SCM_ROCHARS (oldpath), + SCM_ROLENGTH (oldpath), 0); + SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, + SCM_ARG2, s_link); if (SCM_SUBSTRP (newpath)) - newpath = scm_makfromstr (SCM_ROCHARS (newpath), SCM_ROLENGTH (newpath), 0); + newpath = scm_makfromstr (SCM_ROCHARS (newpath), + SCM_ROLENGTH (newpath), 0); + SCM_DEFER_INTS; SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath))); if (val != 0) scm_syserror (s_link); + SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } @@ -469,13 +518,10 @@ scm_rename (oldname, newname) s_rename); SCM_COERCE_SUBSTR (oldname); SCM_COERCE_SUBSTR (newname); + SCM_DEFER_INTS; #ifdef HAVE_RENAME SCM_SYSCALL (rv = rename (SCM_ROCHARS (oldname), SCM_ROCHARS (newname))); - if (rv != 0) - scm_syserror (s_rename); - return SCM_UNSPECIFIED; #else - SCM_DEFER_INTS; SCM_SYSCALL (rv = link (SCM_ROCHARS (oldname), SCM_ROCHARS (newname))); if (rv == 0) { @@ -484,11 +530,11 @@ scm_rename (oldname, newname) /* unlink failed. remove new name */ SCM_SYSCALL (unlink (SCM_ROCHARS (newname))); } - SCM_ALLOW_INTS; +#endif if (rv != 0) scm_syserror (s_rename); + SCM_ALLOW_INTS; return SCM_UNSPECIFIED; -#endif } @@ -499,14 +545,51 @@ scm_delete_file (str) SCM str; { int ans; - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_delete_file); + SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, + s_delete_file); SCM_COERCE_SUBSTR (str); + SCM_DEFER_INTS; SCM_SYSCALL (ans = unlink (SCM_ROCHARS (str))); if (ans != 0) scm_syserror (s_delete_file); + SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } +SCM_PROC (s_truncate_file, "truncate-file", 2, 0, 0, scm_truncate_file); +SCM +scm_truncate_file (SCM object, SCM size) +{ + int rv; + scm_sizet csize; + int fdes; + + csize = (scm_sizet) scm_num2long (size, (char *) SCM_ARG2, s_truncate_file); + SCM_DEFER_INTS; + if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object))) + { + if (SCM_INUMP (object)) + fdes = SCM_INUM (object); + else + { + fdes = fileno ((FILE *) SCM_STREAM (object)); + if (fdes == -1) + scm_syserror (s_truncate_file); + } + SCM_SYSCALL (rv = ftruncate (fdes, csize)); + } + else + { + SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object), + object, SCM_ARG1, s_chown); + SCM_COERCE_SUBSTR (object); + SCM_SYSCALL (rv = truncate (SCM_ROCHARS (object), csize)); + } + if (rv == -1) + scm_syserror (s_truncate_file); + SCM_ALLOW_INTS; + return SCM_UNSPECIFIED; +} SCM_PROC (s_mkdir, "mkdir", 1, 1, 0, scm_mkdir); @@ -521,6 +604,7 @@ scm_mkdir (path, mode) SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_mkdir); SCM_COERCE_SUBSTR (path); + SCM_DEFER_INTS; if (SCM_UNBNDP (mode)) { mask = umask (0); @@ -534,6 +618,7 @@ scm_mkdir (path, mode) } if (rv != 0) scm_syserror (s_mkdir); + SCM_ALLOW_INTS; return SCM_UNSPECIFIED; #else scm_sysmissing (s_mkdir); @@ -555,9 +640,11 @@ scm_rmdir (path) SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_rmdir); SCM_COERCE_SUBSTR (path); + SCM_DEFER_INTS; SCM_SYSCALL (val = rmdir (SCM_ROCHARS (path))); if (val != 0) scm_syserror (s_rmdir); + SCM_ALLOW_INTS; return SCM_UNSPECIFIED; #else scm_sysmissing (s_rmdir); @@ -695,9 +782,11 @@ scm_chdir (str) SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_chdir); SCM_COERCE_SUBSTR (str); + SCM_DEFER_INTS; SCM_SYSCALL (ans = chdir (SCM_ROCHARS (str))); if (ans != 0) scm_syserror (s_chdir); + SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } @@ -1016,30 +1105,64 @@ scm_input_waiting_p (f, caller) -SCM_PROC (s_fcntl, "fcntl", 3, 0, 0, scm_fcntl); - +SCM_PROC (s_fcntl, "fcntl", 2, 0, 1, scm_fcntl); SCM -scm_fcntl (port, cmd, value) - SCM port; - SCM cmd; - SCM value; +scm_fcntl (SCM object, SCM cmd, SCM value) { int rv; + int fdes; + int ivalue; - SCM_ASSERT (SCM_OPFPORTP (port), port, SCM_ARG1, s_fcntl); SCM_ASSERT (SCM_INUMP (cmd), cmd, SCM_ARG2, s_fcntl); - SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG3, s_fcntl); - - rv = fileno ((FILE *)SCM_STREAM (port)); - if (rv != -1) - SCM_SYSCALL (rv = fcntl (rv, SCM_INUM (cmd), SCM_INUM (value))); - if (rv == -1) + if (SCM_NIMP (object) && SCM_OPFPORTP (object)) + fdes = fileno ((FILE *) SCM_STREAM (object)); + else + { + SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fcntl); + fdes = SCM_INUM (object); + } + if (SCM_NULLP (value)) + ivalue = 0; + else + { + SCM_ASSERT (SCM_INUMP (SCM_CAR (value)), value, SCM_ARG3, s_fcntl); + ivalue = SCM_INUM (SCM_CAR (value)); + } + SCM_DEFER_INTS; + if (fdes != -1) + SCM_SYSCALL (rv = fcntl (fdes, SCM_INUM (cmd), ivalue)); + else + rv = 0; /* avoid compiler warning. */ + if (rv == -1 || fdes == -1) scm_syserror (s_fcntl); + SCM_ALLOW_INTS; return SCM_MAKINUM (rv); } - -/* {Symbolic Links} - */ + +SCM_PROC (s_fsync, "fsync", 1, 0, 0, scm_fsync); +SCM +scm_fsync (SCM object) +{ + int fdes; + + SCM_DEFER_INTS; + if (SCM_NIMP (object) && SCM_OPFPORTP (object)) + { + scm_force_output (object); + fdes = fileno ((FILE *) SCM_STREAM (object)); + if (fdes == -1) + scm_syserror (s_fsync); + } + else + { + SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fsync); + fdes = SCM_INUM (object); + } + if (fsync (fdes) == -1) + scm_syserror (s_fsync); + SCM_ALLOW_INTS; + return SCM_UNSPECIFIED; +} SCM_PROC (s_symlink, "symlink", 2, 0, 0, scm_symlink); @@ -1057,9 +1180,11 @@ scm_symlink(oldpath, newpath) s_symlink); SCM_COERCE_SUBSTR (oldpath); SCM_COERCE_SUBSTR (newpath); + SCM_DEFER_INTS; SCM_SYSCALL (val = symlink(SCM_ROCHARS(oldpath), SCM_ROCHARS(newpath))); if (val != 0) scm_syserror (s_symlink); + SCM_ALLOW_INTS; return SCM_UNSPECIFIED; #else scm_sysmissing (s_symlink); @@ -1118,6 +1243,7 @@ scm_lstat(str) SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, (char *) SCM_ARG1, s_lstat); SCM_COERCE_SUBSTR (str); + SCM_DEFER_INTS; SCM_SYSCALL(rv = lstat(SCM_ROCHARS(str), &stat_temp)); if (rv != 0) { @@ -1129,6 +1255,7 @@ scm_lstat(str) SCM_UNDEFINED), en); } + SCM_ALLOW_INTS; return scm_stat2scm(&stat_temp); #else scm_sysmissing (s_lstat); @@ -1216,7 +1343,7 @@ scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC)); #ifdef O_APPEND scm_sysintern ("O_APPEND", scm_long2num (O_APPEND)); #endif -#ifdef O_NONBLO +#ifdef O_NONBLOCK scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK)); #endif #ifdef O_NDELAY diff --git a/libguile/filesys.h b/libguile/filesys.h index 3c251919b..f6f6fba61 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -54,15 +54,17 @@ extern long scm_tc16_dir; #define SCM_OPDIRP(x) (SCM_CAR(x)==(scm_tc16_dir | SCM_OPN)) -extern SCM scm_chown SCM_P ((SCM path, SCM owner, SCM group)); -extern SCM scm_chmod SCM_P ((SCM port_or_path, SCM mode)); +extern SCM scm_chown SCM_P ((SCM object, SCM owner, SCM group)); +extern SCM scm_chmod SCM_P ((SCM object, SCM mode)); extern SCM scm_umask SCM_P ((SCM mode)); -extern SCM scm_open SCM_P ((SCM path, SCM flags, SCM mode)); +extern SCM scm_open_fdes (SCM path, SCM flags, SCM mode); +extern SCM scm_open (SCM path, SCM flags, SCM mode); extern SCM scm_close (SCM fd_or_port); -extern SCM scm_stat SCM_P ((SCM fd_or_path)); +extern SCM scm_stat SCM_P ((SCM object)); extern SCM scm_link SCM_P ((SCM oldpath, SCM newpath)); extern SCM scm_rename SCM_P ((SCM oldname, SCM newname)); extern SCM scm_delete_file SCM_P ((SCM str)); +extern SCM scm_truncate_file (SCM object, SCM size); extern SCM scm_mkdir SCM_P ((SCM path, SCM mode)); extern SCM scm_rmdir SCM_P ((SCM path)); extern SCM scm_opendir SCM_P ((SCM dirname)); @@ -73,7 +75,8 @@ extern SCM scm_chdir SCM_P ((SCM str)); extern SCM scm_getcwd SCM_P ((void)); extern SCM scm_select SCM_P ((SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs)); extern int scm_input_waiting_p SCM_P ((FILE *file, char *caller)); -extern SCM scm_fcntl SCM_P ((SCM port, SCM cmd, SCM value)); +extern SCM scm_fcntl (SCM object, SCM cmd, SCM value); +extern SCM scm_fsync (SCM object); extern SCM scm_symlink SCM_P ((SCM oldpath, SCM newpath)); extern SCM scm_readlink SCM_P ((SCM path)); extern SCM scm_lstat SCM_P ((SCM str)); diff --git a/libguile/ioext.c b/libguile/ioext.c index 3a4cdec98..b47c15076 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -172,16 +172,25 @@ scm_write_line (obj, port) SCM_PROC (s_ftell, "ftell", 1, 0, 0, scm_ftell); SCM -scm_ftell (port) - SCM port; +scm_ftell (object) + SCM object; { long pos; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_ftell); - SCM_SYSCALL (pos = ftell ((FILE *)SCM_STREAM (port))); + SCM_DEFER_INTS; + if (SCM_NIMP (object) && SCM_OPFPORTP (object)) + { + SCM_SYSCALL (pos = ftell ((FILE *)SCM_STREAM (object))); + if (pos > 0 && SCM_CRDYP (object)) + pos--; + } + else + { + SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_ftell); + SCM_SYSCALL (pos = lseek (SCM_INUM (object), 0, SEEK_CUR)); + } if (pos < 0) scm_syserror (s_ftell); - if (pos > 0 && SCM_CRDYP (port)) - pos--; + SCM_ALLOW_INTS; return scm_long2num (pos); } @@ -190,29 +199,33 @@ scm_ftell (port) SCM_PROC (s_fseek, "fseek", 3, 0, 0, scm_fseek); SCM -scm_fseek (port, offset, whence) - SCM port; +scm_fseek (object, offset, whence) + SCM object; SCM offset; SCM whence; { int rv; long loff; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_fseek); loff = scm_num2long (offset, (char *)SCM_ARG2, s_fseek); - SCM_ASSERT (SCM_INUMP (whence) && (SCM_INUM (whence) < 3) && (SCM_INUM (whence) >= 0), - whence, SCM_ARG3, s_fseek); - - SCM_CLRDY (port); /* Clear ungetted char */ - /* Values of whence are interned in scm_init_ioext. */ - rv = fseek ((FILE *)SCM_STREAM (port), loff, SCM_INUM (whence)); - if (rv != 0) + SCM_ASSERT (SCM_INUMP (whence), whence, SCM_ARG3, s_fseek); + SCM_DEFER_INTS; + if (SCM_NIMP (object) && SCM_OPFPORTP (object)) + { + SCM_CLRDY (object); /* Clear ungetted char */ + rv = fseek ((FILE *)SCM_STREAM (object), loff, SCM_INUM (whence)); + } + else + { + SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fseek); + rv = lseek (SCM_INUM (object), loff, SCM_INUM (whence)); + } + if (rv < 0) scm_syserror (s_fseek); + SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } - - SCM_PROC (s_freopen, "freopen", 3, 0, 0, scm_freopen); SCM diff --git a/libguile/ioext.h b/libguile/ioext.h index ef9f8d1da..803dc3294 100644 --- a/libguile/ioext.h +++ b/libguile/ioext.h @@ -50,8 +50,8 @@ extern SCM scm_read_delimited_x SCM_P ((SCM delims, SCM buf, SCM gobble, SCM port, SCM offset, SCM length)); extern SCM scm_write_line SCM_P ((SCM obj, SCM port)); -extern SCM scm_ftell SCM_P ((SCM port)); -extern SCM scm_fseek SCM_P ((SCM port, SCM offset, SCM whence)); +extern SCM scm_ftell SCM_P ((SCM object)); +extern SCM scm_fseek SCM_P ((SCM object, SCM offset, SCM whence)); extern SCM scm_freopen SCM_P ((SCM filename, SCM modes, SCM port)); extern SCM scm_redirect_port SCM_P ((SCM into_pt, SCM from_pt)); extern SCM scm_dup_to_fdes (SCM fd_or_port, SCM newfd); diff --git a/libguile/posix.c b/libguile/posix.c index 048ac55bc..3cc00a030 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -719,28 +719,29 @@ scm_tcsetpgrp (port, pgid) /* Copy exec args from an SCM vector into a new C array. */ -static char ** scm_convert_exec_args SCM_P ((SCM args)); - static char ** -scm_convert_exec_args (args) - SCM args; +scm_convert_exec_args (SCM args, int pos, char *subr) { char **execargv; int num_args; int i; + + SCM_ASSERT (SCM_NULLP (args) + || (SCM_NIMP (args) && SCM_CONSP (args)), + args, pos, subr); SCM_DEFER_INTS; num_args = scm_ilength (args); execargv = (char **) - scm_must_malloc ((num_args + 1) * sizeof (char *), s_ttyname); + scm_must_malloc ((num_args + 1) * sizeof (char *), subr); for (i = 0; SCM_NNULLP (args); args = SCM_CDR (args), ++i) { scm_sizet len; char *dst; char *src; SCM_ASSERT (SCM_NIMP (SCM_CAR (args)) && SCM_ROSTRINGP (SCM_CAR (args)), - SCM_CAR (args), "wrong type in SCM_ARG", "exec arg"); + SCM_CAR (args), SCM_ARGn, subr); len = 1 + SCM_ROLENGTH (SCM_CAR (args)); - dst = (char *) scm_must_malloc ((long) len, s_ttyname); + dst = (char *) scm_must_malloc ((long) len, subr); src = SCM_ROCHARS (SCM_CAR (args)); while (len--) dst[len] = src[len]; @@ -751,46 +752,99 @@ scm_convert_exec_args (args) return execargv; } -SCM_PROC (s_execl, "execl", 0, 0, 1, scm_execl); +SCM_PROC (s_execl, "execl", 1, 0, 1, scm_execl); SCM -scm_execl (args) - SCM args; +scm_execl (filename, args) + SCM filename, args; { char **execargv; - SCM filename = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_execl); - if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0); - args = SCM_CDR (args); - execargv = scm_convert_exec_args (args); + SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, + SCM_ARG1, s_execl); + SCM_COERCE_SUBSTR (filename); + execargv = scm_convert_exec_args (args, SCM_ARG2, s_execl); execv (SCM_ROCHARS (filename), execargv); scm_syserror (s_execl); /* not reached. */ return SCM_BOOL_F; } -SCM_PROC (s_execlp, "execlp", 0, 0, 1, scm_execlp); +SCM_PROC (s_execlp, "execlp", 1, 0, 1, scm_execlp); SCM -scm_execlp (args) - SCM args; +scm_execlp (filename, args) + SCM filename, args; { char **execargv; - SCM filename = SCM_CAR (args); SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_execlp); - if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), - SCM_ROLENGTH (filename), 0); - args = SCM_CDR (args); - execargv = scm_convert_exec_args (args); + SCM_COERCE_SUBSTR (filename); + execargv = scm_convert_exec_args (args, SCM_ARG2, s_execlp); execvp (SCM_ROCHARS (filename), execargv); scm_syserror (s_execlp); /* not reached. */ return SCM_BOOL_F; } +static char ** +environ_list_to_c (SCM envlist, int arg, char *proc) +{ + int num_strings; + char **result; + int i = 0; + + SCM_REDEFER_INTS; + SCM_ASSERT (SCM_NULLP (envlist) + || (SCM_NIMP (envlist) && SCM_CONSP (envlist)), + envlist, arg, proc); + num_strings = scm_ilength (envlist); + result = (char **) malloc ((num_strings + 1) * sizeof (char *)); + if (result == NULL) + scm_memory_error (proc); + while (SCM_NNULLP (envlist)) + { + int len; + char *src; + + SCM_ASSERT (SCM_NIMP (SCM_CAR (envlist)) + && SCM_ROSTRINGP (SCM_CAR (envlist)), + envlist, arg, proc); + len = 1 + SCM_ROLENGTH (SCM_CAR (envlist)); + result[i] = malloc ((long) len); + if (result[i] == NULL) + scm_memory_error (proc); + src = SCM_ROCHARS (SCM_CAR (envlist)); + while (len--) + result[i][len] = src[len]; + envlist = SCM_CDR (envlist); + i++; + } + result[i] = 0; + SCM_REALLOW_INTS; + return result; +} + +SCM_PROC (s_execle, "execle", 2, 0, 1, scm_execle); + +SCM +scm_execle (filename, env, args) + SCM filename, env, args; +{ + char **execargv; + char **exec_env; + + SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, + SCM_ARG1, s_execle); + SCM_COERCE_SUBSTR (filename); + + execargv = scm_convert_exec_args (args, SCM_ARG1, s_execle); + exec_env = environ_list_to_c (env, SCM_ARG2, s_execle); + execve (SCM_ROCHARS (filename), execargv, exec_env); + scm_syserror (s_execle); + /* not reached. */ + return SCM_BOOL_F; +} + SCM_PROC (s_fork, "primitive-fork", 0, 0, 0, scm_fork); SCM @@ -844,33 +898,10 @@ scm_environ (env) return scm_makfromstrs (-1, environ); else { - int num_strings; char **new_environ; - int i = 0; - SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)), - env, SCM_ARG1, s_environ); - num_strings = scm_ilength (env); - new_environ = (char **) malloc ((num_strings + 1) * sizeof (char *)); - if (new_environ == NULL) - scm_memory_error (s_environ); - while (SCM_NNULLP (env)) - { - int len; - char *src; - SCM_ASSERT (SCM_NIMP (SCM_CAR (env)) - && SCM_ROSTRINGP (SCM_CAR (env)), - env, SCM_ARG1, s_environ); - len = 1 + SCM_ROLENGTH (SCM_CAR (env)); - new_environ[i] = malloc ((long) len); - if (new_environ[i] == NULL) - scm_memory_error (s_environ); - src = SCM_ROCHARS (SCM_CAR (env)); - while (len--) - new_environ[i][len] = src[len]; - env = SCM_CDR (env); - i++; - } - new_environ[i] = 0; + + SCM_DEFER_INTS; + new_environ = environ_list_to_c (env, SCM_ARG1, s_environ); /* Free the old environment, except when called for the first * time. */ @@ -886,6 +917,7 @@ scm_environ (env) first = 0; } environ = new_environ; + SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } } @@ -1151,12 +1183,9 @@ scm_sync() scm_sysmissing (s_sync); /* not reached. */ #endif - return SCM_BOOL_F; + return SCM_UNSPECIFIED; } - - - void scm_init_posix () { diff --git a/libguile/posix.h b/libguile/posix.h index 72d1adb65..f7812d75f 100644 --- a/libguile/posix.h +++ b/libguile/posix.h @@ -78,8 +78,9 @@ extern SCM scm_setgid SCM_P ((SCM id)); extern SCM scm_seteuid SCM_P ((SCM id)); extern SCM scm_setegid SCM_P ((SCM id)); extern SCM scm_ttyname SCM_P ((SCM port)); -extern SCM scm_execl SCM_P ((SCM args)); -extern SCM scm_execlp SCM_P ((SCM args)); +extern SCM scm_execl SCM_P ((SCM filename, SCM args)); +extern SCM scm_execlp SCM_P ((SCM filename, SCM args)); +extern SCM scm_execle SCM_P ((SCM filename, SCM env, SCM args)); extern SCM scm_fork SCM_P ((void)); extern SCM scm_uname SCM_P ((void)); extern SCM scm_environ SCM_P ((SCM env)); diff --git a/libguile/stime.c b/libguile/stime.c index eee6271ee..fa2919281 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -160,6 +160,29 @@ scm_get_internal_real_time() } #endif +SCM_PROC (s_times, "times", 0, 0, 0, scm_times); +SCM +scm_times (void) +{ +#ifdef HAVE_TIMES + struct tms t; + clock_t rv; + + SCM result = scm_make_vector (SCM_MAKINUM(5), SCM_UNDEFINED, SCM_UNDEFINED); + rv = times (&t); + if (rv == -1) + scm_syserror (s_times); + SCM_VELTS (result)[0] = scm_long2num (rv); + SCM_VELTS (result)[1] = scm_long2num (t.tms_utime); + SCM_VELTS (result)[2] = scm_long2num (t.tms_stime); + SCM_VELTS (result)[3] = scm_long2num (t.tms_cutime); + SCM_VELTS (result)[4] = scm_long2num (t.tms_cstime); + return result; +#else + scm_sysmissing (s_times); +#endif +} + #ifndef HAVE_TZSET /* GNU-WIN32's cygwin.dll doesn't have this. */ #define tzset() diff --git a/libguile/stime.h b/libguile/stime.h index 9d5ea0d4e..e2cf5dbac 100644 --- a/libguile/stime.h +++ b/libguile/stime.h @@ -55,6 +55,7 @@ extern SCM scm_localtime (SCM time, SCM zone); extern SCM scm_gmtime (SCM time); extern SCM scm_mktime (SCM sbd_time, SCM zone); extern SCM scm_tzset (void); +extern SCM scm_times (void); extern SCM scm_strftime SCM_P ((SCM format, SCM stime)); extern SCM scm_strptime SCM_P ((SCM format, SCM string)); extern void scm_init_stime SCM_P ((void));