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 41536af7eed50c05b765f13dc76511cf7760d34b..72ced5cd878627d5be0a6ce0181bcfbd79322ecb 100644 (file)
--- a/src/runtime/procedure.scm
+++ b/src/runtime/procedure.scm
@@ -91,47 +91,57 @@ USA.
       object))
 \f
 (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 16dc970081ce5b626256969150c2e64a8d9eafb1..3cd936ae7de01145b8b61ad823127ef031c17285 100644 (file)
--- 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!