src/new-cl/conduits.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   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)
   9 ;;; Update Count     - 10
  10 ;;; Status           - Unknown
  11 ;;;
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13
  14 ;;;; Conduit packages, and package cloning
  15 ;;;
  16 ;;; tfb 24-Jul-1998 00:41:02, tfb 3-Jul-2000 21:52:48
  17 ;;;
  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.
  22 ;;;
  23 ;;; This generalises the stuff in VERIFY-FORM.LISP
  24 ;;;
  25 ;;; !!! TODO: more of the package operators probably need to be shadowed
  26 ;;;           Errors should be signalled as subtypes of PACKAGE-ERROR
  27
  28 (cl:defpackage :iolib.internal.conduits
  29   (:use :common-lisp)
  30   ;; redefined CL names
  31   (:shadow #:export #:unexport #:defpackage #:delete-package #:rename-package)
  32   (:export #:export #:unexport #:defpackage #:delete-package #:rename-package)
  33   ;; non-CL thing
  34   (:export #:recompute-conduits))
  35
  36 (in-package :iolib.internal.conduits)
  37
  38 ;;;; Hack to make the HP stuff `work' even when they are not loaded.
  39 ;;;
  40
  41 ;;; Load HP if we can find it
  42 ;;;
  43
  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*)
  48   '())
  49
  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
  54   (setf
  55    (gethash p org.tfeb.hax.hierarchical-packages:*per-package-alias-table*)
  56    new)
  57   #-org.tfeb.hax.hierarchical-packages
  58   (error "No hierarchical packages, so aliases will not work"))
  59
  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*))
  64 \f
  65
  66 ;;;; Conduit implementation
  67 ;;;
  68
  69 (defvar *conduit-package-descriptions* '())
  70 (defvar *package-conduits* '())
  71 (defvar *conduit-packages* '())
  72
  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))
  80                      package/name))
  81     ((or string symbol)
  82      (let ((found (find-package package/name)))
  83        (values (intern (if found
  84                            (package-name found)
  85                            (typecase package/name
  86                              (string package/name)
  87                              (symbol (symbol-name package/name))))
  88                        (find-package :keyword))
  89                found)))))
  90
  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*)))
  95       (if found
  96           (pushnew conduit (cdr found))
  97           (push (list pack conduit) *package-conduits*)))
  98     (let ((found (assoc conduit *conduit-packages*)))
  99       (if found
 100           (pushnew pack (cdr found))
 101           (push (list conduit pack) *conduit-packages*)))))
 102
 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)))
 112
 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)
 118                                      (if (find-package p)
 119                                          (list p)
 120                                          nil))
 121                                  pl)))
 122                 (if (or (null ppl)
 123                         (null (cdr ppl)))
 124                     nil
 125                     (list ppl))))
 126           pa))
 127
 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))))
 135
 136
 137 (defun make-package-conduit-package (package/name &key
 138                                                   extends
 139                                                   extends/including
 140                                                   extends/excluding)
 141   (flet ((ensure-package (p)
 142            (let ((package (etypecase p
 143                             (package p)
 144                             ((or symbol string) (find-package p)))))
 145              (unless package
 146                ;; might want to be able to continue
 147                (error "No package named ~S" p))
 148              package))
 149          (ensure-external-symbol (d p)
 150            (multiple-value-bind (s state)
 151                (find-symbol (etypecase d
 152                               (symbol (symbol-name d))
 153                               (string d))
 154                             p)
 155              (ecase state
 156                ((:external)
 157                 s)
 158                ((nil)
 159                 (error "Symbol name ~S not found in ~S" d p))
 160                ((:internal)
 161                 (error "Symbol ~S internal in ~S" s p))
 162                ((:inherited)
 163                 (error "Symbol ~S not directly present in ~S" s p)))))
 164          (import-symbol (s pack)
 165            (cl:import (if (eq s 'nil)
 166                           '(nil)
 167                           s)
 168                       pack))
 169          (export-symbol (s pack)
 170            (cl:export (if (eq s 'nil)
 171                           '(nil)
 172                           s)
 173                       pack)))
 174     (let ((package (ensure-package package/name)))
 175       (dolist (ex extends)
 176         (note-conduit ex package)
 177         (do-external-symbols (s (ensure-package ex))
 178           (import-symbol s package)
 179           (export-symbol s package)))
 180       (dolist (ei extends/including)
 181         (let ((p (ensure-package (first ei))))
 182           (note-conduit p package)
 183           (dolist (s (mapcar #'(lambda (sd)
 184                                  (ensure-external-symbol sd p))
 185                              (rest ei)))
 186             (import-symbol s package)
 187             (export-symbol s package))))
 188       (dolist (ee extends/excluding)
 189         (let* ((p (ensure-package (first ee)))
 190                (es (mapcar #'(lambda (sd)
 191                                (ensure-external-symbol sd p))
 192                            (rest ee))))
 193           (note-conduit p package)
 194           (do-external-symbols (s p)
 195             (unless (member s es)
 196               (import-symbol s package)
 197               (export-symbol s package)))))
 198       package)))
 199
 200 ;;; Cloning.  Unlike conduits, cloning is a static operation: making a
 201 ;;; clone of a package says to copy its state at a given moment and
 202 ;;; then ignore any further changes.  Redefining a clone package will
 203 ;;; only pick up some of the changes - in particular symbols which
 204 ;;; have been unexported from the cloned packages will not get
 205 ;;; unexported and so on.
 206 ;;;
 207 ;;; It may or may not make sense to clone multiple packages, this
 208 ;;; function `supports' that because it's kind of implicit in the way
 209 ;;; DEFPACKAGE works that you might get multiple packages.
 210 ;;;
 211 ;;; It's not clear if any of this behaviour is right.
 212 ;;;
 213
 214 (defun clone-packages-to-package (froms to)
 215   (let ((to (typecase to
 216               (package to)
 217               (t (or (find-package to)
 218                      (make-package to :use '()))))))
 219     (when (null to)
 220       (error "No target package..."))
 221     (loop :for f :in froms
 222           :for from := (typecase f
 223                          (package f)
 224                          (t (find-package f)))
 225           :for used := (package-use-list from)
 226           :for shadows := (package-shadowing-symbols from)
 227           :for exports := (let ((exps '()))
 228                             (do-external-symbols (s from exps)
 229                               (push s exps)))
 230           :for interned-symbols := (let ((ints '()))
 231                                      (do-symbols (s from ints)
 232                                        (when (eq (symbol-package s) from)
 233                                          (push s ints))))
 234           :when interned-symbols
 235           :do (import interned-symbols to)
 236           :when shadows
 237           :do (shadow shadows to)
 238           :when exports
 239           :do(export exports to)
 240           :when used
 241           :do (use-package used to))
 242     (loop :with aliases := '()
 243           :for f :in froms
 244           :for from := (typecase f
 245                          (package f)
 246                          (t (find-package f)))
 247           :do (loop :for e :in (hp-alias-map from)
 248                     :when (assoc (first e) aliases
 249                                  :test #'string=)
 250                     :do
 251                     (error "Duplicate package alias when cloning ~A" (first e))
 252                     :do (push e aliases))
 253           :finally (when aliases
 254                     ;; Make sure we only call this if there were aliases
 255                     (setf (hp-alias-map to) (nreverse aliases))))
 256     to))
 257
 258 ;;;; Define the basic package operations we need to take over.
 259 ;;;
 260 ;;; !!! Others may need to be added here.  I think that UNINTERN is OK,
 261 ;;; but I'm not sure about others.
 262
 263 (defun export (symbol/s &optional (package *package*))
 264   (prog1
 265     (cl:export symbol/s package)
 266     (recompute-conduits-for package)))
 267
 268 (defun unexport (symbol/s &optional (package *package*))
 269   (prog1
 270     (cl:unexport symbol/s package)
 271     (recompute-conduits-for package)))
 272
 273 (defmacro defpackage (name &body clauses)       ;+++export
 274   "Define a package.  See CL:DEFPACKAGE for tha basics.
 275 In addition, this version of DEFPACKAGE can define a `conduit package':
 276 that you can use as a conduit to extend existing packages.
 277 This works by importing symbols from the existing packages and
 278 then reexporting them. The syntax is as DEFPACKAGE, wiht the addition
 279 of three new clauses:
 280         (:EXTEND package) takes package and reexports all its symbols;
 281         (:EXTEND/INCLUDING package . syms/names) reexports only syms/names;
 282         (:EXTEND/EXCLUDING package . syms/names) reexports all *but* syms/names.
 283 When defining a conduit package no packages are :USEd by default.
 284
 285 If hierarchical packages are loaded when conduits is built (yes, I know)
 286 Then you can also say
 287         (:ALIASES (name realname) ...)
 288 Which will cause name to be a shorthand for realname when the package
 289 Being defined is the current package.  Aliases are not inherited from
 290 conduits.
 291
 292 This version of DEFPACKAGE also support `cloning' packages: making another
 293 package which is `just like' an existing package. This means that all the
 294 internal, exported and shadowing symbols in the clone will be the same as
 295 those in the cloned package, but any additional things defined by DEFPACKAGE
 296 will also take effect.  This allows you to essentially make a copy of
 297 a package which you can then use to define new functionality without
 298 interning a lot of things in the original package.  Cloning is a static
 299 operation - packages do not know who their clones are, and no attempt is made
 300 to keep clones up to date.  Cloning is done by the clause
 301         (:CLONES package)
 302 Cloning is not compatible with extending (this is checked).
 303 As with extending you probably want to specify (:USE) when cloning."
 304   (let ((dpcs '()) (excs '()) (eics ()) (eecs '()) (cpcs '())
 305         (package-aliases '()))
 306     (dolist (c clauses)
 307       (case (first c)
 308         (:extend
 309          (dolist (e (rest c))
 310            (push e excs)))
 311         (:extend/including
 312          (push (rest c) eics))
 313         (:extend/excluding
 314          (push (rest c) eecs))
 315         (:clone
 316          (dolist (e (rest c))
 317            (push e cpcs)))
 318         (:aliases
 319          (loop :for e :in (rest c)
 320                :unless (and (consp e)
 321                             (typep (first e)
 322                                    '(or symbol string))
 323                             (typep (second e)
 324                                    '(or symbol string))
 325                             (null (cddr e)))
 326                :do
 327                (error
 328                 "Package aliases should be list of (STRING STRING)")
 329                :when (assoc (string (first e)) package-aliases
 330                             :test #'string=)
 331                :do
 332                (error "Duplicate package alias ~A" (first e))
 333                :do (push (cons (string (first e)) (string (second e)))
 334                          package-aliases)))
 335         (otherwise
 336          (push c dpcs))))
 337     (when (and cpcs (or excs eics eecs))
 338       (error "Cloning is not compatible with extending"))
 339     (when (and cpcs package-aliases)
 340       (error "Cloning is not compatible with package aliases"))
 341     (unless (find :use dpcs :key 'car)
 342       (push (list :use) dpcs))
 343     (cond ((or excs eics eecs package-aliases)
 344            `(progn
 345               (cl:defpackage ,name
 346                 ,@(nreverse dpcs))
 347               ;; need always to do this because defpackage is always done.
 348               (eval-when (:compile-toplevel :load-toplevel :execute)
 349                 (let* ((cn (canonicalise-package-name ',name))
 350                        (found (assoc cn *conduit-package-descriptions*))
 351                        (descr '(:extends ,(nreverse excs)
 352                                 :extends/including ,(nreverse eics)
 353                                 :extends/excluding ,(nreverse eecs))))
 354                   (if found
 355                       (setf (cdr found) descr)
 356                     (push (cons cn descr) *conduit-package-descriptions*))
 357                   (apply #'make-package-conduit-package cn descr))
 358                 ,@(when package-aliases
 359                     `((setf (hp-alias-map (find-package ',name))
 360                             ',(nreverse package-aliases))))
 361                 (recompute-conduits-for ',name))))
 362           (cpcs
 363            `(progn
 364               (cl:defpackage ,name
 365                 ,@(nreverse dpcs))
 366               (eval-when (:compile-toplevel :load-toplevel :execute)
 367                 (clone-packages-to-package ',cpcs ',name))))
 368           (t
 369            `(progn
 370               (cl:defpackage ,name ,@(nreverse dpcs))
 371               (recompute-conduits-for ',name))))))
 372
 373 (defun delete-package (pack/name)
 374   (let ((name (canonicalise-package-name pack/name)))
 375     (let ((conduits (cdr (assoc name *package-conduits*))))
 376       (when conduits
 377         (error "Trying to delete ~S, but it has conduits ~S"
 378                (find-package pack/name) (mapcar #'find-package conduits))))
 379     (prog1
 380         (progn
 381           (delete-hp-alias-map (find-package pack/name))
 382           (cl:delete-package pack/name))
 383       ;; NAME can occur in *CONDUIT-PACKAGES* if it was a conduit.
 384       ;; NAME can occur in *PACKAGE-CONDUITS* if it had conduits
 385       ;; (there will not now be any)
 386       (setf *conduit-packages* (delete name *conduit-packages* :key #'car)
 387             *package-conduits* (delete name *package-conduits* :key #'car)))))
 388
 389 (defun rename-package (pack/name new-name &optional (nicknames '()))
 390   (prog1
 391     (cl:rename-package pack/name new-name nicknames)
 392     (let ((name (canonicalise-package-name pack/name))
 393           (new-name (canonicalise-package-name new-name)))
 394       (dolist (c *conduit-packages*)
 395         (nsubstitute new-name name c))
 396       (dolist (p *package-conduits*)
 397         (nsubstitute new-name name p)))))