[slime-cvs] CVS slime

[CVS User heller]

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv4330

Modified Files:
	ChangeLog swank-clisp.lisp 
Log Message:
* swank-clisp.lisp (filename-to-pathname, parse-cygwin-filename):
Accept Windows and Unix filenames when :CYGWIN is in *features*.

--- /project/slime/cvsroot/slime/ChangeLog	2008/10/17 21:27:24	1.1563
+++ /project/slime/cvsroot/slime/ChangeLog	2008/10/19 20:03:12	1.1564
@@ -1,3 +1,8 @@
+2008-10-19  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-clisp.lisp (filename-to-pathname, parse-cygwin-filename):
+	Accept Windows and Unix filenames when :CYGWIN is in *features*.
+
 2008-10-17  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-sbcl.lisp (swank-compile-file): Fix typo.
--- /project/slime/cvsroot/slime/swank-clisp.lisp	2008/10/17 21:27:16	1.82
+++ /project/slime/cvsroot/slime/swank-clisp.lisp	2008/10/19 20:03:12	1.83
@@ -116,6 +116,47 @@
   (setf (ext:default-directory) directory)
   (namestring (setf *default-pathname-defaults* (ext:default-directory))))
 
+(defimplementation filename-to-pathname (string)
+  (cond ((member :cygwin *features*)
+         (parse-cygwin-filename string))
+        (t (parse-namestring string))))
+
+(defun parse-cygwin-filename (string)
+  (multiple-value-bind (match _ drive absolute)
+      (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t)
+    (declare (ignore _))
+    (assert (and match (if drive absolute t)) ()
+            "Invalid filename syntax: ~a" string)
+    (let* ((sans-prefix (subseq string (regexp:match-end match)))
+           (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix)))
+           (path (loop for name in path collect
+                       (cond ((equal name "..") ':back)
+                             (t name))))
+           (directoryp (or (equal string "")
+                           (find (aref string (1- (length string))) "\\/"))))
+      (multiple-value-bind (file type)
+          (cond ((and (not directoryp) (last path))
+                 (let* ((file (car (last path)))
+                        (pos (position #\. file :from-end t)))
+                   (cond ((and pos (> pos 0)) 
+                          (values (subseq file 0 pos)
+                                  (subseq file (1+ pos))))
+                         (t file)))))
+        (make-pathname :host nil
+                       :device nil
+                       :directory (cons 
+                                   (if absolute :absolute :relative)
+                                   (let ((path (if directoryp 
+                                                   path 
+                                                   (butlast path))))
+                                     (if drive
+                                         (cons 
+                                          (regexp:match-string string drive)
+                                          path)
+                                         path)))
+                       :name file 
+                       :type type)))))
+
 ;;;; TCP Server
 
 (defimplementation create-socket (host port)