use new 'serialized=?' to tighten setup scribble fixpoint
svn: r10428
This commit is contained in:
parent
9431017d18
commit
3f60a478ad
|
@ -17,6 +17,8 @@
|
||||||
serialize
|
serialize
|
||||||
deserialize
|
deserialize
|
||||||
|
|
||||||
|
serialized=?
|
||||||
|
|
||||||
deserialize-module-guard)
|
deserialize-module-guard)
|
||||||
|
|
||||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
@ -362,7 +364,7 @@
|
||||||
|
|
||||||
(define-struct not-ready (shares fixup))
|
(define-struct not-ready (shares fixup))
|
||||||
|
|
||||||
(define (lookup-shared! share n mod-map)
|
(define (lookup-shared! share n mod-map module-path-index-join)
|
||||||
;; The shared list is not necessarily in order of
|
;; The shared list is not necessarily in order of
|
||||||
;; refereds before referees. A `not-ready' object
|
;; refereds before referees. A `not-ready' object
|
||||||
;; indicates a reference before a value is ready,
|
;; indicates a reference before a value is ready,
|
||||||
|
@ -374,12 +376,12 @@
|
||||||
(let* ([v (vector-ref (not-ready-shares sv) n)]
|
(let* ([v (vector-ref (not-ready-shares sv) n)]
|
||||||
[val (if (box? v)
|
[val (if (box? v)
|
||||||
(deserial-shell (unbox v) mod-map (not-ready-fixup sv) n)
|
(deserial-shell (unbox v) mod-map (not-ready-fixup sv) n)
|
||||||
(deserialize-one v share mod-map))])
|
(deserialize-one v share mod-map module-path-index-join))])
|
||||||
(vector-set! share n val)
|
(vector-set! share n val)
|
||||||
val)
|
val)
|
||||||
sv)))
|
sv)))
|
||||||
|
|
||||||
(define (deserialize-one v share mod-map)
|
(define (deserialize-one v share mod-map module-path-index-join)
|
||||||
(let loop ([v v])
|
(let loop ([v v])
|
||||||
(cond
|
(cond
|
||||||
[(or (boolean? v)
|
[(or (boolean? v)
|
||||||
|
@ -398,7 +400,7 @@
|
||||||
(apply (deserialize-info-maker info) (map loop (cdr v))))]
|
(apply (deserialize-info-maker info) (map loop (cdr v))))]
|
||||||
[else
|
[else
|
||||||
(case (car v)
|
(case (car v)
|
||||||
[(?) (lookup-shared! share (cdr v) mod-map)]
|
[(?) (lookup-shared! share (cdr v) mod-map module-path-index-join)]
|
||||||
[(f) (apply make-prefab-struct (cadr v) (map loop (cddr v)))]
|
[(f) (apply make-prefab-struct (cadr v) (map loop (cddr v)))]
|
||||||
[(void) (void)]
|
[(void) (void)]
|
||||||
[(u) (let ([x (cdr v)])
|
[(u) (let ([x (cdr v)])
|
||||||
|
@ -488,17 +490,39 @@
|
||||||
[(mpi)
|
[(mpi)
|
||||||
(error 'deserialize "cannot restore module-path-index in cycle")])]))
|
(error 'deserialize "cannot restore module-path-index in cycle")])]))
|
||||||
|
|
||||||
|
(define (deserialize-with-map mod-map vers l module-path-index-join)
|
||||||
|
(let ([share-n (list-ref l 2)]
|
||||||
|
[shares (list-ref l 3)]
|
||||||
|
[fixups (list-ref l 4)]
|
||||||
|
[result (list-ref l 5)])
|
||||||
|
;; Create vector for sharing:
|
||||||
|
(let* ([fixup (make-vector share-n #f)]
|
||||||
|
[share (make-vector share-n (make-not-ready
|
||||||
|
(list->vector shares)
|
||||||
|
fixup))])
|
||||||
|
;; Deserialize into sharing array:
|
||||||
|
(let loop ([n 0][l shares])
|
||||||
|
(unless (= n share-n)
|
||||||
|
(lookup-shared! share n mod-map module-path-index-join)
|
||||||
|
(loop (add1 n) (cdr l))))
|
||||||
|
;; Fixup shell for graphs
|
||||||
|
(for-each (lambda (n+v)
|
||||||
|
(let ([v (deserialize-one (cdr n+v) share mod-map module-path-index-join)])
|
||||||
|
((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 module-path-index-join))))
|
||||||
|
|
||||||
|
(define (extract-version l)
|
||||||
|
(if (pair? (car l))
|
||||||
|
(values (caar l) (cdr l))
|
||||||
|
(values 0 l)))
|
||||||
|
|
||||||
(define (deserialize l)
|
(define (deserialize l)
|
||||||
(let-values ([(vers l)
|
(let-values ([(vers l) (extract-version l)])
|
||||||
(if (pair? (car l))
|
|
||||||
(values (caar l) (cdr l))
|
|
||||||
(values 0 l))])
|
|
||||||
(let ([mod-map (make-vector (list-ref l 0))]
|
(let ([mod-map (make-vector (list-ref l 0))]
|
||||||
[mod-map-l (list-ref l 1)]
|
[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
|
;; Load constructor mapping
|
||||||
(let loop ([n 0][l mod-map-l])
|
(let loop ([n 0][l mod-map-l])
|
||||||
(unless (null? l)
|
(unless (null? l)
|
||||||
|
@ -512,21 +536,48 @@
|
||||||
;; Register maker and struct type:
|
;; Register maker and struct type:
|
||||||
(vector-set! mod-map n des))
|
(vector-set! mod-map n des))
|
||||||
(loop (add1 n) (cdr l))))
|
(loop (add1 n) (cdr l))))
|
||||||
;; Create vector for sharing:
|
(deserialize-with-map mod-map vers l module-path-index-join))))
|
||||||
(let* ([fixup (make-vector share-n #f)]
|
|
||||||
[share (make-vector share-n (make-not-ready
|
;; ----------------------------------------
|
||||||
(list->vector shares)
|
|
||||||
fixup))])
|
(define (serialized=? l1 l2)
|
||||||
;; Deserialize into sharing array:
|
(let-values ([(vers1 l1) (extract-version l1)]
|
||||||
(let loop ([n 0][l shares])
|
[(vers2 l2) (extract-version l2)])
|
||||||
(unless (= n share-n)
|
(let ([mod-map1 (make-vector (list-ref l1 0))]
|
||||||
(lookup-shared! share n mod-map)
|
[mod-map1-l (list-ref l1 1)]
|
||||||
(loop (add1 n) (cdr l))))
|
[mod-map2 (make-vector (list-ref l2 0))]
|
||||||
;; Fixup shell for graphs
|
[mod-map2-l (list-ref l2 1)]
|
||||||
(for-each (lambda (n+v)
|
[make-key (lambda (path+name)
|
||||||
(let ([v (deserialize-one (cdr n+v) share mod-map)])
|
(if (car path+name)
|
||||||
((vector-ref fixup (car n+v)) v)))
|
(let ([p (unprotect-path (car path+name))]
|
||||||
fixups)
|
[sym (cdr path+name)])
|
||||||
;; Deserialize final result. (If there's no sharing, then
|
(list p sym))
|
||||||
;; all the work is actually here.)
|
(list #f (cdr path+name))))]
|
||||||
(deserialize-one result share mod-map))))))
|
[mpi-key (gensym)])
|
||||||
|
(let ([keys1 (map make-key mod-map1-l)]
|
||||||
|
[keys2 (map make-key mod-map2-l)]
|
||||||
|
[ht (make-hash)]
|
||||||
|
[mpij (lambda (a b) (vector mpi-key a b))])
|
||||||
|
(for-each (lambda (key)
|
||||||
|
(unless (hash-ref ht key #f)
|
||||||
|
(hash-set! ht key (gensym))))
|
||||||
|
(append keys1 keys2))
|
||||||
|
(for-each (lambda (mod-map keys)
|
||||||
|
(let loop ([n 0][l keys])
|
||||||
|
(unless (null? l)
|
||||||
|
(let ([sym (hash-ref ht (car l))])
|
||||||
|
(vector-set! mod-map n
|
||||||
|
(make-deserialize-info
|
||||||
|
(lambda args
|
||||||
|
(vector sym (list->vector args)))
|
||||||
|
(lambda ()
|
||||||
|
(let ([v (vector sym #f)])
|
||||||
|
(values v
|
||||||
|
(lambda (vec)
|
||||||
|
(vector-set! v 1 (vector-ref vec 1)))))))))
|
||||||
|
(loop (add1 n) (cdr l)))))
|
||||||
|
(list mod-map1 mod-map2)
|
||||||
|
(list keys1 keys2))
|
||||||
|
(let ([v1 (deserialize-with-map mod-map1 vers1 l1 mpij)]
|
||||||
|
[v2 (deserialize-with-map mod-map2 vers2 l2 mpij)])
|
||||||
|
(equal? v1 v2)))))))
|
||||||
|
|
|
@ -58,13 +58,14 @@
|
||||||
(let ([seen (make-hasheq)]
|
(let ([seen (make-hasheq)]
|
||||||
[search-key #f])
|
[search-key #f])
|
||||||
(let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))]
|
(let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))]
|
||||||
[rqueue null])
|
[rqueue null]
|
||||||
|
[need-result? #t])
|
||||||
(cond
|
(cond
|
||||||
[(null? queue)
|
[(null? queue)
|
||||||
(if (null? rqueue)
|
(if (null? rqueue)
|
||||||
;; Not documented
|
;; Not documented
|
||||||
#f
|
#f
|
||||||
(loop (reverse rqueue) null))]
|
(loop (reverse rqueue) null need-result?))]
|
||||||
[else
|
[else
|
||||||
(let ([mod (list-ref (car queue) 0)]
|
(let ([mod (list-ref (car queue) 0)]
|
||||||
[id (list-ref (car queue) 1)]
|
[id (list-ref (car queue) 1)]
|
||||||
|
@ -80,77 +81,86 @@
|
||||||
(not search-key))
|
(not search-key))
|
||||||
(set! search-key eb))
|
(set! search-key eb))
|
||||||
(let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))])
|
(let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))])
|
||||||
(or (and v
|
(let* ([here-result
|
||||||
(let ([v (resolve-get/tentative part ri `(form ,eb))])
|
(and need-result?
|
||||||
(or (and v `(form ,eb))
|
v
|
||||||
`(def ,eb))))
|
(let ([v (resolve-get/tentative part ri `(form ,eb))])
|
||||||
;; Maybe it's re-exported from this module...
|
(or (and v `(form ,eb))
|
||||||
;; Try a shortcut:
|
`(def ,eb))))]
|
||||||
(if (eq? rmp (and (car b) (module-path-index-resolve (car b))))
|
[need-result? (and need-result? (not here-result))])
|
||||||
;; Not defined through this path, so keep looking
|
;; Even if we've found `here-result', look deeper so that we have
|
||||||
(loop queue rqueue)
|
;; consistent `dep' results.
|
||||||
;; Check parents, if we can get the source:
|
(let ([nest-result
|
||||||
(if (and (path? (resolved-module-path-name rmp))
|
;; Maybe it's re-exported from this module...
|
||||||
(not (hash-ref seen rmp #f)))
|
;; Try a shortcut:
|
||||||
(let ([exports
|
(if (eq? rmp (and (car b) (module-path-index-resolve (car b))))
|
||||||
(hash-ref
|
;; Not defined through this path, so keep looking
|
||||||
module-info-cache
|
(loop queue rqueue need-result?)
|
||||||
rmp
|
;; Check parents, if we can get the source:
|
||||||
(lambda ()
|
(if (and (path? (resolved-module-path-name rmp))
|
||||||
(let-values ([(valss stxess)
|
(not (hash-ref seen rmp #f)))
|
||||||
(with-handlers ([exn:fail?
|
(let ([exports
|
||||||
(lambda (exn)
|
(hash-ref
|
||||||
(values null null))])
|
module-info-cache
|
||||||
(module-compiled-exports
|
rmp
|
||||||
(get-module-code (resolved-module-path-name rmp)
|
(lambda ()
|
||||||
#:choose (lambda (src zo so) 'zo))))])
|
(let-values ([(valss stxess)
|
||||||
(let ([t
|
(with-handlers ([exn:fail?
|
||||||
;; Merge the two association lists:
|
(lambda (exn)
|
||||||
(let loop ([base valss]
|
(values null null))])
|
||||||
[stxess stxess])
|
(module-compiled-exports
|
||||||
(cond
|
(get-module-code (resolved-module-path-name rmp)
|
||||||
[(null? stxess) base]
|
#:choose (lambda (src zo so) 'zo))))])
|
||||||
[(assoc (caar stxess) base)
|
(let ([t
|
||||||
=> (lambda (l)
|
;; Merge the two association lists:
|
||||||
(loop (cons (cons (car l)
|
(let loop ([base valss]
|
||||||
(append (cdar stxess)
|
[stxess stxess])
|
||||||
(cdr l)))
|
(cond
|
||||||
(remq l base))
|
[(null? stxess) base]
|
||||||
(cdr stxess)))]
|
[(assoc (caar stxess) base)
|
||||||
[else (loop (cons (car stxess)
|
=> (lambda (l)
|
||||||
base)
|
(loop (cons (cons (car l)
|
||||||
(cdr stxess))]))])
|
(append (cdar stxess)
|
||||||
(hash-set! module-info-cache rmp t)
|
(cdr l)))
|
||||||
t))))])
|
(remq l base))
|
||||||
(hash-set! seen rmp #t)
|
(cdr stxess)))]
|
||||||
(let ([a (assq id (let ([a (assoc export-phase exports)])
|
[else (loop (cons (car stxess)
|
||||||
(if a
|
base)
|
||||||
(cdr a)
|
(cdr stxess))]))])
|
||||||
null)))])
|
(hash-set! module-info-cache rmp t)
|
||||||
(if a
|
t))))])
|
||||||
(loop queue
|
(hash-set! seen rmp #t)
|
||||||
(append (map (lambda (m)
|
(let ([a (assq id (let ([a (assoc export-phase exports)])
|
||||||
(if (pair? m)
|
(if a
|
||||||
(list (module-path-index-rejoin (car m) mod)
|
(cdr a)
|
||||||
(list-ref m 2)
|
null)))])
|
||||||
defn-phase
|
(if a
|
||||||
(list-ref m 1)
|
(loop queue
|
||||||
(list-ref m 3))
|
(append (map (lambda (m)
|
||||||
(list (module-path-index-rejoin m mod)
|
(if (pair? m)
|
||||||
id
|
(list (module-path-index-rejoin (car m) mod)
|
||||||
0
|
(list-ref m 2)
|
||||||
0
|
defn-phase
|
||||||
0)))
|
(list-ref m 1)
|
||||||
(cadr a))
|
(list-ref m 3))
|
||||||
rqueue))
|
(list (module-path-index-rejoin m mod)
|
||||||
(begin
|
id
|
||||||
;; A dead end may not be our fault: the files could
|
0
|
||||||
;; have changed in inconsistent ways. So just say #f
|
0
|
||||||
;; for now.
|
0)))
|
||||||
#;
|
(cadr a))
|
||||||
(error 'find-scheme-tag
|
rqueue)
|
||||||
"dead end when looking for binding source: ~e"
|
need-result?)
|
||||||
id)
|
(begin
|
||||||
#f))))
|
;; A dead end may not be our fault: the files could
|
||||||
;; Can't get the module source, so continue with queue:
|
;; have changed in inconsistent ways. So just say #f
|
||||||
(loop queue rqueue)))))))])))))))
|
;; for now.
|
||||||
|
#;
|
||||||
|
(error 'find-scheme-tag
|
||||||
|
"dead end when looking for binding source: ~e"
|
||||||
|
id)
|
||||||
|
#f))))
|
||||||
|
;; Can't get the module source, so continue with queue:
|
||||||
|
(loop queue rqueue need-result?)))])
|
||||||
|
(or here-result
|
||||||
|
nest-result))))))])))))))
|
||||||
|
|
|
@ -297,6 +297,30 @@ If a value provided to @scheme[serialize] is a simple tree (i.e., no
|
||||||
sharing), then the fourth and fifth elements in the serialized
|
sharing), then the fourth and fifth elements in the serialized
|
||||||
representation will be empty.}
|
representation will be empty.}
|
||||||
|
|
||||||
|
@; ----------------------------------------------------------------------
|
||||||
|
|
||||||
|
@defproc[(serialized=? [v1 any/c] [v2 any/c]) boolean?]{
|
||||||
|
|
||||||
|
Returns @scheme[#t] if @scheme[v1] and @scheme[v2] represent the same
|
||||||
|
serialization information.
|
||||||
|
|
||||||
|
More precisely, it returns the same value that @scheme[(equal?
|
||||||
|
(deserialize v1) (deserialize v2))] would return if
|
||||||
|
|
||||||
|
@itemize[
|
||||||
|
|
||||||
|
@item{all structure types whose deserializers are accessed with
|
||||||
|
distinct module paths are actually distinct types;}
|
||||||
|
|
||||||
|
@item{all structure types are transparent; and}
|
||||||
|
|
||||||
|
@item{all structure instances contain only the constituent values
|
||||||
|
recorded in each of @scheme[v1] and @scheme[v2].}
|
||||||
|
|
||||||
|
]}
|
||||||
|
|
||||||
|
@; ----------------------------------------------------------------------
|
||||||
|
|
||||||
@defparam[deserialize-module-guard guard (module-path? symbol? . -> . void?)]{
|
@defparam[deserialize-module-guard guard (module-path? symbol? . -> . void?)]{
|
||||||
|
|
||||||
A parameter whose value is called by @scheme[deserialize] before
|
A parameter whose value is called by @scheme[deserialize] before
|
||||||
|
|
|
@ -22,7 +22,7 @@
|
||||||
(define verbose (make-parameter #t))
|
(define verbose (make-parameter #t))
|
||||||
|
|
||||||
(define-struct doc (src-dir src-spec src-file dest-dir flags under-main? category))
|
(define-struct doc (src-dir src-spec src-file dest-dir flags under-main? category))
|
||||||
(define-struct info (doc sci provides undef searches deps
|
(define-struct info (doc sci provides undef searches deps known-deps
|
||||||
build? time out-time need-run?
|
build? time out-time need-run?
|
||||||
need-in-write? need-out-write?
|
need-in-write? need-out-write?
|
||||||
vers rendered? failed?)
|
vers rendered? failed?)
|
||||||
|
@ -138,12 +138,14 @@
|
||||||
(let ([one? #f]
|
(let ([one? #f]
|
||||||
[added? #f]
|
[added? #f]
|
||||||
[deps (make-hasheq)]
|
[deps (make-hasheq)]
|
||||||
|
[known-deps (make-hasheq)]
|
||||||
[all-main? (memq 'depends-all-main (doc-flags (info-doc info)))])
|
[all-main? (memq 'depends-all-main (doc-flags (info-doc info)))])
|
||||||
(set-info-deps!
|
(set-info-deps!
|
||||||
info
|
info
|
||||||
(map (lambda (d)
|
(map (lambda (d)
|
||||||
(if (info? d) d (or (hash-ref src->info d #f) d)))
|
(if (info? d) d (or (hash-ref src->info d #f) d)))
|
||||||
(info-deps info)))
|
(info-deps info)))
|
||||||
|
;; Propagate existing dependencies as expected dependencies:
|
||||||
(for ([d (info-deps info)])
|
(for ([d (info-deps info)])
|
||||||
(let ([i (if (info? d) d (hash-ref src->info d #f))])
|
(let ([i (if (info? d) d (hash-ref src->info d #f))])
|
||||||
(if i
|
(if i
|
||||||
|
@ -159,7 +161,7 @@
|
||||||
(printf " [Removed Dependency: ~a]\n"
|
(printf " [Removed Dependency: ~a]\n"
|
||||||
(doc-src-file (info-doc info))))))))
|
(doc-src-file (info-doc info))))))))
|
||||||
(when (or (memq 'depends-all (doc-flags (info-doc info))) all-main?)
|
(when (or (memq 'depends-all (doc-flags (info-doc info))) all-main?)
|
||||||
;; Add all:
|
;; Add all as expected dependency:
|
||||||
(when (verbose)
|
(when (verbose)
|
||||||
(printf " [Adding all~a as dependencies: ~a]\n"
|
(printf " [Adding all~a as dependencies: ~a]\n"
|
||||||
(if all-main? " main" "")
|
(if all-main? " main" "")
|
||||||
|
@ -185,10 +187,20 @@
|
||||||
(for ([k (info-undef info)])
|
(for ([k (info-undef info)])
|
||||||
(let ([i (hash-ref ht k #f)])
|
(let ([i (hash-ref ht k #f)])
|
||||||
(if i
|
(if i
|
||||||
(when (not (hash-ref deps i #f))
|
(begin
|
||||||
(set! added? #t)
|
;; Record a definite dependency:
|
||||||
(hash-set! deps i #t))
|
(when (not (hash-ref known-deps i #f))
|
||||||
(when first? (unless (eq? (car k) 'dep) (not-found k))))))
|
(hash-set! known-deps i #t))
|
||||||
|
;; Record also in the expected-dependency list:
|
||||||
|
(when (not (hash-ref deps i #f))
|
||||||
|
(set! added? #t)
|
||||||
|
(when (verbose)
|
||||||
|
(printf " [Adding... ~a]\n"
|
||||||
|
(doc-src-file (info-doc i))))
|
||||||
|
(hash-set! deps i #t)))
|
||||||
|
(when first?
|
||||||
|
(unless (eq? (car k) 'dep)
|
||||||
|
(not-found k))))))
|
||||||
(when first?
|
(when first?
|
||||||
(for ([(s-key s-ht) (info-searches info)])
|
(for ([(s-key s-ht) (info-searches info)])
|
||||||
(unless (ormap (lambda (k) (hash-ref ht k #f))
|
(unless (ormap (lambda (k) (hash-ref ht k #f))
|
||||||
|
@ -199,6 +211,7 @@
|
||||||
(printf " [Added Dependency: ~a]\n"
|
(printf " [Added Dependency: ~a]\n"
|
||||||
(doc-src-file (info-doc info))))
|
(doc-src-file (info-doc info))))
|
||||||
(set-info-deps! info (hash-map deps (lambda (k v) k)))
|
(set-info-deps! info (hash-map deps (lambda (k v) k)))
|
||||||
|
(set-info-known-deps! info (hash-map known-deps (lambda (k v) k)))
|
||||||
(set-info-need-in-write?! info #t)
|
(set-info-need-in-write?! info #t)
|
||||||
(set-info-need-run?! info #t))))
|
(set-info-need-run?! info #t))))
|
||||||
;; If a dependency changed, then we need a re-run:
|
;; If a dependency changed, then we need a re-run:
|
||||||
|
@ -302,6 +315,10 @@
|
||||||
(and (pair? cat)
|
(and (pair? cat)
|
||||||
(eq? (car cat) 'omit))))
|
(eq? (car cat) 'omit))))
|
||||||
|
|
||||||
|
(define (any-order keys)
|
||||||
|
(let ([ht (make-hash)])
|
||||||
|
(for-each (lambda (k) (hash-set! ht k #t)) keys)
|
||||||
|
ht))
|
||||||
|
|
||||||
(define (read-out-sxref)
|
(define (read-out-sxref)
|
||||||
(fasl->s-exp (current-input-port)))
|
(fasl->s-exp (current-input-port)))
|
||||||
|
@ -368,30 +385,21 @@
|
||||||
(error "old info has wrong version or flags"))
|
(error "old info has wrong version or flags"))
|
||||||
(make-info
|
(make-info
|
||||||
doc
|
doc
|
||||||
(list-ref v-out 1) ; sci
|
(list-ref v-out 1) ; sci (leave serialized)
|
||||||
(let ([v (list-ref v-out 2)]) ; provides
|
(let ([v (list-ref v-out 2)]) ; provides
|
||||||
(if (not (and (pair? v) ; temporary compatibility; used to be not serialized
|
(with-my-namespace
|
||||||
(pair? (car v))
|
(lambda ()
|
||||||
(integer? (caar v))))
|
(deserialize v))))
|
||||||
v
|
|
||||||
(with-my-namespace
|
|
||||||
(lambda ()
|
|
||||||
(deserialize v)))))
|
|
||||||
(let ([v (list-ref v-in 1)]) ; undef
|
(let ([v (list-ref v-in 1)]) ; undef
|
||||||
(if (not (and (pair? v) ; temporary compatibility; used to be not serialized
|
(with-my-namespace
|
||||||
(pair? (car v))
|
(lambda ()
|
||||||
(integer? (caar v))))
|
(deserialize v))))
|
||||||
v
|
|
||||||
(with-my-namespace
|
|
||||||
(lambda ()
|
|
||||||
(deserialize v)))))
|
|
||||||
(let ([v (list-ref v-in 3)]) ; searches
|
(let ([v (list-ref v-in 3)]) ; searches
|
||||||
(if (hash? v) ; temporary compatibility; used to be not serialized
|
(with-my-namespace
|
||||||
v
|
(lambda ()
|
||||||
(with-my-namespace
|
(deserialize v))))
|
||||||
(lambda ()
|
(map rel->path (list-ref v-in 2)) ; expected deps, in case we don't need to build...
|
||||||
(deserialize v)))))
|
null ; known deps (none at this point)
|
||||||
(map rel->path (list-ref v-in 2)) ; deps, in case we don't need to build...
|
|
||||||
can-run?
|
can-run?
|
||||||
my-time info-out-time
|
my-time info-out-time
|
||||||
(and can-run? (memq 'always-run (doc-flags doc)))
|
(and can-run? (memq 'always-run (doc-flags doc)))
|
||||||
|
@ -421,8 +429,11 @@
|
||||||
[defs (send renderer get-defined ci)]
|
[defs (send renderer get-defined ci)]
|
||||||
[searches (resolve-info-searches ri)]
|
[searches (resolve-info-searches ri)]
|
||||||
[need-out-write?
|
[need-out-write?
|
||||||
(or (not (equal? (list (list vers (doc-flags doc)) sci defs)
|
(or (not out-v)
|
||||||
out-v))
|
(not (equal? (list vers (doc-flags doc))
|
||||||
|
(car out-v)))
|
||||||
|
(not (serialized=? sci (cadr out-v)))
|
||||||
|
(not (equal? (any-order defs) (any-order (deserialize (caddr out-v)))))
|
||||||
(info-out-time . > . (current-seconds)))])
|
(info-out-time . > . (current-seconds)))])
|
||||||
(when (and (verbose) need-out-write?)
|
(when (and (verbose) need-out-write?)
|
||||||
(fprintf (current-error-port) " [New out ~a]\n" (doc-src-file doc)))
|
(fprintf (current-error-port) " [New out ~a]\n" (doc-src-file doc)))
|
||||||
|
@ -433,6 +444,7 @@
|
||||||
(send renderer get-undefined ri)
|
(send renderer get-undefined ri)
|
||||||
searches
|
searches
|
||||||
null ; no deps, yet
|
null ; no deps, yet
|
||||||
|
null ; no known deps, yet
|
||||||
can-run?
|
can-run?
|
||||||
-inf.0
|
-inf.0
|
||||||
(if need-out-write?
|
(if need-out-write?
|
||||||
|
@ -485,10 +497,11 @@
|
||||||
[sci (render-time "serialize" (send renderer serialize-info ri))]
|
[sci (render-time "serialize" (send renderer serialize-info ri))]
|
||||||
[defs (render-time "defined" (send renderer get-defined ci))]
|
[defs (render-time "defined" (send renderer get-defined ci))]
|
||||||
[undef (render-time "undefined" (send renderer get-undefined ri))]
|
[undef (render-time "undefined" (send renderer get-undefined ri))]
|
||||||
[in-delta? (not (equal? undef (info-undef info)))]
|
[in-delta? (not (equal? (any-order undef)
|
||||||
[out-delta? (not (equal? (list sci defs)
|
(any-order (info-undef info))))]
|
||||||
(list (info-sci info)
|
[out-delta? (or (not (serialized=? sci (info-sci info)))
|
||||||
(info-provides info))))])
|
(not (equal? (any-order defs)
|
||||||
|
(any-order (info-provides info)))))])
|
||||||
(when (verbose)
|
(when (verbose)
|
||||||
(printf " [~a~afor ~a]\n"
|
(printf " [~a~afor ~a]\n"
|
||||||
(if in-delta? "New in " "")
|
(if in-delta? "New in " "")
|
||||||
|
@ -501,7 +514,9 @@
|
||||||
(set-info-sci! info sci)
|
(set-info-sci! info sci)
|
||||||
(set-info-provides! info defs)
|
(set-info-provides! info defs)
|
||||||
(set-info-undef! info undef)
|
(set-info-undef! info undef)
|
||||||
(when in-delta? (set-info-deps! info null)) ; recompute deps outside
|
(when in-delta?
|
||||||
|
;; Reset expected dependencies to known dependencies, and recompute later:
|
||||||
|
(set-info-deps! info (info-known-deps info)))
|
||||||
(when (or out-delta? (info-need-out-write? info))
|
(when (or out-delta? (info-need-out-write? info))
|
||||||
(unless latex-dest
|
(unless latex-dest
|
||||||
(render-time "xref-out" (write-out info)))
|
(render-time "xref-out" (write-out info)))
|
||||||
|
|
|
@ -4,16 +4,16 @@
|
||||||
|
|
||||||
(Section 'serialization)
|
(Section 'serialization)
|
||||||
|
|
||||||
(require mzlib/serialize)
|
(require scheme/serialize)
|
||||||
|
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
|
|
||||||
(define insp (current-inspector))
|
(define insp (current-inspector))
|
||||||
|
|
||||||
(define-serializable-struct a () insp)
|
(define-serializable-struct a () #:inspector insp #:mutable)
|
||||||
(define-serializable-struct b (x y) insp)
|
(define-serializable-struct b (x y) #:inspector insp #:mutable)
|
||||||
(define-serializable-struct (c a) (z) insp)
|
(define-serializable-struct (c a) (z) #:inspector insp #:mutable)
|
||||||
(define-serializable-struct (d b) (w) insp)
|
(define-serializable-struct (d b) (w) #:inspector insp #:mutable)
|
||||||
|
|
||||||
(define (same? v1 v2)
|
(define (same? v1 v2)
|
||||||
;; This is not quite the same as `equal?', veuase it knows
|
;; This is not quite the same as `equal?', veuase it knows
|
||||||
|
@ -95,7 +95,9 @@
|
||||||
(parameterize ([print-graph #t])
|
(parameterize ([print-graph #t])
|
||||||
(test #t serializable? v)
|
(test #t serializable? v)
|
||||||
(test #t same? v v)
|
(test #t same? v v)
|
||||||
(test #t same? v (deserialize (serialize v)))))
|
(test #t same? v (deserialize (serialize v)))
|
||||||
|
(test #t serialized=? (serialize v) (serialize v))
|
||||||
|
(test #f serialized=? (serialize v) (serialize (not v)))))
|
||||||
|
|
||||||
(define (mk-ht mk)
|
(define (mk-ht mk)
|
||||||
(let ([ht (mk)])
|
(let ([ht (mk)])
|
||||||
|
|
|
@ -13,7 +13,7 @@
|
||||||
|
|
||||||
(module test2 mzscheme
|
(module test2 mzscheme
|
||||||
(require mzlib/unit
|
(require mzlib/unit
|
||||||
test)
|
'test)
|
||||||
(define-unit u1 (import) (export s)
|
(define-unit u1 (import) (export s)
|
||||||
(define a 1))
|
(define a 1))
|
||||||
(define-unit u2 (import s) (export)
|
(define-unit u2 (import s) (export)
|
||||||
|
@ -25,15 +25,15 @@
|
||||||
)
|
)
|
||||||
|
|
||||||
;; 4
|
;; 4
|
||||||
(require test2)
|
(require 'test2)
|
||||||
|
|
||||||
(module test3 mzscheme
|
(module test3 mzscheme
|
||||||
(require mzlib/unit
|
(require mzlib/unit
|
||||||
test)
|
'test)
|
||||||
(define-unit u1 (import) (export s)
|
(define-unit u1 (import) (export s)
|
||||||
(define a 1))
|
(define a 1))
|
||||||
(define-values/invoke-unit u1 (import) (export (rename s)))
|
(define-values/invoke-unit u1 (import) (export (rename s)))
|
||||||
(printf "~a~n" (+ y (z)))
|
(printf "~a~n" (+ y (z)))
|
||||||
)
|
)
|
||||||
;;4
|
;;4
|
||||||
(require test3)
|
(require 'test3)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user