From: Gerd Möllmann Date: Tue, 18 Oct 2022 11:21:20 +0000 (+0200) Subject: Work on defpackage X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=8ca1c93b6746efafdfc5dacf72dc099b7373306b;p=emacs.git Work on defpackage --- diff --git a/lisp/emacs-lisp/pkg.el b/lisp/emacs-lisp/pkg.el new file mode 100644 index 00000000000..073d9f6db54 --- /dev/null +++ b/lisp/emacs-lisp/pkg.el @@ -0,0 +1,260 @@ +;;; pkg.el --- Lisp packages -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Gerd Möllmann +;; Keywords: lisp, tools, maint +;; Version: 1.0 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; 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. + +;;; Code: + +(require 'cl-lib) + +(defvar *default-package-use-list* nil + "tbd") + +(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 + do + (cl-loop with (key1 . set1) = current-arg + for (key2 . set2) in rest-args + for common = (cl-delete-duplicates + (cl-intersection set1 set2 :test #'string=)) + unless (null common) + do + (error "Parameters %s and %s must be disjoint \ +but have common elements %s" key1 key2 common)))) + +(defun pkg-stringify-name (name kind) + (cl-typecase name + (string name) + (symbol (symbol-name name)) + (base-char (char-to-string name)) + (t (error "Bogus %s name: %s" kind name)))) + +(defun pkg-stringify-names (names kind) + (mapcar (lambda (name) (pkg-stringify-name name kind)) names)) + +(defun pkg-package-namify (n) + (pkg-stringify-name n "package")) + +(defun pkg-name-to-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)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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) + 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)))) + +;;; pkg.el ends here