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>=?)) + ; 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) 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)) + '(4 4 4 4 #f #t #f #t #f 10 -8 24 1/24 #f #t #f #t #f)) + )) (define (bug-105-test1)