suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Splicing syntax parameterize, here I come!

Browse Source 
svn: r12601
This commit is contained in:
Stevie Strickland 2008-11-26 22:42:32 +00:00
commit 581800ad8c
17 changed files with 507 additions and 428 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

145
collects/macro-debugger/view/cursor.ss
View File

@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/promise)
(provide cursor?
cursor-position
cursor:new
cursor:add-to-end!
cursor:remove-current!
@ -25,107 +26,109 @@
cursor:prefix->list
cursor:suffix->list)
(define-syntax stream-cons
(syntax-rules ()
[(stream-cons x y)
(delay (cons x y))]))
(define-struct cursor (vector count position)
#:mutable)
(define (stream-car x)
(if (promise? x)
(car (force x))
(car x)))
(define (stream-cdr x)
(if (promise? x)
(cdr (force x))
(cdr x)))
(define (stream-null? x)
(or (null? x)
(and (promise? x) (null? (force x)))))
(define (stream-append x y)
(if (stream-null? x)
y
(stream-cons (stream-car x)
(stream-append (stream-cdr x) y))))
(define (stream->list s)
(if (stream-null? s)
null
(cons (stream-car s) (stream->list (stream-cdr s)))))
;; Cursors
;; A (Cursor-of 'a) is (make-cursor (list-of 'a) (Stream-of 'a))
(define-struct cursor (prefix suffixp) #:mutable)
(define (cursor:ensure-capacity c capacity)
(define v (cursor-vector c))
(when (< (vector-length v) capacity)
(let* ([new-capacity (ceiling (* capacity 3/2))]
[new-v (make-vector new-capacity)])
(vector-copy! new-v 0 v 0)
(set-cursor-vector! c new-v))))
(define (cursor:new items)
(make-cursor null items))
(define v (list->vector items))
(make-cursor v (vector-length v) 0))
(define (cursor:add-to-end! c items)
(let ([suffix (cursor-suffixp c)])
(set-cursor-suffixp! c (stream-append suffix items))))
(define count0 (cursor-count c))
(define items-vector (list->vector items))
(cursor:ensure-capacity c (+ (cursor-count c) (length items)))
(vector-copy! (cursor-vector c) count0 items-vector)
(set-cursor-count! c (+ (cursor-count c) (vector-length items-vector))))
(define (cursor:remove-current! c)
(when (cursor:has-next? c)
(set-cursor-suffixp! c (stream-cdr (cursor-suffixp c)))))
(cursor:remove-at! c (cursor-position c)))
(define (cursor:remove-at! c p)
(define count (cursor-count c))
(define v (cursor-vector c))
(vector-copy! v p v (add1 p))
(vector-set! v (sub1 count) #f)
(set-cursor-count! c (sub1 count)))
(define (cursor:next c)
(let ([suffix (cursor-suffixp c)])
(if (stream-null? suffix)
#f
(stream-car suffix))))
(define p (cursor-position c))
(define count (cursor-count c))
(and (< p count)
(vector-ref (cursor-vector c) p)))
(define (cursor:prev c)
(let ([prefix (cursor-prefix c)])
(if (pair? prefix)
(car prefix)
#f)))
(define p (cursor-position c))
(define count (cursor-count c))
(and (< 0 p)
(vector-ref (cursor-vector c) (sub1 p))))
(define (cursor:move-prev c)
(when (pair? (cursor-prefix c))
(let ([old-prefix (cursor-prefix c)])
(set-cursor-prefix! c (cdr old-prefix))
(set-cursor-suffixp! c (cons (car old-prefix) (cursor-suffixp c))))))
(define (cursor:move-next c)
(when (cursor:has-next? c)
(let* ([old-suffixp (cursor-suffixp c)])
(set-cursor-prefix! c (cons (stream-car old-suffixp)
(cursor-prefix c)))
(set-cursor-suffixp! c (stream-cdr old-suffixp)))))
(define p (cursor-position c))
(define count (cursor-count c))
(when (< p count)
(set-cursor-position! c (add1 p))))
(define (cursor:move-prev c)
(define p (cursor-position c))
(define count (cursor-count c))
(when (< 0 p)
(set-cursor-position! c (sub1 p))))
(define (cursor:at-start? c)
(null? (cursor-prefix c)))
(= (cursor-position c) 0))
(define (cursor:at-end? c)
(stream-null? (cursor-suffixp c)))
(= (cursor-position c) (cursor-count c)))
(define (cursor:has-next? c)
(not (cursor:at-end? c)))
(define (cursor:has-prev? c)
(not (cursor:at-start? c)))
(define (cursor:move-to-start c)
(when (cursor:has-prev? c)
(cursor:move-prev c)
(cursor:move-to-start c)))
(set-cursor-position! c 0))
(define (cursor:move-to-end c)
(when (cursor:has-next? c)
(cursor:move-next c)
(cursor:move-to-end c)))
(set-cursor-position! c (cursor-count c)))
(define (cursor:skip-to c i)
(unless (or (eq? (cursor:next c) i) (cursor:at-end? c))
(cursor:move-next c)
(cursor:skip-to c i)))
(when (<= 0 i (cursor-count c))
(set-cursor-position! c i)))
(define (cursor->list c)
(append (cursor:prefix->list c)
(cursor:suffix->list c)))
(define count (cursor-count c))
(define v (cursor-vector c))
(let loop ([i 0])
(if (< i count)
(cons (vector-ref v i)
(loop (add1 i)))
null)))
(define (cursor:prefix->list c)
(reverse (cursor-prefix c)))
(define position (cursor-position c))
(define v (cursor-vector c))
(let loop ([i 0])
(if (< i position)
(cons (vector-ref v i)
(loop (add1 i)))
null)))
(define (cursor:suffix->list c)
(stream->list (cursor-suffixp c)))
(define position (cursor-position c))
(define count (cursor-count c))
(define v (cursor-vector c))
(let loop ([i position])
(if (< i count)
(cons (vector-ref v i)
(loop (add1 i)))
null)))

40
collects/macro-debugger/view/stepper.ss
View File

@ -49,6 +49,9 @@
(define (focused-term)
(cursor:next terms))
;; current-step-index : notify of number/#f
(field/notify current-step-index (new notify-box% (value #f)))
;; add-deriv : Deriv -> void
(define/public (add-deriv d)
(let ([trec (new term-record% (stepper this) (raw-deriv d))])
@ -173,6 +176,28 @@
(new button% (label "Next term") (parent navigator)
(callback (lambda (b e) (navigate-down)))))
(define nav:text
(new text-field%
(label "Step#")
(init-value "00000")
(parent extra-navigator)
(stretchable-width #f)
(stretchable-height #f)
(callback
(lambda (b e)
(when (eq? (send e get-event-type) 'text-field-enter)
(let* ([value (send b get-value)]
[step (string->number value)])
(cond [(exact-positive-integer? step)
(navigate-to (sub1 step))]
[(equal? value "end")
(navigate-to-end)])))))))
(send nav:text set-value "")
(listen-current-step-index
(lambda (n)
(send nav:text set-value
(if (number? n) (number->string (add1 n)) ""))))
(define/private (trim-navigator)
(if (> (length (cursor->list terms)) 1)
(send navigator change-children
@ -223,6 +248,9 @@
(define/public-final (navigate-next)
(send (focused-term) navigate-next)
(update/save-position))
(define/public-final (navigate-to n)
(send (focused-term) navigate-to n)
(update/save-position))
(define/public-final (navigate-up)
(when (focused-term)
@ -253,7 +281,7 @@
#f
(send text line-start-position (unbox end-box))
'start))
;; update/preserve-view : -> void
(define/public (update/preserve-view)
(define text (send sbview get-text))
@ -271,7 +299,7 @@
(define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence)
(send sbview erase-all)
(update:show-prefix)
(when multiple-terms? (send sbview add-separator))
(set! position-of-interest (send text last-position))
@ -284,6 +312,7 @@
#f
(send text last-position)
'start)
(update-nav-index)
(enable/disable-buttons))
;; update:show-prefix : -> void
@ -305,6 +334,12 @@
(send trec display-initial-term))
(cdr suffix0)))))
;; update-nav-index : -> void
(define/private (update-nav-index)
(define term (focused-term))
(set-current-step-index
(and term (send term get-step-index))))
;; enable/disable-buttons : -> void
(define/private (enable/disable-buttons)
(define term (focused-term))
@ -312,6 +347,7 @@
(send nav:previous enable (and term (send term has-prev?)))
(send nav:next enable (and term (send term has-next?)))
(send nav:end enable (and term (send term has-next?)))
(send nav:text enable (and term #t))
(send nav:up enable (cursor:has-prev? terms))
(send nav:down enable (cursor:has-next? terms)))

6
collects/macro-debugger/view/term-record.ss
View File

@ -204,6 +204,9 @@
(define/public-final (has-next?)
(and (get-steps) (not (cursor:at-end? (get-steps)))))
(define/public-final (get-step-index)
(and (get-steps) (cursor-position (get-steps))))
(define/public-final (navigate-to-start)
(cursor:move-to-start (get-steps))
(save-position))
@ -216,6 +219,9 @@
(define/public-final (navigate-next)
(cursor:move-next (get-steps))
(save-position))
(define/public-final (navigate-to n)
(cursor:skip-to (get-steps) n)
(save-position))
;; save-position : -> void
(define/private (save-position)

7
collects/profj/tool.ss
View File

@ -794,6 +794,8 @@
(list (send execute-types get-test-classes) null)
(find-examples compilation-units))])
#;(printf "ProfJ compilation complete~n")
#;(printf "compilation units- ~a~n" (map syntax->datum
(apply append (map compilation-unit-code compilation-units))))
(set! compiled? #t)
(set! modules (order compilation-units))
(when rep (send rep set-user-types execute-types))
@ -830,7 +832,6 @@
(send ,test-engine-obj run)
#;(printf "Test methods run~n")
(send ,test-engine-obj setup-display ,rep ,eventspace)
(send ,test-engine-obj summarize-results (current-output-port))
(let ([test-objs (send ,test-engine-obj test-objects)])
(let inner-loop ((os test-objs))
(unless (null? os)
@ -842,7 +843,9 @@
(write-special (car out))
(loop (cdr out))))
(newline))
(inner-loop (cdr os)))))))
(inner-loop (cdr os)))))
(send ,test-engine-obj summarize-results (current-output-port))
))
#f))]
[(and (not require?) (null? modules) tests-run?)
(begin0

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "25nov2008")
#lang scheme/base (provide stamp) (define stamp "26nov2008")

49
collects/scheme/private/stxparam.ss Normal file
View File

@ -0,0 +1,49 @@
(module stxparam '#%kernel
(#%require "more-scheme.ss"
"letstx-scheme.ss"
"define.ss"
(for-syntax '#%kernel
"../stxparam-exptime.ss"
"stx.ss" "stxcase-scheme.ss"
"small-scheme.ss"
"stxloc.ss" "stxparamkey.ss"))
(#%provide (for-syntax do-syntax-parameterize))
(define-for-syntax (do-syntax-parameterize stx let-syntaxes-id)
(syntax-case stx ()
[(_ ([id val] ...) body0 body ...)
(let ([ids (syntax->list #'(id ...))])
(with-syntax ([(gen-id ...)
(map (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier"
stx
id))
(let* ([rt (syntax-local-value id (lambda () #f))]
[sp (if (set!-transformer? rt)
(set!-transformer-procedure rt)
rt)])
(unless (syntax-parameter? sp)
(raise-syntax-error
#f
"not bound as a syntax parameter"
stx
id))
(syntax-local-get-shadower
(syntax-local-introduce (syntax-parameter-target sp)))))
ids)])
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error
#f
"duplicate binding"
stx
dup)))
(with-syntax ([let-syntaxes let-syntaxes-id])
(syntax/loc stx
(let-syntaxes ([(gen-id) (convert-renamer val)] ...)
body0 body ...)))))])))

81
collects/scheme/splicing.ss
View File

@ -1,12 +1,16 @@
#lang scheme/base
(require (for-syntax scheme/base))
(require (for-syntax scheme/base
syntax/kerncase)
"stxparam.ss"
"private/stxparam.ss")
(provide splicing-let-syntax
splicing-let-syntaxes
splicing-letrec-syntax
splicing-letrec-syntaxes)
splicing-letrec-syntaxes
splicing-syntax-parameterize)
(define-for-syntax (do-let-syntax stx rec? multi?)
(define-for-syntax (do-let-syntax stx rec? multi? let-stx-id)
(syntax-case stx ()
[(_ ([ids expr] ...) body ...)
(let ([all-ids (map (lambda (ids-stx)
@ -38,13 +42,7 @@
stx
dup-id)))
(if (eq? 'expression (syntax-local-context))
(with-syntax ([let-stx (if rec?
(if multi?
#'letrec-syntaxes
#'letrec-syntax)
(if multi?
#'let-syntaxes
#'let-syntax))])
(with-syntax ([let-stx let-stx-id])
(syntax/loc stx
(let-stx ([ids expr] ...)
(#%expression body)
@ -78,13 +76,68 @@
body ...))))))]))
(define-syntax (splicing-let-syntax stx)
(do-let-syntax stx #f #f))
(do-let-syntax stx #f #f #'let-syntax))
(define-syntax (splicing-let-syntaxes stx)
(do-let-syntax stx #f #t))
(do-let-syntax stx #f #t #'let-syntaxes))
(define-syntax (splicing-letrec-syntax stx)
(do-let-syntax stx #t #f))
(do-let-syntax stx #t #f #'letrec-syntax))
(define-syntax (splicing-letrec-syntaxes stx)
(do-let-syntax stx #t #t))
(do-let-syntax stx #t #t #'letrec-syntaxes))
;; ----------------------------------------
(define-syntax (splicing-syntax-parameterize stx)
(if (eq? 'expression (syntax-local-context))
;; Splicing is no help in an expression context:
(do-syntax-parameterize stx #'let-syntaxes)
;; Let `syntax-parameterize' check syntax, then continue
(do-syntax-parameterize stx #'ssp-let-syntaxes)))
(define-syntax (ssp-let-syntaxes stx)
(syntax-case stx ()
[(_ ([(id) rhs] ...) body ...)
(with-syntax ([(splicing-temp ...) (generate-temporaries #'(id ...))])
#'(begin
;; Evaluate each RHS only once:
(define-syntax splicing-temp rhs) ...
;; Partially expand `body' to push down `let-syntax':
(expand-ssp-body (id ...) (splicing-temp ...) body)
...))]))
(define-syntax (expand-ssp-body stx)
(syntax-case stx ()
[(_ (sp-id ...) (temp-id ...) body)
(let ([body (local-expand #'(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))]
...)
(force-expand body))
(syntax-local-context)
null ;; `force-expand' actually determines stopping places
#f)])
;; Extract expanded body out of `body':
(syntax-case body (quote)
[(ls _ _ (quoute body))
(let ([body #'body])
(syntax-case body (begin define-values define-syntaxes define-for-syntaxes)
[(define-values (id ...) rhs)
(syntax/loc body
(define-values (id ...)
(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...)
rhs)))]
[(define-syntaxes . _) body]
[(define-for-syntaxes . _) body]
[expr (syntax/loc body
(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...)
expr))]))]))]))
(define-syntax (force-expand stx)
(syntax-case stx ()
[(_ stx)
;; Expand `stx' to reveal type of form, and then preserve it via
;; `quote':
#`(quote #,(local-expand #'stx
'module
(kernel-form-identifier-list)
#f))]))

35
collects/scheme/stxparam.ss
View File

@ -3,6 +3,7 @@
(#%require "private/more-scheme.ss"
"private/letstx-scheme.ss"
"private/define.ss"
"private/stxparam.ss"
(for-syntax '#%kernel
"stxparam-exptime.ss"
"private/stx.ss" "private/stxcase-scheme.ss"
@ -30,36 +31,4 @@
gen-id))))))]))
(define-syntax (syntax-parameterize stx)
(syntax-case stx ()
[(_ ([id val] ...) body0 body ...)
(let ([ids (syntax->list #'(id ...))])
(with-syntax ([(gen-id ...)
(map (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier"
stx
id))
(let* ([rt (syntax-local-value id (lambda () #f))]
[sp (if (set!-transformer? rt)
(set!-transformer-procedure rt)
rt)])
(unless (syntax-parameter? sp)
(raise-syntax-error
#f
"not bound as a syntax parameter"
stx
id))
(syntax-local-get-shadower
(syntax-local-introduce (syntax-parameter-target sp)))))
ids)])
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error
#f
"duplicate binding"
stx
dup)))
#'(let-syntaxes ([(gen-id) (convert-renamer val)] ...)
body0 body ...)))])))
(do-syntax-parameterize stx #'let-syntaxes)))

1
collects/scribblings/reference/macros.scrbl
View File

@ -16,6 +16,7 @@ called.
@include-section["stx-comp.scrbl"]
@include-section["stx-trans.scrbl"]
@include-section["stx-param.scrbl"]
@include-section["splicing.scrbl"]
@include-section["stx-props.scrbl"]
@include-section["stx-certs.scrbl"]
@include-section["stx-expand.scrbl"]

4
collects/scribblings/reference/package.scrbl
View File

@ -117,3 +117,7 @@ cookies
(define vii 8)
(define*-seven vii)
vii)]}
@; ----------------------------------------------------------------------
@close-eval[pack-eval]

58
collects/scribblings/reference/splicing.scrbl Normal file
View File

@ -0,0 +1,58 @@
#lang scribble/doc
@(require "mz.ss"
(for-label scheme/splicing
scheme/stxparam))
@(define splice-eval (make-base-eval))
@interaction-eval[#:eval splice-eval (require scheme/splicing
scheme/stxparam
(for-syntax scheme/base))]
@title[#:tag "splicing"]{Local Binding with Splicing Body}
@note-lib-only[scheme/splicing]
@deftogether[(
@defidform[splicing-let-syntax]
@defidform[splicing-letrec-syntax]
@defidform[splicing-let-syntaxes]
@defidform[splicing-letrec-syntaxes]
)]{
Like @scheme[let-syntax], @scheme[letrec-syntax],
@scheme[let-syntaxes], and @scheme[letrec-syntaxes], except that in a
definition context, the body forms are spliced into the enclosing
definition context (in the same as as for @scheme[begin]).
@examples[
#:eval splice-eval
(splicing-let-syntax ([one (lambda (stx) #'1)])
(define o one))
o
one
]}
@defidform[splicing-syntax-parameterize]{
Like @scheme[syntax-parameterize], except that in a definition
context, the body forms are spliced into the enclosing definition
context (in the same as as for @scheme[begin]), as long as the body
forms are valid in an internal-definition context. In particular,
@scheme[require] and @scheme[provide] forms cannot appear in the body
of @scheme[splicing-syntax-parameterize], even if
@scheme[splicing-syntax-parameterize] is used in a @scheme[module]
body.
@examples[
#:eval splice-eval
(define-syntax-parameter place (lambda (stx) #'"Kansas"))
(define-syntax-rule (where) `(at ,(place)))
(where)
(splicing-syntax-parameterize ([place (lambda (stx) #'"Oz")])
(define here (where)))
here
]}
@; ----------------------------------------------------------------------
@close-eval[splice-eval]

5
collects/scribblings/reference/stx-param.scrbl
View File

@ -1,7 +1,8 @@
#lang scribble/doc
@(require "mz.ss"
(for-label scheme/stxparam
scheme/stxparam-exptime))
scheme/stxparam-exptime
scheme/splicing))
@title[#:tag "stxparam"]{Syntax Parameters}
@ -27,6 +28,8 @@ the target's value.}
@defform[(syntax-parameterize ((id expr) ...) body-expr ...+)]{
@margin-note/ref{See also @scheme[splicing-syntax-parameterize].}
Each @scheme[id] must be bound to a @tech{syntax parameter} using
@scheme[define-syntax-parameter]. Each @scheme[expr] is an expression
in the @tech{transformer environment}. During the expansion of the

11
collects/scribblings/reference/syntax.scrbl
View File

@ -10,7 +10,8 @@
scheme/provide-syntax
scheme/provide
scheme/nest
scheme/package))
scheme/package
scheme/splicing))
@(define cvt (schemefont "CVT"))
@ -1248,6 +1249,8 @@ and in the @scheme[body]s.
@defform[(let-syntax ([id trans-expr] ...) body ...+)]{
@margin-note/ref{See also @scheme[splicing-let-syntax].}
Creates a @tech{transformer binding} (see
@secref["transformer-model"]) of each @scheme[id] with the value of
@scheme[trans-expr], which is an expression at @tech{phase level} 1
@ -1265,17 +1268,23 @@ Each @scheme[id] is bound in the @scheme[body]s, and not in other
@defform[(letrec-syntax ([id trans-expr] ...) body ...+)]{
@margin-note/ref{See also @scheme[splicing-letrec-syntax].}
Like @scheme[let-syntax], except that each @scheme[id] is also bound
within all @scheme[trans-expr]s.}
@defform[(let-syntaxes ([(id ...) trans-expr] ...) body ...+)]{
@margin-note/ref{See also @scheme[splicing-let-syntaxes].}
Like @scheme[let-syntax], but each @scheme[trans-expr] must produce as
many values as corresponding @scheme[id]s, each of which is bound to
the corresponding value.}
@defform[(letrec-syntaxes ([(id ...) trans-expr] ...) body ...+)]{
@margin-note/ref{See also @scheme[splicing-letrec-syntaxes].}
Like @scheme[let-syntax], except that each @scheme[id] is also bound
within all @scheme[trans-expr]s.}

448
collects/tests/mzscheme/package.ss
View File

@ -1,309 +1,187 @@
(load-relative "loadtest.ss")
(require mzlib/package)
(require scheme/package)
(Section 'packages)
(define expand-test-use-toplevel? #t)
(define-syntax (test-pack-seq stx)
(syntax-case stx ()
[(_ result form ...)
(let loop ([forms #'(form ...)]
[pre null])
(syntax-case forms ()
[([#:fail expr exn?])
(with-syntax ([(form ...) (reverse pre)])
#`(test-pack-seq* (list (quote-syntax form) ...)
(quote-syntax [#:fail expr])
'expr
exn?))]
[(expr)
(with-syntax ([(form ...) (reverse pre)])
#`(test-pack-seq* (list (quote-syntax form) ...)
(quote-syntax expr)
'expr
result))]
[([#:fail expr exn?] . more)
#`(begin
#,(loop #'([#:fail expr exn?]) pre)
#,(loop #'more pre))]
[(form . more)
(loop #'more (cons #'form pre))]))]))
;; syntax
(syntax-test #'(dot))
(syntax-test #'(dot 1))
(syntax-test #'(dot 1 2))
(syntax-test #'(dot 1 x))
(define (fail? e)
(syntax-case e ()
[(#:fail e) #'e]
[_ #f]))
(syntax-test #'(open))
(syntax-test #'(open 1))
(syntax-test #'(open 1 2))
(syntax-test #'(open 1 x))
(define (fail-expr e)
(or (fail? e) e))
(syntax-test #'(define-dot))
(syntax-test #'(define-dot 1))
(syntax-test #'(define-dot x))
(syntax-test #'(define-dot 1 2))
(syntax-test #'(define-dot 1 x))
(syntax-test #'(define-dot x 1))
(syntax-test #'(define-dot x y))
(syntax-test #'(define-dot 1 x y))
(syntax-test #'(define-dot x y 3))
(syntax-test #'(define-dot x 2 y))
(define (test-pack-seq* forms expr q-expr result)
(let ([orig (current-namespace)])
(let ([ns (make-base-namespace)])
(parameterize ([current-namespace ns])
(namespace-attach-module orig 'scheme/package)
(namespace-require '(for-syntax scheme/base))
(namespace-require 'scheme/package)
(for-each eval forms)
(if (fail? expr)
(err/rt-test (eval (fail-expr expr)) result)
(test result q-expr (eval expr)))))
(let ([ns (make-base-namespace)])
(parameterize ([current-namespace ns])
(namespace-attach-module orig 'scheme/package)
(namespace-require '(for-syntax scheme/base))
(namespace-require 'scheme/package)
(let ([e `(let () (begin . ,forms) ,(fail-expr expr))])
(if (fail? expr)
(err/rt-test (eval e) result)
(test result `(let ... ,q-expr) (eval e))))))
(let ([ns (make-base-namespace)])
(parameterize ([current-namespace ns])
(namespace-attach-module orig 'scheme/package)
(let ([m `(module m scheme/base
(require (for-syntax scheme/base)
scheme/package)
(begin . ,forms)
(define result ,(fail-expr expr))
(provide result))])
(if (fail? expr)
(err/rt-test (eval m) exn:fail:syntax?)
(begin
(eval m)
(test result `(module ... ,q-expr) (dynamic-require ''m 'result)))))))))
(syntax-test #'(package))
(syntax-test #'(package x))
(syntax-test #'(package 1))
(syntax-test #'(package x 1))
(syntax-test #'(package x x))
(syntax-test #'(package x (1)))
;; ----------------------------------------
(test-pack-seq
12
(define-package p (x)
(define y 5)
(define x 12))
[#:fail x exn:fail:contract:variable?]
(open-package p)
x
[#:fail y exn:fail:contract:variable?])
(test-pack-seq
13
(define-package p (q)
(define-package q (x)
(define y 8)
(define x 13)))
[#:fail x exn:fail:contract:variable?]
[#:fail (open-package q) exn:fail:syntax?]
(open-package p)
[#:fail x exn:fail:contract:variable?]
(open-package q)
x
[#:fail y exn:fail:contract:variable?])
;; Providing
(package p1 all-defined
(define x 10)
(package y all-defined
(define x 12)))
(test-pack-seq
14
(define-package p (q)
(define-package q (r)
(define-package r (x)
(define x 14))))
[#:fail x exn:fail:contract:variable?]
[#:fail (open-package q) exn:fail:syntax?]
[#:fail (open-package r) exn:fail:syntax?]
(open-package p)
(open-package q)
(open-package r)
x)
(package p2 ()
(define x 10))
(test-pack-seq
15
(define-package p (x)
(define x 15))
[#:fail x exn:fail:contract:variable?]
(define-package q #:all-defined
(open-package p))
[#:fail x exn:fail:contract:variable?]
(open-package q)
x)
(package p3 (x)
(package x all-defined
(define x 10)))
(test-pack-seq
'(16 160)
(define-package p #:all-defined
(define x 16)
(define y 160))
(open-package p)
(list x y))
(package p4 all-defined
(package x (x)
(define x 10)
(define y 11)))
(test-pack-seq
170
(define-package p #:all-defined-except (x)
(define x 17)
(define y 170))
(open-package p)
[#:fail x exn:fail:contract:variable?]
y)
(define exn:variable? exn:fail:contract:variable?)
;; ----------------------------------------
(err/rt-test xxxx exn:variable?)
(test 10 "" (dot p1 x))
(test 12 "" (dot p1 y x))
(syntax-test #'(dot p2 x))
(test 10 "" (dot p3 x x))
(test 10 "" (dot p4 x x))
(syntax-test #'(dot p4 x y))
(syntax-test #'(package p (x)))
(syntax-test #'(package p (x) (package y (x) (define x 10))))
(test-pack-seq
2
(define-package p (x)
(define* x 1)
(define* x 2))
(open-package p)
x)
;; Internal-defines
(let ((p1 1)
(x 2))
(define x 1111)
(package p1 all-defined
(define x 10)
(package y all-defined
(define x 12)))
(package p2 ()
(define x 10))
(package p3 (x)
(package x all-defined
(define x 10)))
(package p4 all-defined
(package x (x)
(define x 10)
(define y 11)))
(test 10 "" (dot p1 x))
(test 12 "" (dot p1 y x))
(syntax-test #'(dot p2 x))
(test 10 "" (dot p3 x x))
(test 10 "" (dot p4 x x))
(syntax-test #'(dot p4 x y)))
(syntax-test #'(let () (package p (x)) 1))
(syntax-test #'(let () (package p (x) (package y (x) (define x 10))) 1))
(syntax-test #'(let ((all-defined 1)) (package p all-defined (define s 1)) 1))
(test-pack-seq
'(2 1)
(define-package p (x y)
(define* x 1)
(define y x)
(define* x 2))
(open-package p)
(list x y))
;; starred defines
(package p5 all-defined
(define*-values (x) 10)
(define*-values (f) (lambda () x))
(define*-values (x) 12))
(test 12 "" (dot p5 x))
(test 10 "" ((dot p5 f)))
(test-pack-seq
'(2 1)
(define-package p (x y)
(define* x 1)
(define y x)
(define* x 2))
(open-package p)
(list x y))
;; mutual references
(package p99 all-defined
(define (f) x)
(define x 77))
(test 77 "" (dot p99 x))
(test 77 "" ((dot p99 f)))
(let ()
(package p99. all-defined
(define (f) x)
(define x 177))
(test 177 "" (dot p99. x))
(test 177 "" ((dot p99. f))))
;;
(package p98 all-defined
(define (f) x)
(define* y 11)
(define x 78))
(test 78 "" (dot p98 x))
(test 11 "" (dot p98 y))
(test 78 "" ((dot p98 f)))
(let ()
(package p98. all-defined
(define (f) x)
(define* y 111)
(define x 178))
(test 178 "" (dot p98. x))
(test 111 "" (dot p98. y))
(test 178 "" ((dot p98. f))))
;; ----------------------------------------
;; nesting
(package p6 all-defined
(package xx all-defined
(define x 10))
(package z all-defined
(package a all-defined
(define z 111)))
(define y (dot xx x))
(define x 11))
(test-pack-seq
'(17 12)
(define-syntax-rule (mk id)
(begin
(define-package p (x)
(define x 17))
(open-package p)
(define id x)))
(define x 12)
(mk z)
(list z x))
(test 11 "" (dot p6 x))
(test 10 "" (dot p6 y))
(syntax-test #'(dot p6 x x))
(test 111 "" (dot p6 z a z))
;; open
(let ()
(package p7 all-defined
(define a 1)
(define b 2)
(define c 3))
(let ()
(package p8 all-defined
(open* p7)
(define* c 4))
(test 1 "" (dot p8 a))
(test 1 "" (dot p7 a))
(test 2 "" (dot p8 b))
(test 2 "" (dot p7 b))
(test 4 "" (dot p8 c))
(test 3 "" (dot p7 c))))
(let ()
;; Same test as above, but without nested lets:
(package p7. all-defined
(define a 10)
(define b 20)
(define c 30))
(package p8. all-defined
(open* p7.)
(define* c 40))
(test 10 "" (dot p8. a))
(test 10 "" (dot p7. a))
(test 20 "" (dot p8. b))
(test 20 "" (dot p7. b))
(test 40 "" (dot p8. c))
(test 30 "" (dot p7. c)))
(let ()
(package p9 all-defined
(package x all-defined
(define x 1)))
(let ()
(open p9)
(test 1 "" (dot x x))))
(let ()
(package p9 all-defined
(package x all-defined
(define x 1)))
(let ()
(open p9 x)
(test 1 "" x)))
(syntax-test #'(open x))
(syntax-test #'(let () (package y all-defined (package z ())) (let () (open y a))))
(syntax-test #'(let () (package y all-defined (package z ())) (let () (open y z a))))
;; open* after use => no capture
(let ([x 99])
(package yyy ()
(package p (x) (define x 8))
(define (f) x)
(open* p)
(test 99 f))
'ok)
;; open after use => capture
(package yyy ()
(package p (x)
(define x 88))
(define (f) x)
(open p)
(test 88 f))
;; Mutually referential packages:
(let ()
(package o (odd)
(define (odd x) (if (zero? x) #f (even (sub1 x)))))
(package e (even)
(define (even x) (if (zero? x) #t (odd (sub1 x)))))
(open o)
(open e)
(test #t odd 17)
(test #f even 19))
(err/rt-test
;; Like above, but omit an open:
(let ()
(package o (odd)
(define (odd x) (if (zero? x) #f (even (sub1 x)))))
(package e (even)
(define (even x) (if (zero? x) #t (odd (sub1 x)))))
(open o)
(odd 17))
exn:variable?)
(err/rt-test
;; Omit the other open:
(let ()
(package o (odd)
(define (odd x) (if (zero? x) #f (even (sub1 x)))))
(package e (even)
(define (even x) (if (zero? x) #t (odd (sub1 x)))))
(open e)
(even 17))
exn:variable?)
;; Same as working, but in a package:
(package yyy ()
(package o (odd)
(define (odd x) (if (zero? x) #f (even (sub1 x)))))
(package e (even)
(define (even x) (if (zero? x) #t (odd (sub1 x)))))
(open o)
(open e)
(test #t odd 17)
(test #f even 19))
(err/rt-test
;; open* shouldn't work:
(let ()
(package yyy ()
(package o (odd)
(define (odd x) (if (zero? x) #f (even (sub1 x)))))
(package e (even)
(define (even x) (if (zero? x) #t (odd (sub1 x)))))
(open* o)
(open e)
(odd 17))
'ok)
exn:variable?)
;; define-dot
(let ()
(package x all-defined
(define z 10))
(define-dot a x z)
(test 10 "" a))
(let ()
(package x all-defined
(package y all-defined
(define z 10)))
(define-dot a x y)
(define-dot b a z)
(test 10 "" b))
(syntax-test #'(let () (package x ()) (define-dot a x c) 1))
;; dot
(let ()
(package x all-defined
(define z 10))
(test 10 "" (dot x z)))
(let ()
(package x all-defined
(package y all-defined
(define z 10)))
(define-dot a x y)
(test 10 "" (dot a z)))
(syntax-test #'(let () (package x ()) (dot x c)))
(define expand-test-use-toplevel? #f)
;; ----------------------------------------
(report-errs)

28
src/mzscheme/gc2/page_range.c
View File

@ -89,8 +89,8 @@ static int add_page_range(Page_Range *pr, void *_start, unsigned long len, unsig
if (range_root) {
if (try_extend(range_root, start, len)
|| try_extend(range_root->prev, start, len)
|| try_extend(range_root->next, start, len)) {
|| try_extend(range_root->prev, start, len)
|| try_extend(range_root->next, start, len)) {
pr->range_root = range_root;
return 1;
}
@ -104,19 +104,19 @@ static int add_page_range(Page_Range *pr, void *_start, unsigned long len, unsig
r->len = len;
if (range_root) {
if (start < range_root->start) {
r->next = range_root;
r->prev = range_root->prev;
if (r->prev)
r->prev->next = r;
else
pr->range_start = r;
range_root->prev = r;
r->next = range_root;
r->prev = range_root->prev;
if (r->prev)
r->prev->next = r;
else
pr->range_start = r;
range_root->prev = r;
} else {
r->prev = range_root;
r->next = range_root->next;
if (r->next)
r->next->prev = r;
range_root->next = r;
r->prev = range_root;
r->next = range_root->next;
if (r->next)
r->next->prev = r;
range_root->next = r;
}
range_root = range_splay_insert(start, r, range_root);
} else {

4
src/wxmac/src/mac/wx_win.cc
View File

@ -2148,6 +2148,10 @@ Bool wxWindow::PopupMenu(wxMenu *menu, double x, double y)
theWxMenuItem = (wxMenuItem*) node->Data();
if (!theWxMenuItem) wxFatalError("No wxMenuItem for wxNode.");
if (theWxMenuItem->IsCheckable()) {
theWxMenuItem->Check(!theWxMenuItem->IsChecked());
}
itemId = theWxMenuItem->itemId;
}
}

11
src/wxxt/src/Windows/Window.cc
View File

@ -1622,7 +1622,7 @@ void wxWindow::ScrollEventHandler(Widget WXUNUSED(w),
{
XfwfScrollInfo *sinfo = (XfwfScrollInfo*)p_XfwfScrollInfo;
wxScrollEvent *wxevent;
int dir = 0;
int dir = 0, not_understood = 0;
wxWindow *win = (wxWindow *)GET_SAFEREF(winp);
if (!win) {
@ -1661,8 +1661,10 @@ void wxWindow::ScrollEventHandler(Widget WXUNUSED(w),
win->SetScrollPos(dir = wxHORIZONTAL, win->hs_pos + win->hs_page);
break;
case XfwfSTop:
case XfwfSLeftSide:
case XfwfSBottom:
dir = wxVERTICAL;
break;
case XfwfSLeftSide:
case XfwfSRightSide:
dir = wxHORIZONTAL;
break;
@ -1678,7 +1680,7 @@ void wxWindow::ScrollEventHandler(Widget WXUNUSED(w),
}
break;
default:
dir = wxHORIZONTAL;
not_understood = 1;
break;
}
{
@ -1719,7 +1721,8 @@ void wxWindow::ScrollEventHandler(Widget WXUNUSED(w),
break;
}
win->OnScroll(wxevent);
if (!not_understood)
win->OnScroll(wxevent);
wxevent->eventHandle = NULL;
}