From 7da75bdcdb935a4fb72a05482b4b54cebd750d84 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 8 Jul 2019 15:35:03 -0400 Subject: [PATCH] Add procedure-arity-intersection. --- src/runtime/procedure.scm | 9 +++++++++ src/runtime/runtime.pkg | 1 + 2 files changed, 10 insertions(+) diff --git a/src/runtime/procedure.scm b/src/runtime/procedure.scm index a4c59a1ff..9482fdbfd 100644 --- a/src/runtime/procedure.scm +++ b/src/runtime/procedure.scm @@ -220,6 +220,15 @@ USA. (fix:<= (procedure-arity-max arity1) (procedure-arity-max arity2)))))) +(define (procedure-arity-intersection a1 a2) + (make-procedure-arity (fix:max (procedure-arity-min a1) + (procedure-arity-min a2)) + (let ((m1 (procedure-arity-max a1)) + (m2 (procedure-arity-max a2))) + (if m1 + (if m2 (fix:min m1 m2) m1) + m2)))) + (define-integrable (simple-arity? object) (index-fixnum? object)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index acb35ec28..714d247a5 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1932,6 +1932,7 @@ USA. primitive-procedure-name primitive-procedure? procedure-arity + procedure-arity-intersection procedure-arity-max procedure-arity-min procedure-arity-valid? -- 2.25.1