From e9fd2adc6d3d87ab1e8559b02c9b003f9870b176 Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Tue, 30 Jun 2015 05:16:28 +0300
Subject: [PATCH] Fix transitive arithmetic transforms.

NIL in (+ 1 x nil) was ignored.
---
 src/compiler/srctran.lisp | 27 ++++++++++++++++-----------
 tests/compiler.pure.lisp  |  7 +++++++
 2 files changed, 23 insertions(+), 11 deletions(-)

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 2af217f77..76ae2aadd 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -4258,13 +4258,14 @@
 ;;;; versions, and degenerate cases are flushed.
 
 ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
-(declaim (ftype (sfunction (symbol t list t) list) associate-args))
-(defun associate-args (fun first-arg more-args identity)
+(declaim (ftype (sfunction (symbol t list) list) associate-args))
+(defun associate-args (fun first-arg more-args)
+  (aver more-args)
   (let ((next (rest more-args))
         (arg (first more-args)))
     (if (null next)
-        `(,fun ,first-arg ,(if arg arg identity))
-        (associate-args fun `(,fun ,first-arg ,arg) next identity))))
+        `(,fun ,first-arg ,arg)
+        (associate-args fun `(,fun ,first-arg ,arg) next))))
 
 ;;; Reduce constants in ARGS list.
 (declaim (ftype (sfunction (symbol list symbol) list) reduce-constants))
@@ -4309,8 +4310,12 @@
     (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args))))
     (2 (values nil t))
     (t
-     (let ((reduced-args (reduce-constants fun args one-arg-result-type)))
-       (associate-args fun (first reduced-args) (rest reduced-args) identity)))))
+     (let* ((reduced-args (reduce-constants fun args one-arg-result-type))
+            (first (first reduced-args))
+            (rest (rest reduced-args)))
+       (if rest
+           (associate-args fun first rest)
+           first)))))
 
 (define-source-transform + (&rest args)
   (source-transform-transitive '+ args 0))
@@ -4332,10 +4337,10 @@
 ;;; Do source transformations for intransitive n-arg functions such as
 ;;; /. With one arg, we form the inverse. With two args we pass.
 ;;; Otherwise we associate into two-arg calls.
-(declaim (ftype (function (symbol symbol list t list &optional symbol)
+(declaim (ftype (function (symbol symbol list list &optional symbol)
                           (values list &optional (member nil t)))
                 source-transform-intransitive))
-(defun source-transform-intransitive (fun fun* args identity one-arg-prefixes
+(defun source-transform-intransitive (fun fun* args one-arg-prefixes
                                       &optional (one-arg-result-type 'number))
   (case (length args)
     ((0 2) (values nil t))
@@ -4343,12 +4348,12 @@
     (t
      (let ((reduced-args
              (reduce-constants fun* (rest args) one-arg-result-type)))
-       (associate-args fun (first args) reduced-args identity)))))
+       (associate-args fun (first args) reduced-args)))))
 
 (define-source-transform - (&rest args)
-  (source-transform-intransitive '- '+ args 0 '(%negate)))
+  (source-transform-intransitive '- '+ args '(%negate)))
 (define-source-transform / (&rest args)
-  (source-transform-intransitive '/ '* args 1 '(/ 1)))
+  (source-transform-intransitive '/ '* args '(/ 1)))
 
 ;;;; transforming APPLY
 
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index efd27eae3..bd7d2e9ce 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -5541,3 +5541,10 @@
            (coerce a (array-element-type (the (array (unsigned-byte 32)) x)))
            10
            (make-array 10 :element-type '(unsigned-byte 32)))))
+
+(with-test (:name :associate-args)
+  (assert-error
+   (funcall (compile nil `(lambda (x) (+ 1 x nil)))
+            2))
+  (assert-error
+   (funcall (compile nil `(lambda (x) (/ 1 x nil))) 4)))
-- 
2.11.4.GIT