From 0812c6e283d65920e48bd20535e4c418d770c0cc Mon Sep 17 00:00:00 2001
From: WillClinger <will@ccs.neu.edu>
Date: Sat, 1 Jul 2017 11:52:45 -0400
Subject: [PATCH] Added patch for bogus argcount errors reported by compiler
 (ticket #743).

---
 src/Compiler/common.imp.sch | 25 +++++++++++++++++++++++++
 src/Compiler/pass4p2.sch    | 20 ++++++++++++--------
 test/Lib/regression.sch     | 24 +++++++++++++++++++++++-
 3 files changed, 60 insertions(+), 9 deletions(-)

diff --git a/src/Compiler/common.imp.sch b/src/Compiler/common.imp.sch
index 8610cf53..37be22bf 100644
--- a/src/Compiler/common.imp.sch
+++ b/src/Compiler/common.imp.sch
@@ -354,6 +354,31 @@
 ;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+;;; The common-compiler-macros defined below are responsible for
+;;; rewriting many calls to integrable procedures that take a
+;;; variable number of arguments into a composition of calls
+;;; that take the standard number of arguments.  This is done
+;;; at a syntactic level, so it fails to rewrite things like
+;;; ((if #t + -) 1 2 3 4).  A later phase of the compiler turns
+;;; that into (+ 1 2 3 4), which looks like a call to a primop
+;;; with the wrong number of arguments.  To tell pass4 it should
+;;; generate a closed call instead of flagging that as an error,
+;;; the following table names all of the primops for which pass4
+;;; should generate a closed call if the number of arguments
+;;; looks wrong.
+;;;
+;;; FIXME: This is a tedious and error-prone way to fix the
+;;; problem reported by ticket #743.
+;;;
+;;; NOTE: fx+, fx-, and fx* are specified to accept exactly
+;;; two arguments.
+
+(define variable-arity-primops-that-allow-closed-calls
+  '(make-vector make-bytevector make-string make-ustring
+    = < > <= >=
+    + * - /
+    char=? char<? char>? char<=? char>=?))
+
 ; The list of compiler macros has been rewritten to avoid the
 ; use of quasiquote on large structures.  Larceny's quasiquote
 ; apparently takes quadratic time, so this rewrite improved
diff --git a/src/Compiler/pass4p2.sch b/src/Compiler/pass4p2.sch
index fa3d4e4c..595ac049 100644
--- a/src/Compiler/pass4p2.sch
+++ b/src/Compiler/pass4p2.sch
@@ -221,14 +221,18 @@
                           (gen! output $return)
                           'result)
                    (cg-move output frame regs 'result target)))
-        (if (negative? (entry.arity entry))
-            (cg-special output exp target regs frame env tail?)
-            (begin
-             (twobit-error "Wrong number of arguments to integrable procedure"
-                           (make-readable exp))
-             (cg-special output
-                         (make-call-to-TRAP p2error:wna)
-                         target regs frame env tail?))))))
+        (cond ((negative? (entry.arity entry))
+               (cg-special output exp target regs frame env tail?))
+              ((memq (variable.name (call.proc exp))
+                     variable-arity-primops-that-allow-closed-calls)
+               (cg-unknown-call output exp target regs frame env tail? #f))
+              (else
+               (twobit-error
+                "Wrong number of arguments to integrable procedure"
+                (make-readable exp))
+               (cg-special output
+                           (make-call-to-TRAP p2error:wna)
+                           target regs frame env tail?))))))
 
 (define (cg-integrable-call2 output entry args regs frame env)
   (let ((op (entry.op entry)))
diff --git a/test/Lib/regression.sch b/test/Lib/regression.sch
index f36984e3..41fdd47a 100644
--- a/test/Lib/regression.sch
+++ b/test/Lib/regression.sch
@@ -706,7 +706,29 @@
    (test "Ticket #800"                  ; Bug in v0.99 (ARM only)
          (fl<? +nan.0 1.0)
          #f)
-))
+
+   (test "Ticket #743"                  ; Bug in v0.99 and previous
+         (list
+          (vector-length     ((if #t make-vector) 4))
+          (bytevector-length ((if #t make-bytevector) 4))
+          (string-length     ((if #t make-string) 4))
+          (ustring-length    ((if #t make-ustring) 4))    ; FIXME
+          ((if #t =) 1 2 3 4)
+          ((if #t <) 1 2 3 4)
+          ((if #t >) 1 2 3 4)
+          ((if #t <=) 1 2 3 4)
+          ((if #t >=) 1 2 3 4)
+          ((if #t +) 1 2 3 4)
+          ((if #t -) 1 2 3 4)
+          ((if #t *) 1 2 3 4)
+          ((if #t /) 1 2 3 4)
+          ((if #t char=?) #\a #\b #\c #\d)
+          ((if #t char<?) #\a #\b #\c #\d)
+          ((if #t char>?) #\a #\b #\c #\d)
+          ((if #t char<=?) #\a #\b #\c #\d)
+          ((if #t char>=?) #\a #\b #\c #\d))
+         '(4 4 4 4 #f #t #f #t #f 10 -8 24 1/24 #f #t #f #t #f))
+   ))
 
 
 (define (bug-105-test1)