forked from Github/emacs
Ongoing work on the Lisp side and tests
This commit is contained in:
Gerd Möllmann
parent
89114e37f6
commit
15c813b00a
2 changed files with 113 additions and 58 deletions
|
|
@ -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)))))
|
||||
(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)
|
||||
(mapcar (lambda (name) (pkg-find-or-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))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue