doc fixes
svn: r7832
This commit is contained in:
Matthew Flatt
parent
cebdb136fe
commit
5f312dcbde
|
|
@ -5,7 +5,7 @@
|
|||
"region.ss")
|
||||
|
||||
(provide table<%> card<%>
|
||||
region
|
||||
region struct:region
|
||||
make-region
|
||||
region? region-x region-y region-w region-h
|
||||
region-label region-callback region-interactive-callback
|
||||
|
|
|
|||
469
collects/mzlib/private/serialize.ss
Normal file
469
collects/mzlib/private/serialize.ss
Normal 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))))))
|
||||
|
|
@ -3,27 +3,22 @@
|
|||
(require (lib "modcollapse.ss" "syntax")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
"private/serialize-structs.ss")
|
||||
;; core [de]serializer:
|
||||
"private/serialize.ss")
|
||||
|
||||
(provide define-serializable-struct
|
||||
define-serializable-struct/versions
|
||||
|
||||
;; For implementors of other `define-struct'-like forms:
|
||||
prop:serializable
|
||||
make-serialize-info
|
||||
make-deserialize-info
|
||||
|
||||
;; Checks whether a value is seriliazable:
|
||||
serializable?
|
||||
|
||||
;; The two main routines:
|
||||
serialize
|
||||
deserialize)
|
||||
;; core [de]serializer:
|
||||
(all-from "private/serialize.ss"))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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
|
||||
;; call to `make-struct-type'. This is where we insert the serializable property.
|
||||
(define-for-syntax (make-make-make-struct-type inspector+deserializer-stx)
|
||||
|
|
@ -400,458 +395,4 @@
|
|||
(main stx))
|
||||
(lambda (stx)
|
||||
(context-check 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))))))
|
||||
(main/versions stx))))))
|
||||
|
|
@ -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
|
||||
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
|
||||
@scheme['snip-class]. If the result is a @scheme[snip-class%] object,
|
||||
it is inserted into the current eventspace's snip class list, and
|
||||
|
|
|
|||
|
|
@ -47,7 +47,10 @@ To define a class of snips that can be saved or cut-and-pasted:
|
|||
@itemize{
|
||||
|
||||
@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
|
||||
with @method[snip% set-snipclass].}
|
||||
|
|
|
|||
|
|
@ -8,6 +8,9 @@
|
|||
@;------------------------------------------------------------------------
|
||||
@section[#:tag "tcp"]{TCP}
|
||||
|
||||
@declare-exporting[scheme/tcp]
|
||||
@note-lib[scheme/tcp]
|
||||
|
||||
For information about TCP in general, see @italic{TCP/IP Illustrated,
|
||||
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}
|
||||
|
||||
@declare-exporting[scheme/udp]
|
||||
@note-lib[scheme/udp]
|
||||
|
||||
For information about UDP in general, see @italic{TCP/IP Illustrated,
|
||||
Volume 1} by W. Richard Stevens.
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
type.
|
||||
|
||||
@declare-exporting[scheme/struct-info scheme]
|
||||
@note-lib-only[scheme/struct-info]
|
||||
|
||||
@defproc[(struct-info? [v any/c]) boolean?]{
|
||||
|
||||
Returns @scheme[#f] if @scheme[v] is either a six-element list with
|
||||
|
|
|
|||
|
|
@ -1,29 +1,42 @@
|
|||
#lang scribble/doc
|
||||
@require["mz.ss"]
|
||||
@require["mz.ss"
|
||||
(for-label scheme/system)]
|
||||
|
||||
@title[#:tag "subprocess"]{Processes}
|
||||
|
||||
@defproc[(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?]
|
||||
[arg string?] ...)
|
||||
(values subprocess?
|
||||
(or/c input-port? false/c)
|
||||
(or/c output-port? false/c)
|
||||
(or/c input-port? false/c))]{
|
||||
@defproc*[([(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?]
|
||||
[arg string?] ...)
|
||||
(values subprocess?
|
||||
(or/c input-port? false/c)
|
||||
(or/c output-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
|
||||
@scheme[command] asynchronously. The @scheme[command] argument is a
|
||||
path to a program executable, and the @scheme[arg]s are command-line
|
||||
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"]).
|
||||
@scheme[command] asynchronously. See also @scheme[system] and
|
||||
@scheme[process] from @schememodname[scheme/system].
|
||||
|
||||
Under Windows, the first @scheme[arg] can be @indexed-scheme['exact],
|
||||
which triggers a Windows-specific hack: the second @scheme[arg] is
|
||||
used exactly as the command-line for the subprocess, and no additional
|
||||
@scheme[arg]s can be supplied. Otherwise, a command-line string is
|
||||
The @scheme[command] argument is a path to a program executable, and
|
||||
the @scheme[arg]s are command-line 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 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
|
||||
Windows console application can parse it back to an array of
|
||||
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
|
||||
value is returned, its process ID will be @scheme[0] instead of the
|
||||
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].}
|
||||
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@
|
|||
(map (lambda (doc)
|
||||
(parameterize ([current-namespace (namespace-anchor->empty-namespace here)])
|
||||
(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)])
|
||||
(send renderer deserialize-info (cadr r) ci)))))
|
||||
docs)
|
||||
|
|
|
|||
|
|
@ -220,8 +220,8 @@
|
|||
(set-part-tags! v (cons '(part "top") (part-tags v))))))
|
||||
|
||||
(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")]
|
||||
[info-in-file (build-path (or latex-dest (doc-dest-dir doc)) "xref-in.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)) "in.sxref")]
|
||||
[out-file (build-path (doc-dest-dir doc) "index.html")]
|
||||
[src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))])
|
||||
(build-path base "compiled" (path-add-suffix name ".zo")))]
|
||||
|
|
@ -410,9 +410,9 @@
|
|||
|
||||
(define (write-out 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)
|
||||
(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)))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -68,19 +68,18 @@
|
|||
[else null]))])
|
||||
(for-each (lambda (id1)
|
||||
(for-each (lambda (id2)
|
||||
(if (and (= (syntax-position id1)
|
||||
(syntax-position id2))
|
||||
(not (module-identifier=? id1 id2)))
|
||||
(error 'original "mismatch: ~e ~e"
|
||||
id1 id2)))
|
||||
(when (and (= (syntax-position id1)
|
||||
(syntax-position id2))
|
||||
(not (free-identifier=? id1 id2)))
|
||||
(error 'original "mismatch: ~e ~e"
|
||||
id1 id2)))
|
||||
orig-ids))
|
||||
orig-ids)))
|
||||
|
||||
;; Don't need these:
|
||||
(define no-extra-if-tests? #t)
|
||||
|
||||
(require (rename mzscheme exn:fail? exn:fail?)
|
||||
(rename mzscheme exn:fail:contract? exn:fail:contract?))
|
||||
(require (only-in mzscheme exn:fail? exn:fail:contract?))
|
||||
|
||||
(define current-htdp-lang '(lib "htdp-beginner.ss" "lang"))
|
||||
(load-relative "htdp-test.ss")
|
||||
|
|
|
|||
|
|
@ -64,8 +64,9 @@
|
|||
(and (exn:fail:syntax? x)
|
||||
(regexp-match rx (exn-message x)))))]))
|
||||
|
||||
(require (rename mzscheme mz-let let)
|
||||
(rename mzscheme mz-require require))
|
||||
(require (only-in mzscheme
|
||||
[let mz-let]
|
||||
[require mz-require]))
|
||||
|
||||
(define-syntax (htdp-test stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -5,13 +5,10 @@
|
|||
help-desk \- The PLT Scheme documentation center
|
||||
.SH SYNOPSIS
|
||||
.B help-desk
|
||||
[
|
||||
.I Xoption ...
|
||||
]
|
||||
.I term ...
|
||||
.SH DESCRIPTION
|
||||
.I Help Desk
|
||||
contains all of the documentation for
|
||||
the PLT suite of tools.
|
||||
creates an HTML document and opens it in a web browser.
|
||||
.PP
|
||||
For further information on
|
||||
.I Help Desk,
|
||||
|
|
@ -20,41 +17,6 @@ documentation and other information available at
|
|||
.PP
|
||||
.ce 1
|
||||
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
|
||||
.I Help Desk
|
||||
looks for its libraries using the environment variable
|
||||
|
|
@ -67,7 +29,7 @@ the on-line documentation has been installed locally.
|
|||
.SH BUGS
|
||||
Submit bug reports via
|
||||
.ce 1
|
||||
help-desk (encouraged),
|
||||
drscheme (encouraged),
|
||||
or via the web
|
||||
.ce 1
|
||||
http://bugs.plt-scheme.org/ (discouraged)
|
||||
|
|
@ -75,10 +37,7 @@ or by e-mail to
|
|||
.ce 1
|
||||
bugs@plt-scheme.org (discouraged)
|
||||
.SH AUTHOR
|
||||
.I Help Desk
|
||||
was implemented by Robby Findler, Matthew Flatt, and Paul Steckler.
|
||||
The documentation was written by PLT.
|
||||
PLT.
|
||||
.SH SEE ALSO
|
||||
.BR mred(1),
|
||||
.BR mzscheme(1),
|
||||
.BR drscheme(1)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user