>From 79e2255b16ced362a9471e680440238a1b256288 Mon Sep 17 00:00:00 2001
From: Eric Timmons <etimmons@mit.edu>
Date: Tue, 1 Dec 2015 12:44:07 -0500
Subject: [PATCH] Package inferred systems and around-compile.

Package inferred systems now inherit around-compile from their top-level
system. Added test in package-inferred-system-test suite.
---
 package-inferred-system.lisp                            |  9 ++++++---
 test/package-inferred-system-test.script                |  3 +++
 test/package-inferred-system-test/a.lisp                | 17 +++++++++++++++++
 .../package-inferred-system-test.asd                    |  5 ++++-
 4 files changed, 30 insertions(+), 4 deletions(-)

diff --git a/package-inferred-system.lisp b/package-inferred-system.lisp
index 4b6a8ea..a75448f 100644
--- a/package-inferred-system.lisp
+++ b/package-inferred-system.lisp
@@ -93,11 +93,12 @@ otherwise return a default system name computed from PACKAGE-NAME."
       (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
       (error 'package-inferred-system-missing-package-error :system system :pathname file)))
 
-  (defun same-package-inferred-system-p (system name directory subpath dependencies)
+  (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies)
     (and (eq (type-of system) 'package-inferred-system)
          (equal (component-name system) name)
          (pathname-equal directory (component-pathname system))
          (equal dependencies (component-sideway-dependencies system))
+         (equal around-compile (around-compile-hook system))
          (let ((children (component-children system)))
            (and (length=n-p children 1)
                 (let ((child (first children)))
@@ -117,14 +118,16 @@ otherwise return a default system name computed from PACKAGE-NAME."
                                      :truename *resolve-symlinks*)))
                 (when (file-pathname-p f)
                   (let ((dependencies (package-inferred-system-file-dependencies f system))
-                        (previous (cdr (system-registered-p system))))
-                    (if (same-package-inferred-system-p previous system dir sub dependencies)
+                        (previous (cdr (system-registered-p system)))
+                        (around-compile (around-compile-hook top)))
+                    (if (same-package-inferred-system-p previous system dir sub around-compile dependencies)
                         previous
                         (eval `(defsystem ,system
                                  :class package-inferred-system
                                  :source-file nil
                                  :pathname ,dir
                                  :depends-on ,dependencies
+                                 :around-compile ,around-compile
                                  :components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))
 
 (with-upgradability ()
diff --git a/test/package-inferred-system-test.script b/test/package-inferred-system-test.script
index a11c320..6ff0891 100644
--- a/test/package-inferred-system-test.script
+++ b/test/package-inferred-system-test.script
@@ -6,3 +6,6 @@
 
 ;; No such file.
 (signals missing-component (load-system :package-inferred-system-test/f))
+
+;; Test that around-compile is inherited by inferred systems.
+(assert-equal 3 (symbol-call :package-inferred-system-test/a :add10 1)) ;; add10 must have been compiled in base 2
diff --git a/test/package-inferred-system-test/a.lisp b/test/package-inferred-system-test/a.lisp
index f87e709..e4a02a0 100644
--- a/test/package-inferred-system-test/a.lisp
+++ b/test/package-inferred-system-test/a.lisp
@@ -1 +1,18 @@
 (defpackage package-inferred-system-test/a (:use cl))
+
+(in-package :package-inferred-system-test/a)
+
+(eval-when (:compile-toplevel)
+  (format t "This is compile-time and the *read-base* is ~D~%" *read-base*))
+(eval-when (:load-toplevel)
+  (format t "This is load-time and the *read-base* is ~D~%" *read-base*))
+(eval-when (:execute)
+  (format t "This is execute-time and *read-base* is ~D~%" *read-base*))
+
+(defun tst (x)
+  (1+ x))
+
+(defun add10 (x)
+  (+ x 10))
+
+(format t "(add10 0) is (in decimal) ~D~%" (add10 0))
diff --git a/test/package-inferred-system-test/package-inferred-system-test.asd b/test/package-inferred-system-test/package-inferred-system-test.asd
index bf788a4..d19fd2a 100644
--- a/test/package-inferred-system-test/package-inferred-system-test.asd
+++ b/test/package-inferred-system-test/package-inferred-system-test.asd
@@ -3,4 +3,7 @@
 (defsystem package-inferred-system-test
   :class package-inferred-system
   :defsystem-depends-on
-  #.(unless (find-class 'package-inferred-system nil) '(:asdf-package-inferred-system)))
+  #.(unless (find-class 'package-inferred-system nil) '(:asdf-package-inferred-system))
+  :around-compile (lambda (thunk)
+                    (let ((*read-base* 2))
+                      (funcall thunk))))
-- 
2.6.3