From ff4520a3edef4003d767e793890f489e772a1b3e Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Sun, 6 Feb 2011 17:30:35 -0500 Subject: [PATCH] 2.012.6: Another pass at refactoring ECL support, based on a patch by Juanjo --- asdf-ecl.lisp | 46 +++++++++++++++++++++++++++++++++++++--------- asdf.asd | 2 +- asdf.lisp | 35 +++++++++-------------------------- 3 files changed, 47 insertions(+), 36 deletions(-) diff --git a/asdf-ecl.lisp b/asdf-ecl.lisp index 3cf85751..1d8e43be 100644 --- a/asdf-ecl.lisp +++ b/asdf-ecl.lisp @@ -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) diff --git a/asdf.asd b/asdf.asd index 9699e2a5..38c84b76 100644 --- a/asdf.asd +++ b/asdf.asd @@ -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") diff --git a/asdf.lisp b/asdf.lisp index c6ad0bc3..3c1c873f 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- 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)) -- GitLab