1.0.16.15: fix TRANSFORM-LIST-ITEM-SEEK for ADJOIN with constant list arg

[sbcl.git] / src / compiler / srctran.lisp

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 4309045..37c3a73 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -142,7 +142,22 @@
 
 (define-source-transform nth (n l) `(car (nthcdr ,n ,l)))
 
-(define-source-transform last (x) `(sb!impl::last1 ,x))
+(deftransform last ((list &optional n) (t &optional t))
+  (let ((c (constant-lvar-p n)))
+    (cond ((or (not n)
+               (and c (eql 1 (lvar-value n))))
+           '(%last1 list))
+          ((and c (eql 0 (lvar-value n)))
+           '(%last0 list))
+          (t
+           (let ((type (lvar-type n)))
+             (cond ((csubtypep type (specifier-type 'fixnum))
+                    '(%lastn/fixnum list n))
+                   ((csubtypep type (specifier-type 'bignum))
+                    '(%lastn/bignum list n))
+                   (t
+                    (give-up-ir1-transform "second argument type too vague"))))))))
+
 (define-source-transform gethash (&rest args)
   (case (length args)
    (2 `(sb!impl::gethash3 ,@args nil))
@@ -2825,7 +2840,7 @@
                          (ecase signedp
                              ((nil) (let ((mask (1- (ash 1 width))))
                                       `(integer ,mask ,mask)))
-                             (t `(signed-byte ,width))))))
+                             ((t) `(signed-byte ,width))))))
     (lambda (call)
       (let ((res (funcall fun call)))
         (when res
@@ -2840,7 +2855,7 @@
                            (ecase signedp
                              ((nil) (let ((mask (1- (ash 1 width))))
                                       `(integer ,mask ,mask)))
-                             (t `(signed-byte ,width))))))
+                             ((t) `(signed-byte ,width))))))
       (if (eq signedp nil)
           (logand-derive-type-aux res mask-type)))))
 
@@ -2862,7 +2877,7 @@
                                   '(eql 0)
                                   `(,(ecase signedp
                                        ((nil) 'unsigned-byte)
-                                       (t 'signed-byte))
+                                       ((t) 'signed-byte))
                                      ,width)))))
     (labels ((reoptimize-node (node name)
                (setf (node-derived-type node)