Changeset 13319


Ignore:
Timestamp:
06/10/11 09:28:30 (10 years ago)
Author:
Mark Evenson
Message:

Actual commit of asdf-2.016.1.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r13318 r13319  
    11;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.016: Another System Definition Facility.
     2;;; This is ASDF 2.016.1: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    6363                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
    6464  #+(and ecl (not ecl-bytecmp)) (require :cmp)
     65  #+gcl
     66  (when (or (< system::*gcl-major-version* 2)
     67            (and (= system::*gcl-major-version* 2)
     68                 (< system::*gcl-minor-version* 7)))
     69    (pushnew :gcl-pre2.7 *features*))
    6570  #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
    6671  #+(or unix cygwin) (pushnew :asdf-unix *features*)
     
    8590  ;; Has to be inside the eval-when to make Lispworks happy (!)
    8691  (defmacro compatfmt (format)
    87     #-genera format
    88     #+genera
     92    #-(or gcl genera) format
     93    #+(or gcl genera)
    8994    (loop :for (unsupported . replacement) :in
    90       '(("~@<" . "")
    91         ("; ~@;" . "; ")
    92         ("~3i~_" . "")
    93         ("~@:>" . "")
    94         ("~:>" . "")) :do
     95      `(("~3i~_" . "")
     96        #+genera
     97        ,@(("~@<" . "")
     98           ("; ~@;" . "; ")
     99           ("~@:>" . "")
     100           ("~:>" . ""))) :do
    95101      (loop :for found = (search unsupported format) :while found :do
    96102        (setf format
     
    107113         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    108114         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    109          (asdf-version "2.016")
     115         (asdf-version "2.016.1")
    110116         (existing-asdf (find-class 'component nil))
    111117         (existing-version *asdf-version*)
     
    368374;;;; User-visible parameters
    369375;;;;
    370 (defun asdf-version ()
    371   "Exported interface to the version of ASDF currently installed. A string.
    372 You can compare this string with e.g.:
    373 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
    374   *asdf-version*)
    375 
    376376(defvar *resolve-symlinks* t
    377377  "Determine whether or not ASDF resolves symlinks when defining systems.
     
    416416                condition-format condition-location
    417417                coerce-name)
    418          #-cormanlisp
     418         #-(or cormanlisp gcl-pre2.7)
    419419         (ftype (function (t t) t) (setf module-components-by-name)))
    420420
     
    424424(progn
    425425  (deftype logical-pathname () nil)
    426   (defun make-broadcast-stream () *error-output*)
    427   (defun file-namestring (p)
     426  (defun* make-broadcast-stream () *error-output*)
     427  (defun* file-namestring (p)
    428428    (setf p (pathname p))
    429     (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))
    430   (defparameter *count* 3)
    431   (defun dbg (&rest x)
    432     (format *error-output* "~S~%" x)))
    433 #+cormanlisp
    434 (defun maybe-break ()
    435   (decf *count*)
    436   (unless (plusp *count*)
    437     (setf *count* 3)
    438     (break)))
     429    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
    439430
    440431;;;; -------------------------------------------------------------------------
     
    445436       `(defmacro ,def* (name formals &rest rest)
    446437          `(progn
    447              #+(or ecl gcl) (fmakunbound ',name)
     438             #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
    448439             #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
    449440             ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
     
    516507
    517508(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    518   "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
    519 does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
     509  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
     510if the SPECIFIED pathname does not have an absolute directory,
     511then the HOST and DEVICE both come from the DEFAULTS, whereas
     512if the SPECIFIED pathname does have an absolute directory,
     513then the HOST and DEVICE both come from the SPECIFIED.
    520514Also, if either argument is NIL, then the other argument is returned unmodified."
    521515  (when (null specified) (return-from merge-pathnames* defaults))
     
    731725#+genera
    732726(unless (fboundp 'ensure-directories-exist)
    733   (defun ensure-directories-exist (path)
     727  (defun* ensure-directories-exist (path)
    734728    (fs:create-directories-recursively (pathname path))))
    735729
     
    799793    (string (probe-file* (parse-namestring p)))
    800794    (pathname (unless (wild-pathname-p p)
    801                 #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
     795                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl)
     796                      '(probe-file p)
    802797                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
    803798                                   `(ignore-errors (,it p)))
    804799                      '(ignore-errors (truename p)))))))
    805800
    806 (defun* truenamize (p)
     801(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
    807802  "Resolve as much of a pathname as possible"
    808803  (block nil
    809     (when (typep p '(or null logical-pathname)) (return p))
    810     (let* ((p (merge-pathnames* p))
    811            (directory (pathname-directory p)))
     804    (when (typep pathname '(or null logical-pathname)) (return pathname))
     805    (let ((p (merge-pathnames* pathname defaults)))
    812806      (when (typep p 'logical-pathname) (return p))
    813807      (let ((found (probe-file* p)))
    814808        (when found (return found)))
    815       #-(or cmu sbcl scl) (when (stringp directory) (return p))
    816       (when (not (eq :absolute (car directory))) (return p))
     809      (unless (absolute-pathname-p p)
     810        (let ((true-defaults (ignore-errors (truename defaults))))
     811          (when true-defaults
     812            (setf p (merge-pathnames pathname true-defaults)))))
     813      (unless (absolute-pathname-p p) (return p))
    817814      (let ((sofar (probe-file* (pathname-root p))))
    818815        (unless sofar (return p))
     
    825822                                 :version (pathname-version p))
    826823                  sofar)))
    827           (loop :for component :in (cdr directory)
     824          (loop :with directory = (normalize-pathname-directory-component
     825                                   (pathname-directory p))
     826            :for component :in (cdr directory)
    828827            :for rest :on (cdr directory)
    829828            :for more = (probe-file*
     
    848847      path))
    849848
    850 (defun ensure-pathname-absolute (path)
     849(defun* ensure-pathname-absolute (path)
    851850  (cond
    852851    ((absolute-pathname-p path) path)
     
    878877
    879878#-scl
    880 (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
     879(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
    881880  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
    882881    (last-char (namestring foo))))
     
    962961(defgeneric* (setf component-property) (new-value component property))
    963962
    964 (eval-when (:compile-toplevel :load-toplevel :execute)
     963(eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
    965964  (defgeneric* (setf module-components-by-name) (new-value module)))
    966965
     
    12711270      (let ((pathname
    12721271             (merge-pathnames*
    1273              (component-relative-pathname component)
    1274              (pathname-directory-pathname (component-parent-pathname component)))))
     1272              (component-relative-pathname component)
     1273              (pathname-directory-pathname (component-parent-pathname component)))))
    12751274        (unless (or (null pathname) (absolute-pathname-p pathname))
    12761275          (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
     
    13131312  (version-satisfies (component-version c) version))
    13141313
    1315 (defun parse-version (string &optional on-error)
     1314(defun* asdf-version ()
     1315  "Exported interface to the version of ASDF currently installed. A string.
     1316You can compare this string with e.g.:
     1317(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
     1318  *asdf-version*)
     1319
     1320(defun* parse-version (string &optional on-error)
    13161321  "Parse a version string as a series of natural integers separated by dots.
    13171322Return a (non-null) list of integers if the string is valid, NIL otherwise.
     
    15321537        (funcall thunk))))
    15331538
    1534 (defmacro with-system-definitions (() &body body)
     1539(defmacro with-system-definitions ((&optional) &body body)
    15351540  `(call-with-system-definitions #'(lambda () ,@body)))
    15361541
     
    21142119          :initform nil)))
    21152120
    2116 (defun output-file (operation component)
     2121(defun* output-file (operation component)
    21172122  "The unique output file of performing OPERATION on COMPONENT"
    21182123  (let ((files (output-files operation component)))
     
    21452150        (*compile-file-failure-behaviour* (operation-on-failure operation)))
    21462151    (multiple-value-bind (output warnings-p failure-p)
    2147         (apply *compile-op-compile-file-function* source-file :output-file output-file
    2148                (compile-op-flags operation))
     2152        (apply *compile-op-compile-file-function* source-file
     2153               :output-file output-file (compile-op-flags operation))
    21492154      (unless output
    21502155        (error 'compile-error :component c :operation operation))
     
    35243529(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
    35253530  (if (absolute-pathname-p output-file)
    3526       ;;; If the default ABCL rules for translating from a jar path to
    3527       ;;; a non-jar path have been affected, no further computation of
    3528       ;;; the output location is necessary.
    3529       ;; (if (and (find :abcl *features*)
    3530       ;;          (pathname-device input-file) ; input-file is in a jar
    3531       ;;          (not (pathname-device output-file)) ; output-file is not in a jar
    3532       ;;          (equal (pathname-type input-file) "lisp")
    3533       ;;          (equal (pathname-type output-file) "abcl"))
    3534       ;;     output-file
    3535           (apply 'compile-file-pathname (lispize-pathname input-file) keys);)
     3531      ;; what cfp should be doing, w/ mp* instead of mp
     3532      (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
     3533             (defaults (make-pathname
     3534                        :type type :defaults (merge-pathnames* input-file))))
     3535        (merge-pathnames* output-file defaults))
    35363536      (apply-output-translations
    3537        (apply 'compile-file-pathname
    3538               (truenamize (lispize-pathname input-file))
    3539               keys))))
     3537       (apply 'compile-file-pathname input-file keys))))
    35403538
    35413539(defun* tmpize-pathname (x)
     
    37383736  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
    37393737
    3740 (defun directory-asd-files (directory)
     3738(defun* directory-asd-files (directory)
    37413739  (ignore-errors
    37423740    (directory* (merge-pathnames* *wild-asd* directory))))
    37433741
    3744 (defun subdirectories (directory)
     3742(defun* subdirectories (directory)
    37453743  (let* ((directory (ensure-directory-pathname directory))
    37463744         #-(or abcl cormanlisp genera xcl)
     
    37703768    dirs))
    37713769
    3772 (defun collect-asds-in-directory (directory collect)
     3770(defun* collect-asds-in-directory (directory collect)
    37733771  (map () collect (directory-asd-files directory)))
    37743772
    3775 (defun collect-sub*directories (directory collectp recursep collector)
     3773(defun* collect-sub*directories (directory collectp recursep collector)
    37763774  (when (funcall collectp directory)
    37773775    (funcall collector directory))
     
    37803778      (collect-sub*directories subdir collectp recursep collector))))
    37813779
    3782 (defun collect-sub*directories-asd-files
     3780(defun* collect-sub*directories-asd-files
    37833781    (directory &key
    37843782     (exclude *default-source-registry-exclusions*)
Note: See TracChangeset for help on using the changeset viewer.