1.0.4.59: small signal handling improvements

[sbcl.git] / tools-for-build / wxs.lisp

diff --git a/tools-for-build/wxs.lisp b/tools-for-build/wxs.lisp
index b6d4faa..a6f1678 100644 (file)
--- 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))))
@@ -78,16 +83,21 @@
   (loop for flag in (directory "../contrib/*/test-passed")
         collect (car (last (pathname-directory flag)))))
 
+(defvar *id-char-substitutions* '((#\\ . #\_)
+                                  (#\/ . #\_)
+                                  (#\: . #\.)
+                                  (#\- . #\.)))
+
 (defun id (string)
   ;; Mangle a string till it can be used as an Id. A-Z, a-z, 0-9, and
   ;; _ are ok, nothing else is.
-  (nsubstitute #\_ #\-
-               (nsubstitute #\. #\:
-                            (nsubstitute #\. #\/
-                                         (substitute #\. #\\ string)))))
+  (map 'string (lambda (c)
+                 (or (cdr (assoc c *id-char-substitutions*))
+                     c))
+       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)))))
@@ -97,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"))
 
@@ -129,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))