Commit 0484bd87 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

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

parent 2f4058cd
......@@ -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))
......
......@@ -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))))
......
......@@ -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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment