Fix to issue when compiling literal quoted forms that share

information, see #606

src/org/armedbear/lisp/compiler-pass2.lisp

@@ -1288,6 +1288,61 @@ of the other types."
 4. The function to dispatch serialization to
 5. The type of the field to save the serialized result to")
 
+(defun shared-structure-p (object)
+  "Determines if a literal object shares some structure with previous externalized
+ objects"
+  (let ((circularity-hashtable (make-hash-table :test 'eq)))
+    (labels ((sh-str-helper (obj)
+               (unless (eq obj 'quote)
+                 (multiple-value-bind (value present-p)
+                     (gethash obj circularity-hashtable)
+                   (declare (ignore value))
+                   (if present-p
+                       (return-from sh-str-helper nil)
+                       (setf (gethash obj circularity-hashtable) t))))
+               (cond
+                 ((atom obj)
+                  (when (assoc obj *externalized-objects* :test #'eq)
+                    (return-from shared-structure-p t)))
+                 ((listp obj)
+                  (when (assoc obj *externalized-objects* :test #'eq)
+                    (return-from shared-structure-p t))
+                  (progn (sh-str-helper (car obj))
+                         (sh-str-helper (cdr obj))))
+                 (t nil))))
+      (sh-str-helper object))))
+
+(defun quoted-form-p (object)
+  "Determines if a literal object is a quoted form applied to a list object"
+  (and
+   (eq (car object) 'cl:quote)
+   (listp (second object))))
+
+
+(defmacro emit-cons2 (&key car (cdr '((emit-push-nil))))
+  `(progn
+     (emit-new +lisp-cons+)
+     (emit 'dup)
+     (progn
+       ,@car)
+     (progn
+       ,@cdr)
+     (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2))))
+
+
+(defun emit-shared-structure (object field-type cast)
+  "Emit code for the quoted form literal with shared structure with previous
+externalized objects"
+  (if (eq (car object) 'quote)
+      (emit-cons2 :car ((compile-form ''quote 'stack nil))
+                  :cdr ((emit-cons2
+                         :car ((emit-shared-structure (second object) field-type cast)))))
+      (let ((existing (assoc object *externalized-objects* :test #'eq)))
+        (emit-getstatic *this-class* (cdr existing) field-type)
+        (when cast
+          (emit-checkcast cast)))))
+
+
 (defknown emit-load-externalized-object (t &optional t) string)
 (defun emit-load-externalized-object (object &optional cast)
   "Externalizes `object' for use in a FASL.
@@ -1304,7 +1359,6 @@ the constructor if `*declare-inline*' is non-nil.
   ;; of the field it just loaded (to allow casting and what not).
   ;; The function should still do what it does today: de-serialize the
   ;; object and storing its value.
-
   (destructuring-bind
         (type prefix similarity-fn dispatch-fn field-type)
       (assoc-if #'(lambda (x)
@@ -1320,6 +1374,11 @@ the constructor if `*declare-inline*' is non-nil.
           (emit-checkcast cast))
         (return-from emit-load-externalized-object field-type)))
 
+    ;; for things like '#1#, ''#1#, '''#1# and so on ...
+    (when (and (shared-structure-p object) (quoted-form-p object))
+      (emit-shared-structure object field-type cast)
+      (return-from emit-load-externalized-object field-type))
+
     ;; We need to set up the serialized value
     (let ((field-name (symbol-name (gensym prefix))))
       (declare-field field-name field-type)
@@ -5557,18 +5616,18 @@ We need more thought here.
            (if list-star-p
                (compile-form (first (last args)) 'stack nil)
                (progn
-                 (emit-invokespecial-init 
+                 (emit-invokespecial-init
                   +lisp-cons+ (lisp-object-arg-types 1))
                  (pop cons-heads))) ; we've handled one of the args, so remove it
            (dolist (cons-head cons-heads)
              (declare (ignore cons-head))
-             (emit-invokespecial-init 
+             (emit-invokespecial-init
               +lisp-cons+ (lisp-object-arg-types 2)))
            (if list-star-p
                (progn
                  (apply #'maybe-emit-clear-values args)
                  (emit-move-from-stack target representation))
-               (progn 
+               (progn
                  (unless (every 'single-valued-p args)
                    (emit-clear-values))
                  (emit-move-from-stack target))))
@@ -7434,8 +7493,8 @@ We need more thought here.
 
 (defun make-compiler-error-form (form condition)
   `(lambda ,(cadr form)
-     (error 'program-error :format-control "Program error while compiling ~a" :format-arguments 
-            (if ,condition 
+     (error 'program-error :format-control "Program error while compiling ~a" :format-arguments
+            (if ,condition
                 (list (apply 'format nil ,(slot-value condition 'sys::format-control) ',(slot-value condition 'sys::format-arguments)))
                 (list "a form")))))
 

test/lisp/abcl/compiler-tests.lisp

@@ -446,7 +446,7 @@
 
 ;;; ticket #147
 #+abcl
-(deftest compiler.1 
+(deftest compiler.1
     (let ((tmpfile (ext::make-temp-file))
           (original-print-case *print-case*)
           (forms `((in-package :cl-user)
@@ -466,7 +466,7 @@
 #+abcl
 (deftest compiler.2
     (let ((tmpfile (ext::make-temp-file))
-          (line "(defconstant a #.(make-array '(8 256) 
+          (line "(defconstant a #.(make-array '(8 256)
                     :element-type '(unsigned-byte 32) :initial-element 0))"))
       (with-open-file (s tmpfile :direction :output)
         (format s "~A" line))
@@ -502,3 +502,79 @@
           (compile nil '(lambda (&key args &optional x))))
       (typep error 'program-error))
   t)
+
+
+;;; ticket #606 Github
+#+abcl
+(deftest compiler.5a
+    (let ((tmpfile (ext::make-temp-file))
+          (code
+             "(defun abcl/test/lisp::cp5a ()
+               '(0)
+               (let ((x #1='(0))
+                     (y (second '#1#)))
+                 (assert (equal x '(0)))
+                 (assert (equal y '(0)))
+                 (assert (eq x y))))"))
+      (with-open-file (s tmpfile :direction :output)
+        (format s "~A" code))
+      (load (compile-file tmpfile))
+      (delete-file tmpfile)
+      (prog1 (abcl/test/lisp::cp5a)
+        (fmakunbound 'abcl/test/lisp::cp5a)))
+  nil)
+
+#+abcl
+(deftest compiler.5b
+    (let ((tmpfile (ext::make-temp-file))
+          (code
+             "(defun abcl/test/lisp::cp5b ()
+               '(0)
+               (let ((x #1='(0 #1#))
+                     (y (second '#1#)))
+                 (assert (eq x y))))"))
+      (with-open-file (s tmpfile :direction :output)
+        (format s "~A" code))
+      (load (compile-file tmpfile))
+      (delete-file tmpfile)
+      (prog1 (abcl/test/lisp::cp5b)
+        (fmakunbound 'abcl/test/lisp::cp5b)))
+  nil)
+
+#+abcl
+(deftest compiler.5c
+    (let ((tmpfile (ext::make-temp-file))
+          (code
+             "(defun abcl/test/lisp::cp5c ()
+               '(0)
+               (let ((x #1='(0))
+                     (y (second (second ''#1#))))
+                 (assert (equal x '(0)))
+                 (assert (equal y '(0)))
+                 (assert (eq x y))))"))
+      (with-open-file (s tmpfile :direction :output)
+        (format s "~A" code))
+      (load (compile-file tmpfile))
+      (delete-file tmpfile)
+      (prog1 (abcl/test/lisp::cp5c)
+        (fmakunbound 'abcl/test/lisp::cp5c)))
+  nil)
+
+#+abcl
+(deftest compiler.5d
+    (let ((tmpfile (ext::make-temp-file))
+          (code
+             "(defun abcl/test/lisp::cp5d ()
+               '(0)
+               (let ((x #1='(0))
+                     (y (second (second (second '''#1#)))))
+                 (assert (equal x '(0)))
+                 (assert (equal y '(0)))
+                 (assert (eq x y))))"))
+      (with-open-file (s tmpfile :direction :output)
+        (format s "~A" code))
+      (load (compile-file tmpfile))
+      (delete-file tmpfile)
+      (prog1 (abcl/test/lisp::cp5d)
+        (fmakunbound 'abcl/test/lisp::cp5d)))
+  nil)