From: Gerd Möllmann Date: Tue, 18 Oct 2022 14:49:47 +0000 (+0200) Subject: Move make-package to Lisp X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=fc936470cdd13bacd1d1cd04261300739a0ce29c;p=emacs.git Move make-package to Lisp * lisp/emacs-lisp/pkg.el: Implement make-package. * lisp/obarray.el (obarray-make): Use make-%package. * src/pkg.c: Various changes to move make-package to Lisp. --- diff --git a/lisp/emacs-lisp/pkg.el b/lisp/emacs-lisp/pkg.el index 073d9f6db54..cc3556fc9d1 100644 --- a/lisp/emacs-lisp/pkg.el +++ b/lisp/emacs-lisp/pkg.el @@ -26,15 +26,32 @@ ;; 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.") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helpers +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun pkg-check-disjoint (&rest args) "Check whether all given arguments specify disjoint sets of symbols. @@ -63,198 +80,207 @@ but have common elements %s" key1 key2 common)))) (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)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; 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 ) - (: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." - (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 ) +;; (: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." +;; (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 diff --git a/lisp/obarray.el b/lisp/obarray.el index 91cf6805b3f..e335c66d51f 100644 --- a/lisp/obarray.el +++ b/lisp/obarray.el @@ -30,9 +30,9 @@ (defconst obarray-default-size 59 "The value 59 is an arbitrary prime number that gives a good hash.") -(defun obarray-make (&optional _size) +(defun obarray-make (&optional size) "Return a new obarray of size SIZE or `obarray-default-size'." - (make-package "obarray")) + (make-%package "obarray" (or size 31))) (defun obarray-size (_ob) "Return the number of slots of obarray OB." diff --git a/src/pkg.c b/src/pkg.c index 3745dd69fb8..600dd3ce5e7 100644 --- a/src/pkg.c +++ b/src/pkg.c @@ -149,23 +149,17 @@ symbols_to_list (Lisp_Object thing) } /* 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; @@ -530,7 +524,7 @@ pkg_intern_keyword (Lisp_Object name) pkg_add_symbol (keyword, Vkeyword_package); } else - eassert SYMBOL_KEYWORD_P (keyword); + eassert (SYMBOL_KEYWORD_P (keyword)); return keyword; } @@ -824,6 +818,15 @@ pkg_keywordp (Lisp_Object obj) 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) @@ -878,69 +881,6 @@ DEFUN ("package-used-by-list", Fpackage_used_by_list, Spackage_used_by_list, 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) @@ -1358,6 +1298,7 @@ syms_of_pkg (void) defsubr (&Spackage_percent_symbols); defsubr (&Spackage_percent_use_list); + defsubr (&Smake_percent_package); defsubr (&Scl_intern); defsubr (&Scl_unintern); defsubr (&Sdelete_package); @@ -1366,7 +1307,6 @@ syms_of_pkg (void) defsubr (&Sfind_symbol); defsubr (&Simport); defsubr (&Slist_all_packages); - defsubr (&Smake_package); defsubr (&Spackage_name); defsubr (&Spackage_nicknames); defsubr (&Spackage_shadowing_symbols);