X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tools-for-build%2Fwxs.lisp;h=137479981d4bdc34882c9a1a4c568e1b01d92f73;hb=f7a78dd3554bd977b006e5da349a11d4e8463bb5;hp=b6d4faa052885521044a97cd9bae6f681ff1cb3d;hpb=1acfa21e0796f5d72d776b0fd53645813d5f2d98;p=sbcl.git

diff --git a/tools-for-build/wxs.lisp b/tools-for-build/wxs.lisp
index b6d4faa..1374799 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))))
@@ -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"))
 
@@ -106,7 +116,8 @@
     ("fasl" . "fas")
     ("SBCL" . "txt") ; README.SBCL -> README.txt
     ("texinfo" . "tfo")
-    ("lisp-temp" . "lmp")))
+    ("lisp-temp" . "lmp")
+    ("html" . "htm")))
 
 (defun file-names (pathname)
   (if (or (< 8 (length (pathname-name pathname)))
@@ -129,7 +140,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))
 
@@ -222,8 +233,13 @@
                             "Name" "PATH"
                             "Part" "first"
                             "Value" "[INSTALLDIR]"))
-            ,(make-extension "fasl" "application/x-lisp-fasl")
-            ,(make-extension "lisp" "text/x-lisp-source")
+            ;; If we want to associate files with SBCL, this
+            ;; is how it's done -- but doing this by default
+            ;; and without asking the user for permission Is
+            ;; Bad. Before this is enabled we need to figure out
+            ;; how to make WiX ask for permission for this...
+            ;; ,(make-extension "fasl" "application/x-lisp-fasl")
+            ;; ,(make-extension "lisp" "text/x-lisp-source")
             ("File" ("Id" "sbcl.exe"
                      "Name" "sbcl.exe"
                      "Source" "../src/runtime/sbcl.exe")