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

add procedure-arity-mask and procedure-reduce-arity-mask

Browse Source 
The mask encoding of an arity is often easier to test and manipulate,
and masked-based functions are sometimes faster than functions that
used the old arity representation (while always being at least as
fast).

Attempting to assign an arity like `(expt 2 100)` to `(lambda x x)`
won't work anymore; it will raise an out-of-memory exception, because
the arity is represented internally as a mask. The arities that cannot
be represented aren't sensible arities, anyway.
This commit is contained in:
Matthew Flatt 2018-08-09 06:23:27 -06:00
parent 36204b00ca
commit ecbd6f1578
27 changed files with 785 additions and 432 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "7.0.0.10") (define version "7.0.0.11")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

11
pkgs/racket-doc/scribblings/reference/exns.scrbl
View File

@ -316,6 +316,17 @@ message.
]} ]}
@defproc[(raise-arity-mask-error [name (or/c symbol? procedure?)]
[mask exact-integer?]
[arg-v any/c] ...)
any]{
The same as @racket[raise-arity-error], but using the arity representation
described with @racket[procedure-arity-mask].
@history[#:added "7.0.0.11"]}
@defproc[(raise-result-arity-error [name (or/c symbol? #f)] @defproc[(raise-result-arity-error [name (or/c symbol? #f)]
[arity-v exact-nonnegative-integer?] [arity-v exact-nonnegative-integer?]
[detail-str (or/c string? #f)] [detail-str (or/c string? #f)]

50
pkgs/racket-doc/scribblings/reference/procedures.scrbl
View File

@ -135,8 +135,8 @@ the @exnraise[exn:fail:contract].
@defproc[(procedure-arity [proc procedure?]) normalized-arity?]{ @defproc[(procedure-arity [proc procedure?]) normalized-arity?]{
Returns information about the number of by-position arguments accepted Returns information about the number of by-position arguments accepted
by @racket[proc]. See also @racket[procedure-arity?] and by @racket[proc]. See also @racket[procedure-arity?],
@racket[normalized-arity?].} @racket[normalized-arity?], and @racket[procedure-arity-mask].}
@defproc[(procedure-arity? [v any/c]) boolean?]{ @defproc[(procedure-arity? [v any/c]) boolean?]{
@ -169,6 +169,19 @@ The result of @racket[procedure-arity] is always normalized in the sense of
(procedure-arity (case-lambda [(x) 0] [(x y) 1])) (procedure-arity (case-lambda [(x) 0] [(x y) 1]))
]} ]}
@defproc[(procedure-arity-mask [proc procedure?]) exact-integer?]{
Returns the same information as @racket[procedure-arity], but encoded
differently. The arity is encoded as an exact integer @racket[_mask]
where @racket[(bitwise-bit-set? _mask _n)] returns true if @racket[proc]
accepts @racket[_n] arguments.
The mask encoding of an arity is often easier to test and manipulate,
and @racket[procedure-arity-mask] is sometimes faster than
@racket[procedure-arity] while always being at least as fast.
@history[#:added "7.0.0.11"]}
@defproc[(procedure-arity-includes? [proc procedure?] @defproc[(procedure-arity-includes? [proc procedure?]
[k exact-nonnegative-integer?] [k exact-nonnegative-integer?]
[kws-ok? any/c #f]) [kws-ok? any/c #f])
@ -187,7 +200,8 @@ keyword arguments.
]} ]}
@defproc[(procedure-reduce-arity [proc procedure?] @defproc[(procedure-reduce-arity [proc procedure?]
[arity procedure-arity?]) [arity procedure-arity?]
[name (or/c symbol? #f) #f])
procedure?]{ procedure?]{
Returns a procedure that is the same as @racket[proc] (including Returns a procedure that is the same as @racket[proc] (including
@ -195,7 +209,7 @@ the same name returned by @racket[object-name]), but that accepts
only arguments consistent with @racket[arity]. In particular, only arguments consistent with @racket[arity]. In particular,
when @racket[procedure-arity] is applied to the generated when @racket[procedure-arity] is applied to the generated
procedure, it returns a value that is @racket[equal?] to procedure, it returns a value that is @racket[equal?] to
@racket[arity]. the normalized form of @racket[arity].
If the @racket[arity] specification allows arguments that are not in If the @racket[arity] specification allows arguments that are not in
@racket[(procedure-arity proc)], the @exnraise[exn:fail:contract]. If @racket[(procedure-arity proc)], the @exnraise[exn:fail:contract]. If
@ -205,11 +219,35 @@ arity-reduced procedure) or @racket[arity] must be the empty list
(which makes a procedure that cannot be called); otherwise, the (which makes a procedure that cannot be called); otherwise, the
@exnraise[exn:fail:contract]. @exnraise[exn:fail:contract].
If @racket[name] is not @racket[#f], then @racket[object-name] of the
result procedure produces @racket[name]. Otherwise,
@racket[object-name] of the result procedure produces the same result
as for @racket[proc].
@examples[ @examples[
(define my+ (procedure-reduce-arity + 2)) (define my+ (procedure-reduce-arity + 2 ))
(my+ 1 2) (my+ 1 2)
(eval:error (my+ 1 2 3)) (eval:error (my+ 1 2 3))
]} (define also-my+ (procedure-reduce-arity + 2 'also-my+))
(eval:error (also-my+ 1 2 3))
]
@history[#:changed "7.0.0.11" @elem{Added the optional @racket[name]
argument.}]}
@defproc[(procedure-reduce-arity-mask [proc procedure?]
[mask exact-integer?]
[name (or/c symbol? #f) #f])
procedure?]{
The same as @racket[procedure-reduce-arity-mask], but using the
representation of arity described with @racket[procedure-arity-mask].
The mask encoding of an arity is often easier to test and manipulate,
and @racket[procedure-reduce-arity-mask] is sometimes faster than
@racket[procedure-reduce-arity] while always being at least as fast.
@history[#:added "7.0.0.11"]}
@defproc[(procedure-keywords [proc procedure?]) @defproc[(procedure-keywords [proc procedure?])
(values (values

13
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -2149,6 +2149,16 @@
(err/rt-test (raise-result-arity-error 'f -7 #f) exn:fail:contract:arity?/#f) (err/rt-test (raise-result-arity-error 'f -7 #f) exn:fail:contract:arity?/#f)
(err/rt-test (raise-result-arity-error 'f 7 #"oops") exn:fail:contract:arity?/#f) (err/rt-test (raise-result-arity-error 'f 7 #"oops") exn:fail:contract:arity?/#f)
(err/rt-test (raise-arity-mask-error 'f 4) exn:fail:contract:arity?)
(err/rt-test (raise-arity-mask-error 'f -8) exn:fail:contract:arity?)
(err/rt-test (raise-arity-mask-error 'f 5) exn:fail:contract:arity?)
(err/rt-test (raise-arity-mask-error 'f -5) exn:fail:contract:arity?)
(err/rt-test (raise-arity-mask-error 'f (arity-at-least 7)) exn:fail:contract:arity?/#f)
(err/rt-test (raise-arity-mask-error 'f -5.0) exn:fail:contract?)
(err/rt-test (raise-arity-mask-error 1 1) exn:fail:contract?)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; continuations ;; continuations
@ -2944,8 +2954,7 @@
not-inc))) not-inc)))
(list proc (procedure-reduce-arity proc ar))))] (list proc (procedure-reduce-arity proc ar))))]
[representable-arity? (lambda (a) [representable-arity? (lambda (a)
(or (not (eq? 'chez-scheme (system-type 'vm))) (a . < . 4096))])
(a . < . 4096)))])
(let ([check-all-but-one (let ([check-all-but-one
(lambda (+) (lambda (+)
(check-ok + 0 '(0) '(1)) (check-ok + 0 '(0) '(1))

51
pkgs/racket-test-core/tests/racket/object.rktl
View File

@ -1398,57 +1398,6 @@
'(#t #f)) '(#t #f))
;; ------------------------------------------------------------
;; Check arity reporting for methods.
;; (This is really a Racket test, not a class.rkt test.)
(map
(lambda (jit?)
(parameterize ([eval-jit-enabled jit?])
(let ([mk-f (lambda ()
(eval (syntax-property #'(lambda (a b) a) 'method-arity-error #t)))]
[check-arity-error
(lambda (f cl?)
(test (if cl? '("given: 0") '("expected: 1\n"))
regexp-match #rx"expected: 1\n|given: 0$"
(exn-message (with-handlers ([values values])
;; Use `apply' to avoid triggering
;; compilation of f:
(apply f '(1))))))])
(test 2 procedure-arity (mk-f))
(check-arity-error (mk-f) #f)
(test 1 (mk-f) 1 2)
(let ([f (mk-f)])
(test 1 (mk-f) 1 2)
(check-arity-error (mk-f) #f))
(let ([mk-f (lambda ()
(eval (syntax-property #'(case-lambda [(a b) a][(c d) c]) 'method-arity-error #t)))])
(test 2 procedure-arity (mk-f))
(check-arity-error (mk-f) #t)
(test 1 (mk-f) 1 2)
(let ([f (mk-f)])
(test 1 (mk-f) 1 2)
(check-arity-error (mk-f) #t))))
(let* ([f (lambda (a b) a)]
[meth (procedure->method f)]
[check-arity-error
(lambda (f cl?)
(test (if cl? '("given: 0") '("expected: 1\n"))
regexp-match #rx"expected: 1\n|given: 0$"
(exn-message (with-handlers ([values values])
;; Use `apply' to avoid triggering
;; compilation of f:
(apply f '(1))))))])
(test 2 procedure-arity meth)
(check-arity-error meth #f)
(test 1 meth 1 2)
(let* ([f (case-lambda [(a b) a] [(c d) c])]
[meth (procedure->method f)])
(test 2 procedure-arity meth)
(check-arity-error meth #t)
(test 1 meth 1 2)))))
'(#t #f))
;; ------------------------------------------------------------ ;; ------------------------------------------------------------
;; Check define-member-name, etc.: ;; Check define-member-name, etc.:

89
pkgs/racket-test-core/tests/racket/procs.rktl
View File

@ -132,7 +132,7 @@
err-n) err-n)
(exn-message exn))))])) (exn-message exn))))]))
(let () (define (run-procedure-tests procedure-arity procedure-reduce-arity)
(define (get-maybe p n) (define (get-maybe p n)
(and ((length p) . > . n) (list-ref p n))) (and ((length p) . > . n) (list-ref p n)))
(define (try-combos procs add-chaperone) (define (try-combos procs add-chaperone)
@ -361,6 +361,93 @@
(try-combos (map add-chaperone procs) values) (try-combos (map add-chaperone procs) values)
(try-combos (map add-chaperone procs) add-chaperone))) (try-combos (map add-chaperone procs) add-chaperone)))
(define (mask->arity mask)
(let loop ([mask mask] [pos 0])
(cond
[(= mask 0) null]
[(= mask -1) (arity-at-least pos)]
[(bitwise-bit-set? mask 0)
(let ([rest (loop (arithmetic-shift mask -1) (add1 pos))])
(cond
[(null? rest) pos]
[(pair? rest) (cons pos rest)]
[else (list pos rest)]))]
[else
(loop (arithmetic-shift mask -1) (add1 pos))])))
(define (arity->mask a)
(cond
[(exact-nonnegative-integer? a)
(arithmetic-shift 1 a)]
[(arity-at-least? a)
(bitwise-xor -1 (sub1 (arithmetic-shift 1 (arity-at-least-value a))))]
[(list? a)
(let loop ([mask 0] [l a])
(cond
[(null? l) mask]
[else
(let ([a (car l)])
(cond
[(or (exact-nonnegative-integer? a)
(arity-at-least? a))
(loop (bitwise-ior mask (arity->mask a)) (cdr l))]
[else #f]))]))]
[else #f]))
(run-procedure-tests procedure-arity procedure-reduce-arity)
(run-procedure-tests (lambda (p) (mask->arity (procedure-arity-mask p)))
(lambda (p a [name #f]) (procedure-reduce-arity-mask p (arity->mask a) name)))
;; ------------------------------------------------------------
;; Check arity reporting for methods.
(map
(lambda (jit?)
(parameterize ([eval-jit-enabled jit?])
(let ([mk-f (lambda ()
(eval (syntax-property #'(lambda (a b) a) 'method-arity-error #t)))]
[check-arity-error
(lambda (f cl?)
(test (if cl? '("given: 0") '("expected: 1\n"))
regexp-match #rx"expected: 1\n|given: 0$"
(exn-message (with-handlers ([values values])
;; Use `apply' to avoid triggering
;; compilation of f:
(apply f '(1))))))])
(test 2 procedure-arity (mk-f))
(check-arity-error (mk-f) #f)
(test 1 (mk-f) 1 2)
(let ([f (mk-f)])
(test 1 (mk-f) 1 2)
(check-arity-error (mk-f) #f))
(let ([mk-f (lambda ()
(eval (syntax-property #'(case-lambda [(a b) a] [(c d e) c]) 'method-arity-error #t)))])
(test '(2 3) procedure-arity (mk-f))
(check-arity-error (mk-f) #t)
(test 1 (mk-f) 1 2)
(let ([f (mk-f)])
(test 1 (mk-f) 1 2)
(check-arity-error (mk-f) #t))))
(let* ([f (lambda (a b) a)]
[meth (procedure->method f)]
[check-arity-error
(lambda (f cl?)
(test (if cl? '("given: 0") '("expected: 1\n"))
regexp-match #rx"expected: 1\n|given: 0$"
(exn-message (with-handlers ([values values])
;; Use `apply' to avoid triggering
;; compilation of f:
(apply f '(1))))))])
(test 2 procedure-arity meth)
(check-arity-error meth #f)
(test 1 meth 1 2)
(let* ([f (case-lambda [(a b) a] [(c d e) c])]
[meth (procedure->method f)])
(test '(2 3) procedure-arity meth)
(check-arity-error meth #t)
(test 1 meth 1 2)))))
'(#t #f))
;; ---------------------------------------- ;; ----------------------------------------
;; Check error for non-procedures ;; Check error for non-procedures
(err/rt-test (1 2 3) (lambda (x) (regexp-match? "not a procedure" (exn-message x)))) (err/rt-test (1 2 3) (lambda (x) (regexp-match? "not a procedure" (exn-message x))))

152
racket/collects/racket/private/kw.rkt
View File

@ -27,7 +27,9 @@
keyword-apply keyword-apply
procedure-keywords procedure-keywords
new:procedure-reduce-arity new:procedure-reduce-arity
new:procedure-reduce-arity-mask
procedure-reduce-keyword-arity procedure-reduce-keyword-arity
procedure-reduce-keyword-arity-mask
new-prop:procedure new-prop:procedure
new:procedure->method new:procedure->method
new:procedure-rename new:procedure-rename
@ -412,7 +414,7 @@
[(proc plain-proc) [(proc plain-proc)
(make-optional-keyword-procedure (make-optional-keyword-procedure
(make-keyword-checker null #f (and (procedure? proc) ; reundant check helps purity inference (make-keyword-checker null #f (and (procedure? proc) ; reundant check helps purity inference
(procedure-arity proc))) (procedure-arity-mask proc)))
proc proc
null null
#f #f
@ -1386,20 +1388,13 @@
[else (values #f (car kws))]))) [else (values #f (car kws))])))
;; Generates a keyword an arity checker dynamically: ;; Generates a keyword an arity checker dynamically:
(define (make-keyword-checker req-kws allowed-kws arity) (define (make-keyword-checker req-kws allowed-kws arity-mask)
;; If min-args is #f, then max-args is an arity value. ;; If min-args is #f, then max-args is an arity value.
;; If max-args is #f, then >= min-args is accepted. ;; If max-args is #f, then >= min-args is accepted.
(define-syntax (arity-check-lambda stx) (define-syntax (arity-check-lambda stx)
(syntax-case stx () (syntax-case stx ()
[(_ (kws) kw-body) [(_ (kws) kw-body)
#'(cond #'(lambda (kws a) (and kw-body (bitwise-bit-set? arity-mask a)))]))
[(integer? arity)
(lambda (kws a) (and kw-body (= a arity)))]
[(arity-at-least? arity)
(let ([arity (arity-at-least-value arity)])
(lambda (kws a) (and kw-body (a . >= . arity))))]
[else
(lambda (kws a) (and kw-body (arity-includes? arity a)))])]))
(cond (cond
[(not allowed-kws) [(not allowed-kws)
;; All allowed ;; All allowed
@ -1437,14 +1432,6 @@
;; Required is a subset of allowed ;; Required is a subset of allowed
(subsets? req-kws kws allowed-kws)))])])) (subsets? req-kws kws allowed-kws)))])]))
(define (arity-includes? arity a)
(cond
[(integer? arity) (= arity a)]
[(arity-at-least? arity)
(a . >= . (arity-at-least-value a))]
[else
(ormap (lambda (ar) (arity-includes? ar a)) arity)]))
(define (subset? l1 l2) (define (subset? l1 l2)
;; l1 and l2 are sorted ;; l1 and l2 are sorted
(cond (cond
@ -1565,11 +1552,26 @@
(keyword-procedure-extract/method kws n p 0)) (keyword-procedure-extract/method kws n p 0))
;; setting procedure arity ;; setting procedure arity
(define (procedure-reduce-keyword-arity proc arity req-kw allowed-kw) (define procedure-reduce-keyword-arity
(let* ([plain-proc (procedure-reduce-arity (if (okp? proc) (case-lambda
(okp-ref proc 0) [(proc arity req-kw allowed-kw name)
proc) (do-procedure-reduce-keyword-arity 'procedure-reduce-keyword-arity proc arity #f name req-kw allowed-kw)]
arity)]) [(proc arity req-kw allowed-kw)
(do-procedure-reduce-keyword-arity 'procedure-reduce-keyword-arity proc arity #f #f req-kw allowed-kw)]))
(define procedure-reduce-keyword-arity-mask
(case-lambda
[(proc mask req-kw allowed-kw name)
(do-procedure-reduce-keyword-arity 'procedure-reduce-keyword-arity-mask proc #f mask name req-kw allowed-kw)]
[(proc mask req-kw allowed-kw)
(do-procedure-reduce-keyword-arity 'procedure-reduce-keyword-arity-mask proc #f mask #f req-kw allowed-kw)]))
(define (do-procedure-reduce-keyword-arity who proc arity mask name req-kw allowed-kw)
(let* ([plain-proc (let ([p (if (okp? proc)
(okp-ref proc 0)
proc)])
(if arity
(procedure-reduce-arity p arity)
(procedure-reduce-arity-mask p mask name)))])
(define (sorted? kws) (define (sorted? kws)
(let loop ([kws kws]) (let loop ([kws kws])
(cond (cond
@ -1580,51 +1582,44 @@
(unless (and (list? req-kw) (andmap keyword? req-kw) (unless (and (list? req-kw) (andmap keyword? req-kw)
(sorted? req-kw)) (sorted? req-kw))
(raise-argument-error 'procedure-reduce-keyword-arity "(and/c (listof? keyword?) sorted? distinct?)" (raise-argument-error who "(and/c (listof? keyword?) sorted? distinct?)"
2 proc arity req-kw allowed-kw)) 2 proc (or arity mask) req-kw allowed-kw))
(when allowed-kw (when allowed-kw
(unless (and (list? allowed-kw) (andmap keyword? allowed-kw) (unless (and (list? allowed-kw) (andmap keyword? allowed-kw)
(sorted? allowed-kw)) (sorted? allowed-kw))
(raise-argument-error 'procedure-reduce-keyword-arity "(or/c (and/c (listof? keyword?) sorted? distinct?) #f)" (raise-argument-error who "(or/c (and/c (listof? keyword?) sorted? distinct?) #f)"
3 proc arity req-kw allowed-kw)) 3 proc (or arity mask) req-kw allowed-kw))
(unless (subset? req-kw allowed-kw) (unless (subset? req-kw allowed-kw)
(raise-arguments-error 'procedure-reduce-keyword-arity (raise-arguments-error who
"allowed-keyword list does not include all required keywords" "allowed-keyword list does not include all required keywords"
"allowed-keyword list" allowed-kw "allowed-keyword list" allowed-kw
"required keywords" req-kw))) "required keywords" req-kw)))
(let-values ([(old-req old-allowed) (procedure-keywords proc)]) (let-values ([(old-req old-allowed) (procedure-keywords proc)])
(unless (subset? old-req req-kw) (unless (subset? old-req req-kw)
(raise-arguments-error 'procedure-reduce-keyword-arity (raise-arguments-error who
"cannot reduce required keyword set" "cannot reduce required keyword set"
"required keywords" old-req "required keywords" old-req
"requested required keywords" req-kw)) "requested required keywords" req-kw))
(when old-allowed (when old-allowed
(unless (subset? req-kw old-allowed) (unless (subset? req-kw old-allowed)
(raise-arguments-error 'procedure-reduce-keyword-arity (raise-arguments-error who
"cannot require keywords not in original allowed set" "cannot require keywords not in original allowed set"
"original allowed keywords" old-allowed "original allowed keywords" old-allowed
"requested required keywords" req-kw)) "requested required keywords" req-kw))
(unless (or (not allowed-kw) (unless (or (not allowed-kw)
(subset? allowed-kw old-allowed)) (subset? allowed-kw old-allowed))
(raise-arguments-error 'procedure-reduce-keyword-arity (raise-arguments-error who
"cannot allow keywords not in original allowed set" "cannot allow keywords not in original allowed set"
"original allowed keywords" old-allowed "original allowed keywords" old-allowed
"requested allowed keywords" allowed-kw)))) "requested allowed keywords" allowed-kw))))
(if (null? allowed-kw) (if (null? allowed-kw)
plain-proc plain-proc
(let* ([inc-arity (lambda (arity delta) (let* ([mask (or mask (arity->mask arity))]
(let loop ([a arity]) [new-mask (arithmetic-shift mask 2)]
(cond [kw-checker (make-keyword-checker req-kw allowed-kw new-mask)]
[(integer? a) (+ a delta)]
[(arity-at-least? a)
(arity-at-least (+ (arity-at-least-value a) delta))]
[else
(map loop a)])))]
[new-arity (inc-arity arity 2)]
[kw-checker (make-keyword-checker req-kw allowed-kw new-arity)]
[proc (normalize-proc proc)] [proc (normalize-proc proc)]
[new-kw-proc (procedure-reduce-arity (keyword-procedure-proc proc) [new-kw-proc (procedure-reduce-arity-mask (keyword-procedure-proc proc)
new-arity)]) new-mask)])
(if (null? req-kw) (if (null? req-kw)
;; All keywords are optional: ;; All keywords are optional:
((if (okm? proc) ((if (okm? proc)
@ -1640,9 +1635,9 @@
((make-required (or (and (named-keyword-procedure? proc) ((make-required (or (and (named-keyword-procedure? proc)
(car (keyword-procedure-name+fail proc))) (car (keyword-procedure-name+fail proc)))
(object-name proc)) (object-name proc))
(procedure-reduce-arity (procedure-reduce-arity-mask
missing-kw missing-kw
(inc-arity arity 1)) (arithmetic-shift mask 1))
(or (okm? proc) (or (okm? proc)
(keyword-method? proc)) (keyword-method? proc))
#f) #f)
@ -1651,20 +1646,63 @@
req-kw req-kw
allowed-kw)))))) allowed-kw))))))
(define (arity->mask a)
(cond
[(exact-nonnegative-integer? a)
(arithmetic-shift 1 a)]
[(arity-at-least? a)
(bitwise-xor -1 (sub1 (arithmetic-shift 1 (arity-at-least-value a))))]
[(list? a)
(let loop ([mask 0] [l a])
(cond
[(null? l) mask]
[else
(let ([a (car l)])
(cond
[(or (exact-nonnegative-integer? a)
(arity-at-least? a))
(loop (bitwise-ior mask (arity->mask a)) (cdr l))]
[else #f]))]))]
[else #f]))
(define new:procedure-reduce-arity (define new:procedure-reduce-arity
(let ([procedure-reduce-arity (let ([procedure-reduce-arity
(lambda (proc arity) (case-lambda
(if (and (procedure? proc) [(proc arity name)
(let-values ([(req allows) (procedure-keywords proc)]) (if (and (procedure? proc)
(pair? req)) (let-values ([(req allows) (procedure-keywords proc)])
(not (null? arity))) (pair? req))
(raise-arguments-error 'procedure-reduce-arity (not (null? arity)))
"procedure has required keyword arguments" (raise-arguments-error 'procedure-reduce-arity
"procedure" proc) "procedure has required keyword arguments"
(procedure-reduce-arity (if (okm? proc) "procedure" proc)
(procedure->method proc) (procedure-reduce-arity (if (okm? proc)
proc) (procedure->method proc)
arity)))]) proc)
arity
name))]
[(proc arity)
(new:procedure-reduce-arity proc arity #f)])])
procedure-reduce-arity))
(define new:procedure-reduce-arity-mask
(let ([procedure-reduce-arity
(case-lambda
[(proc mask name)
(if (and (procedure? proc)
(let-values ([(req allows) (procedure-keywords proc)])
(pair? req))
(not (eqv? mask 0)))
(raise-arguments-error 'procedure-reduce-arity
"procedure has required keyword arguments"
"procedure" proc)
(procedure-reduce-arity-mask (if (okm? proc)
(procedure->method proc)
proc)
mask
name))]
[(proc mask)
(new:procedure-reduce-arity-mask proc mask #f)])])
procedure-reduce-arity)) procedure-reduce-arity))
(define new:procedure->method (define new:procedure->method

21
racket/collects/racket/private/norm-arity.rkt
View File

@ -1,25 +1,6 @@
(module norm-arity '#%kernel (module norm-arity '#%kernel
(#%require "define.rkt" "small-scheme.rkt" "sort.rkt") (#%require "define.rkt" "small-scheme.rkt" "sort.rkt")
(#%provide norm:procedure-arity (#%provide normalize-arity)
norm:raise-arity-error
normalize-arity) ;; for test suites
(define norm:procedure-arity
(let ([procedure-arity (λ (p) (normalize-arity (procedure-arity p)))])
procedure-arity))
(define norm:raise-arity-error
(let ([raise-arity-error
(λ (name arity-v . arg-vs)
(if (or (exact-nonnegative-integer? arity-v)
(arity-at-least? arity-v)
(and (list? arity-v)
(andmap (λ (x) (or (exact-nonnegative-integer? x)
(arity-at-least? x)))
arity-v)))
(apply raise-arity-error name
(normalize-arity arity-v) arg-vs)
;; here we let raise-arity-error signal an error
(apply raise-arity-error name arity-v arg-vs)))])
raise-arity-error))
;; normalize-arity : (or/c arity (listof arity)) ;; normalize-arity : (or/c arity (listof arity))
;; -> (or/c null ;; -> (or/c null

7
racket/collects/racket/private/pre-base.rkt
View File

@ -16,7 +16,6 @@
"map.rkt" ; shadows #%kernel bindings "map.rkt" ; shadows #%kernel bindings
"member.rkt" "member.rkt"
"kernstruct.rkt" "kernstruct.rkt"
"norm-arity.rkt"
"performance-hint.rkt" "performance-hint.rkt"
"top-int.rkt" "top-int.rkt"
"collect.rkt" "collect.rkt"
@ -204,9 +203,8 @@
(rename #%module-begin #%plain-module-begin) (rename #%module-begin #%plain-module-begin)
(rename printing:module-begin #%printing-module-begin) (rename printing:module-begin #%printing-module-begin)
(rename module-begin #%module-begin) (rename module-begin #%module-begin)
(rename norm:procedure-arity procedure-arity)
(rename norm:raise-arity-error raise-arity-error)
(rename new:procedure-reduce-arity procedure-reduce-arity) (rename new:procedure-reduce-arity procedure-reduce-arity)
(rename new:procedure-reduce-arity-mask procedure-reduce-arity-mask)
(rename new:procedure->method procedure->method) (rename new:procedure->method procedure->method)
(rename new:procedure-rename procedure-rename) (rename new:procedure-rename procedure-rename)
(rename new:chaperone-procedure chaperone-procedure) (rename new:chaperone-procedure chaperone-procedure)
@ -216,7 +214,7 @@
(rename new:collection-path collection-path) (rename new:collection-path collection-path)
(rename new:collection-file-path collection-file-path) (rename new:collection-file-path collection-file-path)
(all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure (all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure
procedure-arity procedure-reduce-arity raise-arity-error procedure-reduce-arity procedure-reduce-arity-mask
procedure->method procedure-rename procedure->method procedure-rename
chaperone-procedure impersonate-procedure chaperone-procedure impersonate-procedure
chaperone-procedure* impersonate-procedure* chaperone-procedure* impersonate-procedure*
@ -243,6 +241,7 @@
(rename new-keyword-apply keyword-apply) (rename new-keyword-apply keyword-apply)
procedure-keywords procedure-keywords
procedure-reduce-keyword-arity procedure-reduce-keyword-arity
procedure-reduce-keyword-arity-mask
(rename define-struct* define-struct) (rename define-struct* define-struct)
define-struct/derived define-struct/derived
struct-field-index struct-field-index

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

@ -656,12 +656,14 @@
[printf (known-procedure -2)] [printf (known-procedure -2)]
[procedure->method (known-procedure 2)] [procedure->method (known-procedure 2)]
[procedure-arity (known-procedure 2)] [procedure-arity (known-procedure 2)]
[procedure-arity-mask (known-procedure 2)]
[procedure-arity-includes? (known-procedure 12)] [procedure-arity-includes? (known-procedure 12)]
[procedure-arity? (known-procedure 2)] [procedure-arity? (known-procedure 2)]
[procedure-closure-contents-eq? (known-procedure 4)] [procedure-closure-contents-eq? (known-procedure 4)]
[procedure-extract-target (known-procedure 2)] [procedure-extract-target (known-procedure 2)]
[procedure-impersonator*? (known-procedure 2)] [procedure-impersonator*? (known-procedure 2)]
[procedure-reduce-arity (known-procedure 4)] [procedure-reduce-arity (known-procedure 12)]
[procedure-reduce-arity-mask (known-procedure 12)]
[procedure-rename (known-procedure 4)] [procedure-rename (known-procedure 4)]
[procedure-result-arity (known-procedure 2)] [procedure-result-arity (known-procedure 2)]
[procedure-specialize (known-procedure 2)] [procedure-specialize (known-procedure 2)]
@ -692,6 +694,7 @@
[raise-argument-error (known-procedure -8)] [raise-argument-error (known-procedure -8)]
[raise-arguments-error (known-procedure -4)] [raise-arguments-error (known-procedure -4)]
[raise-arity-error (known-procedure -4)] [raise-arity-error (known-procedure -4)]
[raise-arity-mask-error (known-procedure -4)]
[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)]

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

@ -139,10 +139,12 @@
extract-procedure ; not exported to Racket extract-procedure ; not exported to Racket
procedure-arity-includes? procedure-arity-includes?
procedure-arity procedure-arity
procedure-arity-mask
procedure-result-arity procedure-result-arity
procedure-extract-target procedure-extract-target
procedure-closure-contents-eq? procedure-closure-contents-eq?
procedure-reduce-arity procedure-reduce-arity
procedure-reduce-arity-mask
procedure-rename procedure-rename
procedure->method procedure->method
procedure-arity? procedure-arity?
@ -185,6 +187,7 @@
raise-mismatch-error raise-mismatch-error
raise-range-error raise-range-error
raise-arity-error raise-arity-error
raise-arity-mask-error
raise-result-arity-error raise-result-arity-error
raise-type-error raise-type-error
raise-binding-result-arity-error ; not exported to Racket raise-binding-result-arity-error ; not exported to Racket

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

@ -328,7 +328,14 @@
(expected-arity-string arity) (expected-arity-string arity)
" given: " (number->string (length args))) " given: " (number->string (length args)))
(current-continuation-marks)))) (current-continuation-marks))))
(define/who (raise-arity-mask-error name mask . args)
(check who (lambda (p) (or (symbol? name) (procedure? name)))
:contract "(or/c symbol? procedure?)"
name)
(check who exact-integer? mask)
(apply raise-arity-error name (mask->arity mask) args))
(define (expected-arity-string arity) (define (expected-arity-string arity)
(let ([expected (let ([expected
(lambda (s) (string-append " expected: " s "\n"))]) (lambda (s) (string-append " expected: " s "\n"))])

107
racket/src/cs/rumble/procedure.ss
View File

@ -241,49 +241,70 @@
(define-record reduced-arity-procedure (proc mask name)) (define-record reduced-arity-procedure (proc mask name))
(define/who (procedure-reduce-arity proc a) (define/who procedure-reduce-arity
(check who procedure? proc) (case-lambda
(let ([mask (arity->mask a)]) [(proc a name)
(unless mask (check who procedure? proc)
(raise-arguments-error who "procedure-arity?" a)) (let ([mask (arity->mask a)])
(unless (= mask (bitwise-and mask (procedure-arity-mask proc))) (unless mask
(raise-arguments-error who (raise-arguments-error who "procedure-arity?" a))
"arity of procedure does not include requested arity" (check who symbol? :or-false name)
"procedure" proc (unless (= mask (bitwise-and mask (procedure-arity-mask proc)))
"requested arity" a)) (raise-arguments-error who
(let ([name (object-name proc)]) "arity of procedure does not include requested arity"
(case mask "procedure" proc
[(1) (make-arity-wrapper-procedure (if (#%procedure? proc) "requested arity" a))
(lambda () (proc)) (do-procedure-reduce-arity-mask proc mask name))]
(lambda () (|#%app| proc))) [(proc a) (procedure-reduce-arity proc a #f)]))
mask
name)] (define/who procedure-reduce-arity-mask
[(2) (make-arity-wrapper-procedure (if (#%procedure? proc) (case-lambda
(lambda (x) (proc x)) [(proc mask name)
(lambda (x) (|#%app| proc x))) (check who procedure? proc)
mask (check who exact-integer? mask)
name)] (check who symbol? :or-false name)
[(4) (make-arity-wrapper-procedure (if (#%procedure? proc) (unless (= mask (bitwise-and mask (procedure-arity-mask proc)))
(lambda (x y) (proc x y)) (raise-arguments-error who
(lambda (x y) (|#%app| proc x y))) "arity mask of procedure does not include requested arity mask"
mask "procedure" proc
name)] "requested arity mask" mask))
[(8) (make-arity-wrapper-procedure (if (#%procedure? proc) (do-procedure-reduce-arity-mask proc mask name)]
(lambda (x y z) (proc x y z)) [(proc mask) (procedure-reduce-arity-mask proc mask #f)]))
(lambda (x y z) (|#%app| proc x y z)))
mask (define (do-procedure-reduce-arity-mask proc mask name)
name)] (let ([name (object-name proc)])
[else (case mask
(make-reduced-arity-procedure [(1) (make-arity-wrapper-procedure (if (#%procedure? proc)
(lambda args (lambda () (proc))
(unless (bitwise-bit-set? mask (length args)) (lambda () (|#%app| proc)))
(apply raise-arity-error mask
(or (object-name proc) 'procedure) name)]
(mask->arity mask) [(2) (make-arity-wrapper-procedure (if (#%procedure? proc)
args)) (lambda (x) (proc x))
(apply proc args)) (lambda (x) (|#%app| proc x)))
mask mask
name)])))) name)]
[(4) (make-arity-wrapper-procedure (if (#%procedure? proc)
(lambda (x y) (proc x y))
(lambda (x y) (|#%app| proc x y)))
mask
name)]
[(8) (make-arity-wrapper-procedure (if (#%procedure? proc)
(lambda (x y z) (proc x y z))
(lambda (x y z) (|#%app| proc x y z)))
mask
name)]
[else
(make-reduced-arity-procedure
(lambda args
(unless (bitwise-bit-set? mask (length args))
(apply raise-arity-error
(or (object-name proc) 'procedure)
(mask->arity mask)
args))
(apply proc args))
mask
name)])))
;; ---------------------------------------- ;; ----------------------------------------

6
racket/src/expander/Makefile
View File

@ -22,6 +22,10 @@ KNOT = ++knot read read/api.rkt \
# a direct use of the primitive name: # a direct use of the primitive name:
DIRECT = ++direct linklet ++direct kernel DIRECT = ++direct linklet ++direct kernel
# Make sure that the flattened form doesn't use
# `make-optional-keyword-procedure`
DISALLOW = ++disallow make-optional-keyword-procedure
# Set `BUILDDIR` as a prefix on "compiled" output (defaults to empty). # Set `BUILDDIR` as a prefix on "compiled" output (defaults to empty).
# Set `DEPENDSDIR` as the same sort of prefix in the generated # Set `DEPENDSDIR` as the same sort of prefix in the generated
# makefile-dependency file (also defaults to empty). The `BUILDDIR` # makefile-dependency file (also defaults to empty). The `BUILDDIR`
@ -31,7 +35,7 @@ DIRECT = ++direct linklet ++direct kernel
expander: expander:
$(RACO) make bootstrap-run.rkt $(RACO) make bootstrap-run.rkt
$(RACKET) bootstrap-run.rkt -c compiled/cache-src $(KNOT) $(DIRECT) --local-rename -O $(TREE) $(RACKET) bootstrap-run.rkt -c compiled/cache-src $(KNOT) $(DIRECT) $(DISALLOW) --local-rename -O $(TREE)
expander-src: expander-src:
$(RACO) make bootstrap-run.rkt $(RACO) make bootstrap-run.rkt

41
racket/src/expander/extract/gc-defn.rkt
View File

@ -13,9 +13,13 @@
(provide garbage-collect-definitions) (provide garbage-collect-definitions)
(define (garbage-collect-definitions linklet-expr) (define (garbage-collect-definitions linklet-expr
#:disallows disallows)
(log-status "Removing unused definitions...") (log-status "Removing unused definitions...")
(define disallow-ht (for/hasheq ([s (in-list disallows)])
(values s #t)))
(define body (bootstrap:s-expr-linklet-body linklet-expr)) (define body (bootstrap:s-expr-linklet-body linklet-expr))
(define used-syms (make-hasheq)) (define used-syms (make-hasheq))
@ -33,12 +37,34 @@
(for ([sym (in-list (defn-syms e))]) (for ([sym (in-list (defn-syms e))])
(hash-set! sym-to-rhs sym (defn-rhs e)))])) (hash-set! sym-to-rhs sym (defn-rhs e)))]))
;; To track dependencies for reporting
(define use-deps (make-hasheq))
(define (track-and-check-disallowed! sym used-by)
(when (hash-ref disallow-ht sym #f)
(apply raise-arguments-error
'flatten "disallowed identifier's definition preserved"
"identifier" sym
(let loop ([used-by used-by])
(cond
[(not used-by) null]
[else
(or (and (list? used-by)
(for/or ([used-by (in-list used-by)])
(define next (hash-ref use-deps used-by #f))
(and next
(list* "due to" used-by
(loop next)))))
(list* "due to" used-by
(loop (hash-ref use-deps used-by #f))))]))))
(hash-set! use-deps sym used-by))
;; A "mark"-like traversal of an expression: ;; A "mark"-like traversal of an expression:
(define (set-all-used! e) (define (set-all-used! e used-by)
(for ([sym (in-set (all-used-symbols e))]) (for ([sym (in-set (all-used-symbols e))])
(unless (hash-ref used-syms sym #f) (unless (hash-ref used-syms sym #f)
(hash-set! used-syms sym #t) (hash-set! used-syms sym #t)
(set-all-used! (hash-ref sym-to-rhs sym #f))))) (track-and-check-disallowed! sym used-by)
(set-all-used! (hash-ref sym-to-rhs sym #f) sym))))
;; Helper to check for side-effects at a definition ;; Helper to check for side-effects at a definition
(define (defn-side-effects? e) (define (defn-side-effects? e)
@ -59,8 +85,9 @@
;; definition and mark everything as used: ;; definition and mark everything as used:
(for ([sym (in-list (defn-syms defn))]) (for ([sym (in-list (defn-syms defn))])
(unless (hash-ref used-syms sym #f) (unless (hash-ref used-syms sym #f)
(track-and-check-disallowed! sym '#:rhs-effect)
(hash-set! used-syms sym #t))) (hash-set! used-syms sym #t)))
(set-all-used! (defn-rhs defn)) (set-all-used! (defn-rhs defn) (defn-syms defn))
;; Afterward, these identifiers are defined. ;; Afterward, these identifiers are defined.
;; (It's ok if delayed types refer to these, ;; (It's ok if delayed types refer to these,
;; because they're apparently used later if they're ;; because they're apparently used later if they're
@ -68,7 +95,7 @@
(for ([sym (in-list (defn-syms defn))]) (for ([sym (in-list (defn-syms defn))])
(hash-set! seen-defns sym (known-defined)))] (hash-set! seen-defns sym (known-defined)))]
[else [else
;; The definition itself doesn't have a side effect, so dont ;; The definition itself doesn't have a side effect, so don't
;; mark it as used right away, and delay analysis to make it ;; mark it as used right away, and delay analysis to make it
;; independent of order within a group without side effects ;; independent of order within a group without side effects
(define thunk (define thunk
@ -83,12 +110,12 @@
(hash-set! seen-defns sym thunk))]) (hash-set! seen-defns sym thunk))])
(loop (cdr body))] (loop (cdr body))]
[else [else
(set-all-used! (car body)) (set-all-used! (car body) '#:effect)
(loop (cdr body))])) (loop (cdr body))]))
;; Mark each export: ;; Mark each export:
(for ([ex+sym (in-list (bootstrap:s-expr-linklet-exports+locals linklet-expr))]) (for ([ex+sym (in-list (bootstrap:s-expr-linklet-exports+locals linklet-expr))])
(set-all-used! (cdr ex+sym))) (set-all-used! (cdr ex+sym) '#:export))
(define can-remove-count (define can-remove-count
(for/sum ([e (in-list body)]) (for/sum ([e (in-list body)])

3
racket/src/expander/extract/known-primitive.rkt
View File

@ -21,4 +21,5 @@
(hash-set! seen-defns 'arity-at-least? (known-predicate 'arity-at-least)) (hash-set! seen-defns 'arity-at-least? (known-predicate 'arity-at-least))
(hash-set! seen-defns 'arity-at-least-value (known-function-of-satisfying '(arity-at-least))) (hash-set! seen-defns 'arity-at-least-value (known-function-of-satisfying '(arity-at-least)))
(hash-set! seen-defns 'procedure? (known-predicate 'procedure)) (hash-set! seen-defns 'procedure? (known-predicate 'procedure))
(hash-set! seen-defns 'procedure-arity (known-function-of-satisfying '(procedure)))) (hash-set! seen-defns 'procedure-arity (known-function-of-satisfying '(procedure)))
(hash-set! seen-defns 'procedure-arity-mask (known-function-of-satisfying '(procedure))))

8
racket/src/expander/extract/main.rkt
View File

@ -44,7 +44,10 @@
;; Override linklet compiler's simple inference ;; Override linklet compiler's simple inference
;; of side-effects to remove a module from the ;; of side-effects to remove a module from the
;; flattened form if it's not otherwise referenced: ;; flattened form if it's not otherwise referenced:
#:side-effect-free-modules side-effect-free-modules) #:side-effect-free-modules side-effect-free-modules
;; A list of symbols that should not be defined in the
;; flattened, GCed form:
#:disallows disallows)
;; Located modules: ;; Located modules:
(define compiled-modules (make-hash)) (define compiled-modules (make-hash))
@ -134,7 +137,8 @@
;; Remove unreferenced definitions ;; Remove unreferenced definitions
(define gced-linklet-expr (define gced-linklet-expr
(garbage-collect-definitions simplified-expr)) (garbage-collect-definitions simplified-expr
#:disallows disallows))
(log-status "Checking that references outside the runtime were removed by simplification...") (log-status "Checking that references outside the runtime were removed by simplification...")
(define really-used-names (all-used-symbols gced-linklet-expr)) (define really-used-names (all-used-symbols gced-linklet-expr))

8
racket/src/expander/run.rkt
View File

@ -50,6 +50,7 @@
(define instance-knot-ties (make-hasheq)) (define instance-knot-ties (make-hasheq))
(define primitive-table-directs (make-hasheq)) (define primitive-table-directs (make-hasheq))
(define side-effect-free-modules (make-hash)) (define side-effect-free-modules (make-hash))
(define disallows null)
(define quiet-load? #f) (define quiet-load? #f)
(define startup-module main.rkt) (define startup-module main.rkt)
(define submod-name #f) (define submod-name #f)
@ -100,7 +101,9 @@
[("++depend") file "Record <file> as a dependency" [("++depend") file "Record <file> as a dependency"
(hash-set! dependencies (simplify-path (path->complete-path file)) #t)] (hash-set! dependencies (simplify-path (path->complete-path file)) #t)]
[("++depend-module") mod-file "Add <mod-file> and transitive as dependencies" [("++depend-module") mod-file "Add <mod-file> and transitive as dependencies"
(set! extra-module-dependencies (cons mod-file extra-module-dependencies))] (set! extra-module-dependencies (cons mod-file extra-module-dependencies))]
[("++disallow") id "If <id> is defined in the flattened version, explain why"
(set! disallows (cons (string->symbol id) disallows))]
#:once-each #:once-each
[("--local-rename") "Use simpler names in extracted, instead of a unique name for each binding" [("--local-rename") "Use simpler names in extracted, instead of a unique name for each binding"
(set! local-rename? #t)] (set! local-rename? #t)]
@ -320,7 +323,8 @@
#:local-rename? local-rename? #:local-rename? local-rename?
#:instance-knot-ties instance-knot-ties #:instance-knot-ties instance-knot-ties
#:primitive-table-directs primitive-table-directs #:primitive-table-directs primitive-table-directs
#:side-effect-free-modules side-effect-free-modules)) #:side-effect-free-modules side-effect-free-modules
#:disallows disallows))
(when load-file (when load-file
(load load-file)) (load load-file))

47
racket/src/racket/src/error.c
View File

@ -105,6 +105,7 @@ static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_arguments_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_arguments_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_range_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_range_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_arity_mask_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *error_escape_handler(int, Scheme_Object *[]); static Scheme_Object *error_escape_handler(int, Scheme_Object *[]);
static Scheme_Object *error_display_handler(int, Scheme_Object *[]); static Scheme_Object *error_display_handler(int, Scheme_Object *[]);
@ -817,6 +818,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-result-arity-error", raise_result_arity_error, 2, -1, env); ESCAPING_NONCM_PRIM("raise-result-arity-error", raise_result_arity_error, 2, -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);
@ -2970,20 +2972,29 @@ static int is_arity_list(Scheme_Object *l)
return 1; return 1;
} }
static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[]) static Scheme_Object *do_raise_arity_error(const char *who, int argc, Scheme_Object *argv[], int as_arity)
{ {
Scheme_Object **args; Scheme_Object **args, *arity;
const char *name; const char *name;
int minc, maxc; int minc, maxc;
if (!SCHEME_SYMBOLP(argv[0]) && !SCHEME_PROCP(argv[0])) if (!SCHEME_SYMBOLP(argv[0]) && !SCHEME_PROCP(argv[0]))
scheme_wrong_contract("raise-arity-error", "(or/c symbol? procedure?)", 0, argc, argv); scheme_wrong_contract(who, "(or/c symbol? procedure?)", 0, argc, argv);
if (!scheme_nonneg_exact_p(argv[1]) if (as_arity) {
&& !is_arity_at_least(argv[1]) arity = argv[1];
&& !is_arity_list(argv[1])) if (!scheme_nonneg_exact_p(arity)
scheme_wrong_contract("raise-arity-error", && !is_arity_at_least(arity)
"(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))", && !is_arity_list(arity))
1, argc, argv); scheme_wrong_contract(who,
"(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))",
1, argc, argv);
} else {
if (!scheme_exact_p(argv[1]))
scheme_wrong_contract(who,
"exact-integer?",
1, argc, argv);
arity = scheme_arity_mask_to_arity(argv[1], -1);
}
args = MALLOC_N(Scheme_Object*, argc - 2); args = MALLOC_N(Scheme_Object*, argc - 2);
memcpy(args, argv + 2, sizeof(Scheme_Object*) * (argc - 2)); memcpy(args, argv + 2, sizeof(Scheme_Object*) * (argc - 2));
@ -2995,11 +3006,11 @@ static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
name = scheme_get_proc_name(argv[0], &len, 1); name = scheme_get_proc_name(argv[0], &len, 1);
} }
if (SCHEME_INTP(argv[1])) { if (SCHEME_INTP(arity)) {
minc = maxc = SCHEME_INT_VAL(argv[1]); minc = maxc = SCHEME_INT_VAL(arity);
} else if (is_arity_at_least(argv[1])) { } else if (is_arity_at_least(arity)) {
Scheme_Object *v; Scheme_Object *v;
v = scheme_struct_ref(argv[1], 0); v = scheme_struct_ref(arity, 0);
if (SCHEME_INTP(v)) { if (SCHEME_INTP(v)) {
minc = SCHEME_INT_VAL(v); minc = SCHEME_INT_VAL(v);
maxc = -1; maxc = -1;
@ -3017,6 +3028,16 @@ static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
return NULL; return NULL;
} }
static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
{
return do_raise_arity_error("raise-arity-error", argc, argv, 1);
}
static Scheme_Object *raise_arity_mask_error(int argc, Scheme_Object *argv[])
{
return do_raise_arity_error("raise-arity-mask-error", argc, argv, 0);
}
static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[]) static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[])
{ {
const char *where = NULL, *detail = NULL; const char *where = NULL, *detail = NULL;

476
racket/src/racket/src/fun.c
View File

@ -146,7 +146,9 @@ static Scheme_Object *seconds_to_date(int argc, Scheme_Object **argv);
static Scheme_Object *object_name(int argc, Scheme_Object *argv[]); static Scheme_Object *object_name(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_arity_mask(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_reduce_arity_mask(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]);
@ -193,6 +195,8 @@ typedef void (*DW_PrePost_Proc)(void *);
#define CONS(a,b) scheme_make_pair(a,b) #define CONS(a,b) scheme_make_pair(a,b)
static Scheme_Object *mask_to_arity(Scheme_Object *mask, int mode);
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
static void register_traversers(void); static void register_traversers(void);
#endif #endif
@ -543,16 +547,27 @@ scheme_init_fun (Scheme_Startup_Env *env)
scheme_procedure_arity_includes_proc = o; scheme_procedure_arity_includes_proc = o;
scheme_addto_prim_instance("procedure-arity-includes?", o, env); scheme_addto_prim_instance("procedure-arity-includes?", o, env);
scheme_addto_prim_instance("procedure-arity-mask",
scheme_make_folding_prim(procedure_arity_mask,
"procedure-arity-mask",
1, 1, 1),
env);
scheme_addto_prim_instance("procedure-reduce-arity", scheme_addto_prim_instance("procedure-reduce-arity",
scheme_make_prim_w_arity(procedure_reduce_arity, scheme_make_prim_w_arity(procedure_reduce_arity,
"procedure-reduce-arity", "procedure-reduce-arity",
2, 2), 2, 3),
env); env);
scheme_addto_prim_instance("procedure-rename", scheme_addto_prim_instance("procedure-rename",
scheme_make_prim_w_arity(procedure_rename, scheme_make_prim_w_arity(procedure_rename,
"procedure-rename", "procedure-rename",
2, 2), 2, 2),
env); env);
scheme_addto_prim_instance("procedure-reduce-arity-mask",
scheme_make_prim_w_arity(procedure_reduce_arity_mask,
"procedure-reduce-arity-mask",
2, 3),
env);
scheme_addto_prim_instance("procedure->method", scheme_addto_prim_instance("procedure->method",
scheme_make_prim_w_arity(procedure_to_method, scheme_make_prim_w_arity(procedure_to_method,
"procedure->method", "procedure->method",
@ -1688,7 +1703,7 @@ _scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
/* arity */ /* arity */
/*========================================================================*/ /*========================================================================*/
static Scheme_Object *make_arity(mzshort mina, mzshort maxa, int mode) static Scheme_Object *make_arity(intptr_t mina, intptr_t maxa, int mode)
{ {
if (mina == maxa) if (mina == maxa)
return scheme_make_integer(mina); return scheme_make_integer(mina);
@ -1701,7 +1716,7 @@ static Scheme_Object *make_arity(mzshort mina, mzshort maxa, int mode)
return scheme_make_struct_instance(scheme_arity_at_least, 1, p); return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
} }
} else { } else {
int i; intptr_t i;
Scheme_Object *l = scheme_null; Scheme_Object *l = scheme_null;
for (i = maxa; i >= mina; --i) { for (i = maxa; i >= mina; --i) {
@ -1717,33 +1732,52 @@ Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa)
return make_arity(mina, maxa, -1); return make_arity(mina, maxa, -1);
} }
static Scheme_Object *clone_arity(Scheme_Object *a, int delta, int mode) Scheme_Object *shift_for_drop(Scheme_Object *n, int drop)
{ {
if (SCHEME_PAIRP(a)) { Scheme_Object *a[2];
Scheme_Object *m, *l; a[0] = n;
m = scheme_copy_list(a); a[1] = scheme_make_integer(-drop);
for (l = m; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { return scheme_bitwise_shift(2, a);
a = clone_arity(SCHEME_CAR(l), delta, mode); }
SCHEME_CAR(l) = a;
} static Scheme_Object *make_shifted_one(intptr_t n)
return m; {
} else if (SCHEME_CHAPERONE_STRUCTP(a)) { Scheme_Object *a[2];
Scheme_Object *p[1]; a[0] = scheme_make_integer(1);
a = scheme_struct_ref(a, 0); a[1] = scheme_make_integer(n);
if (delta) return scheme_bitwise_shift(2, a);
a = scheme_bin_minus(a, scheme_make_integer(delta)); }
if (mode == -3) {
return scheme_make_integer(-(SCHEME_INT_VAL(a)+1)); static Scheme_Object *make_arity_mask(intptr_t mina, intptr_t maxa)
{
/* Generate a mask */
if (mina == maxa) {
if (mina < SCHEME_MAX_FAST_ARITY_CHECK)
return scheme_make_integer(1 << mina);
else
return make_shifted_one(mina);
} else if (maxa == -1) {
if (mina < SCHEME_MAX_FAST_ARITY_CHECK) {
return scheme_make_integer(((1 << mina) - 1) ^ (intptr_t)-1);
} else { } else {
p[0] = a; return scheme_bin_bitwise_xor(scheme_bin_minus(make_shifted_one(mina), scheme_make_integer(1)),
return scheme_make_struct_instance(scheme_arity_at_least, 1, p); scheme_make_integer(-1));
} }
} else if (SCHEME_NULLP(a)) } else {
return a; mzshort i;
else if (delta) Scheme_Object *mask = scheme_make_integer(0);
return scheme_bin_minus(a, scheme_make_integer(delta));
else for (i = mina; i <= maxa; i++) {
return a; mask = scheme_bin_bitwise_or(make_shifted_one(i), mask);
}
return mask;
}
}
Scheme_Object *scheme_make_arity_mask(intptr_t mina, intptr_t maxa)
{
return make_arity_mask(mina, maxa);
} }
int scheme_fast_check_arity(Scheme_Object *p, int a) int scheme_fast_check_arity(Scheme_Object *p, int a)
@ -1780,7 +1814,8 @@ int scheme_fast_check_arity(Scheme_Object *p, int a)
static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Object *bign, int inc_ok) static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Object *bign, int inc_ok)
/* a == -1 => get arity /* a == -1 => get arity
a == -2 => check for allowing bignum a == -2 => check for allowing bignum
a == -3 => like -1, but alternate representation using negative numbers for arity-at-least */ a == -3 => like -1, but alternate representation using negative numbers for arity-at-least
a == -4 => mask */
{ {
Scheme_Type type; Scheme_Type type;
mzshort mina, maxa; mzshort mina, maxa;
@ -1815,101 +1850,86 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
Scheme_Case_Lambda *seq; Scheme_Case_Lambda *seq;
Scheme_Lambda *data; Scheme_Lambda *data;
int i; int i;
Scheme_Object *first, *last = NULL, *v; Scheme_Object *mask = scheme_make_integer(0), *v;
if ((a == -1) || (a == -3))
first = scheme_null;
else
first = scheme_false;
seq = (Scheme_Case_Lambda *)p; seq = (Scheme_Case_Lambda *)p;
for (i = 0; i < seq->count; i++) { for (i = 0; i < seq->count; i++) {
v = seq->array[i]; v = seq->array[i];
if (SAME_TYPE(SCHEME_TYPE(v), scheme_lambda_type)) if ((a == -1) || (a == -3) || (a == -4)) {
data = (Scheme_Lambda *)v; mask = scheme_bin_bitwise_or(get_or_check_arity(v, -4, NULL, inc_ok), mask);
else
data = SCHEME_CLOSURE_CODE(v);
mina = maxa = data->num_params;
if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) {
if (mina)
--mina;
maxa = -1;
}
if (a >= 0) {
if ((a + drop) >= mina && (maxa < 0 || (a + drop) <= maxa))
return scheme_true;
} else if (a == -2) {
if (maxa < 0)
return scheme_true;
} else { } else {
if (mina >= drop) { if (SAME_TYPE(SCHEME_TYPE(v), scheme_lambda_type))
mina -= drop; data = (Scheme_Lambda *)v;
if (maxa > 0) else
maxa -= drop; data = SCHEME_CLOSURE_CODE(v);
mina = maxa = data->num_params;
if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) {
if (mina)
--mina;
maxa = -1;
}
v = scheme_make_pair(make_arity(mina, maxa, a), scheme_null); if (a >= 0) {
if (!last) if ((a + drop) >= mina && (maxa < 0 || (a + drop) <= maxa))
first = v; return scheme_true;
else } else if (a == -2) {
SCHEME_CDR(last) = v; if (maxa < 0)
last = v; return scheme_true;
} }
} }
} }
return first; if ((a == -1) || (a == -3) || (a == -4)) {
if (drop && (a == -4))
mask = shift_for_drop(mask, drop);
if (a != -4)
return mask_to_arity(mask, a);
else
return mask;
} else
return scheme_false;
} else if (type == scheme_proc_struct_type) { } else if (type == scheme_proc_struct_type) {
int is_method; int is_method;
if (!inc_ok if (!inc_ok
&& scheme_no_arity_property && scheme_no_arity_property
&& scheme_struct_type_property_ref(scheme_no_arity_property, p)) && scheme_struct_type_property_ref(scheme_no_arity_property, p)) {
return scheme_false; if (a == -4)
return scheme_make_integer(0);
else
return scheme_false;
}
if (scheme_reduced_procedure_struct if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) { && scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
if (a == -4) {
p = ((Scheme_Structure *)p)->slots[1];
if (drop)
return shift_for_drop(p, drop);
else
return p;
}
if (a >= 0) { if (a >= 0) {
bign = scheme_make_integer(a); bign = scheme_make_integer(a);
if (drop) if (drop)
bign = scheme_bin_plus(bign, scheme_make_integer(drop)); bign = scheme_bin_plus(bign, scheme_make_integer(drop));
} }
if ((a == -1) || (a == -3)) if ((a == -1) || (a == -3)) {
return clone_arity(((Scheme_Structure *)p)->slots[1], drop, a); p = ((Scheme_Structure *)p)->slots[1];
else { if (drop)
/* Check arity (or for varargs) */ p = shift_for_drop(p, drop);
Scheme_Object *v; return mask_to_arity(p, a);
v = ((Scheme_Structure *)p)->slots[1]; } else {
if (SCHEME_STRUCTP(v)) { if (scheme_bin_bitwise_bit_set_p(((Scheme_Structure *)p)->slots[1], bign))
v = ((Scheme_Structure *)v)->slots[0]; return scheme_true;
return (scheme_bin_lt_eq(v, bign) else
? scheme_true
: scheme_false);
} else if (SCHEME_PAIRP(v)) {
Scheme_Object *x;
while (!SCHEME_NULLP(v)) {
x = SCHEME_CAR(v);
if (SCHEME_STRUCTP(x)) {
x = ((Scheme_Structure *)x)->slots[0];
if (scheme_bin_lt_eq(x, bign))
return scheme_true;
} else {
if (scheme_bin_eq(x, bign))
return scheme_true;
}
v = SCHEME_CDR(v);
}
return scheme_false; return scheme_false;
} else if (SCHEME_NULLP(v)) {
return scheme_false;
} else {
return (scheme_bin_eq(v, bign)
? scheme_true
: scheme_false);
}
} }
} else { } else {
p = scheme_extract_struct_procedure(p, -1, NULL, &is_method); p = scheme_extract_struct_procedure(p, -1, NULL, &is_method);
if (!SCHEME_PROCP(p)) { if (!SCHEME_PROCP(p)) {
if ((a == -1) || (a == -3)) if (a == -4)
return scheme_make_integer(0);
else if ((a == -1) || (a == -3))
return scheme_null; return scheme_null;
else else
return scheme_false; return scheme_false;
@ -1925,6 +1945,12 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
Scheme_Object *pa; Scheme_Object *pa;
pa = scheme_get_native_arity(p, a); pa = scheme_get_native_arity(p, a);
if (a == -4) {
if (drop)
return shift_for_drop(pa, drop);
else
return pa;
}
if (SCHEME_BOXP(pa)) { if (SCHEME_BOXP(pa)) {
/* Is a method; pa already corrects for it */ /* Is a method; pa already corrects for it */
@ -2040,40 +2066,21 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
if (cases) { if (cases) {
int count = cases_count, i; int count = cases_count, i;
if ((a == -1) || (a == -3) || (a == -4)) {
if ((a == -1) || (a == -3)) { /* Compute mask to get arity so that the arity is normalized */
Scheme_Object *arity, *ae, *last = NULL; Scheme_Object *mask = scheme_make_integer(0);
arity = scheme_alloc_list(count); for (i = 0; i < count; i++) {
mask = scheme_bin_bitwise_or(make_arity_mask(cases[2 * i], cases[(2 * i)+1]), mask);
for (i = 0, ae = arity; i < count; i++) {
Scheme_Object *av;
int mn, mx;
mn = cases[2 * i];
mx = cases[(2 * i) + 1];
if (mn >= drop) {
mn -= drop;
if (mx > 0)
mx -= drop;
av = make_arity(mn, mx, a);
SCHEME_CAR(ae) = av;
last = ae;
ae = SCHEME_CDR(ae);
}
} }
if (drop)
/* If drop > 0, might have found no matches */ mask = shift_for_drop(mask, drop);
if (!SCHEME_NULLP(ae)) {
if (last)
SCHEME_CDR(last) = scheme_null; if (a == -4)
else return mask;
arity = scheme_null; else
} return mask_to_arity(mask, a);
return arity;
} }
if (a == -2) { if (a == -2) {
@ -2098,11 +2105,14 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
return scheme_false; return scheme_false;
} }
if ((a == -1) || (a == -3)) { if ((a == -1) || (a == -3) || (a == -4)) {
if (mina < drop) { if (mina < drop) {
if ((maxa >= 0) && (maxa < drop)) if ((maxa >= 0) && (maxa < drop)) {
return scheme_null; if (a == -4)
else return scheme_make_integer(0);
else
return scheme_null;
} else
mina = 0; mina = 0;
} else } else
mina -= drop; mina -= drop;
@ -2111,6 +2121,9 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
maxa -= drop; maxa -= drop;
} }
if (a == -4)
return make_arity_mask(mina, maxa);
return make_arity(mina, maxa, a); return make_arity(mina, maxa, a);
} }
@ -2130,6 +2143,11 @@ Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, intptr_t a)
return get_or_check_arity(p, a, NULL, 1); return get_or_check_arity(p, a, NULL, 1);
} }
Scheme_Object *scheme_get_arity_mask(Scheme_Object *p)
{
return get_or_check_arity(p, -4, NULL, 1);
}
int scheme_check_proc_arity2(const char *where, int a, int scheme_check_proc_arity2(const char *where, int a,
int which, int argc, Scheme_Object **argv, int which, int argc, Scheme_Object **argv,
int false_ok) int false_ok)
@ -2714,6 +2732,14 @@ static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[])
return get_or_check_arity(argv[0], -1, NULL, 1); return get_or_check_arity(argv[0], -1, NULL, 1);
} }
static Scheme_Object *procedure_arity_mask(int argc, Scheme_Object *argv[])
{
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_contract("procedure-arity-mask", "procedure?", 0, argc, argv);
return get_or_check_arity(argv[0], -4, NULL, 1);
}
static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[]) static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[])
{ {
Scheme_Object *a = argv[0], *v; Scheme_Object *a = argv[0], *v;
@ -2803,7 +2829,7 @@ void scheme_init_reduced_proc_struct(Scheme_Startup_Env *env)
scheme_reduced_procedure_struct = scheme_make_struct_type2(NULL, scheme_reduced_procedure_struct = scheme_make_struct_type2(NULL,
NULL, NULL,
(Scheme_Object *)insp, (Scheme_Object *)insp,
5, 0, 4, 0,
scheme_false, scheme_false,
scheme_null, scheme_null,
scheme_make_integer(0), scheme_make_integer(0),
@ -2811,49 +2837,99 @@ void scheme_init_reduced_proc_struct(Scheme_Startup_Env *env)
} }
} }
static Scheme_Object *arity_to_fast_check_mask(Scheme_Object *aty) static Scheme_Object *arity_to_mask(Scheme_Object *aty)
{ {
if (SCHEME_INTP(aty)) { if (SCHEME_INTP(aty)) {
intptr_t n = SCHEME_INT_VAL(aty); intptr_t n = SCHEME_INT_VAL(aty);
if (n <= SCHEME_MAX_FAST_ARITY_CHECK) if (n <= SCHEME_MAX_FAST_ARITY_CHECK)
return scheme_make_integer(1 << n); return scheme_make_integer(1 << n);
else else
return scheme_make_integer(0); return make_shifted_one(n);
} else if (SCHEME_BIGNUMP(aty)) {
scheme_raise_out_of_memory(NULL, NULL);
return NULL;
} else if (SCHEME_STRUCTP(aty)) { } else if (SCHEME_STRUCTP(aty)) {
Scheme_Object *mask; Scheme_Object *mask;
intptr_t n;
mask = arity_to_fast_check_mask(scheme_struct_ref(aty, 0)); aty = scheme_struct_ref(aty, 0);
n = SCHEME_INTP(mask); if (SCHEME_INTP(aty))
if (!n) return make_arity_mask(SCHEME_INT_VAL(aty), -1);
return mask;
else { else {
/* Set all bits above highest-set bit */ mask = arity_to_mask(aty);
int i; return scheme_bin_bitwise_xor(scheme_bin_minus(mask, scheme_make_integer(1)),
for (i = SCHEME_MAX_FAST_ARITY_CHECK; ; i--) { scheme_make_integer(-1));
if (n & (1 << i))
break;
n |= (1 << i);
}
return scheme_make_integer(n);
} }
} else if (SCHEME_PAIRP(aty)) { } else if (SCHEME_PAIRP(aty)) {
Scheme_Object *mask; Scheme_Object *mask = scheme_make_integer(0);
intptr_t n = 0;
while (SCHEME_PAIRP(aty)) { while (SCHEME_PAIRP(aty)) {
mask = arity_to_fast_check_mask(SCHEME_CAR(aty)); mask = scheme_bin_bitwise_or(arity_to_mask(SCHEME_CAR(aty)), mask);
n |= SCHEME_INT_VAL(mask);
aty = SCHEME_CDR(aty); aty = SCHEME_CDR(aty);
} }
return scheme_make_integer(n); return mask;
} else } else
return scheme_make_integer(0); return scheme_make_integer(0);
} }
static Scheme_Object *mask_to_arity(Scheme_Object *mask, int mode)
static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty, Scheme_Object *name, Scheme_Object *is_meth) {
intptr_t n, pos = 0;
Scheme_Object *l = scheme_null;
while (!SCHEME_INTP(mask)) {
Scheme_Object *a[2], *b;
b = scheme_bin_bitwise_and(mask, scheme_make_integer(0xFFFF));
if (SCHEME_INTP(b)) {
b = scheme_bin_bitwise_and(mask, scheme_make_integer(1));
if (SCHEME_INTP(b))
l = scheme_make_pair(scheme_make_integer(pos), l);
pos++;
a[0] = mask;
a[1] = scheme_make_integer(-1);
mask = scheme_bitwise_shift(2, a);
} else {
pos += 16;
a[0] = mask;
a[1] = scheme_make_integer(-16);
mask = scheme_bitwise_shift(2, a);
}
}
n = SCHEME_INT_VAL(mask);
if (!n) {
if (SCHEME_PAIRP(l) && SCHEME_NULLP(SCHEME_CDR(l)))
return SCHEME_CAR(l);
else
return scheme_reverse(l);
}
while (1) {
if (n == -1) {
if (SCHEME_NULLP(l))
return make_arity(pos, -1, mode);
else
return scheme_reverse(scheme_make_pair(make_arity(pos, -1, mode), l));
} else if (n == 1) {
if (SCHEME_NULLP(l))
return scheme_make_integer(pos);
else
return scheme_reverse(scheme_make_pair(scheme_make_integer(pos), l));
} else if (n & 0x1) {
l = scheme_make_pair(scheme_make_integer(pos), l);
}
pos++;
n >>= 1;
}
}
Scheme_Object *scheme_arity_mask_to_arity(Scheme_Object *mask, int mode)
{
return mask_to_arity(mask, mode);
}
static Scheme_Object *make_reduced_proc(Scheme_Object *proc,
Scheme_Object *mask,
Scheme_Object *name, Scheme_Object *is_meth)
{ {
Scheme_Object *mask;
Scheme_Structure *inst; Scheme_Structure *inst;
if (SCHEME_STRUCTP(proc) if (SCHEME_STRUCTP(proc)
@ -2866,20 +2942,15 @@ static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty,
proc = ((Scheme_Structure *)proc)->slots[0]; proc = ((Scheme_Structure *)proc)->slots[0];
} }
/* A fast-check bitmap, where a bitmap is set in a fixnum if that
many arguments are allowed: */
mask = arity_to_fast_check_mask(aty);
inst = (Scheme_Structure *)scheme_malloc_tagged(sizeof(Scheme_Structure) inst = (Scheme_Structure *)scheme_malloc_tagged(sizeof(Scheme_Structure)
+ ((5 - mzFLEX_DELTA) * sizeof(Scheme_Object *))); + ((4 - mzFLEX_DELTA) * sizeof(Scheme_Object *)));
inst->so.type = scheme_proc_struct_type; inst->so.type = scheme_proc_struct_type;
inst->stype = (Scheme_Struct_Type *)scheme_reduced_procedure_struct; inst->stype = (Scheme_Struct_Type *)scheme_reduced_procedure_struct;
inst->slots[0] = proc; inst->slots[0] = proc;
inst->slots[1] = aty; inst->slots[1] = mask;
inst->slots[2] = (name ? name : scheme_false); inst->slots[2] = (name ? name : scheme_false);
inst->slots[3] = (is_meth ? is_meth : scheme_false); inst->slots[3] = (is_meth ? is_meth : scheme_false);
inst->slots[4] = mask;
return (Scheme_Object *)inst; return (Scheme_Object *)inst;
} }
@ -3049,31 +3120,50 @@ static int proc_is_method(Scheme_Object *proc)
return 0; return 0;
} }
static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]) static Scheme_Object *do_procedure_reduce_arity(const char *who, int argc, Scheme_Object *argv[], int as_arity)
{ {
Scheme_Object *orig, *aty, *is_meth = NULL; Scheme_Object *orig, *mask, *is_meth = NULL, *name = NULL;
if (!SCHEME_PROCP(argv[0])) if (!SCHEME_PROCP(argv[0]))
scheme_wrong_contract("procedure-reduce-arity", "procedure?", 0, argc, argv); scheme_wrong_contract("procedure-reduce-arity", "procedure?", 0, argc, argv);
if (!is_arity(argv[1], 1, 1)) { if (as_arity) {
scheme_wrong_contract("procedure-reduce-arity", if (!is_arity(argv[1], 1, 1)) {
"(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))", scheme_wrong_contract(who,
1, argc, argv); "(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))",
1, argc, argv);
}
mask = arity_to_mask(argv[1]);
} else {
mask = argv[1];
if (!scheme_exact_p(mask)) {
scheme_wrong_contract(who, "exact-integer?", 1, argc, argv);
return NULL;
}
} }
if (argc > 2) {
name = argv[2];
if (SCHEME_FALSEP(name))
name = NULL;
else if (!SCHEME_SYMBOLP(name)) {
scheme_wrong_contract(who, "(or/c symbol? #f)", 2, argc, argv);
return NULL;
}
} else
name = NULL;
/* Check whether current arity covers the requested arity. This is /* Check whether current arity covers the requested arity. */
a bit complicated, because both the source and target can be
lists that include arity-at-least records. */
orig = get_or_check_arity(argv[0], -1, NULL, 1); orig = get_or_check_arity(argv[0], -4, NULL, 1);
aty = clone_arity(argv[1], 0, -1);
if (!is_subarity(aty, orig, 0)) { if (!scheme_bin_eq(scheme_bin_bitwise_and(mask, orig), mask)) {
scheme_contract_error("procedure-reduce-arity", scheme_contract_error(who,
"arity of procedure does not include requested arity", (as_arity
? "arity of procedure does not include requested arity"
: "arity mask of procedure does not include requested arity mask"),
"procedure", 1, argv[0], "procedure", 1, argv[0],
"requested arity", 1, argv[1], (as_arity ? "requested arity" : "requested arity mask"), 1, argv[1],
NULL); NULL);
return NULL; return NULL;
} }
@ -3082,12 +3172,22 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
is_meth = scheme_true; is_meth = scheme_true;
/* Construct a procedure that has the given arity. */ /* Construct a procedure that has the given arity. */
return make_reduced_proc(argv[0], aty, NULL, is_meth); return make_reduced_proc(argv[0], mask, name, is_meth);
}
static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
{
return do_procedure_reduce_arity("procedure-reduce-arity", argc, argv, 1);
}
static Scheme_Object *procedure_reduce_arity_mask(int argc, Scheme_Object *argv[])
{
return do_procedure_reduce_arity("procedure-reduce-arity-mask", argc, argv, 0);
} }
static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]) static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[])
{ {
Scheme_Object *p, *aty; Scheme_Object *p, *mask;
if (!SCHEME_PROCP(argv[0])) if (!SCHEME_PROCP(argv[0]))
scheme_wrong_contract("procedure-rename", "procedure?", 0, argc, argv); scheme_wrong_contract("procedure-rename", "procedure?", 0, argc, argv);
@ -3097,21 +3197,21 @@ static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[])
p = scheme_rename_struct_proc(argv[0], argv[1]); p = scheme_rename_struct_proc(argv[0], argv[1]);
if (p) return p; if (p) return p;
aty = get_or_check_arity(argv[0], -1, NULL, 1); mask = get_or_check_arity(argv[0], -4, NULL, 1);
return make_reduced_proc(argv[0], aty, argv[1], NULL); return make_reduced_proc(argv[0], mask, argv[1], NULL);
} }
static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]) static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[])
{ {
Scheme_Object *aty; Scheme_Object *mask;
if (!SCHEME_PROCP(argv[0])) if (!SCHEME_PROCP(argv[0]))
scheme_wrong_contract("procedure->method", "procedure?", 0, argc, argv); scheme_wrong_contract("procedure->method", "procedure?", 0, argc, argv);
aty = get_or_check_arity(argv[0], -1, NULL, 1); mask = get_or_check_arity(argv[0], -4, NULL, 1);
return make_reduced_proc(argv[0], aty, NULL, scheme_true); return make_reduced_proc(argv[0], mask, NULL, scheme_true);
} }
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]) static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])

53
racket/src/racket/src/jit.c
View File

@ -4474,8 +4474,8 @@ Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode)
cnt = ((Scheme_Native_Closure *)closure)->code->closure_size; cnt = ((Scheme_Native_Closure *)closure)->code->closure_size;
if (cnt < 0) { if (cnt < 0) {
/* Case-lambda */ /* Case-lambda */
Scheme_Object *l = scheme_null, *a; Scheme_Object *l = scheme_make_integer(0);
int i, has_rest, is_method; int i, is_method;
mzshort *arities, v; mzshort *arities, v;
arities = ((Scheme_Native_Closure *)closure)->code->u.arities; arities = ((Scheme_Native_Closure *)closure)->code->u.arities;
@ -4483,20 +4483,16 @@ Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode)
is_method = arities[cnt]; is_method = arities[cnt];
for (i = cnt; i--; ) { for (i = cnt; i--; ) {
v = arities[i]; v = arities[i];
if (v < 0) { if (v < 0)
v = -(v + 1); l = scheme_bin_bitwise_or(scheme_make_arity_mask(-(v+1), -1), l);
has_rest = 1; else
} else l = scheme_bin_bitwise_or(scheme_make_arity_mask(v, v), l);
has_rest = 0; }
if (mode == -3) { if (mode != -4) {
if (has_rest) v = -(v+1); l = scheme_arity_mask_to_arity(l, mode);
a = scheme_make_integer(v); if (is_method)
} else l = scheme_box(l);
a = scheme_make_arity(v, has_rest ? -1 : v);
l = scheme_make_pair(a, l);
} }
if (is_method)
l = scheme_box(l);
return l; return l;
} }
@ -4505,13 +4501,30 @@ Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode)
Scheme_Object *a; Scheme_Object *a;
c.so.type = scheme_closure_type; c.so.type = scheme_closure_type;
c.code = ((Scheme_Native_Closure *)closure)->code->u2.orig_code; c.code = ((Scheme_Native_Closure *)closure)->code->u2.orig_code;
a = scheme_get_or_check_arity((Scheme_Object *)&c, -1); if (mode == -4) {
if (SCHEME_LAMBDA_FLAGS(c.code) & LAMBDA_IS_METHOD) return scheme_get_arity_mask((Scheme_Object *)&c);
a = scheme_box(a); } else {
return a; a = scheme_get_or_check_arity((Scheme_Object *)&c, -1);
if (SCHEME_LAMBDA_FLAGS(c.code) & LAMBDA_IS_METHOD)
a = scheme_box(a);
return a;
}
} }
return sjc.get_arity_code(closure, 0, 0 EXTRA_NATIVE_ARGUMENT); if (mode == -4) {
Scheme_Object *a;
intptr_t n;
a = sjc.get_arity_code(closure, 0, 0 EXTRA_NATIVE_ARGUMENT);
if (SCHEME_BOXP(a)) a = SCHEME_BOX_VAL(a);
n = SCHEME_INT_VAL(a);
if (n < 0)
return scheme_make_arity_mask(-(n+1), -1);
else if (n < SCHEME_MAX_FAST_ARITY_CHECK)
return scheme_make_integer(1 << n);
else
return scheme_make_arity_mask(n, n);
} else
return sjc.get_arity_code(closure, 0, 0 EXTRA_NATIVE_ARGUMENT);
} }
/**********************************************************************/ /**********************************************************************/

8
racket/src/racket/src/jitcall.c
View File

@ -70,7 +70,7 @@ static Scheme_Object *clear_runstack(Scheme_Object **rs, intptr_t amt, Scheme_Ob
static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, GC_CAN_IGNORE jit_insn *refagain) static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, GC_CAN_IGNORE jit_insn *refagain)
{ {
GC_CAN_IGNORE jit_insn *ref2, *ref3, *refz1, *refz2, *refz3, *refz4, *refz5; GC_CAN_IGNORE jit_insn *ref2, *ref3, *refz1, *refz2, *refz3, *refy3, *refz4, *refz5;
GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8, *refz9, *ref9, *ref10; GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8, *refz9, *ref9, *ref10;
ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_struct_type); ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_struct_type);
@ -83,7 +83,8 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
ref3 = jit_bner_p(jit_forward(), JIT_R1, JIT_R2); ref3 = jit_bner_p(jit_forward(), JIT_R1, JIT_R2);
/* Matches reduced arity in a simple way? */ /* Matches reduced arity in a simple way? */
jit_ldxi_p(JIT_R2, JIT_V1, &((Scheme_Structure *)0x0)->slots[4]); jit_ldxi_p(JIT_R2, JIT_V1, &((Scheme_Structure *)0x0)->slots[1]);
refy3 = jit_bmci_l(jit_forward(), JIT_R2, 1); /* not a fixnum? */
refz3 = jit_bmci_l(jit_forward(), JIT_R2, (1 << (num_rands + 1))); refz3 = jit_bmci_l(jit_forward(), JIT_R2, (1 << (num_rands + 1)));
/* Yes, matches */ /* Yes, matches */
@ -91,6 +92,7 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
} else { } else {
/* Too many arguments for fast check, so assume it desn't match */ /* Too many arguments for fast check, so assume it desn't match */
refz3 = jit_beqr_p(jit_forward(), JIT_R1, JIT_R2); refz3 = jit_beqr_p(jit_forward(), JIT_R1, JIT_R2);
refy3 = NULL;
} }
/* It's an applicable struct that is not an arity reduce or the /* It's an applicable struct that is not an arity reduce or the
@ -176,6 +178,8 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
mz_patch_branch(refz1); mz_patch_branch(refz1);
mz_patch_branch(refz2); mz_patch_branch(refz2);
mz_patch_branch(refz3); mz_patch_branch(refz3);
if (refy3)
mz_patch_branch(refy3);
mz_patch_branch(refz4); mz_patch_branch(refz4);
mz_patch_branch(refz5); mz_patch_branch(refz5);
mz_patch_branch(refz6); mz_patch_branch(refz6);

31
racket/src/racket/src/number.c
View File

@ -4229,6 +4229,21 @@ GEN_BIN_INT_OP(bin_bitwise_and, "bitwise-and", &, scheme_bignum_and)
GEN_BIN_INT_OP(bin_bitwise_or, "bitwise-ior", |, scheme_bignum_or) GEN_BIN_INT_OP(bin_bitwise_or, "bitwise-ior", |, scheme_bignum_or)
GEN_BIN_INT_OP(bin_bitwise_xor, "bitwise-xor", ^, scheme_bignum_xor) GEN_BIN_INT_OP(bin_bitwise_xor, "bitwise-xor", ^, scheme_bignum_xor)
Scheme_Object *scheme_bin_bitwise_or(Scheme_Object *a, Scheme_Object *b)
{
return bin_bitwise_or(a, b);
}
Scheme_Object *scheme_bin_bitwise_xor(Scheme_Object *a, Scheme_Object *b)
{
return bin_bitwise_xor(a, b);
}
Scheme_Object *scheme_bin_bitwise_and(Scheme_Object *a, Scheme_Object *b)
{
return bin_bitwise_and(a, b);
}
#define MZ_PUBLIC /**/ #define MZ_PUBLIC /**/
GEN_NARY_OP(MZ_PUBLIC, scheme_bitwise_and, "bitwise-and", bin_bitwise_and, -1, SCHEME_EXACT_INTEGERP, "exact-integer?", GEN_IDENT) GEN_NARY_OP(MZ_PUBLIC, scheme_bitwise_and, "bitwise-and", bin_bitwise_and, -1, SCHEME_EXACT_INTEGERP, "exact-integer?", GEN_IDENT)
@ -4315,16 +4330,12 @@ scheme_bitwise_shift(int argc, Scheme_Object *argv[])
return scheme_bignum_shift(v, shift); return scheme_bignum_shift(v, shift);
} }
static Scheme_Object *bitwise_bit_set_p (int argc, Scheme_Object *argv[]) static Scheme_Object *bin_bitwise_bit_set_p (Scheme_Object *so, Scheme_Object *sb, int argc, Scheme_Object **argv)
{ {
Scheme_Object *so, *sb;
so = argv[0];
if (!SCHEME_EXACT_INTEGERP(so)) { if (!SCHEME_EXACT_INTEGERP(so)) {
scheme_wrong_contract("bitwise-bit-set?", "exact-integer?", 0, argc, argv); scheme_wrong_contract("bitwise-bit-set?", "exact-integer?", 0, argc, argv);
ESCAPED_BEFORE_HERE; ESCAPED_BEFORE_HERE;
} }
sb = argv[1];
if (SCHEME_INTP(sb)) { if (SCHEME_INTP(sb)) {
intptr_t v; intptr_t v;
v = SCHEME_INT_VAL(sb); v = SCHEME_INT_VAL(sb);
@ -4368,6 +4379,16 @@ static Scheme_Object *bitwise_bit_set_p (int argc, Scheme_Object *argv[])
} }
} }
int scheme_bin_bitwise_bit_set_p (Scheme_Object *so, Scheme_Object *sb)
{
return SCHEME_TRUEP(bin_bitwise_bit_set_p(so, sb, 0, NULL));
}
static Scheme_Object *bitwise_bit_set_p (int argc, Scheme_Object *argv[])
{
return bin_bitwise_bit_set_p(argv[0], argv[1], argc, argv);
}
static Scheme_Object *slow_bitwise_bit_field (int argc, Scheme_Object *argv[], static Scheme_Object *slow_bitwise_bit_field (int argc, Scheme_Object *argv[],
Scheme_Object *so, Scheme_Object *sb1, Scheme_Object *sb2) Scheme_Object *so, Scheme_Object *sb1, Scheme_Object *sb2)
{ {

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1 #define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1437 #define EXPECTED_PRIM_COUNT 1440
#ifdef MZSCHEME_SOMETHING_OMITTED #ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP # undef USE_COMPILED_STARTUP

8
racket/src/racket/src/schpriv.h
View File

@ -2446,6 +2446,11 @@ int scheme_bin_lt_eq(const Scheme_Object *n1, const Scheme_Object *n2);
Scheme_Object *scheme_bin_quotient_remainder(const Scheme_Object *n1, const Scheme_Object *n2, Scheme_Object **_rem); Scheme_Object *scheme_bin_quotient_remainder(const Scheme_Object *n1, const Scheme_Object *n2, Scheme_Object **_rem);
Scheme_Object *scheme_bin_bitwise_or(Scheme_Object *a, Scheme_Object *b);
Scheme_Object *scheme_bin_bitwise_xor(Scheme_Object *a, Scheme_Object *b);
Scheme_Object *scheme_bin_bitwise_and(Scheme_Object *a, Scheme_Object *b);
int scheme_bin_bitwise_bit_set_p (Scheme_Object *so, Scheme_Object *sb);
Scheme_Object *scheme_sub1(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_sub1(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_add1(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_add1(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_odd_p(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_odd_p(int argc, Scheme_Object *argv[]);
@ -3411,7 +3416,9 @@ int scheme_any_string_has_null(Scheme_Object *o);
Scheme_Object *scheme_do_exit(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_do_exit(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_make_arity(mzshort minc, mzshort maxc); Scheme_Object *scheme_make_arity(mzshort minc, mzshort maxc);
Scheme_Object *scheme_make_arity_mask(intptr_t minc, intptr_t maxc);
Scheme_Object *scheme_arity(Scheme_Object *p); Scheme_Object *scheme_arity(Scheme_Object *p);
Scheme_Object *scheme_arity_mask_to_arity(Scheme_Object *mask, int mode);
typedef struct { typedef struct {
MZTAG_IF_REQUIRED MZTAG_IF_REQUIRED
@ -3431,6 +3438,7 @@ Scheme_Object *scheme_get_stack_trace(Scheme_Object *mark_set);
XFORM_NONGCING int scheme_fast_check_arity(Scheme_Object *v, int a); XFORM_NONGCING int scheme_fast_check_arity(Scheme_Object *v, int a);
Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, intptr_t a); Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, intptr_t a);
Scheme_Object *scheme_get_arity_mask(Scheme_Object *p);
int scheme_native_arity_check(Scheme_Object *closure, int argc); int scheme_native_arity_check(Scheme_Object *closure, int argc);
Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode); Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode);

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "7.0.0.10" #define MZSCHEME_VERSION "7.0.0.11"
#define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 10 #define MZSCHEME_VERSION_W 11
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

2
racket/src/racket/src/startup.inc
View File

@ -2624,7 +2624,7 @@ static const char *startup_source =
"(begin" "(begin"
"(if(if(procedure? f_0)(procedure-arity-includes? f_0 1) #f)" "(if(if(procedure? f_0)(procedure-arity-includes? f_0 1) #f)"
"(void)" "(void)"
" (let-values () (raise-argument-error 'assf \"(any/c any/c . -> . any/c)\" f_0)))" " (let-values () (raise-argument-error 'assf \"(any/c . -> . any/c)\" f_0)))"
"((letrec-values(((loop_142)" "((letrec-values(((loop_142)"
"(lambda(l_1 t_0)" "(lambda(l_1 t_0)"
"(begin" "(begin"