source: trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java

Last change on this file was 15036, checked in by Mark Evenson, 7 years ago

Fix PACKAGE-ERROR-PACKAGE behaviour
(Olof-Joachim Frahm)

Also the slot is now always bound, no chance to get an #<UNBOUND>
object anymore.

C.f. <​http://abcl.org/trac/ticket/325>, but adds the package to a lot more
cases too.

From <​https://github.com/Ferada/abcl/commit/9c76a19b73e734c62f1195168c4f4a5a01e8233e>.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 16.7 KB
Line 
1/*
2 * PackageFunctions.java
3 *
4 * Copyright (C) 2003-2005 Peter Graves
5 * $Id: PackageFunctions.java 15036 2017-06-03 04:35:43Z mevenson $
6 *
7 * This program is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
11 *
12 * This program is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 * GNU General Public License for more details.
16 *
17 * You should have received a copy of the GNU General Public License
18 * along with this program; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
20 *
21 * As a special exception, the copyright holders of this library give you
22 * permission to link this library with independent modules to produce an
23 * executable, regardless of the license terms of these independent
24 * modules, and to copy and distribute the resulting executable under
25 * terms of your choice, provided that you also meet, for each linked
26 * independent module, the terms and conditions of the license of that
27 * module.  An independent module is a module which is not derived from
28 * or based on this library.  If you modify this library, you may extend
29 * this exception to your version of the library, but you are not
30 * obligated to do so.  If you do not wish to do so, delete this
31 * exception statement from your version.
32 */
33
34package org.armedbear.lisp;
35
36import static org.armedbear.lisp.Lisp.*;
37
38public final class PackageFunctions
39{
40    // ### packagep
41    // packagep object => generalized-boolean
42    private static final Primitive PACKAGEP = new Primitive("packagep", "object")
43    {
44        @Override
45        public LispObject execute(LispObject arg)
46        {
47            return arg instanceof Package ? T : NIL;
48        }
49    };
50
51    // ### package-name
52    // package-name package => nicknames
53    private static final Primitive PACKAGE_NAME =
54        new Primitive("package-name", "package")
55    {
56        @Override
57        public LispObject execute(LispObject arg)
58        {
59            return coerceToPackage(arg).NAME();
60        }
61    };
62
63    // ### package-nicknames
64    // package-nicknames package => nicknames
65    private static final Primitive PACKAGE_NICKNAMES =
66        new Primitive("package-nicknames", "package")
67    {
68        @Override
69        public LispObject execute(LispObject arg)
70        {
71            return coerceToPackage(arg).packageNicknames();
72        }
73    };
74
75    // ### package-use-list
76    // package-use-list package => use-list
77    private static final Primitive PACKAGE_USE_LIST =
78        new Primitive("package-use-list", "package")
79    {
80        @Override
81        public LispObject execute(LispObject arg)
82        {
83            return coerceToPackage(arg).getUseList();
84        }
85    };
86
87    // ### package-used-by-list
88    // package-used-by-list package => used-by-list
89    private static final Primitive PACKAGE_USED_BY_LIST =
90        new Primitive("package-used-by-list", "package")
91    {
92        @Override
93        public LispObject execute(LispObject arg)
94        {
95            return coerceToPackage(arg).getUsedByList();
96        }
97    };
98
99    // ### %import
100    // %import symbols &optional package => t
101    private static final Primitive _IMPORT =
102        new Primitive("%import", PACKAGE_SYS, false)
103    {
104        @Override
105        public LispObject execute(LispObject[] args)
106        {
107            if (args.length == 0 || args.length > 2)
108                return error(new WrongNumberOfArgumentsException(this, 1, 2));
109            LispObject symbols = args[0];
110            Package pkg =
111                args.length == 2 ? coerceToPackage(args[1]) : getCurrentPackage();
112            if (symbols.listp()) {
113                while (symbols != NIL) {
114                    pkg.importSymbol(checkSymbol(symbols.car()));
115                    symbols = symbols.cdr();
116                }
117            } else
118                pkg.importSymbol(checkSymbol(symbols));
119            return T;
120        }
121    };
122
123    // ### unexport
124    // unexport symbols &optional package => t
125    private static final Primitive UNEXPORT =
126        new Primitive("unexport", "symbols &optional package")
127    {
128        @Override
129        public LispObject execute(LispObject[] args)
130        {
131            if (args.length == 0 || args.length > 2)
132                return error(new WrongNumberOfArgumentsException(this, 1, 2));
133            LispObject symbols = args[0];
134            Package pkg =
135                args.length == 2 ? coerceToPackage(args[1]) : getCurrentPackage();
136            if (symbols.listp()) {
137                while (symbols != NIL) {
138                    pkg.unexport(checkSymbol(symbols.car()));
139                    symbols = symbols.cdr();
140                }
141            } else
142                pkg.unexport(checkSymbol(symbols));
143            return T;
144        }
145    };
146
147    // ### shadow
148    // shadow symbol-names &optional package => t
149    private static final Primitive SHADOW =
150        new Primitive("shadow", "symbol-names &optional package")
151    {
152        @Override
153        public LispObject execute(LispObject[] args)
154        {
155            if (args.length == 0 || args.length > 2)
156                return error(new WrongNumberOfArgumentsException(this, 1, 2));
157            LispObject symbols = args[0];
158            Package pkg =
159                args.length == 2 ? coerceToPackage(args[1]) : getCurrentPackage();
160            if (symbols.listp()) {
161                while (symbols != NIL) {
162                    pkg.shadow(javaString(symbols.car()));
163                    symbols = symbols.cdr();
164                }
165            } else
166                pkg.shadow(javaString(symbols));
167            return T;
168        }
169    };
170
171    // ### shadowing-import
172    // shadowing-import symbols &optional package => t
173    private static final Primitive SHADOWING_IMPORT =
174        new Primitive("shadowing-import", "symbols &optional package")
175    {
176        @Override
177        public LispObject execute(LispObject[] args)
178        {
179            if (args.length == 0 || args.length > 2)
180                return error(new WrongNumberOfArgumentsException(this, 1, 2));
181            LispObject symbols = args[0];
182            Package pkg =
183                args.length == 2 ? coerceToPackage(args[1]) : getCurrentPackage();
184            if (symbols.listp()) {
185                while (symbols != NIL) {
186                    pkg.shadowingImport(checkSymbol(symbols.car()));
187                    symbols = symbols.cdr();
188                }
189            } else
190                pkg.shadowingImport(checkSymbol(symbols));
191            return T;
192        }
193    };
194
195    // ### package-shadowing-symbols
196    // package-shadowing-symbols package => used-by-list
197    private static final Primitive PACKAGE_SHADOWING_SYMBOLS =
198        new Primitive("package-shadowing-symbols", "package")
199    {
200        @Override
201        public LispObject execute(LispObject arg)
202        {
203            return coerceToPackage(arg).getShadowingSymbols();
204        }
205    };
206
207    // ### %delete-package
208    private static final Primitive _DELETE_PACKAGE =
209        new Primitive("%delete-package", PACKAGE_SYS, false)
210    {
211        @Override
212        public LispObject execute(LispObject arg)
213        {
214            return coerceToPackage(arg).delete() ? T : NIL;
215        }
216    };
217
218    // ### unuse-package
219    // unuse-package packages-to-unuse &optional package => t
220    private static final Primitive USE_PACKAGE =
221        new Primitive("unuse-package", "packages-to-unuse &optional package")
222    {
223        @Override
224        public LispObject execute(LispObject[] args)
225        {
226            if (args.length < 1 || args.length > 2)
227                return error(new WrongNumberOfArgumentsException(this, 1, 2));
228            Package pkg;
229            if (args.length == 2)
230                pkg = coerceToPackage(args[1]);
231            else
232                pkg = getCurrentPackage();
233            if (args[0] instanceof Cons) {
234                LispObject list = args[0];
235                while (list != NIL) {
236                    pkg.unusePackage(coerceToPackage(list.car()));
237                    list = list.cdr();
238                }
239            } else
240                pkg.unusePackage(coerceToPackage(args[0]));
241            return T;
242        }
243    };
244
245    // ### rename-package
246    // rename-package package new-name &optional new-nicknames => package-object
247    private static final Primitive RENAME_PACKAGE =
248        new Primitive("rename-package", "package new-name &optional new-nicknames")
249    {
250        @Override
251        public LispObject execute(LispObject[] args)
252        {
253            if (args.length < 2 || args.length > 3)
254                return error(new WrongNumberOfArgumentsException(this, 2, 3));
255            Package pkg = coerceToPackage(args[0]);
256            String newName = javaString(args[1]);
257            LispObject nicknames = args.length == 3 ? checkList(args[2]) : NIL;
258            pkg.rename(newName, nicknames);
259            return pkg;
260        }
261    };
262
263    private static final Primitive LIST_ALL_PACKAGES =
264        new Primitive("list-all-packages", "")
265    {
266        @Override
267        public LispObject execute()
268        {
269            return Packages.listAllPackages();
270        }
271    };
272
273  // ### package-local-nicknames
274  // package-local-nicknames package => nickname-alist
275  private static final Primitive PACKAGE_LOCAL_NICKNAMES =
276    new Primitive("package-local-nicknames", PACKAGE_EXT, true, "package")
277    {
278      @Override
279      public LispObject execute(LispObject arg)
280      {
281        return coerceToPackage(arg).getLocalPackageNicknames();
282      }
283    };
284
285  // ### add-package-local-nickname
286  // add-package-local-nickname local-nickname package &optional package-designator => package
287  private static final Primitive ADD_PACKAGE_LOCAL_NICKNAME =
288    new Primitive("%add-package-local-nickname", PACKAGE_SYS, false,
289                  "local-nickname package &optional package-designator")
290    {
291      @Override
292      public LispObject execute(LispObject nick, LispObject pack,
293                                LispObject target)
294      {
295        return coerceToPackage(target).addLocalPackageNickname(nick.getStringValue(), coerceToPackage(pack));
296      }
297      @Override
298      public LispObject execute(LispObject nick, LispObject pack)
299      {
300        return this.execute(nick, pack, getCurrentPackage());
301      }
302    };
303
304  // ### remove-package-local-nickname
305  // remove-package-local-nickname old-nickname &optional package-designator => boolean
306  private static final Primitive REMOVE_PACKAGE_LOCAL_NICKNAME =
307    new Primitive("remove-package-local-nickname", PACKAGE_EXT, true,
308                  "old-nickname &optional package-designator")
309    {
310      @Override
311      public LispObject execute(LispObject nick, LispObject target)
312      {
313        return coerceToPackage(target).removeLocalPackageNickname(nick.getStringValue());
314      }
315      @Override
316      public LispObject execute(LispObject nick)
317      {
318        return this.execute(nick, getCurrentPackage());
319      }
320    };
321
322  // ### package-locally-nicknamed-by-list
323  // package-locally-nicknamed-by-list package => package-list
324  private static final Primitive PACKAGE_LOCALLY_NICKNAMED_BY_LIST =
325    new Primitive("package-locally-nicknamed-by-list", PACKAGE_EXT, true,
326                  "package")
327    {
328      @Override
329      public LispObject execute(LispObject pack)
330      {
331        return Packages.getPackagesNicknamingPackage(coerceToPackage(pack));
332      }
333    };
334
335
336    // ### %defpackage name nicknames size shadows shadowing-imports use
337    // imports interns exports doc-string => package
338    private static final Primitive _DEFPACKAGE =
339        new Primitive("%defpackage", PACKAGE_SYS, false)
340    {
341        @Override
342        public LispObject execute(LispObject[] args)
343        {
344            if (args.length != 11)
345                return error(new WrongNumberOfArgumentsException(this, 11));
346            final String packageName = args[0].getStringValue();
347            Package currentpkg = getCurrentPackage();
348            LispObject nicknames = checkList(args[1]);
349            // FIXME size is ignored
350            // LispObject size = args[2];
351            LispObject shadows = checkList(args[3]);
352            LispObject shadowingImports = checkList(args[4]);
353            LispObject use = checkList(args[5]);
354            LispObject imports = checkList(args[6]);
355            LispObject interns = checkList(args[7]);
356            LispObject exports = checkList(args[8]);
357            LispObject localNicknames = checkList(args[9]);
358            // FIXME docString is ignored
359            // LispObject docString = args[10];
360            Package pkg = currentpkg.findPackage(packageName);
361            if (pkg != null)
362                return pkg;
363            if (nicknames != NIL) {
364                LispObject list = nicknames;
365                while (list != NIL) {
366                    LispObject lispNick = list.car();
367                    String nick = javaString(lispNick);
368                    if (currentpkg.findPackage(nick) != null) {
369                        return error(new PackageError("A package named " + nick +
370                                                       " already exists.", lispNick));
371                    }
372                    list = list.cdr();
373                }
374            }
375            pkg = Packages.createPackage(packageName);
376            while (nicknames != NIL) {
377                LispObject string = nicknames.car().STRING();
378                pkg.addNickname(string.getStringValue());
379                nicknames = nicknames.cdr();
380            }
381            while (shadows != NIL) {
382                String symbolName = shadows.car().getStringValue();
383                pkg.shadow(symbolName);
384                shadows = shadows.cdr();
385            }
386            while (shadowingImports != NIL) {
387                LispObject si = shadowingImports.car();
388                Package otherPkg = coerceToPackage(si.car());
389                LispObject symbolNames = si.cdr();
390                while (symbolNames != NIL) {
391                    String symbolName = symbolNames.car().getStringValue();
392                    Symbol sym = otherPkg.findAccessibleSymbol(symbolName);
393                    if (sym != null)
394                        pkg.shadowingImport(sym);
395                    else
396                        return error(new LispError(symbolName +
397                                                    " not found in package " +
398                                                    otherPkg.getName() + "."));
399                    symbolNames = symbolNames.cdr();
400                }
401                shadowingImports = shadowingImports.cdr();
402            }
403            while (use != NIL) {
404                LispObject obj = use.car();
405                if (obj instanceof Package)
406                    pkg.usePackage((Package)obj);
407                else {
408                    LispObject string = obj.STRING();
409                    Package p = currentpkg.findPackage(string.getStringValue());
410                    if (p == null)
411                        return error(new LispError(obj.princToString() +
412                                                    " is not the name of a package."));
413                    pkg.usePackage(p);
414                }
415                use = use.cdr();
416            }
417            while (imports != NIL) {
418                LispObject si = imports.car();
419                Package otherPkg = coerceToPackage(si.car());
420                LispObject symbolNames = si.cdr();
421                while (symbolNames != NIL) {
422                    String symbolName = symbolNames.car().getStringValue();
423                    Symbol sym = otherPkg.findAccessibleSymbol(symbolName);
424                    if (sym != null)
425                        pkg.importSymbol(sym);
426                    else
427                        return error(new LispError(symbolName +
428                                                    " not found in package " +
429                                                    otherPkg.getName() + "."));
430                    symbolNames = symbolNames.cdr();
431                }
432                imports = imports.cdr();
433            }
434            while (interns != NIL) {
435                String symbolName = interns.car().getStringValue();
436                pkg.intern(symbolName);
437                interns = interns.cdr();
438            }
439            while (exports != NIL) {
440                String symbolName = exports.car().getStringValue();
441                pkg.export(pkg.intern(symbolName));
442                exports = exports.cdr();
443            }
444            while (localNicknames != NIL) {
445              LispObject nickDecl = localNicknames.car();
446              String name = nickDecl.car().getStringValue();
447              Package pack = coerceToPackage(nickDecl.cadr());
448              pkg.addLocalPackageNickname(name, pack);
449              localNicknames = localNicknames.cdr();
450            }
451            return pkg;
452        }
453    };
454}
Note: See TracBrowser for help on using the repository browser.