X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefpackage.lisp;h=c7772c8bf69d3a956aeca699336fb065984bf2bb;hb=b2ad48f269cd6b9403820588d65eac526e4e32fd;hp=198986947670562bd998a79266184cafa545f509;hpb=902e93736a0888aa6b04dc328b1eb328423bf426;p=sbcl.git

diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp
index 1989869..c7772c8 100644
--- a/src/code/defpackage.lisp
+++ b/src/code/defpackage.lisp
@@ -28,19 +28,24 @@
     nil))
 
 (defmacro defpackage (package &rest options)
-  #!+sb-doc
-  "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
-   following:
-     (:NICKNAMES {package-name}*)
-     (:SIZE <integer>)
-     (:SHADOW {symbol-name}*)
-     (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
-     (:USE {package-name}*)
-     (:IMPORT-FROM <package-name> {symbol-name}*)
-     (:INTERN {symbol-name}*)
-     (:EXPORT {symbol-name}*)
-     (:DOCUMENTATION doc-string)
-   All options except :SIZE and :DOCUMENTATION can be used multiple times."
+  #!+sb-doc 
+  #.(format nil 
+  "Defines a new package called PACKAGE. Each of OPTIONS should be one of the 
+   following: ~{~&~4T~A~}
+   All options except ~{~A, ~}and :DOCUMENTATION can be used multiple 
+   times."
+  '((:nicknames "{package-name}*")
+    (:size "<integer>")
+    (:shadow "{symbol-name}*")
+    (:shadowing-import-from "<package-name> {symbol-name}*")
+    (:use "{package-name}*")
+    (:import-from "<package-name> {symbol-name}*")
+    (:intern "{symbol-name}*")
+    (:export "{symbol-name}*")
+    #!+sb-package-locks (:implement "{package-name}*")
+    #!+sb-package-locks (:lock "boolean")
+    (:documentation "doc-string"))
+  '(:size #!+sb-package-locks :lock))
   (let ((nicknames nil)
 	(size nil)
 	(shadows nil)
@@ -50,7 +55,12 @@
 	(imports nil)
 	(interns nil)
 	(exports nil)
+	(implement (stringify-names (list package) "package"))
+	(implement-p nil)
+	(lock nil)
 	(doc nil))
+    #!-sb-package-locks    
+    (declare (ignore implement-p))
     (dolist (option options)
       (unless (consp option)
 	(error 'simple-program-error
@@ -100,6 +110,19 @@
 	(:export
 	 (let ((new (stringify-names (cdr option) "symbol")))
 	   (setf exports (append exports new))))
+	#!+sb-package-locks
+	(:implement
+	 (unless implement-p 
+	   (setf implement nil))
+	 (let ((new (stringify-names (cdr option) "package")))
+	   (setf implement (append implement new)
+		 implement-p t)))
+	#!+sb-package-locks
+	(:lock
+	 (when lock
+	   (error 'simple-program-error
+		  :format-control "multiple :LOCK options"))
+	 (setf lock (coerce (second option) 'boolean)))
 	(:documentation
 	 (when doc
 	   (error 'simple-program-error
@@ -119,7 +142,7 @@
     `(eval-when (:compile-toplevel :load-toplevel :execute)
        (%defpackage ,(stringify-name package "package") ',nicknames ',size
 		    ',shadows ',shadowing-imports ',(if use-p use :default)
-		    ',imports ',interns ',exports ',doc))))
+		    ',imports ',interns ',exports ',implement ',lock ',doc))))
 
 (defun check-disjoint (&rest args)
   ;; An arg is (:key . set)
@@ -131,17 +154,15 @@
       for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
       when z do (error 'simple-program-error
 		       :format-control "Parameters ~S and ~S must be disjoint ~
-					but have common elements ~%   ~S"
+                                        but have common elements ~%   ~S"
 		       :format-arguments (list (car x)(car y) z)))))
 
 (defun stringify-name (name kind)
-  (/show0 "in STRINGIFY-NAME, NAME=..")
-  (/hexstr name)
   (typecase name
-    (simple-base-string name)
-    (base-string (coerce name 'simple-base-string))
+    (simple-string name)
+    (string (coerce name 'simple-string))
     (symbol (symbol-name name))
-    (base-char (string name))
+    (character (string name))
     (t
      (error "bogus ~A name: ~S" kind name))))
 
@@ -151,12 +172,14 @@
 	  names))
 
 (defun %defpackage (name nicknames size shadows shadowing-imports
-			 use imports interns exports doc-string)
-  (declare (type simple-base-string name)
+		    use imports interns exports implement lock doc-string)
+  (declare (type simple-string name)
 	   (type list nicknames shadows shadowing-imports
 		 imports interns exports)
 	   (type (or list (member :default)) use)
-	   (type (or simple-base-string null) doc-string))
+	   (type (or simple-string null) doc-string)
+	   #!-sb-package-locks
+	   (ignore implement lock))
   (let ((package (or (find-package name)
 		     (progn
 		       (when (eq use :default)
@@ -184,8 +207,9 @@
 	      (shadowing-import sym package)
 	      (setf old-shadows (remove sym old-shadows))))))
       (when old-shadows
-	(warn "~A also shadows the following symbols:~%  ~S"
-	      name old-shadows)))
+	(warn 'package-at-variance
+	      :format-control "~A also shadows the following symbols:~%  ~S"
+	      :format-arguments (list name old-shadows))))
     ;; Handle USE.
     (unless (eq use :default)
       (let ((old-use-list (package-use-list package))
@@ -194,9 +218,9 @@
 	(let ((laterize (set-difference old-use-list new-use-list)))
 	  (when laterize
 	    (unuse-package laterize package)
-	    (warn "~A used to use the following packages:~%  ~S"
-		  name
-		  laterize)))))
+	    (warn 'package-at-variance
+		  :format-control "~A used to use the following packages:~%  ~S"
+		  :format-arguments (list name laterize))))))
     ;; Handle IMPORT and INTERN.
     (dolist (sym-name interns)
       (intern sym-name package))
@@ -215,7 +239,16 @@
       (export exports package)
       (let ((diff (set-difference old-exports exports)))
 	(when diff
-	  (warn "~A also exports the following symbols:~%  ~S" name diff))))
+	  (warn 'package-at-variance
+		:format-control "~A also exports the following symbols:~%  ~S" 
+		:format-arguments (list name diff)))))
+    #!+sb-package-locks
+    (progn
+      ;; Handle packages this is an implementation package of
+      (dolist (p implement)
+	(add-implementation-package package p))
+      ;; Handle lock
+      (setf (package-lock package) lock))
     ;; Handle documentation.
     (setf (package-doc-string package) doc-string)
     package))