suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

repair arity problems

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
racket/src/cs/c/Makefile.in
View File

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

4
racket/src/cs/chezpart.sls
View File

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

44
racket/src/cs/convert.rkt
View File

@ -3,17 +3,14 @@
racket/pretty racket/pretty
racket/match racket/match
racket/file racket/file
racket/fixnum
racket/flonum
racket/unsafe/ops
racket/extflonum racket/extflonum
racket/include
"../schemify/schemify.rkt" "../schemify/schemify.rkt"
"../schemify/serialize.rkt" "../schemify/serialize.rkt"
"../schemify/known.rkt" "../schemify/known.rkt"
"../schemify/lift.rkt" "../schemify/lift.rkt"
"../schemify/reinfer-name.rkt" "../schemify/reinfer-name.rkt"
"../schemify/wrap.rkt") "../schemify/wrap.rkt"
"known.rkt")
(define skip-export? #f) (define skip-export? #f)
(define for-cify? #f) (define for-cify? #f)
@ -100,40 +97,9 @@
(unless for-cify? (unless for-cify?
(lift l)) (lift l))
(define prim-knowns (define prim-knowns (get-prim-knowns))
(let ([knowns (hasheq)]) (define primitives (get-primitives))
(define-syntax-rule (define-primitive-table id [prim known] ...) (check-known-values prim-knowns primitives)
(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))
;; Convert: ;; Convert:
(define schemified-body (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))))

40
racket/src/cs/primitive/kernel.ss
View File

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

28
racket/src/cs/primitive/unsafe.ss
View File

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

2
racket/src/cs/rumble.sls
View File

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

12
racket/src/cs/rumble/error.ss
View File

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

2
racket/src/cs/rumble/extfl.ss
View File

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

8
racket/src/cs/rumble/hash.ss
View File

@ -828,10 +828,14 @@
(hash-iterate-next ht i) (hash-iterate-next ht i)
(unsafe-intmap-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) (if (iterator-for-impersonator? i)
(hash-iterate-key ht i) (hash-iterate-key ht i)
(unsafe-intmap-iterate-key ht i))) (unsafe-intmap-iterate-key ht i))]))
(define unsafe-immutable-hash-iterate-value (define unsafe-immutable-hash-iterate-value
(case-lambda (case-lambda

5
racket/src/cs/rumble/number.ss
View File

@ -432,3 +432,8 @@
(cond (cond
[(null? ms) n] [(null? ms) n]
[else (loop (lcm n (car ms)) (cdr ms))]))])) [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))

6
racket/src/cs/rumble/srcloc.ss
View File

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

2
racket/src/cs/rumble/unsafe.ss
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-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-fxremainder (unsafe-primitive fxremainder))
(define unsafe-fxmodulo (unsafe-primitive fxmodulo)) (define unsafe-fxmodulo (unsafe-primitive fxmodulo))
(define unsafe-fxabs (unsafe-primitive fxabs)) (define unsafe-fxabs (unsafe-primitive fxabs))

2
racket/src/io/port/progress-evt.rkt
View File

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

5
racket/src/io/port/ready.rkt
View File

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

4
racket/src/io/string/convert.rkt
View File

@ -103,11 +103,11 @@
[else #f])])] [else #f])])]
[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))]) (bytes-length bstr))])
(do-bytes-utf-8-ref who bstr skip err-char start end)) (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))]) (bytes-length bstr))])
(do-bytes-utf-8-ref who bstr skip err-char start end #:get-index? #t)) (do-bytes-utf-8-ref who bstr skip err-char start end #:get-index? #t))

2
racket/src/racket/src/error.c
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_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); 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-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-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); ADD_PARAMETER("error-value->string-handler", error_value_string_handler, MZCONFIG_ERROR_PRINT_VALUE_HANDLER, env);

4
racket/src/racket/src/portfun.c
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-commit-peeked", peeked_read, 3, 4, env);
ADD_NONCM_PRIM("port-progress-evt", progress_evt, 0, 1, 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("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-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-read-handler", port_read_handler, 1, 2, env);
ADD_NONCM_PRIM("port-display-handler", port_display_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); ADD_NONCM_PRIM("port-write-handler", port_write_handler, 1, 2, env);

4
racket/src/racket/src/string.c
View File

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