(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 <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)
(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)
(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
(: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))
`(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)
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)
(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))
(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))
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))
projects / sbcl.git / blobdiff