From 3524fbb8a40407f3518627323864fe6d1adaf6aa Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Fri, 8 Mar 1996 22:27:09 +0000
Subject: [PATCH] Added code to deal with primitives called with the wrong
 number of arguments.  A warning is issued.  The primitive is called with
 %internal-apply to ensure correct behaviour at run time.

Note: Perhaps this processing should go later, in case something
clever finds more primitives to substitute.  For non open-coded
primitives, this can be done as late a compat.  The problem with this
is that after CPS conversion, it is impossible to convert an open
coded primitive into a subproblem call.  One way to solve this is not
open code NO primitives, only cookie calls.
---
 v8/src/compiler/midend/applicat.scm | 66 ++++++++++++++++++-----------
 1 file changed, 42 insertions(+), 24 deletions(-)

diff --git a/v8/src/compiler/midend/applicat.scm b/v8/src/compiler/midend/applicat.scm
index 5fc9727b6..a5b8f0381 100644
--- a/v8/src/compiler/midend/applicat.scm
+++ b/v8/src/compiler/midend/applicat.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: applicat.scm,v 1.5 1995/04/17 14:39:18 adams Exp $
+$Id: applicat.scm,v 1.6 1996/03/08 22:27:09 adams Exp $
 
-Copyright (c) 1994 Massachusetts Institute of Technology
+Copyright (c) 1994-1996 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -45,11 +45,10 @@ MIT in each case. |#
     (call-with-values
 	(lambda () (%matchup (cdr bindings) '(handler env) '(cdr form)))
       (lambda (names code)
-	`(DEFINE ,proc-name
+	`(DEFINE (,proc-name ENV FORM)
 	   (LET ((HANDLER (LAMBDA ,(cons (car bindings) names) ,@body)))
-	     (NAMED-LAMBDA (,proc-name ENV FORM)
-	       (APPLICAT/REMEMBER ,code
-				  FORM))))))))
+	     (APPLICAT/REMEMBER ,code
+				FORM)))))))
 
 (define-applicator LOOKUP (env name)
   env					; ignored
@@ -80,28 +79,47 @@ MIT in each case. |#
        ,(applicat/expr env alt)))
 
 (define-applicator CALL (env rator cont #!rest rands)
-  (define (default)
+  (define (direct-call)
+    `(CALL ,(applicat/expr env rator)
+	   ,(applicat/expr env cont)
+	   ,@(applicat/expr* env rands)))
+  (define (checked-call)
     `(CALL (QUOTE ,%internal-apply)
 	   ,(applicat/expr env cont)
 	   (QUOTE ,(length rands))
 	   ,(applicat/expr env rator)
 	   ,@(applicat/expr* env rands)))
+  (define (primitive-call)
+    `(CALL (QUOTE ,%primitive-apply)
+	   ,(applicat/expr env cont)
+	   (QUOTE ,(length rands))
+	   ,(applicat/expr env rator)
+	   ,@(applicat/expr* env rands)))
+  (define (check-primitive operator method-if-good)
+    (let ((arity (primitive-procedure-arity operator)))
+      (if (or (eqv? arity (length rands))
+	      (eqv? arity -1))		; VECTOR & %RECORD
+	  (method-if-good)
+	  (begin
+	    (warn
+	     (string-append
+	      ;;"Primitive "
+	      (string-upcase (symbol-name (primitive-procedure-name operator)))
+	      " called with wrong number of arguments")
+	     (form->source-irritant form))
+	    (checked-call)))))
   (cond ((QUOTE/? rator)
-	 (cond ((and (known-operator? (cadr rator))
-		     (not (and (primitive-procedure? (cadr rator))
-			       (memq (primitive-procedure-name (cadr rator))
-				     compiler:primitives-with-no-open-coding))))
-		`(CALL ,(applicat/expr env rator)
-		       ,(applicat/expr env cont)
-		       ,@(applicat/expr* env rands)))
-	       ((primitive-procedure? (cadr rator))
-		`(CALL (QUOTE ,%primitive-apply)
-		       ,(applicat/expr env cont)
-		       (QUOTE ,(length rands))
-		       ,(applicat/expr env rator)
-		       ,@(applicat/expr* env rands)))
-	       (else
-		(default))))
+	 (let* ((operator   (quote/text rator))
+		(known?     (known-operator? operator))
+		(primitive? (primitive-procedure? operator)))
+	   (cond ((and known? primitive?)
+		  (if (memq (primitive-procedure-name operator)
+			    compiler:primitives-with-no-open-coding)
+		      (primitive-call)
+		      (check-primitive operator direct-call)))
+		 (known?      (direct-call))
+		 (primitive?  (check-primitive operator primitive-call))
+		 (else        (checked-call)))))
 	((LOOKUP/? rator)
 	 (let ((place (assq (cadr rator) env)))
 	   (if (or (not place) (not (cadr place)))
@@ -124,7 +142,7 @@ MIT in each case. |#
 		  ,@(applicat/expr* env rands))))
 	(else
 	 (default))))
-
+
 (define-applicator LET (env bindings body)
   `(LET ,(map (lambda (binding)
 		(list (car binding)
@@ -138,7 +156,7 @@ MIT in each case. |#
 		       (LAMBDA/?  value))))
 	     bindings)
        body)))
-
+
 (define-applicator LETREC (env bindings body)
   (let ((env*  (map* env
 		     (lambda (binding)
-- 
2.25.1