commit 109628370905fbf30d5e8d81476a557c986000c1
parent 88e4b31afe86fdfbab2d03fdb67ea67e911ffa3f
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 15 Oct 2008 22:23:56 +0000
unit bug fixes related to new scoping of signature elements; change scribble/manual to compute ids typeset as variables at compile time, in preparation for moving from a parameter to syntax bindings; fix docs typos; extend decompiler's support for unmarshaling syntax objects
svn: r12046
original commit: 7a55275a26f4052af6ec87f2737f367721abc4ec
Diffstat:
1 file changed, 245 insertions(+), 154 deletions(-)
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -12,7 +12,9 @@
scheme/stxparam
scheme/serialize
setup/main-collects
- (for-syntax scheme/base)
+ (for-syntax scheme/base
+ syntax/boundmap
+ syntax/kerncase)
(for-label scheme/base
scheme/class))
@@ -739,13 +741,16 @@
[(_ [[proto result] ...] desc ...)
(defproc* #:mode procedure #:within #f [[proto result] ...] desc ...)]
[(_ #:mode m #:within cl [[proto result] ...] desc ...)
- (*defproc 'm (quote-syntax/loc cl)
- (list (extract-proc-id proto) ...)
- '[proto ...]
- (list (arg-contracts proto) ...)
- (list (arg-defaults proto) ...)
- (list (lambda () (result-contract result)) ...)
- (lambda () (list desc ...)))]))
+ (with-togetherable-scheme-variables
+ ()
+ ([proc proto] ...)
+ (*defproc 'm (quote-syntax/loc cl)
+ (list (extract-proc-id proto) ...)
+ '[proto ...]
+ (list (arg-contracts proto) ...)
+ (list (arg-defaults proto) ...)
+ (list (lambda () (result-contract result)) ...)
+ (lambda () (list desc ...))))]))
(define-syntax defstruct
(syntax-rules ()
[(_ name fields #:mutable #:inspector #f desc ...)
@@ -762,10 +767,13 @@
(**defstruct name fields #t #f desc ...)]))
(define-syntax-rule (**defstruct name ([field field-contract] ...) immutable?
transparent? desc ...)
- (*defstruct (quote-syntax/loc name) 'name
- '([field field-contract] ...)
- (list (lambda () (schemeblock0 field-contract)) ...)
- immutable? transparent? (lambda () (list desc ...))))
+ (with-togetherable-scheme-variables
+ ()
+ ()
+ (*defstruct (quote-syntax/loc name) 'name
+ '([field field-contract] ...)
+ (list (lambda () (schemeblock0 field-contract)) ...)
+ immutable? transparent? (lambda () (list desc ...)))))
(define-syntax (defform*/subs stx)
(syntax-case stx ()
[(_ #:id defined-id #:literals (lit ...) [spec spec1 ...]
@@ -783,16 +791,20 @@
spec
spec)]
[_ spec])))])
- #'(*defforms (quote-syntax/loc defined-id) '(lit ...)
- '(spec spec1 ...)
- (list (lambda (x) (schemeblock0/form new-spec))
- (lambda (ignored) (schemeblock0/form spec1)) ...)
- '((non-term-id non-term-form ...) ...)
- (list (list (lambda () (scheme non-term-id))
- (lambda () (schemeblock0/form non-term-form))
- ...)
- ...)
- (lambda () (list desc ...))))]
+ #'(with-togetherable-scheme-variables
+ (lit ...)
+ ([form spec] [form spec1] ...
+ [non-term (non-term-id non-term-form ...)] ...)
+ (*defforms (quote-syntax/loc defined-id)
+ '(spec spec1 ...)
+ (list (lambda (x) (schemeblock0/form new-spec))
+ (lambda (ignored) (schemeblock0/form spec1)) ...)
+ '((non-term-id non-term-form ...) ...)
+ (list (list (lambda () (scheme non-term-id))
+ (lambda () (schemeblock0/form non-term-form))
+ ...)
+ ...)
+ (lambda () (list desc ...)))))]
[(fm #:id id [spec spec1 ...] ([non-term-id non-term-form ...] ...)
desc ...)
#'(fm #:id id #:literals () [spec spec1 ...]
@@ -839,46 +851,60 @@
(define-syntax (defform/none stx)
(syntax-case stx ()
[(_ #:literals (lit ...) spec desc ...)
- #'(*defforms #f '(lit ...)
- '(spec) (list (lambda (ignored) (schemeblock0/form spec)))
- null null
- (lambda () (list desc ...)))]
+ #'(with-togetherable-scheme-variables
+ (lit ...)
+ ([form spec])
+ (*defforms #f
+ '(spec) (list (lambda (ignored) (schemeblock0/form spec)))
+ null null
+ (lambda () (list desc ...))))]
[(_ spec desc ...)
#'(defform/none #:literals () spec desc ...)]))
(define-syntax (defidform stx)
(syntax-case stx ()
[(_ spec-id desc ...)
- #'(*defforms (quote-syntax/loc spec-id) null
- '(spec-id)
- (list (lambda (x) (make-omitable-paragraph (list x))))
- null
- null
- (lambda () (list desc ...)))]))
+ #'(with-togetherable-scheme-variables
+ ()
+ ()
+ (*defforms (quote-syntax/loc spec-id)
+ '(spec-id)
+ (list (lambda (x) (make-omitable-paragraph (list x))))
+ null
+ null
+ (lambda () (list desc ...))))]))
(define-syntax (defsubform stx)
(syntax-case stx ()
[(_ . rest) #'(into-blockquote (defform . rest))]))
(define-syntax (defsubform* stx)
(syntax-case stx ()
[(_ . rest) #'(into-blockquote (defform* . rest))]))
+(define-syntax spec?form/subs
+ (syntax-rules ()
+ [(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
+ desc ...)
+ (with-scheme-variables
+ (lit ...)
+ ([form/maybe (has-kw? spec)]
+ [non-term (non-term-id non-term-form ...)] ...)
+ (*specsubform 'spec '(lit ...) (lambda () (schemeblock0/form spec))
+ '((non-term-id non-term-form ...) ...)
+ (list (list (lambda () (scheme non-term-id))
+ (lambda () (schemeblock0/form non-term-form))
+ ...)
+ ...)
+ (lambda () (list desc ...))))]))
(define-syntax specsubform
(syntax-rules ()
[(_ #:literals (lit ...) spec desc ...)
- (*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec))
- null null (lambda () (list desc ...)))]
+ (spec?form/subs #f #:literals (lit ...) spec () desc ...)]
[(_ spec desc ...)
- (*specsubform 'spec #f null (lambda () (schemeblock0/form spec))
- null null (lambda () (list desc ...)))]))
+ (specsubform #:literals () spec desc ...)]))
(define-syntax specsubform/subs
(syntax-rules ()
[(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
desc ...)
- (*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec))
- '((non-term-id non-term-form ...) ...)
- (list (list (lambda () (scheme non-term-id))
- (lambda () (schemeblock0/form non-term-form))
- ...)
- ...)
- (lambda () (list desc ...)))]
+ (spec?form/subs #f #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
+ desc ...)]
[(_ spec subs desc ...)
(specsubform/subs #:literals () spec subs desc ...)]))
(define-syntax-rule (specspecsubform spec desc ...)
@@ -888,37 +914,37 @@
(define-syntax specform
(syntax-rules ()
[(_ #:literals (lit ...) spec desc ...)
- (*specsubform 'spec #t '(lit ...) (lambda () (schemeblock0/form spec))
- null null (lambda () (list desc ...)))]
+ (spec?form/subs #t #:literals (lit ...) spec () desc ...)]
[(_ spec desc ...)
- (*specsubform 'spec #t null (lambda () (schemeblock0/form spec))
- null null (lambda () (list desc ...)))]))
+ (specform #:literals () spec desc ...)]))
(define-syntax specform/subs
(syntax-rules ()
[(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
desc ...)
- (*specsubform 'spec #t
- '(lit ...)
- (lambda () (schemeblock0/form spec))
- '((non-term-id non-term-form ...) ...)
- (list (list (lambda () (scheme non-term-id))
- (lambda () (schemeblock0/form non-term-form))
- ...)
- ...)
- (lambda () (list desc ...)))]
+ (spec?form/subs #t #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
+ desc ...)]
[(_ spec ([non-term-id non-term-form ...] ...) desc ...)
(specform/subs #:literals () spec ([non-term-id non-term-form ...] ...)
desc ...)]))
(define-syntax-rule (specsubform/inline spec desc ...)
- (*specsubform 'spec #f null #f null null (lambda () (list desc ...))))
+ (with-scheme-variables
+ ()
+ ([form/maybe (#f spec)])
+ (*specsubform 'spec null #f null null (lambda () (list desc ...)))))
(define-syntax-rule (defthing id result desc ...)
- (*defthing (list (quote-syntax/loc id)) (list 'id) #f
- (list (schemeblock0 result))
- (lambda () (list desc ...))))
+ (with-togetherable-scheme-variables
+ ()
+ ()
+ (*defthing (list (quote-syntax/loc id)) (list 'id) #f
+ (list (schemeblock0 result))
+ (lambda () (list desc ...)))))
(define-syntax-rule (defthing* ([id result] ...) desc ...)
- (*defthing (list (quote-syntax/loc id) ...) (list 'id ...) #f
- (list (schemeblock0 result) ...)
- (lambda () (list desc ...))))
+ (with-togetherable-scheme-variables
+ ()
+ ()
+ (*defthing (list (quote-syntax/loc id) ...) (list 'id ...) #f
+ (list (schemeblock0 result) ...)
+ (lambda () (list desc ...)))))
(define-syntax-rule (defparam id arg contract desc ...)
(defproc* ([(id) contract] [(id [arg contract]) void?]) desc ...))
(define-syntax-rule (defparam* id arg in-contract out-contract desc ...)
@@ -928,20 +954,26 @@
(define-syntax schemegrammar
(syntax-rules ()
[(_ #:literals (lit ...) id clause ...)
- (*schemegrammar '(lit ...)
- '(id clause ...)
- (lambda ()
- (list (list (scheme id)
- (schemeblock0/form clause) ...))))]
+ (with-scheme-variables
+ (lit ...)
+ ([non-term (id clause ...)])
+ (*schemegrammar '(lit ...)
+ '(id clause ...)
+ (lambda ()
+ (list (list (scheme id)
+ (schemeblock0/form clause) ...)))))]
[(_ id clause ...) (schemegrammar #:literals () id clause ...)]))
(define-syntax schemegrammar*
(syntax-rules ()
[(_ #:literals (lit ...) [id clause ...] ...)
- (*schemegrammar '(lit ...)
- '(id ... clause ... ...)
- (lambda ()
- (list (list (scheme id) (schemeblock0/form clause) ...)
- ...)))]
+ (with-scheme-variables
+ (lit ...)
+ ([non-term (id clause ...)] ...)
+ (*schemegrammar '(lit ...)
+ '(id ... clause ... ...)
+ (lambda ()
+ (list (list (scheme id) (schemeblock0/form clause) ...)
+ ...))))]
[(_ [id clause ...] ...)
(schemegrammar* #:literals () [id clause ...] ...)]))
(define-syntax-rule (var id)
@@ -949,6 +981,75 @@
(define-syntax-rule (svar id)
(*var 'id))
+(define-syntax (with-togetherable-scheme-variables stx)
+ (syntax-case stx ()
+ [(_ . rest)
+ ;; Make it transparent, so deftogether is allowed to pull it apart
+ (syntax-property
+ (syntax/loc stx
+ (with-togetherable-scheme-variables* . rest))
+ 'certify-mode
+ 'transparent)]))
+
+(define-syntax-rule (with-togetherable-scheme-variables* . rest)
+ (with-scheme-variables . rest))
+
+(define-syntax (with-scheme-variables stx)
+ (syntax-case stx ()
+ [(_ lits ([kind s-exp] ...) body)
+ (let ([ht (make-bound-identifier-mapping)]
+ [lits (syntax->datum #'lits)])
+ (for-each (lambda (kind s-exp)
+ (case (syntax-e kind)
+ [(proc)
+ (for-each
+ (lambda (arg)
+ (if (identifier? arg)
+ (unless (or (eq? (syntax-e arg) '...)
+ (eq? (syntax-e arg) '...+)
+ (memq (syntax-e arg) lits))
+ (bound-identifier-mapping-put! ht arg #t))
+ (syntax-case arg ()
+ [(kw arg . rest)
+ (keyword? (syntax-e #'kw))
+ (bound-identifier-mapping-put! ht #'arg #t)]
+ [(arg . rest)
+ (identifier? #'arg)
+ (bound-identifier-mapping-put! ht #'arg #t)])))
+ (cdr (syntax->list s-exp)))]
+ [(form form/maybe non-term)
+ (let loop ([form (case (syntax-e kind)
+ [(form) (if (identifier? s-exp)
+ null
+ (cdr (syntax-e s-exp)))]
+ [(form/maybe)
+ (syntax-case s-exp ()
+ [(#f form) #'form]
+ [(#t (id . form)) #'form])]
+ [(non-term) s-exp])])
+ (if (identifier? form)
+ (unless (or (eq? (syntax-e form) '...)
+ (eq? (syntax-e form) '...+)
+ (eq? (syntax-e form) '?)
+ (memq (syntax-e form) lits))
+ (bound-identifier-mapping-put! ht form #t))
+ (syntax-case form (unsyntax)
+ [(unsyntax _) (void)]
+ [(a . b) (loop #'a) (loop #'b)]
+ [#(a ...) (loop #'(a ...))]
+ [_ (void)])))]
+ [else
+ (raise-syntax-error
+ #f
+ "unknown variable mode"
+ stx
+ kind)]))
+ (syntax->list #'(kind ...))
+ (syntax->list #'(s-exp ...)))
+ (with-syntax ([(id ...) (bound-identifier-mapping-map ht (lambda (k v) k))])
+ #'(parameterize ([current-variable-list '(id ...)])
+ body)))]))
+
(define (defthing/proc id contract descs)
(*defthing (list id) (list (syntax-e id)) #f (list contract)
(lambda () descs)))
@@ -1009,7 +1110,7 @@
(lambda (render part ri)
(proc (or (get-exporting-libraries render part ri) null)))))
-(define-struct (box-splice splice) (var-list))
+(define-struct (box-splice splice) ())
(define (*deftogether boxes body-thunk)
(make-splice
@@ -1029,12 +1130,33 @@
"together"
(table-flowss (car (splice-run box))))))))
boxes))
- (parameterize ([current-variable-list
- (append-map box-splice-var-list boxes)])
- (body-thunk)))))
+ (body-thunk))))
-(define-syntax-rule (deftogether (box ...) . body)
- (*deftogether (list box ...) (lambda () (list . body))))
+(define-syntax (deftogether stx)
+ (syntax-case stx ()
+ [(_ (def ...) . body)
+ (with-syntax ([((_ (lit ...) (var ...) decl) ...)
+ (map (lambda (def)
+ (let ([exp-def (local-expand
+ def
+ 'expression
+ (cons
+ #'with-togetherable-scheme-variables*
+ (kernel-form-identifier-list)))])
+ (syntax-case exp-def (with-togetherable-scheme-variables*)
+ [(with-togetherable-scheme-variables* lits vars decl)
+ exp-def]
+ [_
+ (raise-syntax-error
+ #f
+ "sub-form is not a documentation form that can be combined"
+ stx
+ def)])))
+ (syntax->list #'(def ...)))])
+ #'(with-togetherable-scheme-variables
+ (lit ... ...)
+ (var ... ...)
+ (*deftogether (list decl ...) (lambda () (list . body)))))]))
(define-struct arg
(special? kw id optional? starts-optional? ends-optional? num-closers))
@@ -1365,22 +1487,20 @@
(define var-list
(filter-map (lambda (a) (and (not (arg-special? a)) (arg-id a)))
(append* all-args)))
- (parameterize ([current-variable-list var-list])
- (make-box-splice
- (cons
- (make-table
- 'boxed
- (append-map
- do-one
- stx-ids prototypes all-args arg-contractss arg-valss result-contracts
- (let loop ([ps prototypes] [accum null])
- (cond [(null? ps) null]
- [(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum)
- (cons #f (loop (cdr ps) accum))]
- [else (cons #t (loop (cdr ps)
- (cons (extract-id (car ps)) accum)))]))))
- (content-thunk))
- var-list)))
+ (make-box-splice
+ (cons
+ (make-table
+ 'boxed
+ (append-map
+ do-one
+ stx-ids prototypes all-args arg-contractss arg-valss result-contracts
+ (let loop ([ps prototypes] [accum null])
+ (cond [(null? ps) null]
+ [(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum)
+ (cons #f (loop (cdr ps) accum))]
+ [else (cons #t (loop (cdr ps)
+ (cons (extract-id (car ps)) accum)))]))))
+ (content-thunk))))
(define (make-target-element* inner-make-target-element stx-id content wrappers)
(if (null? wrappers)
@@ -1577,8 +1697,7 @@
(make-flow (list (field-contract))))))))]
[else null]))
fields field-contracts)))
- (content-thunk))
- null))
+ (content-thunk))))
(define (*defthing stx-ids names form? result-contracts content-thunk)
(make-box-splice
@@ -1623,24 +1742,12 @@
result-contract
(make-omitable-paragraph (list result-contract)))))))))))
stx-ids names result-contracts))
- (content-thunk))
- null))
+ (content-thunk))))
(define (meta-symbol? s) (memq s '(... ...+ ?)))
-(define (*defforms kw-id lits forms form-procs subs sub-procs content-thunk)
- (define var-list
- (let loop ([form (cons forms subs)])
- (cond [(symbol? form)
- (if (or (meta-symbol? form)
- (and kw-id (eq? form (syntax-e kw-id)))
- (memq form lits))
- null
- (list form))]
- [(pair? form) (append (loop (car form)) (loop (cdr form)))]
- [else null])))
- (parameterize ([current-variable-list var-list]
- [current-meta-list '(... ...+)])
+(define (*defforms kw-id forms form-procs subs sub-procs content-thunk)
+ (parameterize ([current-meta-list '(... ...+)])
(make-box-splice
(cons
(make-table
@@ -1689,23 +1796,10 @@
(*schemerawgrammars "specgrammar"
(map car l)
(map cdr l))))))))))
- (content-thunk))
- var-list)))
-
-(define (*specsubform form has-kw? lits form-thunk subs sub-procs content-thunk)
- (parameterize ([current-variable-list
- (append (let loop ([form (cons (if has-kw? (cdr form) form)
- subs)])
- (cond
- [(symbol? form) (if (or (meta-symbol? form)
- (memq form lits))
- null
- (list form))]
- [(pair? form) (append (loop (car form))
- (loop (cdr form)))]
- [else null]))
- (current-variable-list))]
- [current-meta-list '(... ...+)])
+ (content-thunk)))))
+
+(define (*specsubform form lits form-thunk subs sub-procs content-thunk)
+ (parameterize ([current-meta-list '(... ...+)])
(make-blockquote
"leftindent"
(cons
@@ -1754,23 +1848,14 @@
(*schemerawgrammars style (list nonterm) (list (cons clause1 clauses))))
(define (*schemegrammar lits s-expr clauseses-thunk)
- (parameterize ([current-variable-list
- (let loop ([form s-expr])
- (cond
- [(symbol? form) (if (memq form lits)
- null
- (list form))]
- [(pair? form) (append (loop (car form))
- (loop (cdr form)))]
- [else null]))])
- (let ([l (clauseses-thunk)])
- (*schemerawgrammars #f
- (map (lambda (x)
- (make-element #f
- (list (hspace 2)
- (car x))))
- l)
- (map cdr l)))))
+ (let ([l (clauseses-thunk)])
+ (*schemerawgrammars #f
+ (map (lambda (x)
+ (make-element #f
+ (list (hspace 2)
+ (car x))))
+ l)
+ (map cdr l))))
(define (*var id)
(to-element (*var-sym id)))
@@ -2425,16 +2510,22 @@
signature-desc)
(define-syntax-rule (defsignature name (super ...) body ...)
- (*defsignature (quote-syntax name)
- (list (quote-syntax super) ...)
- (lambda () (list body ...))
- #t))
+ (with-togetherable-scheme-variables
+ ()
+ ()
+ (*defsignature (quote-syntax name)
+ (list (quote-syntax super) ...)
+ (lambda () (list body ...))
+ #t)))
(define-syntax-rule (defsignature/splice name (super ...) body ...)
- (*defsignature (quote-syntax name)
- (list (quote-syntax super) ...)
- (lambda () (list body ...))
- #f))
+ (with-togetherable-scheme-variables
+ ()
+ ()
+ (*defsignature (quote-syntax name)
+ (list (quote-syntax super) ...)
+ (lambda () (list body ...))
+ #f)))
(define-struct sig-desc (in))
(define (signature-desc . l)
