Commit 92482840 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.012.5: refactoring of the ECL support, based on a patch by Juanjo

parent 075da4da
Loading
Loading
Loading
Loading
+1 −1
Original line number Diff line number Diff line
@@ -12,7 +12,7 @@
  :licence "MIT"
  :description "Another System Definition Facility"
  :long-description "ASDF builds Common Lisp software organized into defined systems."
  :version "2.012.4" ;; to be automatically updated by bin/bump-revision
  :version "2.012.5" ;; to be automatically updated by bin/bump-revision
  :depends-on ()
  :components
  ((:file "asdf")
+40 −58
Original line number Diff line number Diff line
;;; -*- mode: common-lisp; package: asdf; -*-
;;; This is ASDF 2.012.4: Another System Definition Facility.
;;; This is ASDF 2.012.5: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
@@ -62,7 +62,7 @@
  (setf excl::*autoload-package-name-alist*
        (remove "asdf" excl::*autoload-package-name-alist*
                :test 'equalp :key 'car))
  #+ecl (require :cmp)
  #+(and ecl (not ecl-bytecmp)) (require :cmp)
  #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
  #+(or unix cygwin) (pushnew :asdf-unix *features*))

@@ -83,7 +83,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.012.4")
         (asdf-version "2.012.5")
         (existing-asdf (fboundp 'find-system))
         (existing-version *asdf-version*)
         (already-there (equal asdf-version existing-version)))
@@ -189,7 +189,8 @@
           (#:perform #:explain #:output-files #:operation-done-p
            #:perform-with-restarts #:component-relative-pathname
            #:system-source-file #:operate #:find-component #:find-system
            #:apply-output-translations #:translate-pathname* #:resolve-location)
            #:apply-output-translations #:translate-pathname* #:resolve-location
            #:compile-file*)
           :unintern
           (#:*asdf-revision* #:around #:asdf-method-combination
            #:split #:make-collector
@@ -562,26 +563,23 @@ pathnames."
(eval-when (:compile-toplevel :load-toplevel :execute)
  (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))

#+mcl
(defun %getenv (x)
  (ccl:with-cstrs ((name x))
(defun* getenv (x)
  (declare (ignorable x))
  #+(or abcl clisp) (ext:getenv x)
  #+allegro (sys:getenv x)
  #+clozure (ccl:getenv x)
  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
  #+ecl (si:getenv x)
  #+gcl (system:getenv x)
  #+genera nil
  #+lispworks (lispworks:environment-variable x)
  #+mcl (ccl:with-cstrs ((name x))
          (let ((value (_getenv name)))
            (unless (ccl:%null-ptr-p value)
        (ccl:%get-cstring value)))))

(defun* getenv (x)
  (#+(or abcl clisp) ext:getenv
   #+allegro sys:getenv
   #+clozure ccl:getenv
   #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
   #+ecl si:getenv
   #+gcl system:getenv
   #+lispworks lispworks:environment-variable
   #+mcl %getenv
   #+sbcl sb-ext:posix-getenv
   #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl)
   (lambda (x) (declare (ignore x)) (error "getenv not available on your implementation"))
   x))
              (ccl:%get-cstring value))))
  #+sbcl (sb-ext:posix-getenv x)
  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl)
  (error "getenv not available on your implementation"))

(defun* directory-pathname-p (pathname)
  "Does PATHNAME represent a directory?
@@ -724,7 +722,9 @@ with given pathname and if it exists return its truename."

(defun* resolve-symlinks (path)
  #-allegro (truenamize path)
  #+allegro (excl:pathname-resolve-symbolic-links path))
  #+allegro (if (typep path 'logical-pathname)
                path
                (excl:pathname-resolve-symbolic-links path)))

(defun* default-directory ()
  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
@@ -767,6 +767,8 @@ with given pathname and if it exists return its truename."
                            :directory `(:absolute ,@path))))
        (translate-pathname absolute-pathname wild-root (wilden new-base))))))

(defgeneric* compile-file* (x &key output-file &allow-other-keys))

;;;; -------------------------------------------------------------------------
;;;; ASDF Interface, in terms of generic functions.
(defgeneric* find-system (system &optional error-p))
@@ -876,13 +878,6 @@ processed in order by OPERATE."))
;;;; -------------------------------------------------------------------------
;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
(when *upgraded-p*
   #+ecl
   (when (find-class 'compile-op nil)
     (defmethod update-instance-for-redefined-class :after
         ((c compile-op) added deleted plist &key)
       (declare (ignore added deleted))
       (let ((system-p (getf plist 'system-p)))
         (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
   (when (find-class 'module nil)
     (eval
      `(defmethod update-instance-for-redefined-class :after
@@ -1893,7 +1888,7 @@ recursive calls to traverse.")
   (on-failure :initarg :on-failure :accessor operation-on-failure
               :initform *compile-file-failure-behaviour*)
   (flags :initarg :flags :accessor compile-op-flags
          :initform #-ecl nil #+ecl '(:system-p t))))
          :initform nil)))

(defun output-file (operation component)
  "The unique output file of performing OPERATION on COMPONENT"
@@ -1908,24 +1903,10 @@ recursive calls to traverse.")
                         file)
     :do (ensure-directories-exist pathname)))

#+ecl
(defmethod perform :after ((o compile-op) (c cl-source-file))
  ;; Note how we use OUTPUT-FILES to find the binary locations
  ;; This allows the user to override the names.
  (let* ((files (output-files o c))
         (object (first files))
         (fasl (second files)))
    (c:build-fasl fasl :lisp-files (list object))))

(defmethod perform :after ((operation operation) (c component))
  (setf (gethash (type-of operation) (component-operation-times c))
        (get-universal-time)))

(declaim (ftype (function ((or pathname string)
                           &rest t &key (:output-file t) &allow-other-keys)
                          (values t t t))
                compile-file*))

;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
(defmethod perform ((operation compile-op) (c cl-source-file))
@@ -3212,7 +3193,7 @@ effectively disabling the output translation facility."
  (when (and x (probe-file x))
    (delete-file x)))

(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
(defmethod compile-file* (input-file &rest keys &key output-file &allow-other-keys)
  (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
         (tmp-file (tmpize-pathname output-file))
         (status :error))
@@ -3236,6 +3217,18 @@ effectively disabling the output translation facility."
         (setf output-truename nil)))
      (values output-truename warnings-p failure-p))))

#+(and ecl (not ecl-bytecmp))
(defmethod compile-file* :around (input-file &rest keys &key output-file &allow-other-keys)
  (declare (ignore output-file))
  (multiple-value-bind (object-file flags1 flags2)
      (apply #'call-next-method input-file :system-p t keys)
    (values (and object-file
                 (c::build-fasl (compile-file-pathname object-file :type :fasl)
                                :lisp-files (list object-file))
                           object-file)
            flags1
            flags2)))

#+abcl
(defun* translate-jar-pathname (source wildcard)
  (declare (ignore wildcard))
@@ -3718,17 +3711,6 @@ with a different configuration, so the configuration would be re-read then."
;;;; Things to do in case we're upgrading from a previous version of ASDF.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;;
;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
(eval-when (:compile-toplevel :load-toplevel :execute)
  #+ecl ;; Support upgrade from before ECL went to 1.369
  (when (fboundp 'compile-op-system-p)
    (defmethod compile-op-system-p ((op compile-op))
      (getf :system-p (compile-op-flags op)))
    (defmethod initialize-instance :after ((op compile-op)
                                           &rest initargs
                                           &key system-p &allow-other-keys)
      (declare (ignorable initargs))
      (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))

;;; If a previous version of ASDF failed to read some configuration, try again.
(when *ignored-configuration-form*