From 0484bd87aa3d98d434c4b3db5d8b7254825c6851 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Sun, 11 May 2014 10:24:36 -0400
Subject: [PATCH] Genera: support directory deletion, remove some compile-time
 warnings.

---
 uiop/filesystem.lisp  | 7 ++++---
 uiop/run-program.lisp | 4 +++-
 uiop/utility.lisp     | 4 ++--
 3 files changed, 9 insertions(+), 6 deletions(-)

diff --git a/uiop/filesystem.lisp b/uiop/filesystem.lisp
index 392bb395..0317c380 100644
--- a/uiop/filesystem.lisp
+++ b/uiop/filesystem.lisp
@@ -592,13 +592,14 @@ in an atomic way if the implementation allows."
                                     directory-pathname (unix:get-unix-error-msg errno))))
     #+cormanlisp (win32:delete-directory directory-pathname)
     #+ecl (si:rmdir directory-pathname)
+    #+genera (fs:delete-directory directory-pathname)
     #+lispworks (lw:delete-directory directory-pathname)
     #+mkcl (mkcl:rmdir directory-pathname)
     #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
                `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
                `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
     #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
-    #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks mkcl sbcl scl xcl)
+    #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
     (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera
 
   (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
@@ -632,7 +633,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
           (error "~S was asked to delete ~S but the directory does not exist"
               'delete-filesystem-tree directory-pathname))
          (:ignore nil)))
-      #-(or allegro cmu clozure sbcl scl)
+      #-(or allegro cmu clozure genera sbcl scl)
       ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
        ;; except on implementations where we can prevent DIRECTORY from following symlinks;
        ;; instead spawn a standard external program to do the dirty work.
@@ -642,7 +643,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
        #+allegro (symbol-call :excl.osi :delete-directory-and-files
                               directory-pathname :if-does-not-exist if-does-not-exist)
        #+clozure (ccl:delete-directory directory-pathname)
-       #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type))
+       #+genera (fs:delete-directory directory-pathname :confirm nil)
        #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
                   `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
                   '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
diff --git a/uiop/run-program.lisp b/uiop/run-program.lisp
index bae693bf..c622339d 100644
--- a/uiop/run-program.lisp
+++ b/uiop/run-program.lisp
@@ -773,7 +773,7 @@ It returns a process-info plist with possible keys:
     #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
     (%wait-process-result
      (apply '%run-program (%normalize-system-command command) :wait t keys))
-    #+(or abcl cormanlisp clisp ecl gcl (and lispworks os-windows) mkcl xcl)
+    #+(or abcl cormanlisp clisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
     (let ((%command (%redirected-system-command command input output error-output directory)))
       #+(and lispworks os-windows)
       (system:call-system %command :current-directory directory :wait t)
@@ -790,6 +790,8 @@ It returns a process-info plist with possible keys:
                     (*error-output* *stderr*))
                 (ext:system %command))
         #+gcl (system:system %command)
+        #+genera (error "~S not supported on Genera, cannot run ~S"
+                        '%system %command)
         #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
         #+mkcl (mkcl:system %command)
         #+xcl (system:%run-shell-command %command))))
diff --git a/uiop/utility.lisp b/uiop/utility.lisp
index aac6a3a6..74780f1e 100644
--- a/uiop/utility.lisp
+++ b/uiop/utility.lisp
@@ -195,7 +195,7 @@ Returns two values: \(A B C\) and \(1 2 3\)."
 
 ;;; Characters
 (with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR.
-  (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
+  (defconstant +non-base-chars-exist-p+ #.(not (subtypep 'character 'base-char)))
   #-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow???
   (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
 
@@ -372,7 +372,7 @@ and EVAL that in a (FUNCTION ...) context."
     (etypecase fun
       (function fun)
       ((or boolean keyword character number pathname) (constantly fun))
-      (hash-table (lambda (x) (gethash x fun)))
+      (hash-table #'(lambda (x) (gethash x fun)))
       (symbol (fdefinition fun))
       (cons (if (eq 'lambda (car fun))
                 (eval fun)
-- 
GitLab