Ported some functions to new FFI.

scsh/syscalls.scm

@@ -82,15 +82,10 @@
 
 ;;; Process
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-foreign %%exec/errno
-  (scheme_exec (string prog)
-	       (vector-desc argv)
-	       (desc env)) ; string vector or #t.
-  fixnum)
-
 ;; we can't algin env here, because exec-path/env calls
 ;; %%exec/errno directly  F*&% *P
+(define-stubless-foreign %%exec/errno (prog argv env) "scheme_exec")
+
 (define (%%exec prog argv env)
   (errno-error (%%exec/errno prog argv env) %exec prog argv env)) ; cute.
 
@@ -126,11 +121,7 @@
 
 ;;; Working directory
 
-(define-foreign %chdir/errno
+(define-stubless-foreign %chdir (directory) "scsh_chdir")
-  (chdir (string directory))
-  (to-scheme fixnum errno_or_false))
-
-(define-errno-syscall (%chdir dir) %chdir/errno)
 
 ;;; These calls change/reveal the process working directory
 ;;; 
@@ -139,54 +130,29 @@
   (let ((dir (:optional maybe-dir (home-dir))))
     (%chdir (ensure-file-name-is-nondirectory dir))))
 
-
+;; TODO: we get an error if cwd does not exist on startup
-(define-foreign cwd/errno (scheme_cwd)
+(define-stubless-foreign process-cwd () "scheme_cwd")
-  (to-scheme fixnum "False_on_zero") ; errno or #f
-  string) ; directory (or #f on error)
-
-(define-errno-syscall (process-cwd) cwd/errno
-  dir)
-
 
 ;;; GID
 
-(define-foreign user-gid  (getgid) gid_t)
+(define-stubless-foreign user-gid  () "scsh_getgid")
-(define-foreign user-effective-gid (getegid) gid_t)
 
-(define-foreign set-gid/errno (setgid (gid_t id)) no-declare ; for SunOS 4.x 
+(define-stubless-foreign user-effective-gid () "scsh_getegid")
-  (to-scheme fixnum errno_or_false))
 
-(define-errno-syscall (set-gid gid) set-gid/errno)
+(define-stubless-foreign set-gid (gid) "scsh_setgid")
 
-(define-foreign %num-supplementary-gids/errno (num_supp_groups)
+(define-stubless-foreign set-effective-gid (gid) "scsh_setegid")
-  (multi-rep (to-scheme fixnum errno_or_false)
-	     gid_t))
-
-(define-foreign load-groups/errno (get_groups (vector-desc group-vec))
-  (multi-rep (to-scheme fixnum errno_or_false)
-	     fixnum))
-
-(define (user-supplementary-gids)
-  (receive (err numgroups) (%num-supplementary-gids/errno)
-    (if err (errno-error err user-supplementary-gids)
-	(let ((vec (make-vector numgroups)))
-	  (receive (err numgroups2) (load-groups/errno vec)
-	    (if err (errno-error err user-supplementary-gids)
-		(vector->list vec)))))))
 
+(define-stubless-foreign user-supplementary-gids () "get_groups")
 
 ;;; UID
+(define-stubless-foreign user-uid  () "scsh_getuid")
 
-(define-foreign user-uid		(getuid)  uid_t)
+(define-stubless-foreign user-effective-uid () "scsh_geteuid")
-(define-foreign user-effective-uid 	(geteuid) uid_t)
 
-(define-foreign set-uid/errno (setuid (uid_t id)) no-declare ; for SunOS 4.x
+(define-stubless-foreign set-uid (uid) "scsh_setuid")
-  (to-scheme fixnum errno_or_false))
 
-(define-errno-syscall (set-uid uid_t) set-uid/errno)
+(define-stubless-foreign set-effective-uid (uid) "scsh_seteuid")
-
-;;(define-foreign %user-login-name (my_username)
-;;  static-string)
 
 (import-lambda-definition %user-login-name () "my_username")
  
@@ -399,17 +365,9 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; STAT
 
-(define-foreign stat-file/errno
+(define-stubless-foreign stat-file (path data chase?) "scheme_stat")
-  (scheme_stat (string path) (vector-desc data) (bool chase?))
-  (to-scheme fixnum "False_on_zero")) ; errno or #f
 
-;(define-errno-syscall (stat-file fd data chase?) stat-file/errno)
+(define-stubless-foreign stat-fdes (fd data) "scheme_fstat")
-
-(define-foreign stat-fdes/errno
-  (scheme_fstat (integer fd) (vector-desc data))
-  (to-scheme fixnum "False_on_zero")) ; errno or #f
-
-;(define-errno-syscall (stat-fdes fd data) stat-fdes/errno)
 
 (define-record file-info
   type
@@ -427,21 +385,18 @@
 
 
 ;;; Should be redone to return multiple-values.
-(define (file-info/errno fd/port/fname chase?)
+(define (%file-info fd/port/fname chase?)
   (let ((ans-vec (make-vector 11))
 	(file-type (lambda (type-code)
 		     (vector-ref '#(block-special char-special directory fifo
 						  regular socket symlink)
 				 type-code))))
-
+    (generic-file-op fd/port/fname
-    (cond ((generic-file-op fd/port/fname
 		     (lambda (fd)
-			      (stat-fdes/errno fd ans-vec))
+		       (stat-fdes fd ans-vec))
 		     (lambda (fname)
-			      (stat-file/errno fname ans-vec chase?)))
+		       (stat-file fname ans-vec chase?)))
-	   => (lambda (err) (values err #f)))
+    (make-file-info (file-type (vector-ref ans-vec 0))
-
-	  (else (values #f (make-file-info (file-type (vector-ref ans-vec 0))
 		    (vector-ref ans-vec 1)
 		    (vector-ref ans-vec 2)
 		    (vector-ref ans-vec 3)
@@ -451,15 +406,13 @@
 		    (vector-ref ans-vec 7)
 		    (vector-ref ans-vec 8)
 		    (vector-ref ans-vec 9)
-					   (vector-ref ans-vec 10)))))))
+		    (vector-ref ans-vec 10))))
 						      
 		
 (define (file-info fd/port/fname . maybe-chase?)
  (with-cwd-aligned
    (let ((chase? (:optional maybe-chase? #t)))
-     (receive (err info) (file-info/errno fd/port/fname chase?)
+     (%file-info fd/port/fname chase?))))
-	      (if err (errno-error err file-info fd/port/fname chase?)
-		  info)))))
 
 
 (define file-attributes

scsh/syscalls1.c

@@ -79,7 +79,7 @@ s48_value wait_pid(s48_value s48_pid, s48_value s48_flags)
 ** on the Scheme side.
 */
 
-int scheme_exec(const char *prog, s48_value argv, s48_value env)
+s48_value scheme_exec(s48_value prog, s48_value argv, s48_value env)
 {
   int i, j, e;
   int argc = S48_VECTOR_LENGTH(argv);
@@ -87,11 +87,11 @@ int scheme_exec(const char *prog, s48_value argv, s48_value env)
   char **unix_argv = Malloc(char*, argc+1);
   char **unix_env;
 
-  if( unix_argv == NULL ) return errno;
+  if( unix_argv == NULL ) s48_raise_os_error_3(errno, prog, argv, env);
 
   /* Scheme->Unix convert the argv parameter. */
   for(i=0; i<argc; i++)
-    unix_argv[i] = cig_string_body(S48_VECTOR_REF(argv,i));
+    unix_argv[i] = s48_extract_string(S48_VECTOR_REF(argv,i));
   unix_argv[argc] = NULL;
 
   /* Scheme->Unix convert the env parameter. */
@@ -100,24 +100,28 @@ int scheme_exec(const char *prog, s48_value argv, s48_value env)
     int envlen = S48_VECTOR_LENGTH(env);
     unix_env = Malloc(char*, envlen+1);
 
-    if( !unix_env ) goto lose;
+    if( !unix_env ){
+      Free(unix_argv);
+      s48_raise_os_error_3(errno, prog, argv, env);
+    }
 
     for(j=0; j<envlen; j++)
-      unix_env[j] = cig_string_body(S48_VECTOR_REF(env,j));
+      unix_env[j] = s48_extract_string(S48_VECTOR_REF(env,j));
     unix_env[envlen] = NULL;
   }
 
-  execve(prog, unix_argv, unix_env); /* Do it. */
+  execve(s48_extract_string (prog), unix_argv, unix_env); /* Do it. */
 
   if( env != S48_TRUE ) {
     e = errno;
     Free(unix_env);
     errno = e;
   }
- lose:
   e = errno;
   Free(unix_argv);
-  return e;
+  errno = e;
+  return s48_enter_fixnum(errno); // Don't raise an exception since
+                                  // we're maybe just testing the path
 }
 
 s48_value scsh_exit(s48_value status)
@@ -161,7 +165,7 @@ 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);
+    s48_raise_os_error_2(errno, pid, signal);
   else return s48_enter_fixnum (ret);
 }
   
@@ -173,7 +177,7 @@ s48_value scm_readlink(s48_value path)
   char linkpath[MAXPATHLEN+1];
   int retval = readlink(s48_extract_string (path), linkpath, MAXPATHLEN);
   if (retval == -1)
-    s48_raise_os_error(errno);
+    s48_raise_os_error_1(errno, path);
   else
     {
       linkpath[retval] = '\0';
@@ -202,7 +206,7 @@ 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);
+  if( flags == -1 ) s48_raise_os_error_2(errno, _fd, _val);
   val = -val;	/* 0 -> 0 and 1 -> -1 */
 
   /* If it's already what we want, just return. */
@@ -210,10 +214,16 @@ s48_value set_cloexec(s48_value _fd, s48_value _val)
 
   flags = (flags & ~FD_CLOEXEC) | (val & FD_CLOEXEC);
   if (fcntl(fd, F_SETFD, flags) == -1)
-    s48_raise_os_error(errno);
+    s48_raise_os_error_2(errno, _fd, _val);
   else return S48_FALSE;
 }
 
+s48_value scsh_chdir(s48_value directory){
+  int retval = chdir (s48_extract_string (directory));
+  if (retval == -1)
+    s48_raise_os_error_1(errno, directory);
+  return S48_TRUE;
+}
 
 /* Two versions of CWD
 *******************************************************************************
@@ -231,7 +241,7 @@ s48_value set_cloexec(s48_value _fd, s48_value _val)
 #endif
 
 /* Simple-minded POSIX version. */
-int scheme_cwd(const char **dirp)
+s48_value scheme_cwd()
 {
   char *buf;
   int size = scsh_path_max + 1; /* +1 for terminating nul byte... */
@@ -248,40 +258,15 @@ int scheme_cwd(const char **dirp)
       buf = nbuf;
     }
 
-  *dirp = (const char*) buf;		/* win */
+  return s48_enter_string(buf);		/* win */
-  return 0;
 
  lose:
   {int e = errno;
    Free(buf);
-   *dirp = 0;
+   errno = e,
-   return e;}
+   s48_raise_os_error(errno);}
 }
 
-
-#if 0
-/* Faster SUNOS version. */
-/* We have to use malloc, because the stub is going to free the string. */
-
-int scheme_cwd(const char **dirp)
-{
-  char *buf = Malloc(char,MAXPATHLEN); 
-  int e;
-
-  if( buf && getwd(buf) ) {
-    *dirp = (const char*) buf;
-    return 0;
-  }
-
-  /* lose */
-  e = errno;
-  Free(buf);
-  *dirp = 0;
-  return e;
-}
-#endif
-
-
 /* Process times
 *******************************************************************************
 */
@@ -365,12 +350,10 @@ ssize_t write_fdes_substring(s48_value buf, size_t start, size_t end, int fd)
 */
 
 /* Internal aux function -- loads stat values into Scheme vector: */
-static int really_stat(int retval, struct stat *s, s48_value vec)
+s48_value really_stat(struct stat *s, s48_value vec)
 {
   int modes, typecode = -1;
   S48_DECLARE_GC_PROTECT(1);
-  if( 11 != S48_VECTOR_LENGTH(vec) ) return -1;
-  if( retval < 0 ) return errno;
  
   S48_GC_PROTECT_1(vec);
  
@@ -399,19 +382,26 @@ static int really_stat(int retval, struct stat *s, s48_value vec)
      These aren't POSIX, and, e.g., are not around on SGI machines.
      Too bad -- blksize is useful. Unix sux. */
   S48_GC_UNPROTECT();
-  return 0;
+  return S48_UNSPECIFIC;
 }
 
-int scheme_stat(const char *path, s48_value vec, int chase_p)
+s48_value scheme_stat(s48_value path, s48_value vec, s48_value chase_p)
 {
   struct stat s;
-  return really_stat(chase_p ? stat(path, &s) : lstat(path, &s), &s, vec);
+  const char * cp_path = s48_extract_string(path);
+  int retval = (chase_p != S48_FALSE) ? stat(cp_path, &s) : lstat(cp_path, &s);
+
+  if (retval == -1) s48_raise_os_error_2 (errno, path, chase_p);
+
+  return really_stat (&s, vec);
 }
 
-int scheme_fstat(int fd, s48_value vec)
+s48_value scheme_fstat(s48_value fd, s48_value vec)
 {
   struct stat s;
-  return really_stat(fstat(fd,&s), &s, vec);
+  int retval = fstat (s48_extract_fixnum (fd), &s);
+  if (retval == -1) s48_raise_os_error_1 (errno, fd);
+  return really_stat (&s, vec);
 }
 
 
@@ -419,32 +409,89 @@ int scheme_fstat(int fd, s48_value vec)
 *******************************************************************************
 */
 
-int num_supp_groups(void)
+s48_value scsh_getgid()
 {
-  return getgroups(0,NULL);
+  return s48_enter_integer(getgid());
 }
 
-/* Load the supplementary groups into GVEC. */
+s48_value scsh_getegid()
-
-int get_groups(s48_value gvec)
 {
-  int veclen = S48_VECTOR_LENGTH(gvec), i, retval;
+  return s48_enter_integer(getegid());
+}
+
+s48_value scsh_setgid(s48_value gid)
+{
+  int retval = setgid (s48_extract_integer (gid));
+  if (retval == -1)
+    s48_raise_os_error_1(errno, gid);
+  return S48_UNSPECIFIC;
+}
+
+s48_value scsh_setegid(s48_value gid)
+{
+  int retval = setegid (s48_extract_integer (gid));
+  if (retval == -1)
+    s48_raise_os_error_1(errno, gid);
+  return S48_UNSPECIFIC;
+}
+
+/* Load the supplementary groups into a list */
+
+s48_value get_groups()
+{
+  int retval;
+  int veclen = getgroups(0,NULL);
+  int i = veclen;
+  s48_value l = S48_NULL;
   gid_t gvec0[20], *gp = gvec0;
 
   if( veclen > 20 )
-    if( NULL == (gp=Malloc(gid_t,veclen)) ) return -1;
+    if (NULL == (gp=Malloc(gid_t,veclen))) s48_raise_os_error(errno);
 
   retval = getgroups(veclen, gp);
 
-  if( retval != -1 )
+  if (retval == -1){
-    for( i=veclen; i--; )
+    if (veclen > 20) Free(gp);
-      S48_VECTOR_SET(gvec,i, s48_enter_fixnum(gp[i]));
+    s48_raise_os_error(errno);
+  }
+  else if (retval != veclen){     // paranoia...
+    get_groups();
+  }
+  else{
+    while (i > 0){
+      l = s48_cons(s48_enter_integer(gp[--i]), l);
+    }
     
-  if( veclen > 20 ) Free(gp);
+    if (veclen > 20) Free(gp);
     
-  return retval;
+    return l;
+  }
+}
+s48_value scsh_getuid()
+{
+  return s48_enter_integer(getuid());
 }
 
+s48_value scsh_geteuid()
+{
+  return s48_enter_integer(geteuid());
+}
+
+s48_value scsh_setuid(s48_value uid)
+{
+  int retval = setuid (s48_extract_integer (uid));
+  if (retval == -1)
+    s48_raise_os_error_1(errno, uid);
+  return S48_UNSPECIFIC;
+}
+
+s48_value scsh_seteuid(s48_value uid)
+{
+  int retval = seteuid (s48_extract_integer (uid));
+  if (retval == -1)
+    s48_raise_os_error_1(errno, uid);
+  return S48_UNSPECIFIC;
+}
     
 /* Environment hackery
 *******************************************************************************
@@ -663,7 +710,8 @@ s48_value scm_gethostname(void)
    char hostname[MAXHOSTNAMELEN+1]; 
     /* different OS's declare differently, so punt the prototype. */
     int gethostname(); 
-    gethostname(hostname, MAXHOSTNAMELEN);
+    int retval = gethostname(hostname, MAXHOSTNAMELEN);
+    if (retval == -1) s48_raise_os_error(errno);
     return s48_enter_string(hostname);
 }
 
@@ -695,7 +743,7 @@ 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);
+    s48_raise_os_error_2(errno, fd, command);
   else return s48_enter_fixnum (ret); 
 }
 
@@ -706,7 +754,7 @@ s48_value fcntl_write(s48_value fd, s48_value command, s48_value value)
 		  s48_extract_integer (command), 
 		  s48_extract_integer (value));
   if (ret == -1)
-    s48_raise_os_error(errno);
+    s48_raise_os_error_3(errno, fd, command, value);
   else return s48_enter_fixnum (ret); 
 }
 

scsh/syscalls1.h

@@ -2,7 +2,7 @@
 
 s48_value wait_pid(s48_value pid, s48_value flags);
 
-int scheme_exec(const char *prog, s48_value argv, s48_value env);
+s48_value scheme_exec(s48_value prog, s48_value argv, s48_value env);
 
 s48_value scsh_exit (s48_value status);
 
@@ -22,7 +22,9 @@ int scm_utime_now(char const *path);
 
 s48_value set_cloexec(s48_value _fd, s48_value _val);
 
-int scheme_cwd(const char **dirp);
+s48_value scsh_chdir(s48_value directory);
+
+s48_value scheme_cwd();
 
 int process_times(clock_t *utime, clock_t *stime, 
 		  clock_t *cutime, clock_t *cstime);
@@ -41,13 +43,27 @@ ssize_t write_fdes_substring(s48_value buf, size_t start, size_t end, int fd);
 
 int write_stream_substring(s48_value buf, int start, int end, FILE *f);
 
-int scheme_stat(const char *path, s48_value vec, int chase_p);
+s48_value scheme_stat(s48_value path, s48_value vec, s48_value chase_p);
 
-int scheme_fstat(int fd, s48_value vec);
+s48_value scheme_fstat(s48_value fd, s48_value vec);
 
-int num_supp_groups(void);
+s48_value scsh_getgid();
 
-int get_groups(s48_value gvec);
+s48_value scsh_getegid();
+
+s48_value scsh_setgid(s48_value gid);
+
+s48_value scsh_setegid(s48_value gid);
+
+s48_value get_groups();
+
+s48_value scsh_getuid();
+
+s48_value scsh_geteuid();
+
+s48_value scsh_setuid(s48_value uid);
+
+s48_value scsh_seteuid(s48_value uid);
 
 int put_env(const char *s);