Commit 8a6a66b5 authored by Gary King's avatar Gary King
Browse files

Simpler *asdf-revision*; incorporate ABL

parent 5b3d1bd6
......@@ -26,7 +26,7 @@ archive-copy: archive
bin/ tmp/asdf*.tar.gz $(webhome_private)/archives
bin/ $(clnet_home) $(user)
bin/ tmp/asdf.lisp $(webhome_private)
git push
git push --tags
website-copy: FORCE
bin/ website/output/ $(webhome_private)
......@@ -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 @@
#:around ; protocol assistants
(: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
(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)
"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
;;; and
;;; ---------------------------------------------------------------------------
;;; 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*
(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*
"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*
"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*
(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
;; 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.
(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
#+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~]"
#+ppc64-target 64
#-ppc64-target nil)
#+lispworks (format nil "~A~@[~A~]"
(when (member :lispworks-64bit *features*) "-64bit"))
#+allegro (format nil
; 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
(:-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*
(or *implementation-specific-directory-name*
(setf *implementation-specific-directory-name*
((fp (thing)
(etypecase thing
(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
(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)
(let ((lisp (maybe-warn (first-of *implementation-features*)
"No implementation feature found in ~a."
(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."
(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))
source possible-paths (source-to-target-resolved-mappings)))
(defmethod output-files-using-mappings (source possible-paths path-mappings)
(lambda (path)
(loop for (from to) in path-mappings
when (pathname-prefix-p from source)
do (return
(if to
(make-pathname :type (pathname-type path))
(merge-pathnames (enough-namestring source from)
;; 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*
:type (pathname-type path)
:directory `(:relative
,@(cond ((eq *include-per-user-information* t)
(cdr (pathname-directory
((not (null *include-per-user-information*))
(list *include-per-user-information*)))
,@(rest (pathname-directory path)))
:defaults path)
:type (pathname-type path)
:directory (append
(pathname-directory path)
:defaults path)))))
(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)))
(component-system component) operation component source paths))
;;;; -----------------------------------------------------------------
;;;; Windows shortcut support. Based on:
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; -----------------------------------------------------------------
(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)
;;?? 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)))
(make-pathname :name "asdf-binary-locations"
:type "lisp"
:directory '(:relative ".asdf"))
(truename (user-homedir-pathname)))
:if-does-not-exist nil)))
# 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
exit 0
tag=`git describe --tag`
if [ "$tag" == "" ]; then
echo "error: git tag not found"
exit -1
major=`expr //$tag : '//\(.*\)\.'`
minor=`expr //$tag : '.*\.\(.*\)'`
if [ "$major" == "" ]; then
echo "error: unable to parse major version in $tag"
exit -1
if [ "$minor" == "" ]; then
echo "error: unable to parse minor version in $tag"
exit -1
bumped=`expr $minor + 1`
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/ $new_version
......@@ -3,7 +3,7 @@
<plist version="1.0">
......@@ -20,12 +20,18 @@
......@@ -133,6 +139,20 @@
......@@ -184,12 +204,12 @@
......@@ -345,6 +365,7 @@
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment