From 8f1da824ae36ef7ed470bb69ccdb38e8093cdf5f Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 25 Nov 2007 19:48:41 +0000
Subject: [PATCH] doc fixes

svn: r7832

original commit: 5f312dcbde3ed674c3af3d4d5ded23eb1a93ebc8
---
 collects/mzlib/serialize.ss | 475 +-----------------------------------
 1 file changed, 8 insertions(+), 467 deletions(-)

diff --git a/collects/mzlib/serialize.ss b/collects/mzlib/serialize.ss
index e0d3333..8da9809 100644
--- a/collects/mzlib/serialize.ss
+++ b/collects/mzlib/serialize.ss
@@ -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))))))
\ No newline at end of file