diff --git a/LOG b/LOG
index cb9544abca..8a40deae00 100644
--- a/LOG
+++ b/LOG
@@ -335,3 +335,13 @@
     BUILDING, install/* (removed), wininstall/* (new)
 - updated zlib to version 1.2.11
     configure
+- added procedure-arity-mask to report the allowed argument counts of
+  a compiled function.  On a procedure from interpret or from one of
+  the trace procedures or syntactic forms, procedure-arity-mask
+  may report counts that are not actually allowed by the source
+  procedure.
+     cmacros.ss, compile.ss, cpnanopass.ss, mkheader.ss, primdata.ss,
+     prims.ss, strip.ss,
+     fasl.c, gc.c, globals.h, prim.c, prim5.c, scheme.c, schsig.c,
+     misc.ms, root-experr*,
+     objects.stex
diff --git a/c/fasl.c b/c/fasl.c
index fcee4e5a7f..ccc11c46bd 100644
--- a/c/fasl.c
+++ b/c/fasl.c
@@ -97,6 +97,7 @@
  *                 <uptr free>       # number of free variables
  *                 <uptr n>          # length in bytes of code
  *                 <fasl name>
+ *                 <fasl arity-mask> # two's complement encoding of accepted argument counts
  *                 <fasl info>       # inspector info
  *                 <fasl pinfo*>     # profiling info
  *                 <byte code1>...<byte coden>
@@ -839,6 +840,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
             faslin(tc, &name, t, pstrbuf, f);
             if (Sstringp(name)) name = SYMNAME(S_intern_sc(&STRIT(name, 0), Sstring_length(name), name));
             CODENAME(co) = name;
+            faslin(tc, &CODEARITYMASK(co), t, pstrbuf, f);
             faslin(tc, &CODEINFO(co), t, pstrbuf, f);
             faslin(tc, &CODEPINFOS(co), t, pstrbuf, f);
             bytesin((octet *)&CODEIT(co, 0), n, f);
diff --git a/c/gc.c b/c/gc.c
index a735215ded..c7dbd759de 100644
--- a/c/gc.c
+++ b/c/gc.c
@@ -1602,6 +1602,7 @@ static void sweep_code_object(tc, co) ptr tc, co; {
 #endif
 
     relocate(&CODENAME(co))
+    relocate(&CODEARITYMASK(co))
     relocate(&CODEINFO(co))
     relocate(&CODEPINFOS(co))
 
diff --git a/c/globals.h b/c/globals.h
index c4549b0ada..8815f80e96 100644
--- a/c/globals.h
+++ b/c/globals.h
@@ -107,7 +107,6 @@ EXTERN struct {
     ptr nuate_id;
     ptr null_continuation_id;
     ptr collect_request_pending_id;
-    ptr dummy_continuation_code;
 
   /* gc.c */
     ptr guardians[static_generation+1];
diff --git a/c/prim.c b/c/prim.c
index 518cb7dbd5..a81d293608 100644
--- a/c/prim.c
+++ b/c/prim.c
@@ -211,6 +211,7 @@ static void s_instantiate_code_object() {
 
     CODERELOC(new) = newreloc;
     CODENAME(new) = CODENAME(old);
+    CODEARITYMASK(new) = CODEARITYMASK(old);
     CODEFREE(new) = CODEFREE(old);
     CODEINFO(new) = CODEINFO(old);
     CODEPINFOS(new) = CODEPINFOS(old);
diff --git a/c/prim5.c b/c/prim5.c
index 0818974a26..5d7582ea3a 100644
--- a/c/prim5.c
+++ b/c/prim5.c
@@ -57,7 +57,7 @@ static void s_set_code_long2 PROTO((ptr p, ptr n, ptr h, ptr l));
 static ptr s_set_code_quad PROTO((ptr p, ptr n, ptr x));
 static ptr s_set_reloc PROTO((ptr p, ptr n, ptr e));
 static ptr s_flush_instruction_cache PROTO((void));
-static ptr s_make_code PROTO((iptr flags, iptr free, ptr name, iptr n, ptr info, ptr pinfos));
+static ptr s_make_code PROTO((iptr flags, iptr free, ptr name, ptr arity_mark, iptr n, ptr info, ptr pinfos));
 static ptr s_make_reloc_table PROTO((ptr codeobj, ptr n));
 static ptr s_make_closure PROTO((ptr offset, ptr codeobj));
 static ptr s_fxrandom PROTO((ptr n));
@@ -847,8 +847,8 @@ static ptr s_flush_instruction_cache() {
     return Svoid;
 }
 
-static ptr s_make_code(flags, free, name, n, info, pinfos)
-                       iptr flags, free, n; ptr name, info, pinfos; {
+static ptr s_make_code(flags, free, name, arity_mark, n, info, pinfos)
+                       iptr flags, free, n; ptr name, arity_mark, info, pinfos; {
     ptr co;
 
     tc_mutex_acquire()
@@ -856,6 +856,7 @@ static ptr s_make_code(flags, free, name, n, info, pinfos)
     tc_mutex_release()
     CODEFREE(co) = free;
     CODENAME(co) = name;
+    CODEARITYMASK(co) = arity_mark;
     CODEINFO(co) = info;
     CODEPINFOS(co) = pinfos;
     return co;
diff --git a/c/scheme.c b/c/scheme.c
index 15084b3ca7..fcc58abb00 100644
--- a/c/scheme.c
+++ b/c/scheme.c
@@ -98,6 +98,7 @@ static void main_init() {
     p = S_code(tc, type_code, size_rp_header);
     CODERELOC(p) = S_relocation_table(0);
     CODENAME(p) = Sfalse;
+    CODEARITYMASK(p) = FIX(0);
     CODEFREE(p) = 0;
     CODEINFO(p) = Sfalse;
     CODEPINFOS(p) = Snil;
diff --git a/c/schsig.c b/c/schsig.c
index fbebe09ae3..2c2f13728e 100644
--- a/c/schsig.c
+++ b/c/schsig.c
@@ -673,13 +673,11 @@ void S_schsig_init() {
         p = S_code(get_thread_context(), type_code | (code_flag_continuation << code_flags_offset), 0);
         CODERELOC(p) = S_relocation_table(0);
         CODENAME(p) = Sfalse;
+        CODEARITYMASK(p) = FIX(0);
         CODEFREE(p) = 0;
         CODEINFO(p) = Sfalse;
         CODEPINFOS(p) = Snil;
 
-        S_protect(&S_G.dummy_continuation_code);
-        S_G.dummy_continuation_code = p;
-
         S_set_symbol_value(S_G.null_continuation_id,
             S_mkcontinuation(space_new,
                            0,
diff --git a/csug/objects.stex b/csug/objects.stex
index 7b543a8ce2..b9f3c0baa7 100644
--- a/csug/objects.stex
+++ b/csug/objects.stex
@@ -3161,3 +3161,34 @@ rtd ;=> #<record type frob>
 \endschemedisplay
 
 
+\section{Procedures}
+
+%----------------------------------------------------------------------------
+\noskipentryheader
+\formdef{procedure-arity-mask}{\categoryprocedure}{(procedure-arity-mask \var{proc})}
+\returns an exact integer bitmask identifying the accepted argument counts of \var{proc}
+\listlibraries
+\endentryheader
+
+\noindent
+The bitmask is represented as two's complement number with the bit
+at each index \var{n} set if and only if \var{proc} accepts \var{n}
+arguments.
+
+The two's complement encoding implies that if \var{proc} accepts
+\var{n} or more arguments, the encoding is a negative number,
+since all the bits from \var{n} and up are set. For example, if
+\var{proc} accepts any number of arguments, the two's complement
+encoding of all bits set is \scheme{-1}.
+
+\schemedisplay
+(procedure-arity-mask (lambda () 'none)) ;=> 1
+(procedure-arity-mask car) ;=> 2
+(procedure-arity-mask (case-lambda [() 'none] [(x) x])) ;=> 3
+(procedure-arity-mask (lambda x x)) ;=> -1
+(procedure-arity-mask (case-lambda [() 'none] [(x y . z) x])) ;=> -3
+(procedure-arity-mask (case-lambda)) ;=> 0
+(logbit? 1 (procedure-arity-mask pair?)) ;=> #t
+(logbit? 2 (procedure-arity-mask pair?)) ;=> #f
+(logbit? 2 (procedure-arity-mask cons)) ;=> #t
+\endschemedisplay
diff --git a/mats/misc.ms b/mats/misc.ms
index cce1af9e1d..25fb70c79d 100644
--- a/mats/misc.ms
+++ b/mats/misc.ms
@@ -4889,3 +4889,41 @@
                         (fx+ success 1)
                         success)))))))
 )
+
+(mat procedure-arity-mask
+  (equal? (procedure-arity-mask (lambda () #f)) 1)
+  (equal? (procedure-arity-mask (lambda (x) x)) 2)
+  (equal? (procedure-arity-mask (lambda (x y z w) x)) 16)
+  (or (eq? (current-eval) interpret)
+      (equal? (procedure-arity-mask (lambda (x y z w a b c d e f g h i j) x)) (ash 1 14)))
+  (or (eq? (current-eval) interpret)
+      (and
+        (equal? (procedure-arity-mask (case-lambda)) 0)
+        (equal? (procedure-arity-mask (case-lambda [(x) x] [(x y) y])) 6)
+        (equal? (procedure-arity-mask (case-lambda [() x] [(x . y) y])) -1)
+        (equal? (procedure-arity-mask (case-lambda [() x] [(x y . z) y])) (bitwise-not 2))
+        (equal? (procedure-arity-mask (case-lambda [(x y . z) y] [() x])) (bitwise-not 2))
+        (equal? (procedure-arity-mask (case-lambda [(x) x] [(x y) y] [(x y z) z])) 14)))
+  (equal? (procedure-arity-mask list) -1)
+  (equal? (procedure-arity-mask cons) 4)
+  (equal? (procedure-arity-mask list*) (bitwise-not 1))
+
+  (equal? (procedure-arity-mask +) -1)
+  (equal? (procedure-arity-mask -) -2)
+  (equal? (procedure-arity-mask max) -2)
+
+  (equal? (call/cc procedure-arity-mask) -1)
+  (equal? (call/1cc procedure-arity-mask) -1)
+  (equal? (procedure-arity-mask #%$null-continuation) 0)
+  (equal?
+    (parameterize ([enable-cp0 #t]) (compile '(procedure-arity-mask
+                                                (case-lambda [a a] [(b) b]))))
+    -1)
+  (equal?
+    (parameterize ([enable-cp0 #f]) (compile '(procedure-arity-mask
+                                                (case-lambda [a a] [(b) b]))))
+    -1)
+
+  (error? ; invalid argument
+    (procedure-arity-mask 17))
+  )
diff --git a/mats/root-experr-compile-0-f-f-f b/mats/root-experr-compile-0-f-f-f
index f7f9dc3b5b..3a6075d336 100644
--- a/mats/root-experr-compile-0-f-f-f
+++ b/mats/root-experr-compile-0-f-f-f
@@ -3732,6 +3732,7 @@ misc.mo:Expected error in mat virtual-registers: "set-virtual-register!: invalid
 misc.mo:Expected error in mat virtual-registers: "set-virtual-register!: invalid index 0.0".
 misc.mo:Expected error in mat pariah: "invalid syntax (pariah)".
 misc.mo:Expected error in mat pariah: "invalid syntax (pariah . 17)".
+misc.mo:Expected error in mat procedure-arity-mask: "procedure-arity-mask: 17 is not a procedure".
 cp0.mo:Expected error in mat cp0-regression: "attempt to reference undefined variable x".
 cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)".
 cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (cont0 (quote x))".
diff --git a/mats/root-experr-compile-2-f-f-f b/mats/root-experr-compile-2-f-f-f
index beb1c93d3f..6cf94a74a7 100644
--- a/mats/root-experr-compile-2-f-f-f
+++ b/mats/root-experr-compile-2-f-f-f
@@ -3730,6 +3730,7 @@ misc.mo:Expected error in mat virtual-registers: "set-virtual-register!: invalid
 misc.mo:Expected error in mat virtual-registers: "set-virtual-register!: invalid index 0.0".
 misc.mo:Expected error in mat pariah: "invalid syntax (pariah)".
 misc.mo:Expected error in mat pariah: "invalid syntax (pariah . 17)".
+misc.mo:Expected error in mat procedure-arity-mask: "procedure-arity-mask: 17 is not a procedure".
 cp0.mo:Expected error in mat cp0-regression: "attempt to reference undefined variable x".
 cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)".
 cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (cont0 (quote x))".
diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex
index 17c84a44b5..4ee3d21808 100644
--- a/release_notes/release_notes.stex
+++ b/release_notes/release_notes.stex
@@ -58,6 +58,16 @@ Online versions of both books can be found at
 %-----------------------------------------------------------------------------
 \section{Functionality Changes}\label{section:functionality}
 
+\subsection{\protect\scheme{procedure-arity-mask} (9.4.1)}
+
+The new primitive procedure \scheme{procedure-arity-mask} takes a
+procedure \var{p} and returns a two's complement bitmask representing
+the argument counts accepted by \var{p}.
+For example, the arity mask for a two-argument procedure such as
+\var{cons} is $4$ (only bit two set),
+while the arity mask for a procedure that accepts one or more arguments,
+such as \var{list*}, is $-2$ (all but bit 0 set).
+
 \subsection{High-precision clock time in Windows 8 and up (9.4.1)}
 
 When running on Windows 8 and up, Chez Scheme uses the high-precision
diff --git a/s/cmacros.ss b/s/cmacros.ss
index 57bb2b13cb..7a0e700fff 100644
--- a/s/cmacros.ss
+++ b/s/cmacros.ss
@@ -1208,6 +1208,7 @@
    [iptr length]
    [ptr reloc]
    [ptr name]
+   [ptr arity-mask]
    [iptr closure-length]
    [ptr info]
    [ptr pinfo*]
diff --git a/s/compile.ss b/s/compile.ss
index 7050af26c4..ad3805a2de 100644
--- a/s/compile.ss
+++ b/s/compile.ss
@@ -106,9 +106,9 @@
              (let ([p ($make-closure (constant code-data-disp) cp)])
                (set-$c-func-closure! func p)
                p)))]
-      [(code) (func subtype free name size code-list info pinfo*)
+      [(code) (func subtype free name arity-mask size code-list info pinfo*)
        (or ($c-func-code-object func)
-           (let ([p ($make-code-object subtype free name size info pinfo*)])
+           (let ([p ($make-code-object subtype free name arity-mask size info pinfo*)])
              (set-$c-func-code-object! func p)
              (let mkc0 ([c* code-list]
                         [a (constant code-data-disp)]
@@ -240,8 +240,9 @@
           ($fasl-bld-graph x t a?
             (lambda (x t a?)
               (record-case x
-                [(code) (func subtype free name size code-list info pinfo*)
+                [(code) (func subtype free name arity-mask size code-list info pinfo*)
                  ($fasl-enter name t a?)
+                 ($fasl-enter arity-mask t a?)
                  ($fasl-enter info t a?)
                  ($fasl-enter pinfo* t a?)
                  (for-each
@@ -275,12 +276,13 @@
 
 (define (c-faslcode x p t a?)
    (record-case x
-      [(code) (func subtype free name size code-list info pinfo*)
+      [(code) (func subtype free name arity-mask size code-list info pinfo*)
        (put-u8 p (constant fasl-type-code))
        (put-u8 p subtype)
        (put-uptr p free)
        (put-uptr p size)
        ($fasl-out name p t a?)
+       ($fasl-out arity-mask p t a?)
        ($fasl-out info p t a?)
        ($fasl-out pinfo* p t a?)
        (let prf0 ([c* code-list]
@@ -1354,13 +1356,14 @@
           (build-required-library-list node* lib*))))))
 
 (set! $c-make-code
-   (lambda (func subtype free name size code-list info pinfo*)
+   (lambda (func subtype free name arity-mask size code-list info pinfo*)
       (let ([code `(code ,func
                          ,subtype
                          ,free
                          ,(if (symbol? name)
                               (symbol->string name)
                               (and (string? name) name))
+                         ,arity-mask
                          ,size
                          ,code-list
                          ,info
diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss
index e0e4354f7c..6df72dbd07 100644
--- a/s/cpnanopass.ss
+++ b/s/cpnanopass.ss
@@ -4852,6 +4852,7 @@
           (inline-accessor binary-port-output-buffer port-obuffer-disp)
           (inline-accessor textual-port-output-buffer port-obuffer-disp)
           (inline-accessor $code-name code-name-disp)
+          (inline-accessor $code-arity-mask code-arity-mask-disp)
           (inline-accessor $code-info code-info-disp)
           (inline-accessor $code-pinfo* code-pinfo*-disp)
           (inline-accessor $continuation-link continuation-link-disp)
@@ -13626,7 +13627,7 @@
             (lambda (funcrel)
               (let* ([l (cadr funcrel)] [code ($c-func-code-record (local-label-func l))])
                 (record-case code
-                  [(code) (func subtype free name size code-list info)
+                  [(code) (func subtype free name arity-mask size code-list info)
                    (set-car!
                      funcrel
                      (let ([offset (local-label-offset l)])
@@ -13728,6 +13729,7 @@
                (info-lambda-flags info)
                (length (info-lambda-fv* info))
                (info-lambda-name info)
+               (interface*->mask (info-lambda-interface* info))
                code-size
                code*
                (cond
@@ -13815,6 +13817,15 @@
            (let ([ls (cons* e1 e2 ...)])
              (if aop (cons asm ls) ls))]))
 
+      (define interface*->mask
+        (lambda (i*)
+          (fold-left (lambda (mask i)
+                       (logor mask
+                         (if (< i 0)
+                             (- (ash 1 (- -1 i)))
+                             (ash 1 i))))
+            0 i*)))
+
       (architecture assembler)
 
       (import asm-module))
diff --git a/s/mkheader.ss b/s/mkheader.ss
index 0a45118507..e5d7a18fdc 100644
--- a/s/mkheader.ss
+++ b/s/mkheader.ss
@@ -860,6 +860,7 @@
         (defref CODELEN code length)
         (defref CODERELOC code reloc)
         (defref CODENAME code name)
+        (defref CODEARITYMASK code arity-mask)
         (defref CODEFREE code closure-length)
         (defref CODEINFO code info)
         (defref CODEPINFOS code pinfo*)
diff --git a/s/primdata.ss b/s/primdata.ss
index eb863e4ffa..574959d888 100644
--- a/s/primdata.ss
+++ b/s/primdata.ss
@@ -1477,6 +1477,7 @@
   (pretty-format [sig [(symbol) -> (ptr)] [(symbol sub-ptr) -> (void)]] [flags])
   (pretty-print [sig [(ptr) (ptr textual-output-port) -> (void)]] [flags true])
   (printf [sig [(string sub-ptr ...) -> (void)]] [flags true])
+  (procedure-arity-mask [sig [(procedure) -> (sint)]] [flags mifoldable discard true])
   (process [sig [(string) -> (list)]] [flags])
   (profile-clear-database [sig [() -> (void)]] [flags true])
   (profile-clear [sig [() -> (void)]] [flags true])
@@ -1696,6 +1697,7 @@
   ($code? [flags])
   ($code-free-count [flags])
   ($code-info [flags])
+  ($code-arity-mask [flags])
   ($code-name [flags])
   ($code-pinfo* [flags])
   ($collect-rendezvous [flags])
diff --git a/s/prims.ss b/s/prims.ss
index edc30e5d63..91f11dbec5 100644
--- a/s/prims.ss
+++ b/s/prims.ss
@@ -202,6 +202,11 @@
       ($oops '$procedure-name "~s is not a procedure" x))
     ($code-name ($closure-code x))))
 
+(define-who procedure-arity-mask
+  (lambda (x)
+    (unless (procedure? x) ($oops who "~s is not a procedure" x))
+    ($code-arity-mask ($closure-code x))))
+
 (let ()
   (define-syntax frob-proc
     (syntax-rules ()
@@ -369,7 +374,7 @@
 
 (define-who $make-code-object
   (foreign-procedure "(cs)s_make_code"
-     (iptr iptr ptr iptr ptr ptr)
+     (iptr iptr ptr ptr iptr ptr ptr)
      ptr))
 
 (define-who $code-name
@@ -377,6 +382,11 @@
     (unless ($code? x) ($oops who "~s is not code" x))
     ($code-name x)))
 
+(define-who $code-arity-mask
+  (lambda (x)
+    (unless ($code? x) ($oops who "~s is not code" x))
+    ($code-arity-mask x)))
+
 (define-who $code-free-count
   (lambda (x)
     (unless ($code? x) ($oops who "~s is not code" x))
diff --git a/s/strip.ss b/s/strip.ss
index ecdae8c827..6080d0705b 100644
--- a/s/strip.ss
+++ b/s/strip.ss
@@ -35,7 +35,7 @@
     (large-integer sign vuptr)
     (eq-hashtable mutable? weak? minlen veclen vpfasl)
     (symbol-hashtable mutable? minlen equiv veclen vpfasl)
-    (code flags free name info pinfo* bytes m vreloc)
+    (code flags free name arity-mask info pinfo* bytes m vreloc)
     (atom ty uptr)
     (reloc type-etc code-offset item-offset fasl)
     (indirect g i)
@@ -244,6 +244,7 @@
                   [free (read-uptr p)]
                   [nbytes (read-uptr p)]
                   [name (read-fasl p g)]
+                  [arity-mask (read-fasl p g)]
                   [info (read-fasl p g)]
                   [pinfo* (read-fasl p g)]
                   [bytes (let ([bv (make-bytevector nbytes)])
@@ -260,7 +261,7 @@
                                   (loop
                                     (fx+ n (if (fxlogtest type-etc 1) 3 1))
                                     (cons (fasl-reloc type-etc code-offset item-offset (read-fasl p g)) rls)))))])
-             (fasl-code flags free name info pinfo* bytes m vreloc))]
+             (fasl-code flags free name arity-mask info pinfo* bytes m vreloc))]
           [(fasl-type-immediate fasl-type-entry fasl-type-library fasl-type-library-code)
            (fasl-atom ty (read-uptr p))]
           [(fasl-type-graph) (read-fasl p (make-vector (read-uptr p) #f))]
@@ -429,10 +430,11 @@
                    (build! (car pfasl) t)
                    (build! (cdr pfasl) t))
                  vpfasl)))]
-          [code (flags free name info pinfo* bytes m vreloc)
+          [code (flags free name arity-mask info pinfo* bytes m vreloc)
            (build-graph! x t
              (lambda ()
                (build! name t)
+               (build! arity-mask t)
                (unless strip-inspector-information? (build! info t))
                (unless strip-profile-information? (build! pinfo* t))
                (vector-for-each (lambda (reloc) (build! reloc t)) vreloc)))]
@@ -601,7 +603,7 @@
                    (write-fasl p t (car pfasl))
                    (write-fasl p t (cdr pfasl)))
                  vpfasl)))]
-          [code (flags free name info pinfo* bytes m vreloc)
+          [code (flags free name arity-mask info pinfo* bytes m vreloc)
            (write-graph p t x
              (lambda ()
                (write-byte p (constant fasl-type-code))
@@ -609,6 +611,7 @@
                (write-uptr p free)
                (write-uptr p (bytevector-length bytes))
                (write-fasl p t name)
+               (write-fasl p t arity-mask)
                (if strip-inspector-information?
                    (write-fasl p t (fasl-atom (constant fasl-type-immediate) (constant sfalse)))
                    (write-fasl p t info))
@@ -876,10 +879,11 @@
                                (vandmap (lambda (x y) (and (fasl=? (car x) (car y)) (fasl=? (cdr x) (cdr y))))
                                  (vector-sort keyval? vpfasl1)
                                  (vector-sort keyval? vpfasl2))))]
-                       [code (flags free name info pinfo* bytes m reloc)
+                       [code (flags free name arity-mask info pinfo* bytes m reloc)
                         (and (eqv? flags1 flags2)
                              (eqv? free1 free2)
                              (fasl=? name1 name2)
+                             (fasl=? arity-mask1 arity-mask2)
                              (fasl=? info1 info2)
                              (fasl=? pinfo*1 pinfo*2)
                              (bytevector=? bytes1 bytes2)