Add Sacla to the repository.

1 files changed, 633 insertions, 0 deletions

diff --git a/Sacla/package.lisp b/Sacla/package.lisp
new file mode 100644
index 0000000..09e4efc
--- /dev/null
+++ b/Sacla/package.lisp
@@ -0,0 +1,633 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: package.lisp,v 1.21 2004/09/02 06:59:43 yuji Exp $
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;; 
+;;  * Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;  * Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in
+;;    the documentation and/or other materials provided with the
+;;    distribution.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(defstruct (package
+	     (:constructor %make-package)
+	     (:print-object print-package)
+	     (:predicate packagep))
+  ""
+  (%name nil :type (or string null))
+  (%nicknames nil :type list)
+  (%shadowing-symbols nil :type list)
+  (%use-list nil :type list)
+  (%used-by-list nil :type list)
+  (internal-symbols (make-hash-table :test 'equal) :type hash-table)
+  (external-symbols (make-hash-table :test 'equal) :type hash-table))
+
+(defun print-package (package stream)
+  (format stream "#<~A package (sumire)>" (package-%name package)))
+
+(defvar *keyword-package* (%make-package :%name "KEYWORD" :%nicknames '())
+  "")
+
+(defvar *cl-package* (%make-package :%name "COMMON-LISP" :%nicknames (list "CL"))
+  "")
+
+(defvar *cl-user-package*
+  (%make-package :%name "COMMON-LISP-USER" :%nicknames (list "CL-USER")
+		 :%use-list (list *cl-package*))
+  "")
+
+(setf (package-%used-by-list *cl-package*) (list *cl-user-package*))
+
+(defvar *package* *cl-user-package*
+  "The current package.")
+
+(defvar *all-packages* (list *cl-user-package* *cl-package* *keyword-package*)
+  "")
+
+(define-condition non-existent-package-name-error (package-error) ())
+
+(defun %package (designator)
+  (or (find-package designator)
+      (and (typep designator 'package-designator)
+	   (error 'non-existent-package-name-error :package designator))
+      (error 'type-error :datum designator :expected-type 'package-designator)))
+
+(defun %package-list (designator)
+  (mapcar #'%package (%list designator)))
+
+(defmacro in-package (name)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+    (setq *package* (%package ',name))))
+
+(defun list-all-packages ()
+  (copy-list *all-packages*))
+
+(defun find-registered-package (name)
+  (block this
+    (dolist (package *all-packages* nil)
+      (when (string= name (package-%name package))
+	(return-from this package))
+      (dolist (nickname (package-%nicknames package))
+	(when (string= name nickname)
+	  (return-from this package))))))
+
+(defun find-package (name)
+  (if (packagep name)
+      name
+      (find-registered-package (string name))))
+
+(defun unuse-package (packages-to-unuse &optional (package *package*))
+  (let ((packages-to-unuse (%package-list packages-to-unuse))
+	(package (%package package)))
+    (dolist (unuse packages-to-unuse t)
+      (setf (package-%use-list package)
+	    (remove unuse (package-%use-list package)))
+      (setf (package-%used-by-list unuse)
+	    (remove package (package-%used-by-list unuse))))))
+
+(defun package-name (package)
+  (copy-seq (package-%name (%package package))))
+
+(defun package-nicknames (package)
+  (copy-list (package-%nicknames (%package package))))
+
+(defun package-shadowing-symbols (package)
+  (copy-list (package-%shadowing-symbols (%package package))))
+
+(defun package-use-list (package)
+  (copy-list (package-%use-list (%package package))))
+
+(defun package-used-by-list (package)
+  (copy-list (package-%used-by-list (%package package))))
+
+(define-condition package-name-error (simple-error)
+  ((name :type string :reader package-name-error-name :initarg :name))
+  (:report (lambda (condition stream)
+             (format stream "A package named ~S already exists."
+                     (package-name-error-name condition)))))
+
+(defun rename-package (package new-name &optional new-nicknames)
+  (let* ((package (%package package))
+	 (new-name (string new-name))
+	 (new-nicknames (string-list new-nicknames)))
+    (dolist (name (cons new-name new-nicknames))
+      (let ((found (find-package name)))
+	(when (and found (not (eq package found)))
+	  (error 'package-name-error :name name))))
+    (setf (package-%name package) new-name
+	  (package-%nicknames package) new-nicknames)
+    package))
+
+(defun find-symbol (name &optional (package *package*))
+  (let ((name (string name))
+	(package (%package package)))
+    (multiple-value-bind (symbol registered-p)
+	(gethash name (package-external-symbols package))
+      (if registered-p
+	  (values symbol :external)
+	  (multiple-value-bind (symbol registered-p)
+	      (gethash name (package-internal-symbols package))
+	    (if registered-p
+		(values symbol :internal)
+		(dolist (used (package-use-list package) (values nil nil))
+		  (multiple-value-bind (symbol registered-p)
+		      (gethash name (package-external-symbols used))
+		    (when registered-p
+		      (return (values symbol :inherited)))))))))))
+
+(defun find-all-symbols (name)
+  (let ((name (string name))
+	(all-symbols nil))
+    (dolist (package (list-all-packages) (remove-duplicates all-symbols))
+      (multiple-value-bind (symbol status) (find-symbol name package)
+	(case status ((:internal :external) (push symbol all-symbols)))))))
+
+(defun accessible-symbol-p (symbol package)
+  (multiple-value-bind (symbol-found status)
+      (find-symbol (symbol-name symbol) package)
+    (and (eq symbol symbol-found) status)))
+
+(defun present-symbol-p (symbol package)
+  (multiple-value-bind (symbol-found status)
+      (find-symbol (symbol-name symbol) package)
+    (and (eq symbol-found symbol) (find status '(:internal :external)))))
+
+(define-condition unintern-would-reveal-name-conflict-error (package-error)
+  ((symbol :type symbol :reader unintern-error-symbol :initarg :symbol)))
+
+(defun unintern (symbol &optional (package *package*))
+  (flet ((conflicting-inherited-symbols (name package)
+	   (let ((symbols nil))
+	     (dolist (used-package (package-use-list package))
+	       (multiple-value-bind (symbol-found foundp)
+		   (gethash name (package-external-symbols used-package))
+		 (when foundp
+		   (pushnew symbol-found symbols))))
+	     (if (cdr symbols) symbols nil))))
+    (let* ((name (symbol-name symbol))
+	   (package (%package package))
+	   (present-p (present-symbol-p symbol package)))
+      (when present-p
+	(when (member symbol (package-shadowing-symbols package))
+	  (when (conflicting-inherited-symbols name package)
+	    (error 'unintern-would-reveal-name-conflict-error
+		   :symbol symbol :package package))
+	  (setf (package-%shadowing-symbols package)
+		(remove symbol (package-%shadowing-symbols package))))
+	(remhash name (ecase present-p
+			(:internal (package-internal-symbols package))
+			(:external (package-external-symbols package))))
+	(when (eq (symbol-package symbol) package)
+	  (setf (symbol-package symbol) nil))
+	t))))
+
+
+(defun shadowing-import (symbol-list-designator &optional (package *package*))
+  (let ((symbol-list (symbol-list symbol-list-designator))
+	(package (%package package)))
+    (dolist (symbol symbol-list t)
+      (let ((name (symbol-name symbol)))
+	(multiple-value-bind (symbol-found status) (find-symbol name package)
+	  (let ((present-p (member status '(:internal :external))))
+	    (when (and present-p (not (eq symbol symbol-found)))
+	      (unintern symbol-found package))
+	    (unless (and present-p (eq symbol symbol-found))
+	      (setf (gethash name (package-internal-symbols package)) symbol))
+	    (pushnew symbol (package-%shadowing-symbols package))))))))
+
+(define-condition import-would-cause-shadowing-error (package-error)
+  ((symbol :type symbol :reader import-error-symbol :initarg :symbol)))
+
+(defun import (symbol-list-designator &optional (package *package*))
+  (let ((symbol-list (symbol-list symbol-list-designator))
+	(package (%package package)))
+    (dolist (symbol symbol-list t)
+      (let ((name (symbol-name symbol)))
+	(multiple-value-bind (symbol-found status) (find-symbol name package)
+	  (cond
+	    ((and status (not (eq symbol symbol-found)))
+	     (cerror "Import this symbol with shadowing-import."
+		     'import-would-cause-shadowing-error
+		     :package package :symbol symbol)
+	     (shadowing-import symbol package))
+	    ((and (member status '(:internal :external))
+		  (eq symbol symbol-found))
+	     ;; The spec says `If the symbol is already present
+	     ;; in the importing package, import has no effect.'
+	     )
+	    (t
+	     (setf (gethash name (package-internal-symbols package)) symbol)
+	     (when (null (symbol-package symbol))
+	       (setf (symbol-package symbol) package)))))))))
+
+(define-condition use-package-would-cause-name-conflict-error (package-error)
+  ((names :type list :reader use-package-error-names :initarg :names)
+   (package-to-use :type package :reader use-package-error-package-to-use
+		   :initarg :package-to-use)))
+
+(defun check-use-package-name-conflict (using-package package-to-use)
+  (let* ((conflicting-names nil)
+	 (shadows (package-shadowing-symbols using-package))
+	 (user-tables (cons (package-internal-symbols using-package)
+			    (cons (package-external-symbols using-package)
+				  (mapcar #'package-external-symbols
+					  (package-use-list using-package)))))
+	 (fat-user
+	  (> (reduce #'+ user-tables :key #'hash-table-count)
+	     (hash-table-count (package-external-symbols package-to-use))))
+	 (tables (if fat-user
+		     (list (package-external-symbols package-to-use))
+		     user-tables))
+	 (package (if fat-user using-package package-to-use)))
+    (mapc #'(lambda (table)
+	      (maphash
+	       #'(lambda (name symbol)
+		   (multiple-value-bind (symbol-found status)
+		       (find-symbol name package)
+		     (when (and status
+				(not (eq symbol symbol-found))
+				(not (member name shadows :test #'string=)))
+		       (push name conflicting-names))))
+	       table))
+	  tables)
+    (when conflicting-names
+      (restart-case (error 'use-package-would-cause-name-conflict-error
+			   :names conflicting-names :package package
+			   :package-to-use package-to-use)
+	(continue ()
+	  :report "Shadowing-import the conflicting symbols."
+	  (shadowing-import (mapcar #'(lambda (name)
+					(find-symbol name package-to-use))
+				    conflicting-names)
+			    package))))))
+
+(defun use-package (package-to-use-list &optional (package *package*))
+  (let ((package-to-use-list (%package-list package-to-use-list))
+	(package (%package package)))
+    (dolist (package-to-use package-to-use-list t)
+      (cond
+	((member package-to-use (package-use-list package)))
+	((eq package-to-use *keyword-package*)
+	 (warn "The keyword package cannot be used by other packages."))
+	((eq package-to-use package)
+	 (warn "A package cannot use-package itself."))
+	(t (check-use-package-name-conflict package package-to-use)
+	   (push package-to-use (package-%use-list package))
+	   (push package (package-%used-by-list package-to-use)))))))
+
+(defun make-package (name &key nicknames use)
+  (let ((package
+	 (%make-package
+	  :%name (cond
+		   ((not (find-package name)) (string name))
+		   (t (cerror "Return the existing package."
+			      'package-name-error :name name)
+		      (return-from make-package (find-package name))))
+	  :%nicknames (mapcan
+		       #'(lambda (nickname)
+			   (cond
+			     ((string= nickname name) nil)
+			     ((find-package nickname)
+			      (cerror "Don't use this nickname."
+				      'package-name-error :name nickname))
+			     (t (list (string nickname)))))
+		       nicknames))))
+    (use-package use package)
+    (pushnew package *all-packages*)
+    package))
+
+(define-condition non-accessible-symbol-error (package-error)
+  ((symbol :type symbol
+	   :reader non-accessible-symbol-error-symbol :initarg :symbol)))
+(define-condition export-would-cause-conflict-in-user-package-error
+    (package-error)
+  ((symbol :type symbol :reader export-error-symbol :initarg :symbol)
+   (user-package :type package
+		 :reader export-error-user-package :initarg :user-package)))
+
+(defun export (symbol-list-designator &optional (package *package*))
+  (let ((symbol-list (symbol-list symbol-list-designator))
+	(package (%package package))
+	status)
+    (dolist (symbol symbol-list t)
+      (loop until (setq status (accessible-symbol-p symbol package))
+	    do
+	    (cerror "Import this symbol." 'non-accessible-symbol-error
+		    :package package :symbol symbol)
+	    (import (list symbol) package))
+      (unless (eq status :external)
+	(let ((name (symbol-name symbol)))
+	  (dolist (user (package-used-by-list package))
+	    (loop
+	     (multiple-value-bind (symbol-found status) (find-symbol name user)
+	       (when (or (null status) (eq symbol symbol-found))
+		 (return))
+	       (cerror "Shadowing-import the symbol in the user package."
+		       'export-would-cause-conflict-in-user-package-error
+		       :package package :user-package user :symbol symbol)
+	       (shadowing-import (list symbol) user))))
+	  (when (eq status :inherited)
+	    (import (list symbol) package))
+	  (remhash name (package-internal-symbols package))
+	  (setf (gethash name (package-external-symbols package)) symbol))))))
+    
+(defun unexport (symbol-list-designator &optional (package *package*))
+  (let ((symbol-list (symbol-list symbol-list-designator))
+	(package (%package package))
+	status)
+    (dolist (symbol symbol-list t)
+      (unless (setq status (accessible-symbol-p symbol package))
+	(cerror "Import this symbol." 'non-accessible-symbol-error
+		:package package :symbol symbol))
+      (when (eq status :external)
+	(remhash (symbol-name symbol) (package-external-symbols package))
+	(setf (gethash (symbol-name symbol) (package-internal-symbols package))
+	      symbol)))))
+
+(defun intern (name &optional (package *package*))
+  (let ((name (string name))
+	(package (%package package)))
+    (multiple-value-bind (symbol status) (find-symbol name package)
+      (if status
+	  (values symbol status)
+	  (let ((symbol (make-symbol name)))
+	    (import (list symbol) package)
+	    (when (eq package *keyword-package*)
+	      (export (list symbol) package)
+	      (setf (symbol-value symbol) symbol))
+	    (values symbol nil))))))
+
+(defun shadow (symbol-names &optional (package *package*))
+  (let ((symbol-names (string-list symbol-names))
+	(package (%package package)))
+    (dolist (name symbol-names t)
+      (multiple-value-bind (symbol status) (find-symbol name package)
+	(when (or (not status) (eq status :inherited))
+	  (setq symbol (make-symbol name))
+	  (setf (symbol-package symbol) package)
+	  (setf (gethash name (package-internal-symbols package)) symbol))
+	(pushnew symbol (package-%shadowing-symbols package))))))
+
+(defun hash-table-values (table)
+  (let ((values nil))
+    (with-hash-table-iterator (get table)
+      (loop (multiple-value-bind (more k v) (get)
+	      (declare (ignore k))
+	      (unless more (return))
+	      (push v values))))
+    values))
+  
+(defun package-symbol-tables (package type)
+  (ecase type
+    (:internal (list (package-internal-symbols package)))
+    (:external (list (package-external-symbols package)))
+    (:inherited (mapcar #'package-external-symbols
+			(package-use-list package)))))
+
+(define-condition package-symbol-types-error (program-error)
+  ((types :reader symbol-types-error-types :initarg :types)))
+
+(defun shadowed-name-p (name package)
+  (member name (package-shadowing-symbols package) :test #'string=))
+
+(defun package-iterator (package &rest symbol-types)
+  (unless symbol-types (error 'package-symbol-types-error :types symbol-types))
+  (unless package (return-from package-iterator (constantly nil)))
+  (let* ((package-list (%package-list package))
+	 (package (pop package-list))
+	 (type (first symbol-types))
+	 (type-list (rest symbol-types))
+	 (iterator (hash-table-iterator (package-symbol-tables package type))))
+    #'(lambda ()
+	(loop
+	 (multiple-value-bind (more name symbol) (funcall iterator)
+	   (cond
+	     (more
+	      (unless (and (eq type :inherited) (shadowed-name-p name package))
+		(return (values more symbol type package))))
+	     (t
+	      (cond
+		(type-list (setq type (pop type-list)))
+		(package-list (setq type      (first symbol-types)
+				    type-list (rest symbol-types)
+				    package (pop package-list)))
+		(t (return nil)))
+	      (setq iterator
+		    (hash-table-iterator (package-symbol-tables package
+								type))))))))))
+
+(defmacro with-package-iterator ((name package-list-form &rest symbol-types)
+				 &body body)
+  (unless symbol-types (error 'package-symbol-types-error :types symbol-types))
+  (let ((iterator (gensym)))
+    `(let ((,iterator (package-iterator ,package-list-form ,@symbol-types)))
+      (macrolet ((,name () '(funcall ,iterator)))
+	,@body))))
+
+(defmacro do-package-symbols ((var package result-form &rest type-list)
+			      &body body)
+  (let ((get (gensym))
+	(more (gensym))
+	(type (gensym))
+	(pkg (gensym)))
+    (multiple-value-bind (declarations forms) (declarations-and-forms body)
+      `(with-package-iterator (,get ,package ,@type-list)
+	(loop
+	 (multiple-value-bind (,more ,var ,type ,pkg) (,get)
+	   (declare (ignore ,type ,pkg))
+	   ,@declarations
+	   (unless ,more (return ,result-form))
+	   (tagbody
+	      ,@forms)))))))
+
+(defmacro do-symbols ((var &optional (package-form '*package*)
+			   result-form)
+		      &body body)
+  (let ((package (gensym)))
+    `(let ((,package (%package ,package-form)))
+      (do-package-symbols (,var ,package ,result-form
+			   :external :internal :inherited)
+	,@body))))
+
+(defmacro do-external-symbols ((var &optional (package-form '*package*)
+				    result-form)
+			       &body body)
+  (let ((package (gensym)))
+    `(let ((,package (%package ,package-form)))
+      (do-package-symbols (,var ,package ,result-form :external)
+	,@body))))
+
+(defmacro do-all-symbols ((var &optional result-form) &body body)
+  (let ((package (gensym))
+	(body-function (gensym)))
+    (multiple-value-bind (declarations forms) (declarations-and-forms body)
+      `(block nil
+	(flet ((,body-function (,var)
+		 (declare (ignorable ,var))
+		 ,@declarations
+		 (tagbody ,@forms)))
+	  (dolist (,package (list-all-packages) (let ((,var nil))
+						  (declare (ignorable ,var))
+						  ,@declarations
+						  ,result-form))
+	    (do-symbols (,var ,package nil)
+	      (,body-function ,var))))))))
+
+(define-condition deleting-package-used-by-others-error (package-error)
+  ())
+
+(defun delete-package (package)
+  (let ((package (or (find-package package)
+		     (return-from delete-package
+		       (cerror "Return NIL." 'non-existent-package-name-error
+			       :package package)))))
+    (when (package-name package)
+      (when (package-used-by-list package)
+	   (cerror "Remove dependency in other packages."
+		   'deleting-package-used-by-others-error :package package)
+	   (dolist (user (package-used-by-list package))
+	     (unuse-package package user)))
+      (unuse-package (package-use-list package) package)
+      (do-symbols (symbol package)
+	(unintern symbol package))
+      (setf (package-%name package) nil)
+      (setq *all-packages* (remove package *all-packages*))
+      t)))
+
+(define-condition unsupported-defpackage-option-error (program-error)
+  ((option :reader unsupported-defpackage-option-error-option :initarg :option)))
+
+(define-condition non-accessible-symbol-name-error (package-error)
+  ((name :type string
+	 :reader non-accessible-symbol-name-error-name :initarg :name)))
+
+(defun %accessible-symbols (name-list package)
+  (mapcar #'(lambda (name)
+	      (loop
+	       (multiple-value-bind (symbol status)
+		   (find-symbol name package)
+		 (when status
+		   (return symbol))
+		 (cerror "Intern this symbol." 'non-accessible-symbol-name-error
+			 :package package :name name)
+		 (intern (string name) package))))
+	  name-list))
+
+(defun check-disjoint(&rest args)
+  ;; An arg is (:key . set)
+  (do ((list args (cdr list)))
+      ((endp list))
+    (loop
+      with x = (car list)
+      for y in (rest list)
+      for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
+      when z do (error 'program-error
+		       :format-control "Parameters ~S and ~S must be disjoint ~
+					but have common elements ~%   ~S"
+		       :format-arguments (list (car x)(car y) z)))))
+
+(defmacro defpackage (package-name &rest options)
+  (let ((package-name (string package-name))
+	forms nicknames shadow shadowing-import-from use import-from intern
+	export documentation size)
+    (loop
+     for (key . values) in options
+     do
+     (case key
+       (:nicknames     (setq nicknames (append nicknames values)))
+       (:documentation (setq documentation (first values)))
+       (:shadow        (setq shadow (append shadow values)))
+       (:shadowing-import-from (push values shadowing-import-from))
+       (:use           (setq use (append use values)))
+       (:import-from   (push values import-from))
+       (:intern        (setq intern (append intern values)))
+       (:export        (setq export (append export values)))
+       (:size          (setq size (first values)))
+       (t (error 'unsupported-defpackage-option :option (cons key values)))))
+    (check-disjoint `(:intern ,@intern)
+		    `(:import-from ,@(apply #'append (mapcar #'rest
+							     import-from)))
+		    `(:shadow ,@shadow)
+		    `(:shadowing-import-from
+		      ,@(apply #'append (mapcar #'rest shadowing-import-from))))
+    (check-disjoint `(:intern ,@intern) `(:export  ,@export))
+    
+    (push `(let ((package (find-package ,package-name)))
+	    (if package
+		(rename-package package
+				,package-name (union ',(string-list nicknames)
+						     (package-nicknames package)
+						     :test #'string=))
+		(make-package ,package-name :nicknames ',nicknames :use nil)))
+	  forms)
+    (when documentation
+      (push `(setf (documentation ,package-name 'package) ,documentation) forms))
+    (when shadow (push `(shadow ',(string-list shadow) ,package-name) forms))
+    (when shadowing-import-from
+      (loop for (from . names) in shadowing-import-from
+	    do (push `(let ((names ',(string-list names)))
+		       (shadowing-import (%accessible-symbols names ',from)
+			,package-name))
+		     forms)))
+    (when use (push `(use-package ',use ,package-name) forms))
+    (when import-from
+      (loop for (from . names) in import-from
+	    do (push `(let ((names ',(string-list names)))
+		       (import (%accessible-symbols names ',from) ,package-name))
+		     forms)))
+    (when intern
+      (dolist (symbol intern)
+	(push `(intern ',symbol ,package-name) forms)))
+    (when export
+      (push `(export
+	      (mapcar #'(lambda (name) (intern name ,package-name)) ',export)
+	      ,package-name)
+	    forms))
+    (push `(find-package ,package-name) forms)
+    `(eval-when (:load-toplevel :compile-toplevel :execute)
+      ,@(nreverse forms))))
+
+;;;
+(defun clone-package-system ()
+  (let ((src-list (mapcar #'cl:find-package
+			  '("CL" "CL-USER" "KEYWORD" "TESTBED"))))
+    (dolist (src src-list)
+      (format t "Cloning the package ~S~%" src)
+      (let* ((name (cl:package-name src))
+	     (nicknames (cl:package-nicknames src))
+	     (dest (or (tb::find-package name)
+		       (tb::make-package name :nicknames nicknames))))
+	(cl:with-package-iterator (get src :internal :external)
+	  (loop
+	   (multiple-value-bind (more symbol status package) (get)
+	     (declare (ignore status package))
+	     (unless more (return))
+	     ;;(format t "shadowing symbols = ~S~%" (cl:package-shadowing-symbols src))
+	     (if (member symbol (cl:package-shadowing-symbols src))
+		 (shadowing-import (list symbol) dest)
+		 (progn
+		   ;;(format t "calling import~%")
+		   (import (list symbol) dest)
+		   ;;(format t "called import~%"
+		   )))))
+	(cl:do-external-symbols (symbol src)
+	  (export (list symbol) dest))))
+    (setq *package* (find-package (cl:package-name cl:*package*)))))
+