source: trunk/abcl/src/org/armedbear/lisp/defpackage.lisp

;;; defpackage.lisp
;;;
;;; Copyright (C) 2003-2007 Peter Graves
;;; $Id: defpackage.lisp 15569 2022-03-19 12:50:18Z mevenson $
;;;
;;; This program 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 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program 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 this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module.  An independent module is a module which is not derived from
;;; or based on this library.  If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so.  If you do not wish to do so, delete this
;;; exception statement from your version.

(in-package "SYSTEM")

;;; Adapted from CMUCL.

(defun designated-package-name (designator)
  (cond ((packagep designator)
         (package-name designator))
        (t
         (string designator))))

(defun stringify-names (names)
  (mapcar #'string names))

(defun check-disjoint (&rest args)
  (let ((rest-args args))
    (dolist (arg1 args)
      (let ((key1 (car arg1))
            (set1 (cdr arg1)))
        (setq rest-args (cdr rest-args))
        (dolist (arg2 rest-args)
          (let* ((key2 (car arg2))
                 (set2 (cdr arg2))
                 (common (remove-duplicates (intersection set1 set2 :test #'string=))))
            (when common
              (error 'program-error
                     :format-control
                     "Parameters ~S and ~S must be disjoint, but have common elements: ~S"
                     :format-arguments
                     (list key1 key2 common)))))))))

(defun ensure-available-symbols (symbols)
   symbols)

(defmacro defpackage (package &rest options)
  (let ((nicknames nil)
        (size nil)
        (shadows nil)
        (shadowing-imports nil)
        (use nil)
        (use-p nil)
        (imports nil)
        (interns nil)
        (exports nil)
        (local-nicknames nil)
        (doc nil))
    (dolist (option options)
      (unless (consp option)
        (error 'program-error "bad DEFPACKAGE option: ~S" option))
      (case (car option)
        (:nicknames
         (setq nicknames (stringify-names (cdr option))))
        (:size
         (cond (size
                (error 'program-error "can't specify :SIZE twice"))
               ((and (consp (cdr option))
                     (typep (second option) 'unsigned-byte))
                (setq size (second option)))
               (t
                (error 'program-error
                       "bad :SIZE, must be a positive integer: ~S"
                       (second option)))))
        (:shadow
         (let ((new (stringify-names (cdr option))))
           (setq shadows (append shadows new))))
        (:shadowing-import-from
         (let ((package-name (designated-package-name (cadr option)))
               (symbol-names (stringify-names (cddr option))))
           (let ((assoc (assoc package-name shadowing-imports
                               :test #'string=)))
             (if assoc
                 (setf (cdr assoc) (append (cdr assoc) symbol-names))
                 (setq shadowing-imports
                       (acons package-name symbol-names shadowing-imports))))))
        (:use
         (let ((new (mapcar #'designated-package-name (cdr option))))
           (setq use (delete-duplicates (nconc use new) :test #'string=))
           (setq use-p t)))
        (:import-from
         (let ((package-name (designated-package-name (cadr option)))
               (symbol-names (stringify-names (cddr option))))
           (let ((assoc (assoc package-name imports
                               :test #'string=)))
             (if assoc
                 (setf (cdr assoc) (append (cdr assoc) symbol-names))
                 (setq imports (acons package-name symbol-names imports))))))
        (:intern
         (let ((new (stringify-names (cdr option))))
           (setq interns (append interns new))))
        (:export
         (let ((new (stringify-names (cdr option))))
           (setq exports (append exports new))))
        (:documentation
         (when doc
           (error 'program-error "can't specify :DOCUMENTATION twice"))
         (setq doc (coerce (cadr option) 'simple-string)))
        (:local-nicknames
         (dolist (nickdecl (cdr option))
           (unless (= (length nickdecl) 2)
             (error 'program-error "Malformed local nickname declaration ~A"
                    nickdecl))
           (let ((local-nickname (string (first nickdecl)))
                 (package-name (designated-package-name (second nickdecl))))
             (when (member local-nickname '("CL" "COMMON-LISP" "KEYWORD")
                           :test #'string=)
               (cerror "Continue anyway"
                       (format nil "Trying to define a local nickname for package ~A"
                               local-nickname)))
             (when (member local-nickname (list* package nicknames)
                           :test #'string=)
               (cerror "Continue anyway"
                       "Trying to override the name or a nickname (~A) ~
                        with a local nickname for another package ~A"
                       local-nickname package-name))
             (push (list local-nickname package-name) local-nicknames))))
        (t
         (error 'program-error "bad DEFPACKAGE option: ~S" option))))
    (check-disjoint `(:intern ,@interns) `(:export  ,@exports))
    (check-disjoint `(:intern ,@interns)
                    `(:import-from
                      ,@(apply #'append (mapcar #'rest imports)))
                    `(:shadow ,@shadows)
                    `(:shadowing-import-from
                      ,@(apply #'append (mapcar #'rest shadowing-imports))))
    `(prog1
       (%defpackage ,(string package) ',nicknames ',size
                    ',shadows (ensure-available-symbols ',shadowing-imports)
                    ',(if use-p use nil)
                    (ensure-available-symbols ',imports) ',interns ',exports
                    ',local-nicknames ',doc)
       ,(when (and (symbolp package) (not (keywordp package)))
          `(record-source-information-for-type ',package :package))
       (record-source-information-for-type ,(intern (string package) :keyword) :package)
       )))