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

doc fixes

Browse Source 
svn: r7832
This commit is contained in:
Matthew Flatt 2007-11-25 19:48:41 +00:00
parent cebdb136fe
commit 5f312dcbde
13 changed files with 676 additions and 548 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/games/cards/cards.ss
View File

@ -5,7 +5,7 @@
"region.ss") "region.ss")
(provide table<%> card<%> (provide table<%> card<%>
region region struct:region
make-region make-region
region? region-x region-y region-w region-h region? region-x region-y region-w region-h
region-label region-callback region-interactive-callback region-label region-callback region-interactive-callback

469
collects/mzlib/private/serialize.ss Normal file
View File

@ -0,0 +1,469 @@
(module serialize scheme/base
(require syntax/modcollapse
"serialize-structs.ss")
;; This module implements the core serializer. The syntactic
;; `define-serializable-struct' layer is implemented separately
;; (and differently for old-style vs. new-style `define-struct').
(provide prop:serializable
make-serialize-info
make-deserialize-info
;; Checks whether a value is serializable:
serializable?
;; The two main routines:
serialize
deserialize)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; serialize
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (serializable? v)
(or (serializable-struct? v)
(boolean? v)
(null? v)
(number? v)
(char? v)
(symbol? v)
(string? v)
(path-for-some-system? v)
(bytes? v)
(vector? v)
(pair? v)
(mpair? v)
(hash-table? v)
(box? v)
(void? v)
(date? v)
(arity-at-least? v)))
;; If a module is dynamic-required through a path,
;; then it can cause simplified module paths to be paths;
;; keep the literal path, but marshal it to bytes.
(define (protect-path p)
(if (path? p)
(path->bytes p)
p))
(define (unprotect-path p)
(if (bytes? p)
(bytes->path p)
p))
(define (mod-to-id info mod-map cache)
(let ([deserialize-id (serialize-info-deserialize-id info)])
(hash-table-get
cache deserialize-id
(lambda ()
(let ([id
(let ([path+name
(cond
[(identifier? deserialize-id)
(let ([b (identifier-binding deserialize-id)])
(cons
(and (list? b)
(if (symbol? (caddr b))
(caddr b)
(protect-path
(collapse-module-path-index
(caddr b)
(build-path (serialize-info-dir info)
"here.ss")))))
(syntax-e deserialize-id)))]
[(symbol? deserialize-id)
(cons #f deserialize-id)]
[else
(cons
(if (symbol? (cdr deserialize-id))
(cdr deserialize-id)
(protect-path
(collapse-module-path-index
(cdr deserialize-id)
(build-path (serialize-info-dir info)
"here.ss"))))
(car deserialize-id))])])
(hash-table-get
mod-map path+name
(lambda ()
(let ([id (hash-table-count mod-map)])
(hash-table-put! mod-map path+name id)
id))))])
(hash-table-put! cache deserialize-id id)
id)))))
(define (is-mutable? o)
(or (and (or (mpair? o)
(box? o)
(vector? o)
(hash-table? o))
(not (immutable? o)))
(serializable-struct? o)))
;; Finds a mutable object among those that make the
;; current cycle.
(define (find-mutable v cycle-stack)
;; Walk back through cycle-stack to find something
;; mutable. If we get to v without anything being
;; mutable, then we're stuck.
(let ([o (car cycle-stack)])
(cond
[(eq? o v)
(error 'serialize "cannot serialize cycle of immutable values: ~e" v)]
[(is-mutable? o)
o]
[else
(find-mutable v (cdr cycle-stack))])))
(define (share-id share cycle)
(+ (hash-table-count share)
(hash-table-count cycle)))
;; Traverses v to find cycles and charing. Shared
;; object go in the `shared' table, and cycle-breakers go in
;; `cycle'. In each case, the object is mapped to a number that is
;; incremented as shared/cycle objects are discovered, so
;; when the objects are deserialized, build them in reverse
;; order.
(define (find-cycles-and-sharing v cycle share)
(let ([tmp-cycle (make-hash-table)] ;; candidates for sharing
[tmp-share (make-hash-table)] ;; candidates for cycles
[cycle-stack null]) ;; same as in tmpcycle, but for finding mutable
(let loop ([v v])
(cond
[(or (boolean? v)
(number? v)
(char? v)
(symbol? v)
(null? v)
(void? v))
(void)]
[(hash-table-get cycle v (lambda () #f))
;; We already know that this value is
;; part of a cycle
(void)]
[(hash-table-get tmp-cycle v (lambda () #f))
;; We've just learned that this value is
;; part of a cycle.
(let ([mut-v (if (is-mutable? v)
v
(find-mutable v cycle-stack))])
(hash-table-put! cycle mut-v (share-id share cycle))
(unless (eq? mut-v v)
;; This value is potentially shared
(hash-table-put! share v (share-id share cycle))))]
[(hash-table-get share v (lambda () #f))
;; We already know that this value is shared
(void)]
[(hash-table-get tmp-share v (lambda () #f))
;; We've just learned that this value is
;; shared
(hash-table-put! share v (share-id share cycle))]
[else
(hash-table-put! tmp-share v #t)
(hash-table-put! tmp-cycle v #t)
(set! cycle-stack (cons v cycle-stack))
(cond
[(serializable-struct? v)
(let ([info (serializable-info v)])
(for-each loop (vector->list ((serialize-info-vectorizer info) v))))]
[(or (string? v)
(bytes? v)
(path-for-some-system? v))
;; No sub-structure
(void)]
[(vector? v)
(for-each loop (vector->list v))]
[(pair? v)
(loop (car v))
(loop (cdr v))]
[(mpair? v)
(loop (mcar v))
(loop (mcdr v))]
[(box? v)
(loop (unbox v))]
[(date? v)
(for-each loop (cdr (vector->list (struct->vector v))))]
[(hash-table? v)
(hash-table-for-each v (lambda (k v)
(loop k)
(loop v)))]
[(arity-at-least? v)
(loop (arity-at-least-value v))]
[else (raise-type-error
'serialize
"serializable object"
v)])
;; No more possibility for this object in
;; a cycle:
(hash-table-remove! tmp-cycle v)
(set! cycle-stack (cdr cycle-stack))]))))
(define (serialize-one v share check-share? mod-map mod-map-cache)
(define ((serial check-share?) v)
(cond
[(or (boolean? v)
(number? v)
(char? v)
(symbol? v)
(null? v))
v]
[(void? v)
'(void)]
[(and check-share?
(hash-table-get share v (lambda () #f)))
=> (lambda (v) (cons '? v))]
[(and (or (string? v)
(bytes? v))
(immutable? v))
v]
[(serializable-struct? v)
(let ([info (serializable-info v)])
(cons (mod-to-id info mod-map mod-map-cache)
(map (serial #t)
(vector->list
((serialize-info-vectorizer info) v)))))]
[(or (string? v)
(bytes? v))
(cons 'u v)]
[(path-for-some-system? v)
(list* 'p+ (path->bytes v) (path-convention-type v))]
[(vector? v)
(cons (if (immutable? v) 'v 'v!)
(map (serial #t) (vector->list v)))]
[(pair? v)
(let ([loop (serial #t)])
(cons 'c
(cons (loop (car v))
(loop (cdr v)))))]
[(mpair? v)
(let ([loop (serial #t)])
(cons 'm
(cons (loop (mcar v))
(loop (mcdr v)))))]
[(box? v)
(cons (if (immutable? v) 'b 'b!)
((serial #t) (unbox v)))]
[(hash-table? v)
(list* 'h
(if (immutable? v) '- '!)
(append
(if (hash-table? v 'equal) '(equal) null)
(if (hash-table? v 'weak) '(weak) null))
(let ([loop (serial #t)])
(hash-table-map v (lambda (k v)
(cons (loop k)
(loop v))))))]
[(date? v)
(cons 'date
(map (serial #t) (cdr (vector->list (struct->vector v)))))]
[(arity-at-least? v)
(cons 'arity-at-least
((serial #t) (arity-at-least-value v)))]
[else (error 'serialize "shouldn't get here")]))
((serial check-share?) v))
(define (serial-shell v mod-map mod-map-cache)
(cond
[(serializable-struct? v)
(let ([info (serializable-info v)])
(mod-to-id info mod-map mod-map-cache))]
[(vector? v)
(cons 'v (vector-length v))]
[(mpair? v)
'm]
[(box? v)
'b]
[(hash-table? v)
(cons 'h (append
(if (hash-table? v 'equal) '(equal) null)
(if (hash-table? v 'weak) '(weak) null)))]))
(define (serialize v)
(let ([mod-map (make-hash-table)]
[mod-map-cache (make-hash-table 'equal)]
[share (make-hash-table)]
[cycle (make-hash-table)])
;; First, traverse V to find cycles and sharing
(find-cycles-and-sharing v cycle share)
;; To simplify, all add the cycle records to shared.
;; (but keep cycle info, too).
(hash-table-for-each cycle
(lambda (k v)
(hash-table-put! share k v)))
(let ([ordered (map car (sort (hash-table-map share cons)
(lambda (a b) (< (cdr a) (cdr b)))))])
(let ([serializeds (map (lambda (v)
(if (hash-table-get cycle v (lambda () #f))
;; Box indicates cycle record allocation
;; followed by normal serialization
(box (serial-shell v mod-map mod-map-cache))
;; Otherwise, normal serialization
(serialize-one v share #f mod-map mod-map-cache)))
ordered)]
[fixups (hash-table-map
cycle
(lambda (v n)
(cons n
(serialize-one v share #f mod-map mod-map-cache))))]
[main-serialized (serialize-one v share #t mod-map mod-map-cache)]
[mod-map-l (map car (sort (hash-table-map mod-map cons)
(lambda (a b) (< (cdr a) (cdr b)))))])
(list '(1) ;; serialization-format version
(hash-table-count mod-map)
mod-map-l
(length serializeds)
serializeds
fixups
main-serialized)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; deserialize
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (deserialize-one v share mod-map)
(let loop ([v v])
(cond
[(or (boolean? v)
(number? v)
(char? v)
(symbol? v)
(null? v))
v]
[(string? v)
(string->immutable-string v)]
[(bytes? v)
(bytes->immutable-bytes v)]
[(number? (car v))
;; Struct instance:
(let ([info (vector-ref mod-map (car v))])
(apply (deserialize-info-maker info) (map loop (cdr v))))]
[else
(case (car v)
[(?) (vector-ref share (cdr v))]
[(void) (void)]
[(u) (let ([x (cdr v)])
(cond
[(string? x) (string-copy x)]
[(bytes? x) (bytes-copy x)]))]
[(p) (bytes->path (cdr v))]
[(p+) (bytes->path (cadr v) (cddr v))]
[(c) (cons (loop (cadr v)) (loop (cddr v)))]
[(c!) (cons (loop (cadr v)) (loop (cddr v)))]
[(m) (mcons (loop (cadr v)) (loop (cddr v)))]
[(v) (apply vector-immutable (map loop (cdr v)))]
[(v!) (list->vector (map loop (cdr v)))]
[(b) (box-immutable (loop (cdr v)))]
[(b!) (box (loop (cdr v)))]
[(h) (let ([al (map (lambda (p)
(cons (loop (car p))
(loop (cdr p))))
(cdddr v))])
(if (eq? '! (cadr v))
(let ([ht (apply make-hash-table (caddr v))])
(for-each (lambda (p)
(hash-table-put! ht (car p) (cdr p)))
al)
ht)
(apply make-immutable-hash-table al (caddr v))))]
[(date) (apply make-date (map loop (cdr v)))]
[(arity-at-least) (make-arity-at-least (loop (cdr v)))]
[else (error 'serialize "ill-formed serialization")])])))
(define (deserial-shell v mod-map fixup n)
(cond
[(number? v)
;; Struct instance
(let* ([info (vector-ref mod-map v)])
(let-values ([(obj fix) ((deserialize-info-cycle-maker info))])
(vector-set! fixup n fix)
obj))]
[(pair? v)
(case (car v)
[(v)
;; Vector
(let* ([m (cdr v)]
[v0 (make-vector m #f)])
(vector-set! fixup n (lambda (v)
(let loop ([i m])
(unless (zero? i)
(let ([i (sub1 i)])
(vector-set! v0 i (vector-ref v i))
(loop i))))))
v0)]
[(h)
;; Hash table
(let ([ht0 (make-hash-table)])
(vector-set! fixup n (lambda (ht)
(hash-table-for-each
ht
(lambda (k v)
(hash-table-put! ht0 k v)))))
ht0)])]
[else
(case v
[(c)
(let ([c (cons #f #f)])
(vector-set! fixup n (lambda (p)
(error 'deserialize "cannot restore pair in cycle")))
c)]
[(m)
(let ([p0 (mcons #f #f)])
(vector-set! fixup n (lambda (p)
(set-mcar! p0 (mcar p))
(set-mcdr! p0 (mcdr p))))
p0)]
[(b)
(let ([b0 (box #f)])
(vector-set! fixup n (lambda (b)
(set-box! b0 (unbox b))))
b0)]
[(date)
(error 'deserialize "cannot restore date in cycle")]
[(arity-at-least)
(error 'deserialize "cannot restore arity-at-least in cycle")])]))
(define (deserialize l)
(let-values ([(vers l)
(if (pair? (car l))
(values (caar l) (cdr l))
(values 0 l))])
(let ([mod-map (make-vector (list-ref l 0))]
[mod-map-l (list-ref l 1)]
[share-n (list-ref l 2)]
[shares (list-ref l 3)]
[fixups (list-ref l 4)]
[result (list-ref l 5)])
;; Load constructor mapping
(let loop ([n 0][l mod-map-l])
(unless (null? l)
(let* ([path+name (car l)]
[des (if (car path+name)
(dynamic-require (unprotect-path (car path+name))
(cdr path+name))
(namespace-variable-value (cdr path+name)))])
;; Register maker and struct type:
(vector-set! mod-map n des))
(loop (add1 n) (cdr l))))
;; Create vector for sharing:
(let ([share (make-vector share-n #f)]
[fixup (make-vector share-n #f)])
;; Deserialize into sharing array:
(let loop ([n 0][l shares])
(unless (= n share-n)
(vector-set! share n
(let ([v (car l)])
(if (box? v)
(deserial-shell (unbox v) mod-map fixup n)
(deserialize-one v share mod-map))))
(loop (add1 n) (cdr l))))
;; Fixup shell for graphs
(for-each (lambda (n+v)
(let ([v (deserialize-one (cdr n+v) share mod-map)])
((vector-ref fixup (car n+v)) v)))
fixups)
;; Deserialize final result. (If there's no sharing, then
;; all the work is actually here.)
(deserialize-one result share mod-map))))))

475
collects/mzlib/serialize.ss
View File

@ -3,27 +3,22 @@
(require (lib "modcollapse.ss" "syntax") (require (lib "modcollapse.ss" "syntax")
(lib "etc.ss") (lib "etc.ss")
(lib "list.ss") (lib "list.ss")
"private/serialize-structs.ss") ;; core [de]serializer:
"private/serialize.ss")
(provide define-serializable-struct (provide define-serializable-struct
define-serializable-struct/versions define-serializable-struct/versions
;; For implementors of other `define-struct'-like forms: ;; core [de]serializer:
prop:serializable (all-from "private/serialize.ss"))
make-serialize-info
make-deserialize-info
;; Checks whether a value is seriliazable:
serializable?
;; The two main routines:
serialize
deserialize)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; define-serializable-struct ;; define-serializable-struct
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-values (prop:internal-deserialize internal-deserialize? internal-deserialize-info)
(make-struct-type-property 'internal-deserialize #f))
;; generate-struct-declaration wants a function to generate the actual ;; generate-struct-declaration wants a function to generate the actual
;; call to `make-struct-type'. This is where we insert the serializable property. ;; call to `make-struct-type'. This is where we insert the serializable property.
(define-for-syntax (make-make-make-struct-type inspector+deserializer-stx) (define-for-syntax (make-make-make-struct-type inspector+deserializer-stx)
@ -400,458 +395,4 @@
(main stx)) (main stx))
(lambda (stx) (lambda (stx)
(context-check stx) (context-check stx)
(main/versions stx))))) (main/versions stx))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; serialize
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (serializable? v)
(or (serializable-struct? v)
(boolean? v)
(null? v)
(number? v)
(char? v)
(symbol? v)
(string? v)
(path-for-some-system? v)
(bytes? v)
(vector? v)
(pair? v)
(mpair? v)
(hash-table? v)
(box? v)
(void? v)
(date? v)
(arity-at-least? v)))
;; If a module is dynamic-required through a path,
;; then it can cause simplified module paths to be paths;
;; keep the literal path, but marshal it to bytes.
(define (protect-path p)
(if (path? p)
(path->bytes p)
p))
(define (unprotect-path p)
(if (bytes? p)
(bytes->path p)
p))
(define (mod-to-id info mod-map cache)
(let ([deserialize-id (serialize-info-deserialize-id info)])
(hash-table-get
cache deserialize-id
(lambda ()
(let ([id
(let ([path+name
(cond
[(identifier? deserialize-id)
(let ([b (identifier-binding deserialize-id)])
(cons
(and (list? b)
(if (symbol? (caddr b))
(caddr b)
(protect-path
(collapse-module-path-index
(caddr b)
(build-path (serialize-info-dir info)
"here.ss")))))
(syntax-e deserialize-id)))]
[(symbol? deserialize-id)
(cons #f deserialize-id)]
[else
(cons
(if (symbol? (cdr deserialize-id))
(cdr deserialize-id)
(protect-path
(collapse-module-path-index
(cdr deserialize-id)
(build-path (serialize-info-dir info)
"here.ss"))))
(car deserialize-id))])])
(hash-table-get
mod-map path+name
(lambda ()
(let ([id (hash-table-count mod-map)])
(hash-table-put! mod-map path+name id)
id))))])
(hash-table-put! cache deserialize-id id)
id)))))
(define (is-mutable? o)
(or (and (or (mpair? o)
(box? o)
(vector? o)
(hash-table? o))
(not (immutable? o)))
(serializable-struct? o)))
;; Finds a mutable object among those that make the
;; current cycle.
(define (find-mutable v cycle-stack)
;; Walk back through cycle-stack to find something
;; mutable. If we get to v without anything being
;; mutable, then we're stuck.
(let ([o (car cycle-stack)])
(cond
[(eq? o v)
(error 'serialize "cannot serialize cycle of immutable values: ~e" v)]
[(is-mutable? o)
o]
[else
(find-mutable v (cdr cycle-stack))])))
(define (share-id share cycle)
(+ (hash-table-count share)
(hash-table-count cycle)))
;; Traverses v to find cycles and charing. Shared
;; object go in the `shared' table, and cycle-breakers go in
;; `cycle'. In each case, the object is mapped to a number that is
;; incremented as shared/cycle objects are discovered, so
;; when the objects are deserialized, build them in reverse
;; order.
(define (find-cycles-and-sharing v cycle share)
(let ([tmp-cycle (make-hash-table)] ;; candidates for sharing
[tmp-share (make-hash-table)] ;; candidates for cycles
[cycle-stack null]) ;; same as in tmpcycle, but for finding mutable
(let loop ([v v])
(cond
[(or (boolean? v)
(number? v)
(char? v)
(symbol? v)
(null? v)
(void? v))
(void)]
[(hash-table-get cycle v (lambda () #f))
;; We already know that this value is
;; part of a cycle
(void)]
[(hash-table-get tmp-cycle v (lambda () #f))
;; We've just learned that this value is
;; part of a cycle.
(let ([mut-v (if (is-mutable? v)
v
(find-mutable v cycle-stack))])
(hash-table-put! cycle mut-v (share-id share cycle))
(unless (eq? mut-v v)
;; This value is potentially shared
(hash-table-put! share v (share-id share cycle))))]
[(hash-table-get share v (lambda () #f))
;; We already know that this value is shared
(void)]
[(hash-table-get tmp-share v (lambda () #f))
;; We've just learned that this value is
;; shared
(hash-table-put! share v (share-id share cycle))]
[else
(hash-table-put! tmp-share v #t)
(hash-table-put! tmp-cycle v #t)
(set! cycle-stack (cons v cycle-stack))
(cond
[(serializable-struct? v)
(let ([info (serializable-info v)])
(for-each loop (vector->list ((serialize-info-vectorizer info) v))))]
[(or (string? v)
(bytes? v)
(path-for-some-system? v))
;; No sub-structure
(void)]
[(vector? v)
(for-each loop (vector->list v))]
[(pair? v)
(loop (car v))
(loop (cdr v))]
[(mpair? v)
(loop (mcar v))
(loop (mcdr v))]
[(box? v)
(loop (unbox v))]
[(date? v)
(for-each loop (cdr (vector->list (struct->vector v))))]
[(hash-table? v)
(hash-table-for-each v (lambda (k v)
(loop k)
(loop v)))]
[(arity-at-least? v)
(loop (arity-at-least-value v))]
[else (raise-type-error
'serialize
"serializable object"
v)])
;; No more possibility for this object in
;; a cycle:
(hash-table-remove! tmp-cycle v)
(set! cycle-stack (cdr cycle-stack))]))))
(define (serialize-one v share check-share? mod-map mod-map-cache)
(define ((serial check-share?) v)
(cond
[(or (boolean? v)
(number? v)
(char? v)
(symbol? v)
(null? v))
v]
[(void? v)
'(void)]
[(and check-share?
(hash-table-get share v (lambda () #f)))
=> (lambda (v) (cons '? v))]
[(and (or (string? v)
(bytes? v))
(immutable? v))
v]
[(serializable-struct? v)
(let ([info (serializable-info v)])
(cons (mod-to-id info mod-map mod-map-cache)
(map (serial #t)
(vector->list
((serialize-info-vectorizer info) v)))))]
[(or (string? v)
(bytes? v))
(cons 'u v)]
[(path-for-some-system? v)
(list* 'p+ (path->bytes v) (path-convention-type v))]
[(vector? v)
(cons (if (immutable? v) 'v 'v!)
(map (serial #t) (vector->list v)))]
[(pair? v)
(let ([loop (serial #t)])
(cons 'c
(cons (loop (car v))
(loop (cdr v)))))]
[(mpair? v)
(let ([loop (serial #t)])
(cons 'm
(cons (loop (mcar v))
(loop (mcdr v)))))]
[(box? v)
(cons (if (immutable? v) 'b 'b!)
((serial #t) (unbox v)))]
[(hash-table? v)
(list* 'h
(if (immutable? v) '- '!)
(append
(if (hash-table? v 'equal) '(equal) null)
(if (hash-table? v 'weak) '(weak) null))
(let ([loop (serial #t)])
(hash-table-map v (lambda (k v)
(cons (loop k)
(loop v))))))]
[(date? v)
(cons 'date
(map (serial #t) (cdr (vector->list (struct->vector v)))))]
[(arity-at-least? v)
(cons 'arity-at-least
((serial #t) (arity-at-least-value v)))]
[else (error 'serialize "shouldn't get here")]))
((serial check-share?) v))
(define (serial-shell v mod-map mod-map-cache)
(cond
[(serializable-struct? v)
(let ([info (serializable-info v)])
(mod-to-id info mod-map mod-map-cache))]
[(vector? v)
(cons 'v (vector-length v))]
[(mpair? v)
'm]
[(box? v)
'b]
[(hash-table? v)
(cons 'h (append
(if (hash-table? v 'equal) '(equal) null)
(if (hash-table? v 'weak) '(weak) null)))]))
(define (serialize v)
(let ([mod-map (make-hash-table)]
[mod-map-cache (make-hash-table 'equal)]
[share (make-hash-table)]
[cycle (make-hash-table)])
;; First, traverse V to find cycles and sharing
(find-cycles-and-sharing v cycle share)
;; To simplify, all add the cycle records to shared.
;; (but keep cycle info, too).
(hash-table-for-each cycle
(lambda (k v)
(hash-table-put! share k v)))
(let ([ordered (map car (sort (hash-table-map share cons)
(lambda (a b) (< (cdr a) (cdr b)))))])
(let ([serializeds (map (lambda (v)
(if (hash-table-get cycle v (lambda () #f))
;; Box indicates cycle record allocation
;; followed by normal serialization
(box (serial-shell v mod-map mod-map-cache))
;; Otherwise, normal serialization
(serialize-one v share #f mod-map mod-map-cache)))
ordered)]
[fixups (hash-table-map
cycle
(lambda (v n)
(cons n
(serialize-one v share #f mod-map mod-map-cache))))]
[main-serialized (serialize-one v share #t mod-map mod-map-cache)]
[mod-map-l (map car (sort (hash-table-map mod-map cons)
(lambda (a b) (< (cdr a) (cdr b)))))])
(list '(1) ;; serialization-format version
(hash-table-count mod-map)
mod-map-l
(length serializeds)
serializeds
fixups
main-serialized)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; deserialize
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-values (prop:internal-deserialize internal-deserialize? internal-deserialize-info)
(make-struct-type-property 'internal-deserialize #f))
(define (deserialize-one v share mod-map)
(let loop ([v v])
(cond
[(or (boolean? v)
(number? v)
(char? v)
(symbol? v)
(null? v))
v]
[(string? v)
(string->immutable-string v)]
[(bytes? v)
(bytes->immutable-bytes v)]
[(number? (car v))
;; Struct instance:
(let ([info (vector-ref mod-map (car v))])
(apply (deserialize-info-maker info) (map loop (cdr v))))]
[else
(case (car v)
[(?) (vector-ref share (cdr v))]
[(void) (void)]
[(u) (let ([x (cdr v)])
(cond
[(string? x) (string-copy x)]
[(bytes? x) (bytes-copy x)]))]
[(p) (bytes->path (cdr v))]
[(p+) (bytes->path (cadr v) (cddr v))]
[(c) (cons (loop (cadr v)) (loop (cddr v)))]
[(c!) (cons (loop (cadr v)) (loop (cddr v)))]
[(m) (mcons (loop (cadr v)) (loop (cddr v)))]
[(v) (apply vector-immutable (map loop (cdr v)))]
[(v!) (list->vector (map loop (cdr v)))]
[(b) (box-immutable (loop (cdr v)))]
[(b!) (box (loop (cdr v)))]
[(h) (let ([al (map (lambda (p)
(cons (loop (car p))
(loop (cdr p))))
(cdddr v))])
(if (eq? '! (cadr v))
(let ([ht (apply make-hash-table (caddr v))])
(for-each (lambda (p)
(hash-table-put! ht (car p) (cdr p)))
al)
ht)
(apply make-immutable-hash-table al (caddr v))))]
[(date) (apply make-date (map loop (cdr v)))]
[(arity-at-least) (make-arity-at-least (loop (cdr v)))]
[else (error 'serialize "ill-formed serialization")])])))
(define (deserial-shell v mod-map fixup n)
(cond
[(number? v)
;; Struct instance
(let* ([info (vector-ref mod-map v)])
(let-values ([(obj fix) ((deserialize-info-cycle-maker info))])
(vector-set! fixup n fix)
obj))]
[(pair? v)
(case (car v)
[(v)
;; Vector
(let* ([m (cdr v)]
[v0 (make-vector m #f)])
(vector-set! fixup n (lambda (v)
(let loop ([i m])
(unless (zero? i)
(let ([i (sub1 i)])
(vector-set! v0 i (vector-ref v i))
(loop i))))))
v0)]
[(h)
;; Hash table
(let ([ht0 (make-hash-table)])
(vector-set! fixup n (lambda (ht)
(hash-table-for-each
ht
(lambda (k v)
(hash-table-put! ht0 k v)))))
ht0)])]
[else
(case v
[(c)
(let ([c (cons #f #f)])
(vector-set! fixup n (lambda (p)
(error 'deserialize "cannot restore pair in cycle")))
c)]
[(m)
(let ([p0 (mcons #f #f)])
(vector-set! fixup n (lambda (p)
(set-mcar! p0 (mcar p))
(set-mcdr! p0 (mcdr p))))
p0)]
[(b)
(let ([b0 (box #f)])
(vector-set! fixup n (lambda (b)
(set-box! b0 (unbox b))))
b0)]
[(date)
(error 'deserialize "cannot restore date in cycle")]
[(arity-at-least)
(error 'deserialize "cannot restore arity-at-least in cycle")])]))
(define (deserialize l)
(let-values ([(vers l)
(if (pair? (car l))
(values (caar l) (cdr l))
(values 0 l))])
(let ([mod-map (make-vector (list-ref l 0))]
[mod-map-l (list-ref l 1)]
[share-n (list-ref l 2)]
[shares (list-ref l 3)]
[fixups (list-ref l 4)]
[result (list-ref l 5)])
;; Load constructor mapping
(let loop ([n 0][l mod-map-l])
(unless (null? l)
(let* ([path+name (car l)]
[des (if (car path+name)
(dynamic-require (unprotect-path (car path+name))
(cdr path+name))
(namespace-variable-value (cdr path+name)))])
;; Register maker and struct type:
(vector-set! mod-map n des))
(loop (add1 n) (cdr l))))
;; Create vector for sharing:
(let ([share (make-vector share-n #f)]
[fixup (make-vector share-n #f)])
;; Deserialize into sharing array:
(let loop ([n 0][l shares])
(unless (= n share-n)
(vector-set! share n
(let ([v (car l)])
(if (box? v)
(deserial-shell (unbox v) mod-map fixup n)
(deserialize-one v share mod-map))))
(loop (add1 n) (cdr l))))
;; Fixup shell for graphs
(for-each (lambda (n+v)
(let ([v (deserialize-one (cdr n+v) share mod-map)])
((vector-ref fixup (car n+v)) v)))
fixups)
;; Deserialize final result. (If there's no sharing, then
;; all the work is actually here.)
(deserialize-one result share mod-map))))))

2
collects/scribblings/gui/editor-overview.scrbl
View File

@ -429,7 +429,7 @@ Snip class objects can be added to the eventspace-specific
If a snip class's name is of the form @scheme["(lib ...)"], then the If a snip class's name is of the form @scheme["(lib ...)"], then the
snip class implementation can be loaded on demand. The name is parsed snip class implementation can be loaded on demand. The name is parsed
using @scheme[read]; if the result has the form @scheme[(libKW string using @scheme[read]; if the result has the form @scheme[(lib _string
...)], then it is supplied to @scheme[dynamic-require] along with ...)], then it is supplied to @scheme[dynamic-require] along with
@scheme['snip-class]. If the result is a @scheme[snip-class%] object, @scheme['snip-class]. If the result is a @scheme[snip-class%] object,
it is inserted into the current eventspace's snip class list, and it is inserted into the current eventspace's snip class list, and

5
collects/scribblings/gui/snip-class.scrbl
View File

@ -47,7 +47,10 @@ To define a class of snips that can be saved or cut-and-pasted:
@itemize{ @itemize{
@item{Create an instance of @scheme[snip-class%], implementing the @item{Create an instance of @scheme[snip-class%], implementing the
@method[snip-class% read] method.} @method[snip-class% read] method. Export the
@scheme[snip-class%] instance as @scheme[snip-class] from a
module, and use a classname of the form @scheme["(lib ...)"] as
described in @|snipclassdiscuss|.}
@item{For each instance of the snip class, set the snip's class object @item{For each instance of the snip class, set the snip's class object
with @method[snip% set-snipclass].} with @method[snip% set-snipclass].}

6
collects/scribblings/reference/networking.scrbl
View File

@ -8,6 +8,9 @@
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "tcp"]{TCP} @section[#:tag "tcp"]{TCP}
@declare-exporting[scheme/tcp]
@note-lib[scheme/tcp]
For information about TCP in general, see @italic{TCP/IP Illustrated, For information about TCP in general, see @italic{TCP/IP Illustrated,
Volume 1} by W. Richard Stevens. Volume 1} by W. Richard Stevens.
@ -253,6 +256,9 @@ Returns @scheme[#t] if @scheme[v] is a port returned by
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "udp"]{UDP} @section[#:tag "udp"]{UDP}
@declare-exporting[scheme/udp]
@note-lib[scheme/udp]
For information about UDP in general, see @italic{TCP/IP Illustrated, For information about UDP in general, see @italic{TCP/IP Illustrated,
Volume 1} by W. Richard Stevens. Volume 1} by W. Richard Stevens.

3
collects/scribblings/reference/struct.scrbl
View File

@ -424,6 +424,9 @@ imported structure type, in which case the user is expected to know
the set of fields that are listed in the signature for the structure the set of fields that are listed in the signature for the structure
type. type.
@declare-exporting[scheme/struct-info scheme]
@note-lib-only[scheme/struct-info]
@defproc[(struct-info? [v any/c]) boolean?]{ @defproc[(struct-info? [v any/c]) boolean?]{
Returns @scheme[#f] if @scheme[v] is either a six-element list with Returns @scheme[#f] if @scheme[v] is either a six-element list with

185
collects/scribblings/reference/subprocess.scrbl
View File

@ -1,29 +1,42 @@
#lang scribble/doc #lang scribble/doc
@require["mz.ss"] @require["mz.ss"
(for-label scheme/system)]
@title[#:tag "subprocess"]{Processes} @title[#:tag "subprocess"]{Processes}
@defproc[(subprocess [stdout (or/c output-port? false/c)] @defproc*[([(subprocess [stdout (or/c output-port? false/c)]
[stdin (or/c input-port? false/c)] [stdin (or/c input-port? false/c)]
[stderr (or/c output-port? false/c)] [stderr (or/c output-port? false/c)]
[command path-string?] [command path-string?]
[arg string?] ...) [arg string?] ...)
(values subprocess? (values subprocess?
(or/c input-port? false/c) (or/c input-port? false/c)
(or/c output-port? false/c) (or/c output-port? false/c)
(or/c input-port? false/c))]{ (or/c input-port? false/c))]
[(subprocess [stdout (or/c output-port? false/c)]
[stdin (or/c input-port? false/c)]
[stderr (or/c output-port? false/c)]
[command path-string?]
[exact (one-of/c 'exact)]
[arg string?])
(values subprocess?
(or/c input-port? false/c)
(or/c output-port? false/c)
(or/c input-port? false/c))])]{
Creates a new process in the underlying operating system to execute Creates a new process in the underlying operating system to execute
@scheme[command] asynchronously. The @scheme[command] argument is a @scheme[command] asynchronously. See also @scheme[system] and
path to a program executable, and the @scheme[arg]s are command-line @scheme[process] from @schememodname[scheme/system].
arguments for the program. Under Unix and Mac OS X, command-line
arguments are passed as byte strings using the current locale's
encoding (see @secref["encodings"]).
Under Windows, the first @scheme[arg] can be @indexed-scheme['exact], The @scheme[command] argument is a path to a program executable, and
which triggers a Windows-specific hack: the second @scheme[arg] is the @scheme[arg]s are command-line arguments for the program. Under
used exactly as the command-line for the subprocess, and no additional Unix and Mac OS X, command-line arguments are passed as byte strings
@scheme[arg]s can be supplied. Otherwise, a command-line string is using the current locale's encoding (see @secref["encodings"]).
Under Windows, the first @scheme[arg] can be replaced
@indexed-scheme['exact], which triggers a Windows-specific behavior:
the sole @scheme[arg] is used exactly as the command-line for the
subprocess. Otherwise, under Windows, a command-line string is
constructed from @scheme[command] and @scheme[arg] so that a typical constructed from @scheme[command] and @scheme[arg] so that a typical
Windows console application can parse it back to an array of Windows console application can parse it back to an array of
arguments. If @scheme['exact] is provided on a non-Windows platform, arguments. If @scheme['exact] is provided on a non-Windows platform,
@ -206,3 +219,137 @@ In future versions of Scheme, the result may be a subprocess value if
the operating system did returns a process handle (but if a subprocess the operating system did returns a process handle (but if a subprocess
value is returned, its process ID will be @scheme[0] instead of the value is returned, its process ID will be @scheme[0] instead of the
real process ID). real process ID).
@; ----------------------------------------------------------------------
@section{Simple Subprocesses}
@declare-exporting[scheme/system]
@note-lib-only[scheme/system]
@defproc[(system [command string?]) boolean?]{
Executes a Unix, Mac OS X, or Windows shell command synchronously
(i.e., the call to @scheme[system] does not return until the
subprocess has ended). The @scheme[command] argument is a string
containing no nul characters. If the command succeeds, the return
value is @scheme[#t], @scheme[#f] otherwise.}
@defproc*[([(system* [command path-string?][arg string?] ...) boolean?]
[(system* [command path-string?][exact (one-of/c 'exact)][arg string?]) boolean?])]{
Like @scheme[system], except that @scheme[command] is a filename that
is executed directly (instead of through a shell command), and the
@scheme[arg]s are the arguments. The executed file is passed the
specified string arguments (which must contain no nul
characters).
Under Windows, the first argument after @scheme[command] can be
@scheme['exact], and the final @scheme[arg] is a complete command
line. See @scheme[subprocess] for details.}
@defproc[(system/exit-code [command string?]) (integer-in 0 255)]{
Like @scheme[system], except that the result is the exit code returned
by the subprocess. A @scheme[0] result normally indicates success.}
@defproc*[([(system*/exit-code [command path-string?][arg string?] ...) (integer-in 0 255)]
[(system*/exit-code [command path-string?][exact (one-of/c 'exact)][arg string?]) (integer-in 0 255)])]{
Like @scheme[system*], but returns the exit code like
@scheme[system/exit-code].}
@defproc[(process [command string?])
(list input-port?
output-port?
nonnegative-exact-integer?
input-port?
((one-of/c 'status 'wait 'interrupt 'kill) . -> . any))]{
Executes a shell command asynchronously. The result is a list of five values:
@itemize{
@item{an input port piped from the subprocess's standard output,}
@item{an output port piped to the subprocess standard input,}
@item{the system process id of the subprocess,}
@item{an input port piped from the subprocess's standard
error, and}
@item{a procedure of one argument, either @scheme['status],
@scheme['wait], @scheme['interrupt], or @scheme['kill]:
@itemize{
@item{@scheme['status] returns the status of the subprocess as one
of @scheme['running], @scheme['done-ok], or
@scheme['done-error].}
@item{@scheme['exit-code] returns the integer exit code of the
subprocess or @scheme[#f] if it is still running.}
@item{@scheme['wait] blocks execution in the current thread until
the subprocess has completed.}
@item{@scheme['interrupt] sends the subprocess an interrupt signal
under @|AllUnix|, and takes no action under Windows. The result is
@|void-const|.}
@item{@scheme['kill] terminates the subprocess and returns @|void-const|.}
}}
}
@bold{Important:} All three ports returned from @scheme[process] must
be explicitly closed with @scheme[close-input-port] or
@scheme[close-output-port].}
@defproc*[([(process* [command path-string?][arg string?] ...) list?]
[(process* [command path-string?][exact (one-of/c 'exact)][arg string?]) list?])]{
Like @scheme[process], except that @scheme[command] is a filename that
is executed directly, and the @scheme[arg]s are the arguments. Under
Windows, as for @scheme[system*], the first @scheme[arg] can be
replaced with @scheme['exact].}
@defproc[(process/ports [out (or/c false/c output-port?)]
[in (or/c false/c input-port?)]
[error-out (or/c false/c output-port?)]
[command string?])
list?]{
Like @scheme[process], except that @scheme[out] is used for the
process's standard output, @scheme[in] is used for the process's
standard input, and @scheme[error-out] is used for the process's
standard error. Any of the ports can be @scheme[#f], in which case a
system pipe is created and returned, as in @scheme[process]. For each
port that is provided, no pipe is created, and the corresponding value
in the returned list is @scheme[#f].}
@defproc*[([(process*/ports [out (or/c false/c output-port?)]
[in (or/c false/c input-port?)]
[error-out (or/c false/c output-port?)]
[command path-string?]
[arg string?] ...)
list?]
[(process*/ports [out (or/c false/c output-port?)]
[in (or/c false/c input-port?)]
[error-out (or/c false/c output-port?)]
[command path-string?]
[exact (one-of/c 'exact)]
[arg string?])
list?])]{
Like @scheme[process*], but with the port handling of
@scheme[process/ports].}

2
collects/setup/scribble-index.ss
View File

@ -65,7 +65,7 @@
(map (lambda (doc) (map (lambda (doc)
(parameterize ([current-namespace (namespace-anchor->empty-namespace here)]) (parameterize ([current-namespace (namespace-anchor->empty-namespace here)])
(with-handlers ([exn:fail? (lambda (exn) exn)]) (with-handlers ([exn:fail? (lambda (exn) exn)])
(let ([r (with-input-from-file (build-path (doc-dest doc) "xref-out.ss") (let ([r (with-input-from-file (build-path (doc-dest doc) "out.sxref")
read)]) read)])
(send renderer deserialize-info (cadr r) ci))))) (send renderer deserialize-info (cadr r) ci)))))
docs) docs)

8
collects/setup/scribble.ss
View File

@ -220,8 +220,8 @@
(set-part-tags! v (cons '(part "top") (part-tags v)))))) (set-part-tags! v (cons '(part "top") (part-tags v))))))
(define ((get-doc-info only-dirs latex-dest) doc) (define ((get-doc-info only-dirs latex-dest) doc)
(let ([info-out-file (build-path (or latex-dest (doc-dest-dir doc)) "xref-out.ss")] (let ([info-out-file (build-path (or latex-dest (doc-dest-dir doc)) "out.sxref")]
[info-in-file (build-path (or latex-dest (doc-dest-dir doc)) "xref-in.ss")] [info-in-file (build-path (or latex-dest (doc-dest-dir doc)) "in.sxref")]
[out-file (build-path (doc-dest-dir doc) "index.html")] [out-file (build-path (doc-dest-dir doc) "index.html")]
[src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))]) [src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))])
(build-path base "compiled" (path-add-suffix name ".zo")))] (build-path base "compiled" (path-add-suffix name ".zo")))]
@ -410,9 +410,9 @@
(define (write-out info) (define (write-out info)
(make-directory* (doc-dest-dir (info-doc info))) (make-directory* (doc-dest-dir (info-doc info)))
(write- info "xref-out.ss" (lambda (o i) o))) (write- info "out.sxref" (lambda (o i) o)))
(define (write-in info) (define (write-in info)
(make-directory* (doc-dest-dir (info-doc info))) (make-directory* (doc-dest-dir (info-doc info)))
(write- info "xref-in.ss" (lambda (o i) i))) (write- info "in.sxref" (lambda (o i) i)))
) )

13
collects/tests/mzscheme/beginner.ss
View File

@ -68,19 +68,18 @@
[else null]))]) [else null]))])
(for-each (lambda (id1) (for-each (lambda (id1)
(for-each (lambda (id2) (for-each (lambda (id2)
(if (and (= (syntax-position id1) (when (and (= (syntax-position id1)
(syntax-position id2)) (syntax-position id2))
(not (module-identifier=? id1 id2))) (not (free-identifier=? id1 id2)))
(error 'original "mismatch: ~e ~e" (error 'original "mismatch: ~e ~e"
id1 id2))) id1 id2)))
orig-ids)) orig-ids))
orig-ids))) orig-ids)))
;; Don't need these: ;; Don't need these:
(define no-extra-if-tests? #t) (define no-extra-if-tests? #t)
(require (rename mzscheme exn:fail? exn:fail?) (require (only-in mzscheme exn:fail? exn:fail:contract?))
(rename mzscheme exn:fail:contract? exn:fail:contract?))
(define current-htdp-lang '(lib "htdp-beginner.ss" "lang")) (define current-htdp-lang '(lib "htdp-beginner.ss" "lang"))
(load-relative "htdp-test.ss") (load-relative "htdp-test.ss")

5
collects/tests/mzscheme/htdp-test.ss
View File

@ -64,8 +64,9 @@
(and (exn:fail:syntax? x) (and (exn:fail:syntax? x)
(regexp-match rx (exn-message x)))))])) (regexp-match rx (exn-message x)))))]))
(require (rename mzscheme mz-let let) (require (only-in mzscheme
(rename mzscheme mz-require require)) [let mz-let]
[require mz-require]))
(define-syntax (htdp-test stx) (define-syntax (htdp-test stx)
(syntax-case stx () (syntax-case stx ()

49
man/man1/help-desk.1
View File

@ -5,13 +5,10 @@
help-desk \- The PLT Scheme documentation center help-desk \- The PLT Scheme documentation center
.SH SYNOPSIS .SH SYNOPSIS
.B help-desk .B help-desk
[ .I term ...
.I Xoption ...
]
.SH DESCRIPTION .SH DESCRIPTION
.I Help Desk .I Help Desk
contains all of the documentation for creates an HTML document and opens it in a web browser.
the PLT suite of tools.
.PP .PP
For further information on For further information on
.I Help Desk, .I Help Desk,
@ -20,41 +17,6 @@ documentation and other information available at
.PP .PP
.ce 1 .ce 1
http://www.drscheme.org/ http://www.drscheme.org/
.SH X OPTIONS
When running in X11, Help Desk accepts the following standard
.IR Xoption s:
.B -display
.IR disp ,
.B -geometry
.IR geom ,
.B -bg
.IR color ,
.B -background
.IR color ,
.B -fg
.IR color ,
.B -foreground
.IR color ,
.B -fn
.IR font ,
.B -font
.IR font ,
.BR -iconic ,
.B -name
.IR name ,
.BR -rv ,
.BR -reverse ,
.BR +rv ,
.B -selectionTimeout
.IR time ,
.BR -synchronous ,
.B -title
.IR name ,
.B -xnllanguage
.IR lang ,
.B -xrm
.IR file .
.PP
.SH FILES .SH FILES
.I Help Desk .I Help Desk
looks for its libraries using the environment variable looks for its libraries using the environment variable
@ -67,7 +29,7 @@ the on-line documentation has been installed locally.
.SH BUGS .SH BUGS
Submit bug reports via Submit bug reports via
.ce 1 .ce 1
help-desk (encouraged), drscheme (encouraged),
or via the web or via the web
.ce 1 .ce 1
http://bugs.plt-scheme.org/ (discouraged) http://bugs.plt-scheme.org/ (discouraged)
@ -75,10 +37,7 @@ or by e-mail to
.ce 1 .ce 1
bugs@plt-scheme.org (discouraged) bugs@plt-scheme.org (discouraged)
.SH AUTHOR .SH AUTHOR
.I Help Desk PLT.
was implemented by Robby Findler, Matthew Flatt, and Paul Steckler.
The documentation was written by PLT.
.SH SEE ALSO .SH SEE ALSO
.BR mred(1),
.BR mzscheme(1), .BR mzscheme(1),
.BR drscheme(1) .BR drscheme(1)