1 /* 2 * LispClass.java 3 * 4 * Copyright (C) 2003-2005 Peter Graves 5 * $Id$ 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 34 package org.armedbear.lisp; 35 36 import java.util.concurrent.ConcurrentHashMap; 37 import static org.armedbear.lisp.Lisp.*; 38 39 public abstract class LispClass extends StandardObject 40 { 41 private static final ConcurrentHashMap<Symbol, LispObject> map 42 = new ConcurrentHashMap<Symbol, LispObject>(); 43 addClass(Symbol symbol, T c)44 public static <T extends LispClass> T addClass(Symbol symbol, T c) 45 { 46 map.put(symbol, c); 47 return c; 48 } 49 addClass(Symbol symbol, LispObject c)50 public static LispObject addClass(Symbol symbol, LispObject c) 51 { 52 map.put(symbol, c); 53 return c; 54 } 55 removeClass(Symbol symbol)56 public static void removeClass(Symbol symbol) 57 { 58 map.remove(symbol); 59 } 60 findClass(Symbol symbol)61 public static LispClass findClass(Symbol symbol) 62 { 63 return (LispClass)map.get(symbol); 64 } 65 findClass(LispObject name, boolean errorp)66 public static LispObject findClass(LispObject name, boolean errorp) 67 68 { 69 final Symbol symbol = checkSymbol(name); 70 final LispObject c; 71 c = map.get(symbol); 72 if (c != null) 73 return c; 74 if (errorp) 75 { 76 StringBuilder sb = 77 new StringBuilder("There is no class named "); 78 sb.append(name.princToString()); 79 sb.append('.'); 80 return error(new LispError(sb.toString())); 81 } 82 return NIL; 83 } 84 85 private final int sxhash; 86 87 private LispObject name; 88 private LispObject propertyList; 89 private Layout classLayout; 90 private LispObject directSuperclasses = NIL; 91 private LispObject directSubclasses = NIL; 92 private LispObject classPrecedenceList = NIL; 93 private LispObject directMethods = NIL; 94 private LispObject documentation = NIL; 95 private boolean finalized; 96 LispClass(Layout layout)97 protected LispClass(Layout layout) 98 { 99 super(layout, layout == null ? 0 : layout.getLength()); 100 sxhash = hashCode() & 0x7fffffff; 101 } 102 LispClass(Symbol symbol)103 protected LispClass(Symbol symbol) 104 { 105 this(null, symbol); 106 } 107 LispClass(Layout layout, Symbol symbol)108 protected LispClass(Layout layout, Symbol symbol) 109 { 110 super(layout, layout == null ? 0 : layout.getLength()); 111 setName(symbol); 112 sxhash = hashCode() & 0x7fffffff; 113 } 114 LispClass(Layout layout, Symbol symbol, LispObject directSuperclasses)115 protected LispClass(Layout layout, 116 Symbol symbol, LispObject directSuperclasses) 117 { 118 super(layout, layout == null ? 0 : layout.getLength()); 119 sxhash = hashCode() & 0x7fffffff; 120 setName(symbol); 121 setDirectSuperclasses(directSuperclasses); 122 } 123 124 @Override getParts()125 public LispObject getParts() 126 { 127 LispObject result = NIL; 128 result = result.push(new Cons("NAME", name != null ? name : NIL)); 129 result = result.push(new Cons("LAYOUT", 130 getClassLayout() != null 131 ? getClassLayout() : NIL)); 132 result = result.push(new Cons("DIRECT-SUPERCLASSES", 133 getDirectSuperclasses())); 134 result = result.push(new Cons("DIRECT-SUBCLASSES", getDirectSubclasses())); 135 result = result.push(new Cons("CLASS-PRECEDENCE-LIST", getCPL())); 136 result = result.push(new Cons("DIRECT-METHODS", getDirectMethods())); 137 result = result.push(new Cons("DOCUMENTATION", getDocumentation())); 138 return result.nreverse(); 139 } 140 141 @Override sxhash()142 public final int sxhash() 143 { 144 return sxhash; 145 } 146 getName()147 public LispObject getName() 148 { 149 return name; 150 } 151 setName(LispObject name)152 public void setName(LispObject name) 153 { 154 this.name = name; 155 } 156 157 @Override getPropertyList()158 public final LispObject getPropertyList() 159 { 160 if (propertyList == null) 161 propertyList = NIL; 162 return propertyList; 163 } 164 165 @Override setPropertyList(LispObject obj)166 public final void setPropertyList(LispObject obj) 167 { 168 if (obj == null) 169 throw new NullPointerException(); 170 propertyList = obj; 171 } 172 getClassLayout()173 public Layout getClassLayout() 174 { 175 return classLayout; 176 } 177 setClassLayout(LispObject layout)178 public void setClassLayout(LispObject layout) 179 { 180 classLayout = layout == NIL ? null : (Layout)layout; 181 } 182 getLayoutLength()183 public final int getLayoutLength() 184 { 185 if (layout == null) 186 return 0; 187 return layout.getLength(); 188 } 189 getDirectSuperclasses()190 public LispObject getDirectSuperclasses() 191 { 192 return directSuperclasses; 193 } 194 setDirectSuperclasses(LispObject directSuperclasses)195 public void setDirectSuperclasses(LispObject directSuperclasses) 196 { 197 this.directSuperclasses = directSuperclasses; 198 } 199 isFinalized()200 public boolean isFinalized() 201 { 202 return finalized; 203 } 204 setFinalized(boolean b)205 public void setFinalized(boolean b) 206 { 207 finalized = b; 208 } 209 210 // When there's only one direct superclass... setDirectSuperclass(LispObject superclass)211 public final void setDirectSuperclass(LispObject superclass) 212 { 213 setDirectSuperclasses(new Cons(superclass)); 214 } 215 getDirectSubclasses()216 public LispObject getDirectSubclasses() 217 { 218 return directSubclasses; 219 } 220 setDirectSubclasses(LispObject directSubclasses)221 public void setDirectSubclasses(LispObject directSubclasses) 222 { 223 this.directSubclasses = directSubclasses; 224 } 225 getCPL()226 public LispObject getCPL() 227 { 228 return classPrecedenceList; 229 } 230 setCPL(LispObject... cpl)231 public void setCPL(LispObject... cpl) 232 { 233 LispObject obj1 = cpl[0]; 234 if (obj1 instanceof Cons && cpl.length == 1) 235 classPrecedenceList = obj1; 236 else 237 { 238 Debug.assertTrue(obj1 == this); 239 LispObject l = NIL; 240 for (int i = cpl.length; i-- > 0;) 241 l = new Cons(cpl[i], l); 242 classPrecedenceList = l; 243 } 244 } 245 getDirectMethods()246 public LispObject getDirectMethods() 247 { 248 return directMethods; 249 } 250 setDirectMethods(LispObject methods)251 public void setDirectMethods(LispObject methods) 252 { 253 directMethods = methods; 254 } 255 getDocumentation()256 public LispObject getDocumentation() 257 { 258 return documentation; 259 } 260 setDocumentation(LispObject doc)261 public void setDocumentation(LispObject doc) 262 { 263 documentation = doc; 264 } 265 266 @Override typeOf()267 public LispObject typeOf() 268 { 269 return Symbol.CLASS; 270 } 271 272 @Override classOf()273 public LispObject classOf() 274 { 275 return StandardClass.CLASS; 276 } 277 278 @Override typep(LispObject type)279 public LispObject typep(LispObject type) 280 { 281 if (type == Symbol.CLASS) 282 return T; 283 if (type == StandardClass.CLASS) 284 return T; 285 return super.typep(type); 286 } 287 subclassp(LispObject obj)288 public boolean subclassp(LispObject obj) 289 { 290 return subclassp(this, obj); 291 } 292 subclassp(LispObject cls, LispObject obj)293 public static boolean subclassp(LispObject cls, LispObject obj) 294 { 295 LispObject cpl; 296 297 if (cls instanceof LispClass) 298 cpl = ((LispClass)cls).getCPL(); 299 else 300 cpl = Symbol.CLASS_PRECEDENCE_LIST.execute(cls); 301 302 while (cpl != NIL) 303 { 304 if (cpl.car() == obj) 305 return true; 306 cpl = ((Cons)cpl).cdr; 307 } 308 return false; 309 } 310 311 // ### find-class symbol &optional errorp environment => class 312 private static final Primitive FIND_CLASS = 313 new Primitive(Symbol.FIND_CLASS, "symbol &optional errorp environment") 314 { 315 @Override 316 public LispObject execute(LispObject arg) 317 { 318 return findClass(arg, true); 319 } 320 @Override 321 public LispObject execute(LispObject first, LispObject second) 322 323 { 324 return findClass(first, second != NIL); 325 } 326 @Override 327 public LispObject execute(LispObject first, LispObject second, 328 LispObject third) 329 330 { 331 // FIXME Use environment! 332 return findClass(first, second != NIL); 333 } 334 }; 335 336 // ### %set-find-class 337 private static final Primitive _SET_FIND_CLASS = 338 new Primitive("%set-find-class", PACKAGE_SYS, true) 339 { 340 @Override 341 public LispObject execute(LispObject first, LispObject second) 342 343 { 344 final Symbol name = checkSymbol(first); 345 if (second == NIL) 346 { 347 removeClass(name); 348 return second; 349 } 350 addClass(name, second); 351 return second; 352 } 353 }; 354 355 // ### subclassp 356 private static final Primitive SUBCLASSP = 357 new Primitive(Symbol.SUBCLASSP, "class") 358 { 359 @Override 360 public LispObject execute(LispObject first, LispObject second) 361 362 { 363 return LispClass.subclassp(first, second) ? T : NIL; 364 } 365 }; 366 } 367