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

I... think this is merged correctly. It asked me about a difference between

Browse Source 
deleting a svn:mergeinfo entry and adding to the existing one, and... hell,
I dunno.

svn: r12094
This commit is contained in:
Stevie Strickland 2008-10-22 17:46:47 +00:00
commit 69bcae8d7b
40 changed files with 730 additions and 307 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/compiler/decompile.ss
View File

@ -75,7 +75,9 @@
(if (null? stx-ids) null '(#%stx-array))
lift-ids)
(map (lambda (stx id)
`(define ,id (#%decode-syntax ,(stx-encoded stx))))
`(define ,id ,(if stx
`(#%decode-syntax ,(stx-encoded stx))
#f)))
stxs stx-ids)))]
[else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
@ -304,7 +306,8 @@
+ - * / min max bitwise-and bitwise-ior
arithmetic-shift vector-ref string-ref bytes-ref
set-mcar! set-mcdr! cons mcons))]
[(4) (memq (car a) '(vector-set! string-set! bytes-set!))]))
[(4) (memq (car a) '(vector-set! string-set! bytes-set!))]
[else #f]))
(cons '#%in a)
a))

121
collects/compiler/zo-parse.ss
View 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 decoded rns))
(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns mpis))
(define (cp-getc cp)
(begin-with-definitions
@ -430,6 +430,11 @@
;; Synatx unmarshaling
(define-form-struct wrapped (datum wraps certs))
(define-form-struct lexical-rename (alist))
(define-form-struct phase-shift (amt src dest))
(define-form-struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?))
(define-form-struct all-from-module (path phase src-phase exceptions prefix))
(define-form-struct module-binding (path mod-phase import-phase id nominal-path nominal-phase nominal-id))
(define (decode-stx cp v)
(if (integer? v)
@ -515,15 +520,107 @@
;; a mark
(string->symbol (format "mark~a" (car a)))]
[(vector? a)
`(#%decode-lexical-rename ,a)]
(make-lexical-rename
(let ([top (+ (/ (- (vector-length a) 2) 2) 2)])
(let loop ([i 2])
(if (= i top)
null
(cons (cons (vector-ref a i)
(vector-ref a (+ (- top 2) i)))
(loop (+ i 1)))))))]
[(pair? a)
`(#%decode-module-rename ,a)]
(let-values ([(plus-kern? a) (if (eq? (car a) #t)
(values #t (cdr a))
(values #f a))])
(match a
[`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames)
(let-values ([(unmarshals renames mark-renames)
(if (vector? maybe-unmarshals)
(values null maybe-unmarshals renames)
(values maybe-unmarshals
(car renames)
(cdr renames)))])
(make-module-rename phase
(if kind 'marked 'normal)
set-id
(map (lambda (u)
(let ([just-phase? (number? (cddr u))])
(let-values ([(exns prefix)
(if just-phase?
(values null #f)
(let loop ([u (if just-phase? null (cdddr u))]
[a null])
(if (pair? u)
(loop (cdr u) (cons (car u) a))
(values (reverse a) u))))])
(make-all-from-module
(parse-module-path-index cp (car u))
(cadr u)
(if just-phase?
(cddr u)
(caddr u))
exns
prefix))))
unmarshals)
(let loop ([i 0])
(if (= i (vector-length renames))
null
(cons
(let ([key (vector-ref renames i)]
[make-mapping
(lambda (path mod-phase import-phase id nominal-path nominal-phase nominal-id)
(make-module-binding
(parse-module-path-index cp path)
mod-phase
import-phase
id
(parse-module-path-index cp nominal-path)
nominal-phase
(if (eq? id nominal-id) #t nominal-id)))])
(cons key
(let ([m (vector-ref renames (add1 i))]
[parse-nominal-modidx-plus-phase
(lambda (modidx mod-phase exportname nominal-modidx-plus-phase nom-exportname)
(match nominal-modidx-plus-phase
[`(,nominal-modidx ,import-phase-plus-nominal-phase)
(match import-phase-plus-nominal-phase
[`(,import-phase ,nom-phase)
(make-mapping modidx mod-phase import-phase exportname
nominal-modidx nom-phase nom-exportname)]
[import-phase
(make-mapping modidx mod-phase import-phase exportname
modidx mod-phase nom-exportname)])]
[nominal-modidx
(make-mapping modidx mod-phase '* exportname
nominal-modidx mod-phase nom-exportname)]))])
(match m
[`(,modidx ,mod-phase ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname)
(parse-nominal-modidx-plus-phase modidx mod-phase exportname
nominal-modidx-plus-phase nominal-exportname)]
[`(,modidx ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname)
(parse-nominal-modidx-plus-phase modidx '* exportname
nominal-modidx-plus-phase nominal-exportname)]
[`(,modidx ,nominal-modidx)
(make-mapping modidx '* '* key nominal-modidx '* key)]
[`(,modidx ,exportname)
(make-mapping modidx '* '* exportname modidx '* exportname)]
[modidx
(make-mapping modidx '* '* key modidx '* key)]))))
(loop (+ i 2)))))
mark-renames
(and plus-kern? 'plus-kern)))]
[else (error "bad module rename: ~e" a)]))]
[(boolean? a)
`(#%top-level-rename ,a)]
[(symbol? a)
'(#%mark-barrier)]
[(box? a)
`(#%phase-shift ,(unbox a))]
(match (unbox a)
[`#(,amt ,src ,dest #f)
(make-phase-shift amt
(parse-module-path-index cp src)
(parse-module-path-index cp dest))]
[else (error 'parse "bad phase shift: ~e" a)])]
[else (error 'decode-wraps "bad wrap element: ~e" a)])))
w)))
@ -544,6 +641,20 @@
(vector-set! (cport-symtab cp) pos v)
(vector-set! (cport-decoded cp) pos #t))
(define (parse-module-path-index cp s)
(cond
[(not s) #f]
[(module-path-index? s)
(hash-ref (cport-mpis cp) s
(lambda ()
(let-values ([(name base) (module-path-index-split s)])
(let ([v `(module-path-index-join
(quote ,name)
,(parse-module-path-index cp base))])
(hash-set! (cport-mpis cp) s v)
v))))]
[else `(quote ,s)]))
;; ----------------------------------------
;; Main parsing loop
@ -784,7 +895,7 @@
(define symtab (make-vector symtabsize (make-not-ready)))
(define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash)))
(define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (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)))

4
collects/drscheme/private/language.ss
View File

@ -1086,7 +1086,9 @@
(λ ()
(with-handlers ([(λ (x) #t)
(λ (x)
(display (exn-message x))
(display (if (exn? x)
(exn-message x)
(format "~s" x)))
(newline))])
(when module-spec
(if use-copy?

25
collects/drscheme/private/rep.ss
View File

@ -323,6 +323,26 @@ TODO
(define setup-scheme-interaction-mode-keymap
(λ (keymap)
(define (beginning-of-line text select?)
(let* ([para (send text position-line (send text get-start-position))]
[para-start (send text line-start-position para)]
[prompt (send text get-prompt)]
[para-start-text (send text get-text para-start (+ para-start (string-length prompt)))]
[new-start
(cond
[(equal? prompt para-start-text)
(+ para-start (string-length prompt))]
[else
para-start])])
(if select?
(send text set-position new-start (send text get-end-position))
(send text set-position new-start new-start))))
(send keymap add-function "beginning-of-line/prompt"
(λ (text event) (beginning-of-line text #f)))
(send keymap add-function "select-to-beginning-of-line/prompt"
(λ (text event) (beginning-of-line text #t)))
(send keymap add-function "put-previous-sexp"
(λ (text event)
(send text copy-prev-previous-expr)))
@ -330,6 +350,11 @@ TODO
(λ (text event)
(send text copy-next-previous-expr)))
(send keymap map-function "c:a" "beginning-of-line/prompt")
(send keymap map-function "s:c:a" "select-to-beginning-of-line/prompt")
(send keymap map-function "home" "beginning-of-line/prompt")
(send keymap map-function "s:home" "select-to-beginning-of-line/prompt")
(keymap:send-map-function-meta keymap "p" "put-previous-sexp")
(keymap:send-map-function-meta keymap "n" "put-next-sexp")
(send keymap map-function "c:up" "put-previous-sexp")

34
collects/lang/htdp-langs.ss
View File

@ -167,8 +167,7 @@
(namespace-require scheme-test-module-name)
(scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%))
(test-execute (get-preference 'tests:enable? (lambda () #t)))
(test-format (make-formatter (lambda (v o) (render-value/format v settings o 40))))
)))
(test-format (make-formatter (lambda (v o) (render-value/format v settings o 40)))))))
(super on-execute settings run-in-user-thread))
(define/private (teaching-languages-error-value->string settings v len)
@ -1034,22 +1033,19 @@
(thread-cell-set! current-test-coverage-info ht)
(let ([rep (drscheme:rep:current-rep)])
(when rep
(let ([s (make-semaphore 0)])
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(λ ()
(let ([on-sd (make-object style-delta%)]
[off-sd (make-object style-delta%)])
(cond
[(preferences:get 'framework:white-on-black?)
(send on-sd set-delta-foreground "white")
(send off-sd set-delta-foreground "indianred")]
[else
(send on-sd set-delta-foreground "black")
(send off-sd set-delta-foreground "firebrick")])
(send rep set-test-coverage-info ht on-sd off-sd #f))
(semaphore-post s))))
(semaphore-wait s))))))
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(λ ()
(let ([on-sd (make-object style-delta%)]
[off-sd (make-object style-delta%)])
(cond
[(preferences:get 'framework:white-on-black?)
(send on-sd set-delta-foreground "white")
(send off-sd set-delta-foreground "indianred")]
[else
(send on-sd set-delta-foreground "black")
(send off-sd set-delta-foreground "firebrick")])
(send rep set-test-coverage-info ht on-sd off-sd #f)))))))))
(let ([ht (thread-cell-ref current-test-coverage-info)])
(when ht
(hash-set! ht key (mcons #f expr)))))
@ -1124,7 +1120,7 @@
(lambda (exp)
(let* ([is-compiled? (compiled-expression? (if (syntax? exp) (syntax-e exp) exp))]
[annotated
(if is-compiled?
(if is-compiled?
exp
(let* ([et-annotated (et:annotate-top (expand exp)
(namespace-base-phase))]

20
collects/lang/private/beginner-funs.ss
View File

@ -304,32 +304,32 @@
("Characters"
(char? (any -> boolean)
"to determine whether a value is a character")
(char=? (char char ... -> boolean)
(char=? (char char char ... -> boolean)
"to determine whether two characters are equal")
(char<? (char char ... -> boolean)
(char<? (char char char ... -> boolean)
"to determine whether a character precedes another")
(char>? (char char ... -> boolean)
(char>? (char char char ... -> boolean)
"to determine whether a character succeeds another")
(char<=? (char char ... -> boolean)
(char<=? (char char char ... -> boolean)
"to determine whether a character precedes another"
" (or is equal to it)")
(char>=? (char char ... -> boolean)
(char>=? (char char char ... -> boolean)
"to determine whether a character succeeds another"
" (or is equal to it)")
(char-ci=? (char char ... -> boolean)
(char-ci=? (char char char ... -> boolean)
"to determine whether two characters are equal"
" in a case-insensitive manner")
(char-ci<? (char char ... -> boolean)
(char-ci<? (char char char ... -> boolean)
"to determine whether a character precedes another"
" in a case-insensitive manner")
(char-ci>? (char char ... -> boolean)
(char-ci>? (char char char ... -> boolean)
"to determine whether a character succeeds another"
" in a case-insensitive manner")
(char-ci<=? (char char ... -> boolean)
(char-ci<=? (char char char ... -> boolean)
"to determine whether a character precedes another"
" (or is equal to it) in a case-insensitive manner")
(char-ci>=? (char char ... -> boolean)
(char-ci>=? (char char char ... -> boolean)
"to determine whether a character succeeds another"
" (or is equal to it) in a case-insensitive manner")

2
collects/lang/private/contracts/contracts-module-begin.ss
View File

@ -144,7 +144,7 @@
[_ (raise-syntax-error 'contract "internal error.5")])))
(define local-expand-stop-list
(list 'contract 'define-values 'define-syntaxes '#%require
(list 'contract 'define-values 'define-syntaxes 'define-values-for-syntax '#%require
'#%provide 'define-data '#%app '#%datum 'define-struct 'begin 'begin0))
;; parse-contract-expressions

27
collects/mzlib/pretty.ss
View File

@ -1088,11 +1088,13 @@
(define max-call-head-width 5)
(define (no-sharing? expr count acdr)
(if (and found (hash-table-get found (acdr expr) #f))
(define (no-sharing? expr count apair? acdr)
(if (and found
(apair? expr)
(hash-table-get found (acdr expr) #f))
#f
(or (zero? count)
(no-sharing? (acdr expr) (sub1 count) acdr))))
(no-sharing? (acdr expr) (sub1 count) apair? acdr))))
(define (style head expr apair? acar acdr)
(case (look-in-style-table head)
@ -1100,22 +1102,22 @@
syntax-rules
shared
unless when)
(and (no-sharing? expr 1 acdr)
(and (no-sharing? expr 1 apair? acdr)
pp-lambda))
((if set! set!-values)
(and (no-sharing? expr 1 acdr)
(and (no-sharing? expr 1 apair? acdr)
pp-if))
((cond case-lambda)
(and (no-sharing? expr 0 acdr)
(and (no-sharing? expr 0 apair? acdr)
pp-cond))
((case class)
(and (no-sharing? expr 1 acdr)
(and (no-sharing? expr 1 apair? acdr)
pp-case))
((and or import export
require require-for-syntax require-for-template
provide link
public private override rename inherit field init)
(and (no-sharing? expr 0 acdr)
(and (no-sharing? expr 0 apair? acdr)
pp-and))
((let letrec let*
let-values letrec-values let*-values
@ -1126,20 +1128,21 @@
(symbol? (acar (acdr expr))))
2
1)
apair?
acdr)
pp-let))
((begin begin0)
(and (no-sharing? expr 0 acdr)
(and (no-sharing? expr 0 apair? acdr)
pp-begin))
((do letrec-syntaxes+values)
(and (no-sharing? expr 2 acdr)
(and (no-sharing? expr 2 apair? acdr)
pp-do))
((send syntax-case instantiate module)
(and (no-sharing? expr 2 acdr)
(and (no-sharing? expr 2 apair? acdr)
pp-syntax-case))
((make-object)
(and (no-sharing? expr 1 acdr)
(and (no-sharing? expr 1 apair? acdr)
pp-make-object))
(else #f)))

16
collects/redex/examples/omega.ss
View File

@ -20,15 +20,15 @@
(define reductions
(reduction-relation
lang
(--> (in-hole c_1 (call/cc v_arg))
,(term-let ([v (variable-not-in (term c_1) 'x)])
(term (in-hole c_1 (v_arg (lambda (v) (abort (in-hole c_1 v)))))))
call/cc)
(--> (in-hole c (abort e_1))
e_1
(--> (in-hole c (call/cc v))
(in-hole c (v (lambda (x) (abort (in-hole c x)))))
call/cc
(fresh x))
(--> (in-hole c (abort e))
e
abort)
(--> (in-hole c_1 ((lambda (variable_x) e_body) v_arg))
(in-hole c_1 (subst (variable_x v_arg e_body)))
(--> (in-hole c ((lambda (x) e) v))
(in-hole c (subst (x v e)))
βv)))
(traces reductions '((lambda (x) (x x)) (lambda (x) (x x))))

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

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "17oct2008")
#lang scheme/base (provide stamp) (define stamp "21oct2008")

1
collects/scheme/private/contract.ss
View File

@ -1646,6 +1646,7 @@ improve method arity mismatch contract violation error messages?
(λ (x)
(and (number? x)
(integer? x)
(exact? x)
(x . >= . 0)))))
(define (integer-in start end)

116
collects/scribblings/guide/contracts-gotchas.scrbl
View File

@ -1,12 +1,95 @@
#lang scribble/doc
@(require scribble/manual
@(require scribble/manual
scribble/eval
scheme/sandbox
"guide-utils.ss"
"contracts-utils.ss"
(for-label scheme/contract))
@title[#:tag "contracts-gotchas"]{Gotchas}
@ctc-section{Contracts and @scheme[eq?]}
As a general rule, adding a contract to a program should
either leave the behavior of the program unchanged, or
should signal a contract violation. And this is almost true
for PLT Scheme contracts, with one exception: @scheme[eq?].
The @scheme[eq?] procedure is designed to be fast and does
not provide much in the way of guarantees, except that if it
returns true, it means that the two values behave
identically in all respects. Internally, this is implemented
as pointer equality at a low-level so it exposes information
about how PLT Scheme is implemented (and how contracts are
implemented).
Contracts interact poorly with @scheme[eq?] because function
contract checking is implemented internally as wrapper
functions. For example, consider this module:
@schememod[
scheme
(define (make-adder x)
(if (= 1 x)
add1
(lambda (y) (+ x 1))))
(provide/contract [make-adder (-> number? (-> number? number?))])
]
It exports the @scheme[make-adder] function that is the usual curried
addition function, except that it returns Scheme's @scheme[add1] when
its input is @scheme[1].
You might expect that
@schemeblock[
(eq? (make-adder 1)
(make-adder 1))
]
would return @scheme[#t], but it does not. If the contract were
changed to @scheme[any/c] (or even @scheme[(-> number? any/c)]), then
the @scheme[eq?] call would return @scheme[#t].
Moral: do not use @scheme[eq?] on values that have contracts.
@ctc-section{Defining recursive contracts}
When defining a self-referential contract, it is natural to use
@scheme[define]. For example, one might try to write a contract on
streams like this:
@(define e (make-base-eval))
@(interaction-eval #:eval e (require scheme/contract))
@interaction[
#:eval e
(define stream/c
(promise/c
(or/c
null?
(cons/c number? stream/c))))
]
Unfortunately, this does not work because the value of
@scheme[stream/c] is needed before it is defined. Put another way, all
of the combinators evaluate their arguments eagerly, even thought the
values that they accept do not.
Instead, use
@schemeblock[
(define stream/c
(promise/c
(or/c
null?
(cons/c 1
(recursive-contract stream/c)))))
]
The use of @scheme[recursive-contract] delays the evaluation of the
identifier @scheme[stream/c] until after the contract is first
checked, long enough to ensure that @scheme[stream/c] is defined.
See also @ctc-link["lazy-contracts"].
@ctc-section{Using @scheme[set!] to Assign to Variables Provided via @scheme[provide/contract]}
The contract library assumes that variables exported via
@ -50,34 +133,5 @@ scheme
[get-x (-> integer?)])
]
This is a bug we hope to address in a future release.
@;{
@question{Contracts and @scheme[eq?]}
Moral: This is a bug we hope to address in a future release.
As a general rule, adding a contract to a program should
either leave the behavior of the program unchanged, or
should signal a contract violation. And this is almost true
for PLT Scheme contracts, with one exception: @scheme[eq?].
The @scheme[eq?] procedure is designed to be fast and does
not provide much in the way of guarantees, except that if it
returns true, it means that the two values behave
identically in all respects. Internally, this is implemented
as pointer equality at a low-level so it exposes information
about how PLT Scheme is implemented (and how contracts are
implemented).
Contracts interact poorly with @scheme[eq?] because function
contract checking is implemented internally as wrapper
functions. For example, consider this module:
@schememod[
scheme
(define (make-adder ))
(provide make-adder)
(provide/contract [make-adder (-> number? (-> number? number?))])
]
}

37
collects/scribblings/guide/contracts-intro.scrbl
View File

@ -193,3 +193,40 @@ services, it also demands the client to deliver
something. This kind of thing happens when a module exports
a function, an object, a class or other values that enable
values to flow in both directions.
@ctc-section{Experimenting with examples}
All of the contracts and module in this chapter (excluding those just
following) are written using the standard @tt{#lang} syntax for
describing modules. Thus, if you extract examples from this chapter in
order to experiment with the behavior of the contract system, you
would have to make multiple files.
To rectify this, PLT Scheme provides a special language, called
@schememodname[scheme/load]. The contents of such a module is other modules (and
@scheme[require] statements), using the parenthesized syntax for a
module. For example, to try the example earlier in this section, you
would write:
@schememod[
scheme/load
(module m scheme
(define amount 150)
(provide/contract [amount (and/c number? positive?)]))
(module n scheme
(require 'm)
(+ amount 10))
(require 'n)]
Each of the modules and their contracts are wrapped in parentheses
with the @scheme[module] keyword at the front. The first argument to
@scheme[module] should be the name of the module, so it can be used in
a subsequent @scheme[require] statement (note that in the
@scheme[require], the name of the module must be prefixed with a
quote). The second argument to @scheme[module] is the language (what
would have come after @tt{#lang} in the usual notation), and the
remaining arguments are the body of the module. After all of the
modules, there must a @scheme[require] to kick things off.

10
collects/scribblings/reference/regexps.scrbl
View File

@ -206,8 +206,8 @@ case-sensitively.
[start-pos exact-nonnegative-integer? 0]
[end-pos (or/c exact-nonnegative-integer? #f) #f]
[output-port (or/c output-port? #f) #f])
(or/c (listof (or/c (or/c string? bytes?)
#f))
(or/c (listof (or/c string? #f))
(listof (or/c bytes? #f))
#f)]{
Attempts to match @scheme[pattern] (a string, byte string, regexp
@ -304,7 +304,7 @@ bytes. To avoid such interleaving, use @scheme[regexp-match-peek]
[input (or/c string? bytes? input-port?)]
[start-pos exact-nonnegative-integer? 0]
[end-pos (or/c exact-nonnegative-integer? #f) #f])
(listof (or/c string? bytes?))]{
(or/c (listof string?) (listof bytes?))]{
Like @scheme[regexp-match], but the result is a list of strings or
byte strings corresponding to a sequence of matches of
@ -336,8 +336,8 @@ port).
[start-pos exact-nonnegative-integer? 0]
[end-pos (or/c exact-nonnegative-integer? #f) #f]
[output-port (or/c output-port? #f) #f])
(or/c (listof (or/c (or/c string? bytes?)
#f))
(or/c (listof (or/c string? #f))
(listof (or/c bytes? #f))
#f)]{
Like @scheme[regexp-match] on input ports, except that if the match

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

@ -539,8 +539,8 @@ byte string into the pipe. It can also be used with @scheme[eof],
which closes the pipe.}
@defproc*[([(get-output [evaluator (any/c . -> . any)]) (or/c input-port? bytes? string?)]
[(get-error-output [evaluator (any/c . -> . any)]) (or/c input-port? bytes? string?)])]{
@defproc*[([(get-output [evaluator (any/c . -> . any)]) (or/c #f input-port? bytes? string?)]
[(get-error-output [evaluator (any/c . -> . any)]) (or/c #f input-port? bytes? string?)])]{
Returns the output or error-output of the @scheme[evaluator],
in a way that depends on the setting of @scheme[(sandbox-output)] or

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

@ -753,7 +753,7 @@ instead of
#rx"-" (string-titlecase name) "")))
scheme/base))]
will get the @scheme[scheme/base] bindings that match the regexp,
and renamed to use ``caml case''.}
and renamed to use ``camel case''.}
@; --------------------
@ -783,7 +783,7 @@ instead of
#rx"-" (string-titlecase name) "")))
(all-defined-out)))]
will provide all defined bindings that match the regexp, and renamed
to use ``caml case''.}
to use ``camel case''.}
@;------------------------------------------------------------------------
@section[#:tag "quote"]{Literals: @scheme[quote] and @scheme[#%datum]}

10
collects/stepper/internal-docs.txt
View File

@ -202,6 +202,16 @@ Where it's used: the stepper-skipto label is used by the 2nd-pass
macro-labeler and the annotator. Both are in annotate.ss. In addition
to skipping inward, a stepper hint
stepper-skipto/discard :
This is like stepper-skipto, except that it makes the stepper
replace the expression the property is attached to by the
subexpression indicated by its value.
(This is used in the contracts implementation for "Die Macht der
Abstraktion", where procedures are wrapped in a contract-checking
context that has no impact on the reduction semantics.)
stepper-else :
[ #t ] : Initially applied to the 'true' that the cond macro
replaces a beginner's 'else' with, it is later transferred

34
collects/stepper/private/annotate.ss
View File

@ -387,21 +387,25 @@
. -> . (vector/p syntax? binding-set?))
(lambda (exp tail-bound pre-break? procedure-name-info)
(cond [(stepper-syntax-property exp 'stepper-skipto)
(let* ([free-vars-captured #f] ; this will be set!'ed
;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (stepper-syntax-property expr 'stepper-skipto))]
; WARNING! I depend on the order of evaluation in application arguments here:
[annotated (skipto/auto
exp
'rebuild
(lambda (subterm)
(let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)])
(set! free-vars-captured free-vars)
stx)))])
(2vals (wcm-wrap
skipto-mark
annotated)
free-vars-captured))]
(cond [(cond
((stepper-syntax-property exp 'stepper-skipto) 'rebuild)
((stepper-syntax-property exp 'stepper-skipto/discard) 'discard)
(else #f))
=> (lambda (traversal)
(let* ([free-vars-captured #f] ; this will be set!'ed
;;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (stepper-syntax-property expr 'stepper-skipto))]
;; WARNING! I depend on the order of evaluation in application arguments here:
[annotated (skipto/auto
exp
traversal
(lambda (subterm)
(let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)])
(set! free-vars-captured free-vars)
stx)))])
(2vals (wcm-wrap
skipto-mark
annotated)
free-vars-captured)))]
[(stepper-syntax-property exp 'stepper-skip-completely)
(2vals (wcm-wrap 13 exp) null)]

3
collects/stepper/private/shared.ss
View File

@ -481,7 +481,8 @@
;; traversal argument is 'discard, the result of the transformation is the
;; result of this function
(define (skipto/auto stx traversal transformer)
(cond [(stepper-syntax-property stx 'stepper-skipto)
(cond [(or (stepper-syntax-property stx 'stepper-skipto)
(stepper-syntax-property stx 'stepper-skipto/discard))
=>
(cut update <> stx (cut skipto/auto <> traversal transformer) traversal)]
[else (transformer stx)]))

1
collects/tests/mzscheme/contract-test.ss
View File

@ -4778,6 +4778,7 @@ so that propagation occurs.
(test-flat-contract '(real-in 1 10) 3/2 20)
(test-flat-contract '(string-len/c 3) "ab" "abc")
(test-flat-contract 'natural-number/c 5 -1)
(test-flat-contract 'natural-number/c #e3 #i3.0)
(test-flat-contract 'false/c #f #t)
(test-flat-contract #t #t "x")

2
collects/tests/run-automated-tests.ss
View File

@ -32,7 +32,7 @@
;; ignored, and should only be used by the mzscheme tests.)
(define tests
'([no-handler load "mzscheme/quiet.ss" (lib "scheme/init")]
[require "typed-scheme/run.ss"]
;; [require "typed-scheme/run.ss"]
[require "match/plt-match-tests.ss"]
;; [require "stepper/automatic-tests.ss" (lib "scheme/base")]
[require "lazy/main.ss"]

9
collects/tests/typed-scheme/fail/unbound-type.ss Normal file
View File

@ -0,0 +1,9 @@
#;
(exn-pred 1)
#lang typed-scheme
(: f (Foo -> String))
(define (f x) (string-append x))
(f 1)

43
collects/typed-scheme/private/base-env.ss
View File

@ -4,6 +4,7 @@
scheme/list
(only-in rnrs/lists-6 fold-left)
'#%paramz
(only-in '#%kernel [apply kernel:apply])
scheme/promise
(only-in scheme/match/runtime match:error))
@ -236,11 +237,13 @@
[list-tail (-poly (a) ((-lst a) -Integer . -> . (-lst a)))]
[positive? (-> N B)]
[negative? (-> N B)]
[odd? (-> N B)]
[even? (-> N B)]
[odd? (-> -Integer B)]
[even? (-> -Integer B)]
[apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
[time-apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
[apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
[kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
[time-apply (-poly (a b) (((list) a . ->* . b) (-lst a)
. -> . (-values (list b N N N))))]
[call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
[call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
@ -264,20 +267,24 @@
;; regexp stuff
[regexp-match
(cl->
[((*Un -String -Regexp) -String) (-opt (-lst (-opt -String)))]
[(-Pattern -String) (-opt (-lst (-opt (*Un -Bytes -String))))]
[(-Pattern -String N) (-opt (-lst (-opt (*Un -Bytes -String))))]
[(-Pattern -String N (-opt N)) (-opt (-lst (-opt (*Un -Bytes -String))))]
[(-Pattern -String N (-opt N) (-opt -Output-Port)) (-lst (-opt (*Un -Bytes -String)))]
[(-Pattern -String (-opt N) (-opt -Output-Port)) (-lst (-opt (*Un -Bytes -String)))]
[(-Pattern -String (-opt -Output-Port)) (-lst (-opt (*Un -Bytes -String)))]
[(-Pattern (*Un -Input-Port -Bytes)) (-opt (-lst (-opt -Bytes)))]
[(-Pattern (*Un -Input-Port -Bytes) N) (-opt (-lst (-opt -Bytes)))]
[(-Pattern (*Un -Input-Port -Bytes) N (-opt N)) (-opt (-lst (-opt -Bytes)))]
[(-Pattern (*Un -Input-Port -Bytes) (-opt N)) (-opt (-lst (-opt -Bytes)))]
[(-Pattern (*Un -Input-Port -Bytes) N (-opt N) (-opt -Output-Port)) (-lst (-opt -Bytes))])]
(let ([?outp (-opt -Output-Port)]
[?N (-opt N)]
[optlist (lambda (t) (-opt (-lst (-opt t))))]
[-StrRx (*Un -String -Regexp -PRegexp)]
[-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (*Un -Input-Port -Bytes)])
(cl-> [(-StrRx -String ) (optlist -String)]
[(-StrRx -String N ) (optlist -String)]
[(-StrRx -String N ?N ) (optlist -String)]
[(-StrRx -String N ?N ?outp) (optlist -String)]
[(-BtsRx -String ) (optlist -Bytes)]
[(-BtsRx -String N ) (optlist -Bytes)]
[(-BtsRx -String N ?N ) (optlist -Bytes)]
[(-BtsRx -String N ?N ?outp) (optlist -Bytes)]
[(-Pattern -InpBts ) (optlist -Bytes)]
[(-Pattern -InpBts N ) (optlist -Bytes)]
[(-Pattern -InpBts N ?N ) (optlist -Bytes)]
[(-Pattern -InpBts N ?N ?outp) (optlist -Bytes)]))]
[number->string (N . -> . -String)]

7
collects/typed-scheme/private/parse-type.ss
View File

@ -213,10 +213,10 @@
(make-Name #'id)]
[(eq? '-> (syntax-e #'id))
(tc-error/delayed "Incorrect use of -> type constructor")
Univ]
Err]
[else
(tc-error/delayed "Unbound type name ~a" (syntax-e #'id))
Univ])]
Err])]
[(All . rest) (eq? (syntax-e #'All) 'All) (tc-error "All: bad syntax")]
[(Opaque . rest) (eq? (syntax-e #'Opaque) 'Opqaue) (tc-error "Opaque: bad syntax")]
@ -239,8 +239,9 @@
(tc-error "Wrong number of arguments to type ~a, expected ~a but got ~a" rator (length ns) (length args)))
(instantiate-poly rator args)]
[(Mu: _ _) (loop (unfold rator) args)]
[(Error:) Err]
[_ (tc-error/delayed "Type ~a cannot be applied, arguments were: ~a" rator args)
Univ]))
Err]))
#;
(let ([ty (parse-type #'id)])
#;(printf "ty is ~a" ty)

5
collects/typed-scheme/private/prims.ss
View File

@ -52,14 +52,13 @@ This file defines two sorts of primitives. All of them are provided into any mod
(define-syntax (require/typed stx)
(define-syntax (require/typed stx)
(syntax-case* stx (rename) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(_ lib [nm ty] ...)
#'(begin (require/typed nm ty lib) ...)]
[(_ nm ty lib)
(identifier? #'nm)
(with-syntax ([(cnt*) (syntax->datum #'(nm))])
(with-syntax ([(cnt*) (generate-temporaries #'(nm))])
(quasisyntax/loc stx (begin
#,(syntax-property (syntax-property #'(define cnt* #f)
'typechecker:contract-def #'ty)

3
collects/typed-scheme/private/subtype.ss
View File

@ -168,6 +168,9 @@
[(list t t) A0]
;; univ is top
[(list _ (Univ:)) A0]
;; error is top and bot
[(list _ (Error:)) A0]
[(list (Error:) _) A0]
;; (Un) is bot
[(list _ (Union: (list))) (fail! s t)]
[(list (Union: (list)) _) A0]

1
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -139,6 +139,7 @@
(define -Promise make-promise-ty)
(define Univ (make-Univ))
(define Err (make-Error))
(define-syntax -v
(syntax-rules ()

3
collects/typed-scheme/rep/type-rep.ss
View File

@ -15,6 +15,9 @@
;; t must be a Type
(dt Scope (t))
;; this is ONLY used when a type error ocurrs
(dt Error () [#:frees #f] [#:fold-rhs #:base])
;; i is an nat
(dt B (i)
[#:frees empty-hash-table (make-immutable-hasheq (list (cons i Covariant)))]

135
collects/typed-scheme/typecheck/provide-handling.ss
View File

@ -2,7 +2,7 @@
(require (except-in "../utils/utils.ss" extend))
(require (only-in srfi/1/list s:member)
syntax/kerncase
syntax/kerncase syntax/boundmap
mzlib/trace
(private type-contract)
(rep type-rep)
@ -23,68 +23,77 @@
(define (remove-provides forms)
(filter (lambda (e) (not (provide? e))) (syntax->list forms)))
(define ((generate-prov stx-defs val-defs) form)
(define (mem? i vd)
(cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]
[else #f]))
(define (lookup-id i vd)
(def-binding-ty (mem? i vd)))
(define (mk internal-id external-id)
(cond
[(mem? internal-id val-defs)
=>
(lambda (b)
(with-syntax ([id internal-id]
[out-id external-id])
(cond [(type->contract (def-binding-ty b) (lambda () #f))
=>
(lambda (cnt)
(with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))])
#`(begin
(define/contract cnt-id #,cnt id)
(define (generate-prov stx-defs val-defs)
(define mapping (make-free-identifier-mapping))
(lambda (form)
(define (mem? i vd)
(cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]
[else #f]))
(define (lookup-id i vd)
(def-binding-ty (mem? i vd)))
(define (mk internal-id external-id)
(cond
;; if it's already done, do nothing
[(free-identifier-mapping-get mapping internal-id
;; if it wasn't there, put it in, and skip this case
(lambda ()
(free-identifier-mapping-put! mapping internal-id #t)
#f))
#'(begin)]
[(mem? internal-id val-defs)
=>
(lambda (b)
(with-syntax ([id internal-id]
[out-id external-id])
(cond [(type->contract (def-binding-ty b) (lambda () #f))
=>
(lambda (cnt)
(with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))])
#`(begin
(define/contract cnt-id #,cnt id)
(define-syntax export-id
(if (unbox typed-context?)
(make-rename-transformer #'id)
(make-rename-transformer #'cnt-id)))
(#%provide (rename export-id out-id)))))]
[else
(with-syntax ([(export-id) (generate-temporaries #'(id))])
#`(begin
(define-syntax export-id
(if (unbox typed-context?)
(make-rename-transformer #'id)
(make-rename-transformer #'cnt-id)))
(#%provide (rename export-id out-id)))))]
[else
(with-syntax ([(export-id) (generate-temporaries #'(id))])
#`(begin
(define-syntax export-id
(if (unbox typed-context?)
(make-rename-transformer #'id)
(lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))))
(provide (rename-out [export-id out-id]))))])))]
[(mem? internal-id stx-defs)
=>
(lambda (b)
(with-syntax ([id internal-id]
[out-id external-id])
(with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))])
#`(begin
(define-syntax export-id
(if (unbox typed-context?)
(make-rename-transformer #'id)
(lambda (stx)
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id)))))
(provide (rename-out [export-id out-id]))))))]
[(eq? (syntax-e internal-id) (syntax-e external-id))
#`(provide #,internal-id)]
[else #`(provide (rename-out [#,internal-id #,external-id]))]))
(kernel-syntax-case form #f
[(#%provide form ...)
(map
(lambda (f)
(parameterize ([current-orig-stx f])
(syntax-case* f (struct rename all-defined protect all-defined-except all-from all-from-except)
(lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[id
(identifier? #'id)
(mk #'id #'id)]
[(rename in out)
(mk #'in #'out)]
[(protect . _)
(tc-error "provide: protect not supported by Typed Scheme")]
[_ (int-err "unknown provide form")])))
(syntax->list #'(form ...)))]
[_ (int-err "non-provide form! ~a" (syntax->datum form))]))
(lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))))
(provide (rename-out [export-id out-id]))))])))]
[(mem? internal-id stx-defs)
=>
(lambda (b)
(with-syntax ([id internal-id]
[out-id external-id])
(with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))])
#`(begin
(define-syntax export-id
(if (unbox typed-context?)
(make-rename-transformer #'id)
(lambda (stx)
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id)))))
(provide (rename-out [export-id out-id]))))))]
[(eq? (syntax-e internal-id) (syntax-e external-id))
#`(provide #,internal-id)]
[else #`(provide (rename-out [#,internal-id #,external-id]))]))
(kernel-syntax-case form #f
[(#%provide form ...)
(map
(lambda (f)
(parameterize ([current-orig-stx f])
(syntax-case* f (struct rename all-defined protect all-defined-except all-from all-from-except)
(lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[id
(identifier? #'id)
(mk #'id #'id)]
[(rename in out)
(mk #'in #'out)]
[(protect . _)
(tc-error "provide: protect not supported by Typed Scheme")]
[_ (int-err "unknown provide form")])))
(syntax->list #'(form ...)))]
[_ (int-err "non-provide form! ~a" (syntax->datum form))])))

2
collects/typed-scheme/typecheck/tc-app-unit.ss
View File

@ -484,6 +484,8 @@
(match-let ([(list (tc-result: ts) ...) (map (lambda (f) (outer-loop
(ret f e1 e2) argtypes arg-thn-effs arg-els-effs args)) fs)])
(ret (apply Un ts)))]
;; error type is a perfectly good fcn type
[(tc-result: (Error:)) (ret (make-Error))]
[(tc-result: f-ty _ _) (tc-error/expr #:return (ret (Un))
"Cannot apply expression of type ~a, since it is not a function type" f-ty)]))))

4
collects/typed-scheme/typecheck/tc-toplevel.ss
View File

@ -40,7 +40,9 @@
;; require/typed
[(define-values () (begin (quote-syntax (require/typed-internal nm ty)) (#%plain-app values)))
(register-type #'nm (parse-type #'ty))]
(let ([t (parse-type #'ty)])
(register-type #'nm t)
(list (make-def-binding #'nm t)))]
;; define-typed-struct
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values)))

4
collects/typed-scheme/typed-scheme.scrbl
View File

@ -460,8 +460,8 @@ The following base types are parameteric in their type arguments.
@defform[(values t ...)]{is the type of a sequence of multiple values, with
types @scheme[t ...]. This can only appear as the return type of a
function.}
@defform/none[v]{where @scheme[v] is a number, boolean or string, is the singleton type containing
only that value}
@defform/none[v]{where @scheme[v] is a number, boolean or string, is the singleton type containing only that value}
@defform/none['sym]{where @scheme[sym] is a symbol, is the singleton type containing only that symbol}
@defform/none[i]{where @scheme[i] is an identifier can be a reference to a type
name or a type variable}
@defform[(Rec n t)]{is a recursive type where @scheme[n] is bound to the

2
src/mred/wxme/wx_mline.cxx
View File

@ -747,6 +747,8 @@ long wxMediaLine::FindExtraScroll(double y)
{
if (y >= h)
return numscrolls;
if (y <= 0)
return 0;
if (!scrollSnip)
return 0;

13
src/mzscheme/src/env.c
View File

@ -1743,7 +1743,8 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid
return val;
}
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def, Scheme_Object *phase)
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def,
Scheme_Object *phase, int *_skipped)
/* The `env' argument can actually be a hash table. */
{
Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm, *abdg;
@ -1752,6 +1753,9 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
sym = SCHEME_STX_SYM(id);
if (_skipped)
*_skipped = 0;
if (SCHEME_HASHTP((Scheme_Object *)env))
marked_names = (Scheme_Hash_Table *)env;
else {
@ -1951,6 +1955,9 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
scheme_hash_set(rev_ht, best_match, scheme_true);
}
}
} else {
if (_skipped)
*_skipped = best_match_skipped;
}
return best_match;
@ -2515,7 +2522,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
if (SAME_OBJ(modidx, scheme_undefined)) {
if (!env->genv->module && SCHEME_STXP(find_id)) {
/* Looks like lexically bound, but double-check that it's not bound via a tl_id: */
find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL);
find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL);
if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id)))
modidx = NULL; /* yes, it is bound */
}
@ -2582,7 +2589,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
*_menv = genv;
if (!modname && SCHEME_STXP(find_id))
find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL);
find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL);
else
find_global_id = find_id;

11
src/mzscheme/src/eval.c
View File

@ -3518,6 +3518,9 @@ static void sfs_note_app(SFS_Info *info, Scheme_Object *rator)
{
if (!info->pass) {
if (!info->tail_pos) {
if (SAME_OBJ(scheme_values_func, rator))
/* no need to clear for app of `values' */
return;
if (SCHEME_PRIMP(rator)) {
int opt;
opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
@ -5435,7 +5438,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
/* If form is a marked name, then force #%top binding.
This is so temporaries can be used as defined ids. */
Scheme_Object *nm;
nm = scheme_tl_id_sym(env->genv, form, NULL, 0, NULL);
nm = scheme_tl_id_sym(env->genv, form, NULL, 0, NULL, NULL);
if (!SAME_OBJ(nm, SCHEME_STX_VAL(form))) {
stx = scheme_datum_to_syntax(top_symbol, scheme_false, scheme_sys_wraps(env), 0, 0);
@ -5870,7 +5873,7 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co
Scheme_Object *modidx, *symbol = c, *tl_id;
int bad;
tl_id = scheme_tl_id_sym(env->genv, symbol, NULL, 0, NULL);
tl_id = scheme_tl_id_sym(env->genv, symbol, NULL, 0, NULL, NULL);
if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) {
/* Since the module has a rename for this id, it's certainly defined. */
} else {
@ -5917,7 +5920,7 @@ top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
c = check_top(scheme_compile_stx_string, form, env, rec, drec);
c = scheme_tl_id_sym(env->genv, c, NULL, 0, NULL);
c = scheme_tl_id_sym(env->genv, c, NULL, 0, NULL, NULL);
if (env->genv->module && !rec[drec].resolve_module_ids) {
/* Self-reference in a module; need to remember the modidx. Don't
@ -8954,7 +8957,7 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Ob
Scheme_Object *l;
/* Registers marked id: */
scheme_tl_id_sym(env->genv, *_id, scheme_false, 2, NULL);
scheme_tl_id_sym(env->genv, *_id, scheme_false, 2, NULL, NULL);
l = icons(scheme_datum_to_syntax(define_values_symbol, scheme_false, sys_wraps, 0, 0),
icons(scheme_make_pair(*_id, scheme_null),

28
src/mzscheme/src/module.c
View File

@ -3210,7 +3210,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
supplied (not both). For unprotected access, both prot_insp
and stx+certs should be supplied. */
{
symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL);
symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL, NULL);
if (scheme_is_kernel_env(env)
|| ((env->module->primitive && !env->module->provide_protects))
@ -3389,7 +3389,7 @@ Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Sch
if (!menv->et_ran)
scheme_run_module_exptime(menv, 1);
name = scheme_tl_id_sym(menv, name, NULL, 0, NULL);
name = scheme_tl_id_sym(menv, name, NULL, 0, NULL, NULL);
val = scheme_lookup_in_table(menv->syntax, (char *)name);
@ -5505,7 +5505,7 @@ static int check_already_required(Scheme_Hash_Table *required, Scheme_Object *na
static Scheme_Object *stx_sym(Scheme_Object *name, Scheme_Object *_genv)
{
return scheme_tl_id_sym((Scheme_Env *)_genv, name, NULL, 2, NULL);
return scheme_tl_id_sym((Scheme_Env *)_genv, name, NULL, 2, NULL, NULL);
}
static Scheme_Object *add_a_rename(Scheme_Object *fm, Scheme_Object *post_ex_rn)
@ -5546,7 +5546,7 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id,
self_modidx = SCHEME_VEC_ELS(data)[1];
rn = SCHEME_VEC_ELS(data)[2];
name = scheme_tl_id_sym(env->genv, *_id, scheme_false, 2, NULL);
name = scheme_tl_id_sym(env->genv, *_id, scheme_false, 2, NULL, NULL);
/* Create the bucket, indicating that the name will be defined: */
scheme_add_global_symbol(name, scheme_undefined, env->genv);
@ -5848,7 +5848,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* Remember the original: */
all_defs = scheme_make_pair(name, all_defs);
name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL);
name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL);
/* Check that it's not yet defined: */
if (scheme_lookup_in_table(env->genv->toplevel, (const char *)name)) {
@ -5925,7 +5925,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
else
all_et_defs = scheme_make_pair(name, all_et_defs);
name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL);
name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL, NULL);
if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) {
scheme_wrong_syntax("module", orig_name, e,
@ -6278,7 +6278,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* may be a single shadowed exclusion, now bound to exclude_hint... */
n = SCHEME_CAR(n);
if (SCHEME_STXP(n))
n = scheme_tl_id_sym(env->genv, n, NULL, 0, NULL);
n = scheme_tl_id_sym(env->genv, n, NULL, 0, NULL, NULL);
n = scheme_hash_get(required, n);
if (n && !SAME_OBJ(SCHEME_VEC_ELS(n)[1], kernel_modidx)) {
/* there is a single shadowed exclusion. */
@ -6814,7 +6814,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided,
/* Make sure each excluded name was defined: */
for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
a = SCHEME_STX_CAR(exns);
name = scheme_tl_id_sym(genv, a, NULL, 0, NULL);
name = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL);
if (!scheme_lookup_in_table(genv->toplevel, (const char *)name)
&& !scheme_lookup_in_table(genv->syntax, (const char *)name)) {
scheme_wrong_syntax("module", a, ree_kw, "excluded identifier was not defined");
@ -6824,12 +6824,12 @@ int compute_reprovides(Scheme_Hash_Table *all_provided,
for (adl = all_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) {
name = SCHEME_CAR(adl);
exname = SCHEME_STX_SYM(name);
name = scheme_tl_id_sym(genv, name, NULL, 0, NULL);
name = scheme_tl_id_sym(genv, name, NULL, 0, NULL, NULL);
/* Was this one excluded? */
for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
a = SCHEME_STX_CAR(exns);
a = scheme_tl_id_sym(genv, a, NULL, 0, NULL);
a = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL);
if (SAME_OBJ(a, name))
break;
}
@ -6845,7 +6845,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided,
as if it had ree_kw's context, then comparing that result
to the actual tl_id. */
a = scheme_datum_to_syntax(exname, scheme_false, ree_kw, 0, 0);
a = scheme_tl_id_sym(genv, a, NULL, 0, NULL);
a = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL);
if (SAME_OBJ(a, name)) {
/* Add prefix, if any */
@ -7033,7 +7033,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
prnt_name = name;
if (SCHEME_STXP(name)) {
if (genv)
name = scheme_tl_id_sym(genv, name, NULL, 0, phase);
name = scheme_tl_id_sym(genv, name, NULL, 0, phase, NULL);
else
name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */
}
@ -7106,7 +7106,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
if (genv
&& (SAME_OBJ(phase, scheme_make_integer(0))
|| SAME_OBJ(phase, scheme_make_integer(1))))
name = scheme_tl_id_sym(genv, name, NULL, 0, phase);
name = scheme_tl_id_sym(genv, name, NULL, 0, phase, NULL);
else {
name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */
}
@ -8040,7 +8040,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
/* The `require' expression has a set of marks in its
context, which means that we need to generate a name. */
iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0);
iname = scheme_tl_id_sym(orig_env, iname, scheme_false, 2, to_phase);
iname = scheme_tl_id_sym(orig_env, iname, scheme_false, 2, to_phase, NULL);
if (all_simple)
*all_simple = 0;
}

197
src/mzscheme/src/port.c
View File

@ -122,11 +122,15 @@ typedef struct Win_FD_Input_Thread {
/* This is malloced for use in a Win32 thread */
HANDLE fd;
volatile int avail, err, checking;
int *refcount;
HANDLE eof;
unsigned char *buffer;
HANDLE checking_sema, ready_sema, you_clean_up_sema;
HANDLE thread;
} Win_FD_Input_Thread;
static HANDLE refcount_sema;
typedef struct Win_FD_Output_Thread {
/* This is malloced for use in a Win32 thread */
HANDLE fd;
@ -144,6 +148,7 @@ typedef struct Win_FD_Output_Thread {
volatile int done, err_no;
volatile unsigned int buflen, bufstart, bufend; /* used for blocking, only */
unsigned char *buffer; /* used for blocking, only */
int *refcount;
HANDLE lock_sema, work_sema, ready_sema, you_clean_up_sema;
/* lock_sema protects the fields, work_sema starts the flush or
flush-checking thread to work, ready_sema indicates that a flush
@ -187,6 +192,59 @@ typedef struct Scheme_Subprocess {
# define MZ_FDS
#endif
/******************** refcounts ********************/
#ifdef WINDOWS_FILE_HANDLES
static int *malloc_refcount()
{
if (!refcount_sema)
refcount_sema = CreateSemaphore(NULL, 1, 1, NULL);
return (int *)malloc(sizeof(int));
}
#ifdef MZ_XFORM
START_XFORM_SKIP;
#endif
static int dec_refcount(int *refcount)
{
int rc;
if (!refcount)
return 0;
WaitForSingleObject(refcount_sema, INFINITE);
*refcount -= 1;
rc = *refcount;
ReleaseSemaphore(refcount_sema, 1, NULL);
if (!rc) free(refcount);
return rc;
}
#ifdef MZ_XFORM
END_XFORM_SKIP;
#endif
#else
static int *malloc_refcount()
{
return (int *)scheme_malloc_atomic(sizeof(int));
}
static int dec_refcount(int *refcount)
{
if (!refcount)
return 0;
*refcount -= 1;
return *refcount;
}
#endif
/******************** file-descriptor I/O ********************/
@ -4532,6 +4590,26 @@ scheme_make_file_input_port(FILE *fp)
# ifdef WINDOWS_FILE_HANDLES
static long WindowsFDReader(Win_FD_Input_Thread *th);
static void WindowsFDICleanup(Win_FD_Input_Thread *th);
typedef BOOL (WINAPI* CSI_proc)(HANDLE);
static CSI_proc get_csi(void)
{
static int tried_csi = 0;
static CSI_proc csi;
START_XFORM_SKIP;
if (!tried_csi) {
HMODULE hm;
hm = LoadLibrary("kernel32.dll");
if (hm)
csi = (CSI_proc)GetProcAddress(hm, "CancelSynchronousIo");
else
csi = NULL;
tried_csi = 1;
}
END_XFORM_SKIP;
return csi;
}
# endif
/* forward decl: */
@ -4914,11 +4992,10 @@ fd_close_input(Scheme_Input_Port *port)
fip = (Scheme_FD *)port->port_data;
if (fip->refcount)
*fip->refcount -= 1;
#ifdef WINDOWS_FILE_HANDLES
if (fip->th) {
CSI_proc csi;
/* -1 for checking means "shut down" */
fip->th->checking = -1;
ReleaseSemaphore(fip->th->checking_sema, 1, NULL);
@ -4928,25 +5005,40 @@ fd_close_input(Scheme_Input_Port *port)
fip->th->eof = NULL;
}
csi = get_csi();
if (csi) {
/* Helps thread wake up. Otherwise, it's possible for the
thread to stay stuck trying to read, in which case the
file handle (probably a pipe) doesn't get closed. */
csi(fip->th->thread);
}
/* Try to get out of cleaning up the records (since they can't be
cleaned until the thread is also done: */
if (WaitForSingleObject(fip->th->you_clean_up_sema, 0) != WAIT_OBJECT_0) {
/* The other thread exited and left us with clean-up: */
WindowsFDICleanup(fip->th);
} /* otherwise, thread is responsible for clean-up */
}
if (!fip->refcount || !*fip->refcount) {
CloseHandle((HANDLE)fip->fd);
--scheme_file_open_count;
} else {
int rc;
rc = dec_refcount(fip->refcount);
if (!rc) {
CloseHandle((HANDLE)fip->fd);
--scheme_file_open_count;
}
}
#else
if (!fip->refcount || !*fip->refcount) {
int cr;
do {
cr = close(fip->fd);
} while ((cr == -1) && (errno == EINTR));
--scheme_file_open_count;
}
{
int rc;
rc = dec_refcount(fip->refcount);
if (!rc) {
int cr;
do {
cr = close(fip->fd);
} while ((cr == -1) && (errno == EINTR));
--scheme_file_open_count;
}
}
#endif
}
@ -5088,9 +5180,12 @@ make_fd_input_port(int fd, Scheme_Object *name, int regfile, int win_textmode, i
th->ready_sema = sm;
sm = CreateSemaphore(NULL, 1, 1, NULL);
th->you_clean_up_sema = sm;
th->refcount = refcount;
h = CreateThread(NULL, 4096, (LPTHREAD_START_ROUTINE)WindowsFDReader, th, 0, &id);
th->thread = h;
scheme_remember_thread(h, 1);
}
#endif
@ -5161,9 +5256,15 @@ static long WindowsFDReader(Win_FD_Input_Thread *th)
static void WindowsFDICleanup(Win_FD_Input_Thread *th)
{
int rc;
CloseHandle(th->checking_sema);
CloseHandle(th->ready_sema);
CloseHandle(th->you_clean_up_sema);
rc = dec_refcount(th->refcount);
if (!rc) CloseHandle(th->fd);
free(th->buffer);
free(th);
}
@ -5906,7 +6007,8 @@ static long flush_fd(Scheme_Output_Port *op,
oth->ready_sema = sm;
sm = CreateSemaphore(NULL, 1, 1, NULL);
oth->you_clean_up_sema = sm;
oth->refcount = fop->refcount;
h = CreateThread(NULL, 4096, (LPTHREAD_START_ROUTINE)WindowsFDWriter, oth, 0, &id);
scheme_remember_thread(h, 1);
@ -6134,10 +6236,6 @@ fd_write_string(Scheme_Output_Port *port,
return len;
}
#ifdef WINDOWS_FILE_HANDLES
typedef BOOL (WINAPI* CSI_proc)(HANDLE);
#endif
static void
fd_close_output(Scheme_Output_Port *port)
{
@ -6163,32 +6261,15 @@ fd_close_output(Scheme_Output_Port *port)
if (port->closed)
return;
if (fop->refcount)
*fop->refcount -= 1;
#ifdef WINDOWS_FILE_HANDLES
if (fop->oth) {
static int tried_csi = 0;
static CSI_proc csi;
CSI_proc csi;
START_XFORM_SKIP;
if (!tried_csi) {
HMODULE hm;
hm = LoadLibrary("kernel32.dll");
if (hm)
csi = (BOOL (WINAPI*)(HANDLE))GetProcAddress(hm, "CancelSynchronousIo");
else
csi = NULL;
tried_csi = 1;
}
END_XFORM_SKIP;
csi = get_csi();
if (csi) {
/* See also call to csi in fd_close_input */
csi(fop->oth->thread);
/* We're hoping that if CancelSyncrhonousIo isn't available, that
CloseHandle() will work, or that WriteFile() didn't block after
all (which seems to be the case with pre-Vista FILE_TYPE_CHAR
handles). */
}
CloseHandle(fop->oth->thread);
fop->oth->done = 1;
@ -6200,19 +6281,27 @@ fd_close_output(Scheme_Output_Port *port)
WindowsFDOCleanup(fop->oth);
} /* otherwise, thread is responsible for clean-up */
fop->oth = NULL;
}
if (!fop->refcount || !*fop->refcount) {
CloseHandle((HANDLE)fop->fd);
--scheme_file_open_count;
} else {
int rc;
rc = dec_refcount(fop->refcount);
if (!rc) {
CloseHandle((HANDLE)fop->fd);
--scheme_file_open_count;
}
}
#else
if (!fop->refcount || !*fop->refcount) {
int cr;
do {
cr = close(fop->fd);
} while ((cr == -1) && (errno == EINTR));
--scheme_file_open_count;
}
{
int rc;
rc = dec_refcount(fop->refcount);
if (!rc) {
int cr;
do {
cr = close(fop->fd);
} while ((cr == -1) && (errno == EINTR));
--scheme_file_open_count;
}
}
#endif
}
@ -6290,7 +6379,7 @@ make_fd_output_port(int fd, Scheme_Object *name, int regfile, int win_textmode,
if (and_read) {
int *rc;
Scheme_Object *a[2];
rc = (int *)scheme_malloc_atomic(sizeof(int));
rc = malloc_refcount();
*rc = 2;
fop->refcount = rc;
a[1] = the_port;
@ -6382,9 +6471,15 @@ static long WindowsFDWriter(Win_FD_Output_Thread *oth)
static void WindowsFDOCleanup(Win_FD_Output_Thread *oth)
{
int rc;
CloseHandle(oth->lock_sema);
CloseHandle(oth->work_sema);
CloseHandle(oth->you_clean_up_sema);
rc = dec_refcount(oth->refcount);
if (!rc) CloseHandle(oth->fd);
if (oth->buffer)
free(oth->buffer);
free(oth);

3
src/mzscheme/src/schpriv.h
View File

@ -2634,7 +2634,8 @@ void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Sc
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def, Scheme_Object *phase);
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def,
Scheme_Object *phase, int *_skipped);
int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym);
Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env);

83
src/mzscheme/src/stxobj.c
View File

@ -3300,7 +3300,7 @@ static int explain_resolves = 0;
static Scheme_Object *resolve_env(WRAP_POS *_wraps,
Scheme_Object *a, Scheme_Object *orig_phase,
int w_mod, Scheme_Object **get_names,
Scheme_Object *skip_ribs)
Scheme_Object *skip_ribs, int *_binding_marks_skipped)
/* Module binding ignored if w_mod is 0.
If module bound, result is module idx, and get_names[0] is set to source name,
get_names[1] is set to the nominal source module, get_names[2] is set to
@ -3321,6 +3321,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
Scheme_Object *phase = orig_phase;
Scheme_Object *bdg = NULL, *floating = NULL;
Scheme_Hash_Table *export_registry = NULL;
int mresult_skipped = 0;
EXPLAIN(printf("Resolving %s [skips: %s]:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)),
scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL)));
@ -3370,10 +3371,12 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
}
stack_pos -= 2;
}
if (!did_lexical)
if (!did_lexical) {
result = mresult;
else if (get_names)
get_names[0] = scheme_undefined;
if (_binding_marks_skipped)
*_binding_marks_skipped = mresult_skipped;
} else if (get_names)
get_names[0] = scheme_undefined;
EXPLAIN(printf("Result: %s\n", scheme_write_to_string(result, 0)));
@ -3383,6 +3386,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
&& w_mod) {
/* Module rename: */
Module_Renames *mrn;
int skipped;
EXPLAIN(printf("Rename/set\n"));
@ -3415,7 +3419,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
if (mrn->marked_names) {
/* Resolve based on rest of wraps: */
if (!bdg) {
bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, skip_ribs);
bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, skip_ribs, NULL);
if (SCHEME_FALSEP(bdg)) {
if (!floating_checked) {
floating = check_floating_id(a);
@ -3425,7 +3429,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
}
}
/* Remap id based on marks and rest-of-wraps resolution: */
glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL);
glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, &skipped);
if (SCHEME_TRUEP(bdg)
&& !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) {
/* Even if this module doesn't match, the lex-renamed id
@ -3437,8 +3441,10 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
stack_pos = 0;
o_rename_stack = scheme_null;
}
} else
} else {
skipped = 0;
glob_id = SCHEME_STX_VAL(a);
}
EXPLAIN(printf(" search %s\n", scheme_write_to_string(glob_id, 0)));
@ -3478,6 +3484,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
modidx_shift_from,
modidx_shift_to);
mresult_skipped = skipped;
if (get_names) {
int no_shift = 0;
@ -3551,6 +3559,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
}
} else {
mresult = scheme_false;
mresult_skipped = 0;
if (get_names)
get_names[0] = NULL;
}
@ -3647,7 +3656,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
if (SCHEME_VOIDP(other_env)) {
SCHEME_USE_FUEL(1);
other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs);
other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL);
if (!is_rib)
SCHEME_VEC_ELS(rename)[2+c+ri] = other_env;
SCHEME_USE_FUEL(1);
@ -3806,13 +3815,13 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
if (mrn->needs_unmarshal) {
/* Use resolve_env to trigger unmarshal, so that we
don't have to implement top/from shifts here: */
resolve_env(NULL, a, orig_phase, 1, NULL, NULL);
resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL);
}
if (mrn->marked_names) {
/* Resolve based on rest of wraps: */
if (!bdg)
bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL);
bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL);
if (SCHEME_FALSEP(bdg)) {
if (!floating_checked) {
floating = check_floating_id(a);
@ -3821,7 +3830,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
bdg = floating;
}
/* Remap id based on marks and rest-of-wraps resolution: */
glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL);
glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, NULL);
} else
glob_id = SCHEME_STX_VAL(a);
@ -3892,8 +3901,8 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha
if ((a == asym) || (b == bsym))
return 1;
a = resolve_env(NULL, a, phase, 1, NULL, NULL);
b = resolve_env(NULL, b, phase, 1, NULL, NULL);
a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL);
b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL);
if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type))
a = scheme_module_resolve(a, 0);
@ -3935,7 +3944,7 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase,
names[4] = NULL;
names[5] = NULL;
modname = resolve_env(NULL, *a, phase, 1, names, NULL);
modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL);
if (names[0]) {
if (SAME_OBJ(names[0], scheme_undefined)) {
@ -3966,7 +3975,7 @@ Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a)
if (SCHEME_STXP(a)) {
Scheme_Object *r;
r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL);
r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL);
if (SCHEME_FALSEP(r))
r = check_floating_id(a);
@ -3998,13 +4007,13 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
if (!SAME_OBJ(asym, bsym))
return 0;
ae = resolve_env(NULL, a, phase, 0, NULL, NULL);
ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL);
/* No need to module_resolve ae, because we ignored module renamings. */
if (uid)
be = uid;
else {
be = resolve_env(NULL, b, phase, 0, NULL, NULL);
be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL);
/* No need to module_resolve be, because we ignored module renamings. */
}
@ -4034,7 +4043,7 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase
Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a)
{
explain_resolves++;
a = resolve_env(NULL, a, 0, 0, NULL, NULL);
a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL);
--explain_resolves;
return a;
}
@ -4567,7 +4576,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii];
if (SCHEME_VOIDP(other_env)) {
other_env = resolve_env(NULL, stx, 0, 0, NULL, skip_ribs);
other_env = resolve_env(NULL, stx, 0, 0, NULL, skip_ribs, NULL);
SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env;
}
@ -5509,7 +5518,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
scheme_unmarshal_wrap_set(ut, local_key, a);
} else if (SCHEME_PAIRP(a)) {
/* A rename table:
- ([#t] <index-num> <phase-num> <bool> [unmarshal] #(<table-elem> ...)
- ([#t] <phase-num> <kind-num> <set-identity> [unmarshal] #(<table-elem> ...)
. ((<sym> (<marked-list-or-mark> . <target-gensym>) ...) ...)) ; <- marked_names
where a <table-elem> is actually two values, one of:
- <exname> <modname>
@ -6788,7 +6797,7 @@ static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], S
static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv)
{
Scheme_Object *m1, *m2, *delta, *a[1];
Scheme_Object *orig_m1, *m1, *m2, *delta, *a[1];
int l1, l2;
if (!SCHEME_STXP(argv[0]))
@ -6797,6 +6806,7 @@ static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv)
scheme_wrong_type("make-syntax-delta-introducer", "syntax", 1, argc, argv);
m1 = scheme_stx_extract_marks(argv[0]);
orig_m1 = m1;
m2 = scheme_stx_extract_marks(argv[1]);
l1 = scheme_list_length(m1);
@ -6810,11 +6820,32 @@ static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv)
}
if (!scheme_equal(m1, m2)) {
/* tails don't match, so keep all marks */
while (l1) {
delta = CONS(SCHEME_CAR(m1), delta);
m1 = SCHEME_CDR(m1);
l1--;
/* tails don't match, so keep all marks --- except those that determine a module binding */
int skipped = 0;
Scheme_Object *phase;
Scheme_Thread *p = scheme_current_thread;
phase = scheme_make_integer(p->current_local_env
? p->current_local_env->genv->phase
: 0);
resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped);
if (skipped) {
/* Just keep the first `skipped' marks. */
delta = scheme_null;
m1 = orig_m1;
while (skipped) {
delta = CONS(SCHEME_CAR(m1), delta);
m1 = SCHEME_CDR(m1);
skipped--;
}
} else {
/* Keep them all */
while (l1) {
delta = CONS(SCHEME_CAR(m1), delta);
m1 = SCHEME_CDR(m1);
l1--;
}
}
}

4
src/mzscheme/src/syntax.c
View File

@ -1102,7 +1102,7 @@ defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_In
Scheme_Object *name, *pr, *bucket;
name = SCHEME_STX_CAR(var);
name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL);
name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL);
if (rec[drec].resolve_module_ids || !env->genv->module) {
bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv);
@ -5373,7 +5373,7 @@ static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env)
{
Scheme_Env *env = (Scheme_Env *)_env;
return scheme_tl_id_sym(env, name, NULL, 2, NULL);
return scheme_tl_id_sym(env, name, NULL, 2, NULL, NULL);
}
static Scheme_Object *