X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tools-for-build%2Fwxs.lisp;h=a6f1678cd79708a9d46eabaf000a09fb7b6a668d;hb=0e03a9ac950b78d776c4869c809e202d9e929f39;hp=10fbd8ebf4fd1a99b1a5c1dfeb28ffb05c0ab070;hpb=22a6702974b7d6ff4e8f2b3b7b5ff446fc632de0;p=sbcl.git

diff --git a/tools-for-build/wxs.lisp b/tools-for-build/wxs.lisp
index 10fbd8e..a6f1678 100644
--- a/tools-for-build/wxs.lisp
+++ b/tools-for-build/wxs.lisp
@@ -13,6 +13,11 @@
 
 (defvar *indent-level* 0)
 
+(defvar *sbcl-source-root*
+  (truename
+   (merge-pathnames (make-pathname :directory (list :relative :up))
+                    (make-pathname :name nil :type nil :defaults *load-truename*))))
+
 (defun print-xml (sexp &optional (stream *standard-output*))
   (destructuring-bind (tag &optional attributes &body children) sexp
     (when attributes (assert (evenp (length attributes))))
@@ -92,7 +97,7 @@
        string))
 
 (defun directory-id (name)
-  (id (format nil "Directory_~A" (enough-namestring name))))
+  (id (format nil "Directory_~A" (enough-namestring name *sbcl-source-root*))))
 
 (defun directory-names (pathname)
   (let ((name (car (last (pathname-directory pathname)))))
@@ -102,7 +107,7 @@
         (list "Name" name))))
 
 (defun file-id (pathname)
-  (id (format nil "File_~A" (enough-namestring pathname))))
+  (id (format nil "File_~A" (enough-namestring pathname *sbcl-source-root*))))
 
 (defparameter *ignored-directories* '("CVS" ".svn"))
 
@@ -134,7 +139,7 @@
 (defparameter *components* nil)
 
 (defun component-id (pathname)
-  (let ((id (id (format nil "Contrib_~A" (enough-namestring pathname)))))
+  (let ((id (id (format nil "Contrib_~A" (enough-namestring pathname *sbcl-source-root*)))))
     (push id *components*)
     id))