From: Juho Snellman <jsnell@iki.fi>
Date: Fri, 20 Apr 2007 06:11:43 +0000 (+0000)
Subject: 1.0.4.109: rewrite source that mixed quasiquotes and circular lists
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b28b317b471212e2541190567ac723b6f1ed2aa6;p=sbcl.git

1.0.4.109: rewrite source that mixed quasiquotes and circular lists

         * CLisp didn't like the combination, use a macrolet instead
         * Patch by Luis Oliveira
---

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 4b01135..65927a1 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -328,61 +328,63 @@ of specialized arrays is supported."
 ;;; the type information is available. Finally, for each of these
 ;;; routines also provide a slow path, taken for arrays that are not
 ;;; vectors or not simple.
-(macrolet ((define (accessor-name slow-accessor-name table-name extra-params
+(macrolet ((%define (table-name extra-params)
+             `(funcall
+               (the function
+                 (let ((tag 0)
+                       (offset
+                        #.(ecase sb!c:*backend-byte-order*
+                            (:little-endian
+                             (- sb!vm:other-pointer-lowtag))
+                            (:big-endian
+                             ;; I'm not completely sure of what this
+                             ;; 3 represents symbolically. It's
+                             ;; just what all the LOAD-TYPE vops
+                             ;; are doing.
+                             (- 3 sb!vm:other-pointer-lowtag)))))
+                   ;; WIDETAG-OF needs extra code to handle
+                   ;; LIST and FUNCTION lowtags. We're only
+                   ;; dispatching on other pointers, so let's
+                   ;; do the lowtag extraction manually.
+                   (when (sb!vm::%other-pointer-p array)
+                     (setf tag
+                           (sb!sys:sap-ref-8 (int-sap (get-lisp-obj-address array))
+                                             offset)))
+                   ;; SYMBOL-GLOBAL-VALUE is a performance hack
+                   ;; for threaded builds.
+                   (svref (sb!vm::symbol-global-value ',table-name) tag)))
+               array index ,@extra-params))
+           (define (accessor-name slow-accessor-name table-name extra-params
                                   check-bounds)
-             `(progn
-                (defvar ,table-name)
-                (defun ,accessor-name (array index ,@extra-params)
-                  (declare (optimize speed
-                                     ;; (SAFETY 0) is ok. All calls to
-                                     ;; these functions are generated by
-                                     ;; the compiler, so argument count
-                                     ;; checking isn't needed. Type checking
-                                     ;; is done implicitly via the widetag
-                                     ;; dispatch.
-                                     (safety 0)))
-                  #1=(funcall
-                      (the function
-                        (let ((tag 0)
-                              (offset
-                               #.(ecase sb!c:*backend-byte-order*
-                                   (:little-endian
-                                    (- sb!vm:other-pointer-lowtag))
-                                   (:big-endian
-                                    ;; I'm not completely sure of what this
-                                    ;; 3 represents symbolically. It's
-                                    ;; just what all the LOAD-TYPE vops
-                                    ;; are doing.
-                                    (- 3 sb!vm:other-pointer-lowtag)))))
-                          ;; WIDETAG-OF needs extra code to handle
-                          ;; LIST and FUNCTION lowtags. We're only
-                          ;; dispatching on other pointers, so let's
-                          ;; do the lowtag extraction manually.
-                          (when (sb!vm::%other-pointer-p array)
-                            (setf tag
-                                  (sb!sys:sap-ref-8 (int-sap (get-lisp-obj-address array))
-                                                    offset)))
-                          ;; SYMBOL-GLOBAL-VALUE is a performance hack
-                          ;; for threaded builds.
-                          (svref (sb!vm::symbol-global-value ',table-name) tag)))
-                      array index ,@extra-params))
-                (defun ,slow-accessor-name (array index ,@extra-params)
-                  (declare (optimize speed (safety 0)))
-                  (if (not (%array-displaced-p array))
-                      ;; The reasonably quick path of non-displaced complex
-                      ;; arrays.
-                      (let ((array (%array-data-vector array)))
-                        #1#)
-                      ;; The real slow path.
-                      (with-array-data
-                          ((vector array)
-                           (index (locally
-                                      (declare (optimize (speed 1) (safety 1)))
-                                    (,@check-bounds index)))
-                           (end)
-                           :force-inline t)
-                        (declare (ignore end))
-                        (,accessor-name vector index ,@extra-params)))))))
+               `(progn
+                 (defvar ,table-name)
+                 (defun ,accessor-name (array index ,@extra-params)
+                   (declare (optimize speed
+                                      ;; (SAFETY 0) is ok. All calls to
+                                      ;; these functions are generated by
+                                      ;; the compiler, so argument count
+                                      ;; checking isn't needed. Type checking
+                                      ;; is done implicitly via the widetag
+                                      ;; dispatch.
+                                      (safety 0)))
+                   (%define ,table-name ,extra-params))
+                 (defun ,slow-accessor-name (array index ,@extra-params)
+                   (declare (optimize speed (safety 0)))
+                   (if (not (%array-displaced-p array))
+                       ;; The reasonably quick path of non-displaced complex
+                       ;; arrays.
+                       (let ((array (%array-data-vector array)))
+                         (%define ,table-name ,extra-params))
+                       ;; The real slow path.
+                       (with-array-data
+                           ((vector array)
+                            (index (locally
+                                       (declare (optimize (speed 1) (safety 1)))
+                                     (,@check-bounds index)))
+                            (end)
+                            :force-inline t)
+                         (declare (ignore end))
+                         (,accessor-name vector index ,@extra-params)))))))
   (define hairy-data-vector-ref slow-hairy-data-vector-ref
     *data-vector-reffers* nil (progn))
   (define hairy-data-vector-set slow-hairy-data-vector-set
diff --git a/version.lisp-expr b/version.lisp-expr
index fb3aa19..450439b 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.4.108"
+"1.0.4.109"