mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

make C system primitives throw exceptions

Browse source
This commit is contained in:
Gary Houston 1996-08-02 23:26:33 +00:00
parent cb0016401f
commit 02b754d3a6
10 changed files with 415 additions and 454 deletions
Download patch file Download diff file Expand all files Collapse all files

11
ice-9/ChangeLog
View file

@ -5,6 +5,17 @@ Thu Aug 1 02:52:42 1996 Jim Blandy <jimb@totoro.cyclic.com>
* PLUGIN/this.configure (aux_files): Removed PLUGIN; it's a * PLUGIN/this.configure (aux_files): Removed PLUGIN; it's a
directory, and needs special treatment in the dist-dir target. directory, and needs special treatment in the dist-dir target.
Thu Aug 1 09:00:21 1996 Gary Houston <ghouston@actrix.gen.nz>
* boot-9.scm: remove the wrappers for '%' system primitives,
now that they throw errors directly.
remove make-simple-wrapper and similar functions.
protect a call to getenv which may now throw an exception.
Wed Jul 31 23:44:42 1996 Gary Houston <ghouston@actrix.gen.nz>
* boot-9.scm (false-if-exception): new macro.
Fri Apr 19 13:53:08 1996 Tom Lord <lord@beehive> Fri Apr 19 13:53:08 1996 Tom Lord <lord@beehive>
* The more things change... * The more things change...

170
ice-9/boot-9.scm
View file

@ -702,31 +702,6 @@
(define ((make-simple-wrapper func) . args)
(or (apply func args)
(apply throw 'syserror func (errno) args)))
(define ((make-eof-wrapper func) . args)
(let ((rv (apply func args)))
(if (eof-object? rv)
(apply throw 'syserror func (errno) args)
rv)))
(define ((make-errno-wrapper func) . args)
(let ((rv (apply func args)))
(if (number? rv)
(apply throw 'syserror func rv args)
rv)))
(define ((make-errpair-wrapper func) . args)
(let ((rv (apply func args)))
(if (and (pair? rv)
(number? (car rv))
(null? (cdr rv)))
(apply throw 'syserror func (car rv) args)
rv)))
(begin (begin
(define (syserror key fn err . args) (define (syserror key fn err . args)
(errno err) (errno err)
@ -734,18 +709,18 @@
(set-symbol-property! 'syserror 'throw-handler-default syserror)) (set-symbol-property! 'syserror 'throw-handler-default syserror))
(define (%getgrnam name) (%getgr name)) (define (getgrnam name) (getgr name))
(define (%getgrgid id) (%getgr id)) (define (getgrgid id) (getgr id))
(define (%gethostbyaddr addr) (%gethost addr)) (define (gethostbyaddr addr) (gethost addr))
(define (%gethostbyname name) (%gethost name)) (define (gethostbyname name) (gethost name))
(define (%getnetbyaddr addr) (%getnet addr)) (define (getnetbyaddr addr) (getnet addr))
(define (%getnetbyname name) (%getnet name)) (define (getnetbyname name) (getnet name))
(define (%getprotobyname name) (%getproto name)) (define (getprotobyname name) (getproto name))
(define (%getprotobynumber addr) (%getproto addr)) (define (getprotobynumber addr) (getproto addr))
(define (%getpwnam name) (%getpw name)) (define (getpwnam name) (getpw name))
(define (%getpwuid uid) (%getpw uid)) (define (getpwuid uid) (getpw uid))
(define (%getservbyname name proto) (%getserv name proto)) (define (getservbyname name proto) (%getserv name proto))
(define (%getservbyport port proto) (%getserv port proto)) (define (getservbyport port proto) (%getserv port proto))
(define (endgrent) (setgr)) (define (endgrent) (setgr))
(define (endhostent) (sethost)) (define (endhostent) (sethost))
(define (endnetent) (setnet)) (define (endnetent) (setnet))
@ -754,12 +729,12 @@
(define (endservent) (setserv)) (define (endservent) (setserv))
(define (file-position . args) (apply ftell args)) (define (file-position . args) (apply ftell args))
(define (file-set-position . args) (apply fseek args)) (define (file-set-position . args) (apply fseek args))
(define (getgrent) (%getgr)) (define (getgrent) (getgr))
(define (gethostent) (%gethost)) (define (gethostent) (gethost))
(define (getnetent) (%getnet)) (define (getnetent) (getnet))
(define (getprotoent) (%getproto)) (define (getprotoent) (getproto))
(define (getpwent) (%getpw)) (define (getpwent) (getpw))
(define (getservent) (%getserv)) (define (getservent) (getserv))
(define (reopen-file . args) (apply freopen args)) (define (reopen-file . args) (apply freopen args))
(define (setgrent arg) (setgr arg)) (define (setgrent arg) (setgr arg))
(define (sethostent arg) (sethost arg)) (define (sethostent arg) (sethost arg))
@ -767,96 +742,9 @@
(define (setprotoent arg) (setproto arg)) (define (setprotoent arg) (setproto arg))
(define (setpwent arg) (setpw arg)) (define (setpwent arg) (setpw arg))
(define (setservent arg) (setserv arg)) (define (setservent arg) (setserv arg))
(define (%move->fdes port fd) (define (move->fdes port fd)
(if (= 1 (primitive-move->fdes port fd)) (if (= 1 (primitive-move->fdes port fd))
(set-port-revealed! port 1) (set-port-revealed! port 1)))
#t))
(define accept (make-errno-wrapper %accept))
(define bind (make-errno-wrapper %bind))
(define chdir (make-errno-wrapper %chdir))
(define chmod (make-errno-wrapper %chmod))
(define chown (make-errno-wrapper %chown))
(define close (make-errno-wrapper %close))
(define closedir (make-errno-wrapper %closedir))
(define connect (make-errno-wrapper %connect))
(define copy-file (make-simple-wrapper %copy-file))
(define ctermid (make-simple-wrapper %ctermid))
(define delete-file (make-errno-wrapper %delete-file))
(define duplicate-port (make-simple-wrapper %duplicate-port))
(define execl (make-errno-wrapper %execl))
(define execlp (make-errno-wrapper %execlp))
(define fdopen (make-errno-wrapper %fdopen))
(define fileno (make-simple-wrapper %fileno))
(define fork (make-simple-wrapper %fork))
(define freopen (make-errno-wrapper %freopen))
(define fseek (make-errno-wrapper %fseek))
(define ftell (make-errno-wrapper %ftell))
(define getcwd (make-errno-wrapper %getcwd))
(define getenv (make-simple-wrapper %getenv))
(define getgrgid (make-errno-wrapper %getgrgid))
(define getgrnam (make-errno-wrapper %getgrnam))
(define getgroups (make-errno-wrapper %getgroups))
(define gethostbyaddr (make-simple-wrapper %gethostbyaddr))
(define gethost (make-simple-wrapper %gethost))
(define gethostbyname (make-simple-wrapper %gethostbyname))
(define getnetbyaddr (make-simple-wrapper %getnetbyaddr))
(define getnetbyname (make-simple-wrapper %getnetbyname))
(define getpeername (make-errno-wrapper %getpeername))
(define getprotobyname (make-simple-wrapper %getprotobyname))
(define getprotobynumber (make-simple-wrapper %getprotobynumber))
(define getpwnam (make-simple-wrapper %getpwnam))
(define getpwuid (make-simple-wrapper %getpwuid))
(define getservbyname (make-simple-wrapper %getservbyname))
(define getservbyport (make-simple-wrapper %getservbyport))
(define getsockname (make-errno-wrapper %getsockname))
(define getsockopt (make-errpair-wrapper %getsockopt))
(define inet-aton (make-simple-wrapper %inet-aton))
(define isatty? (make-errno-wrapper %isatty?))
(define kill (make-errno-wrapper %kill))
(define link (make-errno-wrapper %link))
(define listen (make-errno-wrapper %listen))
(define lstat (make-errno-wrapper %lstat))
(define mkdir (make-errno-wrapper %mkdir))
(define mknod (make-errno-wrapper %mknod))
(define nice (make-errno-wrapper %nice))
(define opendir (make-errno-wrapper %opendir))
(define pipe (make-errno-wrapper %pipe))
(define primitive-move->fdes (make-simple-wrapper %primitive-move->fdes))
(define putenv (make-errno-wrapper %putenv))
(define read-fd (make-errpair-wrapper %read-fd))
(define readdir (make-errno-wrapper %readdir))
(define readlink (make-errno-wrapper %readlink))
(define recv (make-errno-wrapper %recv))
(define recvfrom (make-errno-wrapper %recvfrom))
(define redirect-port (make-errno-wrapper %redirect-port))
(define rename-file (make-errno-wrapper %rename-file))
(define rmdir (make-errno-wrapper %rmdir))
(define select (make-errno-wrapper %select))
(define send (make-errpair-wrapper %send))
(define sendto (make-errpair-wrapper %sendto))
(define setegid (make-errno-wrapper %setegid))
(define seteuid (make-errno-wrapper %seteuid))
(define setgid (make-errno-wrapper %setgid))
(define setlocale (make-errno-wrapper %setlocale))
(define setpgid (make-errno-wrapper %setpgid))
(define setsid (make-simple-wrapper %setsid))
(define setsockopt (make-errno-wrapper %setsockopt))
(define setuid (make-errno-wrapper %setuid))
(define shutdown (make-errno-wrapper %shutdown))
(define socket (make-errno-wrapper %socket))
(define socketpair (make-errno-wrapper %socketpair))
(define stat (make-errno-wrapper %stat))
(define strptime (make-simple-wrapper %strptime))
(define symlink (make-simple-wrapper %symlink))
(define tcgetpgrp (make-simple-wrapper %tcgetpgrp))
(define tcsetpgrp (make-simple-wrapper %tcsetpgrp))
(define ttyname (make-errno-wrapper %ttyname))
(define uname (make-errno-wrapper %uname))
(define utime (make-errno-wrapper %utime))
(define waitpid (make-errno-wrapper %waitpid))
(define write-fd (make-errpair-wrapper %write-fd))
(define move->fdes (make-simple-wrapper %move->fdes))
;;; {Load Paths} ;;; {Load Paths}
@ -887,11 +775,15 @@
path))))) path)))))
(#t '()))) (#t '())))
(define %load-path (append (parse-path (%getenv "SCHEME_LOAD_PATH")) ;;; we don't have false-if-exception (or defmacro) yet.
(list "" (define %load-path
(in-vicinity (implementation-vicinity) "gls/guile/") (let ((lp (catch #t (lambda () (getenv "SCHEME_LOAD_PATH"))
(in-vicinity (implementation-vicinity) "gls/") (lambda args #f))))
(in-vicinity (implementation-vicinity) "slib/")))) (append (parse-path lp)
(list ""
(in-vicinity (implementation-vicinity) "gls/guile/")
(in-vicinity (implementation-vicinity) "gls/")
(in-vicinity (implementation-vicinity) "slib/")))))
;;; {try-load} ;;; {try-load}
;;; ;;;
@ -2469,6 +2361,10 @@
(define (top-repl) (scm-style-repl)) (define (top-repl) (scm-style-repl))
(defmacro false-if-exception (expr)
`(catch #t (lambda () ,expr)
(lambda args #f)))
(define-module (ice-9 calling)) (define-module (ice-9 calling))

15
libguile/ChangeLog
View file

@ -17,6 +17,21 @@ Thu Aug 1 02:58:39 1996 Jim Blandy <jimb@totoro.cyclic.com>
every if must have an else, or else the whole command has a every if must have an else, or else the whole command has a
non-zero exit code whenever the if's condition is false. non-zero exit code whenever the if's condition is false.
Thu Aug 1 08:22:24 1996 Gary Houston <ghouston@actrix.gen.nz>
* posix.c: include string.h.
Wed Jul 31 23:43:05 1996 Gary Houston <ghouston@actrix.gen.nz>
* numbers.c: rename %expt -> $expt, %atan2 -> $atan2, as it must
have been once.
* posix.c, ioext.c, socket.c, fdsocket.c, files.c, filesys.c, simpos.c:
Remove leading % from scheme names.
Do not return error values, call SCM_SYSERROR or similar.
* __scm.h (SCM_SYSERROR, SCM_SYSMISSING): new macros.
Wed Jun 12 00:28:31 1996 Tom Lord <lord@beehive> Wed Jun 12 00:28:31 1996 Tom Lord <lord@beehive>
* struct.c (scm_init_struct): new file. * struct.c (scm_init_struct): new file.

12
libguile/__scm.h
View file

@ -285,7 +285,19 @@ extern unsigned int scm_async_clock;
if (!(_cond)) \ if (!(_cond)) \
goto _label goto _label
#endif #endif
#define SCM_SYSERROR(_subr) \
scm_everr (SCM_UNDEFINED, SCM_EOL, SCM_UNDEFINED, \
strerror (errno), _subr)
/* equivalent to:
scm_throw (system_error_sym, \
scm_listify (scm_makfrom0str (strerror (errno)), \
scm_makfrom0str (_subr), \
SCM_UNDEFINED));
*/
#define SCM_SYSMISSING(_subr) \
scm_everr (SCM_UNDEFINED, SCM_EOL, SCM_UNDEFINED, \
strerror (ENOSYS), _subr)
#define SCM_ARGn 0 #define SCM_ARGn 0
#define SCM_ARG1 1 #define SCM_ARG1 1

254
libguile/filesys.c
View file

@ -143,7 +143,7 @@ SCM_CONST_LONG (scm_O_SYNC, "O_SYNC", O_SYNC);
/* {Permissions} /* {Permissions}
*/ */
SCM_PROC (s_sys_chown, "%chown", 3, 0, 0, scm_sys_chown); SCM_PROC (s_sys_chown, "chown", 3, 0, 0, scm_sys_chown);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_chown (SCM path, SCM owner, SCM group) scm_sys_chown (SCM path, SCM owner, SCM group)
@ -156,17 +156,21 @@ scm_sys_chown (path, owner, group)
#endif #endif
{ {
int val; int val;
SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_chown); SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_chown);
if (SCM_SUBSTRP (path)) if (SCM_SUBSTRP (path))
path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
SCM_ASSERT (SCM_INUMP (owner), owner, SCM_ARG2, s_sys_chown); SCM_ASSERT (SCM_INUMP (owner), owner, SCM_ARG2, s_sys_chown);
SCM_ASSERT (SCM_INUMP (group), group, SCM_ARG3, s_sys_chown); SCM_ASSERT (SCM_INUMP (group), group, SCM_ARG3, s_sys_chown);
SCM_SYSCALL (val = chown (SCM_ROCHARS (path), SCM_INUM (owner), SCM_INUM (group))); SCM_SYSCALL (val = chown (SCM_ROCHARS (path),
return val ? SCM_MAKINUM (errno) : SCM_BOOL_T; SCM_INUM (owner), SCM_INUM (group)));
if (val != 0)
SCM_SYSERROR (s_sys_chown);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_sys_chmod, "%chmod", 2, 0, 0, scm_sys_chmod); SCM_PROC (s_sys_chmod, "chmod", 2, 0, 0, scm_sys_chmod);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_chmod (SCM port_or_path, SCM mode) scm_sys_chmod (SCM port_or_path, SCM mode)
@ -189,7 +193,9 @@ scm_sys_chmod (port_or_path, mode)
if (rv != -1) if (rv != -1)
SCM_SYSCALL (rv = fchmod (rv, SCM_INUM (mode))); SCM_SYSCALL (rv = fchmod (rv, SCM_INUM (mode)));
} }
return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (rv != 0)
SCM_SYSERROR (s_sys_chmod);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_umask, "umask", 0, 1, 0, scm_umask); SCM_PROC (s_umask, "umask", 0, 1, 0, scm_umask);
@ -280,7 +286,7 @@ scm_intern_fd (fd, flags)
SCM_PROC (s_sys_open, "%open", 3, 0, 0, scm_sys_open); SCM_PROC (s_sys_open, "open", 3, 0, 0, scm_sys_open);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_open (SCM path, SCM flags, SCM mode) scm_sys_open (SCM path, SCM flags, SCM mode)
@ -305,16 +311,15 @@ scm_sys_open (path, flags, mode)
SCM_DEFER_INTS; SCM_DEFER_INTS;
SCM_SYSCALL ( fd = open (SCM_ROCHARS (path), SCM_INUM (flags), SCM_INUM (mode)) ); SCM_SYSCALL ( fd = open (SCM_ROCHARS (path), SCM_INUM (flags), SCM_INUM (mode)) );
if (fd == -1) if (fd == -1)
sfd = SCM_MAKINUM (errno); SCM_SYSERROR (s_sys_open);
else sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc);
sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return scm_return_first (sfd, path); return scm_return_first (sfd, path);
} }
SCM_PROC (s_sys_create, "%create", 2, 0, 0, scm_sys_create); SCM_PROC (s_sys_create, "create", 2, 0, 0, scm_sys_create);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_create (SCM path, SCM mode) scm_sys_create (SCM path, SCM mode)
@ -337,16 +342,15 @@ scm_sys_create (path, mode)
SCM_DEFER_INTS; SCM_DEFER_INTS;
SCM_SYSCALL ( fd = creat (SCM_ROCHARS (path), SCM_INUM (mode)) ); SCM_SYSCALL ( fd = creat (SCM_ROCHARS (path), SCM_INUM (mode)) );
if (fd == -1) if (fd == -1)
sfd = SCM_MAKINUM (errno); SCM_SYSERROR (s_sys_create);
else sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc);
sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return scm_return_first (sfd, path); return scm_return_first (sfd, path);
} }
SCM_PROC (s_sys_close, "%close", 1, 0, 0, scm_sys_close); SCM_PROC (s_sys_close, "close", 1, 0, 0, scm_sys_close);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_close (SCM sfd) scm_sys_close (SCM sfd)
@ -365,11 +369,13 @@ scm_sys_close (sfd)
got = close (fd); got = close (fd);
SCM_SETCAR (sfd, scm_tc16_fd); SCM_SETCAR (sfd, scm_tc16_fd);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return (got == -1 ? SCM_MAKINUM (errno) : SCM_BOOL_T); if (got == -1)
SCM_SYSERROR (s_sys_close);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_sys_write_fd, "%write-fd", 2, 0, 0, scm_sys_write_fd); SCM_PROC (s_sys_write_fd, "write-fd", 2, 0, 0, scm_sys_write_fd);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_write_fd (SCM sfd, SCM buf) scm_sys_write_fd (SCM sfd, SCM buf)
@ -389,15 +395,14 @@ scm_sys_write_fd (sfd, buf)
SCM_DEFER_INTS; SCM_DEFER_INTS;
written = write (fd, SCM_ROCHARS (buf), SCM_ROLENGTH (buf)); written = write (fd, SCM_ROCHARS (buf), SCM_ROLENGTH (buf));
if (written == -1) if (written == -1)
answer = scm_cons (SCM_MAKINUM (errno), SCM_EOL); SCM_SYSERROR (s_sys_write_fd);
else answer = scm_long2num (written);
answer = scm_long2num (written);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return scm_return_first (answer, buf); return scm_return_first (answer, buf);
} }
SCM_PROC (s_sys_read_fd, "%read-fd", 2, 2, 0, scm_sys_read_fd); SCM_PROC (s_sys_read_fd, "read-fd", 2, 2, 0, scm_sys_read_fd);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_read_fd (SCM sfd, SCM buf, SCM offset, SCM length) scm_sys_read_fd (SCM sfd, SCM buf, SCM offset, SCM length)
@ -442,14 +447,13 @@ scm_sys_read_fd (sfd, buf, offset, length)
SCM_DEFER_INTS; SCM_DEFER_INTS;
got = read (fd, bytes + off, len); got = read (fd, bytes + off, len);
if (got == -1) if (got == -1)
answer = scm_cons (SCM_MAKINUM (errno), SCM_EOL); SCM_SYSERROR (s_sys_read_fd);
else answer = scm_long2num (got);
answer = scm_long2num (got);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return scm_return_first (answer, buf); return scm_return_first (answer, buf);
} }
SCM_PROC (s_sys_lseek, "%lseek", 2, 1, 0, scm_sys_lseek); SCM_PROC (s_sys_lseek, "lseek", 2, 1, 0, scm_sys_lseek);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_lseek (SCM sfd, SCM offset, SCM whence) scm_sys_lseek (SCM sfd, SCM offset, SCM whence)
@ -482,15 +486,14 @@ scm_sys_lseek (sfd, offset, whence)
SCM_DEFER_INTS; SCM_DEFER_INTS;
SCM_SYSCALL (got = lseek (fd, off, wh)); SCM_SYSCALL (got = lseek (fd, off, wh));
if (got == -1) if (got == -1)
answer = SCM_MAKINUM (errno); SCM_SYSERROR (s_sys_lseek);
else answer = scm_long2num (got);
answer = scm_long2num (got);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return answer; return answer;
} }
SCM_PROC (s_sys_dup, "%dup", 1, 1, 0, scm_sys_dup); SCM_PROC (s_sys_dup, "dup", 1, 1, 0, scm_sys_dup);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_dup (SCM oldfd, SCM newfd) scm_sys_dup (SCM oldfd, SCM newfd)
@ -514,9 +517,9 @@ scm_sys_dup (oldfd, newfd)
SCM_DEFER_INTS; SCM_DEFER_INTS;
fn = ((nfd == -1) ? (int (*)())dup : (int (*)())dup2); fn = ((nfd == -1) ? (int (*)())dup : (int (*)())dup2);
nfd = fn (fd, nfd); nfd = fn (fd, nfd);
answer = (nfd == -1 if (nfd == -1)
? scm_cons (SCM_MAKINUM (errno), SCM_EOL) SCM_SYSERROR (s_sys_dup);
: SCM_MAKINUM (nfd)); answer = SCM_MAKINUM (nfd);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return answer; return answer;
} }
@ -565,7 +568,7 @@ scm_stat2scm (stat_temp)
return ans; return ans;
} }
SCM_PROC (s_sys_stat, "%stat", 1, 0, 0, scm_sys_stat); SCM_PROC (s_sys_stat, "stat", 1, 0, 0, scm_sys_stat);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_stat (SCM fd_or_path) scm_sys_stat (SCM fd_or_path)
@ -601,7 +604,9 @@ scm_sys_stat (fd_or_path)
} }
} }
return rv ? SCM_MAKINUM (errno) : scm_stat2scm (&stat_temp); if (rv != 0)
SCM_SYSERROR (s_sys_stat);
return scm_stat2scm (&stat_temp);
} }
@ -609,7 +614,7 @@ scm_sys_stat (fd_or_path)
/* {Modifying Directories} /* {Modifying Directories}
*/ */
SCM_PROC (s_sys_link, "%link", 2, 0, 0, scm_sys_link); SCM_PROC (s_sys_link, "link", 2, 0, 0, scm_sys_link);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_link (SCM oldpath, SCM newpath) scm_sys_link (SCM oldpath, SCM newpath)
@ -621,6 +626,7 @@ scm_sys_link (oldpath, newpath)
#endif #endif
{ {
int val; int val;
SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1, s_sys_link); SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1, s_sys_link);
if (SCM_SUBSTRP (oldpath)) if (SCM_SUBSTRP (oldpath))
oldpath = scm_makfromstr (SCM_ROCHARS (oldpath), SCM_ROLENGTH (oldpath), 0); oldpath = scm_makfromstr (SCM_ROCHARS (oldpath), SCM_ROLENGTH (oldpath), 0);
@ -628,12 +634,14 @@ scm_sys_link (oldpath, newpath)
if (SCM_SUBSTRP (newpath)) 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_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath))); SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath)));
return val ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (val != 0)
SCM_SYSERROR (s_sys_link);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_sys_rename, "%rename-file", 2, 0, 0, scm_sys_rename); SCM_PROC (s_sys_rename, "rename-file", 2, 0, 0, scm_sys_rename);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_rename (SCM oldname, SCM newname) scm_sys_rename (SCM oldname, SCM newname)
@ -649,25 +657,29 @@ scm_sys_rename (oldname, newname)
SCM_ASSERT (SCM_NIMP (newname) && SCM_STRINGP (newname), newname, SCM_ARG2, s_sys_rename); SCM_ASSERT (SCM_NIMP (newname) && SCM_STRINGP (newname), newname, SCM_ARG2, s_sys_rename);
#ifdef HAVE_RENAME #ifdef HAVE_RENAME
SCM_SYSCALL (rv = rename (SCM_CHARS (oldname), SCM_CHARS (newname))); SCM_SYSCALL (rv = rename (SCM_CHARS (oldname), SCM_CHARS (newname)));
return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (rv != 0)
SCM_SYSERROR (s_sys_rename);
return SCM_UNSPECIFIED;
#else #else
SCM_DEFER_INTS; SCM_DEFER_INTS;
SCM_SYSCALL (rv = link (SCM_CHARS (oldname), SCM_CHARS (newname))); SCM_SYSCALL (rv = link (SCM_CHARS (oldname), SCM_CHARS (newname)));
if (!rv) if (rv == 0)
{ {
SCM_SYSCALL (rv = unlink (SCM_CHARS (oldname)));; SCM_SYSCALL (rv = unlink (SCM_CHARS (oldname)));;
if (rv) if (rv != 0)
/* unlink failed. remove new name */ /* unlink failed. remove new name */
SCM_SYSCALL (unlink (SCM_CHARS (newname))); SCM_SYSCALL (unlink (SCM_CHARS (newname)));
} }
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (rv != 0)
SCM_SYSERROR (s_sys_rename);
return SCM_UNSPECIFIED;
#endif #endif
} }
SCM_PROC (s_sys_mkdir, "%mkdir", 1, 1, 0, scm_sys_mkdir); SCM_PROC (s_sys_mkdir, "mkdir", 1, 1, 0, scm_sys_mkdir);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_mkdir (SCM path, SCM mode) scm_sys_mkdir (SCM path, SCM mode)
@ -693,14 +705,18 @@ scm_sys_mkdir (path, mode)
SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_mkdir); SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_mkdir);
SCM_SYSCALL (rv = mkdir (SCM_CHARS (path), SCM_INUM (mode))); SCM_SYSCALL (rv = mkdir (SCM_CHARS (path), SCM_INUM (mode)));
} }
return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (rv != 0)
SCM_SYSERROR (s_sys_mkdir);
return SCM_UNSPECIFIED;
#else #else
return SCM_MAKINUM (ENOSYS); SCM_SYSMISSING (s_sys_mkdir);
/* not reached. */
return SCM_BOOL_F;
#endif #endif
} }
SCM_PROC (s_sys_rmdir, "%rmdir", 1, 0, 0, scm_sys_rmdir); SCM_PROC (s_sys_rmdir, "rmdir", 1, 0, 0, scm_sys_rmdir);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_rmdir (SCM path) scm_sys_rmdir (SCM path)
@ -712,11 +728,16 @@ scm_sys_rmdir (path)
{ {
#ifdef HAVE_RMDIR #ifdef HAVE_RMDIR
int val; int val;
SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_sys_rmdir); SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_sys_rmdir);
SCM_SYSCALL (val = rmdir (SCM_CHARS (path))); SCM_SYSCALL (val = rmdir (SCM_CHARS (path)));
return val ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (val != 0)
SCM_SYSERROR (s_sys_rmdir);
return SCM_UNSPECIFIED;
#else #else
return SCM_MAKINUM (ENOSYS); SCM_SYSMISSING (s_sys_rmdir);
/* not reached. */
return SCM_BOOL_F;
#endif #endif
} }
@ -726,7 +747,7 @@ scm_sys_rmdir (path)
long scm_tc16_dir; long scm_tc16_dir;
SCM_PROC (s_sys_opendir, "%opendir", 1, 0, 0, scm_sys_opendir); SCM_PROC (s_sys_opendir, "opendir", 1, 0, 0, scm_sys_opendir);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_opendir (SCM dirname) scm_sys_opendir (SCM dirname)
@ -742,11 +763,8 @@ scm_sys_opendir (dirname)
SCM_NEWCELL (dir); SCM_NEWCELL (dir);
SCM_DEFER_INTS; SCM_DEFER_INTS;
SCM_SYSCALL (ds = opendir (SCM_CHARS (dirname))); SCM_SYSCALL (ds = opendir (SCM_CHARS (dirname)));
if (!ds) if (ds == NULL)
{ SCM_SYSERROR (s_sys_opendir);
SCM_ALLOW_INTS;
return SCM_MAKINUM (errno);
}
SCM_CAR (dir) = scm_tc16_dir | SCM_OPN; SCM_CAR (dir) = scm_tc16_dir | SCM_OPN;
SCM_SETCDR (dir, ds); SCM_SETCDR (dir, ds);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
@ -754,7 +772,7 @@ scm_sys_opendir (dirname)
} }
SCM_PROC (s_sys_readdir, "%readdir", 1, 0, 0, scm_sys_readdir); SCM_PROC (s_sys_readdir, "readdir", 1, 0, 0, scm_sys_readdir);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_readdir (SCM port) scm_sys_readdir (SCM port)
@ -770,9 +788,10 @@ scm_sys_readdir (port)
errno = 0; errno = 0;
SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CDR (port))); SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CDR (port)));
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return (rdent if (errno != 0)
? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0) SCM_SYSERROR (s_sys_readdir);
: (errno ? SCM_MAKINUM (errno) : SCM_EOF_VAL)); return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0)
: SCM_EOF_VAL);
} }
@ -794,7 +813,7 @@ scm_rewinddir (port)
SCM_PROC (s_sys_closedir, "%closedir", 1, 0, 0, scm_sys_closedir); SCM_PROC (s_sys_closedir, "closedir", 1, 0, 0, scm_sys_closedir);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_closedir (SCM port) scm_sys_closedir (SCM port)
@ -805,22 +824,20 @@ scm_sys_closedir (port)
#endif #endif
{ {
int sts; int sts;
SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, SCM_ARG1, s_sys_closedir); SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, SCM_ARG1, s_sys_closedir);
SCM_DEFER_INTS; SCM_DEFER_INTS;
if (SCM_CLOSEDP (port)) if (SCM_CLOSEDP (port))
{ {
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return SCM_MAKINUM (errno); return SCM_UNSPECIFIED;
} }
SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port))); SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port)));
if (sts) if (sts != 0)
{ SCM_SYSERROR (s_sys_closedir);
SCM_ALLOW_INTS;
return SCM_MAKINUM (errno);
}
SCM_CAR (port) = scm_tc16_dir; SCM_CAR (port) = scm_tc16_dir;
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return SCM_BOOL_T; return SCM_UNSPECIFIED;
} }
@ -861,7 +878,7 @@ static scm_smobfuns dir_smob = {scm_mark0, scm_dir_free, scm_dir_print, 0};
*/ */
SCM_PROC (s_sys_chdir, "%chdir", 1, 0, 0, scm_sys_chdir); SCM_PROC (s_sys_chdir, "chdir", 1, 0, 0, scm_sys_chdir);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_chdir (SCM str) scm_sys_chdir (SCM str)
@ -872,14 +889,17 @@ scm_sys_chdir (str)
#endif #endif
{ {
int ans; int ans;
SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_chdir); SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_chdir);
SCM_SYSCALL (ans = chdir (SCM_CHARS (str))); SCM_SYSCALL (ans = chdir (SCM_CHARS (str)));
return ans ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (ans != 0)
SCM_SYSERROR (s_sys_chdir);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_sys_getcwd, "%getcwd", 0, 0, 0, scm_sys_getcwd); SCM_PROC (s_sys_getcwd, "getcwd", 0, 0, 0, scm_sys_getcwd);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_getcwd (void) scm_sys_getcwd (void)
@ -903,15 +923,16 @@ scm_sys_getcwd ()
size *= 2; size *= 2;
wd = scm_must_malloc (size, s_sys_getcwd); wd = scm_must_malloc (size, s_sys_getcwd);
} }
if (rv != 0) if (rv == 0)
result = scm_makfromstr (wd, strlen (wd), 0); SCM_SYSERROR (s_sys_getcwd);
else result = scm_makfromstr (wd, strlen (wd), 0);
result = SCM_MAKINUM (errno);
scm_must_free (wd); scm_must_free (wd);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return result; return result;
#else #else
return SCM_MAKINUM (ENOSYS); SCM_SYSMISSING (s_sys_getcwd);
/* not reached. */
return SCM_BOOL_F;
#endif #endif
} }
@ -978,7 +999,7 @@ retrieve_select_type (set, list)
} }
SCM_PROC (s_sys_select, "%select", 3, 2, 0, scm_sys_select); SCM_PROC (s_sys_select, "select", 3, 2, 0, scm_sys_select);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_select (SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs) scm_sys_select (SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs)
@ -1032,14 +1053,15 @@ scm_sys_select (reads, writes, excepts, secs, msecs)
&read_set, &write_set, &except_set, time_p); &read_set, &write_set, &except_set, time_p);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
if (sreturn < 0) if (sreturn < 0)
return SCM_MAKINUM (errno); SCM_SYSERROR (s_sys_select);
else return scm_listify (retrieve_select_type (&read_set, reads),
return scm_listify (retrieve_select_type (&read_set, reads), retrieve_select_type (&write_set, writes),
retrieve_select_type (&write_set, writes), retrieve_select_type (&except_set, excepts),
retrieve_select_type (&except_set, excepts), SCM_UNDEFINED);
SCM_UNDEFINED);
#else #else
return SCM_MAKINUM (ENOSYS); SCM_SYSMISSING (s_sys_select);
/* not reached. */
return SCM_BOOL_F;
#endif #endif
} }
@ -1047,7 +1069,7 @@ scm_sys_select (reads, writes, excepts, secs, msecs)
/* {Symbolic Links} /* {Symbolic Links}
*/ */
SCM_PROC (s_sys_symlink, "%symlink", 2, 0, 0, scm_sys_symlink); SCM_PROC (s_sys_symlink, "symlink", 2, 0, 0, scm_sys_symlink);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_symlink(SCM oldpath, SCM newpath) scm_sys_symlink(SCM oldpath, SCM newpath)
@ -1060,17 +1082,22 @@ scm_sys_symlink(oldpath, newpath)
{ {
#ifdef HAVE_SYMLINK #ifdef HAVE_SYMLINK
int val; int val;
SCM_ASSERT(SCM_NIMP(oldpath) && SCM_STRINGP(oldpath), oldpath, SCM_ARG1, s_sys_symlink); SCM_ASSERT(SCM_NIMP(oldpath) && SCM_STRINGP(oldpath), oldpath, SCM_ARG1, s_sys_symlink);
SCM_ASSERT(SCM_NIMP(newpath) && SCM_STRINGP(newpath), newpath, SCM_ARG2, s_sys_symlink); SCM_ASSERT(SCM_NIMP(newpath) && SCM_STRINGP(newpath), newpath, SCM_ARG2, s_sys_symlink);
SCM_SYSCALL(val = symlink(SCM_CHARS(oldpath), SCM_CHARS(newpath))); SCM_SYSCALL (val = symlink(SCM_CHARS(oldpath), SCM_CHARS(newpath)));
return val ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (val != 0)
SCM_SYSERROR (s_sys_symlink);
return SCM_UNSPECIFIED;
#else #else
return SCM_MAKINUM (ENOSYS); SCM_SYSMISSING (s_sys_symlink);
/* not reached. */
return SCM_BOOL_F;
#endif #endif
} }
SCM_PROC (s_sys_readlink, "%readlink", 1, 0, 0, scm_sys_readlink); SCM_PROC (s_sys_readlink, "readlink", 1, 0, 0, scm_sys_readlink);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_readlink(SCM path) scm_sys_readlink(SCM path)
@ -1094,20 +1121,21 @@ scm_sys_readlink(path)
size *= 2; size *= 2;
buf = scm_must_malloc (size, s_sys_readlink); buf = scm_must_malloc (size, s_sys_readlink);
} }
if (rv != -1) if (rv == -1)
result = scm_makfromstr (buf, rv, 0); SCM_SYSERROR (s_sys_readlink);
else result = scm_makfromstr (buf, rv, 0);
result = SCM_MAKINUM (errno);
scm_must_free (buf); scm_must_free (buf);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return result; return result;
#else #else
return SCM_MAKINUM (ENOSYS); SCM_SYSMISSING (s_sys_readlink);
/* not reached. */
return SCM_BOOL_F;
#endif #endif
} }
SCM_PROC (s_sys_lstat, "%lstat", 1, 0, 0, scm_sys_lstat); SCM_PROC (s_sys_lstat, "lstat", 1, 0, 0, scm_sys_lstat);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_lstat(SCM str) scm_sys_lstat(SCM str)
@ -1117,19 +1145,24 @@ scm_sys_lstat(str)
SCM str; SCM str;
#endif #endif
{ {
#ifdef HAVE_LSTATE #ifdef HAVE_LSTAT
int i; int rv;
struct stat stat_temp; struct stat stat_temp;
SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, (char *)SCM_ARG1, s_sys_lstat); SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, (char *)SCM_ARG1, s_sys_lstat);
SCM_SYSCALL(i = lstat(SCM_CHARS(str), &stat_temp)); SCM_SYSCALL(rv = lstat(SCM_CHARS(str), &stat_temp));
return i ? SCM_MAKINUM (errno) : scm_stat2scm(&stat_temp); if (rv != 0)
SCM_SYSERROR (s_sys_lstat);
return scm_stat2scm(&stat_temp);
#else #else
return SCM_MAKINUM (ENOSYS); SCM_SYSMISSING (s_sys_lstat);
/* not reached. */
return SCM_BOOL_F;
#endif #endif
} }
SCM_PROC (s_sys_copy_file, "%copy-file", 2, 0, 0, scm_sys_copy_file); SCM_PROC (s_sys_copy_file, "copy-file", 2, 0, 0, scm_sys_copy_file);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_copy_file (SCM oldfile, SCM newfile) scm_sys_copy_file (SCM oldfile, SCM newfile)
@ -1152,39 +1185,30 @@ scm_sys_copy_file (oldfile, newfile)
if (SCM_SUBSTRP (newfile)) if (SCM_SUBSTRP (newfile))
newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0); newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0);
if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1) if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1)
return SCM_BOOL_F; SCM_SYSERROR (s_sys_copy_file);
SCM_DEFER_INTS; SCM_DEFER_INTS;
oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY); oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY);
if (oldfd == -1) if (oldfd == -1)
{ SCM_SYSERROR (s_sys_copy_file);
SCM_ALLOW_INTS;
return SCM_BOOL_F; /* use POSIX flags instead of 07777?. */
}
/* should probably use the POSIX flags instead of 07777. */
newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC, newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC,
oldstat.st_mode & 07777); oldstat.st_mode & 07777);
if (newfd == -1) if (newfd == -1)
{ SCM_SYSERROR (s_sys_copy_file);
close (oldfd);
SCM_ALLOW_INTS;
return SCM_BOOL_F;
}
while ((n = read (oldfd, buf, sizeof buf)) > 0) while ((n = read (oldfd, buf, sizeof buf)) > 0)
if (write (newfd, buf, n) != n) if (write (newfd, buf, n) != n)
{ {
close (oldfd); close (oldfd);
close (newfd); close (newfd);
SCM_ALLOW_INTS; SCM_SYSERROR (s_sys_copy_file);
return SCM_BOOL_F;
} }
close (oldfd); close (oldfd);
if (close (newfd) == -1) if (close (newfd) == -1)
{ SCM_SYSERROR (s_sys_copy_file);
SCM_ALLOW_INTS;
return SCM_BOOL_F;
}
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return SCM_BOOL_T; return SCM_UNSPECIFIED;
} }

91
libguile/ioext.c
View file

@ -48,7 +48,7 @@
SCM_PROC (s_sys_ftell, "%ftell", 1, 0, 0, scm_sys_ftell); SCM_PROC (s_sys_ftell, "ftell", 1, 0, 0, scm_sys_ftell);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_ftell (SCM port) scm_sys_ftell (SCM port)
@ -62,7 +62,7 @@ scm_sys_ftell (port)
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_ftell); SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_ftell);
SCM_SYSCALL (pos = ftell ((FILE *)SCM_STREAM (port))); SCM_SYSCALL (pos = ftell ((FILE *)SCM_STREAM (port)));
if (pos < 0) if (pos < 0)
return SCM_BOOL_F; SCM_SYSERROR (s_sys_ftell);
if (pos > 0 && SCM_CRDYP (port)) if (pos > 0 && SCM_CRDYP (port))
pos--; pos--;
return SCM_MAKINUM (pos); return SCM_MAKINUM (pos);
@ -70,7 +70,7 @@ scm_sys_ftell (port)
SCM_PROC (s_sys_fseek, "%fseek", 3, 0, 0, scm_sys_fseek); SCM_PROC (s_sys_fseek, "fseek", 3, 0, 0, scm_sys_fseek);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_fseek (SCM port, SCM offset, SCM whence) scm_sys_fseek (SCM port, SCM offset, SCM whence)
@ -90,12 +90,14 @@ scm_sys_fseek (port, offset, whence)
SCM_CLRDY (port); /* Clear ungetted char */ SCM_CLRDY (port); /* Clear ungetted char */
/* Values of whence are interned in scm_init_ioext. */ /* Values of whence are interned in scm_init_ioext. */
rv = fseek ((FILE *)SCM_STREAM (port), SCM_INUM (offset), SCM_INUM (whence)); rv = fseek ((FILE *)SCM_STREAM (port), SCM_INUM (offset), SCM_INUM (whence));
return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (rv != 0)
SCM_SYSERROR (s_sys_fseek);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_sys_freopen, "%freopen", 3, 0, 0, scm_sys_freopen); SCM_PROC (s_sys_freopen, "freopen", 3, 0, 0, scm_sys_freopen);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_freopen (SCM filename, SCM modes, SCM port) scm_sys_freopen (SCM filename, SCM modes, SCM port)
@ -134,7 +136,7 @@ scm_sys_freopen (filename, modes, port)
SCM_PROC (s_sys_duplicate_port, "%duplicate-port", 2, 0, 0, scm_sys_duplicate_port); SCM_PROC (s_sys_duplicate_port, "duplicate-port", 2, 0, 0, scm_sys_duplicate_port);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_duplicate_port (SCM oldpt, SCM modes) scm_sys_duplicate_port (SCM oldpt, SCM modes)
@ -155,22 +157,15 @@ scm_sys_duplicate_port (oldpt, modes)
SCM_DEFER_INTS; SCM_DEFER_INTS;
oldfd = fileno ((FILE *)SCM_STREAM (oldpt)); oldfd = fileno ((FILE *)SCM_STREAM (oldpt));
if (oldfd == -1) if (oldfd == -1)
{ SCM_SYSERROR (s_sys_duplicate_port);
SCM_ALLOW_INTS;
return SCM_BOOL_F;
};
SCM_SYSCALL (newfd = dup (oldfd)); SCM_SYSCALL (newfd = dup (oldfd));
if (newfd == -1) if (newfd == -1)
{ SCM_SYSERROR (s_sys_duplicate_port);
SCM_ALLOW_INTS;
return SCM_BOOL_F;
};
f = fdopen (newfd, SCM_CHARS (modes)); f = fdopen (newfd, SCM_CHARS (modes));
if (!f) if (!f)
{ {
SCM_SYSCALL (close (newfd)); SCM_SYSCALL (close (newfd));
SCM_ALLOW_INTS; SCM_SYSERROR (s_sys_duplicate_port);
return SCM_BOOL_F;
} }
{ {
struct scm_port_table * pt; struct scm_port_table * pt;
@ -187,7 +182,7 @@ scm_sys_duplicate_port (oldpt, modes)
SCM_PROC (s_sys_redirect_port, "%redirect-port", 2, 0, 0, scm_sys_redirect_port); SCM_PROC (s_sys_redirect_port, "redirect-port", 2, 0, 0, scm_sys_redirect_port);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_redirect_port (SCM into_pt, SCM from_pt) scm_sys_redirect_port (SCM into_pt, SCM from_pt)
@ -203,13 +198,16 @@ scm_sys_redirect_port (into_pt, from_pt)
SCM_ASSERT (SCM_NIMP (into_pt) && SCM_OPPORTP (into_pt), into_pt, SCM_ARG1, s_sys_redirect_port); SCM_ASSERT (SCM_NIMP (into_pt) && SCM_OPPORTP (into_pt), into_pt, SCM_ARG1, s_sys_redirect_port);
SCM_ASSERT (SCM_NIMP (from_pt) && SCM_OPPORTP (from_pt), from_pt, SCM_ARG2, s_sys_redirect_port); SCM_ASSERT (SCM_NIMP (from_pt) && SCM_OPPORTP (from_pt), from_pt, SCM_ARG2, s_sys_redirect_port);
oldfd = fileno ((FILE *)SCM_STREAM (into_pt)); oldfd = fileno ((FILE *)SCM_STREAM (into_pt));
if (oldfd == -1)
SCM_SYSERROR (s_sys_redirect_port);
newfd = fileno ((FILE *)SCM_STREAM (from_pt)); newfd = fileno ((FILE *)SCM_STREAM (from_pt));
if (oldfd == -1 || newfd == -1) if (newfd == -1)
ans = -1; SCM_SYSERROR (s_sys_redirect_port);
else SCM_SYSCALL (ans = dup2 (oldfd, newfd));
SCM_SYSCALL (ans = dup2 (oldfd, newfd)); if (ans == -1)
SCM_SYSERROR (s_sys_redirect_port);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return (ans == -1) ? SCM_MAKINUM (errno) : SCM_BOOL_T; return SCM_UNSPECIFIED;
} }
SCM_PROC (s_sys_fileno, "%fileno", 1, 0, 0, scm_sys_fileno); SCM_PROC (s_sys_fileno, "%fileno", 1, 0, 0, scm_sys_fileno);
@ -225,11 +223,12 @@ scm_sys_fileno (port)
int fd; int fd;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fileno); SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fileno);
fd = fileno ((FILE *)SCM_STREAM (port)); fd = fileno ((FILE *)SCM_STREAM (port));
return (fd == -1) ? SCM_BOOL_F : SCM_MAKINUM (fd); if (fd == -1)
SCM_SYSERROR (s_sys_fileno);
return SCM_MAKINUM (fd);
} }
SCM_PROC (s_sys_soft_fileno, "soft-fileno", 1, 0, 0, scm_sys_soft_fileno);
SCM_PROC (s_sys_soft_fileno, "%soft-fileno", 1, 0, 0, scm_sys_soft_fileno);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_soft_fileno (SCM port) scm_sys_soft_fileno (SCM port)
@ -240,18 +239,17 @@ scm_sys_soft_fileno (port)
#endif #endif
{ {
int fd; int fd;
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_sys_fileno); SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fileno);
if (!SCM_OPFPORTP (port))
return SCM_BOOL_F;
fd = fileno ((FILE *)SCM_STREAM (port)); fd = fileno ((FILE *)SCM_STREAM (port));
return (fd == -1) ? SCM_BOOL_F : SCM_MAKINUM (fd); if (fd == -1)
SCM_SYSERROR (s_sys_soft_fileno);
return SCM_MAKINUM (fd);
} }
SCM_PROC (s_sys_isatty, "%isatty?", 1, 0, 0, scm_sys_isatty_p); SCM_PROC (s_sys_isatty, "isatty?", 1, 0, 0, scm_sys_isatty_p);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_isatty_p (SCM port) scm_sys_isatty_p (SCM port)
@ -265,17 +263,14 @@ scm_sys_isatty_p (port)
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_isatty); SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_isatty);
rv = fileno ((FILE *)SCM_STREAM (port)); rv = fileno ((FILE *)SCM_STREAM (port));
if (rv == -1) if (rv == -1)
return SCM_MAKINUM (errno); SCM_SYSERROR (s_sys_isatty);
else rv = isatty (rv);
{ return rv ? SCM_BOOL_T : SCM_BOOL_F;
rv = isatty (rv);
return rv ? SCM_BOOL_T : SCM_BOOL_F;
}
} }
SCM_PROC (s_sys_fdopen, "%fdopen", 2, 0, 0, scm_sys_fdopen); SCM_PROC (s_sys_fdopen, "fdopen", 2, 0, 0, scm_sys_fdopen);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_fdopen (SCM fdes, SCM modes) scm_sys_fdopen (SCM fdes, SCM modes)
@ -294,10 +289,7 @@ scm_sys_fdopen (fdes, modes)
SCM_DEFER_INTS; SCM_DEFER_INTS;
f = fdopen (SCM_INUM (fdes), SCM_CHARS (modes)); f = fdopen (SCM_INUM (fdes), SCM_CHARS (modes));
if (f == NULL) if (f == NULL)
{ SCM_SYSERROR (s_sys_fdopen);
SCM_ALLOW_INTS;
return SCM_MAKINUM (errno);
}
SCM_NEWCELL (port); SCM_NEWCELL (port);
SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes)); SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes));
SCM_SETSTREAM (port,(SCM)f); SCM_SETSTREAM (port,(SCM)f);
@ -309,12 +301,11 @@ scm_sys_fdopen (fdes, modes)
/* Move a port's underlying file descriptor to a given value. /* Move a port's underlying file descriptor to a given value.
* Returns: #f for error. * Returns 0 if fdes is already the given value.
* 0 if fdes is already the given value. * 1 if fdes moved.
* 1 if fdes moved.
* MOVE->FDES is implemented in Scheme and calls this primitive. * MOVE->FDES is implemented in Scheme and calls this primitive.
*/ */
SCM_PROC (s_sys_primitive_move_to_fdes, "%primitive-move->fdes", 2, 0, 0, scm_sys_primitive_move_to_fdes); SCM_PROC (s_sys_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, scm_sys_primitive_move_to_fdes);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_primitive_move_to_fdes (SCM port, SCM fd) scm_sys_primitive_move_to_fdes (SCM port, SCM fd)
@ -344,19 +335,13 @@ scm_sys_primitive_move_to_fdes (port, fd)
scm_evict_ports (new_fd); scm_evict_ports (new_fd);
rv = dup2 (old_fd, new_fd); rv = dup2 (old_fd, new_fd);
if (rv == -1) if (rv == -1)
{ SCM_SYSERROR (s_sys_primitive_move_to_fdes);
SCM_ALLOW_INTS;
return SCM_BOOL_F;
}
scm_setfileno (stream, new_fd); scm_setfileno (stream, new_fd);
SCM_SYSCALL (close (old_fd)); SCM_SYSCALL (close (old_fd));
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return SCM_MAKINUM (1); return SCM_MAKINUM (1);
} }
/* FIXME */
#ifdef __STDC__ #ifdef __STDC__
void void
scm_setfileno (FILE *fs, int fd) scm_setfileno (FILE *fs, int fd)

4
libguile/numbers.c
View file

@ -3488,7 +3488,7 @@ void scm_two_doubles(z1, z2, sstring, xy)
SCM_PROC(s_sys_expt, "%expt", 2, 0, 0, scm_sys_expt); SCM_PROC(s_sys_expt, "$expt", 2, 0, 0, scm_sys_expt);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_expt(SCM z1, SCM z2) scm_sys_expt(SCM z1, SCM z2)
@ -3506,7 +3506,7 @@ scm_sys_expt(z1, z2)
SCM_PROC(s_sys_atan2, "%atan2", 2, 0, 0, scm_sys_atan2); SCM_PROC(s_sys_atan2, "$atan2", 2, 0, 0, scm_sys_atan2);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_atan2(SCM z1, SCM z2) scm_sys_atan2(SCM z1, SCM z2)

278
libguile/posix.c
View file

@ -45,6 +45,9 @@
#ifdef HAVE_STRING_H
#include <string.h>
#endif
#ifdef TIME_WITH_SYS_TIME #ifdef TIME_WITH_SYS_TIME
# include <sys/time.h> # include <sys/time.h>
# include <time.h> # include <time.h>
@ -133,7 +136,7 @@ char *strptime ();
SCM_PROC (s_sys_pipe, "%pipe", 0, 0, 0, scm_sys_pipe); SCM_PROC (s_sys_pipe, "pipe", 0, 0, 0, scm_sys_pipe);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_pipe (void) scm_sys_pipe (void)
@ -145,21 +148,20 @@ scm_sys_pipe ()
int fd[2], rv; int fd[2], rv;
FILE *f_rd, *f_wt; FILE *f_rd, *f_wt;
SCM p_rd, p_wt; SCM p_rd, p_wt;
struct scm_port_table * ptr;
struct scm_port_table * ptw;
SCM_NEWCELL (p_rd); SCM_NEWCELL (p_rd);
SCM_NEWCELL (p_wt); SCM_NEWCELL (p_wt);
rv = pipe (fd); rv = pipe (fd);
if (rv) if (rv)
{ SCM_SYSERROR (s_sys_pipe);
SCM_ALLOW_INTS;
return SCM_BOOL_F;
}
f_rd = fdopen (fd[0], "r"); f_rd = fdopen (fd[0], "r");
if (!f_rd) if (!f_rd)
{ {
SCM_SYSCALL (close (fd[0])); SCM_SYSCALL (close (fd[0]));
SCM_SYSCALL (close (fd[1])); SCM_SYSCALL (close (fd[1]));
SCM_ALLOW_INTS; SCM_SYSERROR (s_sys_pipe);
return SCM_BOOL_F;
} }
f_wt = fdopen (fd[1], "w"); f_wt = fdopen (fd[1], "w");
if (!f_wt) if (!f_wt)
@ -168,29 +170,25 @@ scm_sys_pipe ()
en = errno; en = errno;
fclose (f_rd); fclose (f_rd);
SCM_SYSCALL (close (fd[1])); SCM_SYSCALL (close (fd[1]));
SCM_ALLOW_INTS; errno = en;
return SCM_MAKINUM (en); SCM_SYSERROR (s_sys_pipe);
} }
{ ptr = scm_add_to_port_table (p_rd);
struct scm_port_table * ptr; ptw = scm_add_to_port_table (p_wt);
struct scm_port_table * ptw; SCM_SETPTAB_ENTRY (p_rd, ptr);
SCM_SETPTAB_ENTRY (p_wt, ptw);
SCM_CAR (p_rd) = scm_tc16_fport | scm_mode_bits ("r");
SCM_CAR (p_wt) = scm_tc16_fport | scm_mode_bits ("w");
SCM_SETSTREAM (p_rd, (SCM)f_rd);
SCM_SETSTREAM (p_wt, (SCM)f_wt);
ptr = scm_add_to_port_table (p_rd);
ptw = scm_add_to_port_table (p_wt);
SCM_SETPTAB_ENTRY (p_rd, ptr);
SCM_SETPTAB_ENTRY (p_wt, ptw);
SCM_CAR (p_rd) = scm_tc16_fport | scm_mode_bits ("r");
SCM_CAR (p_wt) = scm_tc16_fport | scm_mode_bits ("w");
SCM_SETSTREAM (p_rd, (SCM)f_rd);
SCM_SETSTREAM (p_wt, (SCM)f_wt);
}
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return scm_cons (p_rd, p_wt); return scm_cons (p_rd, p_wt);
} }
SCM_PROC (s_sys_getgroups, "%getgroups", 0, 0, 0, scm_sys_getgroups); SCM_PROC (s_sys_getgroups, "getgroups", 0, 0, 0, scm_sys_getgroups);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_getgroups(void) scm_sys_getgroups(void)
@ -201,7 +199,8 @@ scm_sys_getgroups()
{ {
SCM grps, ans; SCM grps, ans;
int ngroups = getgroups (0, NULL); int ngroups = getgroups (0, NULL);
if (!ngroups) return SCM_BOOL_F; if (!ngroups)
SCM_SYSERROR (s_sys_getgroups);
SCM_NEWCELL(grps); SCM_NEWCELL(grps);
SCM_DEFER_INTS; SCM_DEFER_INTS;
{ {
@ -214,8 +213,7 @@ scm_sys_getgroups()
if (val < 0) if (val < 0)
{ {
scm_must_free((char *)groups); scm_must_free((char *)groups);
SCM_ALLOW_INTS; SCM_SYSERROR (s_sys_getgroups);
return SCM_MAKINUM (errno);
} }
SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */ SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */
SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string); SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string);
@ -229,7 +227,7 @@ scm_sys_getgroups()
SCM_PROC (s_sys_getpwuid, "%getpw", 0, 1, 0, scm_sys_getpwuid); SCM_PROC (s_sys_getpwuid, "getpw", 0, 1, 0, scm_sys_getpwuid);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_getpwuid (SCM user) scm_sys_getpwuid (SCM user)
@ -264,10 +262,8 @@ scm_sys_getpwuid (user)
entry = getpwnam (SCM_ROCHARS (user)); entry = getpwnam (SCM_ROCHARS (user));
} }
if (!entry) if (!entry)
{ SCM_SYSERROR (s_sys_getpwuid);
SCM_ALLOW_INTS;
return SCM_BOOL_F;
}
ve[0] = scm_makfrom0str (entry->pw_name); ve[0] = scm_makfrom0str (entry->pw_name);
ve[1] = scm_makfrom0str (entry->pw_passwd); ve[1] = scm_makfrom0str (entry->pw_passwd);
ve[2] = scm_ulong2num ((unsigned long) entry->pw_uid); ve[2] = scm_ulong2num ((unsigned long) entry->pw_uid);
@ -307,7 +303,7 @@ scm_setpwent (arg)
/* Combines getgrgid and getgrnam. */ /* Combines getgrgid and getgrnam. */
SCM_PROC (s_sys_getgrgid, "%getgr", 0, 1, 0, scm_sys_getgrgid); SCM_PROC (s_sys_getgrgid, "getgr", 0, 1, 0, scm_sys_getgrgid);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_getgrgid (SCM name) scm_sys_getgrgid (SCM name)
@ -335,10 +331,8 @@ scm_sys_getgrgid (name)
SCM_SYSCALL (entry = getgrnam (SCM_CHARS (name))); SCM_SYSCALL (entry = getgrnam (SCM_CHARS (name)));
} }
if (!entry) if (!entry)
{ SCM_SYSERROR (s_sys_getgrgid);
SCM_ALLOW_INTS;
return SCM_MAKINUM (errno);
}
ve[0] = scm_makfrom0str (entry->gr_name); ve[0] = scm_makfrom0str (entry->gr_name);
ve[1] = scm_makfrom0str (entry->gr_passwd); ve[1] = scm_makfrom0str (entry->gr_passwd);
ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid); ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid);
@ -368,7 +362,7 @@ scm_setgrent (arg)
SCM_PROC (s_sys_kill, "%kill", 2, 0, 0, scm_sys_kill); SCM_PROC (s_sys_kill, "kill", 2, 0, 0, scm_sys_kill);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_kill (SCM pid, SCM sig) scm_sys_kill (SCM pid, SCM sig)
@ -379,17 +373,17 @@ scm_sys_kill (pid, sig)
SCM sig; SCM sig;
#endif #endif
{ {
int i;
SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_sys_kill); SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_sys_kill);
SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_sys_kill); SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_sys_kill);
/* Signal values are interned in scm_init_posix(). */ /* Signal values are interned in scm_init_posix(). */
SCM_SYSCALL (i = kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig))); if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0)
return i ? SCM_MAKINUM (errno) : SCM_BOOL_T; SCM_SYSERROR (s_sys_kill);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_sys_waitpid, "%waitpid", 1, 1, 0, scm_sys_waitpid); SCM_PROC (s_sys_waitpid, "waitpid", 1, 1, 0, scm_sys_waitpid);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_waitpid (SCM pid, SCM options) scm_sys_waitpid (SCM pid, SCM options)
@ -413,9 +407,9 @@ scm_sys_waitpid (pid, options)
ioptions = SCM_INUM (options); ioptions = SCM_INUM (options);
} }
SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions)); SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions));
return ((i == -1) if (i == -1)
? SCM_MAKINUM (errno) SCM_SYSERROR (s_sys_waitpid);
: scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status))); return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status));
} }
@ -497,7 +491,7 @@ scm_getegid ()
} }
SCM_PROC (s_sys_setuid, "%setuid", 1, 0, 0, scm_sys_setuid); SCM_PROC (s_sys_setuid, "setuid", 1, 0, 0, scm_sys_setuid);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_setuid (SCM id) scm_sys_setuid (SCM id)
@ -508,10 +502,12 @@ scm_sys_setuid (id)
#endif #endif
{ {
SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setuid); SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setuid);
return setuid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (setuid (SCM_INUM (id)) != 0)
SCM_SYSERROR (s_sys_setuid);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_sys_setgid, "%setgid", 1, 0, 0, scm_sys_setgid); SCM_PROC (s_sys_setgid, "setgid", 1, 0, 0, scm_sys_setgid);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_setgid (SCM id) scm_sys_setgid (SCM id)
@ -522,10 +518,12 @@ scm_sys_setgid (id)
#endif #endif
{ {
SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setgid); SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setgid);
return setgid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (setgid (SCM_INUM (id)) != 0)
SCM_SYSERROR (s_sys_setgid);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_sys_seteuid, "%seteuid", 1, 0, 0, scm_sys_seteuid); SCM_PROC (s_sys_seteuid, "seteuid", 1, 0, 0, scm_sys_seteuid);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_seteuid (SCM id) scm_sys_seteuid (SCM id)
@ -535,15 +533,20 @@ scm_sys_seteuid (id)
SCM id; SCM id;
#endif #endif
{ {
int rv;
SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_seteuid); SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_seteuid);
#ifdef HAVE_SETEUID #ifdef HAVE_SETEUID
return seteuid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; rv = seteuid (SCM_INUM (id));
#else #else
return setuid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; rv = setuid (SCM_INUM (id));
#endif #endif
if (rv != 0)
SCM_SYSERROR (s_sys_seteuid);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_sys_setegid, "%setegid", 1, 0, 0, scm_sys_setegid); SCM_PROC (s_sys_setegid, "setegid", 1, 0, 0, scm_sys_setegid);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_setegid (SCM id) scm_sys_setegid (SCM id)
@ -553,12 +556,18 @@ scm_sys_setegid (id)
SCM id; SCM id;
#endif #endif
{ {
int rv;
SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setegid); SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setegid);
#ifdef HAVE_SETEUID #ifdef HAVE_SETEUID
return setegid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; rv = setegid (SCM_INUM (id));
#else #else
return setgid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; rv = setgid (SCM_INUM (id));
#endif #endif
if (rv != 0)
SCM_SYSERROR (s_sys_setegid);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_getpgrp, "getpgrp", 0, 0, 0, scm_getpgrp); SCM_PROC (s_getpgrp, "getpgrp", 0, 0, 0, scm_getpgrp);
@ -570,30 +579,34 @@ scm_getpgrp ()
return SCM_MAKINUM (fn (0)); return SCM_MAKINUM (fn (0));
} }
SCM_PROC (s_setpgid, "%setpgid", 2, 0, 0, scm_setpgid); SCM_PROC (s_setpgid, "setpgid", 2, 0, 0, scm_setpgid);
SCM SCM
scm_setpgid (pid, pgid) scm_setpgid (pid, pgid)
SCM pid, pgid; SCM pid, pgid;
{ {
SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_setpgid); SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_setpgid);
SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_setpgid); SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_setpgid);
/* This may be known as setpgrp, from BSD. */ /* FIXME(?): may be known as setpgrp. */
return setpgid (SCM_INUM (pid), SCM_INUM (pgid)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0)
SCM_SYSERROR (s_setpgid);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_setsid, "%setsid", 0, 0, 0, scm_setsid); SCM_PROC (s_setsid, "setsid", 0, 0, 0, scm_setsid);
SCM SCM
scm_setsid () scm_setsid ()
{ {
pid_t sid = setsid (); pid_t sid = setsid ();
return (sid == -1) ? SCM_BOOL_F : SCM_MAKINUM (sid); if (sid == -1)
SCM_SYSERROR (s_setsid);
return SCM_UNSPECIFIED;
} }
#ifndef ttyname #ifndef ttyname
extern char * ttyname(); extern char * ttyname();
#endif #endif
SCM_PROC (s_ttyname, "%ttyname", 1, 0, 0, scm_ttyname); SCM_PROC (s_ttyname, "ttyname", 1, 0, 0, scm_ttyname);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_ttyname (SCM port) scm_ttyname (SCM port)
@ -609,24 +622,27 @@ scm_ttyname (port)
if (scm_tc16_fport != SCM_TYP16 (port)) if (scm_tc16_fport != SCM_TYP16 (port))
return SCM_BOOL_F; return SCM_BOOL_F;
fd = fileno ((FILE *)SCM_STREAM (port)); fd = fileno ((FILE *)SCM_STREAM (port));
if (fd != -1) if (fd == -1)
SCM_SYSCALL (ans = ttyname (fd)); SCM_SYSERROR (s_ttyname);
SCM_SYSCALL (ans = ttyname (fd));
if (!ans)
SCM_SYSERROR (s_ttyname);
/* ans could be overwritten by another call to ttyname */ /* ans could be overwritten by another call to ttyname */
return (((fd != -1) && ans) return (scm_makfrom0str (ans));
? scm_makfrom0str (ans)
: SCM_MAKINUM (errno));
} }
SCM_PROC (s_ctermid, "%ctermid", 0, 0, 0, scm_ctermid); SCM_PROC (s_ctermid, "ctermid", 0, 0, 0, scm_ctermid);
SCM SCM
scm_ctermid () scm_ctermid ()
{ {
char *result = ctermid (NULL); char *result = ctermid (NULL);
return *result == '\0' ? SCM_BOOL_F : scm_makfrom0str (result); if (*result == '\0')
SCM_SYSERROR (s_ctermid);
return scm_makfrom0str (result);
} }
SCM_PROC (s_tcgetpgrp, "%tcgetpgrp", 1, 0, 0, scm_tcgetpgrp); SCM_PROC (s_tcgetpgrp, "tcgetpgrp", 1, 0, 0, scm_tcgetpgrp);
SCM SCM
scm_tcgetpgrp (port) scm_tcgetpgrp (port)
SCM port; SCM port;
@ -636,12 +652,11 @@ scm_tcgetpgrp (port)
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcgetpgrp); SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcgetpgrp);
fd = fileno ((FILE *)SCM_STREAM (port)); fd = fileno ((FILE *)SCM_STREAM (port));
if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1) if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1)
return SCM_BOOL_F; SCM_SYSERROR (s_tcgetpgrp);
else return SCM_MAKINUM (pgid);
return SCM_MAKINUM (pgid);
} }
SCM_PROC (s_tcsetpgrp, "%tcsetpgrp", 2, 0, 0, scm_tcsetpgrp); SCM_PROC (s_tcsetpgrp, "tcsetpgrp", 2, 0, 0, scm_tcsetpgrp);
SCM SCM
scm_tcsetpgrp (port, pgid) scm_tcsetpgrp (port, pgid)
SCM port, pgid; SCM port, pgid;
@ -651,9 +666,8 @@ scm_tcsetpgrp (port, pgid)
SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp); SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp);
fd = fileno ((FILE *)SCM_STREAM (port)); fd = fileno ((FILE *)SCM_STREAM (port));
if (fd == -1 || tcsetpgrp (fd, SCM_INUM (pgid)) == -1) if (fd == -1 || tcsetpgrp (fd, SCM_INUM (pgid)) == -1)
return SCM_BOOL_F; SCM_SYSERROR (s_tcsetpgrp);
else return SCM_UNSPECIFIED;
return SCM_BOOL_T;
} }
/* Copy exec args from an SCM vector into a new C array. */ /* Copy exec args from an SCM vector into a new C array. */
@ -692,7 +706,7 @@ scm_convert_exec_args (args)
return execargv; return execargv;
} }
SCM_PROC (s_sys_execl, "%execl", 0, 0, 1, scm_sys_execl); SCM_PROC (s_sys_execl, "execl", 0, 0, 1, scm_sys_execl);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_execl (SCM args) scm_sys_execl (SCM args)
@ -710,10 +724,12 @@ scm_sys_execl (args)
args = SCM_CDR (args); args = SCM_CDR (args);
execargv = scm_convert_exec_args (args); execargv = scm_convert_exec_args (args);
execv (SCM_ROCHARS (filename), execargv); execv (SCM_ROCHARS (filename), execargv);
return SCM_MAKINUM (errno); SCM_SYSERROR (s_sys_execl);
/* not reached. */
return SCM_BOOL_F;
} }
SCM_PROC (s_sys_execlp, "%execlp", 0, 0, 1, scm_sys_execlp); SCM_PROC (s_sys_execlp, "execlp", 0, 0, 1, scm_sys_execlp);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_execlp (SCM args) scm_sys_execlp (SCM args)
@ -731,11 +747,13 @@ scm_sys_execlp (args)
args = SCM_CDR (args); args = SCM_CDR (args);
execargv = scm_convert_exec_args (args); execargv = scm_convert_exec_args (args);
execvp (SCM_ROCHARS (filename), execargv); execvp (SCM_ROCHARS (filename), execargv);
return SCM_MAKINUM (errno); SCM_SYSERROR (s_sys_execlp);
/* not reached. */
return SCM_BOOL_F;
} }
/* Flushing streams etc., is not done here. */ /* Flushing streams etc., is not done here. */
SCM_PROC (s_sys_fork, "%fork", 0, 0, 0, scm_sys_fork); SCM_PROC (s_sys_fork, "fork", 0, 0, 0, scm_sys_fork);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_fork(void) scm_sys_fork(void)
@ -747,13 +765,12 @@ scm_sys_fork()
pid_t pid; pid_t pid;
pid = fork (); pid = fork ();
if (pid == -1) if (pid == -1)
return SCM_BOOL_F; SCM_SYSERROR (s_sys_fork);
else return SCM_MAKINUM (0L+pid);
return SCM_MAKINUM (0L+pid);
} }
SCM_PROC (s_sys_uname, "%uname", 0, 0, 0, scm_sys_uname); SCM_PROC (s_sys_uname, "uname", 0, 0, 0, scm_sys_uname);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_uname (void) scm_sys_uname (void)
@ -774,12 +791,14 @@ scm_sys_uname ()
ve[3] = scm_makfrom0str (buf.version); ve[3] = scm_makfrom0str (buf.version);
ve[4] = scm_makfrom0str (buf.machine); ve[4] = scm_makfrom0str (buf.machine);
/* /*
FIXME a linux special?
ve[5] = scm_makfrom0str (buf.domainname); ve[5] = scm_makfrom0str (buf.domainname);
*/ */
return ans; return ans;
#else #else
return SCM_MAKINUM (ENOSYS); SCM_SYSMISSING (s_sys_uname);
/* not reached. */
return SCM_BOOL_F;
#endif #endif
} }
@ -854,6 +873,8 @@ scm_open_pipe (pipestr, modes)
{ {
FILE *f; FILE *f;
register SCM z; register SCM z;
struct scm_port_table * pt;
SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr, SCM_ARG1, s_open_pipe); SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr, SCM_ARG1, s_open_pipe);
if (SCM_SUBSTRP (pipestr)) if (SCM_SUBSTRP (pipestr))
pipestr = scm_makfromstr (SCM_ROCHARS (pipestr), SCM_ROLENGTH (pipestr), 0); pipestr = scm_makfromstr (SCM_ROCHARS (pipestr), SCM_ROLENGTH (pipestr), 0);
@ -866,15 +887,12 @@ scm_open_pipe (pipestr, modes)
SCM_SYSCALL (f = popen (SCM_ROCHARS (pipestr), SCM_ROCHARS (modes))); SCM_SYSCALL (f = popen (SCM_ROCHARS (pipestr), SCM_ROCHARS (modes)));
scm_unignore_signals (); scm_unignore_signals ();
if (!f) if (!f)
z = SCM_BOOL_F; SCM_SYSERROR (s_open_pipe);
else pt = scm_add_to_port_table (z);
{ SCM_SETPTAB_ENTRY (z, pt);
struct scm_port_table * pt; SCM_CAR (z) = scm_tc16_pipe | SCM_OPN
pt = scm_add_to_port_table (z); | (strchr (SCM_ROCHARS (modes), 'r') ? SCM_RDNG : SCM_WRTNG);
SCM_SETPTAB_ENTRY (z, pt); SCM_SETSTREAM (z, (SCM)f);
SCM_CAR (z) = scm_tc16_pipe | SCM_OPN | (strchr (SCM_ROCHARS (modes), 'r') ? SCM_RDNG : SCM_WRTNG);
SCM_SETSTREAM (z, (SCM)f);
}
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return z; return z;
} }
@ -913,7 +931,7 @@ scm_open_output_pipe(pipestr)
#include <utime.h> #include <utime.h>
#endif #endif
SCM_PROC (s_sys_utime, "%utime", 1, 2, 0, scm_sys_utime); SCM_PROC (s_sys_utime, "utime", 1, 2, 0, scm_sys_utime);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_utime (SCM pathname, SCM actime, SCM modtime) scm_sys_utime (SCM pathname, SCM actime, SCM modtime)
@ -941,13 +959,11 @@ scm_sys_utime (pathname, actime, modtime)
utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_sys_utime); utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_sys_utime);
SCM_SYSCALL (rv = utime (SCM_CHARS (pathname), &utm_tmp)); SCM_SYSCALL (rv = utime (SCM_CHARS (pathname), &utm_tmp));
return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (rv != 0)
SCM_SYSERROR (s_sys_utime);
return SCM_UNSPECIFIED;
} }
SCM_PROC (s_sys_access, "access?", 2, 0, 0, scm_sys_access); SCM_PROC (s_sys_access, "access?", 2, 0, 0, scm_sys_access);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
@ -969,8 +985,6 @@ scm_sys_access (path, how)
return rv ? SCM_BOOL_F : SCM_BOOL_T; return rv ? SCM_BOOL_F : SCM_BOOL_T;
} }
SCM_PROC (s_getpid, "getpid", 0, 0, 0, scm_getpid); SCM_PROC (s_getpid, "getpid", 0, 0, 0, scm_getpid);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
@ -983,8 +997,7 @@ scm_getpid ()
return SCM_MAKINUM ((unsigned long) getpid ()); return SCM_MAKINUM ((unsigned long) getpid ());
} }
SCM_PROC (s_sys_putenv, "putenv", 1, 0, 0, scm_sys_putenv);
SCM_PROC (s_sys_putenv, "%putenv", 1, 0, 0, scm_sys_putenv);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_putenv (SCM str) scm_sys_putenv (SCM str)
@ -998,11 +1011,12 @@ scm_sys_putenv (str)
SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_putenv); SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_putenv);
return putenv (SCM_CHARS (str)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; return putenv (SCM_CHARS (str)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
#else #else
return SCM_MAKINUM (ENOSYS); SCM_SYSMISSING (s_sys_putenv);
/* not reached. */
return SCM_BOOL_F;
#endif #endif
} }
SCM_PROC (s_read_line, "read-line", 0, 2, 0, scm_read_line); SCM_PROC (s_read_line, "read-line", 0, 2, 0, scm_read_line);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
@ -1065,8 +1079,6 @@ scm_read_line (port, include_terminator)
} }
} }
SCM_PROC (s_read_line_x, "read-line!", 1, 1, 0, scm_read_line_x); SCM_PROC (s_read_line_x, "read-line!", 1, 1, 0, scm_read_line_x);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
@ -1111,8 +1123,6 @@ scm_read_line_x (str, port)
} }
} }
SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line); SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
@ -1128,9 +1138,7 @@ scm_write_line (obj, port)
return scm_newline (port); return scm_newline (port);
} }
SCM_PROC (s_setlocale, "setlocale", 1, 1, 0, scm_setlocale);
SCM_PROC (s_setlocale, "%setlocale", 1, 1, 0, scm_setlocale);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_setlocale (SCM category, SCM locale) scm_setlocale (SCM category, SCM locale)
@ -1157,10 +1165,13 @@ scm_setlocale (category, locale)
} }
rv = setlocale (SCM_INUM (category), clocale); rv = setlocale (SCM_INUM (category), clocale);
return rv ? scm_makfrom0str (rv) : SCM_MAKINUM (errno); if (rv == NULL)
SCM_SYSERROR (s_setlocale);
return scm_makfrom0str (rv);
#else #else
/* setlocale not available. */ SCM_SYSMISSING (s_setlocale);
return SCM_MAKINUM (errno); /* not reached. */
return SCM_BOOL_F;
#endif #endif
} }
@ -1217,9 +1228,7 @@ scm_strftime (format, stime)
return scm_makfromstr (tbuf, len, 0); return scm_makfromstr (tbuf, len, 0);
} }
SCM_PROC (s_sys_strptime, "strptime", 2, 0, 0, scm_sys_strptime);
SCM_PROC (s_sys_strptime, "%strptime", 2, 0, 0, scm_sys_strptime);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_strptime (SCM format, SCM string) scm_sys_strptime (SCM format, SCM string)
@ -1235,7 +1244,6 @@ scm_sys_strptime (format, string)
struct tm t; struct tm t;
char *fmt, *str, *rest; char *fmt, *str, *rest;
int len;
int n; int n;
SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, s_sys_strptime); SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, s_sys_strptime);
@ -1265,9 +1273,8 @@ scm_sys_strptime (format, string)
rest = strptime (str, fmt, &t); rest = strptime (str, fmt, &t);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
if (rest == NULL) { if (rest == NULL)
return SCM_BOOL_F; SCM_SYSERROR (s_sys_strptime);
}
stime = scm_make_vector (SCM_MAKINUM (9), scm_long2num (0), SCM_UNDEFINED); stime = scm_make_vector (SCM_MAKINUM (9), scm_long2num (0), SCM_UNDEFINED);
@ -1286,12 +1293,13 @@ scm_sys_strptime (format, string)
return scm_cons (stime, scm_makfrom0str (rest)); return scm_cons (stime, scm_makfrom0str (rest));
#else #else
scm_wta (SCM_UNSPECIFIED, "strptime is not available and no replacement has (yet) been supplied", "strptime"); SCM_SYSMISSING (s_sys_strptime);
/* not reached. */
return SCM_BOOL_F; return SCM_BOOL_F;
#endif #endif
} }
SCM_PROC (s_sys_mknod, "%mknod", 3, 0, 0, scm_sys_mknod); SCM_PROC (s_sys_mknod, "mknod", 3, 0, 0, scm_sys_mknod);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_mknod(SCM path, SCM mode, SCM dev) scm_sys_mknod(SCM path, SCM mode, SCM dev)
@ -1309,14 +1317,18 @@ scm_sys_mknod(path, mode, dev)
SCM_ASSERT(SCM_INUMP(mode), mode, SCM_ARG2, s_sys_mknod); SCM_ASSERT(SCM_INUMP(mode), mode, SCM_ARG2, s_sys_mknod);
SCM_ASSERT(SCM_INUMP(dev), dev, SCM_ARG3, s_sys_mknod); SCM_ASSERT(SCM_INUMP(dev), dev, SCM_ARG3, s_sys_mknod);
SCM_SYSCALL(val = mknod(SCM_CHARS(path), SCM_INUM(mode), SCM_INUM(dev))); SCM_SYSCALL(val = mknod(SCM_CHARS(path), SCM_INUM(mode), SCM_INUM(dev)));
return val ? SCM_BOOL_F : SCM_BOOL_T; if (val != 0)
SCM_SYSERROR (s_sys_mknod);
return SCM_UNSPECIFIED;
#else #else
SCM_SYSMISSING (s_sys_mknod);
/* not reached. */
return SCM_BOOL_F; return SCM_BOOL_F;
#endif #endif
} }
SCM_PROC (s_sys_nice, "%nice", 1, 0, 0, scm_sys_nice); SCM_PROC (s_sys_nice, "nice", 1, 0, 0, scm_sys_nice);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_nice(SCM incr) scm_sys_nice(SCM incr)
@ -1328,9 +1340,13 @@ scm_sys_nice(incr)
{ {
#ifdef HAVE_NICE #ifdef HAVE_NICE
SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_sys_nice); SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_sys_nice);
return nice(SCM_INUM(incr)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; if (nice(SCM_INUM(incr)) != 0)
SCM_SYSERROR (s_sys_nice);
return SCM_UNSPECIFIED;
#else #else
return SCM_MAKINUM (ENOSYS); SCM_SYSMISSING (s_sys_nice);
/* not reached. */
return SCM_BOOL_F;
#endif #endif
} }
@ -1347,7 +1363,9 @@ scm_sync()
#ifdef HAVE_SYNC #ifdef HAVE_SYNC
sync(); sync();
#endif #endif
return SCM_UNSPECIFIED; SCM_SYSMISSING (s_sync);
/* not reached. */
return SCM_BOOL_F;
} }

4
libguile/simpos.c
View file

@ -76,7 +76,7 @@ scm_system(cmd)
#endif #endif
extern char *getenv(); extern char *getenv();
SCM_PROC (s_sys_getenv, "%getenv", 1, 0, 0, scm_sys_getenv); SCM_PROC (s_sys_getenv, "getenv", 1, 0, 0, scm_sys_getenv);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_getenv(SCM nam) scm_sys_getenv(SCM nam)
@ -92,7 +92,7 @@ scm_sys_getenv(nam)
nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0); nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0);
val = getenv(SCM_CHARS(nam)); val = getenv(SCM_CHARS(nam));
if (!val) if (!val)
return SCM_BOOL_F; SCM_SYSERROR (s_sys_getenv);
return scm_makfromstr(val, (scm_sizet)strlen(val), 0); return scm_makfromstr(val, (scm_sizet)strlen(val), 0);
} }

30
libguile/socket.c
View file

@ -23,7 +23,7 @@
int close P ((int fd)); int close P ((int fd));
#endif /* STDC_HEADERS */ #endif /* STDC_HEADERS */
SCM_PROC (s_sys_inet_aton, "%inet-aton", 1, 0, 0, scm_sys_inet_aton); SCM_PROC (s_sys_inet_aton, "inet-aton", 1, 0, 0, scm_sys_inet_aton);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_inet_aton (SCM address) scm_sys_inet_aton (SCM address)
@ -38,8 +38,9 @@ scm_sys_inet_aton (address)
SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_sys_inet_aton); SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_sys_inet_aton);
if (SCM_SUBSTRP (address)) if (SCM_SUBSTRP (address))
address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0); address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0);
rv = inet_aton (SCM_ROCHARS (address), &soka); if (inet_aton (SCM_ROCHARS (address), &soka) == 0)
return rv ? scm_ulong2num (ntohl (soka.s_addr)) : SCM_BOOL_F; SCM_SYSERROR (s_sys_inet_aton);
return scm_ulong2num (ntohl (soka.s_addr));
} }
@ -121,7 +122,7 @@ scm_inet_makeaddr (net, lna)
* Assumes hostent stream isn't reused. * Assumes hostent stream isn't reused.
*/ */
SCM_PROC (s_sys_gethost, "%gethost", 0, 1, 0, scm_sys_gethost); SCM_PROC (s_sys_gethost, "gethost", 0, 1, 0, scm_sys_gethost);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_gethost (SCM name) scm_sys_gethost (SCM name)
@ -159,7 +160,7 @@ scm_sys_gethost (name)
} }
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
if (!entry) if (!entry)
return SCM_BOOL_F; SCM_SYSERROR (s_sys_gethost);
ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0); ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0);
ve[1] = scm_makfromstrs (-1, entry->h_aliases); ve[1] = scm_makfromstrs (-1, entry->h_aliases);
ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L); ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
@ -180,7 +181,7 @@ scm_sys_gethost (name)
} }
SCM_PROC (s_sys_getnet, "%getnet", 0, 1, 0, scm_sys_getnet); SCM_PROC (s_sys_getnet, "getnet", 0, 1, 0, scm_sys_getnet);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_getnet (SCM name) scm_sys_getnet (SCM name)
@ -215,7 +216,7 @@ scm_sys_getnet (name)
} }
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
if (!entry) if (!entry)
return SCM_BOOL_F; SCM_SYSERROR (s_sys_getnet);
ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0); ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
ve[1] = scm_makfromstrs (-1, entry->n_aliases); ve[1] = scm_makfromstrs (-1, entry->n_aliases);
ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L); ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
@ -223,7 +224,7 @@ scm_sys_getnet (name)
return ans; return ans;
} }
SCM_PROC (s_sys_getproto, "%getproto", 0, 1, 0, scm_sys_getproto); SCM_PROC (s_sys_getproto, "getproto", 0, 1, 0, scm_sys_getproto);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_getproto (SCM name) scm_sys_getproto (SCM name)
@ -258,7 +259,7 @@ scm_sys_getproto (name)
} }
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
if (!entry) if (!entry)
return SCM_BOOL_F; SCM_SYSERROR (s_sys_getproto);
ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0); ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
ve[1] = scm_makfromstrs (-1, entry->p_aliases); ve[1] = scm_makfromstrs (-1, entry->p_aliases);
ve[2] = SCM_MAKINUM (entry->p_proto + 0L); ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
@ -279,11 +280,6 @@ scm_return_entry (entry)
ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F); ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
ve = SCM_VELTS (ans); ve = SCM_VELTS (ans);
if (!entry)
{
SCM_ALLOW_INTS;
return SCM_BOOL_F;
}
ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0); ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
ve[1] = scm_makfromstrs (-1, entry->s_aliases); ve[1] = scm_makfromstrs (-1, entry->s_aliases);
ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L); ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
@ -292,7 +288,7 @@ scm_return_entry (entry)
return ans; return ans;
} }
SCM_PROC (s_sys_getserv, "%getserv", 0, 2, 0, scm_sys_getserv); SCM_PROC (s_sys_getserv, "getserv", 0, 2, 0, scm_sys_getserv);
#ifdef __STDC__ #ifdef __STDC__
SCM SCM
scm_sys_getserv (SCM name, SCM proto) scm_sys_getserv (SCM name, SCM proto)
@ -308,6 +304,8 @@ scm_sys_getserv (name, proto)
{ {
SCM_DEFER_INTS; SCM_DEFER_INTS;
entry = getservent (); entry = getservent ();
if (!entry)
SCM_SYSERROR (s_sys_getserv);
return scm_return_entry (entry); return scm_return_entry (entry);
} }
SCM_ASSERT (SCM_NIMP (proto) && SCM_STRINGP (proto), proto, SCM_ARG2, s_sys_getserv); SCM_ASSERT (SCM_NIMP (proto) && SCM_STRINGP (proto), proto, SCM_ARG2, s_sys_getserv);
@ -322,6 +320,8 @@ scm_sys_getserv (name, proto)
SCM_DEFER_INTS; SCM_DEFER_INTS;
entry = getservbyport (SCM_INUM (name), SCM_CHARS (proto)); entry = getservbyport (SCM_INUM (name), SCM_CHARS (proto));
} }
if (!entry)
SCM_SYSERROR (s_sys_getserv);
return scm_return_entry (entry); return scm_return_entry (entry);
} }