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

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

parent 92482840
......@@ -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)
......@@ -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")
......
;;; -*- 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))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment