pkg fc936470cd 56/76: Move make-package to Lisp

[Gerd Moellmann]

branch: pkg
commit fc936470cdd13bacd1d1cd04261300739a0ce29c
Author: Gerd Möllmann <gerd@gnu.org>
Commit: Gerd Möllmann <gerd@gnu.org>

    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.
---
 lisp/emacs-lisp/pkg.el | 402 ++++++++++++++++++++++++++-----------------------
 lisp/obarray.el        |   4 +-
 src/pkg.c              |  84 ++---------
 3 files changed, 228 insertions(+), 262 deletions(-)

diff --git a/lisp/emacs-lisp/pkg.el b/lisp/emacs-lisp/pkg.el
index 073d9f6db5..cc3556fc9d 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 <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
diff --git a/lisp/obarray.el b/lisp/obarray.el
index 91cf6805b3..e335c66d51 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 3745dd69fb..600dd3ce5e 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);