From 8a6a66b519a12fba5b26cbc0748173c73c22c8ed Mon Sep 17 00:00:00 2001
From: Gary King <gwking@franz.com>
Date: Thu, 10 Sep 2009 09:38:06 -0400
Subject: [PATCH] Simpler *asdf-revision*; incorporate ABL

---
 GNUmakefile                  |   2 +-
 asdf.lisp                    | 315 ++++++++++++++++++++++++++++++++---
 bin/bump-revision-and-tag.sh |  41 +++++
 website/website.tmproj       |  31 +++-
 4 files changed, 358 insertions(+), 31 deletions(-)
 create mode 100755 bin/bump-revision-and-tag.sh

diff --git a/GNUmakefile b/GNUmakefile
index a7e7a23f..7477cafd 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -26,7 +26,7 @@ archive-copy: archive
 	bin/rsync-cp.sh tmp/asdf*.tar.gz $(webhome_private)/archives
 	bin/link-tarball.sh $(clnet_home) $(user)
 	bin/rsync-cp.sh tmp/asdf.lisp $(webhome_private)
-	git push cl.net
+	git push --tags cl.net
 
 website-copy: FORCE
 	bin/rsync-cp.sh website/output/ $(webhome_private)
diff --git a/asdf.lisp b/asdf.lisp
index 353139e1..8511a141 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -52,6 +52,7 @@
 #+xcvb (module ())
 
 (defpackage #:asdf
+  (:documentation "Another System Definition Facility")
   (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
            #:system-definition-pathname #:find-component ; miscellaneous
 	   #:compile-system #:load-system #:test-system
@@ -125,7 +126,15 @@
 
            #:standard-asdf-method-combination
            #:around                     ; protocol assistants
-	   )
+	   
+	   #:*source-to-target-mappings*
+	   #:*default-toplevel-directory*
+	   #:*centralize-lisp-binaries*
+	   #:*include-per-user-information*
+	   #:*map-all-source-files*
+	   #:output-files-for-system-and-operation
+	   #:*place-binaries-in-implementation-specific-directories*
+	   #:implementation-specific-directory-name)
   (:use :cl))
 
 
@@ -136,26 +145,7 @@
 
 (in-package #:asdf)
 
-(defvar *asdf-revision*
-  ;; find first tag that looks like /tags/[0-9]*\.[0-9]*. E.g., /tags/1.34
-  ;; return nil or a list of the major and minor version numbers
-  (let* ((v "$Format:%d$")
-	 (to-find "tags/")
-	 (start 0))
-    (when v
-      (loop for tag-start = (search to-find v :test #'char= :start2 start)
-	 while tag-start do
-	 (when tag-start
-	   (let ((dot (position #\. v :start tag-start))
-		 (space (position #\space v :start tag-start)))
-	     (when (and dot (or (not space) (< dot space)))
-	       ;; success
-	       (return
-		 (list (parse-integer v :start (+ tag-start (length to-find))
-				      :junk-allowed t)
-		       (parse-integer v :start (1+ dot)
-				      :junk-allowed t))))
-	     (setf start (1+ tag-start))))))))
+(defvar *asdf-revision* "REVISION:_asdf_revision")
 
 (defvar *resolve-symlinks* t
   "Determine whether or not ASDF resolves symlinks when defining systems.
@@ -282,6 +272,27 @@ The plan returned is a list of dotted-pairs. Each pair is the `cons`
 of ASDF operation object and a `component` object. The pairs will be 
 processed in order by `operate`."))
 
+(defgeneric output-files-using-mappings (source possible-paths path-mappings)
+  (:documentation 
+"Use the variable \\*source-to-target-mappings\\* to find
+an output path for the source. The algorithm transforms each
+entry in possible-paths as follows: If there is a mapping
+whose source starts with the path of possible-path, then
+replace possible-path with a pathname that starts with the
+target of the mapping and continues with the rest of
+possible-path. If no such mapping is found, then use the
+default mapping.
+
+If \\*centralize-lisp-binaries\\* is false, then the default
+mapping is to place the output in a subdirectory of the
+source. The subdirectory is named using the Lisp
+implementation \(see
+implementation-specific-directory-name\). If
+\\*centralize-lisp-binaries\\* is true, then the default
+mapping is to place the output in subdirectories of
+\\*default-toplevel-directory\\* where the subdirectory
+structure will mirror that of the source."))
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; utility stuff
@@ -379,7 +390,8 @@ and NIL NAME and TYPE components"
           (call-next-method c nil) (missing-required-by c)))
 
 (defun sysdef-error (format &rest arguments)
-  (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
+  (error 'formatted-system-definition-error :format-control 
+	 format :format-arguments arguments))
 
 ;;;; methods: components
 
@@ -1581,10 +1593,248 @@ output to `*verbose-out*`.  Returns the shell's exit code."
                     :directory directory)
      (system-source-directory system))))
 
-;;;; Windows shortcut support.  Based on:
+;;; ---------------------------------------------------------------------------
+;;; asdf-binary-locations
+;;;
+;;; this bit of code was stolen from Bjorn Lindberg and then it grew!
+;;; see http://www.cliki.net/asdf%20binary%20locations
+;;; and http://groups.google.com/group/comp.lang.lisp/msg/bd5ea9d2008ab9fd
+;;; ---------------------------------------------------------------------------
+;;; Portions of this code were once from SWANK / SLIME
+
+(defparameter *centralize-lisp-binaries*
+  nil "
+If true, compiled lisp files without an explicit mapping (see
+\\*source-to-target-mappings\\*) will be placed in subdirectories of
+\\*default-toplevel-directory\\*. If false, then compiled lisp files
+without an explicitly mapping will be placed in subdirectories of
+their sources.")
+
+(defparameter *place-binaries-in-implementation-specific-directories* nil
+  "
+If true, then compiled lisp files will be placed into a directory 
+computed from the Lisp version, Operating System and computer archetecture.
+See [implementation-specific-directory-name][] for details.")
+
+
+(defparameter *default-toplevel-directory*
+  (merge-pathnames
+   (make-pathname :directory '(:relative ".fasls"))
+   (truename (user-homedir-pathname)))
+  "If \\*centralize-lisp-binaries\\* is true, then compiled lisp files without an explicit mapping \(see \\*source-to-target-mappings\\*\) will be placed in subdirectories of \\*default-toplevel-directory\\*.")
+
+(defparameter *include-per-user-information*
+  nil
+  "When \\*centralize-lisp-binaries\\* is true this variable controls whether or not to customize the output directory based on the current user. It can be nil, t or a string. If it is nil \(the default\), then no additional information will be added to the output directory. If it is t, then the user's name \(as taken from the return value of #'user-homedir-pathname\) will be included into the centralized path (just before the lisp-implementation directory). Finally, if \\*include-per-user-information\\* is a string, then this string will be included in the output-directory.")
+
+(defparameter *map-all-source-files*
+  nil
+  "If true, then all subclasses of source-file will have their output locations mapped by ASDF-Binary-Locations. If nil (the default), then only subclasses of cl-source-file will be mapped.")
+
+(defvar *source-to-target-mappings* 
+  #-sbcl
+  nil
+  #+sbcl
+  (list (list (princ-to-string (sb-ext:posix-getenv "SBCL_HOME")) nil))
+  "The \\*source-to-target-mappings\\* variable specifies mappings from source to target. If the target is nil, then it means to not map the source to anything. I.e., to leave it as is. This has the effect of turning off ASDF-Binary-Locations for the given source directory. Examples:
+
+    ;; compile everything in .../src and below into .../cmucl
+    '((\"/nfs/home/compbio/d95-bli/share/common-lisp/src/\" 
+       \"/nfs/home/compbio/d95-bli/lib/common-lisp/cmucl/\"))
+
+    ;; leave SBCL innards alone (SBCL specific)
+    (list (list (princ-to-string (sb-ext:posix-getenv \"SBCL_HOME\")) nil))
+")
 
-;;; Jesse Hager: The Windows Shortcut File Format.
-;;; http://www.wotsit.org/list.asp?fc=13
+(defparameter *implementation-features*
+  '(:allegro :lispworks :sbcl :ccl :openmcl :cmu :clisp
+    :corman :cormanlisp :armedbear :gcl :ecl :scl))
+
+(defparameter *os-features*
+  '(:windows :mswindows :win32 :mingw32
+    :solaris :sunos
+    :macosx :darwin :apple
+    :freebsd :netbsd :openbsd :bsd
+    :linux :unix))
+
+(defparameter *architecture-features*
+  '(:amd64 (:x86-64 :x86_64 :x8664-target) :i686 :i586 :pentium3 
+    :i486 (:i386 :pc386 :iapx386) (:x86 :x8632-target) :pentium4
+    :hppa64 :hppa :ppc64 :ppc32 :powerpc :ppc :sparc64 :sparc))
+
+;; note to gwking: this is in slime, system-check, and system-check-server too
+(defun lisp-version-string ()
+  #+cmu       (substitute #\- #\/ 
+			  (substitute #\_ #\Space 
+				      (lisp-implementation-version)))
+  #+scl       (lisp-implementation-version)
+  #+sbcl      (lisp-implementation-version)
+  #+ecl       (reduce (lambda (x str) (substitute #\_ str x))
+		      '(#\Space #\: #\( #\)) 
+		      :initial-value (lisp-implementation-version))
+  #+gcl       (let ((s (lisp-implementation-version))) (subseq s 4))
+  #+openmcl   (format nil "~d.~d~@[-~d~]"
+                      ccl::*openmcl-major-version* 
+                      ccl::*openmcl-minor-version*
+                      #+ppc64-target 64 
+                      #-ppc64-target nil)
+  #+lispworks (format nil "~A~@[~A~]"
+                      (lisp-implementation-version)
+                      (when (member :lispworks-64bit *features*) "-64bit"))
+  #+allegro   (format nil
+                      "~A~A~A~A"
+                      excl::*common-lisp-version-number*
+					; ANSI vs MoDeRn
+		      ;; thanks to Robert Goldman and Charley Cox for
+		      ;; an improvement to my hack
+		      (if (eq excl:*current-case-mode* 
+			      :case-sensitive-lower) "M" "A")
+		      ;; Note if not using International ACL
+		      ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
+		      (excl:ics-target-case
+			(:-ics "8")
+			(:+ics ""))
+                      (if (member :64bit *features*) "-64bit" ""))
+  #+clisp     (let ((s (lisp-implementation-version)))
+                (subseq s 0 (position #\space s)))
+  #+armedbear (lisp-implementation-version)
+  #+cormanlisp (lisp-implementation-version)
+  #+digitool   (subseq (lisp-implementation-version) 8))
+
+
+(defparameter *implementation-specific-directory-name* nil)
+
+(defun implementation-specific-directory-name ()
+  "Return a name that can be used as a directory name that is
+unique to a Lisp implementation, Lisp implementation version,
+operating system, and hardware architecture."
+  (and *place-binaries-in-implementation-specific-directories*
+       (list 
+	(or *implementation-specific-directory-name*
+	    (setf *implementation-specific-directory-name*
+		  (labels 
+		      ((fp (thing)
+			 (etypecase thing
+			   (symbol
+			    (let ((feature (find thing *features*)))
+			      (when feature (return-from fp feature))))
+			   ;; allows features to be lists of which the first
+			   ;; member is the "main name", the rest being aliases
+			   (cons
+			    (dolist (subf thing)
+			      (let ((feature (find subf *features*)))
+				(when feature (return-from fp (first thing))))))))
+		       (first-of (features)
+			 (loop for f in features
+			    when (fp f) return it))
+		       (maybe-warn (value fstring &rest args)
+			 (cond (value)
+			       (t (apply #'warn fstring args)
+				  "unknown"))))
+		    (let ((lisp (maybe-warn (first-of *implementation-features*)
+					    "No implementation feature found in ~a." 
+					    *implementation-features*))
+			  (os   (maybe-warn (first-of *os-features*)
+					    "No os feature found in ~a." *os-features*))
+			  (arch (maybe-warn (first-of *architecture-features*)
+					    "No architecture feature found in ~a."
+					    *architecture-features*))
+			  (version (maybe-warn (lisp-version-string)
+					       "Don't know how to get Lisp ~
+                                          implementation version.")))
+		      (format nil "~(~@{~a~^-~}~)" lisp version os arch))))))))
+
+(defun pathname-prefix-p (prefix pathname)
+  (let ((prefix-ns (namestring prefix))
+        (pathname-ns (namestring pathname)))
+    (= (length prefix-ns)
+       (mismatch prefix-ns pathname-ns))))
+
+(defgeneric output-files-for-system-and-operation
+  (system operation component source possible-paths)
+  (:documentation "Returns the directory where the componets output files should be placed. This may depends on the system, the operation and the component. The ASDF default input and outputs are provided in the source and possible-paths parameters."))
+
+(defun source-to-target-resolved-mappings ()
+  "Answer `*source-to-target-mappings*` with additional entries made
+by resolving sources that are symlinks.
+
+As ASDF sometimes resolves symlinks to compute source paths, we must
+follow that.  For example, if SBCL is installed under a symlink, and
+SBCL_HOME is set through that symlink, the default rule above
+preventing SBCL contribs from being mapped elsewhere will not be
+applied by the plain `*source-to-target-mappings*`."
+  (loop for mapping in asdf:*source-to-target-mappings*
+	for (source target) = mapping
+	for true-source = (and source (resolve-symlinks source))
+	if (equal source true-source)
+	  collect mapping
+	else append (list mapping (list true-source target))))
+
+(defmethod output-files-for-system-and-operation
+           ((system system) operation component source possible-paths)
+  (declare (ignore operation component))
+  (output-files-using-mappings
+   source possible-paths (source-to-target-resolved-mappings)))
+
+(defmethod output-files-using-mappings (source possible-paths path-mappings)
+  (mapcar 
+   (lambda (path) 
+     (loop for (from to) in path-mappings 
+	when (pathname-prefix-p from source) 
+	do (return 
+	     (if to
+		 (merge-pathnames 
+		  (make-pathname :type (pathname-type path)) 
+		  (merge-pathnames (enough-namestring source from) 
+				   to))
+		 path))
+		  
+	finally
+	  (return 
+	    ;; Instead of just returning the path when we 
+	    ;; don't find a mapping, we stick stuff into 
+	    ;; the appropriate binary directory based on 
+	    ;; the implementation
+	    (if *centralize-lisp-binaries*
+		(merge-pathnames
+		 (make-pathname
+		  :type (pathname-type path)
+		  :directory `(:relative
+			       ,@(cond ((eq *include-per-user-information* t)
+					(cdr (pathname-directory
+					      (user-homedir-pathname))))
+				       ((not (null *include-per-user-information*))
+					(list *include-per-user-information*)))
+			       ,@(implementation-specific-directory-name)
+			       ,@(rest (pathname-directory path)))
+		  :defaults path)
+		 *default-toplevel-directory*)
+		(make-pathname 
+		 :type (pathname-type path)
+		 :directory (append
+			     (pathname-directory path)
+			     (implementation-specific-directory-name))
+		 :defaults path))))) 
+	  possible-paths))
+
+(defmethod output-files 
+    :around ((operation compile-op) (component source-file)) 
+  (if (or *map-all-source-files*
+	    (typecase component 
+	      (cl-source-file t)
+	      (t nil)))
+    (let ((source (component-pathname component )) 
+	  (paths (call-next-method))) 
+      (output-files-for-system-and-operation 
+       (component-system component) operation component source paths))
+    (call-next-method)))
+
+;;;; -----------------------------------------------------------------
+;;;; Windows shortcut support.  Based on:
+;;;;
+;;;; Jesse Hager: The Windows Shortcut File Format.
+;;;; http://www.wotsit.org/list.asp?fc=13
+;;;; -----------------------------------------------------------------
 
 (defparameter *link-initial-dword* 76)
 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
@@ -1709,3 +1959,18 @@ output to `*verbose-out*`.  Returns the shell's exit code."
     (asdf-message ";; ASDF, revision unknown; possibly a development version"))
 
 (provide 'asdf)
+
+
+#+(or)
+;;?? ignore -- so how will ABL get "installed"
+;; should be unnecessary with newer versions of ASDF
+;; load customizations
+(eval-when (:load-toplevel :execute)
+  (let* ((*package* (find-package :common-lisp)))
+    (load
+     (merge-pathnames
+      (make-pathname :name "asdf-binary-locations"
+		     :type "lisp"
+		     :directory '(:relative ".asdf"))
+      (truename (user-homedir-pathname)))
+     :if-does-not-exist nil)))
diff --git a/bin/bump-revision-and-tag.sh b/bin/bump-revision-and-tag.sh
new file mode 100755
index 00000000..29abcdf1
--- /dev/null
+++ b/bin/bump-revision-and-tag.sh
@@ -0,0 +1,41 @@
+#!/bin/sh
+
+# make sure that there are no pending comments
+
+# make sure you're on master
+branch=` git branch | grep "\* "`
+if [ "$branch" != "* master" ]; then
+  echo "error: git branch is $branch, not master"
+  exit -1
+fi 
+exit 0
+
+tag=`git describe --tag`
+if [ "$tag" == "" ]; then
+  echo "error: git tag not found"
+  exit -1
+fi
+
+major=`expr //$tag : '//\(.*\)\.'`
+minor=`expr //$tag : '.*\.\(.*\)'`
+
+if [ "$major" == "" ]; then
+  echo "error: unable to parse major version in $tag"
+  exit -1
+fi
+if [ "$minor" == "" ]; then
+  echo "error: unable to parse minor version in $tag"
+  exit -1
+fi
+
+bumped=`expr $minor + 1`
+new_version="$major.$bumped"
+
+cp asdf.lisp asdf.bak
+perl -pi -e "s/REVISION:.*\"/REVISION:$new_version\"/" asdf.lisp
+
+echo "Update reversion and commit"
+git add asdf.lisp
+git commit -m "update ASDF version to $new_version"
+
+bin/tag-release.sh $new_version
diff --git a/website/website.tmproj b/website/website.tmproj
index a481091d..72fec0df 100644
--- a/website/website.tmproj
+++ b/website/website.tmproj
@@ -3,7 +3,7 @@
 <plist version="1.0">
 <dict>
 	<key>currentDocument</key>
-	<string>source/manual.mmd</string>
+	<string>source/git.mmd</string>
 	<key>documents</key>
 	<array>
 		<dict>
@@ -20,12 +20,18 @@
 		</dict>
 		<dict>
 			<key>filename</key>
-			<string>source/manual.mmd</string>
+			<string>source/git.mmd</string>
 			<key>lastUsed</key>
-			<date>2009-08-19T12:45:27Z</date>
+			<date>2009-09-09T14:31:15Z</date>
 			<key>selected</key>
 			<true/>
 		</dict>
+		<dict>
+			<key>filename</key>
+			<string>source/manual.mmd</string>
+			<key>lastUsed</key>
+			<date>2009-09-04T02:23:14Z</date>
+		</dict>
 		<dict>
 			<key>filename</key>
 			<string>source/user-guide.mmd</string>
@@ -133,6 +139,20 @@
 			<key>firstVisibleLine</key>
 			<integer>81</integer>
 		</dict>
+		<key>source/git.mmd</key>
+		<dict>
+			<key>caret</key>
+			<dict>
+				<key>column</key>
+				<integer>0</integer>
+				<key>line</key>
+				<integer>2</integer>
+			</dict>
+			<key>firstVisibleColumn</key>
+			<integer>0</integer>
+			<key>firstVisibleLine</key>
+			<integer>0</integer>
+		</dict>
 		<key>source/glossary.md</key>
 		<dict>
 			<key>caret</key>
@@ -184,12 +204,12 @@
 				<key>column</key>
 				<integer>0</integer>
 				<key>line</key>
-				<integer>451</integer>
+				<integer>162</integer>
 			</dict>
 			<key>firstVisibleColumn</key>
 			<integer>0</integer>
 			<key>firstVisibleLine</key>
-			<integer>434</integer>
+			<integer>141</integer>
 		</dict>
 		<key>source/resources/footer.md</key>
 		<dict>
@@ -345,6 +365,7 @@
 		<string>source/glossary.md</string>
 		<string>source/getting-started.mmd</string>
 		<string>source/manual.mmd</string>
+		<string>source/git.mmd</string>
 		<string>source/user-guide.mmd</string>
 		<string>source/resources/navigation.md</string>
 		<string>source/contributors.md</string>
-- 
GitLab