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:
parent
91190bee63
commit
cd048cb1d0
|
@ -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
|
||||
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
75
racket/src/cs/known.rkt
Normal 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))))
|
||||
|
|
@ -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)])
|
||||
|
|
|
@ -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)])
|
||||
|
|
|
@ -405,6 +405,8 @@
|
|||
make-flrectangular
|
||||
gcd
|
||||
lcm
|
||||
fllog flatan
|
||||
fxquotient
|
||||
|
||||
random
|
||||
random-seed
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -828,10 +828,14 @@
|
|||
(hash-iterate-next ht i)
|
||||
(unsafe-intmap-iterate-next ht i)))
|
||||
|
||||
(define (unsafe-immutable-hash-iterate-key ht i)
|
||||
(if (iterator-for-impersonator? i)
|
||||
(hash-iterate-key ht i)
|
||||
(unsafe-intmap-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))]))
|
||||
|
||||
(define unsafe-immutable-hash-iterate-value
|
||||
(case-lambda
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -103,12 +103,12 @@
|
|||
[else #f])])]
|
||||
[else #f]))
|
||||
|
||||
(define/who (bytes-utf-8-ref bstr [skip 0] [err-char #f] [start 0] [end (and (bytes? bstr)
|
||||
(bytes-length 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)
|
||||
(bytes-length 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))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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",
|
||||
|
|
Loading…
Reference in New Issue
Block a user