From 0f383318a079bd0c7bb23c909f30771b1c20b29c Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Thu, 31 Jul 2008 09:33:25 +0200 Subject: Add Sacla to the repository. --- Sacla/package.lisp | 633 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 633 insertions(+) create mode 100644 Sacla/package.lisp (limited to 'Sacla/package.lisp') diff --git a/Sacla/package.lisp b/Sacla/package.lisp new file mode 100644 index 0000000..09e4efc --- /dev/null +++ b/Sacla/package.lisp @@ -0,0 +1,633 @@ +;; Copyright (C) 2002-2004, Yuji Minejima +;; ALL RIGHTS RESERVED. +;; +;; $Id: package.lisp,v 1.21 2004/09/02 06:59:43 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defstruct (package + (:constructor %make-package) + (:print-object print-package) + (:predicate packagep)) + "" + (%name nil :type (or string null)) + (%nicknames nil :type list) + (%shadowing-symbols nil :type list) + (%use-list nil :type list) + (%used-by-list nil :type list) + (internal-symbols (make-hash-table :test 'equal) :type hash-table) + (external-symbols (make-hash-table :test 'equal) :type hash-table)) + +(defun print-package (package stream) + (format stream "#<~A package (sumire)>" (package-%name package))) + +(defvar *keyword-package* (%make-package :%name "KEYWORD" :%nicknames '()) + "") + +(defvar *cl-package* (%make-package :%name "COMMON-LISP" :%nicknames (list "CL")) + "") + +(defvar *cl-user-package* + (%make-package :%name "COMMON-LISP-USER" :%nicknames (list "CL-USER") + :%use-list (list *cl-package*)) + "") + +(setf (package-%used-by-list *cl-package*) (list *cl-user-package*)) + +(defvar *package* *cl-user-package* + "The current package.") + +(defvar *all-packages* (list *cl-user-package* *cl-package* *keyword-package*) + "") + +(define-condition non-existent-package-name-error (package-error) ()) + +(defun %package (designator) + (or (find-package designator) + (and (typep designator 'package-designator) + (error 'non-existent-package-name-error :package designator)) + (error 'type-error :datum designator :expected-type 'package-designator))) + +(defun %package-list (designator) + (mapcar #'%package (%list designator))) + +(defmacro in-package (name) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setq *package* (%package ',name)))) + +(defun list-all-packages () + (copy-list *all-packages*)) + +(defun find-registered-package (name) + (block this + (dolist (package *all-packages* nil) + (when (string= name (package-%name package)) + (return-from this package)) + (dolist (nickname (package-%nicknames package)) + (when (string= name nickname) + (return-from this package)))))) + +(defun find-package (name) + (if (packagep name) + name + (find-registered-package (string name)))) + +(defun unuse-package (packages-to-unuse &optional (package *package*)) + (let ((packages-to-unuse (%package-list packages-to-unuse)) + (package (%package package))) + (dolist (unuse packages-to-unuse t) + (setf (package-%use-list package) + (remove unuse (package-%use-list package))) + (setf (package-%used-by-list unuse) + (remove package (package-%used-by-list unuse)))))) + +(defun package-name (package) + (copy-seq (package-%name (%package package)))) + +(defun package-nicknames (package) + (copy-list (package-%nicknames (%package package)))) + +(defun package-shadowing-symbols (package) + (copy-list (package-%shadowing-symbols (%package package)))) + +(defun package-use-list (package) + (copy-list (package-%use-list (%package package)))) + +(defun package-used-by-list (package) + (copy-list (package-%used-by-list (%package package)))) + +(define-condition package-name-error (simple-error) + ((name :type string :reader package-name-error-name :initarg :name)) + (:report (lambda (condition stream) + (format stream "A package named ~S already exists." + (package-name-error-name condition))))) + +(defun rename-package (package new-name &optional new-nicknames) + (let* ((package (%package package)) + (new-name (string new-name)) + (new-nicknames (string-list new-nicknames))) + (dolist (name (cons new-name new-nicknames)) + (let ((found (find-package name))) + (when (and found (not (eq package found))) + (error 'package-name-error :name name)))) + (setf (package-%name package) new-name + (package-%nicknames package) new-nicknames) + package)) + +(defun find-symbol (name &optional (package *package*)) + (let ((name (string name)) + (package (%package package))) + (multiple-value-bind (symbol registered-p) + (gethash name (package-external-symbols package)) + (if registered-p + (values symbol :external) + (multiple-value-bind (symbol registered-p) + (gethash name (package-internal-symbols package)) + (if registered-p + (values symbol :internal) + (dolist (used (package-use-list package) (values nil nil)) + (multiple-value-bind (symbol registered-p) + (gethash name (package-external-symbols used)) + (when registered-p + (return (values symbol :inherited))))))))))) + +(defun find-all-symbols (name) + (let ((name (string name)) + (all-symbols nil)) + (dolist (package (list-all-packages) (remove-duplicates all-symbols)) + (multiple-value-bind (symbol status) (find-symbol name package) + (case status ((:internal :external) (push symbol all-symbols))))))) + +(defun accessible-symbol-p (symbol package) + (multiple-value-bind (symbol-found status) + (find-symbol (symbol-name symbol) package) + (and (eq symbol symbol-found) status))) + +(defun present-symbol-p (symbol package) + (multiple-value-bind (symbol-found status) + (find-symbol (symbol-name symbol) package) + (and (eq symbol-found symbol) (find status '(:internal :external))))) + +(define-condition unintern-would-reveal-name-conflict-error (package-error) + ((symbol :type symbol :reader unintern-error-symbol :initarg :symbol))) + +(defun unintern (symbol &optional (package *package*)) + (flet ((conflicting-inherited-symbols (name package) + (let ((symbols nil)) + (dolist (used-package (package-use-list package)) + (multiple-value-bind (symbol-found foundp) + (gethash name (package-external-symbols used-package)) + (when foundp + (pushnew symbol-found symbols)))) + (if (cdr symbols) symbols nil)))) + (let* ((name (symbol-name symbol)) + (package (%package package)) + (present-p (present-symbol-p symbol package))) + (when present-p + (when (member symbol (package-shadowing-symbols package)) + (when (conflicting-inherited-symbols name package) + (error 'unintern-would-reveal-name-conflict-error + :symbol symbol :package package)) + (setf (package-%shadowing-symbols package) + (remove symbol (package-%shadowing-symbols package)))) + (remhash name (ecase present-p + (:internal (package-internal-symbols package)) + (:external (package-external-symbols package)))) + (when (eq (symbol-package symbol) package) + (setf (symbol-package symbol) nil)) + t)))) + + +(defun shadowing-import (symbol-list-designator &optional (package *package*)) + (let ((symbol-list (symbol-list symbol-list-designator)) + (package (%package package))) + (dolist (symbol symbol-list t) + (let ((name (symbol-name symbol))) + (multiple-value-bind (symbol-found status) (find-symbol name package) + (let ((present-p (member status '(:internal :external)))) + (when (and present-p (not (eq symbol symbol-found))) + (unintern symbol-found package)) + (unless (and present-p (eq symbol symbol-found)) + (setf (gethash name (package-internal-symbols package)) symbol)) + (pushnew symbol (package-%shadowing-symbols package)))))))) + +(define-condition import-would-cause-shadowing-error (package-error) + ((symbol :type symbol :reader import-error-symbol :initarg :symbol))) + +(defun import (symbol-list-designator &optional (package *package*)) + (let ((symbol-list (symbol-list symbol-list-designator)) + (package (%package package))) + (dolist (symbol symbol-list t) + (let ((name (symbol-name symbol))) + (multiple-value-bind (symbol-found status) (find-symbol name package) + (cond + ((and status (not (eq symbol symbol-found))) + (cerror "Import this symbol with shadowing-import." + 'import-would-cause-shadowing-error + :package package :symbol symbol) + (shadowing-import symbol package)) + ((and (member status '(:internal :external)) + (eq symbol symbol-found)) + ;; The spec says `If the symbol is already present + ;; in the importing package, import has no effect.' + ) + (t + (setf (gethash name (package-internal-symbols package)) symbol) + (when (null (symbol-package symbol)) + (setf (symbol-package symbol) package))))))))) + +(define-condition use-package-would-cause-name-conflict-error (package-error) + ((names :type list :reader use-package-error-names :initarg :names) + (package-to-use :type package :reader use-package-error-package-to-use + :initarg :package-to-use))) + +(defun check-use-package-name-conflict (using-package package-to-use) + (let* ((conflicting-names nil) + (shadows (package-shadowing-symbols using-package)) + (user-tables (cons (package-internal-symbols using-package) + (cons (package-external-symbols using-package) + (mapcar #'package-external-symbols + (package-use-list using-package))))) + (fat-user + (> (reduce #'+ user-tables :key #'hash-table-count) + (hash-table-count (package-external-symbols package-to-use)))) + (tables (if fat-user + (list (package-external-symbols package-to-use)) + user-tables)) + (package (if fat-user using-package package-to-use))) + (mapc #'(lambda (table) + (maphash + #'(lambda (name symbol) + (multiple-value-bind (symbol-found status) + (find-symbol name package) + (when (and status + (not (eq symbol symbol-found)) + (not (member name shadows :test #'string=))) + (push name conflicting-names)))) + table)) + tables) + (when conflicting-names + (restart-case (error 'use-package-would-cause-name-conflict-error + :names conflicting-names :package package + :package-to-use package-to-use) + (continue () + :report "Shadowing-import the conflicting symbols." + (shadowing-import (mapcar #'(lambda (name) + (find-symbol name package-to-use)) + conflicting-names) + package)))))) + +(defun use-package (package-to-use-list &optional (package *package*)) + (let ((package-to-use-list (%package-list package-to-use-list)) + (package (%package package))) + (dolist (package-to-use package-to-use-list t) + (cond + ((member package-to-use (package-use-list package))) + ((eq package-to-use *keyword-package*) + (warn "The keyword package cannot be used by other packages.")) + ((eq package-to-use package) + (warn "A package cannot use-package itself.")) + (t (check-use-package-name-conflict package package-to-use) + (push package-to-use (package-%use-list package)) + (push package (package-%used-by-list package-to-use))))))) + +(defun make-package (name &key nicknames use) + (let ((package + (%make-package + :%name (cond + ((not (find-package name)) (string name)) + (t (cerror "Return the existing package." + 'package-name-error :name name) + (return-from make-package (find-package name)))) + :%nicknames (mapcan + #'(lambda (nickname) + (cond + ((string= nickname name) nil) + ((find-package nickname) + (cerror "Don't use this nickname." + 'package-name-error :name nickname)) + (t (list (string nickname))))) + nicknames)))) + (use-package use package) + (pushnew package *all-packages*) + package)) + +(define-condition non-accessible-symbol-error (package-error) + ((symbol :type symbol + :reader non-accessible-symbol-error-symbol :initarg :symbol))) +(define-condition export-would-cause-conflict-in-user-package-error + (package-error) + ((symbol :type symbol :reader export-error-symbol :initarg :symbol) + (user-package :type package + :reader export-error-user-package :initarg :user-package))) + +(defun export (symbol-list-designator &optional (package *package*)) + (let ((symbol-list (symbol-list symbol-list-designator)) + (package (%package package)) + status) + (dolist (symbol symbol-list t) + (loop until (setq status (accessible-symbol-p symbol package)) + do + (cerror "Import this symbol." 'non-accessible-symbol-error + :package package :symbol symbol) + (import (list symbol) package)) + (unless (eq status :external) + (let ((name (symbol-name symbol))) + (dolist (user (package-used-by-list package)) + (loop + (multiple-value-bind (symbol-found status) (find-symbol name user) + (when (or (null status) (eq symbol symbol-found)) + (return)) + (cerror "Shadowing-import the symbol in the user package." + 'export-would-cause-conflict-in-user-package-error + :package package :user-package user :symbol symbol) + (shadowing-import (list symbol) user)))) + (when (eq status :inherited) + (import (list symbol) package)) + (remhash name (package-internal-symbols package)) + (setf (gethash name (package-external-symbols package)) symbol)))))) + +(defun unexport (symbol-list-designator &optional (package *package*)) + (let ((symbol-list (symbol-list symbol-list-designator)) + (package (%package package)) + status) + (dolist (symbol symbol-list t) + (unless (setq status (accessible-symbol-p symbol package)) + (cerror "Import this symbol." 'non-accessible-symbol-error + :package package :symbol symbol)) + (when (eq status :external) + (remhash (symbol-name symbol) (package-external-symbols package)) + (setf (gethash (symbol-name symbol) (package-internal-symbols package)) + symbol))))) + +(defun intern (name &optional (package *package*)) + (let ((name (string name)) + (package (%package package))) + (multiple-value-bind (symbol status) (find-symbol name package) + (if status + (values symbol status) + (let ((symbol (make-symbol name))) + (import (list symbol) package) + (when (eq package *keyword-package*) + (export (list symbol) package) + (setf (symbol-value symbol) symbol)) + (values symbol nil)))))) + +(defun shadow (symbol-names &optional (package *package*)) + (let ((symbol-names (string-list symbol-names)) + (package (%package package))) + (dolist (name symbol-names t) + (multiple-value-bind (symbol status) (find-symbol name package) + (when (or (not status) (eq status :inherited)) + (setq symbol (make-symbol name)) + (setf (symbol-package symbol) package) + (setf (gethash name (package-internal-symbols package)) symbol)) + (pushnew symbol (package-%shadowing-symbols package)))))) + +(defun hash-table-values (table) + (let ((values nil)) + (with-hash-table-iterator (get table) + (loop (multiple-value-bind (more k v) (get) + (declare (ignore k)) + (unless more (return)) + (push v values)))) + values)) + +(defun package-symbol-tables (package type) + (ecase type + (:internal (list (package-internal-symbols package))) + (:external (list (package-external-symbols package))) + (:inherited (mapcar #'package-external-symbols + (package-use-list package))))) + +(define-condition package-symbol-types-error (program-error) + ((types :reader symbol-types-error-types :initarg :types))) + +(defun shadowed-name-p (name package) + (member name (package-shadowing-symbols package) :test #'string=)) + +(defun package-iterator (package &rest symbol-types) + (unless symbol-types (error 'package-symbol-types-error :types symbol-types)) + (unless package (return-from package-iterator (constantly nil))) + (let* ((package-list (%package-list package)) + (package (pop package-list)) + (type (first symbol-types)) + (type-list (rest symbol-types)) + (iterator (hash-table-iterator (package-symbol-tables package type)))) + #'(lambda () + (loop + (multiple-value-bind (more name symbol) (funcall iterator) + (cond + (more + (unless (and (eq type :inherited) (shadowed-name-p name package)) + (return (values more symbol type package)))) + (t + (cond + (type-list (setq type (pop type-list))) + (package-list (setq type (first symbol-types) + type-list (rest symbol-types) + package (pop package-list))) + (t (return nil))) + (setq iterator + (hash-table-iterator (package-symbol-tables package + type)))))))))) + +(defmacro with-package-iterator ((name package-list-form &rest symbol-types) + &body body) + (unless symbol-types (error 'package-symbol-types-error :types symbol-types)) + (let ((iterator (gensym))) + `(let ((,iterator (package-iterator ,package-list-form ,@symbol-types))) + (macrolet ((,name () '(funcall ,iterator))) + ,@body)))) + +(defmacro do-package-symbols ((var package result-form &rest type-list) + &body body) + (let ((get (gensym)) + (more (gensym)) + (type (gensym)) + (pkg (gensym))) + (multiple-value-bind (declarations forms) (declarations-and-forms body) + `(with-package-iterator (,get ,package ,@type-list) + (loop + (multiple-value-bind (,more ,var ,type ,pkg) (,get) + (declare (ignore ,type ,pkg)) + ,@declarations + (unless ,more (return ,result-form)) + (tagbody + ,@forms))))))) + +(defmacro do-symbols ((var &optional (package-form '*package*) + result-form) + &body body) + (let ((package (gensym))) + `(let ((,package (%package ,package-form))) + (do-package-symbols (,var ,package ,result-form + :external :internal :inherited) + ,@body)))) + +(defmacro do-external-symbols ((var &optional (package-form '*package*) + result-form) + &body body) + (let ((package (gensym))) + `(let ((,package (%package ,package-form))) + (do-package-symbols (,var ,package ,result-form :external) + ,@body)))) + +(defmacro do-all-symbols ((var &optional result-form) &body body) + (let ((package (gensym)) + (body-function (gensym))) + (multiple-value-bind (declarations forms) (declarations-and-forms body) + `(block nil + (flet ((,body-function (,var) + (declare (ignorable ,var)) + ,@declarations + (tagbody ,@forms))) + (dolist (,package (list-all-packages) (let ((,var nil)) + (declare (ignorable ,var)) + ,@declarations + ,result-form)) + (do-symbols (,var ,package nil) + (,body-function ,var)))))))) + +(define-condition deleting-package-used-by-others-error (package-error) + ()) + +(defun delete-package (package) + (let ((package (or (find-package package) + (return-from delete-package + (cerror "Return NIL." 'non-existent-package-name-error + :package package))))) + (when (package-name package) + (when (package-used-by-list package) + (cerror "Remove dependency in other packages." + 'deleting-package-used-by-others-error :package package) + (dolist (user (package-used-by-list package)) + (unuse-package package user))) + (unuse-package (package-use-list package) package) + (do-symbols (symbol package) + (unintern symbol package)) + (setf (package-%name package) nil) + (setq *all-packages* (remove package *all-packages*)) + t))) + +(define-condition unsupported-defpackage-option-error (program-error) + ((option :reader unsupported-defpackage-option-error-option :initarg :option))) + +(define-condition non-accessible-symbol-name-error (package-error) + ((name :type string + :reader non-accessible-symbol-name-error-name :initarg :name))) + +(defun %accessible-symbols (name-list package) + (mapcar #'(lambda (name) + (loop + (multiple-value-bind (symbol status) + (find-symbol name package) + (when status + (return symbol)) + (cerror "Intern this symbol." 'non-accessible-symbol-name-error + :package package :name name) + (intern (string name) package)))) + name-list)) + +(defun check-disjoint(&rest args) + ;; An arg is (:key . set) + (do ((list args (cdr list))) + ((endp list)) + (loop + with x = (car list) + for y in (rest list) + for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=)) + when z do (error 'program-error + :format-control "Parameters ~S and ~S must be disjoint ~ + but have common elements ~% ~S" + :format-arguments (list (car x)(car y) z))))) + +(defmacro defpackage (package-name &rest options) + (let ((package-name (string package-name)) + forms nicknames shadow shadowing-import-from use import-from intern + export documentation size) + (loop + for (key . values) in options + do + (case key + (:nicknames (setq nicknames (append nicknames values))) + (:documentation (setq documentation (first values))) + (:shadow (setq shadow (append shadow values))) + (:shadowing-import-from (push values shadowing-import-from)) + (:use (setq use (append use values))) + (:import-from (push values import-from)) + (:intern (setq intern (append intern values))) + (:export (setq export (append export values))) + (:size (setq size (first values))) + (t (error 'unsupported-defpackage-option :option (cons key values))))) + (check-disjoint `(:intern ,@intern) + `(:import-from ,@(apply #'append (mapcar #'rest + import-from))) + `(:shadow ,@shadow) + `(:shadowing-import-from + ,@(apply #'append (mapcar #'rest shadowing-import-from)))) + (check-disjoint `(:intern ,@intern) `(:export ,@export)) + + (push `(let ((package (find-package ,package-name))) + (if package + (rename-package package + ,package-name (union ',(string-list nicknames) + (package-nicknames package) + :test #'string=)) + (make-package ,package-name :nicknames ',nicknames :use nil))) + forms) + (when documentation + (push `(setf (documentation ,package-name 'package) ,documentation) forms)) + (when shadow (push `(shadow ',(string-list shadow) ,package-name) forms)) + (when shadowing-import-from + (loop for (from . names) in shadowing-import-from + do (push `(let ((names ',(string-list names))) + (shadowing-import (%accessible-symbols names ',from) + ,package-name)) + forms))) + (when use (push `(use-package ',use ,package-name) forms)) + (when import-from + (loop for (from . names) in import-from + do (push `(let ((names ',(string-list names))) + (import (%accessible-symbols names ',from) ,package-name)) + forms))) + (when intern + (dolist (symbol intern) + (push `(intern ',symbol ,package-name) forms))) + (when export + (push `(export + (mapcar #'(lambda (name) (intern name ,package-name)) ',export) + ,package-name) + forms)) + (push `(find-package ,package-name) forms) + `(eval-when (:load-toplevel :compile-toplevel :execute) + ,@(nreverse forms)))) + +;;; +(defun clone-package-system () + (let ((src-list (mapcar #'cl:find-package + '("CL" "CL-USER" "KEYWORD" "TESTBED")))) + (dolist (src src-list) + (format t "Cloning the package ~S~%" src) + (let* ((name (cl:package-name src)) + (nicknames (cl:package-nicknames src)) + (dest (or (tb::find-package name) + (tb::make-package name :nicknames nicknames)))) + (cl:with-package-iterator (get src :internal :external) + (loop + (multiple-value-bind (more symbol status package) (get) + (declare (ignore status package)) + (unless more (return)) + ;;(format t "shadowing symbols = ~S~%" (cl:package-shadowing-symbols src)) + (if (member symbol (cl:package-shadowing-symbols src)) + (shadowing-import (list symbol) dest) + (progn + ;;(format t "calling import~%") + (import (list symbol) dest) + ;;(format t "called import~%" + ))))) + (cl:do-external-symbols (symbol src) + (export (list symbol) dest)))) + (setq *package* (find-package (cl:package-name cl:*package*))))) + -- cgit v1.2.3