Changeset 3966

Timestamp:

09/21/03 15:09:05 (19 years ago)

Author:

piso

Message:

Work in progress.

Location:

trunk/j/src/org/armedbear/lisp

Files:

• LispClass.java (modified) (4 diffs)
• StandardClass.java (modified) (2 diffs)
• StructureClass.java (modified) (3 diffs)
• StructureObject.java (modified) (5 diffs)
• define-condition.lisp (modified) (2 diffs)
• define_condition.java (modified) (2 diffs)

trunk/j/src/org/armedbear/lisp/LispClass.java

@@ -3 +3 @@
  *
  * Copyright (C) 2003 Peter Graves
- * $Id: LispClass.java,v 1.20 2003-09-20 18:20:47 piso Exp $
+ * $Id: LispClass.java,v 1.21 2003-09-21 15:04:48 piso Exp $
  *
  * This program is free software; you can redistribute it and/or
@@ -28 +28 @@
     protected static final HashMap map = new HashMap();
 
+    public static void addClass(Symbol symbol, LispClass c)
+    {
+        synchronized (map) {
+            map.put(symbol, c);
+        }
+    }
+
+    public static LispClass findClass(Symbol symbol)
+    {
+        synchronized (map) {
+            return (LispClass) map.get(symbol);
+        }
+    }
+
     protected final Symbol symbol;
+    private LispObject directSuperclasses; // A list.
 
     protected LispClass(Symbol symbol)
     {
         this.symbol = symbol;
+        this.directSuperclasses = NIL;
     }
 
-    public Symbol getSymbol()
+    protected LispClass(Symbol symbol, LispObject directSuperclasses)
+    {
+        this.symbol = symbol;
+        this.directSuperclasses = directSuperclasses;
+    }
+
+    public final Symbol getSymbol()
     {
         return symbol;
+    }
+
+    public final LispObject getDirectSuperclasses()
+    {
+        return directSuperclasses;
+    }
+
+    public final void setDirectSuperclasses(Cons directSuperclasses)
+    {
+        this.directSuperclasses = directSuperclasses;
+    }
+
+    // When there's only one direct superclass...
+    public final void setDirectSuperclass(LispObject superclass)
+    {
+        directSuperclasses = new Cons(superclass);
     }
 
@@ -64 +102 @@
     }
 
-    public static LispClass findClass(Symbol symbol)
-    {
-        return (LispClass) map.get(symbol);
-    }
-
     // ### find-class
     private static final Primitive FIND_CLASS = new Primitive("find-class") {
@@ -92 +125 @@
         }
     };
+
+    private static final Primitive1 CLASS_DIRECT_SUPERCLASSES =
+        new Primitive1("class-direct-superclasses", PACKAGE_SYS, false)
+    {
+        public LispObject execute(LispObject arg) throws ConditionThrowable
+        {
+            if (arg instanceof LispClass)
+                return ((LispClass)arg).getDirectSuperclasses();
+            throw new ConditionThrowable(new TypeError(arg, "class"));
+        }
+    };
 }

trunk/j/src/org/armedbear/lisp/StandardClass.java

@@ -3 +3 @@
  *
  * Copyright (C) 2003 Peter Graves
- * $Id: StandardClass.java,v 1.2 2003-09-20 18:16:55 piso Exp $
+ * $Id: StandardClass.java,v 1.3 2003-09-21 15:07:13 piso Exp $
  *
  * This program is free software; you can redistribute it and/or
@@ -24 +24 @@
 public class StandardClass extends LispClass
 {
-    protected LispObject directSuperclasses; // A list.
+    public StandardClass(Symbol symbol, LispObject directSuperclasses)
+    {
+        super(symbol, directSuperclasses);
+    }
 
-    public StandardClass(Symbol symbol)
+    public String toString()
     {
-        super(symbol);
+        StringBuffer sb = new StringBuffer("#<STANDARD-CLASS ");
+        sb.append(symbol.getName());
+        sb.append('>');
+        return sb.toString();
     }
 }

trunk/j/src/org/armedbear/lisp/StructureClass.java

@@ -3 +3 @@
  *
  * Copyright (C) 2003 Peter Graves
- * $Id: StructureClass.java,v 1.1 2003-09-20 18:15:48 piso Exp $
+ * $Id: StructureClass.java,v 1.2 2003-09-21 15:06:39 piso Exp $
  *
  * This program is free software; you can redistribute it and/or
@@ -26 +26 @@
     private StructureClass(Symbol symbol)
     {
-        super(symbol);
+        super(symbol, new Cons(BuiltInClass.STRUCTURE_OBJECT));
     }
 
@@ -64 +64 @@
             Symbol symbol = checkSymbol(arg);
             StructureClass c = new StructureClass(symbol);
-            map.put(symbol, c);
+            addClass(symbol, c);
             return c;
         }

trunk/j/src/org/armedbear/lisp/StructureObject.java

@@ -3 +3 @@
  *
  * Copyright (C) 2003 Peter Graves
- * $Id: StructureObject.java,v 1.14 2003-09-20 18:18:28 piso Exp $
+ * $Id: StructureObject.java,v 1.15 2003-09-21 15:07:43 piso Exp $
  *
  * This program is free software; you can redistribute it and/or
@@ -24 +24 @@
 public final class StructureObject extends LispObject
 {
-    private final Symbol symbol;
+    private final LispClass structureClass;
     private final LispObject[] slots;
 
     public StructureObject(Symbol symbol, LispObject list) throws ConditionThrowable
     {
-        this.symbol = symbol;
+        structureClass = LispClass.findClass(symbol); // Might return null.
+        Debug.assertTrue(structureClass instanceof StructureClass);
         slots = list.copyToArray();
     }
@@ -35 +36 @@
     public StructureObject(StructureObject obj)
     {
-        this.symbol = obj.symbol;
+        this.structureClass = obj.structureClass;
         slots = new LispObject[obj.slots.length];
         for (int i = slots.length; i-- > 0;)
@@ -43 +44 @@
     public LispObject typeOf()
     {
-        return symbol;
+        return structureClass.getSymbol();
     }
 
     public LispClass classOf()
     {
-        return LispClass.findClass(symbol);
+        return structureClass;
     }
 
     public LispObject typep(LispObject type) throws ConditionThrowable
     {
-        if (type == symbol)
+        if (type instanceof StructureClass)
+            return type == structureClass ? T : NIL; // FIXME Could be a superclass.
+        if (type == structureClass.getSymbol())
             return T;
-        if (type instanceof StructureClass)
-            return type == LispClass.findClass(symbol) ? T : NIL;
         if (type == Symbol.STRUCTURE_OBJECT)
             return T;
@@ -67 +68 @@
     {
         StringBuffer sb = new StringBuffer("#S(");
-        sb.append(symbol);
+        sb.append(structureClass.getSymbol());
         // FIXME Use *PRINT-LENGTH*.
         final int limit = Math.min(slots.length, 10);

trunk/j/src/org/armedbear/lisp/define-condition.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003 Peter Graves
-;;; $Id: define-condition.lisp,v 1.1 2003-09-20 16:57:05 piso Exp $
+;;; $Id: define-condition.lisp,v 1.2 2003-09-21 15:08:43 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -22 +22 @@
 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
          &body options)
-  `(%define-condition ',name))
+  (let ((parent-types (or parent-types '(condition))))
+    `(%define-condition ',name ',parent-types ',slot-specs ',options)))

trunk/j/src/org/armedbear/lisp/define_condition.java

@@ -3 +3 @@
  *
  * Copyright (C) 2003 Peter Graves
- * $Id: define_condition.java,v 1.1 2003-09-20 16:56:02 piso Exp $
+ * $Id: define_condition.java,v 1.2 2003-09-21 15:09:05 piso Exp $
  *
  * This program is free software; you can redistribute it and/or
@@ -29 +29 @@
     }
 
+    // define-condition name (parent-type*) ({slot-spec}*) option* => name
     public LispObject execute(LispObject[] args) throws ConditionThrowable
     {
-        if (args.length < 1)
+        if (args.length != 4)
             throw new ConditionThrowable(new WrongNumberOfArgumentsException(this));
-        return NIL;
+        Symbol symbol = checkSymbol(args[0]);
+        Debug.trace("symbol = " + symbol);
+        LispObject parentTypes = checkCons(args[1]);
+        LispObject slotSpecs = args[2];
+        LispObject options = args[3];
+
+        StandardClass c = new StandardClass(symbol, parentTypes);
+        LispClass.addClass(symbol, c);
+        return c;
     }