diff --git a/asdf.lisp b/asdf.lisp index 3777ea8..9964e87 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,3 +1,4 @@ +;;; -*- Package: asdf -*- ;;; This is asdf: Another System Definition Facility. ;;; hash - $Format:%H$ ;;; @@ -400,7 +401,10 @@ and NIL NAME and TYPE components" (force-directory (values relative components nil)) (t - (values relative (butlast components) last-comp)))))) + (destructuring-bind (name &optional type) (split last-comp nil ".") + (values relative (butlast components) + (unless (zerop (length name)) name) + (unless (zerop (length type)) type)))))))) (defun remove-keys (key-names args) (loop :for (name val) :on args :by #'cddr @@ -547,6 +551,15 @@ and NIL NAME and TYPE components" :reader get-component-relative-pathname) (operation-times :initform (make-hash-table) :accessor component-operation-times) + (absolute-pathname + :accessor component-absolute-pathname + :documentation "The absolute component location combined its relative pathname with + its parent's location. If either constituent was a logical pathname, this pathname is + coerced to legal logical pathname syntax and the reverse mapping is recored in the + pathname-component-map slot.") + (pathname-component-map + :initform nil + :accessor component-pathname-component-map) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties @@ -606,16 +619,100 @@ and NIL NAME and TYPE components" (defmethod component-relative-pathname ((component module)) (or (get-component-relative-pathname component) - (multiple-value-bind (relative path) + (multiple-value-bind (relative path) ; ignore the name and type (split-path-string (component-name component) t) (make-pathname :directory `(,relative ,@path) :host (pathname-host (component-parent-pathname component)))))) +#+(or obsolete) (defmethod component-pathname ((component component)) (let ((*default-pathname-defaults* (component-parent-pathname component))) (merge-pathnames (component-relative-pathname component)))) +(defmethod component-pathname ((component component)) + (component-translate-pathname component (component-absolute-pathname component))) + +(defmethod component-translate-pathname ((component component) (pathname logical-pathname)) + (let ((absolute (translate-logical-pathname pathname)) + (map (component-pathname-component-map component))) + (if map + ;; breaks for ambiguous mappings within a single pathname + (flet ((mapped (component) + (if (stringp component) + (or (rest (assoc component map :test #'string-equal)) component) + component))) + (make-pathname :host (pathname-host absolute) + :device (pathname-device absolute) + :directory (mapcar #'mapped (pathname-directory absolute)) + :name (mapped (pathname-name absolute)) + :type (mapped (pathname-type absolute)) + :version (pathname-version absolute))) + absolute))) + +(defmethod component-translate-pathname ((component component) (pathname pathname)) + pathname) + +(defgeneric component-pathname-component-map (component) + (:method ((component null)) + ())) + +(defun absolute-pathname-p (pathname) + (eq (first (pathname-directory pathname)) :absolute)) +(defun logical-pathname-p (pathname) + (typep pathname 'logical-pathname)) + +(defgeneric bind-component-pathname (component) + (:method ((component component)) + (let ((crp (component-relative-pathname component)) + (map (component-pathname-component-map (component-parent component))) + (defaults (component-pathname-defaults component))) + (labels ((logical (word) + (if (stringp word) + (if (every #'word-char-p word) + word + (or (car (rassoc word map :test #'string-equal)) + (caar (push (cons (map 'string #'word-char word) word) map)))) + word)) + (word-char-p (c) (or (digit-char-p c 10) (upper-case-p c) (eql c #\-))) + (word-char (c) (if (word-char-p c) c + (if (alpha-char-p c) (char-upcase c) + #\-)))) + (let ((pathname (if (absolute-pathname-p crp) + (if (logical-pathname-p crp) + (make-pathname :host (pathname-host crp) + :device (pathname-device defaults) + :directory (mapcar #'logical (pathname-directory crp)) + :name (logical (pathname-name crp)) + :type (logical (pathname-type crp)) + :version (or (pathname-version crp) + (pathname-version defaults))) + crp) + (if (logical-pathname-p defaults) + (make-pathname :host (pathname-host defaults) + :device (pathname-device defaults) + :directory (mapcar #'logical (append (pathname-directory defaults) + (rest (pathname-directory crp)))) + :name (logical (pathname-name crp)) + :type (logical (pathname-type crp)) + :version (or (pathname-version crp) + (pathname-version defaults))) + + (make-pathname :host (pathname-host defaults) + :device (pathname-device defaults) + :directory (append (pathname-directory defaults) + (rest (pathname-directory crp))) + :name (pathname-name crp) + :type (pathname-type crp) + :version (or (pathname-version crp) + (pathname-version defaults))))))) + (setf (component-pathname-component-map component) map) + (setf (component-absolute-pathname component) pathname))))) + (:method ((module module)) + (prog1 (call-next-method) + (mapc #'bind-component-pathname (module-components module))))) + + (defmethod component-property ((c component) property) (cdr (assoc property (slot-value c 'properties) :test #'equal))) @@ -638,6 +735,13 @@ and NIL NAME and TYPE components" :reader system-source-file :initarg :source-file :writer %set-system-source-file))) +(defgeneric component-pathname-defaults (component) + (:method ((system system)) + (system-definition-pathname system)) + (:method ((component component)) + (component-absolute-pathname (component-parent component)))) + + ;;;; ------------------------------------------------------------------------- ;;;; version-satisfies @@ -871,23 +975,40 @@ to `~a` which is not a directory.~@:>" (defmethod source-file-type ((c java-source-file) (s module)) "java") (defmethod source-file-type ((c html-file) (s module)) "html") (defmethod source-file-type ((c static-file) (s module)) nil) +(defmethod source-file-type ((m module) (p module)) nil) +(defmethod source-file-type ((s system) (p null)) nil) -(defun merge-component-relative-pathname (pathname name type) - (multiple-value-bind (relative path filename) - (split-path-string name) - (let ((*default-pathname-defaults* - (make-pathname :name nil :type nil :directory nil :host nil))) - (merge-pathnames - (or pathname (make-pathname :directory `(,relative ,@path))) - (if type - (make-pathname :name filename :type type) - filename))))) +(defun merge-component-relative-pathname (pathname name type-arg) + (multiple-value-bind (relative path name type) + (split-path-string name) + (merge-pathnames + (or pathname (make-pathname :directory `(,relative ,@path))) + (make-pathname :name name :type (or type-arg type))))) +#+(or obsolete) (defmethod component-relative-pathname ((component source-file)) - (merge-component-relative-pathname - (get-component-relative-pathname component) - (component-name component) - (source-file-type component (component-system component)))) + (let ((*default-pathname-defaults* + (make-pathname :name nil :type nil :directory nil :host nil + :defaults (component-pathname (component-parent component))))) + (merge-component-relative-pathname + (slot-value component 'relative-pathname) + (component-name component) + (source-file-type component (component-system component))))) + + +(defmethod component-relative-pathname ((component source-file)) + (let ((relative (get-component-relative-pathname component))) + (if (pathnamep relative) + relative + (multiple-value-bind (relative-or-absolute path filename type) + (split-path-string (or relative + (string (component-name component)))) + (let ((*default-pathname-defaults* + (make-pathname :name nil :type nil :directory nil :host nil :device nil :version nil))) + (setf (slot-value component 'relative-pathname) + (make-pathname :directory (cons relative-or-absolute path) + :name filename + :type (or type (source-file-type component (component-parent component)))))))))) ;;;; ------------------------------------------------------------------------- ;;;; Operations @@ -994,7 +1115,7 @@ to `~a` which is not a directory.~@:>" self-deps) ;; no previous operations needed? I guess we work with the ;; original source file, then - (list (component-pathname c))))) + (list (component-translate-pathname c (component-absolute-pathname c)))))) (defmethod input-files ((operation operation) (c module)) nil) @@ -1098,6 +1219,9 @@ to `~a` which is not a directory.~@:>" (if (component-visiting-p operation c) (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) + #+(or) + (format *trace-output* "~&traverse: (~a ~a) before: ~s~%" + (type-of operation) (asdf:component-name c) forced) (unwind-protect (progn (loop :for (required-op . deps) :in @@ -1126,6 +1250,9 @@ to `~a` which is not a directory.~@:>" (error error)) forced)))) ;; now the thing itself + #+(or) + (format *trace-output* "~&traverse: (~a ~a) itself next: ~s ~s ~s~%" + (type-of operation) (asdf:component-name c) forced module-ops) (when (or forced module-ops (not (operation-done-p operation c)) (let ((f (operation-forced @@ -1144,6 +1271,9 @@ to `~a` which is not a directory.~@:>" (list (cons operation c))))))) (setf (visiting-component operation c) nil)) (visit-component operation c (and forced t)) + #+(or) + (format *trace-output* "~&traverse: (~a ~a) result: ~s~%" + (type-of operation) (asdf:component-name c) forced) forced))) @@ -1204,7 +1334,7 @@ to `~a` which is not a directory.~@:>" (error 'compile-error :component c :operation operation))))) (defmethod output-files ((operation compile-op) (c cl-source-file)) - #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) + #-:broken-fasl-loader (list (component-translate-pathname c (compile-file-pathname (component-absolute-pathname c)))) #+:broken-fasl-loader (list (component-pathname c))) (defmethod perform ((operation compile-op) (c static-file)) @@ -1455,13 +1585,9 @@ created with the same initargs as the original one. (make-instance ',class :name ',name)))) (%set-system-source-file *load-truename* (cdr (system-registered-p ',name)))) - (parse-component-form - nil (apply - #'list - :module (coerce-name ',name) - :pathname - ,(determine-system-pathname pathname pathname-arg-p) - ',component-options)))))) + (apply #'make-system ',name + :pathname ,(determine-system-pathname pathname pathname-arg-p) + ',component-options))))) (defun class-for-type (parent type) @@ -1561,6 +1687,13 @@ Returns the new tree (which probably shares structure with the old one)" (%remove-component-inline-methods component) (%define-component-inline-methods component rest)) +(defun make-system (name &rest args) + (let ((system (parse-component-form nil + (list* :module (coerce-name name) args)))) + (bind-component-pathname system) + system)) + + (defun parse-component-form (parent options) (destructuring-bind @@ -1950,6 +2083,7 @@ applied by the plain `*source-to-target-mappings*`." :defaults path))))) possible-paths)) +#+(or obsolete) (defmethod output-files :around ((operation compile-op) (component source-file)) (if (or *map-all-source-files* @@ -1962,6 +2096,10 @@ applied by the plain `*source-to-target-mappings*`." (component-system component) operation component source paths)) (call-next-method))) +(defmethod output-files + :around ((operation compile-op) (component source-file)) + (call-next-method)) + ;;;; ----------------------------------------------------------------- ;;;; Windows shortcut support. Based on: ;;;;