[Maxima-commits] CVS: maxima/src init-cl.lisp,1.144,1.145

[Raymond T. <rt...@us...>]

Update of /cvsroot/maxima/maxima/src
In directory 23jxhf1.ch3.sourceforge.com:/tmp/cvs-serv13818

Modified Files:
	init-cl.lisp 
Log Message:
Fix SHARE-SUBDIRS-LIST for ecl for the case where *maxima-sharedir* is
a symlink.  The call to DIRECTORY follows the symlink so the path
prefix from DIRECTORY is not the same as *maxima-sharedir*.


Index: init-cl.lisp
===================================================================
RCS file: /cvsroot/maxima/maxima/src/init-cl.lisp,v
retrieving revision 1.144
retrieving revision 1.145
diff -u -d -r1.144 -r1.145
--- init-cl.lisp	3 Jun 2009 02:57:00 -0000	1.144
+++ init-cl.lisp	3 Jun 2009 16:46:58 -0000	1.145
@@ -274,7 +274,7 @@
 		  (enough-namestring dir share-root)))
 	    file-list)))
 
-#+(or clisp ecl)
+#+clisp
 (defun share-subdirs-list ()
   ;; This doesn't work yet on windows.  Give up in that case and use
   ;; the default list.
@@ -301,6 +301,36 @@
 	;; Sort in alphabetical order
 	(sort dir-list #'string-lessp))))
 
+#+ecl
+(defun share-subdirs-list ()
+  ;; This doesn't work yet on windows.  Give up in that case and use
+  ;; the default list.
+  (if (string= *autoconf-win32* "true")
+      (default-share-subdirs-list)
+      ;; The call to DIRECTORY is to get ecl to follow any symlinks so
+      ;; that the subsequent call to directory all start with the same
+      ;; initial path.
+      (let* ((share-root (first (directory (pathname (concatenate 'string *maxima-sharedir* "/")))))
+	     (dir-list (directory (merge-pathnames (make-pathname :directory '(:relative :wild-inferiors))
+						   share-root))))
+	;; dir-list contains all of the directories.  Remove stuff we
+	;; don't want like CVS directories.  Anything else?
+	(setf dir-list (delete-if #'(lambda (x)
+				      ;; Remove CVS directories
+				      (or (equal x share-root)
+					  (equal "CVS" (car (last (pathname-directory x))))))
+				  dir-list))
+	;; Now just want the part after the *maxima-sharedir*, and we want
+	;; strings.
+	(setf dir-list
+	      (mapcar #'(lambda (x)
+			  (let ((dir (make-pathname :directory (butlast (pathname-directory x))
+						    :name (car (last (pathname-directory x))))))
+			    (enough-namestring dir share-root)))
+		      dir-list))
+	;; Sort in alphabetical order
+	(sort dir-list #'string-lessp))))
+
 
 (defun default-share-subdirs-list ()
   ;; Default implementation.  Eventually this should go away.