[asdf-devel] compile-with-nicknames

[Gábor Balázs]

Here is the implementation for call-with-package-renamings (see attachment).
I also attached its test case. I successfully tested this on ccl, scl and
clisp.
The run-tests.sh script didn't work for me with sbcl (conflicted with my
system settings), so I skipped that...

Best,
`bg`


2011/10/17 Faré <fahree at gmail.com>

> > I don't see how can you manipulate things by defining subclasses of
> > cl-source-file.
>
> (defpackage :my-system-system
>  (:use :asdf :cl))
>
> (in-package :my-system-system)
>
> (defclass my-cl-source-file (cl-source-file) ())
>
> (defmethod perform ((op compile-op) (c my-cl-source-file))
>  ...) ;; wrapping!
>
> (defsystem :my-system
>  :default-component-class my-cl-source-file
>  :components
>  ((cl-source-file "package") ;; override the new default, so this one
> isn't wrapped!
>   (:file "macros" :depends-on ("package"))
>   ...))
>
> > I have to admit that I don't understand how components are created in
> asdf.
> > My best guess (by looking at the class-for-type function) is that
> everything
> > defined in the defsystem by :file and having .lisp extension becomes
> > *default-component-class* which is cl-source-file.
> >
> Yup. ASDF is really straightforward. Especially after all the
> refactoring we did for ASDF 2,
> for the only way we managed to make sense of the code we inherited was
> to simplify it.
> See also the article Robert and I wrote on ASDF:
> http://common-lisp.net/project/asdf/ilc2010draft.pdf
>
> > And I neither want to introduce a new syntax next to :file, nor change my
> > lisp file extensions to something else.
> > So I don't see how your components can become subclasses of
> cl-source-file
> > at all.
> >
>
> Doing it with the new :around-compile feature, it would be:
>
> (defun my-package-frob-hook (thunk)
>  (call-with-package-renamings
>     '((long-name-1 shrtnm1)
>       (long-name-2 shrtnm2))
>     (funcall thunk)))
>
> (defsystem :my-system
>   :depends-on ((:version :asdf "2.017.18"))
>   :around-compile my-package-frob-hook
>  :components
>  ((:file "package" :around-compile nil) ;; no frobbing around this one
>   (:file "macros" :depends-on ("package"))
>   ...))
>
> —♯ƒ • François-René ÐVB Rideau •Reflection&Cybernethics•
> http://fare.tunes.org
> The reason why we must be tolerant is NOT that everyone is as right as
> everyone else. It is that no system allows to reliably distinguish right
> and wrong beforehand. Only by having the right to err can one have the
> right to be correct. The attitude of toleration is thus to let the fools be
> victims of their own folly rather than of ours, as long as they in turn
> do not impose their folly upon us.
>                 — Faré
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/asdf-devel/attachments/20111018/f9450bbd/attachment.html>
-------------- next part --------------
diff --git a/asdf.lisp b/asdf.lisp
index c328d72..0e605b2 100755
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -348,6 +348,7 @@
 
             ;; Utilities
             #:absolute-pathname-p
+            #:call-with-package-renamings
             ;; #:aif #:it
             ;; #:appendf
             #:coerce-name
@@ -2250,6 +2251,36 @@ recursive calls to traverse.")
 (defmethod perform :after ((operation operation) (c component))
   (mark-operation-done operation c))
 
+(defun set-renamings (renamings)
+  (let ((saved-nicknames nil))
+    (loop for rename-entry in renamings
+       do (let* ((package (first rename-entry))
+                 (rename-def (second rename-entry))
+                 (old-nicknames (package-nicknames package))
+                 (new-nicknames (union old-nicknames
+                                       (if (listp rename-def)
+                                           rename-def
+                                           (list rename-def))
+                                       :test #'string-equal)))
+            (push (list package old-nicknames) saved-nicknames)
+            (rename-package package package new-nicknames)))
+    saved-nicknames))
+
+(defun clear-renamings (saved-renamings)
+  (loop for rename-entry in saved-renamings
+     do (let ((package (first rename-entry)))
+          (rename-package package package (second rename-entry)))))
+
+(defmacro call-with-package-renamings (renamings &body body)
+  "Apply package RENAMINGS around BODY. The specified package nicknames
+ should not cause any conflicts, otherwise the consequences are the same
+ as for the RENAME-PACKAGE function."
+  (let ((saved-renamings (gensym)))
+    `(let ((,saved-renamings (set-renamings ',renamings)))
+       (unwind-protect
+            (progn , at body)
+         (clear-renamings ,saved-renamings)))))
+
 (defgeneric* call-with-around-compile-hook (component thunk))
 (defgeneric* around-compile-hook (component))
 
-------------- next part --------------
A non-text attachment was scrubbed...
Name: test-renamings.asd
Type: application/octet-stream
Size: 516 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/asdf-devel/attachments/20111018/f9450bbd/attachment.obj>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: test-renamings.script
Type: application/octet-stream
Size: 344 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/asdf-devel/attachments/20111018/f9450bbd/attachment-0001.obj>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: test-renamings-file.lisp
Type: application/octet-stream
Size: 170 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/asdf-devel/attachments/20111018/f9450bbd/attachment-0002.obj>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: test-renamings-package.lisp
Type: application/octet-stream
Size: 423 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/asdf-devel/attachments/20111018/f9450bbd/attachment-0003.obj>