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)])
(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 make (c-dynamic-require 'make/make-unit 'make@))
(define coll (c-dynamic-require 'make/collection-unit 'make:collection@))
@ -161,7 +161,9 @@
(parameterize ([current-directory dir]
[current-load-relative-directory dir]
;; 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
(lambda (path) ((compile-notify-handler) path))])
;; Compile the collection files via make-collection
@ -189,7 +191,8 @@
(define (compile-collection-zos 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)

3
collects/mysterx/installer.ss
View File

@ -13,7 +13,8 @@
[regsvr (and winsys-dir (build-path winsys-dir "REGSVR32.EXE"))])
(cond
[(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))
(printf "Warning: MysterX binaries not installed\n")]
[(not winsys-dir)

10
collects/mzscheme/mzscheme.scrbl
View File

@ -16,7 +16,7 @@
@(define-syntax-rule (def-base base-define base-define-struct
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-transformer-identifier=? base-free-label-identifier=?)
(begin
@ -28,13 +28,14 @@
(define base-case (scheme case))
(define base-top-interaction (scheme #%top-interaction))
(define base-open-input-file (scheme open-input-file))
(define base-apply (scheme apply))
(define base-free-identifier=? (scheme free-identifier=?))
(define base-free-template-identifier=? (scheme free-template-identifier=?))
(define base-free-transformer-identifier=? (scheme free-transformer-identifier=?))
(define base-free-label-identifier=? (scheme free-label-identifier=?))))
@(def-base base-define base-define-struct
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-transformer-identifier=? base-free-label-identifier=?)
@ -195,6 +196,11 @@ The same as @|base-top-interaction| in @schememodname[scheme/base].}
@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[(
@defproc[(open-input-file [file path-string?] [mode (one-of/c 'text 'binary) 'binary])
input-port?]

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

@ -179,6 +179,7 @@
(kernel-form-identifier-list)
(list
(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-rest)
(quote-syntax -field)
@ -317,6 +318,24 @@
(and (stx-pair? vars)
(identifier? (stx-car 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
;; for error reporting, etc.
(define (mk-name name)
@ -332,23 +351,52 @@
#f))
;; -- tranform loop starts here --
(let loop ([stx orig-stx][can-expand? #t][name name][locals null])
(syntax-case stx (#%plain-lambda case-lambda letrec-values let-values)
[(#%plain-lambda vars body1 body ...)
(vars-ok? (syntax vars))
(syntax-case stx (#%plain-lambda lambda case-lambda letrec-values let-values)
[(lam vars body1 body ...)
(or (and (free-identifier=? #'lam #'#%plain-lambda)
(vars-ok? (syntax vars)))
(and (free-identifier=? #'lam #'lambda)
(kw-vars-ok? (syntax vars))))
(if xform?
(with-syntax ([the-obj the-obj]
[the-finder the-finder]
[name (mk-name name)])
(let ([l (syntax/loc stx
(lambda (the-obj . vars)
(let-syntax ([the-finder (quote-syntax the-obj)])
body1 body ...)))])
(with-syntax ([l (recertify (add-method-property l) stx)])
(syntax/loc stx
(let ([name l]) name)))))
stx)]
(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
(lambda (the-obj . vars)
(let-syntax ([the-finder (quote-syntax the-obj)])
body1 body ...)))])
(with-syntax ([l (recertify (add-method-property l) stx)])
(syntax/loc stx
(let ([name l]) name))))))
stx)]
[(#%plain-lambda . _)
(bad "ill-formed lambda expression for method" stx)]
[(lambda . _)
(bad "ill-formed lambda expression for method" stx)]
[(case-lambda [vars body1 body ...] ...)
(andmap vars-ok? (syntax->list (syntax (vars ...))))
(if xform?

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

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

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

@ -16,11 +16,16 @@
new-app
(rename *make-keyword-procedure make-keyword-procedure)
keyword-apply
procedure-keywords)
procedure-keywords
procedure-reduce-keyword-arity)
;; ----------------------------------------
(-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)
(let-values ([(req allowed) (procedure-keywords proc)]
@ -42,29 +47,40 @@
(if (null? (cdr req))
(format " and ~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
(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)
(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")))]
[else
"a different number of arguments"])
(if (null? req)
""
(format " plus ~a" (keywords-desc "" req)))
(let ([others (let loop ([req req][allowed allowed])
(cond
[(null? req) allowed]
[(eq? (car req) (car allowed))
(loop (cdr req) (cdr allowed))]
[else
(cons (car allowed) (loop req (cdr allowed)))]))])
(if (null? others)
""
(format " plus ~a"
(keywords-desc "optional " others)))))))
(if allowed
(let ([others (let loop ([req req][allowed allowed])
(cond
[(null? req) allowed]
[(eq? (car req) (car allowed))
(loop (cdr req) (cdr allowed))]
[else
(cons (car allowed) (loop req (cdr allowed)))]))])
(if (null? others)
""
(format " plus ~a"
(keywords-desc "optional " others))))
" plus arbitrary keyword arguments"))))
;; Constructor for a procedure with only optional keywords.
;; The `procedure' property dispatches to a procedure in the
@ -76,15 +92,23 @@
(list (cons prop:arity-string generate-arity-string))
(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.
;; (This is used with lift-expression, so that the same constructor
;; is used for each evaluation of a keyword lambda.)
;; The `procedure' property is a per-type method that has exactly
;; 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!)
(make-struct-type (string->symbol (format "procedure:~a" name))
struct:keyword-procedure
(if method?
struct:keyword-method
struct:keyword-procedure)
0 0 #f
(list (cons prop:arity-string generate-arity-string))
(current-inspector) fail-proc)])
@ -294,7 +318,8 @@
(lambda (a b) (keyword<? (syntax-e a) (syntax-e b))))]
[sorted-kws (sort (map list kws kw-args kw-arg?s kw-reqs)
(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]
[(kw-arg? ...) (let loop ([kw-arg?s kw-arg?s]
[kw-reqs kw-reqs])
@ -318,7 +343,11 @@
'(null))]
[fail-rest (if (null? (syntax-e #'rest))
'(null)
#'rest)])
#'rest)]
[make-okp (if method?
#'make-optional-keyword-method
#'make-optional-keyword-procedure)]
[method? method?])
(let ([with-core
(lambda (result)
@ -400,7 +429,7 @@
p))]
[with-kws (mk-with-kws)])
(syntax/loc stx
(make-optional-keyword-procedure
(make-okp
with-kws
null
'kws
@ -416,7 +445,7 @@
[mk-id (with-syntax ([n (syntax-local-infer-name stx)]
[call-fail (mk-kw-arity-stub)])
(syntax-local-lift-expression
#'(make-required 'n call-fail)))])
#'(make-required 'n call-fail method?)))])
(syntax/loc stx
(mk-id
with-kws
@ -675,7 +704,7 @@
(values (car required) #f))]
[(and (pair? required)
(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
(loop (cdr kws) required #f)]
[(pair? allowed)
@ -708,7 +737,12 @@
(let-values ([(missing-kw extra-kw)
(if (keyword-procedure? p)
(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
(if (and (null? args)
(null? kws))
@ -751,8 +785,76 @@
(format
(string-append
"procedure application: no case matching ~a non-keyword"
" arguments for: ~e; ~a")
" argument~a for: ~e; ~a")
(- n 2)
(if (= 1 (- n 2)) "" "s")
p
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))
(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)
(all-from "misc.ss")
(all-from "define.ss")
@ -33,18 +63,20 @@
(rename new-λ λ)
(rename new-define define)
(rename new-app #%app)
(rename new-apply apply)
(rename #%app #%plain-app)
(rename lambda #%plain-lambda)
(rename #%module-begin #%plain-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 "for.ss")
#%top-interaction
make-keyword-procedure
keyword-apply
(rename new-keyword-apply keyword-apply)
procedure-keywords
procedure-reduce-keyword-arity
(rename define-struct* define-struct)
define-struct/derived
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
augment-final private inherit inherit/super inherit/inner rename-super
rename-inner begin lambda case-lambda let-values letrec-values
define-values)
define-values #%plain-lambda)
(class* superclass-expr (interface-expr ...)
class-clause
...)
@ -252,8 +252,9 @@ interface @scheme[(class->interface object%)], and is transparent
(define-values (id) method-procedure)]
[method-procedure
(lambda formals expr ...+)
(lambda kw-formals expr ...+)
(case-lambda (formals expr ...+) ...)
(#%plain-lambda formals expr ...+)
(let-values (((id) method-procedure) ...)
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
of augmenting methods that would be ignored.
@defform*[[(super id arg-expr ...)
(super id arg-expr ... . arg-list-expr)]]{
@defform*[[(super id arg ...)
(super id arg ... . arg-list-expr)]]{
Always accesses the superclass method, independent of whether the
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 @scheme[arg-list-expr] must not be a parenthesized expression.}
@defform*[[(inner default-expr id arg-expr ...)
(inner default-expr id arg-expr ... . arg-list-expr)]]{
@defform*[[(inner default-expr id arg ...)
(inner default-expr id arg ... . arg-list-expr)]]{
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
evaluated. Otherwise, the augmenting method is called with the
@scheme[arg-expr] results as arguments, and @scheme[default-expr] is
not evaluated. If no @scheme[inner] call is evaluated for a particular
@scheme[default-expr] is evaluated, and the @scheme[arg] expressions
are not evaluated. Otherwise, the augmenting method is called with the
@scheme[arg] results as arguments, and @scheme[default-expr] is not
evaluated. If no @scheme[inner] call is evaluated for a particular
method, then augmenting methods supplied by subclasses are never
used. Using the @scheme[inner] form outside of @scheme[class*] is an
syntax error.
@ -670,14 +673,14 @@ superclass's implementation at run-time. Methods declared with
and must be called with the form
@schemeblock[
(_id (lambda () _default-expr) _arg-expr ...)
(_id (lambda () _default-expr) _arg ...)
]
so that a @scheme[default-expr] is available to evaluate when no
augmenting method is available. In such a form, @scheme[lambda] is a
keyword to separate the @scheme[default-expr] from the
@scheme[arg-expr]. When an augmenting method is available, it receives
the results of the @scheme[arg-expr]s as arguments.
literal identifier to separate the @scheme[default-expr] from the
@scheme[arg]. When an augmenting method is available, it receives the
results of the @scheme[arg] expressions as arguments.
Methods that are present in the superclass but not declared with
@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:
@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
_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.
Methods are called from outside a class with the @scheme[send] and
@scheme[send/apply] forms.
@defform*[[(send obj-expr method-id arg-expr ...)
(send obj-expr method-id arg-expr ... . arg-list-expr)]]{
@defform*[[(send obj-expr method-id arg ...)
(send obj-expr method-id arg ... . arg-list-expr)]]{
Evaluates @scheme[obj-expr] to obtain an object, and calls the method
with (external) name @scheme[method-id] on the object, providing the
@scheme[arg-expr] results as arguments. In the second form,
@scheme[arg-list-expr] cannot be a parenthesized expression.
@scheme[arg] results as arguments. Each @scheme[arg] is as for
@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
@exnraise[exn:fail:contract]. If the object has no public method named
@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
be any expression.}
@defform/subs[(send* obj-expr msg ...)
([msg (method-id arg-expr ...)
(method-id arg-expr ... . arg-list-expr)])]{
([msg (method-id arg ...)
(method-id arg ... . arg-list-expr)])]{
Calls multiple methods (in order) of the same object. Each
@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
@exnraise[exn:fail:object].}
@defform*[[(send-generic obj-expr generic-expr arg-expr ...)
(send-generic obj-expr generic-expr arg-expr ... . arg-list-expr)]]{
@defform*[[(send-generic obj-expr generic-expr arg ...)
(send-generic obj-expr generic-expr arg ... . arg-list-expr)]]{
Calls a method of the object produced by @scheme[obj-expr] as
indicated by the generic produced by @scheme[generic-expr]. The second
form is analogous to calling a procedure with @scheme[apply], where
@scheme[arg-list-expr] is not a parenthesized expression.
indicated by the generic produced by @scheme[generic-expr]. Each
@scheme[arg] is as for @scheme[#%app]: either @scheme[_arg-expr] or
@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
@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.}
@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]}
Applies @scheme[proc] using the content of @scheme[(list* v ... lst)]
as the (by-position) arguments. The given @scheme[proc] must accept as
many arguments as the number of @scheme[v]s plus length of
@scheme[lst], and it must not require any keyword arguments;
otherwise, the @exnraise[exn:fail:contract]. The given @scheme[proc]
is called in tail position with respect to the @scheme[apply] call.
as the (by-position) arguments. The @scheme[#:<kw> kw-arg] sequence is
also supplied as keyword arguments to @scheme[proc], where
@scheme[#:<kw>] stands for any keyword.
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[
(apply + '(1 2 3))
(apply + 1 2 '(3))
(apply + '())
(apply sort (list (list '(2) '(1)) <) #:key car)
]}
@defproc[(compose [proc procedure?] ...) procedure?]{
@ -45,28 +53,35 @@ function consumes.
[kw-lst (listof keyword?)]
[kw-val-lst list?]
[v any/c] ...
[lst list?])
[lst list?]
[#:<kw> kw-arg any/c] ...)
any]{
@guideintro["apply"]{@scheme[keyword-apply]}
Like @scheme[apply], but @scheme[kw-lst] and @scheme[kw-val-lst]
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
sorted using @scheme[keyword<?], and no keyword can appear twice in
@scheme[kw-lst], otherwise, the @exnraise[exn:fail:contract]. The
given @scheme[kw-val-lst] must have 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], 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].
of the @scheme[v]s and @scheme[lst], and in addition to the directly
supplied keyword arguments in the @scheme[#:<kw> kw-arg] sequence,
where @scheme[#:<kw>] stands for any keyword.
The given @scheme[kw-lst] must be sorted using @scheme[keyword<?]. No
keyword can appear twice in @scheme[kw-lst] or in both
@scheme[kw-list] and as a @scheme[#:<kw>], otherwise, the
@exnraise[exn:fail:contract]. The given @scheme[kw-val-lst] must have
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[
(define (f x #:y y #:z [z 10])
(list x y z))
(keyword-apply f '(#:y) '(2) '(1))
(keyword-apply f '(#:y #:z) '(2 3) '(1))
(keyword-apply f #:z 7 '(#:y) '(2) '(1))
]}
@defproc[(procedure-arity [proc procedure?])
@ -126,7 +141,13 @@ procedure, it returns a value that is @scheme[equal?] to
@scheme[arity].
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?])
(values
@ -154,7 +175,8 @@ list is also in the second list.
procedure?]{
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]
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)
]}
@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?])]{
@ -221,7 +271,8 @@ redundant and disallowed).
@examples[
(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
(lambda (x) (+ x 1))
"adds 1 to its argument"))
@ -255,7 +306,9 @@ is disallowed).
#:mutable
#:property
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))
(fish? 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
quoted).
@; [Eli] `name' is not needed, but I think it's used by planet
As usual, you may want to add a descriptive
@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:
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[
setup/infotab
(define name "Some documentation")
(define scribblings '(("manual.scrbl" ())))
]}
@item{@; [Eli] If this is following a planet example, then it should
@; 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
@item{Run @exec{setup-plt} to build your documentation. For a
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
@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
Scheme's main @filepath{collects} directory, however, then the
documentation is generated as @filepath{manual/index.html} in
@ -311,12 +303,31 @@ and they declare hyperlink targets for @scheme[scheme]-based
hyperlinks.
To document a @scheme[my-helper] procedure that is exported by
@filepath{helper.ss} in the collection that contains
@filepath{manual.scrbl}, first use @scheme[(require (for-label ....))]
to import the binding information of @filepath{helper.ss}. Then add a
@scheme[defmodule] declaration, which connects the @scheme[for-label]
binding with the module path as seen by a reader. Finally, use
@scheme[defproc] to document the procedure:
@filepath{helper.ss} in the @scheme{my-lib} collection that contains
@filepath{manual.scrbl}:
@itemize[
@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
@; planet libraries
@ -370,7 +381,7 @@ generates:
@item{If you use @scheme[my-helper] in any documentation now, as long
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.}
}

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

@ -7,6 +7,7 @@
(load-relative "read.ss")
(load-relative "macro.ss")
(load-relative "syntax.ss")
(load-relative "procs.ss")
(load-relative "stx.ss")
(load-relative "module.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 "list.ss")
(load-in-sandbox "function.ss")
(load-in-sandbox "dict.ss")
(load-in-sandbox "promise.ss")
(load-in-sandbox "contract-test.ss")

37
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_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_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_Meta_Continuation *available_prompt_mc;
static Scheme_Object *reduced_procedure_struct;
typedef void (*DW_PrePost_Proc)(void *);
#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;
} else if (type == scheme_proc_struct_type) {
int is_method;
if (reduced_procedure_struct
&& scheme_is_struct_instance(reduced_procedure_struct, p)) {
if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
if (a >= 0)
bign = scheme_make_integer(a);
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);
}
return scheme_false;
} else if (SCHEME_NULLP(v)) {
return scheme_false;
} else {
return (scheme_bin_eq(v, bign)
? scheme_true
@ -3390,20 +3392,20 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
scheme_wrong_type("procedure-reduce-arity", "arity", 1, argc, argv);
}
if (!reduced_procedure_struct) {
REGISTER_SO(reduced_procedure_struct);
if (!scheme_reduced_procedure_struct) {
REGISTER_SO(scheme_reduced_procedure_struct);
pr = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
while (((Scheme_Inspector *)pr)->superior->superior) {
pr = (Scheme_Object *)((Scheme_Inspector *)pr)->superior;
}
orig = scheme_builtin_value("prop:procedure");
reduced_procedure_struct = scheme_make_proc_struct_type(NULL,
NULL,
pr,
2, 0,
scheme_false,
scheme_make_integer(0),
NULL);
scheme_reduced_procedure_struct = scheme_make_proc_struct_type(NULL,
NULL,
pr,
2, 0,
scheme_false,
scheme_make_integer(0),
NULL);
}
/* Check whether current arity covers the requested arity. This is
@ -3525,11 +3527,10 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
if (SCHEME_NULLP(ol)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"procedure-reduce-arity: arity of procedre: %V"
" does not include requested arity: %V : %V",
"procedure-reduce-arity: arity of procedure: %V"
" does not include requested arity: %V",
argv[0],
argv[1],
ra);
argv[1]);
return NULL;
}
@ -3542,7 +3543,7 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
pr = clone_arity(argv[1]);
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[])

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_Object *past_checkeds, *future_checkeds, *future_todos, *past_to_modchains, *past_todos;
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]))
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;
past_to_modchains = scheme_null;
first_iteration = 1;
/* Check whether todo, or anything it needs, is already declared
incompatibly. Successive iterations of the outer loop explore
successive phases (i.e, for-syntax levels). */
@ -1272,6 +1274,13 @@ static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[])
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
deeper in phases (for-syntax levels) than the target
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);
}
/* 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)
scheme_run_module(menv, 1);
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_reduced_procedure_struct;
/*========================================================================*/
/* 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);
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);
if (v && !is_method && SCHEME_PROCP(v))
return v;