From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 16 Apr 2018 02:16:56 +0000 (-0700)
Subject: Implement scode-procedure-arity so that it can be run during cold load.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~125
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=817cbe3dca39a1452a23e06620f73ebd5583c6d5;p=mit-scheme.git

Implement scode-procedure-arity so that it can be run during cold load.

The lack of this prevented the cold load from running correctly when using
interpreted code, since it depended on a complex scode lambda implementation
that was loaded much later.
---

diff --git a/src/runtime/procedure.scm b/src/runtime/procedure.scm
index 41536af7e..72ced5cd8 100644
--- a/src/runtime/procedure.scm
+++ b/src/runtime/procedure.scm
@@ -91,47 +91,57 @@ USA.
       object))
 
 (define (procedure-arity procedure)
-  (let loop ((p procedure) (e 0))
+  (let loop ((p procedure))
     (cond ((%primitive-procedure? p)
 	   (let ((arity ((ucode-primitive primitive-procedure-arity) p)))
-	     (cond ((fix:< arity 0)
-		    (cons 0 #f))
-		   ((fix:<= e arity)
-		    (let ((arity (fix:- arity e)))
-		      (cons arity arity)))
-		   (else
-		    (error "Illegal arity for entity:" procedure)))))
+	     (if (fix:< arity 0)
+		 (cons 0 #f)
+		 (cons arity arity))))
 	  ((%compound-procedure? p)
-	   (scode-lambda-components (%compound-procedure-lambda p)
-	     (lambda (name required optional rest auxiliary decl body)
-	       name auxiliary decl body
-	       (let ((r (fix:- (length required) e)))
-		 (cond (rest
-			(cons (fix:max 0 r) #f))
-		       ((fix:>= r 0)
-			(cons r (fix:+ r (length optional))))
-		       (else
-			(error "Illegal arity for entity:" procedure)))))))
+	   (scode-lambda-arity (%compound-procedure-lambda p)))
 	  ((%compiled-procedure? p)
-	   (let ((info (compiled-entry-kind p))
-		 (e+1 (fix:+ e 1)))
+	   (let ((info (compiled-entry-kind p)))
 	     ;; max = (-1)^tail? * (1 + req + opt + tail?)
 	     ;; min = (1 + req)
-	     (let ((min (fix:- (system-hunk3-cxr1 info) e+1))
-		   (max (system-hunk3-cxr2 info)))
-	       (cond ((fix:< max 0)
-		      (cons (if (fix:< min 0) 0 min) #f))
-		     ((fix:>= min 0)
-		      (cons min (fix:- max e+1)))
-		     (else
-		      (error "Illegal arity for entity:" procedure))))))
+	     (cons (fix:- (system-hunk3-cxr1 info) 1)
+		   (let ((max (system-hunk3-cxr2 info)))
+		     (and (fix:>= max 0)
+			  (fix:- max 1))))))
 	  ((%entity? p)
 	   (if (%entity-is-apply-hook? p)
-	       (loop (apply-hook-procedure p) e)
-	       (loop (entity-procedure p) (fix:+ e 1))))
+	       (loop (apply-hook-procedure p))
+	       (let ((arity (loop (entity-procedure p))))
+		 (let ((min (car arity))
+		       (max (cdr arity)))
+		   (cond ((not max)
+			  (cons (if (fix:> min 0) (fix:- min 1) 0)
+				#f))
+			 ((fix:> max 0)
+			  (cons (fix:- min 1)
+				(fix:- max 1)))
+			 (else
+			  (error "Illegal arity for entity:"
+				 (entity-procedure p))))))))
 	  (else
-	   (error:wrong-type-argument procedure "procedure"
-				      'procedure-arity)))))
+	   (error:not-a procedure? procedure 'procedure-arity)))))
+
+;; Here because it's needed during cold load for interpreted code.
+(define (scode-lambda-arity l)
+  (cond ((object-type? (ucode-type lambda) l)
+	 (let ((min (fix:- (vector-length (system-pair-cdr l)) 1)))
+	   (cons min min)))
+	((object-type? (ucode-type extended-lambda) l)
+	 (let ((arity (object-datum (system-hunk3-cxr2 l))))
+	   (let ((n-required (fix:and (fix:lsh arity -8) #xff))
+		 (n-optional (fix:and arity #xff)))
+	     (cond ((fix:= 1 (fix:lsh arity -16))
+		    (cons n-required #f))
+		   ((fix:> n-optional 0)
+		    (cons n-required (fix:+ n-required n-optional)))
+		   (else
+		    (cons n-required n-required))))))
+	(else
+	 (error:not-a scode-lambda? l 'scode-lambda-arity))))
 
 (define (procedure-arity-valid? procedure arity)
   (procedure-arity<= arity (procedure-arity procedure)))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 16dc97008..3cd936ae7 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1825,6 +1825,7 @@ USA.
 	  procedure-lambda
 	  procedure-of-arity?
 	  procedure?
+	  scode-lambda-arity
 	  set-apply-hook-extra!
 	  set-apply-hook-procedure!
 	  set-entity-extra!