[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv26432

Modified Files:
	packages.lisp 
Log Message:
Add make-package and delete-package.


--- /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp	2008/04/19 12:45:03	1.14
+++ /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp	2008/04/21 19:41:52	1.15
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Aug 30 15:19:43 2001
 ;;;;                
-;;;; $Id: packages.lisp,v 1.14 2008/04/19 12:45:03 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.15 2008/04/21 19:41:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -25,14 +25,50 @@
 	    (:constructor make-package-object)
 	    (:conc-name package-object-))
   name
-  external-symbols
-  internal-symbols
+  (external-symbols (make-hash-table :test #'equal))
+  (internal-symbols (make-hash-table :test #'equal))
   shadowing-symbols-list
   use-list
   nicknames)
 
 (defvar *packages*)			; Set by dump-image.
 
+(deftype package-designator ()
+  '(or package string-designator))
+
+(defun make-package (name &key nicknames use)
+  (let ((name* (string name))
+        (nicknames* (mapcar #'string nicknames))
+        (use* (mapcar #'find-package use)))
+    (when (some #'null use*)
+      (warn "Cannot use nonexisting package ~S."
+            (find-if-not #'find-package use))
+      (setf use* (remove nil use*)))
+    (let ((existing-packages (remove-if-not #'find-package (cons name* nicknames*))))
+      (when existing-packages
+        (cerror "Create the package anyway."
+                "There already exist package~P by the name~:P ~{~A~^ ~}."
+                (length existing-packages)
+                existing-packages)))
+    (let ((package (make-package-object :name name*
+                                        :use-list use*
+                                        :nicknames nicknames*)))
+      (dolist (nickname nicknames*)
+        (setf (gethash nickname *packages*) package))
+      (setf (gethash name* *packages*) package))))
+
+(defun delete-package (package)
+  (let ((package (find-package package)))
+    (when (and (package-name package)
+               (eq package (find-package (package-name package))))
+      (dolist (nickname (package-nicknames package))
+        (when (eq package (gethash nickname *packages*))
+          (setf (gethash nickname *packages*) nil)))
+      (setf (gethash (package-name package) *packages*)
+            nil)
+      (setf (package-object-name package) nil)
+      t)))
+
 (defun package-name (object)
   (package-object-name (find-package object)))
 
@@ -45,9 +81,13 @@
 (defun find-package (name)
   (typecase name
     (package name)
-    (null (find-package 'common-lisp))	; This can be practical..
-    ((or symbol string) (find-package-string (string name)))
-    (t (error "Not a package name: ~S" name))))
+    (null
+     (find-package 'common-lisp))	; This can be practical..
+    (string-designator
+     (find-package-string (string name)))
+    (t (error 'type-error
+        :datum name
+        :expected-type 'package-designator))))
 
 (defun find-package-string (name &optional (start 0) (end (length name)) (key 'identity))
   (values (gethash-string name start end *packages* nil key)))