Add directory listing primitives from SRFI 170 draft

TODO: 'dotfiles?' flag and 'directory-files' procedure

c/builtins.c

@@ -526,4 +526,5 @@ void builtins_init(void)
     table_init();
     iostream_init();
     print_init();
+    os_init();
 }

c/libraries.c

@@ -80,6 +80,10 @@ static struct builtin_procedure builtin_procedures[] = {
 
     { "color-name->rgb24", builtin_color_name_to_rgb24, UP_2019 },
 
+    { "open-directory", builtin_os_open_directory, SRFI_170 | UP_2019 },
+    { "read-directory", builtin_os_read_directory, SRFI_170 | UP_2019 },
+    { "close-directory", builtin_os_close_directory, SRFI_170 | UP_2019 },
+
     { 0, 0, 0 },
 };
 

c/os_unix.c

@@ -4,6 +4,7 @@
 
 #include <assert.h>
 #include <ctype.h>
+#include <dirent.h>
 #include <errno.h>
 #include <limits.h>
 #include <math.h>
@@ -18,6 +19,9 @@
 
 #include "scheme.h"
 
+static value_t dirsym;
+struct fltype *dirtype;
+
 void path_to_dirname(char *path)
 {
     char *p;
@@ -114,6 +118,105 @@ void os_setenv(const char *name, const char *value)
     }
 }
 
+int isdirvalue(value_t v)
+{
+    return iscvalue(v) && cv_class((struct cvalue *)ptr(v)) == dirtype;
+}
+
+static DIR **todirhandleptr(value_t v, const char *fname)
+{
+    if (!isdirvalue(v))
+        type_error(fname, "dir", v);
+    return value2c(DIR **, v);
+}
+
+value_t builtin_os_open_directory(value_t *args, uint32_t nargs)
+{
+    const char *path;
+    DIR *dirhandle;
+    DIR **dirhandleptr;
+    value_t dirvalue;
+
+    argcount("open-directory", nargs, 1);
+    path = tostring(args[0], "path");
+    if (!(dirhandle = opendir(path))) {
+        lerror(IOError, "cannot open directory");
+    }
+    dirvalue = cvalue(dirtype, sizeof(DIR *));
+    dirhandleptr = value2c(DIR **, dirvalue);
+    *dirhandleptr = dirhandle;
+    return dirvalue;
+}
+
+value_t builtin_os_read_directory(value_t *args, uint32_t nargs)
+{
+    DIR *dirhandle;
+    DIR **dirhandleptr;
+    struct dirent *d;
+
+    argcount("read-directory", nargs, 1);
+    dirhandleptr = todirhandleptr(args[0], "dir");
+    dirhandle = *dirhandleptr;
+    for (;;) {
+        errno = 0;
+        if (!(d = readdir(dirhandle))) {
+            break;
+        }
+        if (!strcmp(d->d_name, ".") || !strcmp(d->d_name, "..")) {
+            continue;
+        }
+        break;
+    }
+    if (!d && errno) {
+        lerror(IOError, "cannot read directory");
+    }
+    return d ? string_from_cstr(d->d_name) : FL_EOF;
+}
+
+value_t builtin_os_close_directory(value_t *args, uint32_t nargs)
+{
+    DIR *dirhandle;
+    DIR **dirhandleptr;
+
+    argcount("read-directory", nargs, 1);
+    dirhandleptr = todirhandleptr(args[0], "dir");
+    dirhandle = *dirhandleptr;
+    if (dirhandle) {
+        if (closedir(dirhandle) == -1) {
+            lerror(IOError, "cannot close directory");
+        }
+        *dirhandleptr = dirhandle = 0;
+    }
+    return FL_F;
+}
+
+static void print_dir(value_t v, struct ios *f)
+{
+    (void)v;
+    fl_print_str("#<directory>", f);
+}
+
+static void free_dir(value_t self)
+{
+    DIR *dirhandle;
+    DIR **dirhandleptr;
+
+    dirhandleptr = todirhandleptr(self, "dir");
+    dirhandle = *dirhandleptr;
+    if (dirhandle) {
+        if (closedir(dirhandle) == -1) {
+            // lerror(IOError, "cannot close directory");
+        }
+        *dirhandleptr = dirhandle = 0;
+    }
+}
+
+static void relocate_dir(value_t oldv, value_t newv)
+{
+    (void)oldv;
+    (void)newv;
+}
+
 // TODO: cleanup
 static struct termios term_mode_orig;
 static struct termios term_mode_raw;
@@ -146,3 +249,11 @@ value_t builtin_term_exit(value_t *args, uint32_t nargs)
     tcsetattr(0, TCSAFLUSH, &term_mode_orig);
     return FL_T;
 }
+
+struct cvtable dir_vtable = { print_dir, relocate_dir, free_dir, NULL };
+
+void os_init(void)
+{
+    dirsym = symbol("dir");
+    dirtype = define_opaque_type(dirsym, sizeof(DIR *), &dir_vtable, NULL);
+}

c/scheme.h

@@ -471,6 +471,11 @@ char *get_exename(char *buf, size_t size);
 int os_path_exists(const char *path);
 void os_setenv(const char *name, const char *value);
 
+value_t builtin_os_open_directory(value_t *args, uint32_t nargs);
+value_t builtin_os_read_directory(value_t *args, uint32_t nargs);
+value_t builtin_os_close_directory(value_t *args, uint32_t nargs);
+void os_init(void);
+
 //// #include "random.h"
 
 #define random() genrand_int32()

scheme-core/aliases.scm

@@ -23,6 +23,17 @@
 (define-macro (begin0 first . rest)
   `(prog1 ,first ,@rest))
 
+(define (fold-proc cons_ nil_ proc)
+  (let loop ((acc nil_))
+    (let ((value (proc)))
+      (if (eof-object? value) acc (loop (cons_ value acc))))))
+
+(define (directory-names path)
+  (let ((d (open-directory path)))
+    (unwind-protect
+     (fold-proc cons '() (λ () (read-directory d)))
+     (close-directory d))))
+
 (define vector-ref aref)
 (define vector-set! aset!)
 (define vector-length length)