Changeset 12528


Ignore:
Timestamp:
03/13/10 21:47:59 (13 years ago)
Author:
ehuelsmann
Message:

Reference #38: make the following snippet work:

(defclass g (standard-class) ())
(defclass h () () (:metaclass g))
(make-instance 'h)

Location:
branches/metaclass/abcl/src/org/armedbear/lisp
Files:
6 edited

Legend:

Unmodified
Added
Removed

  • branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java

    r12527 r12528  
    4949  }
    5050
     51  public static LispObject addClass(Symbol symbol, LispObject c)
     52  {
     53    synchronized (map)
     54      {
     55        map.put(symbol, c);
     56      }
     57    return c;
     58  }
     59
    5160  public static void removeClass(Symbol symbol)
    5261  {
    … …  
    6978  {
    7079    final Symbol symbol = checkSymbol(name);
    71     final LispClass c;
    72     synchronized (map)
    73       {
    74         c = (LispClass) map.get(symbol);
     80    final LispObject c;
     81    synchronized (map)
     82      {
     83        c = map.get(symbol);
    7584      }
    7685    if (c != null)
    … …  
    292301  public boolean subclassp(LispObject obj)
    293302  {
    294     LispObject cpl = getCPL();
     303    return false;
     304  }
     305
     306  public static boolean subclassp(LispObject cls, LispObject obj)
     307  {
     308    LispObject cpl;
     309
     310    if (cls instanceof LispClass)
     311      cpl = ((LispClass)cls).getCPL();
     312    else
     313      cpl = Symbol.CLASS_PRECEDENCE_LIST.execute(cls);
     314
    295315    while (cpl != NIL)
    296316      {
    … …  
    299319        cpl = ((Cons)cpl).cdr;
    300320      }
     321
     322    if (cls instanceof LispClass)
     323      // additional checks (currently because of JavaClass)
     324      return ((LispClass)cls).subclassp(obj);
     325
    301326    return false;
    302327  }
    … …  
    341366            return second;
    342367          }
    343         final LispClass c = checkClass(second);
    344         addClass(name, c);
     368        addClass(name, second);
    345369        return second;
    346370      }
    … …  
    355379
    356380      {
    357         final LispClass c = checkClass(first);
    358         return c.subclassp(second) ? T : NIL;
     381        return LispClass.subclassp(first, second) ? T : NIL;
    359382      }
    360383    };

  • branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java

    r12527 r12528  
    53175317        @Override
    53185318        public LispObject execute(LispObject arg) {
    5319             return checkClass(arg).getName();
     5319            if (arg instanceof LispClass)
     5320                return ((LispClass)arg).getName();
     5321
     5322            return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symName);
    53205323        }
    53215324    };
    … …  
    53325335
    53335336        {
    5334             checkClass(second).setName(checkSymbol(first));
     5337            if (second instanceof LispClass)
     5338                ((LispClass)second).setName(checkSymbol(first));
     5339            else
     5340                ((StandardObject)second).setInstanceSlotValue(StandardClass.symName,
     5341                                                           checkSymbol(first));
    53355342            return first;
    53365343        }
    … …  
    53465353        @Override
    53475354        public LispObject execute(LispObject arg) {
    5348             Layout layout = checkClass(arg).getClassLayout();
     5355            Layout layout;
     5356            if (arg instanceof LispClass)
     5357              layout = ((LispClass)arg).getClassLayout();
     5358            else
     5359              layout = (Layout)((StandardObject)arg).getInstanceSlotValue(StandardClass.symLayout);
     5360
    53495361            return layout != null ? layout : NIL;
    53505362        }
    … …  
    53635375        {
    53645376            if (first == NIL || first instanceof Layout) {
    5365                 checkClass(second).setClassLayout(first);
     5377                if (second instanceof LispClass)
     5378                  ((LispClass)second).setClassLayout(first);
     5379                else
     5380                  ((StandardObject)second).setInstanceSlotValue(StandardClass.symLayout, first);
    53665381                return first;
    53675382            }
    … …  
    53795394        @Override
    53805395        public LispObject execute(LispObject arg) {
    5381             return checkClass(arg).getDirectSuperclasses();
     5396            if (arg instanceof LispClass)
     5397              return ((LispClass)arg).getDirectSuperclasses();
     5398            else
     5399              return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSuperclasses);
    53825400        }
    53835401    };
    … …  
    53925410        @Override
    53935411        public LispObject execute(LispObject first, LispObject second)
    5394 
    5395         {
    5396             checkClass(second).setDirectSuperclasses(first);
     5412        {
     5413            if (second instanceof LispClass)
     5414              ((LispClass)second).setDirectSuperclasses(first);
     5415            else
     5416              ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSuperclasses, first);
    53975417            return first;
    53985418        }
    … …  
    54085428        @Override
    54095429        public LispObject execute(LispObject arg) {
    5410             return checkClass(arg).getDirectSubclasses();
     5430            if (arg instanceof LispClass)
     5431                return ((LispClass)arg).getDirectSubclasses();
     5432            else
     5433                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSubclasses);
    54115434        }
    54125435    };
    … …  
    54225445        @Override
    54235446        public LispObject execute(LispObject first, LispObject second)
    5424 
    5425         {
    5426             checkClass(second).setDirectSubclasses(first);
     5447        {
     5448            if (second instanceof LispClass)
     5449                ((LispClass)second).setDirectSubclasses(first);
     5450            else
     5451                ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSubclasses, first);
    54275452            return first;
    54285453        }
    … …  
    54385463        @Override
    54395464        public LispObject execute(LispObject arg) {
    5440             return checkClass(arg).getCPL();
     5465            if (arg instanceof LispClass)
     5466                return ((LispClass)arg).getCPL();
     5467            else
     5468                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symClassPrecedenceList);
    54415469        }
    54425470    };
    … …  
    54515479        @Override
    54525480        public LispObject execute(LispObject first, LispObject second)
    5453 
    5454         {
    5455             checkClass(second).setCPL(first);
     5481        {
     5482            if (second instanceof LispClass)
     5483                ((LispClass)second).setCPL(first);
     5484            else
     5485                ((StandardObject)second).setInstanceSlotValue(StandardClass.symClassPrecedenceList, first);
    54565486            return first;
    54575487        }
    … …  
    54675497        @Override
    54685498        public LispObject execute(LispObject arg)
    5469 
    5470         {
    5471             return checkClass(arg).getDirectMethods();
     5499        {
     5500            if (arg instanceof LispClass)
     5501                return ((LispClass)arg).getDirectMethods();
     5502            else
     5503                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectMethods);
    54725504        }
    54735505    };
    … …  
    54825514        @Override
    54835515        public LispObject execute(LispObject first, LispObject second)
    5484 
    5485         {
    5486             checkClass(second).setDirectMethods(first);
     5516        {
     5517            if (second instanceof LispClass)
     5518                ((LispClass)second).setDirectMethods(first);
     5519            else
     5520                ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectMethods, first);
    54875521            return first;
    54885522        }
    … …  
    55015535
    55025536        {
    5503             return checkClass(arg).getDocumentation();
     5537            if (arg instanceof LispClass)
     5538                return ((LispClass)arg).getDocumentation();
     5539            else
     5540                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDocumentation);
    55045541        }
    55055542    };
    … …  
    55155552        @Override
    55165553        public LispObject execute(LispObject first, LispObject second)
    5517 
    5518         {
    5519             checkClass(first).setDocumentation(second);
     5554        {
     5555            if (first instanceof LispClass)
     5556                ((LispClass)first).setDocumentation(second);
     5557            else
     5558                ((StandardObject)first).setInstanceSlotValue(StandardClass.symDocumentation, second);
    55205559            return second;
    55215560        }
    … …  
    55315570        @Override
    55325571        public LispObject execute(LispObject arg) {
    5533             return checkClass(arg).isFinalized() ? T : NIL;
     5572            if (arg instanceof LispClass)
     5573                return ((LispClass)arg).isFinalized() ? T : NIL;
     5574            else
     5575                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symFinalizedP);
    55345576        }
    55355577    };
    … …  
    55445586        @Override
    55455587        public LispObject execute(LispObject first, LispObject second)
    5546 
    5547         {
    5548             checkClass(second).setFinalized(first != NIL);
     5588        {
     5589            if (second instanceof LispClass)
     5590                ((LispClass)second).setFinalized(first != NIL);
     5591            else
     5592                ((StandardObject)second).setInstanceSlotValue(StandardClass.symFinalizedP, first);
    55495593            return first;
    55505594        }

  • branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java

    r12527 r12528  
    309309    };
    310310
    311     // ### compute-class-default-initargs
    312     private static final Primitive COMPUTE_CLASS_DEFAULT_INITARGS =
    313         new Primitive("compute-class-default-initargs", PACKAGE_SYS, true)
    314     {
    315         @Override
    316         public LispObject execute(LispObject arg)
    317 
    318         {
    319             final SlotClass c;
    320             if (arg instanceof SlotClass) {
    321                 c = (SlotClass) arg;
    322             }
    323             else {
    324                 return type_error(arg, Symbol.STANDARD_CLASS);
    325             }
    326             return c.computeDefaultInitargs();
    327         }
    328     };
    329311}

  • branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java

    r12527 r12528  
    3939{
    4040
    41   private static Symbol symName = PACKAGE_MOP.intern("NAME");
    42   private static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT");
    43   private static Symbol symDirectSuperclasses
     41  public static Symbol symName = PACKAGE_MOP.intern("NAME");
     42  public static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT");
     43  public static Symbol symDirectSuperclasses
    4444    = PACKAGE_MOP.intern("DIRECT-SUPERCLASSES");
    45   private static Symbol symDirectSubclasses
     45  public static Symbol symDirectSubclasses
    4646    = PACKAGE_MOP.intern("DIRECT-SUBCLASSES");
    47   private static Symbol symClassPrecedenceList
     47  public static Symbol symClassPrecedenceList
    4848    = PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST");
    49   private static Symbol symDirectMethods
     49  public static Symbol symDirectMethods
    5050    = PACKAGE_MOP.intern("DIRECT-METHODS");
    51   private static Symbol symDocumentation
     51  public static Symbol symDocumentation
    5252    = PACKAGE_MOP.intern("DOCUMENTATION");
    53   private static Symbol symDirectSlots
     53  public static Symbol symDirectSlots
    5454    = PACKAGE_MOP.intern("DIRECT-SLOTS");
    55   private static Symbol symSlots
     55  public static Symbol symSlots
    5656    = PACKAGE_MOP.intern("SLOTS");
    57   private static Symbol symDirectDefaultInitargs
     57  public static Symbol symDirectDefaultInitargs
    5858    = PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS");
    59   private static Symbol symDefaultInitargs
     59  public static Symbol symDefaultInitargs
    6060    = PACKAGE_MOP.intern("DEFAULT-INITARGS");
    61   private static Symbol symFinalizedP
     61  public static Symbol symFinalizedP
    6262    = PACKAGE_MOP.intern("FINALIZED-P");
    6363

  • branches/metaclass/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java

    r12290 r12528  
    4848          return new StandardClass();
    4949        if (arg instanceof StandardClass)
    50                 return ((StandardClass)arg).allocateInstance();
     50            return ((StandardClass)arg).allocateInstance();
     51        if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) {
     52            Layout layout = (Layout)Symbol.CLASS_LAYOUT.execute(arg);
     53            return new StandardObject(layout);
     54        }
    5155        return type_error(arg, Symbol.STANDARD_CLASS);
    5256      }

  • branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp

    r12527 r12528  
    289289;;; finalize-inheritance
    290290
     291(defun std-compute-class-default-initargs (class)
     292  (mapcan #'(lambda (c)
     293              (copy-list
     294               (class-direct-default-initargs c)))
     295          (class-precedence-list class)))
     296
    291297(defun std-finalize-inheritance (class)
    292298  (setf (class-precedence-list class)
    … …  
    332338    (setf (class-layout class)
    333339          (make-layout class (nreverse instance-slots) (nreverse shared-slots))))
    334   (setf (class-default-initargs class) (compute-class-default-initargs class))
     340  (setf (class-default-initargs class)
     341        (std-compute-class-default-initargs class))
    335342  (setf (class-finalized-p class) t))
    336343
Note: See TracChangeset for help on using the changeset viewer.