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

keyword in methods and apply; procedure-reduce-keyword-arity

Browse Source 
svn: r9396
This commit is contained in:
Matthew Flatt 2008-04-22 18:00:04 +00:00
parent 193f1e8ff1
commit e25e7a1098
17 changed files with 680 additions and 177 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/compiler/compiler-unit.ss
View File

@ -137,7 +137,7 @@
(let ([zo (append-zo-suffix f)]) (let ([zo (append-zo-suffix f)])
(compile-to-zo f zo n prefix))))) (compile-to-zo f zo n prefix)))))
(define (compile-directory dir info) (define (compile-directory dir info #:verbose [verbose? #t])
(define info* (or info (lambda (key mk-default) (mk-default)))) (define info* (or info (lambda (key mk-default) (mk-default))))
(define make (c-dynamic-require 'make/make-unit 'make@)) (define make (c-dynamic-require 'make/make-unit 'make@))
(define coll (c-dynamic-require 'make/collection-unit 'make:collection@)) (define coll (c-dynamic-require 'make/collection-unit 'make:collection@))
@ -161,7 +161,9 @@
(parameterize ([current-directory dir] (parameterize ([current-directory dir]
[current-load-relative-directory dir] [current-load-relative-directory dir]
;; Verbose compilation manager: ;; Verbose compilation manager:
;; [manager-trace-handler (lambda (s) (printf "~a\n" s))] [manager-trace-handler (if verbose?
(lambda (s) (printf "~a\n" s))
(manager-trace-handler))]
[manager-compile-notify-handler [manager-compile-notify-handler
(lambda (path) ((compile-notify-handler) path))]) (lambda (path) ((compile-notify-handler) path))])
;; Compile the collection files via make-collection ;; Compile the collection files via make-collection
@ -189,7 +191,8 @@
(define (compile-collection-zos collection . cp) (define (compile-collection-zos collection . cp)
(compile-directory (apply collection-path collection cp) (compile-directory (apply collection-path collection cp)
(c-get-info (cons collection cp)))) (c-get-info (cons collection cp))
#:verbose #f))
(define compile-directory-zos compile-directory) (define compile-directory-zos compile-directory)

3
collects/mysterx/installer.ss
View File

@ -13,7 +13,8 @@
[regsvr (and winsys-dir (build-path winsys-dir "REGSVR32.EXE"))]) [regsvr (and winsys-dir (build-path winsys-dir "REGSVR32.EXE"))])
(cond (cond
[(not (eq? (system-type) 'windows)) [(not (eq? (system-type) 'windows))
(printf "Warning: can't install MysterX on non-Windows machine\n")] ;; (printf "Warning: can't install MysterX on non-Windows machine\n")
(void)]
[(not (andmap file-exists? dll-paths)) [(not (andmap file-exists? dll-paths))
(printf "Warning: MysterX binaries not installed\n")] (printf "Warning: MysterX binaries not installed\n")]
[(not winsys-dir) [(not winsys-dir)

10
collects/mzscheme/mzscheme.scrbl
View File

@ -16,7 +16,7 @@
@(define-syntax-rule (def-base base-define base-define-struct @(define-syntax-rule (def-base base-define base-define-struct
base-if base-cond base-case base-top-interaction base-if base-cond base-case base-top-interaction
base-open-input-file base-open-input-file base-apply
base-free-identifier=? base-free-template-identifier=? base-free-identifier=? base-free-template-identifier=?
base-free-transformer-identifier=? base-free-label-identifier=?) base-free-transformer-identifier=? base-free-label-identifier=?)
(begin (begin
@ -28,13 +28,14 @@
(define base-case (scheme case)) (define base-case (scheme case))
(define base-top-interaction (scheme #%top-interaction)) (define base-top-interaction (scheme #%top-interaction))
(define base-open-input-file (scheme open-input-file)) (define base-open-input-file (scheme open-input-file))
(define base-apply (scheme apply))
(define base-free-identifier=? (scheme free-identifier=?)) (define base-free-identifier=? (scheme free-identifier=?))
(define base-free-template-identifier=? (scheme free-template-identifier=?)) (define base-free-template-identifier=? (scheme free-template-identifier=?))
(define base-free-transformer-identifier=? (scheme free-transformer-identifier=?)) (define base-free-transformer-identifier=? (scheme free-transformer-identifier=?))
(define base-free-label-identifier=? (scheme free-label-identifier=?)))) (define base-free-label-identifier=? (scheme free-label-identifier=?))))
@(def-base base-define base-define-struct @(def-base base-define base-define-struct
base-if base-cond base-case base-top-interaction base-if base-cond base-case base-top-interaction
base-open-input-file base-open-input-file base-apply
base-free-identifier=? base-free-template-identifier=? base-free-identifier=? base-free-template-identifier=?
base-free-transformer-identifier=? base-free-label-identifier=?) base-free-transformer-identifier=? base-free-label-identifier=?)
@ -195,6 +196,11 @@ The same as @|base-top-interaction| in @schememodname[scheme/base].}
@section{Old Functions} @section{Old Functions}
@defproc[(apply [proc procedure?] [v any/c] ... [lst list?]) any]{
Like @base-apply from @schememodname[scheme/base], but without support
for keyword arguments.}
@deftogether[( @deftogether[(
@defproc[(open-input-file [file path-string?] [mode (one-of/c 'text 'binary) 'binary]) @defproc[(open-input-file [file path-string?] [mode (one-of/c 'text 'binary) 'binary])
input-port?] input-port?]

56
collects/scheme/private/class-internal.ss
View File

@ -179,6 +179,7 @@
(kernel-form-identifier-list) (kernel-form-identifier-list)
(list (list
(quote-syntax #%app) ; scheme/base app, as opposed to #%plain-app (quote-syntax #%app) ; scheme/base app, as opposed to #%plain-app
(quote-syntax lambda) ; scheme/base lambda, as opposed to #%plain-lambda
(quote-syntax -init) (quote-syntax -init)
(quote-syntax init-rest) (quote-syntax init-rest)
(quote-syntax -field) (quote-syntax -field)
@ -317,6 +318,24 @@
(and (stx-pair? vars) (and (stx-pair? vars)
(identifier? (stx-car vars)) (identifier? (stx-car vars))
(vars-ok? (stx-cdr vars))))) (vars-ok? (stx-cdr vars)))))
(define (kw-vars-ok? vars)
(or (identifier? vars)
(stx-null? vars)
(and (stx-pair? vars)
(let ([a (stx-car vars)]
[opt-arg-ok?
(lambda (a)
(or (identifier? a)
(and (stx-pair? a)
(identifier? (stx-car a))
(stx-pair? (stx-cdr a))
(stx-null? (stx-cdr (stx-cdr a))))))])
(or (and (opt-arg-ok? a)
(kw-vars-ok? (stx-cdr vars)))
(and (keyword? (syntax-e a))
(stx-pair? (stx-cdr vars))
(opt-arg-ok? (stx-car (stx-cdr vars)))
(kw-vars-ok? (stx-cdr (stx-cdr vars)))))))))
;; mk-name: constructs a method name ;; mk-name: constructs a method name
;; for error reporting, etc. ;; for error reporting, etc.
(define (mk-name name) (define (mk-name name)
@ -332,23 +351,52 @@
#f)) #f))
;; -- tranform loop starts here -- ;; -- tranform loop starts here --
(let loop ([stx orig-stx][can-expand? #t][name name][locals null]) (let loop ([stx orig-stx][can-expand? #t][name name][locals null])
(syntax-case stx (#%plain-lambda case-lambda letrec-values let-values) (syntax-case stx (#%plain-lambda lambda case-lambda letrec-values let-values)
[(#%plain-lambda vars body1 body ...) [(lam vars body1 body ...)
(vars-ok? (syntax vars)) (or (and (free-identifier=? #'lam #'#%plain-lambda)
(vars-ok? (syntax vars)))
(and (free-identifier=? #'lam #'lambda)
(kw-vars-ok? (syntax vars))))
(if xform? (if xform?
(with-syntax ([the-obj the-obj] (with-syntax ([the-obj the-obj]
[the-finder the-finder] [the-finder the-finder]
[name (mk-name name)]) [name (mk-name name)])
(with-syntax ([vars (if (free-identifier=? #'lam #'lambda)
(let loop ([vars #'vars])
(cond
[(identifier? vars) vars]
[(syntax? vars)
(datum->syntax vars
(loop (syntax-e vars))
vars
vars)]
[(pair? vars)
(syntax-case (car vars) ()
[(id expr)
(identifier? #'id)
;; optional argument; need to wrap arg expression
(cons
(with-syntax ([expr (syntax/loc #'expr
(let-syntax ([the-finder (quote-syntax the-obj)])
(#%expression expr)))])
(syntax/loc (car vars)
(id expr)))
(loop (cdr vars)))]
[_ (cons (car vars) (loop (cdr vars)))])]
[else vars]))
#'vars)])
(let ([l (syntax/loc stx (let ([l (syntax/loc stx
(lambda (the-obj . vars) (lambda (the-obj . vars)
(let-syntax ([the-finder (quote-syntax the-obj)]) (let-syntax ([the-finder (quote-syntax the-obj)])
body1 body ...)))]) body1 body ...)))])
(with-syntax ([l (recertify (add-method-property l) stx)]) (with-syntax ([l (recertify (add-method-property l) stx)])
(syntax/loc stx (syntax/loc stx
(let ([name l]) name))))) (let ([name l]) name))))))
stx)] stx)]
[(#%plain-lambda . _) [(#%plain-lambda . _)
(bad "ill-formed lambda expression for method" stx)] (bad "ill-formed lambda expression for method" stx)]
[(lambda . _)
(bad "ill-formed lambda expression for method" stx)]
[(case-lambda [vars body1 body ...] ...) [(case-lambda [vars body1 body ...] ...)
(andmap vars-ok? (syntax->list (syntax (vars ...)))) (andmap vars-ok? (syntax->list (syntax (vars ...))))
(if xform? (if xform?

67
collects/scheme/private/classidmap.ss
View File

@ -1,7 +1,8 @@
(module classidmap mzscheme (module classidmap scheme/base
(require syntax/stx) (require syntax/stx
(require-for-template mzscheme "class-events.ss") (for-syntax scheme/base)
(for-template scheme/base "class-events.ss"))
(define-values (struct:s!t make-s!t s!t? s!t-ref s!t-set!) (define-values (struct:s!t make-s!t s!t? s!t-ref s!t-set!)
(make-struct-type 'set!-transformer #f 2 0 #f null (current-inspector) 0)) (make-struct-type 'set!-transformer #f 2 0 #f null (current-inspector) 0))
@ -21,7 +22,7 @@
(define (find the-finder name src) (define (find the-finder name src)
(let ([this-id (syntax-local-value (syntax-local-get-shadower the-finder))]) (let ([this-id (syntax-local-value (syntax-local-get-shadower the-finder))])
(datum->syntax-object this-id name src))) (datum->syntax this-id name src)))
;; Check Syntax binding info: ;; Check Syntax binding info:
(define (binding from to stx) (define (binding from to stx)
@ -29,16 +30,16 @@
(define (make-this-map orig-id the-finder the-obj) (define (make-this-map orig-id the-finder the-obj)
(let ([set!-stx (datum->syntax-object the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
orig-id orig-id
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(set! id expr) [(set! id expr)
(module-identifier=? (syntax set!) set!-stx) (free-identifier=? (syntax set!) set!-stx)
(raise-syntax-error 'class "cannot mutate object identifier" stx)] (raise-syntax-error 'class "cannot mutate object identifier" stx)]
[(id . args) [(id . args)
(datum->syntax-object (datum->syntax
stx stx
(cons (find the-finder the-obj stx) (syntax args)) (cons (find the-finder the-obj stx) (syntax args))
stx)] stx)]
@ -46,14 +47,14 @@
(define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized (define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized
field-accessor field-mutator field-pos/null) field-accessor field-mutator field-pos/null)
(let ([set!-stx (datum->syntax-object the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
the-binder-localized the-binder-localized
(lambda (stx) (lambda (stx)
(with-syntax ([obj-expr (find the-finder the-obj stx)]) (with-syntax ([obj-expr (find the-finder the-obj stx)])
(syntax-case stx () (syntax-case stx ()
[(set! id expr) [(set! id expr)
(module-identifier=? (syntax set!) set!-stx) (free-identifier=? (syntax set!) set!-stx)
(with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [id expr]))] (with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [id expr]))]
[trace (syntax/loc stx (set-event obj (quote id) id))] [trace (syntax/loc stx (set-event obj (quote id) id))]
[set (quasisyntax/loc stx [set (quasisyntax/loc stx
@ -82,18 +83,18 @@
(syntax/loc stx (let* bindings get))))])))))) (syntax/loc stx (let* bindings get))))]))))))
(define (make-method-map the-finder the-obj the-binder the-binder-localized method-accessor) (define (make-method-map the-finder the-obj the-binder the-binder-localized method-accessor)
(let ([set!-stx (datum->syntax-object the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
the-binder-localized the-binder-localized
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(set! id expr) [(set! id expr)
(module-identifier=? (syntax set!) set!-stx) (free-identifier=? (syntax set!) set!-stx)
(raise-syntax-error 'class "cannot mutate method" stx)] (raise-syntax-error 'class "cannot mutate method" stx)]
[(id . args) [(id . args)
(binding (binding
the-binder (syntax id) the-binder (syntax id)
(datum->syntax-object (datum->syntax
the-finder the-finder
(make-method-apply (make-method-apply
(list method-accessor (find the-finder the-obj stx)) (list method-accessor (find the-finder the-obj stx))
@ -109,18 +110,18 @@
;; For methods that are dirrectly available via their names ;; For methods that are dirrectly available via their names
;; (e.g., private methods) ;; (e.g., private methods)
(define (make-direct-method-map the-finder the-obj the-binder the-binder-localized new-name) (define (make-direct-method-map the-finder the-obj the-binder the-binder-localized new-name)
(let ([set!-stx (datum->syntax-object the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
the-binder-localized the-binder-localized
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(set! id expr) [(set! id expr)
(module-identifier=? (syntax set!) set!-stx) (free-identifier=? (syntax set!) set!-stx)
(raise-syntax-error 'class "cannot mutate method" stx)] (raise-syntax-error 'class "cannot mutate method" stx)]
[(id . args) [(id . args)
(binding (binding
the-binder (syntax id) the-binder (syntax id)
(datum->syntax-object (datum->syntax
the-finder the-finder
(make-method-apply (find the-finder new-name stx) (find the-finder the-obj stx) (syntax args)) (make-method-apply (find the-finder new-name stx) (find the-finder the-obj stx) (syntax args))
stx))] stx))]
@ -131,18 +132,18 @@
stx)]))))) stx)])))))
(define (make-rename-super-map the-finder the-obj the-binder the-binder-localized rename-temp) (define (make-rename-super-map the-finder the-obj the-binder the-binder-localized rename-temp)
(let ([set!-stx (datum->syntax-object the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
the-binder-localized the-binder-localized
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(set! id expr) [(set! id expr)
(module-identifier=? (syntax set!) set!-stx) (free-identifier=? (syntax set!) set!-stx)
(raise-syntax-error 'class "cannot mutate super method" stx)] (raise-syntax-error 'class "cannot mutate super method" stx)]
[(id . args) [(id . args)
(binding (binding
the-binder (syntax id) the-binder (syntax id)
(datum->syntax-object (datum->syntax
the-finder the-finder
(make-method-apply (find the-finder rename-temp stx) (find the-finder the-obj stx) (syntax args)) (make-method-apply (find the-finder rename-temp stx) (find the-finder the-obj stx) (syntax args))
stx))] stx))]
@ -153,33 +154,33 @@
stx)]))))) stx)])))))
(define (make-rename-inner-map the-finder the-obj the-binder the-binder-localized rename-temp) (define (make-rename-inner-map the-finder the-obj the-binder the-binder-localized rename-temp)
(let ([set!-stx (datum->syntax-object the-finder 'set!)] (let ([set!-stx (datum->syntax the-finder 'set!)]
[lambda-stx (datum->syntax-object the-finder 'lambda)]) [lambda-stx (datum->syntax the-finder 'lambda)])
(mk-set!-trans (mk-set!-trans
the-binder-localized the-binder-localized
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(set! id expr) [(set! id expr)
(module-identifier=? (syntax set!) set!-stx) (free-identifier=? (syntax set!) set!-stx)
(raise-syntax-error 'class "cannot mutate inner method" stx)] (raise-syntax-error 'class "cannot mutate inner method" stx)]
[(id (lambda () default) . args) [(id (lambda () default) . args)
(module-identifier=? (syntax lambda) lambda-stx) (free-identifier=? (syntax lambda) lambda-stx)
(let ([target (find the-finder the-obj stx)]) (let ([target (find the-finder the-obj stx)])
(binding (binding
the-binder (syntax id) the-binder (syntax id)
(datum->syntax-object (datum->syntax
the-finder the-finder
(make-method-apply (list (find the-finder rename-temp stx) target #'default) (make-method-apply (list (find the-finder rename-temp stx) target #'default)
target (syntax args)) target (syntax args))
stx)))] stx)))]
[(id (lambda largs default) . args) [(id (lambda largs default) . args)
(module-identifier=? (syntax lambda) lambda-stx) (free-identifier=? (syntax lambda) lambda-stx)
(raise-syntax-error (raise-syntax-error
'class 'class
"misuse of inner method (lambda for default does not take zero arguments)" "misuse of inner method (lambda for default does not take zero arguments)"
stx)] stx)]
[(id (lambda . rest) . args) [(id (lambda . rest) . args)
(module-identifier=? (syntax lambda) lambda-stx) (free-identifier=? (syntax lambda) lambda-stx)
(raise-syntax-error (raise-syntax-error
'class 'class
"misuse of inner method (ill-formed lambda for default)" "misuse of inner method (ill-formed lambda for default)"
@ -196,7 +197,7 @@
stx)]))))) stx)])))))
(define (generate-super-call stx the-finder the-obj rename-temp args) (define (generate-super-call stx the-finder the-obj rename-temp args)
(datum->syntax-object (datum->syntax
the-finder the-finder
(make-method-apply (find the-finder rename-temp stx) (make-method-apply (find the-finder rename-temp stx)
(find the-finder the-obj stx) (find the-finder the-obj stx)
@ -204,10 +205,10 @@
stx)) stx))
(define (generate-inner-call stx the-finder the-obj default-expr rename-temp args) (define (generate-inner-call stx the-finder the-obj default-expr rename-temp args)
(datum->syntax-object (datum->syntax
the-finder the-finder
(let ([target (find the-finder the-obj stx)]) (let ([target (find the-finder the-obj stx)])
(datum->syntax-object (datum->syntax
the-finder the-finder
`(let ([i (,(find the-finder rename-temp stx) ,target)]) `(let ([i (,(find the-finder rename-temp stx) ,target)])
(if i (if i
@ -231,14 +232,14 @@
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(set! id expr) [(set! id expr)
(module-identifier=? (syntax set!) set!-stx) (free-identifier=? (syntax set!) set!-stx)
(with-syntax ([local-id local-id]) (with-syntax ([local-id local-id])
(syntax/loc stx (set! local-id expr)))] (syntax/loc stx (set! local-id expr)))]
[(id . args) [(id . args)
(with-syntax ([local-id local-id] (with-syntax ([local-id local-id]
[#%app #%app-stx]) [#%app #%app-stx])
(syntax/loc stx (#%app local-id . args)))] (syntax/loc stx (#%app local-id . args)))]
[_else (datum->syntax-object [_else (datum->syntax
local-id local-id
(syntax-e local-id) (syntax-e local-id)
stx stx
@ -258,7 +259,7 @@
(syntax-case stx () (syntax-case stx ()
[(set! id expr) [(set! id expr)
(and (identifier? (syntax id)) (and (identifier? (syntax id))
(module-identifier=? (syntax set!) set!-stx)) (free-identifier=? (syntax set!) set!-stx))
(raise-syntax-error 'with-method "cannot mutate method" stx)] (raise-syntax-error 'with-method "cannot mutate method" stx)]
[(id . args) [(id . args)
(identifier? (syntax id)) (identifier? (syntax id))
@ -328,7 +329,7 @@
(with-syntax ([object object-stx] (with-syntax ([object object-stx]
[method method-proc-stx] [method method-proc-stx]
[app (if rest-arg? (qstx apply) (qstx #%plain-app))] [app (if rest-arg? (qstx apply) (qstx #%app))]
[args args-stx]) [args args-stx])
(if traced? (if traced?
(with-syntax ([(mth obj) (generate-temporaries (with-syntax ([(mth obj) (generate-temporaries
@ -346,7 +347,7 @@
finalize-call-event)))) finalize-call-event))))
(qstx (app method object . args))))) (qstx (app method object . args)))))
(provide (protect make-this-map make-field-map make-method-map (provide (protect-out make-this-map make-field-map make-method-map
make-direct-method-map make-direct-method-map
make-rename-super-map make-rename-inner-map make-rename-super-map make-rename-inner-map
make-init-error-map make-init-redirect super-error-map make-init-error-map make-init-redirect super-error-map

132
collects/scheme/private/kw.ss
View File

@ -16,11 +16,16 @@
new-app new-app
(rename *make-keyword-procedure make-keyword-procedure) (rename *make-keyword-procedure make-keyword-procedure)
keyword-apply keyword-apply
procedure-keywords) procedure-keywords
procedure-reduce-keyword-arity)
;; ---------------------------------------- ;; ----------------------------------------
(-define-struct keyword-procedure (proc required allowed)) (-define-struct keyword-procedure (proc required allowed))
(define-values (struct:keyword-method make-km keyword-method? km-ref km-set!)
(make-struct-type 'procedure
struct:keyword-procedure
0 0 #f))
(define (generate-arity-string proc) (define (generate-arity-string proc)
(let-values ([(req allowed) (procedure-keywords proc)] (let-values ([(req allowed) (procedure-keywords proc)]
@ -42,18 +47,28 @@
(if (null? (cdr req)) (if (null? (cdr req))
(format " and ~a" (car req)) (format " and ~a" (car req))
(format " ~a,~a" (car req) (format " ~a,~a" (car req)
(loop (cdr req)))))])))]) (loop (cdr req)))))])))]
[(method-adjust)
(lambda (a)
(if (or (okm? proc)
(keyword-method? proc))
(if (zero? a) 0 (sub1 a))
a))])
(string-append (string-append
(cond (cond
[(number? a) (format "~a argument~a" a (if (= a 1) "" "s"))] [(number? a)
(let ([a (method-adjust a)])
(format "~a argument~a" a (if (= a 1) "" "s")))]
[(arity-at-least? a) [(arity-at-least? a)
(let ([a (arity-at-least-value a)]) (let ([a (method-adjust (arity-at-least-value a))])
(format "at least ~a argument~a" a (if (= a 1) "" "s")))] (format "at least ~a argument~a" a (if (= a 1) "" "s")))]
[else [else
"a different number of arguments"]) "a different number of arguments"])
(if (null? req) (if (null? req)
"" ""
(format " plus ~a" (keywords-desc "" req))) (format " plus ~a" (keywords-desc "" req)))
(if allowed
(let ([others (let loop ([req req][allowed allowed]) (let ([others (let loop ([req req][allowed allowed])
(cond (cond
[(null? req) allowed] [(null? req) allowed]
@ -64,7 +79,8 @@
(if (null? others) (if (null? others)
"" ""
(format " plus ~a" (format " plus ~a"
(keywords-desc "optional " others))))))) (keywords-desc "optional " others))))
" plus arbitrary keyword arguments"))))
;; Constructor for a procedure with only optional keywords. ;; Constructor for a procedure with only optional keywords.
;; The `procedure' property dispatches to a procedure in the ;; The `procedure' property dispatches to a procedure in the
@ -76,15 +92,23 @@
(list (cons prop:arity-string generate-arity-string)) (list (cons prop:arity-string generate-arity-string))
(current-inspector) 0)) (current-inspector) 0))
;; A ``method'' (for arity reporting)
(define-values (struct:okm make-optional-keyword-method okm? okm-ref okm-set!)
(make-struct-type 'procedure
struct:okp
0 0 #f))
;; Constructor generator for a procedure with a required keyword. ;; Constructor generator for a procedure with a required keyword.
;; (This is used with lift-expression, so that the same constructor ;; (This is used with lift-expression, so that the same constructor
;; is used for each evaluation of a keyword lambda.) ;; is used for each evaluation of a keyword lambda.)
;; The `procedure' property is a per-type method that has exactly ;; The `procedure' property is a per-type method that has exactly
;; the right arity, and that sends all arguments to `missing-kw'. ;; the right arity, and that sends all arguments to `missing-kw'.
(define (make-required name fail-proc) (define (make-required name fail-proc method?)
(let-values ([(s: mk ? -ref -set!) (let-values ([(s: mk ? -ref -set!)
(make-struct-type (string->symbol (format "procedure:~a" name)) (make-struct-type (string->symbol (format "procedure:~a" name))
struct:keyword-procedure (if method?
struct:keyword-method
struct:keyword-procedure)
0 0 #f 0 0 #f
(list (cons prop:arity-string generate-arity-string)) (list (cons prop:arity-string generate-arity-string))
(current-inspector) fail-proc)]) (current-inspector) fail-proc)])
@ -294,7 +318,8 @@
(lambda (a b) (keyword<? (syntax-e a) (syntax-e b))))] (lambda (a b) (keyword<? (syntax-e a) (syntax-e b))))]
[sorted-kws (sort (map list kws kw-args kw-arg?s kw-reqs) [sorted-kws (sort (map list kws kw-args kw-arg?s kw-reqs)
(lambda (a b) (keyword<? (syntax-e (car a)) (lambda (a b) (keyword<? (syntax-e (car a))
(syntax-e (car b)))))]) (syntax-e (car b)))))]
[method? (syntax-property stx 'method-arity-error)])
(with-syntax ([(kw-arg ...) kw-args] (with-syntax ([(kw-arg ...) kw-args]
[(kw-arg? ...) (let loop ([kw-arg?s kw-arg?s] [(kw-arg? ...) (let loop ([kw-arg?s kw-arg?s]
[kw-reqs kw-reqs]) [kw-reqs kw-reqs])
@ -318,7 +343,11 @@
'(null))] '(null))]
[fail-rest (if (null? (syntax-e #'rest)) [fail-rest (if (null? (syntax-e #'rest))
'(null) '(null)
#'rest)]) #'rest)]
[make-okp (if method?
#'make-optional-keyword-method
#'make-optional-keyword-procedure)]
[method? method?])
(let ([with-core (let ([with-core
(lambda (result) (lambda (result)
@ -400,7 +429,7 @@
p))] p))]
[with-kws (mk-with-kws)]) [with-kws (mk-with-kws)])
(syntax/loc stx (syntax/loc stx
(make-optional-keyword-procedure (make-okp
with-kws with-kws
null null
'kws 'kws
@ -416,7 +445,7 @@
[mk-id (with-syntax ([n (syntax-local-infer-name stx)] [mk-id (with-syntax ([n (syntax-local-infer-name stx)]
[call-fail (mk-kw-arity-stub)]) [call-fail (mk-kw-arity-stub)])
(syntax-local-lift-expression (syntax-local-lift-expression
#'(make-required 'n call-fail)))]) #'(make-required 'n call-fail method?)))])
(syntax/loc stx (syntax/loc stx
(mk-id (mk-id
with-kws with-kws
@ -675,7 +704,7 @@
(values (car required) #f))] (values (car required) #f))]
[(and (pair? required) [(and (pair? required)
(eq? (car required) (car kws))) (eq? (car required) (car kws)))
(loop (cdr kws) (cdr required) (cdr allowed))] (loop (cdr kws) (cdr required) (and allowed (cdr allowed)))]
[(not allowed) ; => all keywords are allowed [(not allowed) ; => all keywords are allowed
(loop (cdr kws) required #f)] (loop (cdr kws) required #f)]
[(pair? allowed) [(pair? allowed)
@ -708,7 +737,12 @@
(let-values ([(missing-kw extra-kw) (let-values ([(missing-kw extra-kw)
(if (keyword-procedure? p) (if (keyword-procedure? p)
(check-kw-args p kws) (check-kw-args p kws)
(values #f (car kws)))]) (values #f (car kws)))]
[(n) (if (and (positive? n)
(or (keyword-method? p)
(okm? p)))
(sub1 n)
n)])
(let ([args-str (let ([args-str
(if (and (null? args) (if (and (null? args)
(null? kws)) (null? kws))
@ -751,8 +785,76 @@
(format (format
(string-append (string-append
"procedure application: no case matching ~a non-keyword" "procedure application: no case matching ~a non-keyword"
" arguments for: ~e; ~a") " argument~a for: ~e; ~a")
(- n 2) (- n 2)
(if (= 1 (- n 2)) "" "s")
p p
args-str))) args-str)))
(current-continuation-marks))))))))))) (current-continuation-marks))))))))))
;; setting procedure arity
(define (procedure-reduce-keyword-arity proc arity req-kw allowed-kw)
(let ([plain-proc (procedure-reduce-arity (if (okp? proc)
(okp-ref proc 0)
proc)
arity)])
(define (sorted? kws)
(let loop ([kws kws])
(cond
[(null? kws) #t]
[(null? (cdr kws)) #t]
[(keyword<? (car kws) (cadr kws)) (loop (cdr kws))]
[else #f])))
(define (subset? a b)
(cond
[(null? a) #t]
[(null? b) #f]
[(eq? (car a) (car b)) (subset? (cdr a) (cdr b))]
[(keyword<? (car a) (car b)) #f]
[else (subset? a (cdr b))]))
(unless (and (list? req-kw) (andmap keyword? req-kw)
(sorted? req-kw))
(raise-type-error 'procedure-reduce-keyword-arity "sorted list of keywords"
2 proc arity req-kw allowed-kw))
(when allowed-kw
(unless (and (list? allowed-kw) (andmap keyword? allowed-kw)
(sorted? allowed-kw))
(raise-type-error 'procedure-reduce-keyword-arity "sorted list of keywords or #f"
2 proc arity req-kw allowed-kw))
(unless (subset? req-kw allowed-kw)
(raise-mismatch-error 'procedure-reduce-keyword-arity
"allowed-keyword list does not include all required keywords: "
allowed-kw)))
(let ([old-req (if (keyword-procedure? proc)
(keyword-procedure-required proc)
null)]
[old-allowed (if (keyword-procedure? proc)
(keyword-procedure-allowed proc)
null)])
(unless (subset? old-req req-kw)
(raise-mismatch-error 'procedure-reduce-keyword-arity
"cannot reduce required keyword set: "
old-req))
(when old-allowed
(unless (subset? req-kw old-allowed)
(raise-mismatch-error 'procedure-reduce-keyword-arity
"cannot require keywords not in original allowed set: "
old-allowed))
(unless (or (not allowed-kw)
(subset? allowed-kw old-allowed))
(raise-mismatch-error 'procedure-reduce-keyword-arity
"cannot allow keywords not in original allowed set: "
old-allowed))))
(make-optional-keyword-procedure
(procedure-reduce-arity (keyword-procedure-proc proc)
(let loop ([a arity])
(cond
[(integer? a) (+ a 2)]
[(arity-at-least? a)
(make-arity-at-least (+ (arity-at-least-value a) 2))]
[else
(map loop a)])))
req-kw
allowed-kw
plain-proc))))

36
collects/scheme/private/pre-base.ss
View File

@ -25,6 +25,36 @@
stx)) stx))
(datum->syntax stx (cdr (syntax-e stx)) stx stx))) (datum->syntax stx (cdr (syntax-e stx)) stx stx)))
(define-values (new-apply)
(make-keyword-procedure
(lambda (kws kw-args proc args . rest)
(keyword-apply proc kws kw-args (apply list* args rest)))
apply))
(define-values (new-keyword-apply)
(make-keyword-procedure
(lambda (kws kw-args proc orig-kws orig-kw-args args . rest)
(let-values ([(kws kw-args)
(let loop ([kws kws] [kw-args kw-args]
[kws2 orig-kws] [kw-args2 orig-kw-args]
[swapped? #f])
(cond
[(null? kws) (values kws2 kw-args2)]
[(null? kws2) (values kws kw-args)]
[(keyword<? (car kws) (car kws2))
(let-values ([(res-kws res-kw-args)
(loop (cdr kws) (cdr kw-args) kws2 kw-args2 #f)])
(values (cons (car kws) res-kws)
(cons (car kw-args) res-kw-args)))]
[swapped?
(raise-mismatch-error
'keyword-apply
"keyword duplicated in list and direct keyword arguments: "
(car kws))]
[else (loop kws2 kw-args2 kws kw-args #t)]))])
(keyword-apply proc kws kw-args (apply list* args rest))))
keyword-apply))
(#%provide (all-from-except "more-scheme.ss" old-case fluid-let) (#%provide (all-from-except "more-scheme.ss" old-case fluid-let)
(all-from "misc.ss") (all-from "misc.ss")
(all-from "define.ss") (all-from "define.ss")
@ -33,18 +63,20 @@
(rename new-λ λ) (rename new-λ λ)
(rename new-define define) (rename new-define define)
(rename new-app #%app) (rename new-app #%app)
(rename new-apply apply)
(rename #%app #%plain-app) (rename #%app #%plain-app)
(rename lambda #%plain-lambda) (rename lambda #%plain-lambda)
(rename #%module-begin #%plain-module-begin) (rename #%module-begin #%plain-module-begin)
(rename module-begin #%module-begin) (rename module-begin #%module-begin)
(all-from-except '#%kernel lambda λ #%app #%module-begin) (all-from-except '#%kernel lambda λ #%app #%module-begin apply)
(all-from "reqprov.ss") (all-from "reqprov.ss")
(all-from "for.ss") (all-from "for.ss")
#%top-interaction #%top-interaction
make-keyword-procedure make-keyword-procedure
keyword-apply (rename new-keyword-apply keyword-apply)
procedure-keywords procedure-keywords
procedure-reduce-keyword-arity
(rename define-struct* define-struct) (rename define-struct* define-struct)
define-struct/derived define-struct/derived
struct-field-index)) struct-field-index))

65
collects/scribblings/reference/class.scrbl
View File

@ -201,7 +201,7 @@ interface @scheme[(class->interface object%)], and is transparent
public pubment public-final override override-final overment augment augride public pubment public-final override override-final overment augment augride
augment-final private inherit inherit/super inherit/inner rename-super augment-final private inherit inherit/super inherit/inner rename-super
rename-inner begin lambda case-lambda let-values letrec-values rename-inner begin lambda case-lambda let-values letrec-values
define-values) define-values #%plain-lambda)
(class* superclass-expr (interface-expr ...) (class* superclass-expr (interface-expr ...)
class-clause class-clause
...) ...)
@ -252,8 +252,9 @@ interface @scheme[(class->interface object%)], and is transparent
(define-values (id) method-procedure)] (define-values (id) method-procedure)]
[method-procedure [method-procedure
(lambda formals expr ...+) (lambda kw-formals expr ...+)
(case-lambda (formals expr ...+) ...) (case-lambda (formals expr ...+) ...)
(#%plain-lambda formals expr ...+)
(let-values (((id) method-procedure) ...) (let-values (((id) method-procedure) ...)
method-procedure) method-procedure)
(letrec-values (((id) method-procedure) ...) (letrec-values (((id) method-procedure) ...)
@ -616,24 +617,26 @@ using the @scheme[inner] form. The only difference between
@scheme[inner] is that @scheme[public-final] prevents the declaration @scheme[inner] is that @scheme[public-final] prevents the declaration
of augmenting methods that would be ignored. of augmenting methods that would be ignored.
@defform*[[(super id arg-expr ...) @defform*[[(super id arg ...)
(super id arg-expr ... . arg-list-expr)]]{ (super id arg ... . arg-list-expr)]]{
Always accesses the superclass method, independent of whether the Always accesses the superclass method, independent of whether the
method is overridden again in subclasses. Using the @scheme[super] method is overridden again in subclasses. Using the @scheme[super]
form outside of @scheme[class*] is an syntax error. form outside of @scheme[class*] is an syntax error. Each @scheme[arg]
is as for @scheme[#%app]: either @scheme[_arg-expr] or
@scheme[_keyword _arg-expr].
The second form is analogous to using @scheme[apply] with a procedure; The second form is analogous to using @scheme[apply] with a procedure;
the @scheme[arg-list-expr] must not be a parenthesized expression.} the @scheme[arg-list-expr] must not be a parenthesized expression.}
@defform*[[(inner default-expr id arg-expr ...) @defform*[[(inner default-expr id arg ...)
(inner default-expr id arg-expr ... . arg-list-expr)]]{ (inner default-expr id arg ... . arg-list-expr)]]{
If the object's class does not supply an augmenting method, then If the object's class does not supply an augmenting method, then
@scheme[default-expr] is evaluated, and the @scheme[arg-expr]s are not @scheme[default-expr] is evaluated, and the @scheme[arg] expressions
evaluated. Otherwise, the augmenting method is called with the are not evaluated. Otherwise, the augmenting method is called with the
@scheme[arg-expr] results as arguments, and @scheme[default-expr] is @scheme[arg] results as arguments, and @scheme[default-expr] is not
not evaluated. If no @scheme[inner] call is evaluated for a particular evaluated. If no @scheme[inner] call is evaluated for a particular
method, then augmenting methods supplied by subclasses are never method, then augmenting methods supplied by subclasses are never
used. Using the @scheme[inner] form outside of @scheme[class*] is an used. Using the @scheme[inner] form outside of @scheme[class*] is an
syntax error. syntax error.
@ -670,14 +673,14 @@ superclass's implementation at run-time. Methods declared with
and must be called with the form and must be called with the form
@schemeblock[ @schemeblock[
(_id (lambda () _default-expr) _arg-expr ...) (_id (lambda () _default-expr) _arg ...)
] ]
so that a @scheme[default-expr] is available to evaluate when no so that a @scheme[default-expr] is available to evaluate when no
augmenting method is available. In such a form, @scheme[lambda] is a augmenting method is available. In such a form, @scheme[lambda] is a
keyword to separate the @scheme[default-expr] from the literal identifier to separate the @scheme[default-expr] from the
@scheme[arg-expr]. When an augmenting method is available, it receives @scheme[arg]. When an augmenting method is available, it receives the
the results of the @scheme[arg-expr]s as arguments. results of the @scheme[arg] expressions as arguments.
Methods that are present in the superclass but not declared with Methods that are present in the superclass but not declared with
@scheme[inherit], @scheme[inherit/super], or @scheme[inherit/inner] or @scheme[inherit], @scheme[inherit/super], or @scheme[inherit/inner] or
@ -977,37 +980,39 @@ To allow methods to be applied to lists of arguments, a method
application can have the following form: application can have the following form:
@specsubform[ @specsubform[
(method-id arg-expr ... . arg-list-expr) (method-id arg ... . arg-list-expr)
] ]
This form calls the method in a way analogous to @scheme[(apply This form calls the method in a way analogous to @scheme[(apply
_method-id _arg-expr ... _arg-list-expr)]. The @scheme[arg-list-expr] _method-id _arg ... _arg-list-expr)]. The @scheme[arg-list-expr]
must not be a parenthesized expression. must not be a parenthesized expression.
Methods are called from outside a class with the @scheme[send] and Methods are called from outside a class with the @scheme[send] and
@scheme[send/apply] forms. @scheme[send/apply] forms.
@defform*[[(send obj-expr method-id arg-expr ...) @defform*[[(send obj-expr method-id arg ...)
(send obj-expr method-id arg-expr ... . arg-list-expr)]]{ (send obj-expr method-id arg ... . arg-list-expr)]]{
Evaluates @scheme[obj-expr] to obtain an object, and calls the method Evaluates @scheme[obj-expr] to obtain an object, and calls the method
with (external) name @scheme[method-id] on the object, providing the with (external) name @scheme[method-id] on the object, providing the
@scheme[arg-expr] results as arguments. In the second form, @scheme[arg] results as arguments. Each @scheme[arg] is as for
@scheme[arg-list-expr] cannot be a parenthesized expression. @scheme[#%app]: either @scheme[_arg-expr] or @scheme[_keyword
_arg-expr]. In the second form, @scheme[arg-list-expr] cannot be a
parenthesized expression.
If @scheme[obj-expr] does not produce an object, the If @scheme[obj-expr] does not produce an object, the
@exnraise[exn:fail:contract]. If the object has no public method named @exnraise[exn:fail:contract]. If the object has no public method named
@scheme[method-id], the @exnraise[exn:fail:object].} @scheme[method-id], the @exnraise[exn:fail:object].}
@defform[(send/apply obj-expr method-id arg-expr ... arg-list-expr)]{ @defform[(send/apply obj-expr method-id arg ... arg-list-expr)]{
Like the dotted form of @scheme[send], but @scheme[arg-list-expr] can Like the dotted form of @scheme[send], but @scheme[arg-list-expr] can
be any expression.} be any expression.}
@defform/subs[(send* obj-expr msg ...) @defform/subs[(send* obj-expr msg ...)
([msg (method-id arg-expr ...) ([msg (method-id arg ...)
(method-id arg-expr ... . arg-list-expr)])]{ (method-id arg ... . arg-list-expr)])]{
Calls multiple methods (in order) of the same object. Each Calls multiple methods (in order) of the same object. Each
@scheme[msg] corresponds to a use of @scheme[send]. @scheme[msg] corresponds to a use of @scheme[send].
@ -1122,13 +1127,15 @@ interface, the @exnraise[exn:fail:contract]. If the resulting class or
interface does not contain a method named @scheme[id], the interface does not contain a method named @scheme[id], the
@exnraise[exn:fail:object].} @exnraise[exn:fail:object].}
@defform*[[(send-generic obj-expr generic-expr arg-expr ...) @defform*[[(send-generic obj-expr generic-expr arg ...)
(send-generic obj-expr generic-expr arg-expr ... . arg-list-expr)]]{ (send-generic obj-expr generic-expr arg ... . arg-list-expr)]]{
Calls a method of the object produced by @scheme[obj-expr] as Calls a method of the object produced by @scheme[obj-expr] as
indicated by the generic produced by @scheme[generic-expr]. The second indicated by the generic produced by @scheme[generic-expr]. Each
form is analogous to calling a procedure with @scheme[apply], where @scheme[arg] is as for @scheme[#%app]: either @scheme[_arg-expr] or
@scheme[arg-list-expr] is not a parenthesized expression. @scheme[_keyword _arg-expr]. The second form is analogous to calling a
procedure with @scheme[apply], where @scheme[arg-list-expr] is not a
parenthesized expression.
If @scheme[obj-expr] does not produce a object, or if If @scheme[obj-expr] does not produce a object, or if
@scheme[generic-expr] does not produce a generic, the @scheme[generic-expr] does not produce a generic, the

93
collects/scribblings/reference/procedures.scrbl
View File

@ -7,21 +7,29 @@
@scheme[v] is a procedure, @scheme[#f] otherwise.} @scheme[v] is a procedure, @scheme[#f] otherwise.}
@defproc[(apply [proc procedure?] [v any/c] ... [lst list?]) any]{ @defproc[(apply [proc procedure?]
[v any/c] ... [lst list?]
[#:<kw> kw-arg any/c] ...) any]{
@guideintro["apply"]{@scheme[apply]} @guideintro["apply"]{@scheme[apply]}
Applies @scheme[proc] using the content of @scheme[(list* v ... lst)] Applies @scheme[proc] using the content of @scheme[(list* v ... lst)]
as the (by-position) arguments. The given @scheme[proc] must accept as as the (by-position) arguments. The @scheme[#:<kw> kw-arg] sequence is
many arguments as the number of @scheme[v]s plus length of also supplied as keyword arguments to @scheme[proc], where
@scheme[lst], and it must not require any keyword arguments; @scheme[#:<kw>] stands for any keyword.
otherwise, the @exnraise[exn:fail:contract]. The given @scheme[proc]
is called in tail position with respect to the @scheme[apply] call. The given @scheme[proc] must accept as many arguments as the number of
@scheme[v]s plus length of @scheme[lst], it must accept the supplied
keyword arguments, and it must not require any other keyword
arguments; otherwise, the @exnraise[exn:fail:contract]. The given
@scheme[proc] is called in tail position with respect to the
@scheme[apply] call.
@examples[ @examples[
(apply + '(1 2 3)) (apply + '(1 2 3))
(apply + 1 2 '(3)) (apply + 1 2 '(3))
(apply + '()) (apply + '())
(apply sort (list (list '(2) '(1)) <) #:key car)
]} ]}
@defproc[(compose [proc procedure?] ...) procedure?]{ @defproc[(compose [proc procedure?] ...) procedure?]{
@ -45,28 +53,35 @@ function consumes.
[kw-lst (listof keyword?)] [kw-lst (listof keyword?)]
[kw-val-lst list?] [kw-val-lst list?]
[v any/c] ... [v any/c] ...
[lst list?]) [lst list?]
[#:<kw> kw-arg any/c] ...)
any]{ any]{
@guideintro["apply"]{@scheme[keyword-apply]} @guideintro["apply"]{@scheme[keyword-apply]}
Like @scheme[apply], but @scheme[kw-lst] and @scheme[kw-val-lst] Like @scheme[apply], but @scheme[kw-lst] and @scheme[kw-val-lst]
supply by-keyword arguments in addition to the by-position arguments supply by-keyword arguments in addition to the by-position arguments
of the @scheme[v]s and @scheme[lst]. The given @scheme[kw-lst] must be of the @scheme[v]s and @scheme[lst], and in addition to the directly
sorted using @scheme[keyword<?], and no keyword can appear twice in supplied keyword arguments in the @scheme[#:<kw> kw-arg] sequence,
@scheme[kw-lst], otherwise, the @exnraise[exn:fail:contract]. The where @scheme[#:<kw>] stands for any keyword.
given @scheme[kw-val-lst] must have the same length as
@scheme[kw-lst], otherwise, the @exnraise[exn:fail:contract]. The The given @scheme[kw-lst] must be sorted using @scheme[keyword<?]. No
given @scheme[proc] must accept all of the keywords in keyword can appear twice in @scheme[kw-lst] or in both
@scheme[kw-lst], it must not require any other keywords, and it must @scheme[kw-list] and as a @scheme[#:<kw>], otherwise, the
accept as many by-position arguments as supplied via the @scheme[v]s @exnraise[exn:fail:contract]. The given @scheme[kw-val-lst] must have
and @scheme[lst]; otherwise, the @exnraise[exn:fail:contract]. the same length as @scheme[kw-lst], otherwise, the
@exnraise[exn:fail:contract]. The given @scheme[proc] must accept all
of the keywords in @scheme[kw-lst] plus the @scheme[#:<kw>]s, it must
not require any other keywords, and it must accept as many by-position
arguments as supplied via the @scheme[v]s and @scheme[lst]; otherwise,
the @exnraise[exn:fail:contract].
@defexamples[ @defexamples[
(define (f x #:y y #:z [z 10]) (define (f x #:y y #:z [z 10])
(list x y z)) (list x y z))
(keyword-apply f '(#:y) '(2) '(1)) (keyword-apply f '(#:y) '(2) '(1))
(keyword-apply f '(#:y #:z) '(2 3) '(1)) (keyword-apply f '(#:y #:z) '(2 3) '(1))
(keyword-apply f #:z 7 '(#:y) '(2) '(1))
]} ]}
@defproc[(procedure-arity [proc procedure?]) @defproc[(procedure-arity [proc procedure?])
@ -126,7 +141,13 @@ procedure, it returns a value that is @scheme[equal?] to
@scheme[arity]. @scheme[arity].
If the @scheme[arity] specification allows arguments that are not If the @scheme[arity] specification allows arguments that are not
in @scheme[(procedure-arity proc)], the @exnraise[exn:fail:contract].} in @scheme[(procedure-arity proc)], the @exnraise[exn:fail:contract].
@examples[
(define my+ (procedure-reduce-arity + 2))
(my+ 1 2)
(my+ 1 2 3)
]}
@defproc[(procedure-keywords [proc procedure?]) @defproc[(procedure-keywords [proc procedure?])
(values (values
@ -154,7 +175,8 @@ list is also in the second list.
procedure?]{ procedure?]{
Returns a procedure that accepts all keyword arguments (without Returns a procedure that accepts all keyword arguments (without
requiring any keyword arguments). requiring any keyword arguments). See also
@scheme[procedure-reduce-keyword-arity].
When the result is called with keyword arguments, then @scheme[proc] When the result is called with keyword arguments, then @scheme[proc]
is called; the first argument is a list of keywords sorted by is called; the first argument is a list of keywords sorted by
@ -175,6 +197,34 @@ obtains its result from @scheme[plain-proc].
(show #:init 0 1 2 3 #:extra 4) (show #:init 0 1 2 3 #:extra 4)
]} ]}
@defproc[(procedure-reduce-keyword-arity [proc procedure?]
[arity procedure-arity?]
[required-kws (listof keyword?)]
[allowed-kws (or/c (listof keyword?)
false/c)])
procedure?]{
Like @scheme[procedure-reduce-arity], but constrains the keyword
arguments according to @scheme[required-kws] and @scheme[allowed-kws],
which must be sorted using @scheme[keyword<?]. If @scheme[allowed-kws]
is @scheme[#f], then the resulting procedure still accepts any
keyword, otherwise the keywords in @scheme[required-kws] must be a
subset of those in @scheme[allowed-kws]. The original @scheme[proc]
must require no more keywords than the ones listed din
@scheme[required-kws], and it must allow at least the keywors in
@scheme[allowed-kws] (or it must allow all keywords if
@scheme[allowed-kws] is @scheme[#f]).
@defexamples[
(define orig-show
(make-keyword-procedure (lambda (kws kw-args . rest)
(list kws kw-args rest))))
(define show (procedure-reduce-keyword-arity
orig-show 3 '(#:init) '(#:extra #:init)))
(show #:init 0 1 2 3 #:extra 4)
(show 1)
(show #:init 0 1 2 3 #:extra 4 #:more 7)
]}
@defstruct[arity-at-least ([value nonnegative-exact-integer?])]{ @defstruct[arity-at-least ([value nonnegative-exact-integer?])]{
@ -221,7 +271,8 @@ redundant and disallowed).
@examples[ @examples[
(define-struct annotated-proc (base note) (define-struct annotated-proc (base note)
#:property prop:procedure (struct-field-index base)) #:property prop:procedure
(struct-field-index base))
(define plus1 (make-annotated-proc (define plus1 (make-annotated-proc
(lambda (x) (+ x 1)) (lambda (x) (+ x 1))
"adds 1 to its argument")) "adds 1 to its argument"))
@ -255,7 +306,9 @@ is disallowed).
#:mutable #:mutable
#:property #:property
prop:procedure prop:procedure
(lambda (f n) (set-fish-weight! f (+ n (fish-weight f))))) (lambda (f n)
(let ([w (fish-weight f)])
(set-fish-weight! f (+ n w)))))
(define wanda (make-fish 12 'red)) (define wanda (make-fish 12 'red))
(fish? wanda) (fish? wanda)
(procedure? wanda) (procedure? wanda)

55
collects/scribblings/scribble/how-to.scrbl
View File

@ -54,31 +54,23 @@ To document a collection or @|PLaneT| package:
the whole right-hand side of the definition is already the whole right-hand side of the definition is already
quoted). quoted).
@; [Eli] `name' is not needed, but I think it's used by planet If you do not already have an @filepath{info.ss} module,
As usual, you may want to add a descriptive here's a suitable complete module:
@schemeidfont{name} field in your @filepath{info.ss}. If you
do not already have an @filepath{info.ss} module, here's a
suitable complete module:
@; [Eli] "Some documentation" is probably not a good name
@; since this is supposed to be documentation for a library
@schememod[ @schememod[
setup/infotab setup/infotab
(define name "Some documentation")
(define scribblings '(("manual.scrbl" ()))) (define scribblings '(("manual.scrbl" ())))
]} ]}
@item{@; [Eli] If this is following a planet example, then it should @item{Run @exec{setup-plt} to build your documentation. For a
@; have the correct command line here. (I don't know what
@; it should be though.)
Run @exec{setup-plt} to build your documentation. For a
collection, optionally supply @Flag{l} followed by the collection, optionally supply @Flag{l} followed by the
collection name to limit the build process to that collection.} collection name to limit the build process to that
collection. For a @|PLaneT| package, optionally supply
@Flag{P} followed by the package information to limit the
build process to that package.}
@item{The generated documentation is normally @item{The generated documentation is normally
@filepath{doc/manual/index.html} within the collection or @filepath{doc/manual/index.html} within the collection or
@; [Eli] I "fixed" the obvious typo in the following sentence,
@; but it's still weird and should probably be different.
@|PLaneT| package directory. If the collection is in PLT @|PLaneT| package directory. If the collection is in PLT
Scheme's main @filepath{collects} directory, however, then the Scheme's main @filepath{collects} directory, however, then the
documentation is generated as @filepath{manual/index.html} in documentation is generated as @filepath{manual/index.html} in
@ -311,12 +303,31 @@ and they declare hyperlink targets for @scheme[scheme]-based
hyperlinks. hyperlinks.
To document a @scheme[my-helper] procedure that is exported by To document a @scheme[my-helper] procedure that is exported by
@filepath{helper.ss} in the collection that contains @filepath{helper.ss} in the @scheme{my-lib} collection that contains
@filepath{manual.scrbl}, first use @scheme[(require (for-label ....))] @filepath{manual.scrbl}:
to import the binding information of @filepath{helper.ss}. Then add a
@scheme[defmodule] declaration, which connects the @scheme[for-label] @itemize[
binding with the module path as seen by a reader. Finally, use
@scheme[defproc] to document the procedure: @item{Use @scheme[(require (for-label "helper.ss"))] to import the
binding information about the bindings of @filepath{helper.ss}
for use when typesetting identifiers. A relative reference
@scheme["helper.ss"] works since it is relative to the
documentation source.}
@item{Add a @tt|{@defmodule[my-lib/helper]}| declaration, which
specifies the library that is being documented within the
section. The @scheme[defmodule] form needs an absolute module
name @scheme[mylib/helper], instead of a relative reference
@scheme["helper.ss"], since the module path given to
@scheme[defmodule] appears verbatim in the generated
documentation.}
@item{Use @scheme[defproc] to document the procedure.}
]
Adding these pieces to @filepath{"manual.scrbl"} gives us the
following:
@; [Eli] This is also using `my-lib/helper' which doesn't work with @; [Eli] This is also using `my-lib/helper' which doesn't work with
@; planet libraries @; planet libraries
@ -370,7 +381,7 @@ generates:
@item{If you use @scheme[my-helper] in any documentation now, as long @item{If you use @scheme[my-helper] in any documentation now, as long
as that documentation source also has a @scheme[(require as that documentation source also has a @scheme[(require
(for-label ....))] of @filepath{my-helper.ss}, then the (for-label ....))] of @filepath{helper.ss}, then the
reference is hyperlinked to the definition above.} reference is hyperlinked to the definition above.}
} }

1
collects/tests/mzscheme/mz.ss
View File

@ -7,6 +7,7 @@
(load-relative "read.ss") (load-relative "read.ss")
(load-relative "macro.ss") (load-relative "macro.ss")
(load-relative "syntax.ss") (load-relative "syntax.ss")
(load-relative "procs.ss")
(load-relative "stx.ss") (load-relative "stx.ss")
(load-relative "module.ss") (load-relative "module.ss")
(load-relative "number.ss") (load-relative "number.ss")

218
collects/tests/mzscheme/procs.ss Normal file
View File

@ -0,0 +1,218 @@
(load-relative "loadtest.ss")
(Section 'procs)
;; ----------------------------------------
(define (f0) null)
(define (f1 x) (list x))
(define (f1+ x . rest) (cons x rest))
(define (f0:a #:a a) (list a))
(define (f0:a? #:a [a 0]) (list a))
(define (f1:a x #:a a) (list x a))
(define (f1:a? x #:a [a 0]) (list x a))
(define (f1+:a x #:a a . args) (list* x a args))
(define (f1+:a? x #:a [a 0] . args) (list* x a args))
(define (f0:a:b #:a a #:b b) (list a b))
(define (f0:a?:b #:a [a 0] #:b b) (list a b))
(define (f1:a:b x #:a a #:b b) (list x a b))
(define (f1:a?:b x #:a [a 0] #:b b) (list x a b))
(define (f1+:a:b x #:a a #:b b . args) (list* x a b args))
(define (f1+:a?:b x #:a [a 0] #:b b . args) (list* x a b args))
(define (f0:a:b? #:a a #:b [b 1]) (list a b))
(define (f0:a?:b? #:a [a 0] #:b [b 1]) (list a b))
(define (f1:a:b? x #:a a #:b [b 1]) (list x a b))
(define (f1:a?:b? x #:a [a 0] #:b [b 1]) (list x a b))
(define (f1+:a:b? x #:a a #:b [b 1] . args) (list* x a b args))
(define (f1+:a?:b? x #:a [a 0] #:b [b 1] . args) (list* x a b args))
(define f_ (case-lambda))
(define f_1_2 (case-lambda
[(x) (list x)]
[(x y) (list x y)]))
(define f_0_2+ (case-lambda
[() null]
[(x y . args) (list* x y args)]))
(define f1:+ (make-keyword-procedure
(lambda (kws kw-args x)
(cons x kw-args))
(lambda (x) (list x))))
(define procs
`((,f0 0 () ())
(,f1 1 () ())
(,f1+ ,(make-arity-at-least 1) () ())
(,f0:a 0 (#:a) (#:a))
(,f0:a? 0 () (#:a))
(,f1:a 1 (#:a) (#:a))
(,f1:a? 1 () (#:a))
(,f1+:a ,(make-arity-at-least 1) (#:a) (#:a))
(,f1+:a? ,(make-arity-at-least 1) () (#:a))
(,f0:a:b 0 (#:a #:b) (#:a #:b))
(,f0:a?:b 0 (#:b) (#:a #:b))
(,f1:a:b 1 (#:a #:b) (#:a #:b))
(,f1:a?:b 1 (#:b) (#:a #:b))
(,f1+:a:b ,(make-arity-at-least 1) (#:a #:b) (#:a #:b))
(,f1+:a?:b ,(make-arity-at-least 1) (#:b) (#:a #:b))
(,f0:a:b? 0 (#:a) (#:a #:b))
(,f0:a?:b? 0 () (#:a #:b))
(,f1:a:b? 1 (#:a) (#:a #:b))
(,f1:a?:b? 1 () (#:a #:b))
(,f1+:a:b? ,(make-arity-at-least 1) (#:a) (#:a #:b))
(,f1+:a?:b? ,(make-arity-at-least 1) () (#:a #:b))
(,f_ () () ())
(,f_1_2 (1 2) () ())
(,f_0_2+ ,(list 0 (make-arity-at-least 2)) () ())
(,f1:+ 1 () #f)))
(for-each (lambda (p)
(let ([a (cadr p)])
(test a procedure-arity (car p))
(test-values (list (caddr p) (cadddr p))
(lambda ()
(procedure-keywords (car p))))
(let ([1-ok? (let loop ([a a])
(or (equal? a 1)
(and (arity-at-least? a)
((arity-at-least-value a) . <= . 1))
(and (list? a)
(ormap loop a))))])
(test 1-ok? procedure-arity-includes? (car p) 1)
(let ([allowed (cadddr p)])
(if 1-ok?
(cond
[(equal? allowed '())
(test (let ([auto (cddddr p)])
(cond
[(equal? auto '((#:a #:b))) '(1 0 1)]
[(equal? auto '((#:a))) '(1 0)]
[(equal? auto '((#:a))) '(1 0)]
[else '(1)]))
(car p) 1)
(err/rt-test ((car p) 1 #:a 0))
(err/rt-test ((car p) 1 #:b 0))
(err/rt-test ((car p) 1 #:a 0 #:b 0))]
[(equal? allowed '(#:a))
(test (if (pair? (cddddr p))
'(10 20 1) ; dropped #:b
'(10 20))
(car p) 10 #:a 20)
(err/rt-test ((car p) 1 #:b 0))
(err/rt-test ((car p) 1 #:a 0 #:b 0))]
[(equal? allowed '(#:b))
(test '(10.0 20.0) (car p) 10.0 #:b 20.0)
(err/rt-test ((car p) 1 #:a 0))
(err/rt-test ((car p) 1 #:a 0 #:b 0))]
[(equal? allowed '(#:a #:b))
(test '(100 200 300) (car p) 100 #:b 300 #:a 200)
(err/rt-test ((car p) 1 #:a 0 #:b 0 #:c 3))]
[(equal? allowed #f)
(test '(1 2 3) (car p) 1 #:b 3 #:a 2)])
(begin
;; Try just 1:
(err/rt-test ((car p) 1))
;; Try with right keyword args, to make sure the by-position
;; arity is checked:
(cond
[(equal? allowed '())
(void)]
[(equal? allowed '(#:a))
(err/rt-test ((car p) 1 #:a 1))]
[(equal? allowed '(#:b))
(err/rt-test ((car p) 1 #:b 1))]
[(equal? allowed '(#:a #:b))
(err/rt-test ((car p) 1 #:a 1 #:b 1))]
[(equal? allowed #f)
(err/rt-test ((car p) 1 #:a 1 #:b 1))])))))))
(append procs
;; reduce to arity 1 or nothing:
(map (lambda (p)
(let ([p (car p)])
(let-values ([(req allowed) (procedure-keywords p)])
(if (null? allowed)
(if (procedure-arity-includes? p 1)
(list (procedure-reduce-arity p 1) 1 req allowed)
(list (procedure-reduce-arity p '()) '() req allowed))
(if (procedure-arity-includes? p 1)
(list (procedure-reduce-keyword-arity p 1 req allowed) 1 req allowed)
(list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed))))))
procs)
;; reduce to arity 0 or nothing:
(map (lambda (p)
(let ([p (car p)])
(let-values ([(req allowed) (procedure-keywords p)])
(if (null? allowed)
(if (procedure-arity-includes? p 0)
(list (procedure-reduce-arity p 0) 0 req allowed)
(list (procedure-reduce-arity p '()) '() req allowed))
(if (procedure-arity-includes? p 0)
(list (procedure-reduce-keyword-arity p 0 req allowed) 0 req allowed)
(list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed))))))
procs)
;; reduce to arity 1 or nothing --- no keywords:
(map (lambda (p)
(let ([p (car p)])
(let-values ([(req allowed) (procedure-keywords p)])
(if (and (procedure-arity-includes? p 1)
(null? req))
(list* (procedure-reduce-arity p 1) 1 '() '()
(if (null? allowed)
null
(list allowed)))
(list (procedure-reduce-arity p '()) '() '() '())))))
procs)
;; reduce to arity 0 or nothing --- no keywords:
(map (lambda (p)
(let ([p (car p)])
(let-values ([(req allowed) (procedure-keywords p)])
(if (and (procedure-arity-includes? p 0)
(null? req))
(list (procedure-reduce-arity p 0) 0 '() '())
(list (procedure-reduce-arity p '()) '() '() '())))))
procs)
;; make #:a required, if possible:
(map (lambda (p)
(let-values ([(req allowed) (procedure-keywords (car p))])
(let ([new-req (if (member '#:a req)
req
(cons '#:a req))])
(list (procedure-reduce-keyword-arity
(car p)
(cadr p)
new-req
allowed)
(cadr p)
new-req
allowed))))
(filter (lambda (p)
(let-values ([(req allowed) (procedure-keywords (car p))])
(or (not allowed)
(memq '#:a allowed))))
procs))
;; remove #:b, if allowed and not required:
(map (lambda (p)
(let-values ([(req allowed) (procedure-keywords (car p))])
(let ([new-allowed (if allowed
(remove '#:b allowed)
'(#:a))])
(list* (procedure-reduce-keyword-arity
(car p)
(cadr p)
req
new-allowed)
(cadr p)
req
new-allowed
(if allowed
(list allowed)
'())))))
(filter (lambda (p)
(let-values ([(req allowed) (procedure-keywords (car p))])
(and (or (not allowed)
(memq '#:b allowed))
(not (memq '#:b req)))))
procs))))
;; ----------------------------------------
(report-errs)

1
collects/tests/mzscheme/scheme.ss
View File

@ -4,6 +4,7 @@
(load-in-sandbox "for.ss") (load-in-sandbox "for.ss")
(load-in-sandbox "list.ss") (load-in-sandbox "list.ss")
(load-in-sandbox "function.ss") (load-in-sandbox "function.ss")
(load-in-sandbox "dict.ss")
(load-in-sandbox "promise.ss") (load-in-sandbox "promise.ss")
(load-in-sandbox "contract-test.ss") (load-in-sandbox "contract-test.ss")

25
src/mzscheme/src/fun.c
View File

@ -84,6 +84,8 @@ Scheme_Object *scheme_procedure_p_proc;
Scheme_Object *scheme_void_proc; Scheme_Object *scheme_void_proc;
Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */ Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
Scheme_Object *scheme_reduced_procedure_struct;
Scheme_Object *scheme_tail_call_waiting; Scheme_Object *scheme_tail_call_waiting;
Scheme_Object *scheme_inferred_name_symbol; Scheme_Object *scheme_inferred_name_symbol;
@ -173,8 +175,6 @@ static Scheme_Prompt *available_prompt, *available_cws_prompt, *available_regula
static Scheme_Dynamic_Wind *available_prompt_dw; static Scheme_Dynamic_Wind *available_prompt_dw;
static Scheme_Meta_Continuation *available_prompt_mc; static Scheme_Meta_Continuation *available_prompt_mc;
static Scheme_Object *reduced_procedure_struct;
typedef void (*DW_PrePost_Proc)(void *); typedef void (*DW_PrePost_Proc)(void *);
#define CONS(a,b) scheme_make_pair(a,b) #define CONS(a,b) scheme_make_pair(a,b)
@ -2763,8 +2763,8 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, long a, Scheme_Object
return first; return first;
} else if (type == scheme_proc_struct_type) { } else if (type == scheme_proc_struct_type) {
int is_method; int is_method;
if (reduced_procedure_struct if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(reduced_procedure_struct, p)) { && scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
if (a >= 0) if (a >= 0)
bign = scheme_make_integer(a); bign = scheme_make_integer(a);
if (a == -1) if (a == -1)
@ -2793,6 +2793,8 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, long a, Scheme_Object
v = SCHEME_CDR(v); v = SCHEME_CDR(v);
} }
return scheme_false; return scheme_false;
} else if (SCHEME_NULLP(v)) {
return scheme_false;
} else { } else {
return (scheme_bin_eq(v, bign) return (scheme_bin_eq(v, bign)
? scheme_true ? scheme_true
@ -3390,14 +3392,14 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
scheme_wrong_type("procedure-reduce-arity", "arity", 1, argc, argv); scheme_wrong_type("procedure-reduce-arity", "arity", 1, argc, argv);
} }
if (!reduced_procedure_struct) { if (!scheme_reduced_procedure_struct) {
REGISTER_SO(reduced_procedure_struct); REGISTER_SO(scheme_reduced_procedure_struct);
pr = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR); pr = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
while (((Scheme_Inspector *)pr)->superior->superior) { while (((Scheme_Inspector *)pr)->superior->superior) {
pr = (Scheme_Object *)((Scheme_Inspector *)pr)->superior; pr = (Scheme_Object *)((Scheme_Inspector *)pr)->superior;
} }
orig = scheme_builtin_value("prop:procedure"); orig = scheme_builtin_value("prop:procedure");
reduced_procedure_struct = scheme_make_proc_struct_type(NULL, scheme_reduced_procedure_struct = scheme_make_proc_struct_type(NULL,
NULL, NULL,
pr, pr,
2, 0, 2, 0,
@ -3525,11 +3527,10 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
if (SCHEME_NULLP(ol)) { if (SCHEME_NULLP(ol)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION, scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"procedure-reduce-arity: arity of procedre: %V" "procedure-reduce-arity: arity of procedure: %V"
" does not include requested arity: %V : %V", " does not include requested arity: %V",
argv[0], argv[0],
argv[1], argv[1]);
ra);
return NULL; return NULL;
} }
@ -3542,7 +3543,7 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
pr = clone_arity(argv[1]); pr = clone_arity(argv[1]);
a[1] = pr; a[1] = pr;
return scheme_make_struct_instance(reduced_procedure_struct, 2, a); return scheme_make_struct_instance(scheme_reduced_procedure_struct, 2, a);
} }
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]) static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])

15
src/mzscheme/src/module.c
View File

@ -1201,7 +1201,7 @@ static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[])
Scheme_Hash_Table *checked, *next_checked, *prev_checked; Scheme_Hash_Table *checked, *next_checked, *prev_checked;
Scheme_Object *past_checkeds, *future_checkeds, *future_todos, *past_to_modchains, *past_todos; Scheme_Object *past_checkeds, *future_checkeds, *future_todos, *past_to_modchains, *past_todos;
Scheme_Module *m2; Scheme_Module *m2;
int same_namespace, set_env_for_notify = 0, phase; int same_namespace, set_env_for_notify = 0, phase, first_iteration;
if (!SCHEME_NAMESPACEP(argv[0])) if (!SCHEME_NAMESPACEP(argv[0]))
scheme_wrong_type("namespace-attach-module", "namespace", 0, argc, argv); scheme_wrong_type("namespace-attach-module", "namespace", 0, argc, argv);
@ -1236,6 +1236,8 @@ static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[])
future_todos = scheme_null; future_todos = scheme_null;
past_to_modchains = scheme_null; past_to_modchains = scheme_null;
first_iteration = 1;
/* Check whether todo, or anything it needs, is already declared /* Check whether todo, or anything it needs, is already declared
incompatibly. Successive iterations of the outer loop explore incompatibly. Successive iterations of the outer loop explore
successive phases (i.e, for-syntax levels). */ successive phases (i.e, for-syntax levels). */
@ -1272,6 +1274,13 @@ static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[])
name); name);
} }
if (first_iteration) {
/* Run everything */
first_iteration = 0;
start_module(menv->module, from_env, 0, menv->module->self_modidx, 1, 1, scheme_null);
}
/* If to_modchain goes to #f, then our source check has gone /* If to_modchain goes to #f, then our source check has gone
deeper in phases (for-syntax levels) than the target deeper in phases (for-syntax levels) than the target
namespace has ever gone, so there's definitely no conflict namespace has ever gone, so there's definitely no conflict
@ -1324,7 +1333,9 @@ static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[])
l = SCHEME_CDR(l); l = SCHEME_CDR(l);
} }
/* Have to force laziness in source to ensure sharing: */ /* Have to force laziness in source to ensure sharing. This
should be redundant, since we called start_module() for the
inital module, but we keep it just in case... */
if (!menv->ran) if (!menv->ran)
scheme_run_module(menv, 1); scheme_run_module(menv, 1);
if (menv->lazy_syntax) if (menv->lazy_syntax)

2
src/mzscheme/src/schpriv.h
View File

@ -291,6 +291,8 @@ extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
extern Scheme_Object *scheme_equal_property; extern Scheme_Object *scheme_equal_property;
extern Scheme_Object *scheme_reduced_procedure_struct;
/*========================================================================*/ /*========================================================================*/
/* thread state and maintenance */ /* thread state and maintenance */
/*========================================================================*/ /*========================================================================*/

5
src/mzscheme/src/struct.c
View File

@ -3453,6 +3453,11 @@ static Scheme_Object *procedure_extract_target(int argc, Scheme_Object **argv)
scheme_wrong_type("procedure-extract-target", "procedure", 0, argc, argv); scheme_wrong_type("procedure-extract-target", "procedure", 0, argc, argv);
if (SCHEME_PROC_STRUCTP(argv[0])) { if (SCHEME_PROC_STRUCTP(argv[0])) {
/* Don't expose arity reducer: */
if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, argv[0]))
return scheme_false;
v = scheme_extract_struct_procedure(argv[0], -1, NULL, &is_method); v = scheme_extract_struct_procedure(argv[0], -1, NULL, &is_method);
if (v && !is_method && SCHEME_PROCP(v)) if (v && !is_method && SCHEME_PROCP(v))
return v; return v;