Replaced many define-foreign by define-stubless-foreign

scsh/syscalls.scm

@@ -101,36 +101,18 @@
     (%%exec prog argv env)))
 
 
-(define-foreign exit/errno ; errno -- misnomer.
+(define-stubless-foreign exit/errno ; errno -- misnomer.
-  (exit (fixnum status))
+  (status) "scsh_exit")
-  ignore)
 
 (define-foreign %exit/errno ; errno -- misnomer
-  (_exit (fixnum status))
+  (status) "scsh__exit")
-  ignore)
 
 (define (%exit . maybe-status)
   (%exit/errno (:optional maybe-status 0))
   (error "Yikes! %exit returned."))
 
 
-(define-foreign %%fork/errno (fork)
+(define-stubless-foreign %%fork () "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.
 (define-stubless-foreign %wait-pid/errno-list (pid options)
@@ -372,17 +354,7 @@
            (lambda (err)
 	     (if err (errno-error err create-directory path mode)))))))
 
-
+(define-stubless-foreign read-symlink (path) "scm_readlink")
-(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))
@@ -624,21 +596,16 @@
      (%open path flags (:optional maybe-mode #o666))))
 
 
-(define-foreign pipe-fdes/errno (scheme_pipe)
+(define-stubless-foreign pipe-fdes () "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)
+  (apply (pipe-fdes) 
-    (let ((r (fdes->inport  r-fd))
+	 (lambda (r-fd w-fd)
-	  (w (fdes->outport w-fd)))
+	   (let ((r (fdes->inport  r-fd))
-      (release-port-handle r)
+		 (w (fdes->outport w-fd)))
-      (release-port-handle w)
+	     (release-port-handle r)
-      (values r w))))
+	     (release-port-handle w)
+	     (values r w)))))
 
 (define-foreign %read-fdes-char
   (read_fdes_char (fixnum fd))
@@ -678,11 +645,7 @@
 ;;; Signals (rather incomplete)
 ;;; ---------------------------
 
-(define-foreign signal-pid/errno
+(define-stubless-foreign signal-pid (pid signal) "scsh_kill")
-  (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)
   (signal-pid (cond ((proc? proc)    (proc:pid proc))
@@ -955,22 +918,13 @@
 ;;; Fd-ports
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define-foreign %set-cloexec (set_cloexec (fixnum fd) (bool val))
+(define-stubless-foreign %set-cloexec (fd val) "set_cloexec")
-  (to-scheme fixnum "errno_or_false"))
 
 ;;; Some of fcntl()
 ;;;;;;;;;;;;;;;;;;;
 
-(define-foreign %fcntl-read/errno (fcntl_read (fixnum fd) (fixnum command))
+(define-stubless-foreign %fcntl-read (fd command) "fcntl_read")
-  (multi-rep (to-scheme fixnum errno_or_false)
+(define-stubless-foreign %fcntl-write (fd command val) "fcntl_write")
-	     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
@@ -1019,16 +973,14 @@
 (define-foreign %sleep-until (sleep_until (time_t secs))
   desc)
 
-(define-foreign %gethostname (scm_gethostname)
+(define-stubless-foreign %gethostname () "scm_gethostname")
-  desc)
 
 (define system-name %gethostname)
 
 (define-foreign errno-msg (errno_msg (integer i))
   static-string)
 
-(define-foreign %crypt (scm_crypt (desc key) (desc salt))
+(define-stubless-foreign %crypt (key salt) "scm_crypt")
-  desc)
 
 (define (crypt key salt)
   (let* ((allowed-char-set  (rx (| alpha digit "." "/")))

scsh/syscalls1.c

@@ -120,43 +120,68 @@ int scheme_exec(const char *prog, s48_value argv, s48_value env)
   return e;
 }
 
+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 [errno, r, w] */
+/* Returns (r w) */
-int scheme_pipe(int *r, int *w)
+s48_value scheme_pipe()
 {
   int fds[2];
-  if( pipe(fds) ) {
+  if(pipe(fds) == -1) 
-    *r = 0; *w = 0;
+    s48_raise_os_error(errno);
-    return errno;
+  else
-  }
+    return s48_cons (s48_enter_fixnum (fds[0]),
-
+		     s48_cons (s48_enter_fixnum (fds [1]),
-  *r = fds[0]; *w = fds[1];
+			       S48_NULL));
-  return 0;
 }
 
+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 into static memory. Return NULL on error. */
+/* Read the symlink. */
 
-// JMG:  static char linkpath[MAXPATHLEN+1]; /*  Maybe unaligned. Not reentrant. */
+s48_value scm_readlink(s48_value path)
-
-s48_value scm_readlink(const char *path, s48_value *ret_string)
 {
   char linkpath[MAXPATHLEN+1];
   int retval = readlink(path, linkpath, MAXPATHLEN);
-  if (retval != -1){
+  if (retval == -1)
-    linkpath[retval] = '\0';
+    s48_raise_os_error(errno);
-    *ret_string = s48_enter_string(linkpath);
+  else
-    return S48_FALSE;
+    {
-  }
+      linkpath[retval] = '\0';
-  return s48_enter_fixnum(errno);
+      return s48_enter_string(linkpath);
+    }
 }
 
 
-
 /* Scheme interfaces to utime(). 
 ** Complicated by need to pass real 32-bit quantities.
 */
@@ -172,18 +197,22 @@ int scm_utime(char const *path, time_t ac, time_t mod)
 int scm_utime_now(char const *path) {return utime(path, 0);}
 
 
-int set_cloexec(int fd, int val)
+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 ) return errno;
+  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 0;
+  if( (flags & FD_CLOEXEC) == (FD_CLOEXEC & val) ) return S48_FALSE;
 
   flags = (flags & ~FD_CLOEXEC) | (val & FD_CLOEXEC);
-  return fcntl(fd, F_SETFD, flags) ? errno : 0;
+  if (fcntl(fd, F_SETFD, flags) == -1)
-  }
+    s48_raise_os_error(errno);
+  else return S48_FALSE;
+}
 
 
 /* Two versions of CWD
@@ -661,12 +690,25 @@ char *errno_msg(int i)
 ******************
 */
 
-int fcntl_read(int fd, int command)
+s48_value fcntl_read(s48_value fd, s48_value command)
-{ return fcntl(fd, 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); 
+}
 
 
-int fcntl_write(int fd, int command, int value)
+s48_value fcntl_write(s48_value fd, s48_value command, s48_value value)
-{ return fcntl(fd, command, 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()
 ******************

scsh/syscalls1.h

@@ -4,7 +4,15 @@ s48_value wait_pid(s48_value pid, s48_value flags);
 
 int scheme_exec(const char *prog, s48_value argv, s48_value env);
 
-int scheme_pipe(int *r, int *w);
+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*);
 
@@ -51,8 +59,8 @@ s48_value scm_gethostname(void);
 
 char *errno_msg(int i);
 
-int fcntl_read(int fd, int command);
+s48_value fcntl_read(s48_value fd, s48_value command);
 
-int fcntl_write(int fd, int command, int value);
+s48_value fcntl_write(s48_value fd, s48_value command, s48_value value);
 
 s48_value scm_crypt(s48_value key, s48_value salt);