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

2.012.6: Another pass at refactoring ECL support, based on a patch by Juanjo

parent 92482840
Loading
Loading
Loading
Loading
+37 −9
Original line number Diff line number Diff line
@@ -12,7 +12,36 @@
#+xcvb (module (:depends-on ("asdf")))

(in-package :asdf)
(require :cmp)

;;;
;;; We rewrite a subset of ASDF functions so that instead of generating one
;;; FASL file per lisp file, ASDF creates an object file and a FASL file. The
;;; object file is reused by the extensions below.
;;;

(setf *compile-op-compile-file-function*
      (lambda (input-file &rest keys &key output-file &allow-other-keys)
        (declare (ignore output-file))
        (multiple-value-bind (object-file flags1 flags2)
            (apply #'compile-file* 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))))

(defmethod output-files ((operation compile-op) (c cl-source-file))
  (declare (ignorable operation))
  (let ((p (lispize-pathname (component-pathname c))))
    (list (compile-file-pathname p :type :object)
          (compile-file-pathname p :type :fasl))))

(defmethod perform ((o load-op) (c cl-source-file))
  (map () #'load
       (loop :for i :in (input-files o c)
          :unless (string= (pathname-type i) "fas")
          :collect (compile-file-pathname (lispize-pathname i)))))

;;;
;;; COMPILE-OP / LOAD-OP
@@ -96,11 +125,11 @@
         (*force-load-p* t)
         (tree (traverse (make-instance 'load-op) system)))
    (append
     (loop for (op . component) in tree
        when (and (typep op 'load-op)
     (loop :for (op . component) :in tree
       :when (and (typep op 'load-op)
                  (typep component filter-type)
                  (or (not filter-system) (eq (component-system component) filter-system)))
        collect (progn
       :collect (progn
                  (when (eq component system) (setf include-self nil))
                  (cons operation component)))
     (and include-self (list (cons operation system))))))
@@ -414,7 +443,6 @@
(export '(make-build load-fasl-op prebuilt-system))
(push '("fasb" . si::load-binary) si::*load-hooks*)

(require 'cmp)
(defvar *require-asdf-operator* 'load-op)

(defun module-provide-asdf (name)
@@ -430,9 +458,9 @@
                                       :source-file nil)))

(setf si::*module-provider-functions*
      (loop for f in si::*module-provider-functions*
         unless (eq f 'module-provide-asdf)
         collect #'(lambda (name)
      (loop :for f :in si::*module-provider-functions*
        :unless (eq f 'module-provide-asdf)
        :collect #'(lambda (name)
                     (let ((l (multiple-value-list (funcall f name))))
                       (and (first l) (register-pre-built-system name))
                       (values-list l)))))
@@ -440,4 +468,4 @@
(pushnew 'module-provide-asdf ext:*module-provider-functions*)
(pushnew (translate-logical-pathname "SYS:") *central-registry*)

(provide 'asdf)
(provide :asdf)
+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.5" ;; to be automatically updated by bin/bump-revision
  :version "2.012.6" ;; to be automatically updated by bin/bump-revision
  :depends-on ()
  :components
  ((:file "asdf")
+9 −26
Original line number Diff line number Diff line
;;; -*- mode: common-lisp; package: asdf; -*-
;;; This is ASDF 2.012.5: Another System Definition Facility.
;;; This is ASDF 2.012.6: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
@@ -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.5")
         (asdf-version "2.012.6")
         (existing-asdf (fboundp 'find-system))
         (existing-version *asdf-version*)
         (already-there (equal asdf-version existing-version)))
@@ -767,8 +767,6 @@ 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))
@@ -1907,6 +1905,9 @@ recursive calls to traverse.")
  (setf (gethash (type-of operation) (component-operation-times c))
        (get-universal-time)))

(defvar *compile-op-compile-file-function* 'compile-file*
  "Function used to compile lisp files.")

;;; 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))
@@ -1918,7 +1919,7 @@ recursive calls to traverse.")
        (*compile-file-warnings-behaviour* (operation-on-warnings operation))
        (*compile-file-failure-behaviour* (operation-on-failure operation)))
    (multiple-value-bind (output warnings-p failure-p)
        (apply #'compile-file* source-file :output-file output-file
        (apply *compile-op-compile-file-function* source-file :output-file output-file
               (compile-op-flags operation))
      (when warnings-p
        (case (operation-on-warnings operation)
@@ -1940,9 +1941,7 @@ recursive calls to traverse.")
(defmethod output-files ((operation compile-op) (c cl-source-file))
  (declare (ignorable operation))
  (let ((p (lispize-pathname (component-pathname c))))
    #-broken-fasl-loader
    (list (compile-file-pathname p #+ecl :type #+ecl :object)
          #+ecl (compile-file-pathname p :type :fasl))
    #-broken-fasl-loader (list (compile-file-pathname p))
    #+broken-fasl-loader (list p)))

(defmethod perform ((operation compile-op) (c static-file))
@@ -1969,11 +1968,7 @@ recursive calls to traverse.")
(defclass load-op (basic-load-op) ())

(defmethod perform ((o load-op) (c cl-source-file))
  (map () #'load
       #-ecl (input-files o c)
       #+ecl (loop :for i :in (input-files o c)
               :unless (string= (pathname-type i) "fas")
               :collect (compile-file-pathname (lispize-pathname i)))))
  (map () #'load (input-files o c)))

(defmethod perform-with-restarts (operation component)
  (perform operation component))
@@ -3193,7 +3188,7 @@ effectively disabling the output translation facility."
  (when (and x (probe-file x))
    (delete-file x)))

(defmethod compile-file* (input-file &rest keys &key output-file &allow-other-keys)
(defun* 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))
@@ -3217,18 +3212,6 @@ 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))