fix problem with recursive reads on hash tables, sfix syntax-quoted hash tables in marhsaled compiled code, and add a bit more new documentation

svn: r6759

collects/mzlib/cm.ss

@@ -1,5 +1,6 @@
 (module cm mzscheme
-  (require (lib "moddep.ss" "syntax")
+  (require (lib "modcode.ss" "syntax")
+           (lib "modresolve.ss" "syntax")
 	   (lib "main-collects.ss" "setup")
 	   (lib "file.ss"))
 

collects/scribble/eval.ss

@@ -33,6 +33,31 @@
 
   (define maxlen 60)
 
+  (define (format-output str style)
+    (if (string=? "" str)
+        null
+        (list
+         (list
+          (make-flow 
+           (list
+            (let ([s (regexp-split #rx"\n"
+                                   (regexp-replace #rx"\n$"
+                                                   str
+                                                   ""))])
+              (if (= 1 (length s))
+                  (make-paragraph
+                   (list
+                    (hspace 2)
+                    (span-class style (car s))))
+                  (make-table
+                   #f
+                   (map (lambda (s)
+                          (list (make-flow (list (make-paragraph
+                                                  (list
+                                                   (hspace 2)
+                                                   (span-class style s)))))))
+                        s))))))))))
+
   (define (interleave title expr-paras val-list+outputs)
     (make-table
      #f
@@ -48,29 +73,8 @@
                            (if (flow? p)
                                p
                                (make-flow (list p))))))
-             (if (string=? "" (cdar val-list+outputs))
+             (format-output (cadar val-list+outputs) "schemestdout")
-                 null
+             (format-output (caddar val-list+outputs) "schemeerror")
-                 (list
-                  (list
-                   (make-flow 
-                    (list
-                     (let ([s (regexp-split #rx"\n"
-                                            (regexp-replace #rx"\n$"
-                                                            (cdar val-list+outputs)
-                                                            ""))])
-                       (if (= 1 (length s))
-                           (make-paragraph
-                            (list
-                             (hspace 2)
-                             (span-class "schemestdout" (car s))))
-                           (make-table
-                            #f
-                            (map (lambda (s)
-                                   (list (make-flow (list (make-paragraph
-                                                           (list
-                                                            (hspace 2)
-                                                            (span-class "schemestdout" s)))))))
-                                 s)))))))))
              (if (string? (caar val-list+outputs))
                  ;; Error result case:
                  (map
@@ -114,14 +118,18 @@
      [(eval:alts p e)
       (do-eval #'e)]
      [else
-      (let ([o (open-output-string)])
+      (let ([o (open-output-string)]
-        (parameterize ([current-output-port o])
+            [o2 (open-output-string)])
+        (parameterize ([current-output-port o]
+                       [current-error-port o2])
           (with-handlers ([exn? (lambda (e)
-                                  (cons (exn-message e)
+                                  (list (exn-message e)
-                                        (get-output-string o)))])
+                                        (get-output-string o)
-            (cons (let ([v (do-plain-eval s #t)])
+                                        (get-output-string o2)))])
+            (list (let ([v (do-plain-eval s #t)])
                     (copy-value v (make-hash-table)))
-                  (get-output-string o)))))]))
+                  (get-output-string o)
+                  (get-output-string o2)))))]))
 
   (define (install ht v v2)
     (hash-table-put! ht v v2)

collects/scribble/html-render.ss

@@ -77,27 +77,29 @@
                           (class "tocviewlink"))
                          ,@(render-content (part-title-content top) d ht)))
                  (div nbsp)
-                 (div
+                 (table 
-                  ((class "tocviewlist"))
+                  ((class "tocviewlist")
+                   (cellspacing "0"))
                   ,@(map (lambda (p)
-                           `(div
+                           `(tr
-                             ((class "tocviewitem"))
+                             (td
-                             (a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))])
+                              ,@(format-number (collected-info-number (part-collected-info p))
-                                          (format "~a~a~a" 
+                                               '((tt nbsp))))
-                                                  (from-root (car dest)
+                             (td
-                                                             (get-dest-directory))
+                              (a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))])
-                                                  (if (caddr dest)
+                                           (format "~a~a~a" 
-                                                      ""
+                                                   (from-root (car dest)
-                                                      "#")
+                                                              (get-dest-directory))
-                                                  (if (caddr dest)
+                                                   (if (caddr dest)
-                                                      ""
+                                                       ""
-                                                      `(part ,(part-tag p))))))
+                                                       "#")
-                                 (class ,(if (eq? p mine)
+                                                   (if (caddr dest)
-                                             "tocviewselflink"
+                                                       ""
-                                             "tocviewlink")))
+                                                       `(part ,(part-tag p))))))
-                                ,@(format-number (collected-info-number (part-collected-info p))
+                                  (class ,(if (eq? p mine)
-                                                 '((tt nbsp)))
+                                              "tocviewselflink"
-                                ,@(render-content (part-title-content p) d ht))))
+                                              "tocviewlink")))
+                                 ,@(render-content (part-title-content p) d ht)))))
                          (part-parts top)))))))
 
       (define/public (render-one-part d ht fn number)

collects/scribble/scheme.ss

@@ -338,11 +338,14 @@
                        "#hash"
                        "#hasheq")
                    value-color)
-              (set! src-col (+ src-col 5 (if equal-table? 2 0)))
+              (let ([delta (+ 5 (if equal-table? 2 0))]
-              (hash-table-put! next-col-map src-col dest-col)
+                    [orig-col src-col])
-              ((loop init-line! +inf.0)
+                (set! src-col (+ src-col delta))
-               (syntax-ize (hash-table-map (syntax-e c) cons)
+                (hash-table-put! next-col-map src-col dest-col)
-                           (syntax-column c))))]
+                ((loop init-line! +inf.0)
+                 (syntax-ize (hash-table-map (syntax-e c) cons)
+                             (+ (syntax-column c) delta)))
+                (set! src-col (+ orig-col (syntax-span c)))))]
            [else
             (advance c init-line!)
             (let-values ([(s it? sub?)

collects/scribble/scribble.css

@@ -51,13 +51,12 @@
                 }
 
                .tocviewlist { 
-                  font-size: 80%;
                   margin: 0.2em 0.2em 0.2em 0.2em;
                 }
 
-               .tocviewitem { 
+               .tocviewlist td { 
-                  margin-left: 1em;
+                  font-size: 80%;
-                  text-indent: -1em;
+                  vertical-align: top;
                }
 
                .tocviewlink { 

collects/scribblings/guide/data.scrbl

@@ -3,7 +3,7 @@
 @require[(lib "eval.ss" "scribble")]
 @require["guide-utils.ss"]
 
-@title[#:tag "datatypes" #:style 'toc]{Built-In Datatypes}
+@title[#:tag "guide:datatypes" #:style 'toc]{Built-In Datatypes}
 
 The @seclink["to-scheme"]{previous chapter} introduced some of
 Scheme's built-in datatype: numbers, booleans, strings, lists, and

collects/scribblings/guide/guide.scrbl

@@ -33,6 +33,8 @@ precise details to @|MzScheme| and other reference manuals.
 
 @include-section["modules.scrbl"]
 
+@include-section["io.scrbl"]
+
 @; ----------------------------------------------------------------------
 @section[#:tag "guide:contracts"]{Contracts}
 
@@ -52,10 +54,6 @@ using @idefterm{contracts}.
 @include-section["for.scrbl"]
 
 
-@; ----------------------------------------------------------------------
-@include-section["io.scrbl"]
-
-
 @; ----------------------------------------------------------------------
 @section[#:tag "regexp"]{Regular-Expression Matching@aux-elem{ (Regexps)}}
 
@@ -71,6 +69,8 @@ of an expression to the values for the clause:
 @specform[(case [(_datum ...+) expr ...+] 
                 ...)]
 
+@; ----------------------------------------------------------------------
+@include-section["qq.scrbl"]
 
 @; ----------------------------------------------------------------------
 @section[#:tag "units"]{Units (Higher-Order Modules)}

collects/scribblings/guide/io.scrbl

@@ -1,14 +1,253 @@
 #reader(lib "docreader.ss" "scribble")
 @require[(lib "manual.ss" "scribble")]
+@require[(lib "struct.ss" "scribble")]
 @require[(lib "eval.ss" "scribble")]
+@require[(lib "process.ss")]
 @require["guide-utils.ss"]
 
-@title[#:tag "guide:i/o"]{Input and Output}
+@define[(twocolumn a b)
+        (make-table #f
+         (list (list (make-flow (list a)) 
+                     (make-flow (list (make-paragraph (list (hspace 1)))))
+                     (make-flow (list b)))))]
+@interaction-eval[(print-hash-table #t)]
+
+@title[#:tag "guide:i/o" #:style 'toc]{Input and Output}
+
+A Scheme @defterm{port} represents an input or output stream, such as
+a file, a terminal, a TCP connection, or an in-memory string. More
+specifically, an @defterm{input port} represents a stream from which a
+program can read data, and an @defterm{output port} represents a
+stream for writing data.
+
+@local-table-of-contents[]
+
+@;------------------------------------------------------------------------
+@section{Varieties of Ports}
+
+Various functions create various kinds of ports. Here are a few
+examples:
+
+@itemize{
+
+@;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ @item{@bold{Files:} The @scheme[open-output-file] function opens a
+  file for writing, and @scheme[open-input-file] opens a file for
+  reading.
+
+@interaction-eval[(define old-dir (current-directory))]
+@interaction-eval[(current-directory (find-system-path 'temp-dir))]
+@interaction-eval[(when (file-exists? "data") (delete-file "data"))]
+
+@examples[
+(define out (open-output-file "data"))
+(display "hello" out)
+(close-output-port out)
+(define in (open-input-file "data"))
+(read-line in)
+(close-input-port in)
+]
+
+@interaction-eval[(delete-file "data")]
+
+Instead of having to match @scheme[open-input-file] and
+@scheme[open-output-file] calls, most Scheme programmers will instead
+use @scheme[call-with-output-file], which takes a function to call
+with the output port; when the function returns, the port is closed.
+
+@examples[
+(call-with-output-file "data"
+                        (lambda (out)
+                          (display "hello" out)))
+(call-with-input-file "data"
+                      (lambda (in)
+                        (read-line in)))
+]
+
+@interaction-eval[(delete-file "data")]
+@interaction-eval[(current-directory old-dir)]}
+
+@;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ @item{@bold{Strings:} The @scheme[open-output-string] function creates
+ a port that accumulates data into a string, and @scheme[get-output-string]
+ extracts the accumulated string. The @scheme[open-input-string] function
+ creates a port to read from a string.
+
+  @examples[
+  (define p (open-output-string))
+  (display "hello" p)
+  (get-output-string p)
+  (read-line (open-input-string "goodbye\nfarewell"))
+  ]}
+
+@;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ 
+ @item{@bold{TCP Connections:} The @scheme[tcp-connect] function
+ creates both an input port and an output port for the client side of
+ a TCP communication. The @scheme[tcp-listen] function creates a
+ server, which accepts connections via @scheme[tcp-accept].
+
+  @examples[
+  (eval:alts (define server (tcp-listen 12345)) (void))
+  (eval:alts (define-values (c-in c-out) (tcp-connect "localhost" 12345)) (void))
+  (eval:alts (define-values (s-in s-out) (tcp-accept server))
+             (begin (define-values (s-in c-out) (make-pipe))
+                    (define-values (c-in s-out) (make-pipe))))
+  (display "hello\n" c-out)
+  (read-line s-in)
+  (close-output-port c-out)
+  (read-line s-in)
+  ]}
+
+@;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ 
+ @item{@bold{Process Pipes:} The @scheme[process] function runs a new
+  process at the OS level and returns ports that correspond to the
+  subprocess's stdin, stdout, and stderr. (The first three arguments
+  can be certain kinds of existing ports to connect directly to the
+  subprocess, instead of creating new ports.)
+
+  @examples[
+  (eval:alts
+   (define-values (p stdout stdin stderr)
+     (subprocess #f #f #f "/usr/bin/wc" "-w"))
+   (define-values (p stdout stdin stderr)
+     (values #f (open-input-string "       3") (open-output-string) (open-input-string ""))))
+  (display "a b c\n" stdin)
+  (close-output-port stdin)
+  (read-line stdout)
+  (close-input-port stdout)
+  (close-input-port stderr)
+  ]}
+
+@;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ 
+ @item{@bold{Internal Pipes:} The @scheme[make-pipe] function returns
+ two ports that are ends of a pipe. This kind of pipe is internal to
+ Scheme, and not related to OS-level pipes for communicating between
+ different processes.
+
+ @examples[
+  (define-values (in out) (make-pipe))
+  (display "garbage" out)
+  (close-output-port out)
+  (read-line in)
+ ]}
+
+}
+
+@;------------------------------------------------------------------------
+@section{Default Ports}
+
+For most simple I/O functions, the target port is an optional
+argument, and the default is the @defterm{current input port} or
+@defterm{current output port}. Furthermore, error messages are written
+to the @defterm{current error port}, which is an output port. The
+@scheme[current-input-port], @scheme[current-output-port], and
+@scheme[current-error-port] functions return the corresponding current
+ports.
+
+@examples[
+(display "Hi")
+(code:line (display "Hi" (current-output-port)) (code:comment #, @t{the same}))
+]
+
+If you start the @exec{mzscheme} program in a terminal, then the
+current input, output, and error ports are all connected to the
+terminal. More generally, they are connected to the OS-level stdin,
+stdout, and stderr. In this guide, the examples show output written to
+stdout in purple, and output written to stderr in red italics.
+
+@defexamples[
+(define (swing-hammer)
+  (display "Ouch!" (current-error-port)))
+(swing-hammer)
+]
+
+The current-port functions actually @tech{parameters}, which means
+that their values can be set with @scheme[parameterize].
+
+@moreguide["guide:parameters"]{parameters}
+
+@examples[
+(let ([s (open-output-string)])
+  (parameterize ([current-error-port s])
+    (swing-hammer)
+    (swing-hammer)
+    (swing-hammer))
+  (get-output-string s))
+]
 
 @; ----------------------------------------------------------------------
-@section[#:tag "guide:networking"]{Networking}
+@section{Reading and Writing Scheme Data}
+
+As noted throughout @secref["guide:datatypes"], Scheme provides two
+ways to print an instance of a built-in value:
+
+@itemize{
+
+ @item{ @scheme[write], which prints a value in the same way that is it
+        printed for a @tech{REPL} result; and }
+
+ @item{@scheme[display], which tends to reduce a value to just its
+       character or byte content---at least for those datatypes that
+       are primarily about characters or bytes, otherwise it falls
+       back to the same output as @scheme[write].}
+
+}
+
+@twocolumn[
+
+@interaction[
+(write 1/2)
+(write #\x)
+(write "hello")
+(write #"goodbye")
+(write '|dollar sign|)
+(write '("alphabet" soup))
+(write write)
+]
+
+@interaction[
+(display 1/2)
+(display #\x)
+(display "hello")
+(display #"goodbye")
+(display '|dollar sign|)
+(display '("alphabet" soup))
+(display write)
+]
+
+]
+
+The @scheme[printf] function supports simple formatting of data and
+text. In the format string supplied to @scheme[printf], @litchar{~a}
+@scheme[display]s the enxt argument, while @litchar{~s}
+@scheme[write]s the next argument.
+
+@defexamples[
+(define (deliver who what)
+  (printf "Value for ~a: ~s" who what))
+(deliver "John" "string")
+]
+
+An advantage of @scheme[write] is that many forms of data can be
+read back in using @scheme[read].
+
+@examples[
+(define-values (in out) (make-pipe))
+(write "hello" out)
+(read in)
+(write '("alphabet" soup) out)
+(read in)
+(write #hash((a . "apple") (b . "banana")) out)
+(read in)
+]
+
+@; ----------------------------------------------------------------------
+@subsection{Serialization}
 
 
 @; ----------------------------------------------------------------------
-@include-section["qq.scrbl"]
+@section{Bytes versus Characters}
 

collects/tests/mzscheme/optimize.ss

@@ -442,6 +442,30 @@
               5)
            5)
 
+(test-comp '(letrec-values ([() (values)])
+              5)
+           5)
+
+(test-comp '(let-values ([() (values)]
+                         [(x) 10])
+              x)
+           10)
+
+(test-comp '(letrec-values ([() (values)]
+                            [(x) 10])
+              x)
+           10)
+
+(test-comp '(letrec-values ([(x) 10]
+                            [() (values)])
+              x)
+           10)
+
+(test-comp '(let-values ([(x) 10]
+                         [() (values)])
+              x)
+           10)
+
 (test-comp '(letrec ([x 3]
                      [f (lambda (y) x)])
               f)

collects/tests/mzscheme/read.ss

@@ -982,6 +982,16 @@
         (read (open-input-string
                "!#hash((apple . (red round)) * (banana . (yellow long)))"))))
 
+(test #t hash-table?
+      (parameterize ([current-readtable
+                      (make-readtable #f
+                                      #\% 'terminating-macro
+                                      (lambda (char port . args)
+                                        (let ([v (read-syntax/recursive #f port)])
+                                          v)))])
+        (let ([ht (eval (read-syntax #f (open-input-string "#0=' % % #hash((a . #0#) (b . \"banana\"))")))])
+          (cadr (hash-table-get ht 'a)))))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

src/mzscheme/gc2/sighand.c

@@ -24,7 +24,7 @@ void fault_handler(int sn, struct siginfo *si, void *ctx)
 #endif
 
 /* ========== FreeBSD/NetBSD/OpenBSD signal handler ========== */
-/*  As of 2007/04/28, this is a guess for NetBSD and OpenBSD!  */
+/*  As of 2007/06/29, this is a guess for NetBSD!  */
 #if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
 # include <signal.h>
 void fault_handler(int sn, siginfo_t *si, void *ctx)
@@ -33,7 +33,11 @@ void fault_handler(int sn, siginfo_t *si, void *ctx)
     abort();
 }
 #  define NEED_SIGACTION
-#  define USE_SIGACTON_SIGNAL_KIND SIGBUS
+#  defined(__FreeBSD__)
+#    define USE_SIGACTON_SIGNAL_KIND SIGBUS
+#  else
+#    define USE_SIGACTON_SIGNAL_KIND SIGSEGV
+#  endif
 #endif
 
 /* ========== Solaris signal handler ========== */

src/mzscheme/src/read.c

@@ -1819,26 +1819,32 @@ read_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht,
 #ifdef DO_STACK_CHECK
 static Scheme_Object *resolve_references(Scheme_Object *obj,
 					 Scheme_Object *port,
-					 int mkstx);
+                                         Scheme_Object **dht,
+					 int mkstx,
+                                         int ph_type);
 
 static Scheme_Object *resolve_k(void)
 {
   Scheme_Thread *p = scheme_current_thread;
   Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
   Scheme_Object *port = (Scheme_Object *)p->ku.k.p2;
+  Scheme_Object **dht = (Scheme_Object **)p->ku.k.p3;
 
   p->ku.k.p1 = NULL;
   p->ku.k.p2 = NULL;
+  p->ku.k.p3 = NULL;
 
-  return resolve_references(o, port, p->ku.k.i1);
+  return resolve_references(o, port, dht, p->ku.k.i1, p->ku.k.i2);
 }
 #endif
 
 static Scheme_Object *resolve_references(Scheme_Object *obj,
 					 Scheme_Object *port,
-					 int mkstx)
+					 Scheme_Object **dht,
+					 int mkstx,
+                                         int ph_type)
 {
-  Scheme_Object *start = obj, *result;
+  Scheme_Object *result;
 
 #ifdef DO_STACK_CHECK
   {
@@ -1847,7 +1853,9 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
       Scheme_Thread *p = scheme_current_thread;
       p->ku.k.p1 = (void *)obj;
       p->ku.k.p2 = (void *)port;
+      p->ku.k.p3 = (void *)dht;
       p->ku.k.i1 = mkstx;
+      p->ku.k.i2 = ph_type;
       return scheme_handle_stack_overflow(resolve_k);
     }
   }
@@ -1855,22 +1863,25 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
 
   SCHEME_USE_FUEL(1);
 
-  if (SAME_TYPE(SCHEME_TYPE(obj), scheme_placeholder_type)) {
+  if (SAME_TYPE(SCHEME_TYPE(obj), ph_type)) {
-    /* For placeholders generated by recursive read: */
+    Scheme_Object *start = obj;
-    if (SCHEME_IMMUTABLEP(obj)) {
+    while (SAME_TYPE(SCHEME_TYPE(obj), ph_type)) {
-      obj = (Scheme_Object *)SCHEME_PTR_VAL(obj); 
+      if (SCHEME_IMMUTABLEP(obj)) {
-    } else {
+        /* Placeholder generated by recursive read. */
-      obj = (Scheme_Object *)SCHEME_PTR_VAL(obj);
+        break;
-      while (SAME_TYPE(SCHEME_TYPE(obj), scheme_placeholder_type)) {
+      } else {
-	if (SAME_OBJ(start, obj)) {
+        obj = (Scheme_Object *)SCHEME_PTR_VAL(obj);
-	  scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
+        if (SAME_OBJ(start, obj)) {
-			  "read: illegal cycle");
+          scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
-	  return NULL;
+                          "read: illegal cycle");
-	}
+          return NULL;
-	obj = (Scheme_Object *)SCHEME_PTR_VAL(obj);
+        }
       }
-      return obj;
     }
+    if (!SAME_TYPE(SCHEME_TYPE(obj), ph_type))
+      return obj;
+    else
+      obj = (Scheme_Object *)SCHEME_PTR_VAL(obj); 
   }
 
   result = obj;
@@ -1880,26 +1891,26 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
     /* This check is needed because recursive read-syntax produces
        a placeholder value, and it might be embedded into a larger
        syntax object. */
-    if (SAME_TYPE(SCHEME_TYPE(obj), scheme_placeholder_type)) {
+    if (SAME_TYPE(SCHEME_TYPE(obj), ph_type)) {
       /* Assert: SCHEME_IMMUTABLEP(ph) */
       if (mkstx && !SCHEME_STXP(SCHEME_PTR_VAL(obj))) {
 	/* A placeholder from read/recur used in read-syntax/recur.
 	   Treat it as opaque. */
 	return result;
       }
-      return resolve_references(obj, port, mkstx);
+      return resolve_references(obj, port, dht, mkstx, ph_type);
     }
   }
 
   if (SCHEME_PAIRP(obj)) {
     Scheme_Object *rr;
-    rr = resolve_references(SCHEME_CAR(obj), port, mkstx);
+    rr = resolve_references(SCHEME_CAR(obj), port, dht, mkstx, ph_type);
     SCHEME_CAR(obj) = rr;
-    rr = resolve_references(SCHEME_CDR(obj), port, mkstx);
+    rr = resolve_references(SCHEME_CDR(obj), port, dht, mkstx, ph_type);
     SCHEME_CDR(obj) = rr;
   } else if (SCHEME_BOXP(obj)) {
     Scheme_Object *rr;
-    rr = resolve_references(SCHEME_BOX_VAL(obj), port, mkstx);
+    rr = resolve_references(SCHEME_BOX_VAL(obj), port, dht, mkstx, ph_type);
     SCHEME_BOX_VAL(obj) = rr;
   } else if (SCHEME_VECTORP(obj)) {
     int i, len;
@@ -1913,12 +1924,12 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
 	rr = prev_rr;
       } else {
 	prev_v = SCHEME_VEC_ELS(obj)[i];
-	rr = resolve_references(prev_v, port, mkstx);
+	rr = resolve_references(prev_v, port, dht, mkstx, ph_type);
 	prev_rr = rr;
       }
       SCHEME_VEC_ELS(obj)[i] = rr;
     }
-  } else if (SCHEME_HASHTP(obj)) {
+  } else if ((ph_type == scheme_placeholder_type) && SCHEME_HASHTP(obj)) {
     Scheme_Object *l;
     Scheme_Hash_Table *t = (Scheme_Hash_Table *)obj;
 
@@ -1934,18 +1945,31 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
       /* Make it immutable before we might hash on it */
       SCHEME_SET_IMMUTABLE(obj);
 
-      l = resolve_references(l, port, mkstx);
+      l = resolve_references(l, port, dht, mkstx, ph_type);
 
-      if (mkstx)
+      if (mkstx && dht) {
-	l = scheme_syntax_to_datum(l, 0, NULL);
+        /* Problem: l might still include an "immutable placeholder",
+           which is a result from a recursive read, that is going to
+           be replaced when we return, but isn't replaced, yet.  A
+           syntax->datum conversion now would lose the sharing, and
+           not pick up the later replacement. So, we have to delay the
+           conversion. */
+        Scheme_Object *d;
+        scheme_hash_set(t, an_uninterned_symbol, l);
+        d = scheme_make_raw_pair((Scheme_Object *)t, *dht);
+        *dht = d;
+      } else {
+        if (mkstx)
+          l = scheme_syntax_to_datum(l, 0, NULL);
+        
+        scheme_hash_set(t, an_uninterned_symbol, NULL);
+        for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
+          a = SCHEME_CAR(l);
+          key = SCHEME_CAR(a);
+          val = SCHEME_CDR(a);
 
-      scheme_hash_set(t, an_uninterned_symbol, NULL);
+          scheme_hash_set(t, key, val);
-      for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
+        }
-	a = SCHEME_CAR(l);
-	key = SCHEME_CAR(a);
-	val = SCHEME_CDR(a);
-
-	scheme_hash_set(t, key, val);
       }
     }
   }
@@ -1953,6 +1977,27 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
   return result;
 }
 
+static void fixup_delayed_hash_tables(Scheme_Object *dht)
+{
+  Scheme_Hash_Table *t;
+  Scheme_Object *l, *a, *key, *val;
+
+  while (dht) {
+    t = (Scheme_Hash_Table *)SCHEME_CAR(dht);
+    l = scheme_hash_get(t, an_uninterned_symbol);
+    l = scheme_syntax_to_datum(l, 0, NULL);
+    scheme_hash_set(t, an_uninterned_symbol, NULL);
+    for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
+      a = SCHEME_CAR(l);
+      key = SCHEME_CAR(a);
+      val = SCHEME_CDR(a);
+      
+      scheme_hash_set(t, key, val);
+    }
+    dht = SCHEME_CDR(dht);
+  }
+}
+
 Scheme_Object *
 _scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int honu_mode, 
 		      int recur, int expose_comment, int extra_char, Scheme_Object *init_readtable,
@@ -2040,16 +2085,20 @@ _scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int h
 
     if (*ht && !recur) {
       /* Resolve placeholders: */
+      Scheme_Object *dht = NULL;
+
       if (v)
-	v = resolve_references(v, port, !!stxsrc);
+	v = resolve_references(v, port, &dht, !!stxsrc, scheme_placeholder_type);
 
       /* In case some placeholders were introduced by #;: */
       v2 = scheme_hash_get(*ht, an_uninterned_symbol);
       if (v2)
-	resolve_references(v2, port, !!stxsrc);
+	resolve_references(v2, port, &dht, !!stxsrc, scheme_placeholder_type);
 
       if (!v)
 	*ht = NULL;
+
+      fixup_delayed_hash_tables(dht);
     }
 
     if (!v && expose_comment) {
@@ -2161,9 +2210,9 @@ Scheme_Object *scheme_read_syntax(Scheme_Object *port, Scheme_Object *stxsrc)
   return scheme_internal_read(port, stxsrc, -1, 0, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
 }
 
-Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj, int mkstx)
+Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj, int mkstx, Scheme_Type ph_type)
 {
-  return resolve_references(obj, NULL, mkstx);
+  return resolve_references(obj, NULL, NULL, mkstx, ph_type);
 }
 
 /*========================================================================*/
@@ -4475,7 +4524,16 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
 	  port->ut->rns = rht;
 	}
 
+        if (*port->ht)
+          scheme_ill_formed_code(port);
+
 	v = read_compact(port, 1);
+
+        if (*port->ht) {
+          v = resolve_references(v, NULL, NULL, 0, scheme_placeholder_type);
+          *port->ht = NULL;
+        }
+
 	v = scheme_unmarshal_datum_to_syntax(v, port->ut, ch == CPT_GSTX);
 	scheme_num_read_syntax_objects++;
 	if (!v)
@@ -4903,7 +4961,7 @@ static Scheme_Object *read_compact_quote(CPort *port, int embedded)
   port->ht = old_ht;
 
   if (*q_ht)
-    resolve_references(v, NULL, 0);
+    resolve_references(v, NULL, NULL, 0, scheme_placeholder_type);
 
   return v;
 }
@@ -4969,6 +5027,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
   Scheme_Object **symtab;
   long *so;
   Scheme_Load_Delay *delay_info;
+  Scheme_Hash_Table **local_ht;
   int all_short;
 
   if (USE_LISTSTACK(!p->list_stack))
@@ -5095,9 +5154,11 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
 		    "read (compiled): ill-formed code (bad count: %ld != %ld, started at %ld)",
 		    got, size, rp->base);
 
+  local_ht = MALLOC_N(Scheme_Hash_Table *, 1);
+
   symtab = MALLOC_N(Scheme_Object *, symtabsize);
   rp->symtab_size = symtabsize;
-  rp->ht = ht;
+  rp->ht = local_ht;
   rp->symtab = symtab;
 
   insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
@@ -5138,6 +5199,12 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
   /* Read main body: */
   result = read_marshalled(scheme_compilation_top_type, rp);
 
+  if (*local_ht) {
+    scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
+		    "read (compiled): ill-formed code (unexpected graph structure)");
+    return NULL;
+  }
+
   if (SAME_TYPE(SCHEME_TYPE(result), scheme_compilation_top_type)) {
     Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)result;
 
@@ -5203,7 +5270,7 @@ Scheme_Object *scheme_load_delayed_code(int which, Scheme_Load_Delay *delay_info
   delay_info->symtab[which] = v;
 
   if (*ht) {
-    resolve_references(v, NULL, 0);
+    resolve_references(v, NULL, NULL, 0, scheme_placeholder_type);
   }
   
   return v;
@@ -5850,6 +5917,9 @@ static Scheme_Object *copy_to_protect(Scheme_Object *v, Scheme_Object *src, Sche
       SCHEME_SET_VECTOR_IMMUTABLE(o);
   } else {
     /* Assert: !ph */
+    /* We don't need special handling for hash tables here, 
+       becase they're only traversed for graphs when they're under
+       a placeholder. */
     return v;
   }
 

src/mzscheme/src/schpriv.h

@@ -695,7 +695,7 @@ int scheme_stx_proper_list_length(Scheme_Object *list);
 
 Scheme_Object *scheme_stx_extract_marks(Scheme_Object *stx);
 
-Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj, int mkstx);
+Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj, int mkstx, Scheme_Type ph_type);
 Scheme_Hash_Table *scheme_setup_datum_graph(Scheme_Object *o, void *for_print);
 
 Scheme_Object *scheme_stx_strip_module_context(Scheme_Object *stx);

src/mzscheme/src/stxobj.c

@@ -22,6 +22,9 @@
 #include "schpriv.h"
 #include "schmach.h"
 
+/* REMOVEME */
+# define scheme_stx_placeholder_type scheme_multiple_values_type
+
 /* The implementation of syntax objects is extremely complex due to
    two levels of optimization:
 
@@ -2433,7 +2436,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
 	  return ph;
 	else {
 	  ph = scheme_alloc_small_object();
-	  ph->type = scheme_placeholder_type;
+	  ph->type = scheme_stx_placeholder_type;
       
 	  scheme_hash_set(*ht, key, (Scheme_Object *)ph);
 	}
@@ -2500,7 +2503,7 @@ static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active)
     o = add_certs(o, certs, NULL, as_active);
 
   if (ht)
-    o = scheme_resolve_placeholders(o, 1);
+    o = scheme_resolve_placeholders(o, 1, scheme_stx_placeholder_type);
 
   return o;
 }
@@ -4413,7 +4416,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o,
       return ph;
     else {
       ph = scheme_alloc_small_object();
-      ph->type = scheme_placeholder_type;
+      ph->type = scheme_stx_placeholder_type;
       
       scheme_hash_set(*ht, key, (Scheme_Object *)ph);
     }
@@ -4595,7 +4598,7 @@ Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_marks,
   }
 
   if (ht)
-    v = scheme_resolve_placeholders(v, 0);
+    v = scheme_resolve_placeholders(v, 0, scheme_stx_placeholder_type);
 
   return v;
 }
@@ -5137,7 +5140,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
       if (val != 1) {
 	if (val & 0x1) {
 	  ph = scheme_alloc_small_object();
-	  ph->type = scheme_placeholder_type;
+	  ph->type = scheme_stx_placeholder_type;
 	  scheme_hash_set(ht, o, (Scheme_Object *)ph);
 	} else {
 	  return (Scheme_Object *)val;
@@ -5351,7 +5354,7 @@ static Scheme_Object *general_datum_to_syntax(Scheme_Object *o,
   }
 
   if (ht)
-    v = scheme_resolve_placeholders(v, 1);
+    v = scheme_resolve_placeholders(v, 1, scheme_stx_placeholder_type);
 
   if (copy_props > 0)
     ((Scheme_Stx *)v)->props = ((Scheme_Stx *)stx_src)->props;

src/mzscheme/src/type.c

@@ -26,6 +26,9 @@
 #include "schpriv.h"
 #include <string.h>
 
+/* REMOVEME */
+# define scheme_stx_placeholder_type scheme_multiple_values_type
+
 Scheme_Type_Reader *scheme_type_readers;
 Scheme_Type_Writer *scheme_type_writers;
 Scheme_Equal_Proc *scheme_type_equals;
@@ -170,8 +173,8 @@ scheme_init_type (Scheme_Env *env)
   set_name(scheme_bucket_table_type, "<hash-table>");
   set_name(scheme_module_registry_type, "<module-registry>");
   set_name(scheme_case_closure_type, "<procedure>");
-  set_name(scheme_multiple_values_type, "<multiple-values>");
   set_name(scheme_placeholder_type, "<placeholder>");
+  set_name(scheme_stx_placeholder_type, "<syntax<->datum-placeholder>");
   set_name(scheme_weak_box_type, "<weak-box>");
   set_name(scheme_ephemeron_type, "<ephemeron>");
   set_name(scheme_rational_type, "<fractional-number>");
@@ -558,8 +561,8 @@ void scheme_register_traversers(void)
   GC_REG_TRAV(scheme_eval_waiting_type, bad_trav);
   GC_REG_TRAV(scheme_tail_call_waiting_type, bad_trav);
   GC_REG_TRAV(scheme_undefined_type, char_obj); /* small */
-  GC_REG_TRAV(scheme_multiple_values_type, bad_trav);
   GC_REG_TRAV(scheme_placeholder_type, small_object);
+  GC_REG_TRAV(scheme_stx_placeholder_type, small_object);
   GC_REG_TRAV(scheme_case_lambda_sequence_type, case_closure);
   GC_REG_TRAV(scheme_begin0_sequence_type, seq_rec);