feature/pkg 160dcd51d0: First traces of defpackage

[Gerd Moellmann]

branch: feature/pkg
commit 160dcd51d0a8fd1f583b86fc6947994e718a3b73
Author: Gerd Möllmann <gerd@gnu.org>
Commit: Gerd Möllmann <gerd@gnu.org>

    First traces of defpackage
    
    * lisp/emacs-lisp/pkg.el (pkg--ensure-symbol): New function.
    (do-external-symbols): Prevent byte-compiler warnings.
    (pkg-defpackage): New.
    (defpackage): New.
---
 lisp/emacs-lisp/pkg.el | 319 ++++++++++++++++++++++++-------------------------
 1 file changed, 154 insertions(+), 165 deletions(-)

diff --git a/lisp/emacs-lisp/pkg.el b/lisp/emacs-lisp/pkg.el
index ead9c7b418..64076ef369 100644
--- a/lisp/emacs-lisp/pkg.el
+++ b/lisp/emacs-lisp/pkg.el
@@ -52,7 +52,7 @@
 ;;                               Helpers
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defun pkg-check-disjoint (&rest args)
+(defun pkg--check-disjoint (&rest args)
   "Check whether all given arguments specify disjoint sets of symbols.
 Each argument is of the form (:key . set)."
   (cl-loop for (current-arg . rest-args) on args
@@ -170,6 +170,15 @@ Otherwise assume that "
         ((null package) *package*)
         (t (pkg--package-or-lose package))))
 
+(defun pkg--ensure-symbol (name package)
+  ;; We could also intern it, hm...
+  (cl-multiple-value-bind (symbol how)
+      (find-symbol name package)
+    (if how
+        symbol
+      (error "%s does not contain a symbol %s"
+             (package-name package) name))))
+
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;                                  Macros
@@ -216,13 +225,13 @@ normally, or else if an explcit return occurs the value 
it transfers."
     `(cl-block nil
        (cl-flet ((,flet-name (,var)
                   (cl-tagbody ,@body)))
-        (let* ((package (pkg--package-or-lose ,package))
-               (shadows (package-%shadowing-symbols package)))
+        (let* ((package (pkg--package-or-lose ,package)))
           (maphash (lambda (k v)
                      (when (eq v :external)
                        (,flet-name k)))
                    (package-%symbols package))))
        (let ((,var nil))
+         ,var
         ,result-form))))
 
 ;;;###autoload
@@ -243,6 +252,7 @@ normally, or else if an explcit return occurs the value it 
transfers."
                      (,flet-name k))
                    (package-%symbols package))))
        (let ((,var nil))
+         ,var
         ,result-form))))
 
 
@@ -564,168 +574,147 @@ Value is t."
 ;;                            defpackage
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;; (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 (find-package name)))
-;;     (unless package
-;;       (setq package (make-package name :use nil :size (or size 10))))
-;;     (unless (string= (package-name package) name)
-;;       (error "%s is a nickname for the package %s"
-;;              name (package-name package)))
-
-;;     Nicknames
-;;     (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
-;;     (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))))
+(defun pkg-defpackage (name nicknames size shadows shadowing-imports
+                           use imports interns exports _doc-string)
+  (let ((package (or (find-package name)
+                     (make-package name :use nil :size size
+                                   :nicknames nicknames))))
+    ;; PKG-FIXME: What of the existing stuff does survive?  Nicknames,
+    ;; use-list, and so on.
+    (unregister-package package)
+    (register-package package)
+
+    ;; 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 (pkg--package-or-lose (car simports-from))))
+         (dolist (sym-name (cdr simports-from))
+           (let ((sym (pkg--ensure-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
+    (let ((old-use-list (package-use-list package))
+         (new-use-list (mapcar #'pkg--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 (pkg--package-or-lose (car imports-from))))
+       (dolist (sym-name (cdr imports-from))
+         (import (list (pkg--ensure-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))))
 
 (provide 'pkg)