X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefpackage.lisp;h=e1988d8176dfbfecd952056cb1eddcd5564d5bcf;hb=1913e44aa31172eb3c345115a2acb367356f6b4b;hp=01d38ce00a105d70aeacb0e9afadf141cbc14a73;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp
index 01d38ce..e1988d8 100644
--- a/src/code/defpackage.lisp
+++ b/src/code/defpackage.lisp
@@ -55,7 +55,7 @@
         (imports nil)
         (interns nil)
         (exports nil)
-        (implement (stringify-names (list package) "package"))
+        (implement (stringify-package-designators (list package)))
         (implement-p nil)
         (lock nil)
         (doc nil))
@@ -68,7 +68,7 @@
                :format-arguments (list option)))
       (case (car option)
         (:nicknames
-         (setf nicknames (stringify-names (cdr option) "package")))
+         (setf nicknames (stringify-package-designators (cdr option))))
         (:size
          (cond (size
                 (error 'simple-program-error
@@ -82,11 +82,11 @@
                  :format-control ":SIZE is not a positive integer: ~S"
                  :format-arguments (list (second option))))))
         (:shadow
-         (let ((new (stringify-names (cdr option) "symbol")))
+         (let ((new (stringify-string-designators (cdr option))))
            (setf shadows (append shadows new))))
         (:shadowing-import-from
-         (let ((package-name (stringify-name (second option) "package"))
-               (names (stringify-names (cddr option) "symbol")))
+         (let ((package-name (stringify-package-designator (second option)))
+               (names (stringify-string-designators (cddr option))))
            (let ((assoc (assoc package-name shadowing-imports
                                :test #'string=)))
              (if assoc
@@ -94,27 +94,27 @@
                  (setf shadowing-imports
                        (acons package-name names shadowing-imports))))))
         (:use
-         (setf use (append use (stringify-names (cdr option) "package") )
+         (setf use (append use (stringify-package-designators (cdr option)) )
                use-p t))
         (:import-from
-         (let ((package-name (stringify-name (second option) "package"))
-               (names (stringify-names (cddr option) "symbol")))
+         (let ((package-name (stringify-package-designator (second option)))
+               (names (stringify-string-designators (cddr option))))
            (let ((assoc (assoc package-name imports
                                :test #'string=)))
              (if assoc
                  (setf (cdr assoc) (append (cdr assoc) names))
                  (setf imports (acons package-name names imports))))))
         (:intern
-         (let ((new (stringify-names (cdr option) "symbol")))
+         (let ((new (stringify-string-designators (cdr option))))
            (setf interns (append interns new))))
         (:export
-         (let ((new (stringify-names (cdr option) "symbol")))
+         (let ((new (stringify-string-designators (cdr option))))
            (setf exports (append exports new))))
         #!+sb-package-locks
         (:implement
          (unless implement-p
            (setf implement nil))
-         (let ((new (stringify-names (cdr option) "package")))
+         (let ((new (stringify-package-designators (cdr option))))
            (setf implement (append implement new)
                  implement-p t)))
         #!+sb-package-locks
@@ -140,9 +140,10 @@
                     `(:shadowing-import-from
                       ,@(apply #'append (mapcar #'rest shadowing-imports))))
     `(eval-when (:compile-toplevel :load-toplevel :execute)
-       (%defpackage ,(stringify-name package "package") ',nicknames ',size
+       (%defpackage ,(stringify-string-designator package) ',nicknames ',size
                     ',shadows ',shadowing-imports ',(if use-p use :default)
-                    ',imports ',interns ',exports ',implement ',lock ',doc))))
+                    ',imports ',interns ',exports ',implement ',lock ',doc
+                    (sb!c:source-location)))))
 
 (defun check-disjoint (&rest args)
   ;; An arg is (:key . set)
@@ -157,22 +158,35 @@
                                         but have common elements ~%   ~S"
                        :format-arguments (list (car x)(car y) z)))))
 
-(defun stringify-name (name kind)
-  (typecase name
-    (simple-string name)
-    (string (coerce name 'simple-string))
-    (symbol (symbol-name name))
-    (character (string name))
+(defun stringify-string-designator (string-designator)
+  (typecase string-designator
+    (simple-string string-designator)
+    (string (coerce string-designator 'simple-string))
+    (symbol (symbol-name string-designator))
+    (character (string string-designator))
     (t
-     (error "bogus ~A name: ~S" kind name))))
+     (error "~S does not designate a string" string-designator))))
+
+(defun stringify-string-designators (string-designators)
+  (mapcar #'stringify-string-designator string-designators))
+
+(defun stringify-package-designator (package-designator)
+  (typecase package-designator
+    (simple-string package-designator)
+    (string (coerce package-designator 'simple-string))
+    (symbol (symbol-name package-designator))
+    (character (string package-designator))
+    (package (package-name package-designator))
+    (t
+     (error "~S does not designate a package" package-designator))))
+
+(defun stringify-package-designators (package-designators)
+  (mapcar #'stringify-package-designator package-designators))
 
-(defun stringify-names (names kind)
-  (mapcar (lambda (name)
-            (stringify-name name kind))
-          names))
 
 (defun %defpackage (name nicknames size shadows shadowing-imports
-                    use imports interns exports implement lock doc-string)
+                    use imports interns exports implement lock doc-string
+                    source-location)
   (declare (type simple-string name)
            (type list nicknames shadows shadowing-imports
                  imports interns exports)
@@ -188,6 +202,8 @@
                                      :use nil
                                      :internal-symbols (or size 10)
                                      :external-symbols (length exports))))))
+    (sb!c:with-source-location (source-location)
+      (setf (package-source-location package) source-location))
     (unless (string= (the string (package-name package)) name)
       (error 'simple-package-error
              :package name