source: branches/streams/abcl/src/org/armedbear/lisp/StructureClass.java

Last change on this file was 14463, checked in by rschlatte, 12 years ago

move structure-class metaclass definition into Lisp

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 4.4 KB
Line 
1/*
2 * StructureClass.java
3 *
4 * Copyright (C) 2003-2005 Peter Graves
5 * $Id: StructureClass.java 14463 2013-04-24 12:50:30Z rschlatte $
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 class StructureClass extends SlotClass
39{
40    StructureClass(Symbol symbol)
41    {
42        super(symbol, new Cons(BuiltInClass.STRUCTURE_OBJECT));
43    }
44
45    public StructureClass(Symbol symbol, LispObject directSuperclasses)
46    {
47        super(symbol, directSuperclasses);
48    }
49
50    @Override
51    public LispObject typeOf()
52    {
53        return Symbol.STRUCTURE_CLASS;
54    }
55
56    @Override
57    public LispObject classOf()
58    {
59      return LispClass.findClass(Symbol.STRUCTURE_CLASS);
60    }
61
62    @Override
63    public LispObject typep(LispObject type)
64    {
65        if (type == Symbol.STRUCTURE_CLASS)
66            return T;
67        if (type == LispClass.findClass(Symbol.STRUCTURE_CLASS))
68            return T;
69        return super.typep(type);
70    }
71
72    @Override
73    public LispObject getDescription()
74    {
75        return new SimpleString(princToString());
76    }
77
78    @Override
79    public String printObject()
80    {
81        StringBuilder sb = new StringBuilder("STRUCTURE-CLASS ");
82        sb.append(getName().princToString());
83        return unreadableString(sb.toString(), false);
84    }
85
86    // ### make-structure-class name direct-slots slots include => class
87    private static final Primitive MAKE_STRUCTURE_CLASS =
88        new Primitive("make-structure-class", PACKAGE_SYS, false)
89    {
90        @Override
91        public LispObject execute(LispObject first, LispObject second,
92                                  LispObject third, LispObject fourth)
93
94        {
95            Symbol symbol = checkSymbol(first);
96            LispClass existingClass = LispClass.findClass(symbol);
97
98            if (existingClass instanceof StructureClass)
99                // DEFSTRUCT-REDEFINITION write-up
100                // states the effects from re-definition are undefined
101                // we punt: our compiler bootstrapping depends on
102                // the class not being redefined (remaining in the
103                // same location in the class hierarchy)
104                return existingClass;
105
106
107
108            LispObject directSlots = checkList(second);
109            LispObject slots = checkList(third);
110            Symbol include = checkSymbol(fourth);
111
112            StructureClass c = new StructureClass(symbol);
113            if (include != NIL) {
114                LispClass includedClass = LispClass.findClass(include);
115                if (includedClass == null)
116                    return error(new SimpleError("Class " + include +
117                                                  " is undefined."));
118                c.setCPL(new Cons(c, includedClass.getCPL()));
119            } else
120                c.setCPL(c, BuiltInClass.STRUCTURE_OBJECT, BuiltInClass.CLASS_T);
121            c.setDirectSlotDefinitions(directSlots);
122            c.setSlotDefinitions(slots);
123            c.setFinalized(true);
124            addClass(symbol, c);
125            return c;
126        }
127    };
128}
Note: See TracBrowser for help on using the repository browser.