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

shared

Browse Source 
svn: r8069
This commit is contained in:
Matthew Flatt 2007-12-19 21:32:07 +00:00
parent 98c57e31df
commit f70ea2d03a
15 changed files with 501 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/lang/private/teach-shared.ss Normal file
View File

@ -0,0 +1,19 @@
#lang scheme/base
(require syntax/stx
syntax/kerncase
syntax/struct
scheme/include)
(provide shared/proc)
(require (for-template
scheme/base
(only-in "teachprims.ss" [advanced-cons the-cons])))
(define shared/proc
(lambda (stx make-check-cdr undefined-expr)
(with-syntax ([undefined undefined-expr])
;; Include the implementation.
;; See private/shared-body.ss.
(include (lib "mzlib/private/shared-body.ss")))))

3
collects/lang/private/teach.ss
View File

@ -39,6 +39,7 @@
(lib "math.ss")
"set-result.ss")
(require-for-syntax "teachhelp.ss"
"teach-shared.ss"
(lib "kerncase.ss" "syntax")
(lib "stx.ss" "syntax")
(lib "struct.ss" "syntax")
@ -2353,4 +2354,4 @@
[_else (bad-use-error 'shared stx)])
;; The main implementation
(include (build-path up up "mzlib" "private" "shared-body.ss"))))))))
(shared/proc stx make-check-cdr #'undefined)))))))

160
collects/mzlib/private/shared-body.ss
View File

@ -31,17 +31,20 @@
(kernel-form-identifier-list)
names))])
;; Remove #%app if present...
(syntax-case e (#%app)
[(#%app a ...)
(syntax-case e (#%plain-app)
[(#%plain-app a ...)
(syntax/loc e (a ...))]
[_else e])))
exprs)]
[temp-ids (generate-temporaries names)]
[placeholder-ids (generate-temporaries names)]
[ph-used?s (map (lambda (x) (box #f)) names)]
[struct-decl-for (lambda (id)
(and (identifier? id)
(let* ([s (symbol->string (syntax-e id))]
[m (regexp-match-positions "make-" s)])
(and m
(let ([name (datum->syntax-object
(let ([name (datum->syntax
id
(string->symbol (string-append (substring s 0 (caar m))
(substring s (cdar m) (string-length s))))
@ -49,42 +52,63 @@
(let ([v (syntax-local-value name (lambda () #f))])
(and v
(struct-declaration-info? v)
(extract-struct-info v))))))))]
(let ([decl (extract-struct-info v)])
(and (cadr decl)
(andmap values (list-ref decl 4))
decl)))))))))]
[same-special-id? (lambda (a b)
;; Almost module-or-top-identifier=?,
;; but handle the-cons specially
(or (module-identifier=? a b)
(module-identifier=?
(or (free-identifier=? a b)
(free-identifier=?
a
(datum->syntax-object
(datum->syntax
#f
(if (eq? 'the-cons (syntax-e b))
'cons
(syntax-e b))))))])
(with-syntax ([(init-expr ...)
(with-syntax ([(graph-expr ...)
(map (lambda (expr)
(let loop ([expr expr])
(define (bad n)
(raise-syntax-error
'shared
(format "illegal use of ~a" n)
stx
expr))
(syntax-case* expr (the-cons list box vector) same-special-id?
(define (cons-elem expr)
(or (and (identifier? expr)
(ormap (lambda (i ph ph-used?)
(and (free-identifier=? i expr)
(set-box! ph-used? #t)
ph))
names placeholder-ids ph-used?s))
(loop expr)))
(syntax-case* expr (the-cons mcons list box box-immutable vector vector-immutable) same-special-id?
[(the-cons a d)
(syntax (cons undefined undefined))]
(with-syntax ([a (cons-elem #'a)]
[d (cons-elem #'d)])
(syntax/loc expr (cons a d)))]
[(the-cons . _)
(bad "cons")]
[(mcons a d)
(syntax (mcons undefined undefined))]
[(mcons . _)
(bad "mcons")]
[(list e ...)
(with-syntax ([(e ...)
(map (lambda (x) (syntax undefined))
(map (lambda (x) (cons-elem x))
(syntax->list (syntax (e ...))))])
(syntax (list e ...)))]
(syntax/loc expr (list e ...)))]
[(list . _)
(bad "list")]
[(box v)
(syntax (box undefined))]
[(box . _)
(bad "box")]
[(box-immutable v)
(with-syntax ([v (cons-elem #'v)])
(syntax/loc expr (box-immutable v)))]
[(vector e ...)
(with-syntax ([(e ...)
(map (lambda (x) (syntax undefined))
@ -92,19 +116,19 @@
(syntax (vector e ...)))]
[(vector . _)
(bad "vector")]
[(make-x . _)
[(vector-immutable e ...)
(with-syntax ([(e ...)
(map (lambda (x) (cons-elem x))
(syntax->list (syntax (e ...))))])
(syntax/loc expr (vector-immutable e ...)))]
[(vector-immutable . _)
(bad "vector-immutable")]
[(make-x . args)
(struct-decl-for (syntax make-x))
(let ([decl (struct-decl-for (syntax make-x))]
[args (syntax->list (syntax _))])
[args (syntax->list (syntax args))])
(unless args
(bad "structure constructor"))
(when (or (not (cadr decl))
(ormap not (list-ref decl 4)))
(raise-syntax-error
'shared
"not enough information about the structure type in this context"
stx
expr))
(unless (= (length (list-ref decl 4)) (length args))
(raise-syntax-error
'shared
@ -114,35 +138,73 @@
expr))
(with-syntax ([undefineds (map (lambda (x) (syntax undefined)) args)])
(syntax (make-x . undefineds))))]
[_else
expr]))
[_else expr])))
exprs)]
[(init-expr ...)
(map (lambda (expr temp-id used?)
(let ([init-id
(syntax-case* expr (the-cons mcons list box box-immutable vector vector-immutable) same-special-id?
[(the-cons . _) temp-id]
[(mcons . _) temp-id]
[(list . _) temp-id]
[(box . _) temp-id]
[(box-immutable . _) temp-id]
[(vector . _) temp-id]
[(vector-immutable . _) temp-id]
[(make-x . _)
(struct-decl-for (syntax make-x))
temp-id]
[else #f])])
(cond
[init-id
(set-box! used? #t)
init-id]
[(unbox used?)
temp-id]
[else
expr])))
exprs temp-ids ph-used?s)]
[(finish-expr ...)
(let ([gen-n (lambda (l)
(let loop ([l l][n 0])
(if (null? l)
null
(cons (datum->syntax-object (quote-syntax here) n #f)
(cons (datum->syntax (quote-syntax here) n #f)
(loop (cdr l) (add1 n))))))])
(map (lambda (name expr)
(let loop ([name name] [expr expr])
(with-syntax ([name name])
(syntax-case* expr (the-cons list box vector) same-special-id?
(syntax-case* expr (the-cons mcons list box box-immutable vector vector-immutable) same-special-id?
[(the-cons a d)
#`(begin #,(loop #`(car name) #'a)
#,(loop #`(cdr name) #'d))]
[(mcons a d)
(syntax (begin
(set-car! name a)
(set-cdr! name d)))]
(set-mcar! name a)
(set-mcdr! name d)))]
[(list e ...)
(with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))])
(syntax (let ([lst name])
(set-car! (list-tail lst n) e)
...)))]
(let ([es (syntax->list #'(e ...))])
#`(begin
#,@(map (lambda (n e)
(loop #`(list-ref name #,n) e))
(gen-n es)
es)))]
[(box v)
(syntax (set-box! name v))]
[(box-immutable v)
(loop #'(unbox name) #'v)]
[(vector e ...)
(with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))])
(syntax (let ([vec name])
(vector-set! vec n e)
...)))]
[(vector-immutable e ...)
(let ([es (syntax->list #'(e ...))])
#`(begin
#,@(map (lambda (n e)
(loop #`(vector-ref name #,n) e))
(gen-n es)
es)))]
[(make-x e ...)
(struct-decl-for (syntax make-x))
(let ([decl (struct-decl-for (syntax make-x))])
@ -151,23 +213,47 @@
(syntax (void))]
[(setter ...)
(syntax (begin (setter name e) ...))]))]
[_else (syntax (void))])))
[_else (syntax (void))]))))
names exprs))]
[(check-expr ...)
(if make-check-cdr
(map (lambda (name expr)
(syntax-case* expr (the-cons list box vector) same-special-id?
(syntax-case* expr (the-cons) same-special-id?
[(the-cons a d)
(make-check-cdr name)]
[_else (syntax #t)]))
names exprs)
null)])
(syntax
(letrec ([name init-expr] ...)
null)]
[(temp-id ...) temp-ids]
[(placeholder-id ...) placeholder-ids]
[(ph-used? ...) (map unbox ph-used?s)]
[(used-ph-id ...) (filter values
(map (lambda (ph ph-used?)
(and (unbox ph-used?)
ph))
placeholder-ids ph-used?s))]
[(maybe-ph-id ...) (map (lambda (ph ph-used?)
(and (unbox ph-used?)
ph))
placeholder-ids ph-used?s)])
(with-syntax ([(ph-init ...) (filter values
(map (lambda (ph ph-used? graph-expr)
(and (unbox ph-used?)
#`(placeholder-set! #,ph #,graph-expr)))
placeholder-ids ph-used?s
(syntax->list #'(graph-expr ...))))])
(syntax/loc stx
(letrec-values ([(used-ph-id) (make-placeholder #f)] ...
[(temp-id ...)
(begin
ph-init ...
(apply values (make-reader-graph
(list maybe-ph-id ...))))]
[(name) init-expr] ...)
finish-expr
...
check-expr
...
body1
body
...)))))])
...))))))])

15
collects/mzlib/shared.ss
View File

@ -1,18 +1,19 @@
#lang scheme/base
(module shared mzscheme
(require-for-syntax (lib "stx.ss" "syntax")
(lib "kerncase.ss" "syntax")
(lib "struct.ss" "syntax")
"include.ss")
(require (for-syntax scheme/base
syntax/stx
syntax/kerncase
syntax/struct
scheme/include))
(provide shared)
(define undefined (letrec ([x x]) x))
(require (rename mzscheme the-cons cons))
(require (only-in scheme/base [cons the-cons]))
(define-syntax shared
(lambda (stx)
(define make-check-cdr #f)
;; Include the implementation.
;; See private/shared-body.ss.
(include (build-path "private" "shared-body.ss")))))
(include "private/shared-body.ss")))

2
collects/scheme/main.ss
View File

@ -6,6 +6,7 @@
scheme/pretty
scheme/math
scheme/match
scheme/shared
scheme/tcp
scheme/udp
scheme/list
@ -22,6 +23,7 @@
scheme/pretty
scheme/math
scheme/match
scheme/shared
scheme/base
scheme/tcp
scheme/udp

4
collects/scheme/shared.ss Normal file
View File

@ -0,0 +1,4 @@
#lang scheme/base
(require mzlib/shared)
(provide shared)

12
collects/scribble/eval.ss
View File

@ -141,7 +141,7 @@
(get-output-string o)
(get-output-string o2)))])
(list (let ([v (do-plain-eval s #t)])
(copy-value v (make-hash-table)))
(make-reader-graph (copy-value v (make-hash-table))))
(get-output-string o)
(get-output-string o2)))))]))
@ -157,9 +157,15 @@
=> (lambda (v) v)]
[(string? v) (install ht v (string-copy v))]
[(bytes? v) (install ht v (bytes-copy v))]
[(pair? v) (cons (copy-value (car v) ht)
(copy-value (cdr v) ht))]
[(pair? v)
(let ([ph (make-placeholder #f)])
(hash-table-put! ht v ph)
(placeholder-set! ph
(cons (copy-value (car v) ht)
(copy-value (cdr v) ht)))
ph)]
[(mpair? v) (let ([p (mcons #f #f)])
(hash-table-put! ht v p)
(set-mcar! p (copy-value (mcar v) ht))
(set-mcdr! p (copy-value (mcdr v) ht))
p)]

103
collects/scribble/scheme.ss
View File

@ -390,7 +390,6 @@
((loop init-line! quote-depth) (car l))
(lloop (cdr l))]
[else
(advance l init-line! -2)
(out ". " (if (positive? quote-depth) value-color paren-color))
(set! src-col (+ src-col 3))
@ -425,6 +424,20 @@
(syntax-ize (hash-table-map (syntax-e c) cons)
(+ (syntax-column c) delta)))
(set! src-col (+ orig-col (syntax-span c)))))]
[(graph-reference? (syntax-e c))
(out (format "#~a#" (unbox (graph-reference-bx (syntax-e c))))
(if (positive? quote-depth)
value-color
paren-color))]
[(graph-defn? (syntax-e c))
(let ([bx (graph-defn-bx (syntax-e c))])
(set-box! bx 0)
(out (format "#~a=" (unbox bx))
(if (positive? quote-depth)
value-color
paren-color))
(set! src-col (+ src-col 3))
((loop init-line! quote-depth) (graph-defn-r (syntax-e c))))]
[else
(advance c init-line!)
(typeset-atom c out color? quote-depth)
@ -458,7 +471,9 @@
(vector? s)
(box? s)
(null? s)
(hash-table? s))
(hash-table? s)
(graph-defn? s)
(graph-reference? s))
(gen-typeset c multi-line? prefix1 prefix suffix color?)
(typeset-atom c
(case-lambda
@ -561,6 +576,8 @@
(define syntax-ize-hook (make-parameter (lambda (v col) #f)))
(define (vector->short-list v extract)
(vector->list v)
#;
(let ([l (vector->list v)])
(reverse (list-tail
(reverse l)
@ -586,21 +603,40 @@
(define-struct shaped-parens (val shape))
(define-struct just-context (val ctx))
(define-struct graph-reference (bx))
(define-struct graph-defn (r bx))
(define (syntax-ize v col)
(do-syntax-ize v col (make-hash-table) #f))
(define (graph-count ht graph?)
(and graph?
(let ([n (hash-table-get ht '#%graph-count 0)])
(hash-table-put! ht '#%graph-count (add1 n))
n)))
(define (do-syntax-ize v col ht graph?)
(cond
[((syntax-ize-hook) v col)
=> (lambda (r) r)]
[(shaped-parens? v)
(syntax-property (syntax-ize (shaped-parens-val v) col)
(syntax-property (do-syntax-ize (shaped-parens-val v) col ht #f)
'paren-shape
(shaped-parens-shape v))]
[(just-context? v)
(let ([s (syntax-ize (just-context-val v) col)])
(let ([s (do-syntax-ize (just-context-val v) col ht #f)])
(datum->syntax (just-context-ctx v)
(syntax-e s)
s
s
(just-context-ctx v)))]
[(hash-table-get ht v #f)
=> (lambda (m)
(unless (unbox m)
(set-box! m #t))
(datum->syntax #f
(make-graph-reference m)
(list #f 1 col (+ 1 col) 1)))]
[(and (list? v)
(pair? v)
(memq (let ([s (car v)])
@ -608,24 +644,29 @@
(just-context-val s)
s))
'(quote unquote unquote-splicing)))
(let ([c (syntax-ize (cadr v) (+ col 1))])
(let ([c (do-syntax-ize (cadr v) (+ col 1) ht #f)])
(datum->syntax #f
(list (syntax-ize (car v) col)
(list (do-syntax-ize (car v) col ht #f)
c)
(list #f 1 col (+ 1 col)
(+ 1 (syntax-span c)))))]
[(or (list? v)
(vector? v))
(let* ([vec-sz (if (vector? v)
(let ([graph-box (box (graph-count ht graph?))])
(hash-table-put! ht v graph-box)
(let ([r (let* ([vec-sz (+ (if graph?
(+ 2 (string-length (format "~a" (unbox graph-box))))
0)
(if (vector? v)
(+ 1 #;(string-length (format "~a" (vector-length v))))
0)])
0))])
(let ([l (let loop ([col (+ col 1 vec-sz)]
[v (if (vector? v)
(vector->short-list v values)
v)])
(if (null? v)
null
(let ([i (syntax-ize (car v) col)])
(let ([i (do-syntax-ize (car v) col ht #f)])
(cons i
(loop (+ col 1 (syntax-span i)) (cdr v))))))])
(datum->syntax #f
@ -638,17 +679,47 @@
(if (zero? (length l))
0
(sub1 (length l)))
(apply + (map syntax-span l)))))))]
(apply + (map syntax-span l)))))))])
(unless graph?
(hash-table-put! ht v #f))
(cond
[graph? (datum->syntax #f
(make-graph-defn r graph-box)
r)]
[(unbox graph-box)
;; Go again, this time knowing that there will be a graph:
(do-syntax-ize v col ht #t)]
[else r])))]
[(pair? v)
(let* ([a (syntax-ize (car v) (+ col 1))]
[sep (if (pair? (cdr v)) 0 3)]
[b (syntax-ize (cdr v) (+ col 1 (syntax-span a) sep))])
(datum->syntax #f
(let ([graph-box (box (graph-count ht graph?))])
(hash-table-put! ht v graph-box)
(let* ([inc (if graph?
(+ 2 (string-length (format "~a" (unbox graph-box))))
0)]
[a (do-syntax-ize (car v) (+ col 1 inc) ht #f)]
[sep (if (and (pair? (cdr v))
;; FIXME: what if it turns out to be a graph reference?
(not (hash-table-get ht (cdr v) #f)))
0
3)]
[b (do-syntax-ize (cdr v) (+ col 1 inc (syntax-span a) sep) ht #f)])
(let ([r (datum->syntax #f
(cons a b)
(list #f 1 (+ col inc) (+ 1 col inc)
(+ 2 sep (syntax-span a) (syntax-span b))))])
(unless graph?
(hash-table-put! ht v #f))
(cond
[graph? (datum->syntax #f
(make-graph-defn r graph-box)
(list #f 1 col (+ 1 col)
(+ 2 sep (syntax-span a) (syntax-span b)))))]
(+ inc (syntax-span r))))]
[(unbox graph-box)
;; Go again...
(do-syntax-ize v col ht #t)]
[else r]))))]
[(box? v)
(let ([a (syntax-ize (unbox v) (+ col 2))])
(let ([a (do-syntax-ize (unbox v) (+ col 2) ht #f)])
(datum->syntax #f
(box a)
(list #f 1 col (+ 1 col)

2
collects/scribblings/reference/data.scrbl
View File

@ -1,7 +1,7 @@
#lang scribble/doc
@require["mz.ss"]
@title[#:style 'toc]{Core Datatypes}
@title[#:style 'toc]{Primitive Datatypes}
Each of the built-in datatypes comes with a set of procedures for
manipulating members of the datatype.

119
collects/scribblings/reference/shared.scrbl Normal file
View File

@ -0,0 +1,119 @@
#lang scribble/doc
@(require "mz.ss"
scribble/struct
scheme/shared
(for-label scheme/shared))
@(define maker
(make-element #f (list
(schemevarfont "prefix:")
(schemeidfont "make-")
(schemevarfont "id"))))
@(define typedef
(make-element #f (list
(schemevarfont "prefix:")
(schemevarfont "id"))))
@title[#:tag "shared"]{Constructing Graphs: @scheme[shared]}
@note-lib[scheme/shared]
@defform[(shared ([id expr] ...) body ...+)]{
Binds @scheme[id]s with shared structure according to @scheme[exprs]
and then evaluates the @scheme[body-expr]s, returning the result of
the last expression.
The @scheme[shared] form is similar to @scheme[letrec], except that
special forms of @scheme[expr] are recognized (after partial macro
expansion) to construct graph-structured data, where the corresponding
@scheme[letrec] would instead produce @|undefined-const|s.
Each @scheme[expr] (after partial expansion) is matched against the
following @scheme[_shared-expr] grammar, where earlier variants in a
production take precedence over later variants:
@schemegrammar*[
#:literals (cons list vector-immutable box-immutable mcons vector box)
[shared-expr shell-expr
plain-expr]
[shell-expr (cons in-immutable-expr in-immutable-expr)
(list in-immutable-expr ...)
(vector-immutable in-immutable-expr ...)
(box-immutable in-immutable-expr)
(mcons patchable-expr)
(vector patchable-expr ...)
(box patchable-expr ...)
(#, @|maker| patchable-expr ...)]
[in-immutable-expr shell-id
shell-expr
early-expr]
[shell-id id]
[patchable-expr expr]
[early-expr expr]
[plain-expr expr]
]
The @|maker| identifier above references to any binding whose name has
@schemeidfont{make-} in the middle, and where @|typedef| has a
@tech{transformer binding} to structure information with a full set of
mutator bindings; see @secref["structinfo"]. A @scheme[_shell-id] must
be one of the @scheme[id]s bound by the @scheme[shared] form to a
@scheme[_shell-expr].
When the @scheme[expr]s of the @scheme[shared] form are parsed via
@scheme[_shared-expr] (taking into account the order of the variants
for precedence), and sub-expression that parses via
@scheme[_early-expr] will be evaluated first when the @scheme[shared]
form is evaluated. Among such expressions, they are evaluated in the
order as they appear within the @scheme[shared] form. However, any
reference to an @scheme[id] bound by @scheme[shared] produces
@|undefined-const|, even if the binding for the @scheme[id] appears
before the corresponding @scheme[_early-expr] within the
@scheme[shared] form.
The @scheme[_shell-ids] and @scheme[_shell-exprs] (not counting
@scheme[_patchable-expr] and @scheme[_early-expr] sub-expressions) are
effectively evaluated next. A @scheme[_shell-id] reference produces
the same value as the corresponding @scheme[_id] will produce within
the @scheme[body]s, assuming that @scheme[_id] is never mutated with
@scheme[set!]. This special handling of a @scheme[_shell-id]
reference is one way in which @scheme[shared] supports the creation of
cyclic data, including immutable cyclic data.
Next, the @scheme[_plain-expr]s are evaluated as for @scheme[letrec],
where a reference to an @scheme[id] produces @|undefined-const| if it
is evaluated before the right-hand side of the @scheme[id] binding.
Finally, the @scheme[_patchable-expr]s are evaluated. At this point,
all @scheme[id]s are bound, so @scheme[_patchable-expr]s also created
data cycles (but only with cycles that can be created via mutation).
@examples[
(shared ([a (cons 1 a)])
a)
(shared ([a (cons 1 b)]
[b (cons 2 a)])
a)
(shared ([a (cons 1 b)]
[b 7])
a)
(shared ([a a]) (code:comment #, @t{no indirection...})
a)
(shared ([a (cons 1 b)] (code:comment #, @t{@scheme[b] is early...})
[b a])
a)
(shared ([a (mcons 1 b)] (code:comment #, @t{@scheme[b] is patchable...})
[b a])
a)
(shared ([a (vector b b b)]
[b (box 1)])
(set-box! b 5)
a)
(shared ([a (box b)]
[b (vector (unbox a) (code:comment #, @t{@scheme[unbox] after @scheme[a] is patched})
(unbox c))] (code:comment #, @t{@scheme[unbox] before @scheme[c] is patched})
[c (box b)])
b)
]}

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

@ -3,7 +3,7 @@
@define[cvt (schemefont "CVT")]
@title[#:tag "syntax" #:style 'toc]{Core Syntactic Forms}
@title[#:tag "syntax" #:style 'toc]{Syntactic Forms}
This section describes the core syntax forms that apear in a fully
expanded expression, plus a many closely-related non-core forms.
@ -524,6 +524,9 @@ Combines @scheme[letrec-syntaxes] with @scheme[letrec-values]: each
@scheme[trans-id] and @scheme[val-id] is bound in all
@scheme[trans-expr]s and @scheme[val-expr]s.}
@;------------------------------------------------------------------------
@include-section["shared.scrbl"]
@;------------------------------------------------------------------------
@section[#:tag "if"]{Conditionals: @scheme[if], @scheme[cond], @scheme[and], and @scheme[or]}

4
collects/tests/mzscheme/advanced.ss
View File

@ -206,8 +206,8 @@
(define x 10)
(define (f y) f)
(define-struct s (x y)))
(mz-require my-advanced-module)
(parameterize ([current-namespace (module->namespace 'my-advanced-module)])
(mz-require 'my-advanced-module)
(parameterize ([current-namespace (module->namespace ''my-advanced-module)])
(eval #'(set! x 12))
(eval #'(set! f 12))
(eval #'(set! make-s 12))

27
collects/tests/mzscheme/shared-tests.ss
View File

@ -1,4 +1,6 @@
;; This file has to work for both "shared.ss" and "advanced.ss"
;; this writes values to strings and compares the strings
;; to implements an equal? predicate that works for cyclic
;; structures.
@ -8,6 +10,8 @@
(begin
(write v p)
(get-output-string p))))
(define (x s)
(read (open-input-string s)))
(define (stest expect expression)
(test
(gs expect)
@ -18,14 +22,25 @@
(stest #(1 2) '(shared ([x (vector 1 2)]) x))
(stest (box 1) '(shared ([x (box 1)]) x))
(stest '(1) '(shared ([x (cons 1 null)]) x))
(stest (mcons 1 null) '(shared ([x (mcons 1 null)]) x))
(stest '#1=(#1# 1) '(shared ([x (list x 1)]) x))
(stest '#2=#(#2# 1) '(shared ([x (vector x 1)]) x))
(stest '#3=#&#3# '(shared ([x (box x)]) x))
(stest '#4=(#4#) '(shared ([x (cons x null)]) x))
(stest '#5=(1 . #5#) '(shared ([x (cons 1 x)]) x))
(stest (x "#1=(#1# 1)") '(shared ([x (list x 1)]) x))
(stest (x "#2=#(#2# 1)") '(shared ([x (vector x 1)]) x))
(stest (x "#2=#(#2# 1)") '(shared ([x (vector-immutable x 1)]) x))
(stest (x "#3=#&#3#") '(shared ([x (box x)]) x))
(stest (x "#3=#&#3#") '(shared ([x (box-immutable x)]) x))
(stest (x "#4=(#4#)") '(shared ([x (cons x null)]) x))
(stest (x "#5=(1 . #5#)") '(shared ([x (cons 1 x)]) x))
(stest (let ([x (mcons 1 #f)])
(begin (set-mcdr! x x)
x))
'(shared ([x (mcons 1 x)]) x))
(stest '#11=(#11#) '(shared ([x `(,x)]) x))
(stest (x "#11=(#11#)") '(shared ([x `(,x)]) x))
(stest 1 '(shared ([x (list 1 x p)]
[p (lambda () x)])
(car ((caddr x)))))
(define-struct s (a b))
(shared ([x (make-s 17 x)])

7
collects/tests/mzscheme/shared.ss
View File

@ -5,9 +5,14 @@
(require (lib "shared.ss"))
(require (only-in mzscheme define-struct))
(load-relative "shared-tests.ss")
(require mzscheme)
(stest (letrec ([x x]) x) (shared ([x x]) x))
(stest (letrec ([x x]) x) (shared ([x y][y x]) x))
(namespace-require/copy 'scheme/base)
(require (only-in mzscheme define-struct))
(load-relative "shared-tests.ss")
(report-errs)

2
src/mzscheme/src/file.c
View File

@ -5791,7 +5791,7 @@ find_system_path(int argc, Scheme_Object **argv)
|| (which == id_pref_file))
which_folder = CSIDL_APPDATA;
else if (which == id_doc_dir) {
# ifndef CSIDL_MYDOCUMENTS
# ifndef CSIDL_PERSONAL
# define CSIDL_PERSONAL 0x0005
# endif
which_folder = CSIDL_PERSONAL;