source: trunk/abcl/src/org/armedbear/lisp/package.lisp @ 14196

Last change on this file since 14196 was 13999, checked in by rschlatte, 9 years ago

Introduce a "continue" restart for delete-package

  • Fixes ansi test DELETE-PACKAGE.6
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 4.4 KB
Line 
1;;; package.lisp
2;;;
3;;; Copyright (C) 2008 Erik Huelsmann
4;;; $Id: package.lisp 13999 2012-07-10 20:46:34Z rschlatte $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "SYSTEM")
33
34;; Redefines make-package from boot.lisp
35
36(defun make-package (name &key nicknames use)
37  (restart-case
38      (progn
39        (when (find-package name)
40          (error 'simple-error "Package ~A already exists." name))
41        (dolist (nick nicknames)
42          (when (find-package nick)
43            (error 'package-error :package nick)))
44        (%make-package name nicknames use))
45    (use-existing-package ()
46      :report "Use existing package"
47      (return-from make-package (find-package name)))))
48
49;; Redefines function from defpackage.lisp, because there it's lacking restart-case
50
51(defun ensure-available-symbols (imports)
52  (remove nil
53          (mapcar #'(lambda (package-and-symbols)
54                      (let* ((package (find-package (designated-package-name (car package-and-symbols))))
55                             (new-symbols
56                              (remove nil
57                                      (mapcar #'(lambda (sym)
58                                                  (restart-case
59                                                      (progn
60                                                        (unless (nth-value 1 (find-symbol sym package))
61                                                          (error 'package-error
62                                                                 "The symbol ~A is not present in package ~A." sym (package-name package)))
63                                                        sym)
64                                                    (skip ()
65                                                      :report "Skip this symbol."
66                                                      nil)))
67                                              (cdr package-and-symbols)))))
68                        (when new-symbols
69                          (cons package new-symbols))))
70                  imports)))
71
72
73
74
75(defun import (symbols &optional (package *package* package-supplied-p))
76  (dolist (symbol (if (listp symbols) symbols (list symbols)))
77    (let* ((sym-name (string symbol))
78           (local-sym (find-symbol sym-name package)))
79      (restart-case
80          (progn
81            (when (and local-sym (not (eql symbol local-sym)))
82              (error 'package-error
83                     "Different symbol (~A) with the same name already accessible in package ~A."
84                     local-sym (package-name package)))
85            (if package-supplied-p
86                (%import (list symbol) package) ;; in order to pass NIL, wrap in a list
87                (%import (list symbol))))
88        (unintern-existing ()
89          :report (lambda (s) (format s "Unintern ~S and continue" local-sym))
90          (unintern local-sym)
91          (%import symbol))
92        (skip ()
93          :report "Skip symbol"))))
94  T)
95
96(defun delete-package (package)
97  (with-simple-restart (continue "Ignore missing package.")
98    (sys::%delete-package package)))
Note: See TracBrowser for help on using the repository browser.