repair arity problems

Fix many incorrect arity declarations and actual arities in Racket CS,
and fix several incorrect arities in traditional Racket. Building
Racket CS now checks the information in "racket/src/cs/primitives"
against both Racket variants to make sure that they're all consistent.

Closes #2924
This commit is contained in:
Matthew Flatt 2019-11-23 15:00:29 -05:00
parent 91190bee63
commit cd048cb1d0
19 changed files with 167 additions and 97 deletions

View File

@ -56,6 +56,7 @@ cs:
$(MAKE) racket-so
cd rktio; $(MAKE)
$(MAKE) racketcs
$(MAKE) check-racketcs
$(MAKE) gracketcs
$(MAKE) starter
@ -466,6 +467,12 @@ macos-install-gracket:
rm -rf $(DESTDIR)"$(libpltdir)/Starter.app"
$(ICP) -r Starter.app $(DESTDIR)"$(libpltdir)/."
# ----------------------------------------
# Check
check-racketcs:
./racketcs $(srcdir)/../known.rkt $(srcdir)/..
# ----------------------------------------
# Reconfigure

View File

@ -43,7 +43,9 @@
bitwise-ior
bitwise-xor
bitwise-and
bitwise-not)
bitwise-not
fllog flatan
fxquotient)
[make-parameter chez:make-parameter]
[date-second chez:date-second]
[date-minute chez:date-minute]

View File

@ -3,17 +3,14 @@
racket/pretty
racket/match
racket/file
racket/fixnum
racket/flonum
racket/unsafe/ops
racket/extflonum
racket/include
"../schemify/schemify.rkt"
"../schemify/serialize.rkt"
"../schemify/known.rkt"
"../schemify/lift.rkt"
"../schemify/reinfer-name.rkt"
"../schemify/wrap.rkt")
"../schemify/wrap.rkt"
"known.rkt")
(define skip-export? #f)
(define for-cify? #f)
@ -100,40 +97,9 @@
(unless for-cify?
(lift l))
(define prim-knowns
(let ([knowns (hasheq)])
(define-syntax-rule (define-primitive-table id [prim known] ...)
(begin (set! knowns (hash-set knowns 'prim known)) ...))
(include "primitive/kernel.ss")
(include "primitive/unsafe.ss")
(include "primitive/flfxnum.ss")
(include "primitive/paramz.ss")
(include "primitive/extfl.ss")
(include "primitive/network.ss")
(include "primitive/futures.ss")
(include "primitive/place.ss")
(include "primitive/foreign.ss")
(include "primitive/linklet.ss")
(include "primitive/internal.ss")
knowns))
(define primitives
(let ([ns (make-base-namespace)])
(namespace-attach-module (current-namespace) 'racket/fixnum ns)
(namespace-require 'racket/fixnum ns)
(namespace-attach-module (current-namespace) 'racket/flonum ns)
(namespace-require 'racket/flonum ns)
(namespace-attach-module (current-namespace) 'racket/unsafe/ops ns)
(namespace-require 'racket/unsafe/ops ns)
(define primitives (make-hasheq))
(for ([s (in-list (namespace-mapped-symbols ns))])
(define v (namespace-variable-value s
#t
(lambda () #f)
ns))
(when v
(hash-set! primitives s v)))
primitives))
(define prim-knowns (get-prim-knowns))
(define primitives (get-primitives))
(check-known-values prim-knowns primitives)
;; Convert:
(define schemified-body

75
racket/src/cs/known.rkt Normal file
View File

@ -0,0 +1,75 @@
#lang racket/base
(require racket/include
racket/fixnum
racket/flonum
racket/unsafe/ops
racket/extflonum
"../schemify/known.rkt")
(provide get-prim-knowns
get-primitives
check-known-values)
(define (get-prim-knowns)
(let ([knowns (hasheq)])
(define-syntax-rule (define-primitive-table id [prim known] ...)
(begin (set! knowns (hash-set knowns 'prim known)) ...))
(include "primitive/kernel.ss")
(include "primitive/unsafe.ss")
(include "primitive/flfxnum.ss")
(include "primitive/paramz.ss")
(include "primitive/extfl.ss")
(include "primitive/network.ss")
(include "primitive/futures.ss")
(include "primitive/place.ss")
(include "primitive/foreign.ss")
(include "primitive/linklet.ss")
(include "primitive/internal.ss")
knowns))
(define (get-primitives)
(let ([ns (make-base-namespace)])
(namespace-attach-module (current-namespace) 'racket/fixnum ns)
(namespace-require 'racket/fixnum ns)
(namespace-attach-module (current-namespace) 'racket/flonum ns)
(namespace-require 'racket/flonum ns)
(namespace-attach-module (current-namespace) 'racket/unsafe/ops ns)
(namespace-require 'racket/unsafe/ops ns)
(define primitives (make-hasheq))
(for ([s (in-list (namespace-mapped-symbols ns))])
(define v (namespace-variable-value s
#t
(lambda () #f)
ns))
(when v
(hash-set! primitives s v)))
primitives))
;; Check known-value information
(define (check-known-values prim-knowns primitives)
(for ([(name val) (in-hash primitives)])
(define k (hash-ref prim-knowns name #f))
(when k
(when (known-procedure? k)
(unless (= (known-procedure-arity-mask k)
(procedure-arity-mask val))
(error 'convert
(string-append
"arity mask mismatch in \"primitive/...\"\n"
" primitive: ~s\n"
" specified: ~a\n"
" actual: ~a")
name
(known-procedure-arity-mask k)
(procedure-arity-mask val)))))))
(module+ main
(require racket/cmdline)
(command-line
#:args (dir)
(parameterize ([current-directory dir])
(define prim-knowns (get-prim-knowns))
(define primitives (get-primitives))
(check-known-values prim-knowns primitives))))

View File

@ -29,7 +29,7 @@
[arity-at-least-value (known-procedure 2)]
[arity-at-least? (known-procedure/pure/folding 2)]
[asin (known-procedure/folding 2)]
[assoc (known-procedure 4)]
[assoc (known-procedure 12)]
[assq (known-procedure/no-prompt 4)]
[assv (known-procedure/no-prompt 4)]
[atan (known-procedure/folding 6)]
@ -65,8 +65,8 @@
[bytes->string/utf-8 (known-procedure/no-prompt 30)]
[bytes-append (known-procedure/no-prompt -1)]
[bytes-close-converter (known-procedure/no-prompt 2)]
[bytes-convert (known-procedure/no-prompt 254)]
[bytes-convert-end (known-procedure/no-prompt 15)]
[bytes-convert (known-procedure/no-prompt 252)]
[bytes-convert-end (known-procedure/no-prompt 30)]
[bytes-converter? (known-procedure/pure/folding 2)]
[bytes-copy (known-procedure/no-prompt 2)]
[bytes-copy! (known-procedure/no-prompt 56)]
@ -75,9 +75,9 @@
[bytes-open-converter (known-procedure/no-prompt 4)]
[bytes-ref (known-procedure/has-unsafe 4 'unsafe-bytes-ref)]
[bytes-set! (known-procedure/has-unsafe 8 'unsafe-bytes-set!)]
[bytes-utf-8-index (known-procedure/no-prompt 28)]
[bytes-utf-8-index (known-procedure/no-prompt 60)]
[bytes-utf-8-length (known-procedure/no-prompt 30)]
[bytes-utf-8-ref (known-procedure/no-prompt 28)]
[bytes-utf-8-ref (known-procedure/no-prompt 60)]
[bytes<? (known-procedure/no-prompt -2)]
[bytes=? (known-procedure/no-prompt -2)]
[bytes>? (known-procedure/no-prompt -2)]
@ -245,9 +245,9 @@
[custodian-shut-down? (known-procedure/no-prompt 2)]
[custodian-shutdown-all (known-procedure 2)]
[custodian? (known-procedure/pure/folding 2)]
[custom-print-quotable-accessor (known-procedure/no-prompt 2)]
[custom-print-quotable-accessor (known-procedure/no-prompt 6)]
[custom-print-quotable? (known-procedure/no-prompt 2)]
[custom-write-accessor (known-procedure/no-prompt 2)]
[custom-write-accessor (known-procedure/no-prompt 6)]
[custom-write? (known-procedure/pure/folding 2)]
[date (known-constant)]
[date* (known-constant)]
@ -283,7 +283,7 @@
[environment-variables? (known-procedure/pure/folding 2)]
[eof (known-literal eof)]
[eof-object? (known-procedure/pure/folding 2)]
[ephemeron-value (known-procedure/no-prompt 6)]
[ephemeron-value (known-procedure/no-prompt 14)]
[ephemeron? (known-procedure/pure/folding 2)]
[eprintf (known-procedure -2)]
[eq-hash-code (known-procedure/no-prompt 2)]
@ -411,11 +411,11 @@
[hash-eqv? (known-procedure 2)]
[hash-for-each (known-procedure 12)]
[hash-iterate-first (known-procedure 2)]
[hash-iterate-key (known-procedure 4)]
[hash-iterate-key+value (known-procedure 4)]
[hash-iterate-key (known-procedure 12)]
[hash-iterate-key+value (known-procedure 12)]
[hash-iterate-next (known-procedure 4)]
[hash-iterate-pair (known-procedure 4)]
[hash-iterate-value (known-procedure 4)]
[hash-iterate-pair (known-procedure 12)]
[hash-iterate-value (known-procedure 12)]
[hash-keys-subset? (known-procedure 4)]
[hash-map (known-procedure 12)]
[hash-placeholder? (known-procedure/pure/folding 2)]
@ -484,7 +484,7 @@
[log-level-evt (known-procedure/no-prompt 2)]
[log-level? (known-procedure/no-prompt 12)]
[log-max-level (known-procedure/no-prompt 6)]
[log-message (known-procedure/no-prompt 112)]
[log-message (known-procedure/no-prompt 120)]
[log-receiver? (known-procedure/pure/folding 2)]
[logger-name (known-procedure/no-prompt 2)]
[logger? (known-procedure/pure/folding 2)]
@ -608,7 +608,7 @@
[plumber-flush-handle? (known-procedure/pure/folding 2)]
[plumber? (known-procedure/pure/folding 2)]
[poll-guard-evt (known-procedure 2)]
[port-closed-evt (known-procedure 3)]
[port-closed-evt (known-procedure 2)]
[port-closed? (known-procedure 2)]
[port-commit-peeked (known-procedure 24)]
[port-count-lines! (known-procedure 2)]
@ -694,10 +694,10 @@
[raise-mismatch-error (known-procedure -8)]
[raise-range-error (known-procedure 384)]
[raise-result-error (known-procedure -8)]
[raise-result-arity-error (known-procedure -16)]
[raise-result-arity-error (known-procedure -8)]
[raise-type-error (known-procedure -8)]
[raise-user-error (known-procedure -2)]
[random (known-procedure/no-prompt 7)]
[random (known-procedure/no-prompt 15)]
[random-seed (known-procedure/no-prompt 2)]
[rational? (known-procedure/pure/folding 2)]
[read-accept-bar-quote (known-procedure 3)]
@ -735,7 +735,7 @@
[regexp-match? (known-procedure 124)]
[regexp-max-lookbehind (known-procedure 2)]
[regexp-replace (known-procedure 24)]
[regexp-replace* (known-procedure 24)]
[regexp-replace* (known-procedure 120)]
[regexp? (known-procedure/pure/folding 2)]
[relative-path? (known-procedure/no-prompt 2)]
[remainder (known-procedure/folding 4)]
@ -786,7 +786,7 @@
[string->immutable-string (known-procedure/no-prompt 2)]
[string->keyword (known-procedure/no-prompt 2)]
[string->list (known-procedure/no-prompt 2)]
[string->number (known-procedure/no-prompt 30)]
[string->number (known-procedure/no-prompt 62)]
[string->path (known-procedure/no-prompt 2)]
[string->path-element (known-procedure/no-prompt 2)]
[string->symbol (known-procedure/no-prompt 2)]
@ -962,7 +962,7 @@
[will-execute (known-procedure 2)]
[will-executor? (known-procedure/pure/folding 2)]
[will-register (known-procedure 8)]
[will-try-execute (known-procedure 2)]
[will-try-execute (known-procedure 6)]
[with-input-from-file (known-procedure 12)]
[with-output-to-file (known-procedure 28)]
[wrap-evt (known-procedure 4)]
@ -976,6 +976,6 @@
[write-char (known-procedure 6)]
[write-special (known-procedure 6)]
[write-special-avail* (known-procedure 6)]
[write-special-evt (known-procedure 4)]
[write-special-evt (known-procedure 6)]
[write-string (known-procedure 30)]
[zero? (known-procedure/folding 2)])

View File

@ -64,8 +64,8 @@
[unsafe-fl>= (known-procedure/pure/folding-unsafe -2 'fl>=)]
[unsafe-flabs (known-procedure/pure/folding-unsafe 2 'flabs)]
[unsafe-flimag-part (known-procedure/pure/folding-unsafe 2 'flimag-part)]
[unsafe-flmax (known-procedure/pure/folding-unsafe 4 'flmax)]
[unsafe-flmin (known-procedure/pure/folding-unsafe 4 'flmin)]
[unsafe-flmax (known-procedure/pure/folding-unsafe -2 'flmax)]
[unsafe-flmin (known-procedure/pure/folding-unsafe -2 'flmin)]
[unsafe-flrandom (known-procedure/pure/folding-unsafe 2 'flrandom)]
[unsafe-flreal-part (known-procedure/pure/folding-unsafe 2 'flreal-part)]
[unsafe-flsqrt (known-procedure/pure/folding-unsafe 2 'flsqrt)]
@ -99,11 +99,11 @@
[unsafe-fxxor (known-procedure/pure/folding-unsafe -1 'fxxor)]
[unsafe-get-place-table (known-procedure 1)]
[unsafe-immutable-hash-iterate-first (known-procedure/pure 2)]
[unsafe-immutable-hash-iterate-key (known-procedure/pure 4)]
[unsafe-immutable-hash-iterate-key+value (known-procedure/pure 4)]
[unsafe-immutable-hash-iterate-key (known-procedure/pure 12)]
[unsafe-immutable-hash-iterate-key+value (known-procedure/pure 12)]
[unsafe-immutable-hash-iterate-next (known-procedure/pure 4)]
[unsafe-immutable-hash-iterate-pair (known-procedure/pure 4)]
[unsafe-immutable-hash-iterate-value (known-procedure/pure 4)]
[unsafe-immutable-hash-iterate-pair (known-procedure/pure 12)]
[unsafe-immutable-hash-iterate-value (known-procedure/pure 12)]
[unsafe-impersonate-procedure (known-procedure -4)]
[unsafe-impersonate-vector (known-procedure -4)]
[unsafe-in-atomic? (known-procedure 1)]
@ -118,11 +118,11 @@
[unsafe-mcar (known-procedure 2)]
[unsafe-mcdr (known-procedure 2)]
[unsafe-mutable-hash-iterate-first (known-procedure 2)]
[unsafe-mutable-hash-iterate-key (known-procedure 4)]
[unsafe-mutable-hash-iterate-key+value (known-procedure 4)]
[unsafe-mutable-hash-iterate-key (known-procedure 12)]
[unsafe-mutable-hash-iterate-key+value (known-procedure 12)]
[unsafe-mutable-hash-iterate-next (known-procedure 4)]
[unsafe-mutable-hash-iterate-pair (known-procedure 4)]
[unsafe-mutable-hash-iterate-value (known-procedure 4)]
[unsafe-mutable-hash-iterate-pair (known-procedure 12)]
[unsafe-mutable-hash-iterate-value (known-procedure 12)]
[unsafe-os-semaphore-post (known-procedure 2)]
[unsafe-os-semaphore-wait (known-procedure 2)]
[unsafe-os-thread-enabled? (known-procedure 1)]
@ -173,8 +173,8 @@
[unsafe-vector-ref (known-procedure 4)]
[unsafe-vector-set! (known-procedure 8)]
[unsafe-weak-hash-iterate-first (known-procedure 2)]
[unsafe-weak-hash-iterate-key (known-procedure 4)]
[unsafe-weak-hash-iterate-key+value (known-procedure 4)]
[unsafe-weak-hash-iterate-key (known-procedure 12)]
[unsafe-weak-hash-iterate-key+value (known-procedure 12)]
[unsafe-weak-hash-iterate-next (known-procedure 4)]
[unsafe-weak-hash-iterate-pair (known-procedure 4)]
[unsafe-weak-hash-iterate-value (known-procedure 4)])
[unsafe-weak-hash-iterate-pair (known-procedure 12)]
[unsafe-weak-hash-iterate-value (known-procedure 12)])

View File

@ -405,6 +405,8 @@
make-flrectangular
gcd
lcm
fllog flatan
fxquotient
random
random-seed

View File

@ -228,8 +228,12 @@
[(who what pos arg . args)
(do-raise-argument-error 'raise-argument-error "given" who what pos arg args)]))
(define (raise-result-error who what arg)
(do-raise-argument-error 'raise-result-error "result" who what #f arg #f))
(define raise-result-error
(case-lambda
[(who what arg)
(do-raise-argument-error 'raise-result-error "result" who what #f arg #f)]
[(who what pos arg . args)
(do-raise-argument-error 'raise-result-error "result" who what pos arg args)]))
(define (do-raise-type-error e-who tag who what pos arg args)
(unless (symbol? who)
@ -269,7 +273,7 @@
[(who what pos arg . args)
(do-raise-type-error 'raise-argument-error "given" who what pos arg args)]))
(define/who (raise-mismatch-error in-who what . more)
(define/who (raise-mismatch-error in-who what v . more)
(check who symbol? in-who)
(check who string? what)
(raise
@ -280,7 +284,7 @@
(symbol->string in-who)
": "
what
(let loop ([more more])
(let loop ([more (cons v more)])
(cond
[(null? more) '()]
[else

View File

@ -72,7 +72,7 @@
(unsafe-extfl= a b)
(unsafe-extfl> a b)
(unsafe-extfl>= a b)
(unsafe-extflabs a b)
(unsafe-extflabs a)
(unsafe-extflmax a b)
(unsafe-extflmin a b)
(unsafe-extflsqrt a)

View File

@ -828,10 +828,14 @@
(hash-iterate-next ht i)
(unsafe-intmap-iterate-next ht i)))
(define (unsafe-immutable-hash-iterate-key ht i)
(define unsafe-immutable-hash-iterate-key
(case-lambda
[(ht i)
(unsafe-immutable-hash-iterate-key ht i none)]
[(ht i bad-index-v)
(if (iterator-for-impersonator? i)
(hash-iterate-key ht i)
(unsafe-intmap-iterate-key ht i)))
(unsafe-intmap-iterate-key ht i))]))
(define unsafe-immutable-hash-iterate-value
(case-lambda

View File

@ -432,3 +432,8 @@
(cond
[(null? ms) n]
[else (loop (lcm n (car ms)) (cdr ms))]))]))
(define (fllog n) (#2%fllog n))
(define (flatan n) (#2%flatan n))
(define (fxquotient n d) (#2%fxquotient n d))

View File

@ -7,8 +7,12 @@
(check who exact-nonnegative-integer? :or-false span)
(values source line column position span)))
(define-values (prop:exn:srclocs exn:srclocs? exn:srclocs-accessor)
(define-values (prop:exn:srclocs exn:srclocs? exn:srclocs-accessor*)
(make-struct-type-property 'exn:srclocs
(lambda (v info)
(check 'guard-for-prop:exn:srclocs (procedure-arity-includes/c 1) v)
v)))
;; Constrain to a single argument, not itself exposed as an accessor:
(define (exn:srclocs-accessor a)
(exn:srclocs-accessor* a))

View File

@ -19,7 +19,7 @@
(define unsafe-fx+ (unsafe-primitive fx+))
(define unsafe-fx- (unsafe-primitive fx-))
(define unsafe-fx* (unsafe-primitive fx*))
(define unsafe-fxquotient (unsafe-primitive fxquotient))
(define (unsafe-fxquotient n d) (#3%fxquotient n d))
(define unsafe-fxremainder (unsafe-primitive fxremainder))
(define unsafe-fxmodulo (unsafe-primitive fxmodulo))
(define unsafe-fxabs (unsafe-primitive fxabs))

View File

@ -37,7 +37,7 @@
(let ([in (->core-input-port in)])
(and (method core-input-port in get-progress-evt) #t)))
(define/who (port-progress-evt orig-in)
(define/who (port-progress-evt [orig-in (current-input-port)])
(check who input-port? orig-in)
(let ([in (->core-input-port orig-in)])
(define get-progress-evt (method core-input-port in get-progress-evt))

View File

@ -4,6 +4,7 @@
"../host/thread.rkt"
"../string/utf-8-decode.rkt"
"port.rkt"
"parameter.rkt"
"input-port.rkt"
"read-and-peek.rkt"
"bytes-input.rkt"
@ -13,7 +14,7 @@
(provide byte-ready?
char-ready?)
(define/who (byte-ready? in)
(define/who (byte-ready? [in (current-input-port)])
(check who input-port? in)
(let loop ([in (->core-input-port in)])
(define byte-ready (method core-input-port in byte-ready))
@ -27,7 +28,7 @@
(end-atomic)
(eq? #t r)])))
(define/who (char-ready? in)
(define/who (char-ready? [in (current-input-port)])
(check who input-port? in)
(let ([in (->core-input-port in)])
(cond

View File

@ -103,11 +103,11 @@
[else #f])])]
[else #f]))
(define/who (bytes-utf-8-ref bstr [skip 0] [err-char #f] [start 0] [end (and (bytes? bstr)
(define/who (bytes-utf-8-ref bstr skip [err-char #f] [start 0] [end (and (bytes? bstr)
(bytes-length bstr))])
(do-bytes-utf-8-ref who bstr skip err-char start end))
(define/who (bytes-utf-8-index bstr [skip 0] [err-char #f] [start 0] [end (and (bytes? bstr)
(define/who (bytes-utf-8-index bstr skip [err-char #f] [start 0] [end (and (bytes? bstr)
(bytes-length bstr))])
(do-bytes-utf-8-ref who bstr skip err-char start end #:get-index? #t))

View File

@ -796,7 +796,7 @@ void scheme_init_error(Scheme_Startup_Env *env)
scheme_raise_arity_error_proc = scheme_make_noncm_prim(raise_arity_error, "raise-arity-error", 2, -1);
scheme_addto_prim_instance("raise-arity-error", scheme_raise_arity_error_proc, env);
ESCAPING_NONCM_PRIM("raise-arity-mask-error", raise_arity_mask_error, 2, -1, env);
ESCAPING_NONCM_PRIM("raise-result-arity-error", raise_result_arity_error, 2, -1, env);
ESCAPING_NONCM_PRIM("raise-result-arity-error", raise_result_arity_error, 3, -1, env);
ADD_PARAMETER("error-display-handler", error_display_handler, MZCONFIG_ERROR_DISPLAY_HANDLER, env);
ADD_PARAMETER("error-value->string-handler", error_value_string_handler, MZCONFIG_ERROR_PRINT_VALUE_HANDLER, env);

View File

@ -292,9 +292,9 @@ scheme_init_port_fun(Scheme_Startup_Env *env)
ADD_NONCM_PRIM("port-commit-peeked", peeked_read, 3, 4, env);
ADD_NONCM_PRIM("port-progress-evt", progress_evt, 0, 1, env);
ADD_NONCM_PRIM("progress-evt?", is_progress_evt, 1, 2, env);
ADD_NONCM_PRIM("port-closed-evt", closed_evt, 0, 1, env);
ADD_NONCM_PRIM("port-closed-evt", closed_evt, 1, 1, env);
ADD_NONCM_PRIM("write-bytes-avail-evt", write_bytes_avail_evt, 1, 4, env);
ADD_NONCM_PRIM("write-special-evt", write_special_evt, 2, 2, env);
ADD_NONCM_PRIM("write-special-evt", write_special_evt, 1, 2, env);
ADD_NONCM_PRIM("port-read-handler", port_read_handler, 1, 2, env);
ADD_NONCM_PRIM("port-display-handler", port_display_handler, 1, 2, env);
ADD_NONCM_PRIM("port-write-handler", port_write_handler, 1, 2, env);

View File

@ -528,13 +528,13 @@ scheme_init_string (Scheme_Startup_Env *env)
scheme_addto_prim_instance("bytes-convert",
scheme_make_prim_w_arity2(byte_string_convert,
"bytes-convert",
1, 7,
2, 7,
3, 3),
env);
scheme_addto_prim_instance("bytes-convert-end",
scheme_make_prim_w_arity2(byte_string_convert_end,
"bytes-convert-end",
0, 3,
1, 4,
2, 2),
env);
scheme_addto_prim_instance("bytes-open-converter",