From e25e7a109851e1c64273ad8fb0a69d5075e7b15d Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 22 Apr 2008 18:00:04 +0000
Subject: [PATCH] keyword in methods and apply; procedure-reduce-keyword-arity

svn: r9396
---
 collects/compiler/compiler-unit.ss            |   9 +-
 collects/mysterx/installer.ss                 |   3 +-
 collects/mzscheme/mzscheme.scrbl              |  10 +-
 collects/scheme/private/class-internal.ss     |  70 +++++-
 collects/scheme/private/classidmap.ss         |  83 +++----
 collects/scheme/private/kw.ss                 | 154 ++++++++++---
 collects/scheme/private/pre-base.ss           |  36 ++-
 collects/scribblings/reference/class.scrbl    |  65 +++---
 .../scribblings/reference/procedures.scrbl    |  93 ++++++--
 collects/scribblings/scribble/how-to.scrbl    |  55 +++--
 collects/tests/mzscheme/mz.ss                 |   1 +
 collects/tests/mzscheme/procs.ss              | 218 ++++++++++++++++++
 collects/tests/mzscheme/scheme.ss             |   1 +
 src/mzscheme/src/fun.c                        |  37 +--
 src/mzscheme/src/module.c                     |  15 +-
 src/mzscheme/src/schpriv.h                    |   2 +
 src/mzscheme/src/struct.c                     |   5 +
 17 files changed, 680 insertions(+), 177 deletions(-)
 create mode 100644 collects/tests/mzscheme/procs.ss

diff --git a/collects/compiler/compiler-unit.ss b/collects/compiler/compiler-unit.ss
index b5902d0a03..db11456a4b 100644
--- a/collects/compiler/compiler-unit.ss
+++ b/collects/compiler/compiler-unit.ss
@@ -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)
 
diff --git a/collects/mysterx/installer.ss b/collects/mysterx/installer.ss
index e1b816d4ff..cd4db1ef61 100644
--- a/collects/mysterx/installer.ss
+++ b/collects/mysterx/installer.ss
@@ -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)
diff --git a/collects/mzscheme/mzscheme.scrbl b/collects/mzscheme/mzscheme.scrbl
index b2ba16b48c..626cf2578f 100644
--- a/collects/mzscheme/mzscheme.scrbl
+++ b/collects/mzscheme/mzscheme.scrbl
@@ -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?]
diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index ad57672b3a..dcacd26b86 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -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?
diff --git a/collects/scheme/private/classidmap.ss b/collects/scheme/private/classidmap.ss
index 8358797c7d..f46886cf2f 100644
--- a/collects/scheme/private/classidmap.ss
+++ b/collects/scheme/private/classidmap.ss
@@ -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?)))
diff --git a/collects/scheme/private/kw.ss b/collects/scheme/private/kw.ss
index c65f1a3a67..97d718218a 100644
--- a/collects/scheme/private/kw.ss
+++ b/collects/scheme/private/kw.ss
@@ -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 
@@ -75,16 +91,24 @@
                       1 0 #f
                       (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)])
@@ -106,7 +130,7 @@
                   #f
                   plain-proc)])])
       make-keyword-procedure))
-
+                         
   (define (keyword-apply proc kws kw-vals . normal-argss)
     (let ([type-error
            (lambda (what which)
@@ -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))))
diff --git a/collects/scheme/private/pre-base.ss b/collects/scheme/private/pre-base.ss
index e83ca9b684..84a389fca4 100644
--- a/collects/scheme/private/pre-base.ss
+++ b/collects/scheme/private/pre-base.ss
@@ -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))
diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl
index 686decf57a..15dea2ea79 100644
--- a/collects/scribblings/reference/class.scrbl
+++ b/collects/scribblings/reference/class.scrbl
@@ -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
diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl
index dc0c3c4fcc..f0e1a9449c 100644
--- a/collects/scribblings/reference/procedures.scrbl
+++ b/collects/scribblings/reference/procedures.scrbl
@@ -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)
diff --git a/collects/scribblings/scribble/how-to.scrbl b/collects/scribblings/scribble/how-to.scrbl
index e834c39ea4..97fe5bdd6c 100644
--- a/collects/scribblings/scribble/how-to.scrbl
+++ b/collects/scribblings/scribble/how-to.scrbl
@@ -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.}
 
 }
diff --git a/collects/tests/mzscheme/mz.ss b/collects/tests/mzscheme/mz.ss
index 1b116c5eb9..a6bfe07a1a 100644
--- a/collects/tests/mzscheme/mz.ss
+++ b/collects/tests/mzscheme/mz.ss
@@ -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")
diff --git a/collects/tests/mzscheme/procs.ss b/collects/tests/mzscheme/procs.ss
new file mode 100644
index 0000000000..8d4b214ff3
--- /dev/null
+++ b/collects/tests/mzscheme/procs.ss
@@ -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)
diff --git a/collects/tests/mzscheme/scheme.ss b/collects/tests/mzscheme/scheme.ss
index f4a0fc1b3d..72fffabc53 100644
--- a/collects/tests/mzscheme/scheme.ss
+++ b/collects/tests/mzscheme/scheme.ss
@@ -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")
 
diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c
index 8f72deee4d..033fcc4042 100644
--- a/src/mzscheme/src/fun.c
+++ b/src/mzscheme/src/fun.c
@@ -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[])
diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c
index 5fd7bac139..ea70581b7a 100644
--- a/src/mzscheme/src/module.c
+++ b/src/mzscheme/src/module.c
@@ -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)
diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h
index 91519d4741..fec1d5aee3 100644
--- a/src/mzscheme/src/schpriv.h
+++ b/src/mzscheme/src/schpriv.h
@@ -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                        */
 /*========================================================================*/
diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c
index 96c52905fe..77a9a5d610 100644
--- a/src/mzscheme/src/struct.c
+++ b/src/mzscheme/src/struct.c
@@ -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;