[Scsh-checkins] CVS: scsh-0.6/scsh syscalls.scm,1.11,1.12 syscalls1.c,1.10,1.11 syscalls1.h,1.9,1.10

[Martin Gasbichler <mainzelm@users.sourceforge.net>]

Update of /cvsroot/scsh/scsh-0.6/scsh
In directory slayer.i.sourceforge.net:/tmp/cvs-serv21341/scsh

Modified Files:
        syscalls.scm syscalls1.c syscalls1.h 
Log Message:
Replaced many define-foreign by define-stubless-foreign

Index: syscalls.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls.scm,v
retrieving revision 1.11
retrieving revision 1.12
diff -C2 -r1.11 -r1.12
*** syscalls.scm        2000/07/27 13:32:12     1.11
--- syscalls.scm        2000/09/19 08:08:39     1.12
***************
*** 102,112 ****
  
  
! (define-foreign exit/errno ; errno -- misnomer.
!   (exit (fixnum status))
!   ignore)
  
  (define-foreign %exit/errno ; errno -- misnomer
!   (_exit (fixnum status))
!   ignore)
  
  (define (%exit . maybe-status)
--- 102,110 ----
  
  
! (define-stubless-foreign exit/errno ; errno -- misnomer.
!   (status) "scsh_exit")
  
  (define-foreign %exit/errno ; errno -- misnomer
!   (status) "scsh__exit")
  
  (define (%exit . maybe-status)
***************
*** 114,135 ****
    (error "Yikes! %exit returned."))
  
- 
- (define-foreign %%fork/errno (fork)
-   (multi-rep (to-scheme pid_t errno_or_false)
-              pid_t))
- 
- ;;; If the fork fails, and we are doing early zombie reaping, then reap
- ;;; some zombies to try and free up a some space in the process table,
- ;;; and try again.
- ;;;
- ;;; This ugly little hack will have to stay in until I do early
- ;;; zombie reaping with SIGCHLD interrupts.
- 
- (define (%%fork-with-retry/errno)
-   (receive (err pid) (%%fork/errno)
-          (values err pid)))
  
! (define-errno-syscall (%%fork) %%fork-with-retry/errno
!   pid)
  
  ;;; Posix waitpid(2) call.
--- 112,117 ----
    (error "Yikes! %exit returned."))
  
  
! (define-stubless-foreign %%fork () "fork")
  
  ;;; Posix waitpid(2) call.
***************
*** 373,388 ****
             (if err (errno-error err create-directory path mode)))))))
  
  
- (define-foreign read-symlink/errno (scm_readlink (string path))
-  desc
-  desc)
- 
- ;(to-scheme string errno_on_zero_or_false) ; NULL => errno, otw #f
- ;          static-string))
-              
- (define-errno-syscall (read-symlink path) read-symlink/errno
-   new-path)
- 
- 
  (define-foreign %rename-file/errno
    (rename (string old-name) (string new-name))
--- 355,360 ----
             (if err (errno-error err create-directory path mode)))))))
  
+ (define-stubless-foreign read-symlink (path) "scm_readlink")
  
  (define-foreign %rename-file/errno
    (rename (string old-name) (string new-name))
***************
*** 625,643 ****
  
  
! (define-foreign pipe-fdes/errno (scheme_pipe)
!   (to-scheme fixnum "False_on_zero")  ; Win: #f, lose: errno
!   fixnum      ; r
!   fixnum)     ; w
  
- (define-errno-syscall (pipe-fdes) pipe-fdes/errno
-   r w)
- 
  (define (pipe)
!   (receive (r-fd w-fd) (pipe-fdes)
!     (let ((r (fdes->inport  r-fd))
!         (w (fdes->outport w-fd)))
!       (release-port-handle r)
!       (release-port-handle w)
!       (values r w))))
  
  (define-foreign %read-fdes-char
--- 597,610 ----
  
  
! (define-stubless-foreign pipe-fdes () "scheme_pipe")
  
  (define (pipe)
!   (apply (pipe-fdes) 
!        (lambda (r-fd w-fd)
!          (let ((r (fdes->inport  r-fd))
!                (w (fdes->outport w-fd)))
!            (release-port-handle r)
!            (release-port-handle w)
!            (values r w)))))
  
  (define-foreign %read-fdes-char
***************
*** 678,687 ****
  ;;; Signals (rather incomplete)
  ;;; ---------------------------
- 
- (define-foreign signal-pid/errno
-   (kill (pid_t pid) (fixnum signal))
-   (to-scheme fixnum errno_or_false))
  
! (define-errno-syscall (signal-pid pid signal) signal-pid/errno)
  
  (define (signal-process proc signal)
--- 645,650 ----
  ;;; Signals (rather incomplete)
  ;;; ---------------------------
  
! (define-stubless-foreign signal-pid (pid signal) "scsh_kill")
  
  (define (signal-process proc signal)
***************
*** 956,976 ****
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
! (define-foreign %set-cloexec (set_cloexec (fixnum fd) (bool val))
!   (to-scheme fixnum "errno_or_false"))
  
  ;;; Some of fcntl()
  ;;;;;;;;;;;;;;;;;;;
  
! (define-foreign %fcntl-read/errno (fcntl_read (fixnum fd) (fixnum command))
!   (multi-rep (to-scheme fixnum errno_or_false)
!            fixnum))
  
- (define-foreign %fcntl-write/errno
-   (fcntl_write (fixnum fd) (fixnum command) (fixnum val))
-   (to-scheme fixnum errno_or_false))
- 
- (define-errno-syscall (%fcntl-read fd command) %fcntl-read/errno value)
- (define-errno-syscall (%fcntl-write fd command val) %fcntl-write/errno)
- 
  ;;; fcntl()'s F_GETFD and F_SETFD.  Note that the SLEAZY- prefix on the
  ;;; CALL/FDES isn't an optimisation; it's *required* for the correct behaviour
--- 919,930 ----
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
! (define-stubless-foreign %set-cloexec (fd val) "set_cloexec")
  
  ;;; Some of fcntl()
  ;;;;;;;;;;;;;;;;;;;
  
! (define-stubless-foreign %fcntl-read (fd command) "fcntl_read")
! (define-stubless-foreign %fcntl-write (fd command val) "fcntl_write")
  
  ;;; fcntl()'s F_GETFD and F_SETFD.  Note that the SLEAZY- prefix on the
  ;;; CALL/FDES isn't an optimisation; it's *required* for the correct behaviour
***************
*** 1020,1025 ****
    desc)
  
! (define-foreign %gethostname (scm_gethostname)
!   desc)
  
  (define system-name %gethostname)
--- 974,978 ----
    desc)
  
! (define-stubless-foreign %gethostname () "scm_gethostname")
  
  (define system-name %gethostname)
***************
*** 1028,1033 ****
    static-string)
  
! (define-foreign %crypt (scm_crypt (desc key) (desc salt))
!   desc)
  
  (define (crypt key salt)
--- 981,985 ----
    static-string)
  
! (define-stubless-foreign %crypt (key salt) "scm_crypt")
  
  (define (crypt key salt)

Index: syscalls1.c
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls1.c,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -r1.10 -r1.11
*** syscalls1.c 2000/09/01 07:06:38     1.10
--- syscalls1.c 2000/09/19 08:08:39     1.11
***************
*** 121,161 ****
  }
  
  
  /* Random file and I/O stuff
  
*******************************************************************************
  */
  
! /* Returns [errno, r, w] */
! int scheme_pipe(int *r, int *w)
  {
    int fds[2];
!   if( pipe(fds) ) {
!     *r = 0; *w = 0;
!     return errno;
!   }
! 
!   *r = fds[0]; *w = fds[1];
!   return 0;
  }
- 
  
! /* Read the symlink into static memory. Return NULL on error. */
  
! // JMG:  static char linkpath[MAXPATHLEN+1]; /*  Maybe unaligned. Not 
reentrant. */
  
! s48_value scm_readlink(const char *path, s48_value *ret_string)
  {
    char linkpath[MAXPATHLEN+1];
    int retval = readlink(path, linkpath, MAXPATHLEN);
!   if (retval != -1){
!     linkpath[retval] = '\0';
!     *ret_string = s48_enter_string(linkpath);
!     return S48_FALSE;
!   }
!   return s48_enter_fixnum(errno);
  }
  
  
- 
  /* Scheme interfaces to utime(). 
  ** Complicated by need to pass real 32-bit quantities.
--- 121,186 ----
  }
  
+ s48_value scsh_exit(s48_value status)
+ {
+     exit(s48_extract_fixnum(status));
+     return S48_FALSE;
+ }
+ 
+ s48_value scsh__exit(s48_value status)
+ {
+     _exit(s48_extract_fixnum(status));
+     return S48_FALSE;
+ }
  
+ s48_value scsh_fork()
+ {
+   pid_t pid = fork();
+   if (pid == -1)
+     s48_raise_os_error(errno);
+   else return s48_enter_fixnum (pid);
+ }
+ 
  /* Random file and I/O stuff
  
*******************************************************************************
  */
  
! /* Returns (r w) */
! s48_value scheme_pipe()
  {
    int fds[2];
!   if(pipe(fds) == -1) 
!     s48_raise_os_error(errno);
!   else
!     return s48_cons (s48_enter_fixnum (fds[0]),
!                    s48_cons (s48_enter_fixnum (fds [1]),
!                              S48_NULL));
  }
  
! s48_value scsh_kill (s48_value pid, s48_value signal)
! {
!   int ret = kill ((pid_t) s48_extract_fixnum (pid),
!                 s48_extract_fixnum (signal));
!   if (ret == -1)
!     s48_raise_os_error(errno);
!   else return s48_enter_fixnum (ret);
! }
!   
  
! /* Read the symlink. */
  
! s48_value scm_readlink(s48_value path)
  {
    char linkpath[MAXPATHLEN+1];
    int retval = readlink(path, linkpath, MAXPATHLEN);
!   if (retval == -1)
!     s48_raise_os_error(errno);
!   else
!     {
!       linkpath[retval] = '\0';
!       return s48_enter_string(linkpath);
!     }
  }
  
  
  /* Scheme interfaces to utime(). 
  ** Complicated by need to pass real 32-bit quantities.
***************
*** 173,188 ****
  
  
! int set_cloexec(int fd, int val)
  {
    int flags = fcntl(fd, F_GETFD);
!   if( flags == -1 ) return errno;
    val = -val; /* 0 -> 0 and 1 -> -1 */
  
    /* If it's already what we want, just return. */
!   if( (flags & FD_CLOEXEC) == (FD_CLOEXEC & val) ) return 0;
  
    flags = (flags & ~FD_CLOEXEC) | (val & FD_CLOEXEC);
!   return fcntl(fd, F_SETFD, flags) ? errno : 0;
!   }
  
  
--- 198,217 ----
  
  
! s48_value set_cloexec(s48_value _fd, s48_value _val)
  {
+   int fd = s48_extract_fixnum (_fd);
+   int val = (_val == S48_TRUE) ? 1 : 0;
    int flags = fcntl(fd, F_GETFD);
!   if( flags == -1 ) s48_raise_os_error(errno);
    val = -val; /* 0 -> 0 and 1 -> -1 */
  
    /* If it's already what we want, just return. */
!   if( (flags & FD_CLOEXEC) == (FD_CLOEXEC & val) ) return S48_FALSE;
  
    flags = (flags & ~FD_CLOEXEC) | (val & FD_CLOEXEC);
!   if (fcntl(fd, F_SETFD, flags) == -1)
!     s48_raise_os_error(errno);
!   else return S48_FALSE;
! }
  
  
***************
*** 662,671 ****
  */
  
! int fcntl_read(int fd, int command)
! { return fcntl(fd, command); }
  
  
! int fcntl_write(int fd, int command, int value)
! { return fcntl(fd, command, value); }
  
  /* crypt()
--- 691,713 ----
  */
  
! s48_value fcntl_read(s48_value fd, s48_value command)
! { 
!   int ret = fcntl(s48_extract_fixnum (fd), 
!                                s48_extract_integer (command)); 
!   if (ret == -1)
!     s48_raise_os_error(errno);
!   else return s48_enter_fixnum (ret); 
! }
  
  
! s48_value fcntl_write(s48_value fd, s48_value command, s48_value value)
! { 
!   int ret = fcntl(s48_extract_fixnum (fd), 
!                 s48_extract_integer (command), 
!                 s48_extract_integer (value));
!   if (ret == -1)
!     s48_raise_os_error(errno);
!   else return s48_enter_fixnum (ret); 
! }
  
  /* crypt()

Index: syscalls1.h
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls1.h,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -r1.9 -r1.10
*** syscalls1.h 2000/07/27 13:32:12     1.9
--- syscalls1.h 2000/09/19 08:08:39     1.10
***************
*** 5,10 ****
  int scheme_exec(const char *prog, s48_value argv, s48_value env);
  
! int scheme_pipe(int *r, int *w);
  
  s48_value scm_readlink(const char *path, s48_value*);
  
--- 5,18 ----
  int scheme_exec(const char *prog, s48_value argv, s48_value env);
  
! s48_value scsh_exit (s48_value status);
  
+ s48_value scsh__exit (s48_value status);
+ 
+ s48_value scsh_fork ();
+ 
+ s48_value scheme_pipe();
+ 
+ s48_value scsh_kill (s48_value pid, s48_value signal);
+ 
  s48_value scm_readlink(const char *path, s48_value*);
  
***************
*** 52,58 ****
  char *errno_msg(int i);
  
! int fcntl_read(int fd, int command);
  
! int fcntl_write(int fd, int command, int value);
  
  s48_value scm_crypt(s48_value key, s48_value salt);
--- 60,66 ----
  char *errno_msg(int i);
  
! s48_value fcntl_read(s48_value fd, s48_value command);
  
! s48_value fcntl_write(s48_value fd, s48_value command, s48_value value);
  
  s48_value scm_crypt(s48_value key, s48_value salt);