Skip to content
Snippets Groups Projects
Commit 0484bd87 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Genera: support directory deletion, remove some compile-time warnings.

parent 2f4058cd
No related branches found
No related tags found
No related merge requests found
...@@ -592,13 +592,14 @@ in an atomic way if the implementation allows." ...@@ -592,13 +592,14 @@ in an atomic way if the implementation allows."
directory-pathname (unix:get-unix-error-msg errno)))) directory-pathname (unix:get-unix-error-msg errno))))
#+cormanlisp (win32:delete-directory directory-pathname) #+cormanlisp (win32:delete-directory directory-pathname)
#+ecl (si:rmdir directory-pathname) #+ecl (si:rmdir directory-pathname)
#+genera (fs:delete-directory directory-pathname)
#+lispworks (lw:delete-directory directory-pathname) #+lispworks (lw:delete-directory directory-pathname)
#+mkcl (mkcl:rmdir directory-pathname) #+mkcl (mkcl:rmdir directory-pathname)
#+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
`(,dd directory-pathname) ;; requires SBCL 1.0.44 or later `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
`(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
#+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring 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 (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)) (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." ...@@ -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" (error "~S was asked to delete ~S but the directory does not exist"
'delete-filesystem-tree directory-pathname)) 'delete-filesystem-tree directory-pathname))
(:ignore nil))) (: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, ((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; ;; except on implementations where we can prevent DIRECTORY from following symlinks;
;; instead spawn a standard external program to do the dirty work. ;; 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." ...@@ -642,7 +643,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
#+allegro (symbol-call :excl.osi :delete-directory-and-files #+allegro (symbol-call :excl.osi :delete-directory-and-files
directory-pathname :if-does-not-exist if-does-not-exist) directory-pathname :if-does-not-exist if-does-not-exist)
#+clozure (ccl:delete-directory directory-pathname) #+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)) #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
`(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
'(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree)) '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
......
...@@ -773,7 +773,7 @@ It returns a process-info plist with possible keys: ...@@ -773,7 +773,7 @@ It returns a process-info plist with possible keys:
#+(or allegro clozure cmu (and lispworks os-unix) sbcl scl) #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
(%wait-process-result (%wait-process-result
(apply '%run-program (%normalize-system-command command) :wait t keys)) (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))) (let ((%command (%redirected-system-command command input output error-output directory)))
#+(and lispworks os-windows) #+(and lispworks os-windows)
(system:call-system %command :current-directory directory :wait t) (system:call-system %command :current-directory directory :wait t)
...@@ -790,6 +790,8 @@ It returns a process-info plist with possible keys: ...@@ -790,6 +790,8 @@ It returns a process-info plist with possible keys:
(*error-output* *stderr*)) (*error-output* *stderr*))
(ext:system %command)) (ext:system %command))
#+gcl (system: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)) #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
#+mkcl (mkcl:system %command) #+mkcl (mkcl:system %command)
#+xcl (system:%run-shell-command %command)))) #+xcl (system:%run-shell-command %command))))
......
...@@ -195,7 +195,7 @@ Returns two values: \(A B C\) and \(1 2 3\)." ...@@ -195,7 +195,7 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;;; Characters ;;; Characters
(with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR. (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??? #-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*))) (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
...@@ -372,7 +372,7 @@ and EVAL that in a (FUNCTION ...) context." ...@@ -372,7 +372,7 @@ and EVAL that in a (FUNCTION ...) context."
(etypecase fun (etypecase fun
(function fun) (function fun)
((or boolean keyword character number pathname) (constantly 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)) (symbol (fdefinition fun))
(cons (if (eq 'lambda (car fun)) (cons (if (eq 'lambda (car fun))
(eval fun) (eval fun)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment