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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sun Sep  6 16:22:41 2009
New Revision: 12139

Log:
Make it possible to have non-private fields.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Sep  6 16:22:41 2009
@@ -1904,11 +1904,16 @@
   (write-u2 (field-descriptor-index field) stream)
   (write-u2 0 stream)) ; attributes count
 
-(defknown declare-field (t t) t)
-(defun declare-field (name descriptor)
+(defconst +field-access-protected+ #x4) ;; subclass accessible
+(defconst +field-access-private+   #x2) ;; class-only accessible
+(defconst +field-access-public+    #x1) ;; generally accessible
+(defconst +field-access-default+   #x0) ;; package accessible, used for LABELS
+
+(defknown declare-field (t t t) t)
+(defun declare-field (name descriptor access-flags)
   (let ((field (make-field name descriptor)))
-    ;; final private static
-    (setf (field-access-flags field) (logior #x10 #x8 #x2))
+    ;; final static <access-flags>
+    (setf (field-access-flags field) (logior #x10 #x8 access-flags))
     (setf (field-name-index field) (pool-name (field-name field)))
     (setf (field-descriptor-index field) (pool-name (field-descriptor field)))
     (push field *fields*)))
@@ -1958,7 +1963,7 @@
 	    (setf g (symbol-name (gensym "SYM")))
 	    (when s
 	      (setf g (concatenate 'string g "_" s)))
-	    (declare-field g +lisp-symbol+)
+	    (declare-field g +lisp-symbol+ +field-access-private+)
 	    (emit 'ldc (pool-string (symbol-name symbol)))
 	    (emit 'ldc (pool-string (package-name (symbol-package symbol))))
 	    (emit-invokestatic +lisp-class+ "internInPackage"
@@ -1984,7 +1989,7 @@
    symbol *declared-symbols* ht g
    (let ((*code* *static-code*))
      (setf g (symbol-name (gensym "KEY")))
-     (declare-field g +lisp-symbol+)
+     (declare-field g +lisp-symbol+ +field-access-private+)
      (emit 'ldc (pool-string (symbol-name symbol)))
      (emit-invokestatic +lisp-class+ "internKeyword"
 			(list +java-string+) +lisp-symbol+)
@@ -2001,7 +2006,7 @@
    (let ((s (sanitize symbol)))
      (when s
        (setf f (concatenate 'string f "_" s))))
-   (declare-field f +lisp-object+)
+   (declare-field f +lisp-object+ +field-access-private+)
    (multiple-value-bind
          (name class)
        (lookup-or-declare-symbol symbol)
@@ -2028,7 +2033,7 @@
    (setf g (symbol-name (gensym "LFUN")))
    (let* ((pathname (class-file-pathname (local-function-class-file local-function)))
 	  (*code* *static-code*))
-     (declare-field g +lisp-object+)
+     (declare-field g +lisp-object+ +field-access-default+)
      (emit 'ldc (pool-string (file-namestring pathname)))
      (emit-invokestatic +lisp-class+ "loadCompiledFunction"
 			(list +java-string+) +lisp-object+)
@@ -2045,7 +2050,7 @@
      (setf g (format nil "FIXNUM_~A~D"
 		     (if (minusp n) "MINUS_" "")
 		     (abs n)))
-     (declare-field g +lisp-integer+)
+     (declare-field g +lisp-integer+ +field-access-private+)
      (cond ((<= 0 n 255)
 	    (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+)
 	    (emit-push-constant-int n)
@@ -2063,7 +2068,7 @@
    n *declared-integers* ht g
    (setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym))))
    (let ((*code* *static-code*))
-     (declare-field g +lisp-integer+)
+     (declare-field g +lisp-integer+ +field-access-private+)
      (cond ((<= most-negative-java-long n most-positive-java-long)
 ;;	    (setf g (format nil "BIGNUM_~A~D"
 ;;			    (if (minusp n) "MINUS_" "")
@@ -2088,7 +2093,7 @@
    s *declared-floats* ht g
    (let* ((*code* *static-code*))
      (setf g (concatenate 'string "FLOAT_" (symbol-name (gensym))))
-     (declare-field g +lisp-single-float+)
+     (declare-field g +lisp-single-float+ +field-access-private+)
      (emit 'new +lisp-single-float-class+)
      (emit 'dup)
      (emit 'ldc (pool-float s))
@@ -2103,7 +2108,7 @@
    d *declared-doubles* ht g
    (let ((*code* *static-code*))
      (setf g (concatenate 'string "DOUBLE_" (symbol-name (gensym))))
-     (declare-field g +lisp-double-float+)
+     (declare-field g +lisp-double-float+ +field-access-private+)
      (emit 'new +lisp-double-float-class+)
      (emit 'dup)
      (emit 'ldc2_w (pool-double d))
@@ -2117,7 +2122,7 @@
   (let ((g (symbol-name (gensym "CHAR")))
         (n (char-code c))
         (*code* *static-code*))
-    (declare-field g +lisp-character+)
+    (declare-field g +lisp-character+ +field-access-private+)
     (cond ((<= 0 n 255)
            (emit 'getstatic +lisp-character-class+ "constants" +lisp-character-array+)
            (emit-push-constant-int n)
@@ -2137,7 +2142,7 @@
   (let* ((g (symbol-name (gensym "OBJSTR")))
          (s (with-output-to-string (stream) (dump-form obj stream)))
          (*code* *static-code*))
-    (declare-field g obj-ref)
+    (declare-field g obj-ref +field-access-private+)
     (emit 'ldc (pool-string s))
     (emit-invokestatic +lisp-class+ "readObjectFromString"
                        (list +java-string+) +lisp-object+)
@@ -2151,7 +2156,7 @@
   (let* ((g (symbol-name (gensym "LTV")))
          (s (with-output-to-string (stream) (dump-form obj stream)))
          (*code* *static-code*))
-    (declare-field g +lisp-object+)
+    (declare-field g +lisp-object+ +field-access-private+)
     (emit 'ldc (pool-string s))
     (emit-invokestatic +lisp-class+ "readObjectFromString"
                        (list +java-string+) +lisp-object+)
@@ -2169,7 +2174,7 @@
   (let* ((g (symbol-name (gensym "INSTANCE")))
          (s (with-output-to-string (stream) (dump-form obj stream)))
          (*code* *static-code*))
-    (declare-field g +lisp-object+)
+    (declare-field g +lisp-object+ +field-access-private+)
     (emit 'ldc (pool-string s))
     (emit-invokestatic +lisp-class+ "readObjectFromString"
                        (list +java-string+) +lisp-object+)
@@ -2185,7 +2190,7 @@
          (*print-length* nil)
          (s (format nil "#.(FIND-PACKAGE ~S)" (package-name obj)))
          (*code* *static-code*))
-    (declare-field g +lisp-object+)
+    (declare-field g +lisp-object+ +field-access-private+)
     (emit 'ldc (pool-string s))
     (emit-invokestatic +lisp-class+ "readObjectFromString"
                        (list +java-string+) +lisp-object+)
@@ -2205,7 +2210,7 @@
     (let* ((g1 (declare-string key))
            (g2 (symbol-name (gensym "O2BJ"))))
       (let* ((*code* *static-code*))
-      (declare-field g2 obj-ref)
+      (declare-field g2 obj-ref +field-access-private+)
       (emit 'getstatic *this-class* g1 +lisp-simple-string+)
       (emit-invokestatic +lisp-class+ "recall"
                          (list +lisp-simple-string+) +lisp-object+)
@@ -2221,7 +2226,7 @@
          (*print-length* nil)
          (s (format nil "~S" obj))
          (*code* *static-code*))
-    (declare-field g +lisp-object+)
+    (declare-field g +lisp-object+ +field-access-private+)
     (emit 'ldc
           (pool-string s))
     (emit-invokestatic +lisp-class+ "readObjectFromString"
@@ -2237,7 +2242,7 @@
    string *declared-strings* ht g
    (let ((*code* *static-code*))
         (setf g (symbol-name (gensym "STR")))
-        (declare-field g +lisp-simple-string+)
+        (declare-field g +lisp-simple-string+ +field-access-private+)
         (emit 'new +lisp-simple-string-class+)
         (emit 'dup)
         (emit 'ldc (pool-string string))