projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
1.0.4.70: more x86 backend cleanups
[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 *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))))
(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)))))
(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.
(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)
(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)))))
(defun directory-names (pathname)
(let ((name (car (last (pathname-directory pathname)))))
@@
-97,7
+107,7
@@
(list "Name" name))))
(defun file-id (pathname)
(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"))
(defparameter *ignored-directories* '("CVS" ".svn"))
@@
-129,7
+139,7
@@
(defparameter *components* nil)
(defun component-id (pathname)
(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))
(push id *components*)
id))