;; This file is part of the implementation of Lisp packages for Emacs.
;; Code is partly adapted from CMUCL, which is in the public domain.
-;; The goal of this is, among others, to do as much as possible in
-;; Lisp, not C.
+;; The implementation strives to do as much as possible in Lisp, not
+;; C. C functions with names like 'package-%...' are defined which
+;; allow low-level access to the guts of Lisp_Package objects.
+;; Several variables are exposed from C that allow manipulating
+;; internal state.
+
+;; All that is dangerous :-).
;;; Code:
(require 'cl-lib)
+(require 'cl-macs)
+(require 'gv)
+
+;;; Define setters for internal package details.
+(gv-define-simple-setter package-%name package-%set-name)
+(gv-define-simple-setter package-%nicknames package-%set-nicknames)
+(gv-define-simple-setter package-%use-list package-%set-use-list)
(defvar *default-package-use-list* nil
- "tbd")
+ "List of packages to use when defpackage is used without :use.")
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Helpers
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pkg-check-disjoint (&rest args)
"Check whether all given arguments specify disjoint sets of symbols.
(defun pkg-package-namify (n)
(pkg-stringify-name n "package"))
-(defun pkg-name-to-package (name)
+(defun pkg-find-package (name)
(gethash name *package-registry* nil))
-(defun pkg-enter-new-nicknames (package nicknames)
- (cl-check-type nicknames list)
- (dolist (n nicknames)
- (let* ((n (pkg-package-namify n))
- (found (pkg-name-to-package n)))
- (cond ((not found)
- (setf (gethash n *package-registry*) package)
- (push n (package-%nicknames package)))
- ((eq found package))
- ((string= (package-name found) n)
- (error "%s is a package name, so it cannot be a nickname for %s."
- n (package-name package)))
- (t
- (error "%s is already a nickname for %s"
- n (package-name found)))))))
-
-;;; package-or-lose -- Internal
-;;;
-;;; Take a package-or-string-or-symbol and return a package.
-;;;
-(defun package-or-lose (thing)
- (cond ((packagep thing)
- (unless (package-%name thing)
- (error "Can't do anything to a deleted package: %s" thing))
- thing)
- (t
- (let ((thing (pkg-package-namify thing)))
- (cond ((pkg-name-to-package thing))
- (t (make-package thing)))))))
-
-(defun find-or-make-symbol (name package)
- (cl-multiple-value-bind (symbol how)
- (find-symbol name package)
- (if how
- symbol
- (intern name package))))
+(defun pkg-find-or-make-package (name)
+ (if (packagep name)
+ (progn
+ (unless (package-%name thing)
+ (error "Can't do anything with deleted package: %s" name))
+ name)
+ (let* ((name (pkg-stringify-name name "package name")))
+ (or (pkg-find-package name)
+ (make-package name)))))
+
+(defun pkg-packages-from-names (names)
+ (mapcar (lambda (name) (pkg-find-or-make-package name))
+ names))
\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; defpackage
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun %defpackage (name nicknames size shadows shadowing-imports
- use imports interns exports doc-string)
- (let ((package (or (find-package name)
- (progn
- (when (eq use :default)
- (setf use *default-package-use-list*))
- (make-package name
- :use nil
- :size (or size 10))))))
- (unless (string= (package-name package) name)
- (error "%s is a nick-name for the package %s" name (package-name name)))
- (pkg-enter-new-nicknames package nicknames)
-
- ;; 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 (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 "%s also shadows the following symbols: %s"
- name old-shadows)))
-
- ;; Use
- (unless (eq use :default)
- (let ((old-use-list (package-use-list package))
- (new-use-list (mapcar #'package-or-lose use)))
- (use-package (cl-set-difference new-use-list old-use-list) package)
- (let ((laterize (cl-set-difference old-use-list new-use-list)))
- (when laterize
- (unuse-package laterize package)
- (warn "%s previously used the following packages: %s"
- name laterize)))))
-
- ;; Import and Intern.
- (dolist (sym-name interns)
- (intern sym-name package))
- (dolist (imports-from imports)
- (let ((other-package (package-or-lose (car imports-from))))
- (dolist (sym-name (cdr imports-from))
- (import (list (find-or-make-symbol sym-name other-package))
- package))))
-
- ;; 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 (cl-set-difference old-exports exports)))
- (when diff
- (warn "%s also exports the following symbols: %s" name diff))))
-
- ;; Documentation
- (setf (package-doc-string package) doc-string)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Creating packages
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;###autoload
+(cl-defun make-package (name &key nicknames use (size 10))
+ "tbd"
+ (cl-check-type size natnum)
+ (let* ((name (pkg-stringify-name name "package name"))
+ (nicknames (pkg-stringify-names nicknames "package nickname"))
+ (use (pkg-packages-from-names use))
+ (package (make-%package name size)))
+ (setf (package-%nicknames package) nicknames
+ (package-%use-list package) use)
package))
-(defmacro defpackage (package &rest options)
- "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."
- (let ((nicknames nil)
- (size nil)
- (shadows nil)
- (shadowing-imports nil)
- (use nil)
- (use-p nil)
- (imports nil)
- (interns nil)
- (exports nil)
- (doc nil))
- (dolist (option options)
- (unless (consp option)
- (error "Bogus DEFPACKAGE option: %s" option))
- (cl-case (car option)
- (:nicknames
- (setf nicknames (pkg-stringify-names (cdr option) "package")))
- (:size
- (cond (size
- (error "Can't specify :SIZE twice."))
- ((and (consp (cdr option))
- (cl-typep (cl-second option) 'natnum))
- (setf size (cl-second option)))
- (t
- (error "Bogus :SIZE, must be a positive integer: %s"
- (cl-second option)))))
- (:shadow
- (let ((new (pkg-stringify-names (cdr option) "symbol")))
- (setf shadows (append shadows new))))
- (:shadowing-import-from
- (let ((package-name (pkg-stringify-name (cl-second option) "package"))
- (names (pkg-stringify-names (cddr option) "symbol")))
- (let ((assoc (cl-assoc package-name shadowing-imports
- :test #'string=)))
- (if assoc
- (setf (cdr assoc) (append (cdr assoc) names))
- (setf shadowing-imports
- (cl-acons package-name names shadowing-imports))))))
- (:use
- (let ((new (pkg-stringify-names (cdr option) "package")))
- (setf use (cl-delete-duplicates (nconc use new) :test #'string=))
- (setf use-p t)))
- (:import-from
- (let ((package-name (pkg-stringify-name (cl-second option) "package"))
- (names (pkg-stringify-names (cddr option) "symbol")))
- (let ((assoc (cl-assoc package-name imports
- :test #'string=)))
- (if assoc
- (setf (cdr assoc) (append (cdr assoc) names))
- (setf imports (cl-acons package-name names imports))))))
- (:intern
- (let ((new (pkg-stringify-names (cdr option) "symbol")))
- (setf interns (append interns new))))
- (:export
- (let ((new (pkg-stringify-names (cdr option) "symbol")))
- (setf exports (append exports new))))
- (:documentation
- (when doc
- (error "Can't specify :DOCUMENTATION twice."))
- (setf doc (cl-coerce (cl-second option) 'string)))
- (t
- (error "Bogus DEFPACKAGE option: %s" option))))
- (pkg-check-disjoint `(:intern ,@interns) `(:export ,@exports))
- (pkg-check-disjoint `(:intern ,@interns)
- `(:import-from ,@(apply 'append (mapcar 'cl-rest imports)))
- `(:shadow ,@shadows)
- `(:shadowing-import-from
- ,@(apply 'append (mapcar 'cl-rest shadowing-imports))))
- `(cl-eval-when (compile load eval)
- (%defpackage ,(pkg-stringify-name package "package") ',nicknames ',size
- ',shadows ',shadowing-imports ',(if use-p use :default)
- ',imports ',interns ',exports ',doc))))
+
+
+;; (defun pkg-enter-new-nicknames (package nicknames)
+;; (cl-check-type nicknames list)
+;; (dolist (n nicknames)
+;; (let* ((n (pkg-package-namify n))
+;; (found (pkg-name-to-package n)))
+;; (cond ((not found)
+;; (setf (gethash n *package-registry*) package)
+;; (push n (package-%nicknames package)))
+;; ((eq found package))
+;; ((string= (package-name found) n)
+;; (error "%s is a package name, so it cannot be a nickname for %s."
+;; n (package-name package)))
+;; (t
+;; (error "%s is already a nickname for %s"
+;; n (package-name found)))))))
+
+;; (defun pkg-defpackage (name nicknames size shadows shadowing-imports
+;; use imports interns exports doc-string)
+;; (let ((package (or (find-package name)
+;; (progn
+;; (when (eq use :default)
+;; (setf use *default-package-use-list*))
+;; (make-package name
+;; :use nil
+;; :size (or size 10))))))
+;; (unless (string= (package-name package) name)
+;; (error "%s is a nick-name for the package %s" name (package-name name)))
+;; (pkg-enter-new-nicknames package nicknames)
+
+;; ;; 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 (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 "%s also shadows the following symbols: %s"
+;; name old-shadows)))
+
+;; ;; Use
+;; (unless (eq use :default)
+;; (let ((old-use-list (package-use-list package))
+;; (new-use-list (mapcar #'package-or-lose use)))
+;; (use-package (cl-set-difference new-use-list old-use-list) package)
+;; (let ((laterize (cl-set-difference old-use-list new-use-list)))
+;; (when laterize
+;; (unuse-package laterize package)
+;; (warn "%s previously used the following packages: %s"
+;; name laterize)))))
+
+;; ;; Import and Intern.
+;; (dolist (sym-name interns)
+;; (intern sym-name package))
+;; (dolist (imports-from imports)
+;; (let ((other-package (package-or-lose (car imports-from))))
+;; (dolist (sym-name (cdr imports-from))
+;; (import (list (find-or-make-symbol sym-name other-package))
+;; package))))
+
+;; ;; 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 (cl-set-difference old-exports exports)))
+;; (when diff
+;; (warn "%s also exports the following symbols: %s" name diff))))
+
+;; ;; Documentation
+;; (setf (package-doc-string package) doc-string)
+;; package))
+
+
+
+;; (defmacro defpackage (package &rest options)
+;; "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."
+;; (let ((nicknames nil)
+;; (size nil)
+;; (shadows nil)
+;; (shadowing-imports nil)
+;; (use nil)
+;; (use-p nil)
+;; (imports nil)
+;; (interns nil)
+;; (exports nil)
+;; (doc nil))
+;; (dolist (option options)
+;; (unless (consp option)
+;; (error "Bogus DEFPACKAGE option: %s" option))
+;; (cl-case (car option)
+;; (:nicknames
+;; (setf nicknames (pkg-stringify-names (cdr option) "package")))
+;; (:size
+;; (cond (size
+;; (error "Can't specify :SIZE twice."))
+;; ((and (consp (cdr option))
+;; (cl-typep (cl-second option) 'natnum))
+;; (setf size (cl-second option)))
+;; (t
+;; (error "Bogus :SIZE, must be a positive integer: %s"
+;; (cl-second option)))))
+;; (:shadow
+;; (let ((new (pkg-stringify-names (cdr option) "symbol")))
+;; (setf shadows (append shadows new))))
+;; (:shadowing-import-from
+;; (let ((package-name (pkg-stringify-name (cl-second option) "package"))
+;; (names (pkg-stringify-names (cddr option) "symbol")))
+;; (let ((assoc (cl-assoc package-name shadowing-imports
+;; :test #'string=)))
+;; (if assoc
+;; (setf (cdr assoc) (append (cdr assoc) names))
+;; (setf shadowing-imports
+;; (cl-acons package-name names shadowing-imports))))))
+;; (:use
+;; (let ((new (pkg-stringify-names (cdr option) "package")))
+;; (setf use (cl-delete-duplicates (nconc use new) :test #'string=))
+;; (setf use-p t)))
+;; (:import-from
+;; (let ((package-name (pkg-stringify-name (cl-second option) "package"))
+;; (names (pkg-stringify-names (cddr option) "symbol")))
+;; (let ((assoc (cl-assoc package-name imports
+;; :test #'string=)))
+;; (if assoc
+;; (setf (cdr assoc) (append (cdr assoc) names))
+;; (setf imports (cl-acons package-name names imports))))))
+;; (:intern
+;; (let ((new (pkg-stringify-names (cdr option) "symbol")))
+;; (setf interns (append interns new))))
+;; (:export
+;; (let ((new (pkg-stringify-names (cdr option) "symbol")))
+;; (setf exports (append exports new))))
+;; (:documentation
+;; (when doc
+;; (error "Can't specify :DOCUMENTATION twice."))
+;; (setf doc (cl-coerce (cl-second option) 'string)))
+;; (t
+;; (error "Bogus DEFPACKAGE option: %s" option))))
+;; (pkg-check-disjoint `(:intern ,@interns) `(:export ,@exports))
+;; (pkg-check-disjoint `(:intern ,@interns)
+;; `(:import-from ,@(apply 'append (mapcar 'cl-rest imports)))
+;; `(:shadow ,@shadows)
+;; `(:shadowing-import-from
+;; ,@(apply 'append (mapcar 'cl-rest shadowing-imports))))
+;; `(cl-eval-when (compile load eval)
+;; (pkg-defpackage ,(pkg-stringify-name package "package") ',nicknames ',size
+;; ',shadows ',shadowing-imports ',(if use-p use :default)
+;; ',imports ',interns ',exports ',doc))))
;;; pkg.el ends here
}
/* Create and return a new Lisp package object for a package with name
- NAME, a string. NSYMBOLS is the expected number of symbols. */
+ NAME, a string. NSYMBOLS is the sieo of the symbol-table to allocate. */
static Lisp_Object
make_package (Lisp_Object name, Lisp_Object nsymbols)
{
- eassert (STRINGP (name));
- if (NILP (nsymbols))
- nsymbols = make_fixnum (50);
- CHECK_FIXNAT (nsymbols);
-
struct Lisp_Package *pkg
= ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Package, symbols,
PVEC_PACKAGE);
pkg->name = name;
pkg->symbols = CALLN (Fmake_hash_table, QCtest, Qequal,
QCsize, nsymbols);
-
Lisp_Object package;
XSETPACKAGE (package, pkg);
return package;
pkg_add_symbol (keyword, Vkeyword_package);
}
else
- eassert SYMBOL_KEYWORD_P (keyword);
+ eassert (SYMBOL_KEYWORD_P (keyword));
return keyword;
}
Lisp functions
***********************************************************************/
+DEFUN ("make-%package", Fmake_percent_package, Smake_percent_package,
+ 2, 2, 0, doc: /**/)
+ (Lisp_Object name, Lisp_Object size)
+{
+ CHECK_STRING (name);
+ CHECK_FIXNAT (size);
+ return make_package (name, size);
+}
+
DEFUN ("packagep", Fpackagep, Spackagep, 1, 1, 0, doc:
/* Value is non-nil if PACKAGE is a package object. */)
(Lisp_Object package)
return result;
}
-DEFUN ("make-package", Fmake_package, Smake_package, 0, MANY, 0,
- doc: /* Value is a new package with name NAME.
-
-NAME must be a string designator.
-
-Additional arguments are specified as keyword/argument pairs. The
-following keyword arguments are defined:
-
-:nicknames NICKNAMES is a list of additional names which may be used
-to refer to the new package.
-
-:use USE specifies a list of zero or more packages the external
-symbols of which are to be inherited by the new package. See the
-function 'use-package'.
-
-usage: (make-package NAME &rest KEYWORD-ARGS) */)
- (ptrdiff_t nargs, Lisp_Object *args)
-{
- if (nargs <= 0)
- signal_error ("make-package: no package name", Qnil);
-
- /* Determine the package's name as a string. A package with the
- same name or nickname must not be known yet. */
- const Lisp_Object name = string_from_designator (args[0]);
- ++args;
- --nargs;
-
- /* The vector `used' is used to keep track of arguments that have
- been consumed below. */
- USE_SAFE_ALLOCA;
- char *used_args = SAFE_ALLOCA (nargs * sizeof *used_args);
- memset (used_args, 0, nargs * sizeof *used_args);
-
- /* Check for :USE. Argument must be a list of package designators
- for known packages. */
- const ptrdiff_t use_index = get_key_arg (QCuse, nargs, args, used_args);
- const Lisp_Object use_designators = use_index ? args[use_index] : Qnil;
- const Lisp_Object used_packages = package_list_from_designators (use_designators);
-
- /* Check for :NICKNAMES. Argument must be a list of string
- designators. Note that we don't check if the package name
- appears also as a nickname, because SBCL also doesn't. */
- const ptrdiff_t nicknames_index = get_key_arg (QCnicknames, nargs, args, used_args);
- const Lisp_Object nickname_designators = nicknames_index ? args[nicknames_index] : Qnil;
- const Lisp_Object nicknames = string_list_from_designators (nickname_designators);
-
- /* Check for :SIZE. Argument is checked in make_package. */
- const ptrdiff_t size_index = get_key_arg (QCsize, nargs, args, used_args);
- const Lisp_Object size = size_index ? args[size_index] : Qnil;
-
- /* Now, all args should have been used up, or there's a problem. */
- for (ptrdiff_t i = 0; i < nargs; ++i)
- if (!used_args[i])
- signal_error ("make-package: invalid argument", args[i]);
-
- const Lisp_Object package = make_package (name, size);
- XPACKAGE (package)->nicknames = nicknames;
- XPACKAGE (package)->use_list = used_packages;
-
- SAFE_FREE ();
- return package;
-}
-
DEFUN ("%register-package", Fregister_package, Sregister_package, 1, 1, 0, doc:
/* Register PACKAGE in the package registry. */)
(Lisp_Object package)
defsubr (&Spackage_percent_symbols);
defsubr (&Spackage_percent_use_list);
+ defsubr (&Smake_percent_package);
defsubr (&Scl_intern);
defsubr (&Scl_unintern);
defsubr (&Sdelete_package);
defsubr (&Sfind_symbol);
defsubr (&Simport);
defsubr (&Slist_all_packages);
- defsubr (&Smake_package);
defsubr (&Spackage_name);
defsubr (&Spackage_nicknames);
defsubr (&Spackage_shadowing_symbols);
projects / emacs.git / commitdiff