X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefpackage.lisp;h=dfd5b9976a991b891c12a896551c78cfb4ef806e;hb=771b864c8f32af7734bc0550aeaf1539fc4df194;hp=31a9e7da86ee9c3b6e980106d23f16dd6075a55e;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index 31a9e7d..dfd5b99 100644 --- a/src/code/defpackage.lisp +++ b/src/code/defpackage.lisp @@ -11,20 +11,41 @@ (in-package "SB!IMPL") +;;; the list of packages to use by default when no :USE argument is +;;; supplied to MAKE-PACKAGE or other package creation forms +;;; +;;; ANSI specifies (1) that MAKE-PACKAGE and DEFPACKAGE use the same +;;; value, and (2) that it (as an implementation-defined value) should +;;; be documented, which we do in the doc string. So for OAOO reasons +;;; we represent this value as a variable only at compile time, and +;;; then use #. readmacro hacks to splice it into the target code as a +;;; constant. +(eval-when (:compile-toplevel) + (defparameter *default-package-use-list* + ;; ANSI says this is implementation-defined. So we make it NIL, + ;; the way God intended. Anyone who actually wants a random value + ;; is free to :USE (PACKAGE-USE-LIST :CL-USER) anyway.:-| + 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 ) - (:SHADOW {symbol-name}*) - (:SHADOWING-IMPORT-FROM {symbol-name}*) - (:USE {package-name}*) - (:IMPORT-FROM {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 "") + (:shadow "{symbol-name}*") + (:shadowing-import-from " {symbol-name}*") + (:use "{package-name}*") + (:import-from " {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) @@ -34,10 +55,15 @@ (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 'program-error + (error 'simple-program-error :format-control "bogus DEFPACKAGE option: ~S" :format-arguments (list option))) (case (car option) @@ -45,14 +71,14 @@ (setf nicknames (stringify-names (cdr option) "package"))) (:size (cond (size - (error 'program-error + (error 'simple-program-error :format-control "can't specify :SIZE twice.")) ((and (consp (cdr option)) (typep (second option) 'unsigned-byte)) (setf size (second option))) (t (error - 'program-error + 'simple-program-error :format-control ":SIZE is not a positive integer: ~S" :format-arguments (list (second option)))))) (:shadow @@ -84,13 +110,26 @@ (: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 'program-error + (error 'simple-program-error :format-control "multiple :DOCUMENTATION options")) (setf doc (coerce (second option) 'simple-string))) (t - (error 'program-error + (error 'simple-program-error :format-control "bogus DEFPACKAGE option: ~S" :format-arguments (list option))))) (check-disjoint `(:intern ,@interns) `(:export ,@exports)) @@ -103,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) @@ -113,36 +152,38 @@ 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 + 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) (typecase name - (simple-string name) - (string (coerce name 'simple-string)) + (simple-base-string name) + (string (coerce name 'simple-base-string)) (symbol (symbol-name name)) (base-char (string name)) (t (error "bogus ~A name: ~S" kind name)))) (defun stringify-names (names kind) - (mapcar #'(lambda (name) - (stringify-name name kind)) + (mapcar (lambda (name) + (stringify-name name kind)) names)) (defun %defpackage (name nicknames size shadows shadowing-imports - use imports interns exports doc-string) + use imports interns exports implement lock doc-string) (declare (type simple-base-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-base-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*)) + (setf use '#.*default-package-use-list*)) (make-package name :use nil :internal-symbols (or size 10) @@ -166,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)) @@ -176,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)) @@ -190,14 +232,23 @@ package)))) ;; Handle exports. (let ((old-exports nil) - (exports (mapcar #'(lambda (sym-name) (intern sym-name package)) + (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 "~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))