[armedbear-cvs] r13201 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Mon Jan 31 16:45:41 2011
New Revision: 13201

Log:
Rename STD-ALLOCATE-INSTANCE to %STD-ALLOCATE-INSTANCE,
creating STD-ALLOCATE-INSTANCE which is closer to the one
specified by AMOP.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Autoload.java
   trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java
   trunk/abcl/src/org/armedbear/lisp/clos.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java	Mon Jan 31 16:45:41 2011
@@ -687,7 +687,7 @@
         autoload(PACKAGE_SYS, "set-slot-definition-writers", "SlotDefinition", true);
         autoload(PACKAGE_SYS, "simple-list-remove-duplicates", "simple_list_remove_duplicates");
         autoload(PACKAGE_SYS, "single-float-bits", "FloatFunctions", true);
-        autoload(PACKAGE_SYS, "std-allocate-instance", "StandardObjectFunctions", true);
+        autoload(PACKAGE_SYS, "%std-allocate-instance", "StandardObjectFunctions", true);
         autoload(PACKAGE_SYS, "unzip", "unzip", true);
         autoload(PACKAGE_SYS, "zip", "zip", true);
 

Modified: trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java	Mon Jan 31 16:45:41 2011
@@ -37,9 +37,9 @@
 
 public class StandardObjectFunctions
 {
-  // ### std-allocate-instance class => instance
-  private static final Primitive STD_ALLOCATE_INSTANCE =
-    new Primitive("std-allocate-instance", PACKAGE_SYS, true, "class")
+  // ### %std-allocate-instance class => instance
+  private static final Primitive _STD_ALLOCATE_INSTANCE =
+    new Primitive("%std-allocate-instance", PACKAGE_SYS, true, "class")
     {
       @Override
       public LispObject execute(LispObject arg)

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Mon Jan 31 16:45:41 2011
@@ -623,6 +623,13 @@
 (defun instance-slot-p (slot)
   (eq (slot-definition-allocation slot) :instance))
 
+(defun std-allocate-instance (class)
+  ;; AMOP says ALLOCATE-INSTANCE checks if the class is finalized
+  ;; and if not, tries to finalize it.
+  (unless (class-finalized-p class)
+    (std-finalize-inheritance class))
+  (sys::%std-allocate-instance class))
+
 (defun make-instance-standard-class (metaclass
 				     &rest initargs
                                      &key name direct-superclasses direct-slots