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

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

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

29
collects/mzlib/shared.ss
View File

@ -1,18 +1,19 @@
#lang scheme/base
(module shared mzscheme (require (for-syntax scheme/base
(require-for-syntax (lib "stx.ss" "syntax") syntax/stx
(lib "kerncase.ss" "syntax") syntax/kerncase
(lib "struct.ss" "syntax") syntax/struct
"include.ss") scheme/include))
(provide shared) (provide shared)
(define undefined (letrec ([x x]) x)) (define undefined (letrec ([x x]) x))
(require (rename mzscheme the-cons cons)) (require (only-in scheme/base [cons the-cons]))
(define-syntax shared (define-syntax shared
(lambda (stx) (lambda (stx)
(define make-check-cdr #f) (define make-check-cdr #f)
;; Include the implementation. ;; Include the implementation.
;; See private/shared-body.ss. ;; 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/pretty
scheme/math scheme/math
scheme/match scheme/match
scheme/shared
scheme/tcp scheme/tcp
scheme/udp scheme/udp
scheme/list scheme/list
@ -22,6 +23,7 @@
scheme/pretty scheme/pretty
scheme/math scheme/math
scheme/match scheme/match
scheme/shared
scheme/base scheme/base
scheme/tcp scheme/tcp
scheme/udp 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 o)
(get-output-string o2)))]) (get-output-string o2)))])
(list (let ([v (do-plain-eval s #t)]) (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 o)
(get-output-string o2)))))])) (get-output-string o2)))))]))
@ -157,9 +157,15 @@
=> (lambda (v) v)] => (lambda (v) v)]
[(string? v) (install ht v (string-copy v))] [(string? v) (install ht v (string-copy v))]
[(bytes? v) (install ht v (bytes-copy v))] [(bytes? v) (install ht v (bytes-copy v))]
[(pair? v) (cons (copy-value (car v) ht) [(pair? v)
(copy-value (cdr v) ht))] (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)]) [(mpair? v) (let ([p (mcons #f #f)])
(hash-table-put! ht v p)
(set-mcar! p (copy-value (mcar v) ht)) (set-mcar! p (copy-value (mcar v) ht))
(set-mcdr! p (copy-value (mcdr v) ht)) (set-mcdr! p (copy-value (mcdr v) ht))
p)] p)]

145
collects/scribble/scheme.ss
View File

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

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

@ -1,7 +1,7 @@
#lang scribble/doc #lang scribble/doc
@require["mz.ss"] @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 Each of the built-in datatypes comes with a set of procedures for
manipulating members of the datatype. 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")] @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 This section describes the core syntax forms that apear in a fully
expanded expression, plus a many closely-related non-core forms. 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-id] and @scheme[val-id] is bound in all
@scheme[trans-expr]s and @scheme[val-expr]s.} @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]} @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 x 10)
(define (f y) f) (define (f y) f)
(define-struct s (x y))) (define-struct s (x y)))
(mz-require my-advanced-module) (mz-require 'my-advanced-module)
(parameterize ([current-namespace (module->namespace 'my-advanced-module)]) (parameterize ([current-namespace (module->namespace ''my-advanced-module)])
(eval #'(set! x 12)) (eval #'(set! x 12))
(eval #'(set! f 12)) (eval #'(set! f 12))
(eval #'(set! make-s 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 ;; this writes values to strings and compares the strings
;; to implements an equal? predicate that works for cyclic ;; to implements an equal? predicate that works for cyclic
;; structures. ;; structures.
@ -8,6 +10,8 @@
(begin (begin
(write v p) (write v p)
(get-output-string p)))) (get-output-string p))))
(define (x s)
(read (open-input-string s)))
(define (stest expect expression) (define (stest expect expression)
(test (test
(gs expect) (gs expect)
@ -18,14 +22,25 @@
(stest #(1 2) '(shared ([x (vector 1 2)]) x)) (stest #(1 2) '(shared ([x (vector 1 2)]) x))
(stest (box 1) '(shared ([x (box 1)]) x)) (stest (box 1) '(shared ([x (box 1)]) x))
(stest '(1) '(shared ([x (cons 1 null)]) 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 (x "#1=(#1# 1)") '(shared ([x (list x 1)]) x))
(stest '#2=#(#2# 1) '(shared ([x (vector x 1)]) x)) (stest (x "#2=#(#2# 1)") '(shared ([x (vector x 1)]) x))
(stest '#3=#&#3# '(shared ([x (box x)]) x)) (stest (x "#2=#(#2# 1)") '(shared ([x (vector-immutable x 1)]) x))
(stest '#4=(#4#) '(shared ([x (cons x null)]) x)) (stest (x "#3=#&#3#") '(shared ([x (box x)]) x))
(stest '#5=(1 . #5#) '(shared ([x (cons 1 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)) (define-struct s (a b))
(shared ([x (make-s 17 x)]) (shared ([x (make-s 17 x)])

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

@ -5,9 +5,14 @@
(require (lib "shared.ss")) (require (lib "shared.ss"))
(require (only-in mzscheme define-struct))
(load-relative "shared-tests.ss") (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") (load-relative "shared-tests.ss")
(report-errs) (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 == id_pref_file))
which_folder = CSIDL_APPDATA; which_folder = CSIDL_APPDATA;
else if (which == id_doc_dir) { else if (which == id_doc_dir) {
# ifndef CSIDL_MYDOCUMENTS # ifndef CSIDL_PERSONAL
# define CSIDL_PERSONAL 0x0005 # define CSIDL_PERSONAL 0x0005
# endif # endif
which_folder = CSIDL_PERSONAL; which_folder = CSIDL_PERSONAL;