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
This commit is contained in:
Matthew Flatt
parent
61aa266525
commit
7a55275a26
|
|
@ -266,6 +266,7 @@
|
|||
|
||||
(define (decompile-lam expr globs stack)
|
||||
(match expr
|
||||
[(struct closure (lam gen-id)) (decompile-lam lam globs stack)]
|
||||
[(struct lam (name flags num-params rest? closure-map max-let-depth body))
|
||||
(let ([vars (for/list ([i (in-range num-params)])
|
||||
(gensym (format "arg~a-" i)))]
|
||||
|
|
|
|||
|
|
@ -453,7 +453,8 @@
|
|||
(for ([zo-file source-files])
|
||||
(let ([zo-file (path->complete-path zo-file)])
|
||||
(let-values ([(base name dir?) (split-path zo-file)])
|
||||
(parameterize ([current-load-relative-directory base])
|
||||
(parameterize ([current-load-relative-directory base]
|
||||
[print-graph #t])
|
||||
(pretty-print
|
||||
(decompile
|
||||
(call-with-input-file*
|
||||
|
|
|
|||
|
|
@ -306,7 +306,7 @@
|
|||
;; not sure if it's really unsigned
|
||||
(integer-bytes->integer (read-bytes 4 p) #f #f))
|
||||
|
||||
(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets))
|
||||
(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns))
|
||||
|
||||
(define (cp-getc cp)
|
||||
(begin-with-definitions
|
||||
|
|
@ -426,6 +426,124 @@
|
|||
|
||||
(define-struct not-ready ())
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Synatx unmarshaling
|
||||
|
||||
(define-form-struct wrapped (datum wraps certs))
|
||||
|
||||
(define (decode-stx cp v)
|
||||
(if (integer? v)
|
||||
(let-values ([(v2 decoded?) (unmarshal-stx-get cp v)])
|
||||
(if decoded?
|
||||
v2
|
||||
(let ([v2 (decode-stx cp v2)])
|
||||
(unmarshal-stx-set! cp v v2)
|
||||
v2)))
|
||||
(let loop ([v v])
|
||||
(let-values ([(cert-marks v encoded-wraps)
|
||||
(match v
|
||||
[`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)]
|
||||
[`(,datum . ,wraps) (values #f datum wraps)]
|
||||
[else (error 'decode-wraps "bad datum+wrap: ~e" v)])])
|
||||
(let* ([wraps (decode-wraps cp encoded-wraps)]
|
||||
[add-wrap (lambda (v) (make-wrapped v wraps cert-marks))])
|
||||
(cond
|
||||
[(pair? v)
|
||||
(if (eq? #t (car v))
|
||||
;; Share decoded wraps with all nested parts.
|
||||
(let loop ([v (cdr v)])
|
||||
(cond
|
||||
[(pair? v)
|
||||
(let ploop ([v v])
|
||||
(cond
|
||||
[(null? v) null]
|
||||
[(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))]
|
||||
[else (loop v)]))]
|
||||
[(box? v) (add-wrap (box (loop (unbox v))))]
|
||||
[(vector? v)
|
||||
(add-wrap (list->vector (map loop (vector->list v))))]
|
||||
[(prefab-struct-key v)
|
||||
=> (lambda (k)
|
||||
(add-wrap
|
||||
(apply
|
||||
make-prefab-struct
|
||||
k
|
||||
(map loop (cdr (vector->list (struct->vector v)))))))]
|
||||
[else (add-wrap v)]))
|
||||
;; Decode sub-elements that have their own wraps:
|
||||
(let-values ([(v counter) (if (exact-integer? (car v))
|
||||
(values (cdr v) (car v))
|
||||
(values v -1))])
|
||||
(add-wrap
|
||||
(let ploop ([v v][counter counter])
|
||||
(cond
|
||||
[(null? v) null]
|
||||
[(or (not (pair? v)) (zero? counter)) (loop v)]
|
||||
[(pair? v) (cons (loop (car v))
|
||||
(ploop (cdr v) (sub1 counter)))])))))]
|
||||
[(box? v) (add-wrap (box (loop (unbox v))))]
|
||||
[(vector? v)
|
||||
(add-wrap (list->vector (map loop (vector->list v))))]
|
||||
[(prefab-struct-key v)
|
||||
=> (lambda (k)
|
||||
(add-wrap
|
||||
(apply
|
||||
make-prefab-struct
|
||||
k
|
||||
(map loop (cdr (vector->list (struct->vector v)))))))]
|
||||
[else (add-wrap v)]))))))
|
||||
|
||||
(define (decode-wraps cp w)
|
||||
(if (integer? w)
|
||||
(let-values ([(w2 decoded?) (unmarshal-stx-get cp w)])
|
||||
(if decoded?
|
||||
w2
|
||||
(let ([w2 (decode-wraps cp w2)])
|
||||
(unmarshal-stx-set! cp w w2)
|
||||
w2)))
|
||||
(map (lambda (a)
|
||||
(let aloop ([a a])
|
||||
(cond
|
||||
[(integer? a)
|
||||
(let-values ([(a2 decoded?) (unmarshal-stx-get cp a)])
|
||||
(if decoded?
|
||||
a2
|
||||
(let ([a2 (aloop a2)])
|
||||
(unmarshal-stx-set! cp a a2)
|
||||
a2)))]
|
||||
[(and (pair? a) (null? (cdr a)) (number? (car a)))
|
||||
;; a mark
|
||||
(string->symbol (format "mark~a" (car a)))]
|
||||
[(vector? a)
|
||||
`(#%decode-lexical-rename ,a)]
|
||||
[(pair? a)
|
||||
`(#%decode-module-rename ,a)]
|
||||
[(boolean? a)
|
||||
`(#%top-level-rename ,a)]
|
||||
[(symbol? a)
|
||||
'(#%mark-barrier)]
|
||||
[(box? a)
|
||||
`(#%phase-shift ,(unbox a))]
|
||||
[else (error 'decode-wraps "bad wrap element: ~e" a)])))
|
||||
w)))
|
||||
|
||||
(define (unmarshal-stx-get cp pos)
|
||||
(if (pos . >= . (vector-length (cport-symtab cp)))
|
||||
(values `(#%bad-index ,pos) #t)
|
||||
(let ([v (vector-ref (cport-symtab cp) pos)])
|
||||
(if (not-ready? v)
|
||||
(let ([save-pos (cport-pos cp)])
|
||||
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos)))
|
||||
(let ([v (read-compact cp)])
|
||||
(vector-set! (cport-symtab cp) pos v)
|
||||
(set-cport-pos! cp save-pos)
|
||||
(values v #f)))
|
||||
(values v (vector-ref (cport-decoded cp) pos))))))
|
||||
|
||||
(define (unmarshal-stx-set! cp pos v)
|
||||
(vector-set! (cport-symtab cp) pos v)
|
||||
(vector-set! (cport-decoded cp) pos #t))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Main parsing loop
|
||||
|
||||
|
|
@ -535,7 +653,7 @@
|
|||
[(marshalled) (read-marshalled (read-compact-number cp) cp)]
|
||||
[(stx)
|
||||
(let ([v (make-reader-graph (read-compact cp))])
|
||||
(make-stx v))]
|
||||
(make-stx (decode-stx cp v)))]
|
||||
[(local local-unbox)
|
||||
(let ([c (read-compact-number cp)]
|
||||
[unbox? (eq? cpt-tag 'local-unbox)])
|
||||
|
|
@ -666,7 +784,7 @@
|
|||
|
||||
(define symtab (make-vector symtabsize (make-not-ready)))
|
||||
|
||||
(define cp (make-cport 0 port size* rst symtab so*))
|
||||
(define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash)))
|
||||
(for/list ([i (in-range 1 symtabsize)])
|
||||
(when (not-ready? (vector-ref symtab i))
|
||||
(set-cport-pos! cp (vector-ref so* (sub1 i)))
|
||||
|
|
|
|||
|
|
@ -355,7 +355,7 @@
|
|||
(define (process-tagged-import spec)
|
||||
(process-tagged-import/export spec #t #t))
|
||||
(define (process-tagged-export spec)
|
||||
(process-tagged-import/export spec #f #f))
|
||||
(process-tagged-import/export spec #f #t))
|
||||
|
||||
;; process-spec : syntax-object -> sig
|
||||
(define (process-spec spec)
|
||||
|
|
|
|||
|
|
@ -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 ...)
|
||||
(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 ...)))]))
|
||||
(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 ...)
|
||||
(with-togetherable-scheme-variables
|
||||
()
|
||||
()
|
||||
(*defstruct (quote-syntax/loc name) 'name
|
||||
'([field field-contract] ...)
|
||||
(list (lambda () (schemeblock0 field-contract)) ...)
|
||||
immutable? transparent? (lambda () (list desc ...))))
|
||||
immutable? transparent? (lambda () (list desc ...)))))
|
||||
(define-syntax (defform*/subs stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:id defined-id #:literals (lit ...) [spec spec1 ...]
|
||||
|
|
@ -783,7 +791,11 @@
|
|||
spec
|
||||
spec)]
|
||||
[_ spec])))])
|
||||
#'(*defforms (quote-syntax/loc defined-id) '(lit ...)
|
||||
#'(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)) ...)
|
||||
|
|
@ -792,7 +804,7 @@
|
|||
(lambda () (schemeblock0/form non-term-form))
|
||||
...)
|
||||
...)
|
||||
(lambda () (list desc ...))))]
|
||||
(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 ...)
|
||||
#'(with-togetherable-scheme-variables
|
||||
(lit ...)
|
||||
([form spec])
|
||||
(*defforms #f
|
||||
'(spec) (list (lambda (ignored) (schemeblock0/form spec)))
|
||||
null null
|
||||
(lambda () (list desc ...)))]
|
||||
(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
|
||||
#'(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 ...)))]))
|
||||
(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 specsubform
|
||||
(define-syntax spec?form/subs
|
||||
(syntax-rules ()
|
||||
[(_ #:literals (lit ...) spec desc ...)
|
||||
(*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec))
|
||||
null null (lambda () (list desc ...)))]
|
||||
[(_ spec desc ...)
|
||||
(*specsubform 'spec #f null (lambda () (schemeblock0/form spec))
|
||||
null null (lambda () (list desc ...)))]))
|
||||
(define-syntax specsubform/subs
|
||||
(syntax-rules ()
|
||||
[(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
|
||||
[(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
|
||||
desc ...)
|
||||
(*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec))
|
||||
(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 ...)))]
|
||||
(lambda () (list desc ...))))]))
|
||||
(define-syntax specsubform
|
||||
(syntax-rules ()
|
||||
[(_ #:literals (lit ...) spec desc ...)
|
||||
(spec?form/subs #f #:literals (lit ...) spec () desc ...)]
|
||||
[(_ spec desc ...)
|
||||
(specsubform #:literals () spec desc ...)]))
|
||||
(define-syntax specsubform/subs
|
||||
(syntax-rules ()
|
||||
[(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
|
||||
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 ...)
|
||||
(with-togetherable-scheme-variables
|
||||
()
|
||||
()
|
||||
(*defthing (list (quote-syntax/loc id)) (list 'id) #f
|
||||
(list (schemeblock0 result))
|
||||
(lambda () (list desc ...))))
|
||||
(lambda () (list desc ...)))))
|
||||
(define-syntax-rule (defthing* ([id result] ...) desc ...)
|
||||
(with-togetherable-scheme-variables
|
||||
()
|
||||
()
|
||||
(*defthing (list (quote-syntax/loc id) ...) (list 'id ...) #f
|
||||
(list (schemeblock0 result) ...)
|
||||
(lambda () (list desc ...))))
|
||||
(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 ...)
|
||||
(with-scheme-variables
|
||||
(lit ...)
|
||||
([non-term (id clause ...)])
|
||||
(*schemegrammar '(lit ...)
|
||||
'(id clause ...)
|
||||
(lambda ()
|
||||
(list (list (scheme id)
|
||||
(schemeblock0/form clause) ...))))]
|
||||
(schemeblock0/form clause) ...)))))]
|
||||
[(_ id clause ...) (schemegrammar #:literals () id clause ...)]))
|
||||
(define-syntax schemegrammar*
|
||||
(syntax-rules ()
|
||||
[(_ #:literals (lit ...) [id 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,7 +1487,6 @@
|
|||
(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
|
||||
|
|
@ -1379,8 +1500,7 @@
|
|||
(cons #f (loop (cdr ps) accum))]
|
||||
[else (cons #t (loop (cdr ps)
|
||||
(cons (extract-id (car ps)) accum)))]))))
|
||||
(content-thunk))
|
||||
var-list)))
|
||||
(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)))
|
||||
(content-thunk)))))
|
||||
|
||||
(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 '(... ...+)])
|
||||
(define (*specsubform form lits form-thunk subs sub-procs content-thunk)
|
||||
(parameterize ([current-meta-list '(... ...+)])
|
||||
(make-blockquote
|
||||
"leftindent"
|
||||
(cons
|
||||
|
|
@ -1754,15 +1848,6 @@
|
|||
(*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)
|
||||
|
|
@ -1770,7 +1855,7 @@
|
|||
(list (hspace 2)
|
||||
(car x))))
|
||||
l)
|
||||
(map cdr 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 ...)
|
||||
(with-togetherable-scheme-variables
|
||||
()
|
||||
()
|
||||
(*defsignature (quote-syntax name)
|
||||
(list (quote-syntax super) ...)
|
||||
(lambda () (list body ...))
|
||||
#t))
|
||||
#t)))
|
||||
|
||||
(define-syntax-rule (defsignature/splice name (super ...) body ...)
|
||||
(with-togetherable-scheme-variables
|
||||
()
|
||||
()
|
||||
(*defsignature (quote-syntax name)
|
||||
(list (quote-syntax super) ...)
|
||||
(lambda () (list body ...))
|
||||
#f))
|
||||
#f)))
|
||||
|
||||
(define-struct sig-desc (in))
|
||||
(define (signature-desc . l)
|
||||
|
|
|
|||
|
|
@ -391,7 +391,7 @@ fast-clause [id fast-seq]
|
|||
]
|
||||
|
||||
@schemegrammar[
|
||||
#:literals [in-range in-naturals in-list in-vector in-string in-bytes stop-before stop-after]
|
||||
#:literals [in-range in-naturals in-list in-vector in-string in-bytes in-value stop-before stop-after]
|
||||
fast-seq (in-range expr expr)
|
||||
(in-range expr expr expr)
|
||||
(in-naturals)
|
||||
|
|
|
|||
|
|
@ -144,7 +144,8 @@ such macros, the programmer much use the more general
|
|||
@scheme[define-syntax] form along with the @scheme[syntax-rules]
|
||||
transformer form:
|
||||
|
||||
@specform[(define-syntax id
|
||||
@specform[#:literals (syntax-rules)
|
||||
(define-syntax id
|
||||
(syntax-rules (literal-id ...)
|
||||
[pattern template]
|
||||
...))]
|
||||
|
|
@ -260,7 +261,8 @@ clock 3)] expands to @scheme[(put-clock! 3)].
|
|||
The @scheme[syntax-id-rules] form is like @scheme[syntax-rules], but
|
||||
it creates a transformer that acts as an identifier macro:
|
||||
|
||||
@specform[(define-syntax id
|
||||
@specform[#:literals (syntax-id-rules)
|
||||
(define-syntax id
|
||||
(syntax-id-rules (literal-id ...)
|
||||
[pattern template]
|
||||
...))]
|
||||
|
|
|
|||
|
|
@ -310,7 +310,7 @@ checking will not terminate.}
|
|||
|
||||
@defform[(flat-murec-contract ([id flat-contract-expr ...] ...) body ...+)]{
|
||||
|
||||
A generalization of @scheme[flat-rec-contracts] for defining several
|
||||
A generalization of @scheme[flat-rec-contract] for defining several
|
||||
mutually recursive flat contracts simultaneously. Each @scheme[id] is
|
||||
visible in the entire @scheme[flat-murec-contract] form, and the
|
||||
result of the final @scheme[body] is the result of the entire form.}
|
||||
|
|
@ -988,7 +988,7 @@ raised by the contract system.}
|
|||
|
||||
@defproc[(contract? [v any/c]) boolean?]{
|
||||
|
||||
Returns @scheme[#t] if its argument is a contract (ie, constructed
|
||||
Returns @scheme[#t] if its argument is a contract (i.e., constructed
|
||||
with one of the combinators described in this section or a value that
|
||||
can be used as a contract) and @scheme[#f] otherwise.}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user