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