diff --git a/collects/lang/private/teach-shared.ss b/collects/lang/private/teach-shared.ss new file mode 100644 index 0000000000..284b94ce7d --- /dev/null +++ b/collects/lang/private/teach-shared.ss @@ -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"))))) diff --git a/collects/lang/private/teach.ss b/collects/lang/private/teach.ss index 048bbf3d95..9526acc629 100644 --- a/collects/lang/private/teach.ss +++ b/collects/lang/private/teach.ss @@ -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))))))) diff --git a/collects/mzlib/private/shared-body.ss b/collects/mzlib/private/shared-body.ss index e241ff02f3..92ecd0948e 100644 --- a/collects/mzlib/private/shared-body.ss +++ b/collects/mzlib/private/shared-body.ss @@ -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,125 +52,208 @@ (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) - (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? - [(the-cons a d) - (syntax (cons undefined undefined))] - [(the-cons . _) - (bad "cons")] - [(list e ...) - (with-syntax ([(e ...) - (map (lambda (x) (syntax undefined)) - (syntax->list (syntax (e ...))))]) - (syntax (list e ...)))] - [(list . _) - (bad "list")] - [(box v) - (syntax (box undefined))] - [(box . _) - (bad "box")] - [(vector e ...) - (with-syntax ([(e ...) - (map (lambda (x) (syntax undefined)) - (syntax->list (syntax (e ...))))]) - (syntax (vector e ...)))] - [(vector . _) - (bad "vector")] - [(make-x . _) - (struct-decl-for (syntax make-x)) - (let ([decl (struct-decl-for (syntax make-x))] - [args (syntax->list (syntax _))]) - (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 - (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)] + (let loop ([expr expr]) + (define (bad n) + (raise-syntax-error + 'shared + (format "illegal use of ~a" n) + stx + expr)) + (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) + (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) (cons-elem x)) + (syntax->list (syntax (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)) + (syntax->list (syntax (e ...))))]) + (syntax (vector e ...)))] + [(vector . _) + (bad "vector")] + [(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))]) + (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 ...) (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) - (with-syntax ([name name]) - (syntax-case* expr (the-cons list box vector) same-special-id? - [(the-cons a d) - (syntax (begin - (set-car! name a) - (set-cdr! name d)))] - [(list e ...) - (with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))]) - (syntax (let ([lst name]) - (set-car! (list-tail lst n) e) - ...)))] - [(box v) - (syntax (set-box! name v))] - [(vector e ...) - (with-syntax ([(n ...) (gen-n (syntax->list (syntax (e ...))))]) - (syntax (let ([vec name]) - (vector-set! vec n e) - ...)))] - [(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))] + (let loop ([name name] [expr expr]) + (with-syntax ([name name]) + (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-mcar! name a) + (set-mcdr! name d)))] + [(list 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))]) + (syntax-case (reverse (list-ref decl 4)) () + [() + (syntax (void))] + [(setter ...) + (syntax (begin (setter name e) ...))]))] + [_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] ...) - finish-expr - ... - check-expr - ... - body1 - body - ...)))))]) + 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 + ...))))))]) diff --git a/collects/mzlib/shared.ss b/collects/mzlib/shared.ss index d71b2c4a12..c49edd48f5 100644 --- a/collects/mzlib/shared.ss +++ b/collects/mzlib/shared.ss @@ -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) +(provide shared) - (define undefined (letrec ([x x]) x)) - (require (rename mzscheme the-cons cons)) +(define undefined (letrec ([x x]) x)) +(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"))))) +(define-syntax shared + (lambda (stx) + (define make-check-cdr #f) + ;; Include the implementation. + ;; See private/shared-body.ss. + (include "private/shared-body.ss"))) diff --git a/collects/scheme/main.ss b/collects/scheme/main.ss index aebd7c43d3..65eb8841f2 100644 --- a/collects/scheme/main.ss +++ b/collects/scheme/main.ss @@ -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 diff --git a/collects/scheme/shared.ss b/collects/scheme/shared.ss new file mode 100644 index 0000000000..2e9994faa2 --- /dev/null +++ b/collects/scheme/shared.ss @@ -0,0 +1,4 @@ +#lang scheme/base + +(require mzlib/shared) +(provide shared) diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss index b77f49d356..fb2dc72364 100644 --- a/collects/scribble/eval.ss +++ b/collects/scribble/eval.ss @@ -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)] diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index 9eeb25a3d2..e73736a320 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -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,47 +644,82 @@ (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) - (+ 1 #;(string-length (format "~a" (vector-length v)))) - 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)]) - (cons i - (loop (+ col 1 (syntax-span i)) (cdr v))))))]) - (datum->syntax #f - (if (vector? v) - (short-list->vector v l) - l) - (list #f 1 col (+ 1 col) - (+ 2 - vec-sz - (if (zero? (length l)) - 0 - (sub1 (length l))) - (apply + (map syntax-span l)))))))] + (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))]) + (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 (do-syntax-ize (car v) col ht #f)]) + (cons i + (loop (+ col 1 (syntax-span i)) (cdr v))))))]) + (datum->syntax #f + (if (vector? v) + (short-list->vector v l) + l) + (list #f 1 col (+ 1 col) + (+ 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) - (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 - (cons a b) - (list #f 1 col (+ 1 col) - (+ 2 sep (syntax-span a) (syntax-span b)))))] + (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) + (+ 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) diff --git a/collects/scribblings/reference/data.scrbl b/collects/scribblings/reference/data.scrbl index cac5131e96..4d252592a1 100644 --- a/collects/scribblings/reference/data.scrbl +++ b/collects/scribblings/reference/data.scrbl @@ -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. diff --git a/collects/scribblings/reference/shared.scrbl b/collects/scribblings/reference/shared.scrbl new file mode 100644 index 0000000000..fe78fcee76 --- /dev/null +++ b/collects/scribblings/reference/shared.scrbl @@ -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) +]} + diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 5f210ec080..f9bd7032e3 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -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]} diff --git a/collects/tests/mzscheme/advanced.ss b/collects/tests/mzscheme/advanced.ss index 9087e2911c..3f32280130 100644 --- a/collects/tests/mzscheme/advanced.ss +++ b/collects/tests/mzscheme/advanced.ss @@ -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)) diff --git a/collects/tests/mzscheme/shared-tests.ss b/collects/tests/mzscheme/shared-tests.ss index 9c8aabcde3..0b0f671ef2 100644 --- a/collects/tests/mzscheme/shared-tests.ss +++ b/collects/tests/mzscheme/shared-tests.ss @@ -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=## '(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=##") '(shared ([x (box x)]) x)) +(stest (x "#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)]) diff --git a/collects/tests/mzscheme/shared.ss b/collects/tests/mzscheme/shared.ss index b924ef415d..64bb774132 100644 --- a/collects/tests/mzscheme/shared.ss +++ b/collects/tests/mzscheme/shared.ss @@ -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) diff --git a/src/mzscheme/src/file.c b/src/mzscheme/src/file.c index 78e8a911e9..fcb5a97bc6 100644 --- a/src/mzscheme/src/file.c +++ b/src/mzscheme/src/file.c @@ -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;