suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r12046

original commit: 7a55275a26f4052af6ec87f2737f367721abc4ec
This commit is contained in:
Matthew Flatt 2008-10-15 22:23:56 +00:00
parent 88e4b31afe
commit 1096283709
1 changed files with 244 additions and 153 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

397
collects/scribble/manual.ss
View File

@ -12,7 +12,9 @@
scheme/stxparam scheme/stxparam
scheme/serialize scheme/serialize
setup/main-collects setup/main-collects
(for-syntax scheme/base) (for-syntax scheme/base
syntax/boundmap
syntax/kerncase)
(for-label scheme/base (for-label scheme/base
scheme/class)) scheme/class))
@ -739,13 +741,16 @@
[(_ [[proto result] ...] desc ...) [(_ [[proto result] ...] desc ...)
(defproc* #:mode procedure #:within #f [[proto result] ...] desc ...)] (defproc* #:mode procedure #:within #f [[proto result] ...] desc ...)]
[(_ #:mode m #:within cl [[proto result] ...] desc ...) [(_ #:mode m #:within cl [[proto result] ...] desc ...)
(*defproc 'm (quote-syntax/loc cl) (with-togetherable-scheme-variables
(list (extract-proc-id proto) ...) ()
'[proto ...] ([proc proto] ...)
(list (arg-contracts proto) ...) (*defproc 'm (quote-syntax/loc cl)
(list (arg-defaults proto) ...) (list (extract-proc-id proto) ...)
(list (lambda () (result-contract result)) ...) '[proto ...]
(lambda () (list desc ...)))])) (list (arg-contracts proto) ...)
(list (arg-defaults proto) ...)
(list (lambda () (result-contract result)) ...)
(lambda () (list desc ...))))]))
(define-syntax defstruct (define-syntax defstruct
(syntax-rules () (syntax-rules ()
[(_ name fields #:mutable #:inspector #f desc ...) [(_ name fields #:mutable #:inspector #f desc ...)
@ -762,10 +767,13 @@
(**defstruct name fields #t #f desc ...)])) (**defstruct name fields #t #f desc ...)]))
(define-syntax-rule (**defstruct name ([field field-contract] ...) immutable? (define-syntax-rule (**defstruct name ([field field-contract] ...) immutable?
transparent? desc ...) transparent? desc ...)
(*defstruct (quote-syntax/loc name) 'name (with-togetherable-scheme-variables
'([field field-contract] ...) ()
(list (lambda () (schemeblock0 field-contract)) ...) ()
immutable? transparent? (lambda () (list desc ...)))) (*defstruct (quote-syntax/loc name) 'name
'([field field-contract] ...)
(list (lambda () (schemeblock0 field-contract)) ...)
immutable? transparent? (lambda () (list desc ...)))))
(define-syntax (defform*/subs stx) (define-syntax (defform*/subs stx)
(syntax-case stx () (syntax-case stx ()
[(_ #:id defined-id #:literals (lit ...) [spec spec1 ...] [(_ #:id defined-id #:literals (lit ...) [spec spec1 ...]
@ -783,16 +791,20 @@
spec spec
spec)] spec)]
[_ spec])))]) [_ spec])))])
#'(*defforms (quote-syntax/loc defined-id) '(lit ...) #'(with-togetherable-scheme-variables
'(spec spec1 ...) (lit ...)
(list (lambda (x) (schemeblock0/form new-spec)) ([form spec] [form spec1] ...
(lambda (ignored) (schemeblock0/form spec1)) ...) [non-term (non-term-id non-term-form ...)] ...)
'((non-term-id non-term-form ...) ...) (*defforms (quote-syntax/loc defined-id)
(list (list (lambda () (scheme non-term-id)) '(spec spec1 ...)
(lambda () (schemeblock0/form non-term-form)) (list (lambda (x) (schemeblock0/form new-spec))
...) (lambda (ignored) (schemeblock0/form spec1)) ...)
...) '((non-term-id non-term-form ...) ...)
(lambda () (list desc ...))))] (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 ...] ...) [(fm #:id id [spec spec1 ...] ([non-term-id non-term-form ...] ...)
desc ...) desc ...)
#'(fm #:id id #:literals () [spec spec1 ...] #'(fm #:id id #:literals () [spec spec1 ...]
@ -839,46 +851,60 @@
(define-syntax (defform/none stx) (define-syntax (defform/none stx)
(syntax-case stx () (syntax-case stx ()
[(_ #:literals (lit ...) spec desc ...) [(_ #:literals (lit ...) spec desc ...)
#'(*defforms #f '(lit ...) #'(with-togetherable-scheme-variables
'(spec) (list (lambda (ignored) (schemeblock0/form spec))) (lit ...)
null null ([form spec])
(lambda () (list desc ...)))] (*defforms #f
'(spec) (list (lambda (ignored) (schemeblock0/form spec)))
null null
(lambda () (list desc ...))))]
[(_ spec desc ...) [(_ spec desc ...)
#'(defform/none #:literals () spec desc ...)])) #'(defform/none #:literals () spec desc ...)]))
(define-syntax (defidform stx) (define-syntax (defidform stx)
(syntax-case stx () (syntax-case stx ()
[(_ spec-id desc ...) [(_ spec-id desc ...)
#'(*defforms (quote-syntax/loc spec-id) null #'(with-togetherable-scheme-variables
'(spec-id) ()
(list (lambda (x) (make-omitable-paragraph (list x)))) ()
null (*defforms (quote-syntax/loc spec-id)
null '(spec-id)
(lambda () (list desc ...)))])) (list (lambda (x) (make-omitable-paragraph (list x))))
null
null
(lambda () (list desc ...))))]))
(define-syntax (defsubform stx) (define-syntax (defsubform stx)
(syntax-case stx () (syntax-case stx ()
[(_ . rest) #'(into-blockquote (defform . rest))])) [(_ . rest) #'(into-blockquote (defform . rest))]))
(define-syntax (defsubform* stx) (define-syntax (defsubform* stx)
(syntax-case stx () (syntax-case stx ()
[(_ . rest) #'(into-blockquote (defform* . rest))])) [(_ . 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 (define-syntax specsubform
(syntax-rules () (syntax-rules ()
[(_ #:literals (lit ...) spec desc ...) [(_ #:literals (lit ...) spec desc ...)
(*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec)) (spec?form/subs #f #:literals (lit ...) spec () desc ...)]
null null (lambda () (list desc ...)))]
[(_ spec desc ...) [(_ spec desc ...)
(*specsubform 'spec #f null (lambda () (schemeblock0/form spec)) (specsubform #:literals () spec desc ...)]))
null null (lambda () (list desc ...)))]))
(define-syntax specsubform/subs (define-syntax specsubform/subs
(syntax-rules () (syntax-rules ()
[(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
desc ...) desc ...)
(*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec)) (spec?form/subs #f #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
'((non-term-id non-term-form ...) ...) desc ...)]
(list (list (lambda () (scheme non-term-id))
(lambda () (schemeblock0/form non-term-form))
...)
...)
(lambda () (list desc ...)))]
[(_ spec subs desc ...) [(_ spec subs desc ...)
(specsubform/subs #:literals () spec subs desc ...)])) (specsubform/subs #:literals () spec subs desc ...)]))
(define-syntax-rule (specspecsubform spec desc ...) (define-syntax-rule (specspecsubform spec desc ...)
@ -888,37 +914,37 @@
(define-syntax specform (define-syntax specform
(syntax-rules () (syntax-rules ()
[(_ #:literals (lit ...) spec desc ...) [(_ #:literals (lit ...) spec desc ...)
(*specsubform 'spec #t '(lit ...) (lambda () (schemeblock0/form spec)) (spec?form/subs #t #:literals (lit ...) spec () desc ...)]
null null (lambda () (list desc ...)))]
[(_ spec desc ...) [(_ spec desc ...)
(*specsubform 'spec #t null (lambda () (schemeblock0/form spec)) (specform #:literals () spec desc ...)]))
null null (lambda () (list desc ...)))]))
(define-syntax specform/subs (define-syntax specform/subs
(syntax-rules () (syntax-rules ()
[(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
desc ...) desc ...)
(*specsubform 'spec #t (spec?form/subs #t #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
'(lit ...) desc ...)]
(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 ([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 ...] ...) (specform/subs #:literals () spec ([non-term-id non-term-form ...] ...)
desc ...)])) desc ...)]))
(define-syntax-rule (specsubform/inline spec 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 ...) (define-syntax-rule (defthing id result desc ...)
(*defthing (list (quote-syntax/loc id)) (list 'id) #f (with-togetherable-scheme-variables
(list (schemeblock0 result)) ()
(lambda () (list desc ...)))) ()
(*defthing (list (quote-syntax/loc id)) (list 'id) #f
(list (schemeblock0 result))
(lambda () (list desc ...)))))
(define-syntax-rule (defthing* ([id result] ...) desc ...) (define-syntax-rule (defthing* ([id result] ...) desc ...)
(*defthing (list (quote-syntax/loc id) ...) (list 'id ...) #f (with-togetherable-scheme-variables
(list (schemeblock0 result) ...) ()
(lambda () (list desc ...)))) ()
(*defthing (list (quote-syntax/loc id) ...) (list 'id ...) #f
(list (schemeblock0 result) ...)
(lambda () (list desc ...)))))
(define-syntax-rule (defparam id arg contract desc ...) (define-syntax-rule (defparam id arg contract desc ...)
(defproc* ([(id) contract] [(id [arg contract]) void?]) desc ...)) (defproc* ([(id) contract] [(id [arg contract]) void?]) desc ...))
(define-syntax-rule (defparam* id arg in-contract out-contract desc ...) (define-syntax-rule (defparam* id arg in-contract out-contract desc ...)
@ -928,20 +954,26 @@
(define-syntax schemegrammar (define-syntax schemegrammar
(syntax-rules () (syntax-rules ()
[(_ #:literals (lit ...) id clause ...) [(_ #:literals (lit ...) id clause ...)
(*schemegrammar '(lit ...) (with-scheme-variables
'(id clause ...) (lit ...)
(lambda () ([non-term (id clause ...)])
(list (list (scheme id) (*schemegrammar '(lit ...)
(schemeblock0/form clause) ...))))] '(id clause ...)
(lambda ()
(list (list (scheme id)
(schemeblock0/form clause) ...)))))]
[(_ id clause ...) (schemegrammar #:literals () id clause ...)])) [(_ id clause ...) (schemegrammar #:literals () id clause ...)]))
(define-syntax schemegrammar* (define-syntax schemegrammar*
(syntax-rules () (syntax-rules ()
[(_ #:literals (lit ...) [id clause ...] ...) [(_ #:literals (lit ...) [id clause ...] ...)
(*schemegrammar '(lit ...) (with-scheme-variables
'(id ... clause ... ...) (lit ...)
(lambda () ([non-term (id clause ...)] ...)
(list (list (scheme id) (schemeblock0/form clause) ...) (*schemegrammar '(lit ...)
...)))] '(id ... clause ... ...)
(lambda ()
(list (list (scheme id) (schemeblock0/form clause) ...)
...))))]
[(_ [id clause ...] ...) [(_ [id clause ...] ...)
(schemegrammar* #:literals () [id clause ...] ...)])) (schemegrammar* #:literals () [id clause ...] ...)]))
(define-syntax-rule (var id) (define-syntax-rule (var id)
@ -949,6 +981,75 @@
(define-syntax-rule (svar id) (define-syntax-rule (svar id)
(*var '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) (define (defthing/proc id contract descs)
(*defthing (list id) (list (syntax-e id)) #f (list contract) (*defthing (list id) (list (syntax-e id)) #f (list contract)
(lambda () descs))) (lambda () descs)))
@ -1009,7 +1110,7 @@
(lambda (render part ri) (lambda (render part ri)
(proc (or (get-exporting-libraries render part ri) null))))) (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) (define (*deftogether boxes body-thunk)
(make-splice (make-splice
@ -1029,12 +1130,33 @@
"together" "together"
(table-flowss (car (splice-run box)))))))) (table-flowss (car (splice-run box))))))))
boxes)) boxes))
(parameterize ([current-variable-list (body-thunk))))
(append-map box-splice-var-list boxes)])
(body-thunk)))))
(define-syntax-rule (deftogether (box ...) . body) (define-syntax (deftogether stx)
(*deftogether (list box ...) (lambda () (list . body)))) (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 (define-struct arg
(special? kw id optional? starts-optional? ends-optional? num-closers)) (special? kw id optional? starts-optional? ends-optional? num-closers))
@ -1365,22 +1487,20 @@
(define var-list (define var-list
(filter-map (lambda (a) (and (not (arg-special? a)) (arg-id a))) (filter-map (lambda (a) (and (not (arg-special? a)) (arg-id a)))
(append* all-args))) (append* all-args)))
(parameterize ([current-variable-list var-list]) (make-box-splice
(make-box-splice (cons
(cons (make-table
(make-table 'boxed
'boxed (append-map
(append-map do-one
do-one stx-ids prototypes all-args arg-contractss arg-valss result-contracts
stx-ids prototypes all-args arg-contractss arg-valss result-contracts (let loop ([ps prototypes] [accum null])
(let loop ([ps prototypes] [accum null]) (cond [(null? ps) null]
(cond [(null? ps) null] [(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum)
[(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum) (cons #f (loop (cdr ps) accum))]
(cons #f (loop (cdr ps) accum))] [else (cons #t (loop (cdr ps)
[else (cons #t (loop (cdr ps) (cons (extract-id (car ps)) accum)))]))))
(cons (extract-id (car ps)) accum)))])))) (content-thunk))))
(content-thunk))
var-list)))
(define (make-target-element* inner-make-target-element stx-id content wrappers) (define (make-target-element* inner-make-target-element stx-id content wrappers)
(if (null? wrappers) (if (null? wrappers)
@ -1577,8 +1697,7 @@
(make-flow (list (field-contract))))))))] (make-flow (list (field-contract))))))))]
[else null])) [else null]))
fields field-contracts))) fields field-contracts)))
(content-thunk)) (content-thunk))))
null))
(define (*defthing stx-ids names form? result-contracts content-thunk) (define (*defthing stx-ids names form? result-contracts content-thunk)
(make-box-splice (make-box-splice
@ -1623,24 +1742,12 @@
result-contract result-contract
(make-omitable-paragraph (list result-contract))))))))))) (make-omitable-paragraph (list result-contract)))))))))))
stx-ids names result-contracts)) stx-ids names result-contracts))
(content-thunk)) (content-thunk))))
null))
(define (meta-symbol? s) (memq s '(... ...+ ?))) (define (meta-symbol? s) (memq s '(... ...+ ?)))
(define (*defforms kw-id lits forms form-procs subs sub-procs content-thunk) (define (*defforms kw-id forms form-procs subs sub-procs content-thunk)
(define var-list (parameterize ([current-meta-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 '(... ...+)])
(make-box-splice (make-box-splice
(cons (cons
(make-table (make-table
@ -1689,23 +1796,10 @@
(*schemerawgrammars "specgrammar" (*schemerawgrammars "specgrammar"
(map car l) (map car l)
(map cdr l)))))))))) (map cdr l))))))))))
(content-thunk)) (content-thunk)))))
var-list)))
(define (*specsubform form has-kw? lits form-thunk subs sub-procs content-thunk) (define (*specsubform form lits form-thunk subs sub-procs content-thunk)
(parameterize ([current-variable-list (parameterize ([current-meta-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 '(... ...+)])
(make-blockquote (make-blockquote
"leftindent" "leftindent"
(cons (cons
@ -1754,23 +1848,14 @@
(*schemerawgrammars style (list nonterm) (list (cons clause1 clauses)))) (*schemerawgrammars style (list nonterm) (list (cons clause1 clauses))))
(define (*schemegrammar lits s-expr clauseses-thunk) (define (*schemegrammar lits s-expr clauseses-thunk)
(parameterize ([current-variable-list (let ([l (clauseses-thunk)])
(let loop ([form s-expr]) (*schemerawgrammars #f
(cond (map (lambda (x)
[(symbol? form) (if (memq form lits) (make-element #f
null (list (hspace 2)
(list form))] (car x))))
[(pair? form) (append (loop (car form)) l)
(loop (cdr form)))] (map cdr l))))
[else null]))])
(let ([l (clauseses-thunk)])
(*schemerawgrammars #f
(map (lambda (x)
(make-element #f
(list (hspace 2)
(car x))))
l)
(map cdr l)))))
(define (*var id) (define (*var id)
(to-element (*var-sym id))) (to-element (*var-sym id)))
@ -2425,16 +2510,22 @@
signature-desc) signature-desc)
(define-syntax-rule (defsignature name (super ...) body ...) (define-syntax-rule (defsignature name (super ...) body ...)
(*defsignature (quote-syntax name) (with-togetherable-scheme-variables
(list (quote-syntax super) ...) ()
(lambda () (list body ...)) ()
#t)) (*defsignature (quote-syntax name)
(list (quote-syntax super) ...)
(lambda () (list body ...))
#t)))
(define-syntax-rule (defsignature/splice name (super ...) body ...) (define-syntax-rule (defsignature/splice name (super ...) body ...)
(*defsignature (quote-syntax name) (with-togetherable-scheme-variables
(list (quote-syntax super) ...) ()
(lambda () (list body ...)) ()
#f)) (*defsignature (quote-syntax name)
(list (quote-syntax super) ...)
(lambda () (list body ...))
#f)))
(define-struct sig-desc (in)) (define-struct sig-desc (in))
(define (signature-desc . l) (define (signature-desc . l)