diff --git a/Makefile b/Makefile index 426e7468bab80c407f7e4b395ca352713a7b53df..ba13d1572ecdb6442fb66a7df751892114dd260d 100644 --- a/Makefile +++ b/Makefile @@ -18,19 +18,19 @@ export CL_SOURCE_REGISTRY := (:source-registry (:tree "${sourceDirectory}") :ign lisp ?= sbcl +ABCL ?= abcl +ALLEGRO ?= alisp +ALLEGROMODERN ?= mlisp CCL ?= ccl CLISP ?= clisp -SBCL ?= sbcl +CMUCL ?= cmucl ECL ?= ecl +GCL ?= gcl +LISPWORKS ?= lispworks MKCL ?= mkcl -CMUCL ?= cmucl -ABCL ?= abcl -XCL ?= xcl +SBCL ?= sbcl SCL ?= scl -ALLEGRO ?= alisp -ALLEGROMODERN ?= mlisp -LISPWORKS ?= lispworks -GCL ?= gcl +XCL ?= xcl # website, tag, install @@ -53,7 +53,7 @@ archive-copy: archive tmp/asdf.lisp tmp/asdf.lisp: $(wildcard *.lisp) mkdir -p tmp - cat header.lisp package.lisp implementation.lisp utility.lisp upgrade.lisp pathname.lisp os.lisp component.lisp system.lisp find-system.lisp find-component.lisp lisp-build.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp configuration.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp user.lisp footer.lisp > $@ + cat header.lisp package.lisp implementation.lisp utility.lisp upgrade.lisp pathname.lisp os.lisp component.lisp system.lisp find-system.lisp find-component.lisp lisp-build.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp configuration.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp > $@ push: git status @@ -146,7 +146,7 @@ test-upgrade: test-forward-references: tmp/asdf.lisp ${SBCL} --noinform --no-userinit --no-sysinit --load tmp/asdf.lisp --load test/script-support.lisp --eval '(asdf-test::exit-lisp 0)' 2>&1 | cmp - /dev/null -test-lisp: +test-lisp: tmp/asdf.lisp @cd test; ${MAKE} clean;./run-tests.sh ${lisp} ${test-glob} test: test-lisp test-forward-references doc diff --git a/asdf.asd b/asdf.asd index 9f246d4599e720caaa2df40906077193780ee1c2..c49b913296b755860deae9599261b996fbace900 100644 --- a/asdf.asd +++ b/asdf.asd @@ -14,7 +14,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.62" ;; to be automatically updated by bin/bump-revision + :version "2.26.63" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf"))) diff --git a/bin/bump-version b/bin/bump-version index 9ac83866060ec0deee168799649b849023082bde..cc1a578dde06258ffa23d4ebdfcfe97411549bf1 100755 --- a/bin/bump-version +++ b/bin/bump-version @@ -7,7 +7,7 @@ PROG="$0" ASDFDIR="$(cd $(dirname $PROG)/.. ; /bin/pwd)" ## readlink -f doesn't work on BSD if [ -z "$NEWVER" ] ; then - OLDVER="$(grep ' (asdf-version "' ${ASDFDIR}/header.lisp | cut -d\" -f2)" + OLDVER="$(grep ' (asdf-version "' ${ASDFDIR}/upgrade.lisp | cut -d\" -f2)" NEWVER="$(echo $OLDVER | perl -npe 's/([0-9].[0-9]+)(\.([0-9]+))?/"${1}.".($3+1)/e')" fi echo "Setting ASDF version to $NEWVER" diff --git a/bundle.lisp b/bundle.lisp index ed61f78043fc568bbb2409986c27e76b54a9d1a1..623a3f54ced569a8c7e13becc5fd77d8d4e44f1e 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -244,7 +244,7 @@ (files (and system (output-files operation system)))) (if (or move-here (and (null move-here-p) (member operation-name '(:program :binary)))) - (loop :with dest-path = (truename (ensure-directories-exist move-here-path)) + (loop :with dest-path = (truename* (ensure-directories-exist move-here-path)) :for f :in files :for new-f = (make-pathname :name (pathname-name f) :type (pathname-type f) diff --git a/component.lisp b/component.lisp index bc1a90dbb3fe3a3ec848e9b37895ed2519242986..2f9e062b0b6880351aff3b3637d933e8214d7c49 100644 --- a/component.lisp +++ b/component.lisp @@ -184,7 +184,7 @@ hopefully, if done consistently, that won't affect program behavior too much.") "Hook for an extension to define a function to automatically detect a file's encoding") (defun* detect-encoding (pathname) - (if (and pathname (probe-file pathname)) + (if (and pathname (not (directory-pathname-p pathname)) (probe-file pathname)) (funcall *encoding-detection-hook* pathname) *default-encoding*)) diff --git a/generate-asdf.asd b/generate-asdf.asd index c165825ce3c401ec2496aeb6994e34b48d3de136..87b78efeb2c29c2a8a44d404f710fdf3eb97f988 100644 --- a/generate-asdf.asd +++ b/generate-asdf.asd @@ -7,7 +7,7 @@ :class :concatenated-source-system ;; :include-dependencies t :translate-output-p nil - :output-file "tmp/asdf.lisp" + :concatenated-source-file "tmp/generated-asdf.lisp" #| :depends-on (:asdf-header :asdf-package diff --git a/header.lisp b/header.lisp index ccd50ff86ab113eaec5397ba57ede6c0725569c6..4c46d105143c0512fe879c519f617b50d73063c9 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.62: Another System Definition Facility. +;;; This is ASDF 2.26.63: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. diff --git a/os.lisp b/os.lisp index a9664f6413abf39ed33ddfb726554ca9fa718397..ae621ca8324f974b3e90751cff7bd29351487189 100644 --- a/os.lisp +++ b/os.lisp @@ -222,12 +222,12 @@ using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver (defun* lisp-implementation-directory (&key truename) (let ((dir (ignore-errors - #+clozure (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:")) + #+clozure #p"ccl:" #+(or ecl mkcl) #p"SYS:" #+sbcl (aif (find-symbol* :sbcl-homedir-pathname :sb-int) (funcall it) (getenv-pathname "SBCL_HOME" :want-directory t))))) (if (and dir truename) - (let ((*default-pathname-defaults* #p"")) (truename dir)) + (truename* dir) dir))) diff --git a/package.lisp b/package.lisp index 06f7a2ae075112df3dd8246400acf29276138e15..40614aaaed5aa94e9c2611ac7e6206ebbdad858e 100644 --- a/package.lisp +++ b/package.lisp @@ -124,9 +124,10 @@ when the symbol is not found." (loop :for x :in newly-exported-symbols :do (export (intern* x package))))) (defun ensure-package (name &key - nicknames use reuse unintern - shadow export fmakunbound fmakunbound-setf) - reuse + nicknames use intern unintern shadow export + import-from shadowing-import-from + recycle mix fmakunbound fmakunbound-setf) + recycle mix intern import-from shadowing-import-from (let* ((p (ensure-package-exists name nicknames use))) #-ecl (ensure-package-fmakunbound p fmakunbound) #+ecl fmakunbound ;; do it later on ECL #-ecl (ensure-package-fmakunbound-setf p fmakunbound-setf) #+ecl fmakunbound-setf @@ -134,8 +135,6 @@ when the symbol is not found." (ensure-package-shadow p shadow) (ensure-package-export p export) p)) - (defun do-define-package (package clauses) - package clauses #| (let ((h (make-hash-table :test 'equal))) (labels ((ensure-imported (n) @@ -163,8 +162,28 @@ when the symbol is not found." ,@clauses (:export ,@(loop :for s :being :the :hash-keys :of h :collect s))))))) |# - )) + (defun parse-define-package-clauses (clauses) + (loop :for (kw . args) :in clauses + :when (eq kw :nicknames) :append args :into nicknames :else + :when (eq kw :use) :append args :into use :else + :when (eq kw :shadow) :append args :into shadow :else + :when (eq kw :export) :append args :into export :else + :when (eq kw :intern) :append args :into intern :else + :when (eq kw :import-from) :collect args :into import-from :else + :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else + :when (eq kw :recycle) :append args :into recycle :else + :when (eq kw :mix) :append args :into mix :else + :when (eq kw :unintern) :append args :into unintern :else + :when (eq kw :fmakunbound) :append args :into fmakunbound :else + :when (eq kw :fmakunbound-setf) :append args :into fmakunbound-setf :else + :do (error "unrecognized define-package keyword ~S" kw) + :finally (return `(:nicknames ,nicknames :use ,use + :shadow ,shadow :export ,export :intern ,intern + :import-from ,import-from :shadowing-import-from ,shadowing-import-from + :recycle ,recycle :mix ,mix :unintern ,unintern + :fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf)))) +);eval-when (defmacro define-package (package &rest clauses) `(eval-when (:compile-toplevel :load-toplevel :execute) - (do-define-package ',package ',clauses))) + (apply 'ensure-package ',package ',(parse-define-package-clauses clauses)))) diff --git a/pathname.lisp b/pathname.lisp index 72acca94621e79fddf43da621abdb390341adb01..01bdf0d59635dd7d2a961aaab972150a50de2303 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -23,10 +23,12 @@ ;; Wildcard pathnames #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden ;; Pathname host and its root - #:pathname-root #:directory-sperator-for-host + #:pathname-root #:directory-separator-for-host #:directorize-pathname-host-device + ;; defaults + #:nil-pathname #:with-pathname-defaults ;; probe filesystem - #:probe-file* #:safe-file-write-date + #:truename* #:probe-file* #:safe-file-write-date #:subdirectories #:directory-files #:directory* #:filter-logical-directory-results #:collect-sub*directories ;; Simple filesystem operations @@ -39,7 +41,9 @@ #:add-pathname-suffix #:tmpize-pathname #:call-with-staging-pathname #:with-staging-pathname ;; basic pathnames - #:load-pathname #:default-directory + #:load-pathname #:default-directory #:nil-pathname + ;; physical pathnames + #:physical-pathname-p #:sane-physical-pathname ;; Windows shortcut support #:read-null-terminated-string #:read-little-endian #:parse-file-location-info #:parse-windows-shortcut)) @@ -106,7 +110,7 @@ Defaults to T.") :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) (defun* make-pathname* (&rest keys &key (directory nil directoryp) - host device name type version defaults) + host device name type version defaults #+scl &allow-other-keys) (declare (ignore host device name type version defaults)) (apply 'make-pathname (append (when directoryp @@ -241,24 +245,36 @@ actually-existing directory." ;;; Probing the filesystem +(defun* nil-pathname (&optional (defaults *default-pathname-defaults*)) + (make-pathname :directory nil :name nil :type nil :version nil :device nil :host nil + :defaults defaults)) ;; shouldn't matter + +(defmacro with-pathname-defaults ((&optional defaults) &body body) + `(let ((*default-pathname-defaults* ,(or defaults (nil-pathname)))) ,@body)) + +(defun truename* (p) + ;; avoids both logical-pathname merging and physical resolution issues + (ignore-errors (with-pathname-defaults () (truename p)))) + (defun* probe-file* (p) "when given a pathname P, probes the filesystem for a file or directory with given pathname and if it exists return its truename." - (etypecase p - (null nil) - (string (probe-file* (parse-namestring p))) - (pathname (unless (wild-pathname-p p) - #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) - '(probe-file p) - #+clisp (aif (find-symbol* '#:probe-pathname :ext) - `(ignore-errors (,it p))) - #+gcl<2.7 - '(or (probe-file p) - (and (directory-pathname-p p) - (ignore-errors - (ensure-directory-pathname - (truename (subpathname (ensure-directory-pathname p) ".")))))) - '(ignore-errors (truename p))))))) + (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations + (etypecase p + (null nil) + (string (probe-file* (parse-namestring p))) + (pathname (unless (wild-pathname-p p) + #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) + '(probe-file p) + #+clisp (aif (find-symbol* '#:probe-pathname :ext) + `(ignore-errors (,it p))) + #+gcl<2.7 + '(or (probe-file p) + (and (directory-pathname-p p) + (ignore-errors + (ensure-directory-pathname + (truename* (subpathname (ensure-directory-pathname p) ".")))))) + '(truename* p))))))) (defun* safe-file-write-date (pathname) ;; If FILE-WRITE-DATE returns NIL, it's possible that @@ -293,8 +309,8 @@ with given pathname and if it exists return its truename." (let* ((u (ignore-errors (funcall merger f)))) ;; The first u avoids a cumbersome (truename u) error. ;; At this point f should already be a truename, - ;; but isn't quite in CLISP, for doesn't have :version :newest - (and u (equal (ignore-errors (truename u)) (truename f)) u))) + ;; but isn't quite in CLISP, for it doesn't have :version :newest + (and u (equal (truename* u) (truename* f)) u))) :when p :collect p) entries)) @@ -489,6 +505,13 @@ Host, device and version components are taken from DEFAULTS." ;; scheme-specific parts: port username password, not others: . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) +(defun* pathname-host-pathname (pathname) + (make-pathname :directory nil + :name nil :type nil :version nil :device nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + #-scl (defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname))) @@ -547,7 +570,7 @@ Host, device and version components are taken from DEFAULTS." (let ((found (probe-file* p))) (when found (return found))) (unless (absolute-pathname-p p) - (let ((true-defaults (ignore-errors (truename defaults)))) + (let ((true-defaults (truename* defaults))) (when true-defaults (setf p (merge-pathnames pathname true-defaults))))) (unless (absolute-pathname-p p) (return p)) @@ -680,6 +703,29 @@ For the latter case, we ought pick random suffix and atomically open it." (defun* default-directory () (truenamize (pathname-directory-pathname *default-pathname-defaults*))) +(defun* physical-pathname-p (x) + (and (pathnamep x) (not (typep x 'logical-pathname)))) + +(defun* sane-physical-pathname (&key (defaults *default-pathname-defaults*) + fallback (keep t) must-exist) + (flet ((sanitize (x) + (setf x (and x (ignore-errors (translate-logical-pathname x)))) + (when (pathnamep x) + (setf x + (ecase keep + ((t) x) + ((:directory) (pathname-directory-pathname x)) + ((:root) (pathname-root x)) + ((:host) (pathname-host-pathname x)) + ((nil) (nil-pathname x)))) + (when must-exist ;; CCL's probe-file will choke if d-p-d is logical + (setf x (and (probe-file* x) x))) + (and (physical-pathname-p x) x)))) + (or (sanitize defaults) + (when fallback (sanitize (ignore-errors (user-homedir-pathname)))) + (error "Could not find a sanitize ~S ~:[~;or a fallback ~] into a physical pathname" + defaults fallback)))) + ;;;; ----------------------------------------------------------------- ;;;; Windows shortcut support. Based on: ;;;; diff --git a/plan.lisp b/plan.lisp index c5bd9ccefcab6e6c91f4b47532689a7d9b9d8d99..11581ba7d26796886eea000bd7c3dc172e58d636 100644 --- a/plan.lisp +++ b/plan.lisp @@ -219,16 +219,15 @@ the action of OPERATION on COMPONENT in the PLAN")) (with-accessors ((action-set plan-visiting-action-set) (action-list plan-visiting-action-list)) plan (let ((action (cons operation component))) - (aif (gethash action action-set) - (error 'circular-dependency :actions - (member action (reverse action-list) :test 'equal)) - (progn - (setf (gethash action action-set) t) - (push action action-list) - (unwind-protect - (funcall fun) - (pop action-list) - (setf (gethash action action-set) nil))))))) + (when (gethash action action-set) + (error 'circular-dependency :actions + (member action (reverse action-list) :test 'equal))) + (setf (gethash action action-set) t) + (push action action-list) + (unwind-protect + (funcall fun) + (pop action-list) + (setf (gethash action action-set) nil))))) ;;;; Actual traversal: traverse-action diff --git a/source-registry.lisp b/source-registry.lisp index 928384b897a7653d4bf3e682ceb99533e7ce7434..6b7a4f7b3f41c2672268fe224586ef0102a10d43 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -247,7 +247,7 @@ with a different configuration, so the configuration would be re-read then." (defun* flatten-source-registry (&optional parameter) (remove-duplicates (while-collecting (collect) - (let ((*default-pathname-defaults* (default-directory))) + (with-pathname-defaults () ;; be location-independent (inherit-source-registry `(wrapping-source-registry ,parameter diff --git a/test/script-support.lisp b/test/script-support.lisp index 42b01326cbc7dc1f6e8acc0d4906b1366b69a9d1..f3d04415a3c43a7e4c0e887c2668850408cdbe6b 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -31,7 +31,9 @@ (make-pathname :directory '(#-gcl :relative #-gcl :back #+gcl :parent) :defaults *test-directory*) *test-directory*))) (defparameter *asdf-lisp* - (make-pathname :name "asdf" :type "lisp" :defaults *asdf-directory*)) + (merge-pathnames + (make-pathname :directory '(#-gcl :relative "tmp") :name "asdf" :type "lisp" :defaults *asdf-directory*) + *asdf-directory*)) (defparameter *asdf-fasl* (compile-file-pathname (let ((impl (string-downcase diff --git a/upgrade.lisp b/upgrade.lisp index 22feaa7b9c1176e83a9cbc4b652421a9cc5e569a..a8fcec8c5f2269f159651bf025d21dfdf8b34276 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -23,7 +23,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.62") + (asdf-version "2.26.63") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) diff --git a/utility.lisp b/utility.lisp index 1a39025210c4833b147fb21176e8bd4453568bee..fdce626d4c9fb134e200aa9ff360e0ab78e2da99 100644 --- a/utility.lisp +++ b/utility.lisp @@ -152,7 +152,7 @@ starting the separation from the end, e.g. when called with arguments ;;; Functions (defun* ensure-function (fun &key (package :asdf)) (etypecase fun - ((or boolean keyword character number) (constantly fun)) + ((or boolean keyword character number pathname) (constantly fun)) ((or function symbol) fun) (cons (eval `(function ,fun))) (string (eval `(function ,(with-standard-io-syntax @@ -186,8 +186,8 @@ NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" If major versions differ, it's not compatible. If they are equal, then any later version is compatible, with later being determined by a lexicographical comparison of minor numbers." - (let ((x (parse-version version 'warn)) - (y (parse-version base-version 'warn))) + (let ((x (parse-version provided-version 'warn)) + (y (parse-version required-version 'warn))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil)