Ongoing work on the Lisp side and tests

diff --git a/lisp/emacs-lisp/pkg.el b/lisp/emacs-lisp/pkg.el
index 8a2afb2966a68125796deb5b45d52f8f95cadf69..4258673d9f0a80c93db3a9726fd87912ee9f77be 100644 (file)
--- a/lisp/emacs-lisp/pkg.el
+++ b/lisp/emacs-lisp/pkg.el
@@ -64,20 +64,27 @@ Each argument is of the form (:key . set)."
                    (error "Parameters %s and %s must be disjoint \
 but have common elements %s" key1 key2 common))))
 
-(defun pkg-stringify-name (name kind)
+(defun pkg--stringify-name (name kind)
+  "Return a string for string designator NAME.
+If NAME is a string, return that.
+If NAME is a symbol, return its symbol name.
+If NAME is a character, return what 'char-to-string' returns.
+KIND is the kind of name we are processing, for error messages."
   (cl-typecase name
     (string name)
     (symbol (cl-symbol-name name))
     (base-char (char-to-string name))
-    (t (error "Bogus %s name: %s" kind name))))
+    (t (error "Bogus %s: %s" kind name))))
 
-(defun pkg-stringify-names (names kind)
+(defun pkg--stringify-names (names kind)
+  "Transform a list of string designators to a list of strings.
+Duplicates are removed from the result list."
   (cl-remove-duplicates
-   (mapcar (lambda (name) (pkg-stringify-name name kind)) names)
+   (mapcar #'(lambda (name) (pkg--stringify-name name kind)) names)
    :test #'equal))
 
 (defun pkg-package-namify (n)
-  (pkg-stringify-name n "package"))
+  (pkg--stringify-name n "package"))
 
 (defun pkg-find-package (name)
   (gethash name *package-registry* nil))
@@ -93,24 +100,30 @@ but have common elements %s" key1 key2 common))))
        (t
         (error "%s is neither a symbol nor a list of symbols" thing))))
 
-(defun pkg-find-or-make-package (name)
-  (if (packagep name)
-      (progn
-       (unless (package-%name name)
-         (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))
+(cl-defun pkg--find-or-make-package (name)
+  "Find or make a package named NAME.
+If NAME is a package object, return that.  Otherwise, if NAME can
+be found with 'find-package' return that.  Otherwise, make a new
+package with name NAME."
+  (cond ((packagep name)
+         (unless (package-%name name)
+           (error "Can't do anything with deleted package: %s" name))
+         name)
+        (t
+         (let* ((name (pkg--stringify-name name "package name")))
+           (or (pkg-find-package name)
+              (make-package name))))))
+
+(defun pkg--packages-from-names (names)
+  "Return a list of packages object for NAMES.
+NAMES must be a list of package objects or valid package names."
+  (mapcar #'(lambda (name) (pkg--find-or-make-package name))
           names))
 
 (defun pkg-package-or-lose (name)
   (if (packagep name)
       name
-    (let ((pkg-name (pkg-stringify-name name "package")))
+    (let ((pkg-name (pkg--stringify-name name "package")))
       (or (find-package pkg-name)
           (error "No package %s found" name)))))
 
@@ -155,17 +168,48 @@ but have common elements %s" key1 key2 common))))
 
 ;;;###autoload
 
-(cl-defun make-package (name &key nicknames use (size 0))
-  "tbd"
+(cl-defun make-package (name &key nicknames use (size 10))
+  "Create and return a new package with name NAME.
+
+NAME must be a string designator, that is a string, a symbol, or
+a character.  If it is a symbol, the symbol's name will be used
+as package name.  If a character, the character's string
+representation will be used ('char-to-string').
+
+NICKNAMES specifies a list of string designators for additional
+names which may be used to refer to the package.  Default is nil.
+
+USE specifies zero or more packages the external symbols of which
+are to be inherited by the package.  See also function
+'use-package'.  All packages in the use-list must be either
+package objects or they are looked up in the package registry
+with 'find-package'.  If they are not found, a new package with
+the given name is created.
+
+SIZE gives the size to use for the symbol table of the new
+package.  Default is 10.
+
+Please note that the newly created package is not automaticall
+registered in the package registry, that is it will not be found
+under its names by 'find-package'.  Use 'register-package' to
+register the package.  This deviates from the CLHS specification,
+but is what Common Lisp implementations usually do."
   (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))
+  (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))
 
+;;;###autoload
+(defun list-all-packages ()
+  "Return a fresh list of all registered packages."
+  (let ((all ()))
+    (maphash (lambda (_ p) (push p all)) *package-registry*)
+    (cl-remove-duplicates all)))
+
 ;;;###autoload
 (defun package-name (package)
   (package-%name (pkg-package-or-lose package)))
@@ -191,19 +235,11 @@ but have common elements %s" key1 key2 common))))
         (cl-pushnew p used-by)))
     used-by))
 
-;;;###autoload
-(defun list-all-packages ()
-  (let ((all ()))
-    (maphash (lambda (_name package)
-               (cl-pushnew package all))
-             *package-registry*)
-    all))
-
 ;;;###autoload
 (defun find-package (package)
   (if (packagep package)
       package
-    (let ((name (pkg-stringify-name package "package name")))
+    (let ((name (pkg--stringify-name package "package name")))
       (gethash name *package-registry*))))
 
 ;;;###autoload
@@ -436,7 +472,7 @@ but have common elements %s" key1 key2 common))))
 ;;     (error "Bogus DEFPACKAGE option: %s" option))
 ;;       (cl-case (car option)
 ;;     (:nicknames
-;;      (setf nicknames (pkg-stringify-names (cdr option) "package")))
+;;      (setf nicknames (pkg--stringify-names (cdr option) "package")))
 ;;     (:size
 ;;      (cond (size
 ;;             (error "Can't specify :SIZE twice."))
@@ -447,11 +483,11 @@ but have common elements %s" key1 key2 common))))
 ;;             (error "Bogus :SIZE, must be a positive integer: %s"
 ;;                        (cl-second option)))))
 ;;     (:shadow
-;;      (let ((new (pkg-stringify-names (cdr option) "symbol")))
+;;      (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 ((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
@@ -459,22 +495,22 @@ but have common elements %s" key1 key2 common))))
 ;;            (setf shadowing-imports
 ;;                  (cl-acons package-name names shadowing-imports))))))
 ;;     (:use
-;;      (let ((new (pkg-stringify-names (cdr option) "package")))
+;;      (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 ((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")))
+;;      (let ((new (pkg--stringify-names (cdr option) "symbol")))
 ;;        (setf interns (append interns new))))
 ;;     (:export
-;;      (let ((new (pkg-stringify-names (cdr option) "symbol")))
+;;      (let ((new (pkg--stringify-names (cdr option) "symbol")))
 ;;        (setf exports (append exports new))))
 ;;     (:documentation
 ;;      (when doc
@@ -489,7 +525,7 @@ but have common elements %s" key1 key2 common))))
 ;;                     `(: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
+;;        (pkg-defpackage ,(pkg--stringify-name package "package") ',nicknames ',size
 ;;                    ',shadows ',shadowing-imports ',(if use-p use :default)
 ;;                    ',imports ',interns ',exports ',doc))))
 

diff --git a/test/src/pkg-tests.el b/test/src/pkg-tests.el
index 9023ee2af4b9f86c357168e8cbeda4da0103d18d..add6770d4073a55d55c45723bbd351d111573bf1 100644 (file)
--- a/test/src/pkg-tests.el
+++ b/test/src/pkg-tests.el
@@ -41,17 +41,10 @@
           (progn ,@(nreverse makes) ,@body)
         ,@(nreverse deletions)))))
 
-(ert-deftest pkg-tests-make-package-invalid ()
-  (should-error (make-package))
-  (should-error (make-package 1.0))
-  (should-error (make-package "x" :hansi 1))
-  (should-error (make-package "x" :nicknames))
-  (should-error (make-package "x" :use))
-  (should-error (make-package "x" :nicknames 1))
-  (should-error (make-package "x" :use 1)))
-
 (ert-deftest pkg-tests-packagep ()
-  (packagep (make-package "x")))
+  (should (packagep (make-package "x")))
+  (should (not (packagep "emacs")))
+  (should (not (packagep nil))))
 
 (ert-deftest pkg-tests-standard-packages ()
   (should (packagep (find-package "emacs")))
@@ -59,7 +52,33 @@
   (should (packagep (find-package "")))
   (should (eq (find-package "keyword") (find-package ""))))
 
+(ert-deftest pkg-tests-make-package ()
+  ;; Valid package names
+  (dolist (name '(?a "a" :a a))
+    (let ((p (make-package name)))
+      (should (packagep p))
+      (should (equal (package-name p) "a"))))
+  (should (packagep (make-package nil)))
+  ;; Invalid package names
+  (dolist (name '(1.0 (a)))
+    (should-error (make-package name)))
+  ;; Otherwise invalid forms.
+  (should-error (make-package))
+  (should-error (make-package 1.0))
+  (should-error (make-package :hansi 1))
+  (should-error (make-package "x" :hansi 1))
+  (should-error (make-package "x" :nicknames))
+  (should-error (make-package "x" :use))
+  (should-error (make-package "x" :nicknames 1))
+  (should-error (make-package "x" :use 1)))
+
 (ert-deftest pkg-tests-make-package-nicknames ()
+  ;; Valid nicknames
+  (dolist (nickname '("a" b ?c))
+    (should (packagep (make-package "x" :nicknames (list nickname)))))
+  ;; Invalid nicknames
+  (dolist (nickname '(1.0))
+    (should-error (packagep (make-package "x" :nicknames (list nickname)))))
   (with-packages ((x :nicknames '(x z)))
     ;; Package name allowed in nicknames.
     (should (equal (package-nicknames x) '("x" "z"))))
@@ -67,6 +86,13 @@
     ;; Duplicates removed, order-preserving.
     (should (equal (package-nicknames x) '("y" "z")))))
 
+(ert-deftest pkg-tests-list-all-packages ()
+  (let ((all (list-all-packages)))
+    (should (cl-every #'packagep all))
+    (should (memq (find-package "emacs") all))
+    (should (memq (find-package "keyword") all))
+    (should (memq (find-package "") all))))
+
 ;; (ert-deftest pkg-tests-package-use-list ()
 ;;   (should nil))
 
@@ -76,13 +102,6 @@
 ;; (ert-deftest pkg-tests-package-shadowing-symbols ()
 ;;   (should nil))
 
-(ert-deftest pkg-tests-list-all-packages ()
-  (let ((all (list-all-packages)))
-    (should (seq-every-p #'packagep all))
-    (should (memq (find-package "emacs") all))
-    (should (memq (find-package "keyword") all))
-    (should (memq (find-package "") all))))
-
 (ert-deftest pkg-tests-package-find-package ()
   (with-packages (x)
     (package-%register x)