1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
3 ;;; File - conduit-packages.lisp
4 ;;; Description - Conduit packages, and package cloning
5 ;;; Author - Tim Bradshaw (tfb at lostwithiel)
6 ;;; Created On - Thu Sep 14 21:40:18 2000
7 ;;; Last Modified On - Tue Apr 30 15:10:56 2002
8 ;;; Last Modified By - Tim Bradshaw (tfb at lostwithiel)
12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14 ;;;; Conduit packages, and package cloning
16 ;;; tfb 24-Jul-1998 00:41:02, tfb 3-Jul-2000 21:52:48
18 ;;; Copyright 1998-2002 Tim Bradshaw. This code may be used for any
19 ;;; purpose whatsoever by anyone. It has no warranty whatsoever. I
20 ;;; would appreciate acknowledgement if you use it in anger, and I
21 ;;; would also very much appreciate any feedback or bug fixes.
23 ;;; This generalises the stuff in VERIFY-FORM.LISP
25 ;;; !!! TODO: more of the package operators probably need to be shadowed
26 ;;; Errors should be signalled as subtypes of PACKAGE-ERROR
28 (cl:defpackage
:iolib.internal.conduits
31 (:shadow
#:export
#:unexport
#:defpackage
#:delete-package
#:rename-package
)
32 (:export
#:export
#:unexport
#:defpackage
#:delete-package
#:rename-package
)
34 (:export
#:recompute-conduits
))
36 (in-package :iolib.internal.conduits
)
38 ;;;; Hack to make the HP stuff `work' even when they are not loaded.
41 ;;; Load HP if we can find it
44 (defun hp-alias-map (p)
45 (declare (ignorable p
))
46 #+org.tfeb.hax.hierarchical-packages
47 (gethash p org.tfeb.hax.hierarchical-packages
:*per-package-alias-table
*)
50 (defun (setf hp-alias-map
) (new p
)
51 ;; This one should never be called if HP is not loaded.
52 (declare (ignorable new p
))
53 #+org.tfeb.hax.hierarchical-packages
55 (gethash p org.tfeb.hax.hierarchical-packages
:*per-package-alias-table
*)
57 #-org.tfeb.hax.hierarchical-packages
58 (error "No hierarchical packages, so aliases will not work"))
60 (defun delete-hp-alias-map (p)
61 (declare (ignorable p
))
62 #+org.tfeb.hax.hierarchical-packages
63 (remhash p org.tfeb.hax.hierarchical-packages
:*per-package-alias-table
*))
66 ;;;; Conduit implementation
69 (defvar *conduit-package-descriptions
* '())
70 (defvar *package-conduits
* '())
71 (defvar *conduit-packages
* '())
73 (defun canonicalise-package-name (package/name
)
74 ;; Return a keyword, being the canonical name of the package.
75 ;; Second value is the package named, if it exists.
76 ;; maybe this should not use KEYWORD but our own secret package.
77 (etypecase package
/name
78 (package (values (intern (package-name package
/name
)
79 (find-package :keyword
))
82 (let ((found (find-package package
/name
)))
83 (values (intern (if found
85 (etypecase package
/name
87 (symbol (symbol-name package
/name
))))
88 (find-package :keyword
))
91 (defun note-conduit (pack conduit
)
92 (let ((pack (canonicalise-package-name pack
))
93 (conduit (canonicalise-package-name conduit
)))
94 (let ((found (assoc pack
*package-conduits
*)))
96 (pushnew conduit
(cdr found
))
97 (push (list pack conduit
) *package-conduits
*)))
98 (let ((found (assoc conduit
*conduit-packages
*)))
100 (pushnew pack
(cdr found
))
101 (push (list conduit pack
) *conduit-packages
*)))))
103 (defun recompute-conduits-for (pack &optional
(chain '()))
104 (let ((pack (canonicalise-package-name pack
)))
105 (when (member pack chain
)
106 (error "Circular conduits: ~S occurs in ~S" pack chain
))
107 (dolist (conduit (cdr (assoc pack
*package-conduits
*)))
108 (apply #'make-package-conduit-package
109 (assoc conduit
*conduit-package-descriptions
*))
110 (recompute-conduits-for conduit
(cons pack chain
)))
111 (find-package pack
)))
113 (defun clean-package-alist (pa)
114 ;; return a cleaned package alist: no nulls, no singletons, no nonexistent
115 ;; packages. Just blindly cons a new list here.
116 (mapcan #'(lambda (pl)
117 (let ((ppl (mapcan #'(lambda (p)
128 (defun recompute-conduits ()
129 "Clean up the lists of conduits, and recompute all conduit packages
130 to make them consistent"
131 (setf *package-conduits
* (clean-package-alist *package-conduits
*)
132 *conduit-packages
* (clean-package-alist *conduit-packages
*))
133 (dolist (pd *package-conduits
* (values))
134 (recompute-conduits-for (car pd
))))
137 (defun make-package-conduit-package (package/name
&key
141 (flet ((ensure-package (p)
143 ;; might want to be able to continue
144 (error "No package named ~S" p
)))
145 (ensure-external-symbol (d p
)
146 (multiple-value-bind (s state
)
147 (find-symbol (etypecase d
148 (symbol (symbol-name d
))
155 (error "Symbol name ~S not found in ~S" d p
))
157 (error "Symbol ~S internal in ~S" s p
))
159 (error "Symbol ~S not directly present in ~S" s p
)))))
160 (import-symbol (s pack
)
161 (cl:import
(if (eq s
'nil
)
165 (export-symbol (s pack
)
166 (cl:export
(if (eq s
'nil
)
170 (let ((package (ensure-package package
/name
)))
172 (note-conduit ex package
)
173 (do-external-symbols (s (ensure-package ex
))
174 (import-symbol s package
)
175 (export-symbol s package
)))
176 (dolist (ei extends
/including
)
177 (let ((p (ensure-package (first ei
))))
178 (note-conduit p package
)
179 (dolist (s (mapcar #'(lambda (sd)
180 (ensure-external-symbol sd p
))
182 (import-symbol s package
)
183 (export-symbol s package
))))
184 (dolist (ee extends
/excluding
)
185 (let* ((p (ensure-package (first ee
)))
186 (es (mapcar #'(lambda (sd)
187 (ensure-external-symbol sd p
))
189 (note-conduit p package
)
190 (do-external-symbols (s p
)
191 (unless (member s es
)
192 (import-symbol s package
)
193 (export-symbol s package
)))))
196 ;;; Cloning. Unlike conduits, cloning is a static operation: making a
197 ;;; clone of a package says to copy its state at a given moment and
198 ;;; then ignore any further changes. Redefining a clone package will
199 ;;; only pick up some of the changes - in particular symbols which
200 ;;; have been unexported from the cloned packages will not get
201 ;;; unexported and so on.
203 ;;; It may or may not make sense to clone multiple packages, this
204 ;;; function `supports' that because it's kind of implicit in the way
205 ;;; DEFPACKAGE works that you might get multiple packages.
207 ;;; It's not clear if any of this behaviour is right.
210 (defun clone-packages-to-package (froms to
)
211 (let ((to (or (find-package to
)
212 (make-package to
:use
'()))))
213 (loop :for f
:in froms
214 :for from
:= (find-package f
)
215 :for used
:= (package-use-list from
)
216 :for shadows
:= (package-shadowing-symbols from
)
217 :for exports
:= (let ((exps '()))
218 (do-external-symbols (s from exps
)
220 :for interned-symbols
:= (let ((ints '()))
221 (do-symbols (s from ints
)
222 (when (eq (symbol-package s
) from
)
224 :when interned-symbols
225 :do
(import interned-symbols to
)
227 :do
(shadow shadows to
)
229 :do
(export exports to
)
231 :do
(use-package used to
))
232 (loop :with aliases
:= '()
234 :for from
:= (find-package f
)
235 :do
(loop :for e
:in
(hp-alias-map from
)
236 :when
(assoc (first e
) aliases
239 (error "Duplicate package alias when cloning ~A" (first e
))
240 :do
(push e aliases
))
241 :finally
(when aliases
242 ;; Make sure we only call this if there were aliases
243 (setf (hp-alias-map to
) (nreverse aliases
))))
246 ;;;; Define the basic package operations we need to take over.
248 ;;; !!! Others may need to be added here. I think that UNINTERN is OK,
249 ;;; but I'm not sure about others.
251 (defun export (symbol/s
&optional
(package *package
*))
253 (cl:export symbol
/s package
)
254 (recompute-conduits-for package
)))
256 (defun unexport (symbol/s
&optional
(package *package
*))
258 (cl:unexport symbol
/s package
)
259 (recompute-conduits-for package
)))
261 (defmacro defpackage
(name &body clauses
) ;+++export
262 "Define a package. See CL:DEFPACKAGE for tha basics.
263 In addition, this version of DEFPACKAGE can define a `conduit package':
264 that you can use as a conduit to extend existing packages.
265 This works by importing symbols from the existing packages and
266 then reexporting them. The syntax is as DEFPACKAGE, wiht the addition
267 of three new clauses:
268 (:EXTEND package) takes package and reexports all its symbols;
269 (:EXTEND/INCLUDING package . syms/names) reexports only syms/names;
270 (:EXTEND/EXCLUDING package . syms/names) reexports all *but* syms/names.
271 When defining a conduit package no packages are :USEd by default.
273 If hierarchical packages are loaded when conduits is built (yes, I know)
274 Then you can also say
275 (:ALIASES (name realname) ...)
276 Which will cause name to be a shorthand for realname when the package
277 Being defined is the current package. Aliases are not inherited from
280 This version of DEFPACKAGE also support `cloning' packages: making another
281 package which is `just like' an existing package. This means that all the
282 internal, exported and shadowing symbols in the clone will be the same as
283 those in the cloned package, but any additional things defined by DEFPACKAGE
284 will also take effect. This allows you to essentially make a copy of
285 a package which you can then use to define new functionality without
286 interning a lot of things in the original package. Cloning is a static
287 operation - packages do not know who their clones are, and no attempt is made
288 to keep clones up to date. Cloning is done by the clause
290 Cloning is not compatible with extending (this is checked).
291 As with extending you probably want to specify (:USE) when cloning."
292 (let ((dpcs '()) (excs '()) (eics ()) (eecs '()) (cpcs '())
293 (package-aliases '()))
300 (push (rest c
) eics
))
302 (push (rest c
) eecs
))
307 (loop :for e
:in
(rest c
)
308 :unless
(and (consp e
)
316 "Package aliases should be list of (STRING STRING)")
317 :when
(assoc (string (first e
)) package-aliases
320 (error "Duplicate package alias ~A" (first e
))
321 :do
(push (cons (string (first e
)) (string (second e
)))
325 (when (and cpcs
(or excs eics eecs
))
326 (error "Cloning is not compatible with extending"))
327 (when (and cpcs package-aliases
)
328 (error "Cloning is not compatible with package aliases"))
329 (unless (find :use dpcs
:key
'car
)
330 (push (list :use
) dpcs
))
331 (cond ((or excs eics eecs package-aliases
)
335 ;; need always to do this because defpackage is always done.
336 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
337 (let* ((cn (canonicalise-package-name ',name
))
338 (found (assoc cn
*conduit-package-descriptions
*))
339 (descr '(:extends
,(nreverse excs
)
340 :extends
/including
,(nreverse eics
)
341 :extends
/excluding
,(nreverse eecs
))))
343 (setf (cdr found
) descr
)
344 (push (cons cn descr
) *conduit-package-descriptions
*))
345 (apply #'make-package-conduit-package cn descr
))
346 ,@(when package-aliases
347 `((setf (hp-alias-map (find-package ',name
))
348 ',(nreverse package-aliases
))))
349 (recompute-conduits-for ',name
))))
354 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
355 (clone-packages-to-package ',cpcs
',name
))))
358 (cl:defpackage
,name
,@(nreverse dpcs
))
359 (recompute-conduits-for ',name
))))))
361 (defun delete-package (pack/name
)
362 (let ((name (canonicalise-package-name pack
/name
)))
363 (let ((conduits (cdr (assoc name
*package-conduits
*))))
365 (error "Trying to delete ~S, but it has conduits ~S"
366 (find-package pack
/name
) (mapcar #'find-package conduits
))))
369 (delete-hp-alias-map (find-package pack
/name
))
370 (cl:delete-package pack
/name
))
371 ;; NAME can occur in *CONDUIT-PACKAGES* if it was a conduit.
372 ;; NAME can occur in *PACKAGE-CONDUITS* if it had conduits
373 ;; (there will not now be any)
374 (setf *conduit-packages
* (delete name
*conduit-packages
* :key
#'car
)
375 *package-conduits
* (delete name
*package-conduits
* :key
#'car
)))))
377 (defun rename-package (pack/name new-name
&optional
(nicknames '()))
379 (cl:rename-package pack
/name new-name nicknames
)
380 (let ((name (canonicalise-package-name pack
/name
))
381 (new-name (canonicalise-package-name new-name
)))
382 (dolist (c *conduit-packages
*)
383 (nsubstitute new-name name c
))
384 (dolist (p *package-conduits
*)
385 (nsubstitute new-name name p
)))))