X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefpackage.lisp;h=ff3037c0e9289d6d1408c85a6c62bbaab7c08b4a;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=1d6a191ed04cf7f9186539c6f60cd149c40b6ab4;hpb=31f072311935e32751508ecf824905c6b58a1d95;p=sbcl.git diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index 1d6a191..ff3037c 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,7 +140,7 @@ `(: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 (sb!c:source-location))))) @@ -158,19 +158,136 @@ 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-names (names kind) - (mapcar (lambda (name) - (stringify-name name kind)) - names)) +(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 import-list-symbols (import-list) + (let ((symbols nil)) + (dolist (import import-list symbols) + (destructuring-bind (package-name &rest symbol-names) + import + (let ((package (find-undeleted-package-or-lose package-name))) + (mapcar (lambda (name) + (push (find-or-make-symbol name package) symbols)) + symbol-names)))))) + +(defun use-list-packages (package package-designators) + (cond ((listp package-designators) + (mapcar #'find-undeleted-package-or-lose package-designators)) + (package + ;; :default for an existing package means preserve the + ;; existing use list + (package-use-list package)) + (t + ;; :default for a new package is the *default-package-use-list* + '#.*default-package-use-list*))) + +(defun update-package (package nicknames source-location + shadows shadowing-imports + use + imports interns + exports + implement lock doc-string) + (declare #!-sb-package-locks + (ignore implement lock)) + (enter-new-nicknames package nicknames) + ;; 1. :shadow and :shadowing-import-from + ;; + ;; shadows is a list of strings, shadowing-imports is a list of symbols. + (shadow shadows package) + (shadowing-import shadowing-imports package) + ;; 2. :use + ;; + ;; use is a list of package objects. + (use-package use package) + ;; 3. :import-from and :intern + ;; + ;; imports is a list of symbols. interns is a list of strings. + (import imports package) + (dolist (intern interns) + (intern intern package)) + ;; 4. :export + ;; + ;; exports is a list of strings + (export (mapcar (lambda (symbol-name) (intern symbol-name package)) + exports) + package) + ;; Everything was created: update metadata + (sb!c:with-source-location (source-location) + (setf (package-source-location package) source-location)) + (setf (package-doc-string package) doc-string) + #!+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)) + package) + +(defun update-package-with-variance (package name nicknames source-location + shadows shadowing-imports + use + imports interns + exports + implement lock doc-string) + (let ((old-exports nil) + (old-shadows (package-%shadowing-symbols package)) + (old-use (package-use-list package)) + (no-longer-used nil)) + (unless (string= (the string (package-name package)) name) + (error 'simple-package-error + :package name + :format-control "~A is a nickname for the package ~A" + :format-arguments (list name (package-name name)))) + (do-external-symbols (symbol package) + (push symbol old-exports)) + (setf old-shadows (set-difference old-shadows (append shadows + shadowing-imports) + :test #'string=)) + (setf no-longer-used (set-difference old-use use)) + (setf use (set-difference use old-use)) + (setf old-exports (set-difference old-exports exports :test #'string=)) + (when old-shadows + (warn 'package-at-variance + :format-control "~A also shadows the following symbols:~% ~S" + :format-arguments (list name old-shadows))) + (when no-longer-used + (dolist (unused-package no-longer-used) + (unuse-package unused-package package)) + (warn 'package-at-variance + :format-control "~A used to use the following packages:~% ~S" + :format-arguments (list name no-longer-used))) + (when old-exports + (warn 'package-at-variance + :format-control "~A also exports the following symbols:~% ~S" + :format-arguments (list name old-exports))) + (update-package package nicknames source-location + shadows shadowing-imports + use imports interns exports + implement lock doc-string))) (defun %defpackage (name nicknames size shadows shadowing-imports use imports interns exports implement lock doc-string @@ -182,80 +299,25 @@ (type (or simple-string null) doc-string) #!-sb-package-locks (ignore implement lock)) - (let ((package (or (find-package name) - (progn - (when (eq use :default) - (setf use '#.*default-package-use-list*)) - (make-package name + (let* ((existing-package (find-package name)) + (use (use-list-packages existing-package use)) + (shadowing-imports (import-list-symbols shadowing-imports)) + (imports (import-list-symbols imports))) + (if existing-package + (update-package-with-variance existing-package name + nicknames source-location + shadows shadowing-imports + use imports interns exports + implement lock doc-string) + (let ((package (make-package name :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 - :format-control "~A is a nickname for the package ~A" - :format-arguments (list name (package-name name)))) - (enter-new-nicknames package nicknames) - ;; Handle shadows and shadowing-imports. - (let ((old-shadows (package-%shadowing-symbols package))) - (shadow shadows package) - (dolist (sym-name shadows) - (setf old-shadows (remove (find-symbol sym-name package) old-shadows))) - (dolist (simports-from shadowing-imports) - (let ((other-package (find-undeleted-package-or-lose - (car simports-from)))) - (dolist (sym-name (cdr simports-from)) - (let ((sym (find-or-make-symbol sym-name other-package))) - (shadowing-import sym package) - (setf old-shadows (remove sym old-shadows)))))) - (when 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)) - (new-use-list (mapcar #'find-undeleted-package-or-lose use))) - (use-package (set-difference new-use-list old-use-list) package) - (let ((laterize (set-difference old-use-list new-use-list))) - (when laterize - (unuse-package laterize package) - (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)) - (dolist (imports-from imports) - (let ((other-package (find-undeleted-package-or-lose (car - imports-from)))) - (dolist (sym-name (cdr imports-from)) - (import (list (find-or-make-symbol sym-name other-package)) - package)))) - ;; Handle exports. - (let ((old-exports nil) - (exports (mapcar (lambda (sym-name) (intern sym-name package)) - exports))) - (do-external-symbols (sym package) - (push sym old-exports)) - (export exports package) - (let ((diff (set-difference old-exports exports))) - (when 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)) + :external-symbols (length exports)))) + (update-package package + nicknames source-location + shadows shadowing-imports + use imports interns exports + implement lock doc-string))))) (defun find-or-make-symbol (name package) (multiple-value-bind (symbol how) (find-symbol name package)