;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               package-mac.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    This package is a CLOS wrapper over the Common Lisp package system.
;;;;
;;;;    This file contains the macros.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2013-11-30 <PJB> cl:package wrapper for LispOS.
;;;;BUGS
;;;;LEGAL
;;;;    AGPL3
;;;;
;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
;;;;
;;;;    This program is free software: you can redistribute it and/or modify
;;;;    it under the terms of the GNU Affero General Public License as published by
;;;;    the Free Software Foundation, either version 3 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 Affero General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU Affero General Public License
;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************

(cl:in-package "COM.INFORMATIMAGO.COMMON-LISP.LISPOS.PACKAGE")

(define-modify-macro appendf (&rest args) append "Append onto list")


(defmacro with-package-iterator ((name package-list-form &rest symbol-types)
                                 &body declarations-body)
  "
DO:     Within the lexical scope of the body forms, the name is
        defined via macrolet such that successive invocations of
        (name) will return the symbols, one by one, from the packages
        in package-list.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/m_w_pkg_.htm>
"
  (flet ((valid-symbol-type-p (object)
           (member object '(:internal :external :inherited
                            ;; extensions:
                            :present :shadowing))))
    (cond
      ((null symbol-types) (error 'simple-program-error
                                  :format-control "Missing at least one symbol-type"))
      ((every (function valid-symbol-type-p) symbol-types))
      (t (error 'simple-program-error
                :format-control "Invalid symbol-type: ~S"
                :format-arguments (list (find-if-not (function valid-symbol-type-p) symbol-types))))))
  (let ((viterator (gensym "ITERATOR")))
    `(let ((,viterator (make-package-iterator ,package-list-form ',symbol-types)))
       (macrolet ((,name () '(funcall ,viterator)))
         ,@declarations-body))))


(eval-when (:compile-toplevel :load-toplevel :execute)

  (defun declarations (body)
    (loop
      :for item :in body
      :while (and (listp item) (eql 'declare (car item)))
      :collect item))

  (defun body (body)
    (loop
      :for items :on body
      :for item = (car items)
      :while (and (listp item) (eql 'declare (car item)))
      :finally (return items)))

  (assert (equal (mapcar (lambda (body) (list (declarations body) (body body)))
                         '(()
                           ((declare (ignore x)))
                           ((declare (ignore x)) (declare (ignore y)))
                           ((print w) (print z))
                           ((declare (ignore x)) (print w) (print z))
                           ((declare (ignore x)) (declare (ignore y)) (print w) (print z))))
                 '((nil nil)
                   (((declare (ignore x))) nil)
                   (((declare (ignore x)) (declare (ignore y))) nil)
                   (nil ((print w) (print z)))
                   (((declare (ignore x))) ((print w) (print z)))
                   (((declare (ignore x)) (declare (ignore y))) ((print w) (print z))))))


  (defun generate-do-symbols-loop (var package result-form body symbol-types)
    (let ((iter   (gensym "ITERATOR"))
          (got-it (gensym "GOT-IT"))
          (symbol (gensym "SYMBOL"))
          (vpack  (gensym "PACKAGE")))
      `(let ((,vpack (or ,package *package*)))
         (with-package-iterator (,iter ,vpack ,@symbol-types)
           (let (,var)
             ,@(declarations body)
             (loop
               (multiple-value-bind (,got-it ,symbol) (,iter)
                 (if ,got-it
                     (tagbody
                        (setf ,var ,symbol)
                        ,@(body body))
                     (progn
                       (setf ,var nil)
                       (return ,result-form))))))))))

  );;eval-when


(defmacro do-symbols         ((var &optional package result-form) &body body)
  "
DO:     Iterate over all the symbols of the package.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/m_do_sym.htm>
"
  (generate-do-symbols-loop var package result-form body '(:internal :external :inherited)))


(defmacro do-external-symbols ((var &optional package result-form) &body body)
  "
DO:     Iterate over all the external symbols of the package.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/m_do_sym.htm>
"
  (generate-do-symbols-loop var package result-form body '(:external)))


(defmacro do-all-symbols      ((var &optional result-form) &body body)
  "
DO:     Iterate over all the symbols of all the packages.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/m_do_sym.htm>
"
  (generate-do-symbols-loop var '(list-all-packages) result-form body '(:internal :external :inherited)))


(defmacro defpackage (defined-package-name &rest options)
  "
DO:     Define a new package.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/m_defpkg.htm>
"
  ;; option::= (:nicknames nickname*)* |
  ;;           (:documentation string) |
  ;;           (:use package-name*)* |
  ;;           (:shadow {symbol-name}*)* |
  ;;           (:shadowing-import-from package-name {symbol-name}*)* |
  ;;           (:import-from package-name {symbol-name}*)* |
  ;;           (:export {symbol-name}*)* |
  ;;           (:intern {symbol-name}*)* |
  ;;           (:size integer)
  (dolist (option options)
    (unless (typep option 'list)
      (error 'simple-type-error
             :datum option
             :expected-type 'list
             :format-control "This implementation doesn't support any non-standard option such as ~S"
             :format-arguments (list option)))
    (unless (typep (car option) '(member :nicknames :documentation :use
                                  :shadow :shadowing-import-from
                                  :import-from :export :intern :size))
      (error 'simple-type-error
             :datum (car option)
             :expected-type '(member :nicknames :documentation :use
                              :shadow :shadowing-import-from
                              :import-from :export :intern :size)
             :format-control "This implementation doesn't support any non-standard option such as ~S"
             :format-arguments (list option))))
  (dolist (key '(:documentation :size))
    (unless (<= (count key options :key (function first)) 1)
      (cerror "Ignore all but the first" 'simple-program-error
              :format-control "Too many ~S options given: ~S"
              :format-arguments (list key (remove key options :test-not (function eql) :key (function first))))))
  (labels ((extract-strings (key)
             (delete-duplicates
              (normalize-weak-designator-of-list-of-string-designator
               (reduce (function append)
                       (mapcar (function rest)
                               (remove key options
                                       :key (function first)
                                       :test-not (function eql)))))))
           (extract-packages (key)
             (delete-duplicates
              (mapcan (lambda (package)
                        (list (normalize-package-designator
                               package
                               :if-package-does-not-exist :ignore-or-replace
                               :if-package-exists :string)))
                      (reduce (function append)
                              (mapcar (function rest)
                                      (remove key options
                                              :key (function first)
                                              :test-not (function eql)))))))
           (extract-from (key)
             (let ((table (make-hash-table))
                   (result '()))
               (dolist (entry  (remove key options
                                       :key (function first)
                                       :test-not (function eql)))
                 (let ((entry (rest entry)))
                   (appendf (gethash (normalize-package-designator
                                      (first entry) :if-package-does-not-exist :error)
                                     table)
                            (normalize-weak-designator-of-list-of-string-designator (rest entry)))))
               ;; should do the same as in classify-per-package below.
               (maphash (lambda (k v) (push (list k v) result))
                        table)
               result))
           (check-string (object)
             (check-type object string)
             object)
           (extract-one-string (key)
             (let ((entries (remove key options
                                    :key (function first)
                                    :test-not (function eql))))
               (let ((entry (first entries)))
                 (when (rest entry)
                   (assert (null (cddr entry))
                           () "Invalid :DOCUMENTATION option: it should contain only one string.")
                   (check-string (second entry)))))))
    (let* ((shadows           (extract-strings    :shadow))
           (shadowing-imports (extract-from       :shadowing-import-from))
           (import-froms      (extract-from       :import-from))
           (interns           (extract-strings    :intern))
           (exports           (extract-strings    :export)))
      (check-disjoints shadows shadowing-imports import-froms interns exports)
      `(eval-when (:execute :compile-toplevel :load-toplevel)
         (%define-package ',(normalize-string-designator defined-package-name :if-not-a-string-designator :replace)
                          ',shadows
                          ',shadowing-imports
                          ',(extract-packages   :use)
                          ',import-froms
                          ',interns
                          ',exports
                          ',(extract-one-string :documentation)
                          ',(extract-strings    :nicknames))))))

;;;; THE END ;;;;
ViewGit