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

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Fri Aug 19 13:43:00 2011
New Revision: 13514

Log:
Fix #116 (fail to load cl-unicode) by saving serialized resources with a
size bigger that 64k in a separate file instead of within-classfile.

Modified:
   trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java
   trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java	Fri Aug 19 12:52:56 2011	(r13513)
+++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java	Fri Aug 19 13:43:00 2011	(r13514)
@@ -33,9 +33,9 @@
 
 package org.armedbear.lisp;
 
+import java.io.InputStream;
 import static org.armedbear.lisp.Lisp.*;
 
-import java.util.*;
 
 public class FaslClassLoader extends JavaClassLoader {
 
@@ -89,6 +89,27 @@
         }
     }
 
+    @Override
+    public InputStream getResourceAsStream(String resourceName) {
+      final LispThread thread = LispThread.currentThread();
+
+      Pathname name = new Pathname(resourceName.substring("org/armedbear/lisp/".length()));
+      LispObject truenameFasl = Symbol.LOAD_TRUENAME_FASL.symbolValue(thread);
+      LispObject truename = Symbol.LOAD_TRUENAME.symbolValue(thread);
+      
+      if (truenameFasl instanceof Pathname) {
+          return Pathname.mergePathnames(name, (Pathname)truenameFasl, Keyword.NEWEST)
+                    .getInputStream();
+      } else if (truename instanceof Pathname) {
+          return Pathname.mergePathnames(name, (Pathname) truename, Keyword.NEWEST)
+                  .getInputStream();
+      } else if (!Pathname.truename(name).equals(NIL)) {
+              return name.getInputStream();
+      }
+
+      return null;
+    }
+
     public byte[] getFunctionClassBytes(String name) {
         Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls");
         return readFunctionBytes(pathname);

Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	Fri Aug 19 12:52:56 2011	(r13513)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	Fri Aug 19 13:43:00 2011	(r13514)
@@ -585,7 +585,15 @@
     (when (probe-file fasl-loader)
       (push fasl-loader pathnames))
     (dotimes (i *class-number*)
-      (push (probe-file (compute-classfile-name (1+ i))) pathnames))
+      (let ((truename (probe-file (compute-classfile-name (1+ i)))))
+        (when truename
+          (push truename pathnames)
+          (dolist (resource (directory
+                             (make-pathname :name (format nil "~A_*"
+                                                           (pathname-name truename))
+                                            :type "clc"
+                                            :defaults truename)))
+            (push resource pathnames)))))
     (setf pathnames (nreverse (remove nil pathnames)))
     (let ((load-file (merge-pathnames (make-pathname :type "_")
                                       output-file)))

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug 19 12:52:56 2011	(r13513)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug 19 13:43:00 2011	(r13514)
@@ -1181,11 +1181,14 @@
   (emit-invokestatic +lisp+ "readObjectFromString"
                      (list +java-string+) +lisp-object+))
 
-(defun external-constant-resource-name (class)
-  (declare (ignore class))
-  ;; dummy implementation to suppress compiler warnings
-  ;; which break abcl compilation
-  )
+(defun compiland-external-constant-resource-name (compiland)
+  (let ((resource-number (compiland-next-resource compiland))
+        (pathname (abcl-class-file-pathname (compiland-class-file compiland))))
+    (incf (compiland-next-resource compiland))
+    (make-pathname :name (format nil "~A_~D"
+                                 (pathname-name pathname) resource-number)
+                   :type "clc"
+                   :defaults pathname)))
 
 (defun serialize-object (object)
   "Generate code to restore a serialized object which is not of any
@@ -1198,10 +1201,19 @@
        (emit-invokestatic +lisp+ "readObjectFromString"
                           (list +java-string+) +lisp-object+))
       (t
-       (assert (not "Serialized representation too long to be stored in a string"))
        (aload 0) ;; this
        (emit-invokevirtual +java-object+ "getClass" '() +java-class+)
-       (emit 'ldc (pool-string (external-constant-resource-name *this-class*)))
+       (let ((pathname
+              (compiland-external-constant-resource-name *current-compiland*)))
+         (with-open-file (f pathname
+                            :direction :output
+                            :if-exists :supersede
+                            :if-does-not-exist :create)
+           (write-string s f))
+         (emit 'ldc (pool-string
+                     (namestring (make-pathname :name (pathname-name pathname)
+                                                :type (pathname-type pathname)
+                                                :version nil)))))
        (emit-invokevirtual +java-class+ "getResourceAsStream"
                            (list +java-string+)
                            +java-io-input-stream+)

Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Fri Aug 19 12:52:56 2011	(r13513)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Fri Aug 19 13:43:00 2011	(r13514)
@@ -198,6 +198,7 @@
   children          ; List of local functions
                     ; defined with FLET, LABELS or LAMBDA
   blocks            ; TAGBODY, PROGV, BLOCK, etc. blocks
+  (next-resource 0)
   argument-register
   closure-register
   environment-register