Import Upstream version 5d9upstream/5d9

1 files changed, 178 insertions, 49 deletions

diff --git a/ioext.c b/ioext.c
index 62ec8b2..6a8e6e1 100644
--- a/ioext.c
+++ b/ioext.c
@@ -70,6 +70,9 @@ SCM	stat2scm P((struct stat *stat_temp));
 #ifdef __FreeBSD__
 # include <unistd.h>
 #endif
+#ifdef __NetBSD__
+# include <unistd.h>
+#endif
 #ifdef __OpenBSD__
 # include <unistd.h>
 #endif
@@ -134,7 +137,7 @@ SCM read_line(port)
   SCM tok_buf = makstr((long) len);
   register char *p = CHARS(tok_buf);
   if UNBNDP(port) port = cur_inp;
-  else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_line);
+  else ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_line);
   if (EOF==(c = lgetc(port))) return EOF_VAL;
   while(1) {
     switch (c) {
@@ -161,11 +164,11 @@ SCM read_line1(str, port)
   register int j = 0;
   register char *p;
   sizet len;
-  ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_read_line1);
+  ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_read_line1);
   p = CHARS(str);
   len = LENGTH(str);
   if UNBNDP(port) port = cur_inp;
-  else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG2, s_read_line1);
+  else ASRTER(NIMP(port) && OPINPORTP(port), port, ARG2, s_read_line1);
   c = lgetc(port);
   if (EOF==c) return EOF_VAL;
   while(1) {
@@ -197,7 +200,7 @@ SCM file_position(port)
      SCM port;
 {
 	long ans;
-	ASSERT(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_position);
+	ASRTER(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_position);
 	SYSCALL(ans = ftell(STREAM(port)););
 	if CRDYP(port) ans--;
 	return MAKINUM(ans);
@@ -206,7 +209,7 @@ SCM file_set_position(port, pos)
      SCM port, pos;
 {
 	SCM ans;
-	ASSERT(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_set_pos);
+	ASRTER(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_set_pos);
 #ifndef RECKLESS
 	if (TRACKED & SCM_PORTFLAGS(port)) {
 	  if (INUM0==pos) {
@@ -226,7 +229,7 @@ SCM file_set_position(port, pos)
 #ifdef HAVE_PIPE
 # ifdef ESPIPE
 	if (!OPIOPORTP(port))
-	  ASSERT(ESPIPE != errno, port, ARG1, s_file_set_pos);
+	  ASRTER(ESPIPE != errno, port, ARG1, s_file_set_pos);
 # endif
 #endif
 	return ans;
@@ -239,12 +242,12 @@ SCM reopen_file(filename, modes, port)
   FILE *f;
   char cmodes[4];
   long flags;
-  ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_reopen_file);
-  ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_reopen_file);
+  ASRTER(NIMP(filename) && STRINGP(filename), filename, ARG1, s_reopen_file);
+  ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_reopen_file);
   flags =  mode_bits(CHARS(modes), cmodes);
-  ASSERT(flags, modes, ARG2, s_reopen_file);
+  ASRTER(flags, modes, ARG2, s_reopen_file);
   DEFER_INTS;
-  ASSERT(NIMP(port) && FPORTP(port) && OPENP(port), port, ARG3, s_reopen_file);
+  ASRTER(NIMP(port) && FPORTP(port) && OPENP(port), port, ARG3, s_reopen_file);
   SCM_OPENCALL(f = freopen(CHARS(filename), cmodes, STREAM(port)));
   if (!f) {
     ALLOW_INTS;
@@ -272,10 +275,10 @@ SCM l_dup(oldpt, modes)
   int tfd;
   FILE *f;
   SCM newpt;
-  ASSERT(NIMP(oldpt) && OPFPORTP(oldpt), oldpt, ARG1, s_dup);
-  ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_dup);
+  ASRTER(NIMP(oldpt) && OPFPORTP(oldpt), oldpt, ARG1, s_dup);
+  ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_dup);
   flags = mode_bits(CHARS(modes), cmodes);
-  ASSERT(flags, modes, ARG2, s_dup);
+  ASRTER(flags, modes, ARG2, s_dup);
   NEWCELL(newpt);
   DEFER_INTS;
   SCM_OPENCALL(tfd = dup(fileno(STREAM(oldpt))));
@@ -303,8 +306,8 @@ SCM l_dup2(into_pt, from_pt)
 {
   int ans, oldfd, newfd;
   DEFER_INTS;
-  ASSERT(NIMP(into_pt) && OPFPORTP(into_pt), into_pt, ARG1, s_dup2);
-  ASSERT(NIMP(from_pt) && OPFPORTP(from_pt), from_pt, ARG1, s_dup2);
+  ASRTER(NIMP(into_pt) && OPFPORTP(into_pt), into_pt, ARG1, s_dup2);
+  ASRTER(NIMP(from_pt) && OPFPORTP(from_pt), from_pt, ARG1, s_dup2);
   oldfd = fileno(STREAM(into_pt));
   newfd = fileno(STREAM(from_pt));
   SCM_OPENCALL(ans = dup2(oldfd, newfd));
@@ -315,15 +318,18 @@ SCM l_dup2(into_pt, from_pt)
 # endif
 
 # ifndef vms
+static char s_opendir[]="opendir";
+static char s_readdir[]="readdir";
+static char s_rewinddir[]="rewinddir";
+static char s_closedir[]="closedir";
 #  ifndef _WIN32
 #   include <dirent.h>
-static char s_opendir[]="opendir";
 SCM l_opendir(dirname)
      SCM dirname;
 {
   DIR *ds;
   SCM dir;
-  ASSERT(NIMP(dirname) && STRINGP(dirname), dirname, ARG1, s_opendir);
+  ASRTER(NIMP(dirname) && STRINGP(dirname), dirname, ARG1, s_opendir);
   NEWCELL(dir);
   DEFER_INTS;
   SCM_OPENCALL(ds = opendir(CHARS(dirname)));
@@ -333,33 +339,33 @@ SCM l_opendir(dirname)
   ALLOW_INTS;
   return dir;
 }
-static char s_readdir[]="readdir";
+
 SCM l_readdir(port)
      SCM port;
 {
   struct dirent *rdent;
   DEFER_INTS;
-  ASSERT(OPDIRP(port), port, ARG1, s_readdir);
+  ASRTER(OPDIRP(port), port, ARG1, s_readdir);
   SYSCALL(rdent = readdir((DIR *)CDR(port)););
   if (!rdent) {ALLOW_INTS; return BOOL_F;}
   ALLOW_INTS;
   /* rdent could be overwritten by another readdir to the same handle */
   return makfrom0str((char *)rdent->d_name);
 }
-static char s_rewinddir[]="rewinddir";
+
 SCM l_rewinddir(port)
      SCM port;
 {
-  ASSERT(OPDIRP(port), port, ARG1, s_rewinddir);
+  ASRTER(OPDIRP(port), port, ARG1, s_rewinddir);
   rewinddir((DIR *)CDR(port));
   return UNSPECIFIED;
 }
-static char s_closedir[]="closedir";
+
 SCM l_closedir(port)
      SCM port;
 {
   int sts;
-  ASSERT(DIRP(port), port, ARG1, s_closedir);
+  ASRTER(DIRP(port), port, ARG1, s_closedir);
   DEFER_INTS;
   if CLOSEDP(port) {ALLOW_INTS;return BOOL_F;}
   SYSCALL(sts = closedir((DIR *)CDR(port)););
@@ -381,10 +387,117 @@ sizet dir_free(p)
   if OPENP((SCM)p) closedir((DIR *)CDR((SCM)p));
   return 0;
 }
+#  define dir_mark mark0
+#  else /* _WIN32 */
+struct WDIR {
+  long handle;                  //-1 if at end of list.
+  struct _finddata_t info;
+  SCM fspec;                  //for rewind, needs gc protection.
+};
 
-long tc16_dir;
-static smobfuns dir_smob = {mark0, dir_free, dir_print, 0};
+SCM l_opendir(dirname)
+     SCM dirname;
+{
+  long handle;
+  SCM fspec, dir;
+  struct _finddata_t info;
+  struct WDIR *wdir;
+  int dlen;
+  ASRTER(NIMP(dirname) && STRINGP(dirname), dirname, ARG1, s_opendir);
+  dlen = LENGTH(dirname);
+  fspec = makstr(dlen + 2);
+  strcpy(CHARS(fspec), CHARS(dirname));
+  if ('/' != CHARS(fspec)[dlen - 1] && '\\' != CHARS(fspec)[dlen - 1])
+    CHARS(fspec)[dlen++] = '/';
+  CHARS(fspec)[dlen++] = '*';
+  CHARS(fspec)[dlen] = 0;
+  DEFER_INTS;
+  dir = must_malloc_cell(sizeof(struct WDIR)+0L, tc16_dir, s_opendir);
+  wdir = (struct WDIR*)CHARS(dir);
+  wdir->fspec = fspec;
+  SCM_OPENCALL(handle = _findfirst(CHARS(fspec), &(wdir->info)));
+  if (-1 == handle) {ALLOW_INTS; return BOOL_F;}
+  wdir->handle = handle;
+  CAR(dir) |= OPN;
+  ALLOW_INTS;
+  return dir;
+}
+
+SCM l_readdir(port)
+     SCM port;
+{
+  SCM fname;
+  struct WDIR *wdir;
+  int ret;
+  ASRTER(OPDIRP(port), port, ARG1, s_readdir);
+  wdir = (struct WDIR*)CHARS(port);
+  if (-1 == wdir->handle) return BOOL_F;
+  fname = makfrom0str(wdir->info.name);
+  DEFER_INTS;
+  SYSCALL(ret = _findnext(wdir->handle, &(wdir->info)););
+  if (0 != ret) {
+    SYSCALL(_findclose(wdir->handle););
+    wdir->handle = -1;
+  }
+  ALLOW_INTS;
+  return fname;
+}
+
+SCM l_rewinddir(port)
+     SCM port;
+{
+  struct WDIR *wdir;
+  ASRTER(OPDIRP(port), port, ARG1, s_rewinddir);
+  wdir = (struct WDIR*)CHARS(port);
+  DEFER_INTS;
+  if (-1 != wdir->handle)
+    SYSCALL(_findclose(wdir->handle););
+  SYSCALL(wdir->handle = _findfirst(CHARS(wdir->fspec), &(wdir->info)););
+  ALLOW_INTS;
+  return UNSPECIFIED;
+}
+
+SCM l_closedir(port)
+     SCM port;
+{
+  struct WDIR *wdir;
+  ASRTER(DIRP(port), port, ARG1, s_closedir);
+  wdir = (struct WDIR*)CHARS(port);
+  DEFER_INTS;
+  if CLOSEDP(port) {ALLOW_INTS;return BOOL_F;}
+  if (-1 != wdir->handle) {
+    SYSCALL(_findclose(wdir->handle););
+    wdir->handle = -1;
+  }
+  CAR(port) = tc16_dir;
+  wdir->fspec = UNSPECIFIED;
+  ALLOW_INTS;
+  return BOOL_T;
+}
+
+int dir_print(sexp, port, writing)
+     SCM sexp; SCM port; int writing;
+{
+  prinport(sexp, port, "directory");
+  return !0;
+}
+sizet dir_free(p)
+     CELLPTR p;
+{
+  struct WDIR *wdir = (struct WDIR*)CHARS((SCM)p);
+  if (-1 != wdir->handle)
+    _findclose(wdir->handle);
+  must_free(CHARS((SCM)p), (sizet)sizeof(struct WDIR));
+  return 0;
+}
+SCM dir_mark(ptr)
+     SCM ptr;
+{
+  return ((struct WDIR*)CHARS(ptr))->fspec;
+}
 #  endif /* _WIN32 */
+long tc16_dir;
+static smobfuns dir_smob = {dir_mark, dir_free, dir_print, 0};
 # endif /* vms */
 
 static char s_mkdir[] = "mkdir";
@@ -392,8 +505,8 @@ SCM l_mkdir(path, mode)
      SCM path, mode;
 {
   int val;
-  ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_mkdir);
-  ASSERT(INUMP(mode), mode, ARG2, s_mkdir);
+  ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_mkdir);
+  ASRTER(INUMP(mode), mode, ARG2, s_mkdir);
 # ifdef _WIN32
   SYSCALL(val = mkdir(CHARS(path)););
 # else
@@ -410,7 +523,7 @@ SCM l_rmdir(path)
      SCM path;
 {
   int val;
-  ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_rmdir);
+  ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_rmdir);
 # ifdef vms
   return del_fil(st_append(cons2(path, s_dot_dir, EOL)));
 # else
@@ -426,7 +539,7 @@ SCM lchdir(str)
      SCM str;
 {
   int ans;
-  ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_chdir);
+  ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_chdir);
   SYSCALL(ans = chdir(CHARS(str)););
   return ans ? BOOL_F : BOOL_T;
 }
@@ -453,8 +566,8 @@ SCM l_chmod(pathname, mode)
      SCM pathname, mode;
 {
   int val;
-  ASSERT(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_chmod);
-  ASSERT(INUMP(mode), mode, ARG2, s_chmod);
+  ASRTER(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_chmod);
+  ASRTER(INUMP(mode), mode, ARG2, s_chmod);
   SYSCALL(val = chmod(CHARS(pathname), INUM(mode)););
   return val ? BOOL_F : BOOL_T;
 }
@@ -478,7 +591,7 @@ SCM l_utime(pathname, acctime, modtime)
   struct utimbuf utm_tmp;
   utm_tmp.actime = num2ulong(acctime, (char *)ARG2, s_utime);
   utm_tmp.modtime = num2ulong(modtime, (char *)ARG3, s_utime);
-  ASSERT(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_utime);
+  ASRTER(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_utime);
   SYSCALL(val = utime(CHARS(pathname), &utm_tmp););
   return val ? BOOL_F : BOOL_T;
 }
@@ -489,7 +602,7 @@ static char s_umask[] = "umask";
 SCM l_umask(mode)
      SCM mode;
 {
-  ASSERT(INUMP(mode), mode, ARG1, s_umask);
+  ASRTER(INUMP(mode), mode, ARG1, s_umask);
   return MAKINUM(umask(INUM(mode)));
 }
 #  endif
@@ -501,8 +614,8 @@ SCM ren_fil(oldname, newname)
      SCM oldname, newname;
 {
   SCM ans;
-  ASSERT(NIMP(oldname) && STRINGP(oldname), oldname, ARG1, s_ren_fil);
-  ASSERT(NIMP(newname) && STRINGP(newname), newname, ARG2, s_ren_fil);
+  ASRTER(NIMP(oldname) && STRINGP(oldname), oldname, ARG1, s_ren_fil);
+  ASRTER(NIMP(newname) && STRINGP(newname), newname, ARG2, s_ren_fil);
 #if 1 /* def STDC_HEADERS */
   SYSCALL(ans = (rename(CHARS(oldname), CHARS(newname))) ? BOOL_F: BOOL_T;);
   return ans;
@@ -522,7 +635,7 @@ static char s_fileno[] = "fileno";
 SCM l_fileno(port)
      SCM port;
 {
-  ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_fileno);
+  ASRTER(NIMP(port) && OPPORTP(port), port, ARG1, s_fileno);
   if (tc16_fport != TYP16(port)) return BOOL_F;
   return MAKINUM(fileno(STREAM(port)));
 }
@@ -540,10 +653,10 @@ SCM l_access(pathname, mode)
 {
   int val;
   int imodes;
-  ASSERT(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_access);
+  ASRTER(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_access);
   if INUMP(mode) imodes = INUM(mode);
   else {
-    ASSERT(NIMP(mode) && STRINGP(mode), mode, ARG2, s_access);
+    ASRTER(NIMP(mode) && STRINGP(mode), mode, ARG2, s_access);
     imodes = F_OK | (strchr(CHARS(mode), 'r') ? R_OK : 0)
       | (strchr(CHARS(mode), 'w') ? W_OK : 0)
 	| (strchr(CHARS(mode), 'x') ? X_OK : 0);
@@ -630,8 +743,8 @@ SCM i_execv(modes, path, args)
 {
   char **execargv;
   int i = ilength(args);
-  ASSERT(i>0, args, WNA, s_execv);
-  ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_execv);
+  ASRTER(i>0, args, WNA, s_execv);
+  ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_execv);
   /*  dowinds(EOL); */
   args = cons(path, args);
   DEFER_INTS;
@@ -667,7 +780,7 @@ static char s_putenv[] = "putenv";
 SCM l_putenv(str)
      SCM str;
 {
-  ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_putenv);
+  ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_putenv);
   return putenv(CHARS(str)) ? BOOL_F : BOOL_T;
 }
 #   endif
@@ -680,12 +793,10 @@ static iproc subr1s[] = {
 	{s_fileno, l_fileno},
 #ifndef MCH_AMIGA
 # ifndef vms
-#  ifndef _WIN32
 	{s_opendir, l_opendir},
 	{s_readdir, l_readdir},
 	{s_rewinddir, l_rewinddir},
 	{s_closedir, l_closedir},
-#  endif
 # endif
 	{s_rmdir, l_rmdir},
 #endif
@@ -734,11 +845,11 @@ SCM scm_try_create_file(fname, modes, perms)
 # else
   int cperms = 0666;
 # endif
-  ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_try_create_file);
-  ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_try_create_file);
+  ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_try_create_file);
+  ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_try_create_file);
   if (NNULLP(perms)) {
     perms = CAR(perms);
-    ASSERT(INUMP(perms), perms, ARG3, s_try_create_file);
+    ASRTER(INUMP(perms), perms, ARG3, s_try_create_file);
 # ifdef S_IROTH
     cperms = (mode_t)INUM(perms);
 # else
@@ -746,7 +857,7 @@ SCM scm_try_create_file(fname, modes, perms)
 # endif
   }
   flags = mode_bits(CHARS(modes), cmodes);
-  ASSERT(flags, modes, ARG2, s_try_create_file);
+  ASRTER(flags, modes, ARG2, s_try_create_file);
   fdflags |= (RDNG & flags) ? O_RDWR : O_WRONLY;
   DEFER_INTS;
   SCM_OPENCALL(fd = open(CHARS(fname), fdflags, cperms));
@@ -768,6 +879,8 @@ static iproc subr2os[] = {
 	{s_write_line, l_write_line},
 	{0, 0}};
 
+SCM_DLL_EXPORT void init_ioext P((void));
+
 void init_ioext()
 {
 	init_iprocs(subr1os, tc7_subr_1o);
@@ -787,8 +900,8 @@ void init_ioext()
 #  ifndef vms
 #   ifndef _WIN32
 	make_subr(s_utime, tc7_subr_3, l_utime);
-	tc16_dir = newsmob(&dir_smob);
 #   endif
+	tc16_dir = newsmob(&dir_smob);
 #  endif
 # endif
 #endif
@@ -809,6 +922,11 @@ void init_ioext()
 	add_feature("line-i/o");
 	scm_ldstr("\n\
 (define (file-exists? path) (access path \"r\"))\n\
+(define (make-directory path)\n\
+  (define umsk (umask 18))\n\
+  (umask umsk)\n\
+  (mkdir path (logxor #o777 umsk)))\n\
+(define current-directory getcwd)\n\
 (define (directory-for-each proc dirname . args)\n\
   (define dir (opendir (if (symbol? dirname)\n\
 			   (symbol->string dirname)\n\
@@ -830,6 +948,17 @@ void init_ioext()
 	(do ((filename (readdir dir) (readdir dir)))\n\
 	    ((not filename) (closedir dir))\n\
 	  (and (selector filename) (proc filename))))))\n\
+(define (system->line command . tmp)\n\
+  (require 'filename)\n\
+  (cond ((null? tmp)\n\
+         (call-with-tmpnam\n\
+          (lambda (tmp) (system->line command tmp))))\n\
+        (else\n\
+         (set! tmp (car tmp))\n\
+         (and (zero? (system (string-append command \" > \" tmp)))\n\
+              (file-exists? tmp)\n\
+              (let ((line (call-with-input-file tmp read-line)))\n\
+                (if (eof-object? line) \"\" line))))))\n\
 ");
-	add_feature("directory-for-each");
+	add_feature("directory");
 }