From b883f4ef765c783d4a013b76ebdbb2f6b7a8acd0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 Jun 2007 22:59:06 +0000 Subject: [PATCH] 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 | 3 +- collects/scribble/eval.ss | 66 ++++--- collects/scribble/html-render.ss | 42 +++-- collects/scribble/scheme.ss | 13 +- collects/scribble/scribble.css | 7 +- collects/scribblings/guide/data.scrbl | 2 +- collects/scribblings/guide/guide.scrbl | 8 +- collects/scribblings/guide/io.scrbl | 245 ++++++++++++++++++++++++- collects/tests/mzscheme/optimize.ss | 24 +++ collects/tests/mzscheme/read.ss | 10 + src/mzscheme/gc2/sighand.c | 8 +- src/mzscheme/src/read.c | 154 +++++++++++----- src/mzscheme/src/schpriv.h | 2 +- src/mzscheme/src/stxobj.c | 15 +- src/mzscheme/src/type.c | 7 +- 15 files changed, 486 insertions(+), 120 deletions(-) diff --git a/collects/mzlib/cm.ss b/collects/mzlib/cm.ss index ef2abd2388..11a1a31340 100644 --- a/collects/mzlib/cm.ss +++ b/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")) diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss index 92d9502489..fb36237203 100644 --- a/collects/scribble/eval.ss +++ b/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)) - null - (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))))))))) + (format-output (cadar val-list+outputs) "schemestdout") + (format-output (caddar val-list+outputs) "schemeerror") (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)]) - (parameterize ([current-output-port o]) + (let ([o (open-output-string)] + [o2 (open-output-string)]) + (parameterize ([current-output-port o] + [current-error-port o2]) (with-handlers ([exn? (lambda (e) - (cons (exn-message e) - (get-output-string o)))]) - (cons (let ([v (do-plain-eval s #t)]) + (list (exn-message e) + (get-output-string o) + (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) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index fddce7dab4..2566865be7 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -77,27 +77,29 @@ (class "tocviewlink")) ,@(render-content (part-title-content top) d ht))) (div nbsp) - (div - ((class "tocviewlist")) + (table + ((class "tocviewlist") + (cellspacing "0")) ,@(map (lambda (p) - `(div - ((class "tocviewitem")) - (a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))]) - (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) - "tocviewselflink" - "tocviewlink"))) - ,@(format-number (collected-info-number (part-collected-info p)) - '((tt nbsp))) - ,@(render-content (part-title-content p) d ht)))) + `(tr + (td + ,@(format-number (collected-info-number (part-collected-info p)) + '((tt nbsp)))) + (td + (a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))]) + (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) + "tocviewselflink" + "tocviewlink"))) + ,@(render-content (part-title-content p) d ht))))) (part-parts top))))))) (define/public (render-one-part d ht fn number) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index c762f20554..16dd478f7e 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -338,11 +338,14 @@ "#hash" "#hasheq") value-color) - (set! src-col (+ src-col 5 (if equal-table? 2 0))) - (hash-table-put! next-col-map src-col dest-col) - ((loop init-line! +inf.0) - (syntax-ize (hash-table-map (syntax-e c) cons) - (syntax-column c))))] + (let ([delta (+ 5 (if equal-table? 2 0))] + [orig-col src-col]) + (set! src-col (+ src-col delta)) + (hash-table-put! next-col-map src-col dest-col) + ((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?) diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css index 2310f499a3..56b2c80c6a 100644 --- a/collects/scribble/scribble.css +++ b/collects/scribble/scribble.css @@ -51,13 +51,12 @@ } .tocviewlist { - font-size: 80%; margin: 0.2em 0.2em 0.2em 0.2em; } - .tocviewitem { - margin-left: 1em; - text-indent: -1em; + .tocviewlist td { + font-size: 80%; + vertical-align: top; } .tocviewlink { diff --git a/collects/scribblings/guide/data.scrbl b/collects/scribblings/guide/data.scrbl index dc6bfabca3..6987f0a6c8 100644 --- a/collects/scribblings/guide/data.scrbl +++ b/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 diff --git a/collects/scribblings/guide/guide.scrbl b/collects/scribblings/guide/guide.scrbl index 94ffc21159..3f8a6f2d9e 100644 --- a/collects/scribblings/guide/guide.scrbl +++ b/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)} diff --git a/collects/scribblings/guide/io.scrbl b/collects/scribblings/guide/io.scrbl index 8301e545da..ae2fb493ff 100644 --- a/collects/scribblings/guide/io.scrbl +++ b/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} diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index 9d0d66b53f..d7bf0df803 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/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) diff --git a/collects/tests/mzscheme/read.ss b/collects/tests/mzscheme/read.ss index 1d1f1a2f52..21cf4a8598 100644 --- a/collects/tests/mzscheme/read.ss +++ b/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) diff --git a/src/mzscheme/gc2/sighand.c b/src/mzscheme/gc2/sighand.c index f612b5d0b9..f3a13d99a5 100644 --- a/src/mzscheme/gc2/sighand.c +++ b/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 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 ========== */ diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index 3af2b2f176..31007ead04 100644 --- a/src/mzscheme/src/read.c +++ b/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)) { - /* For placeholders generated by recursive read: */ - if (SCHEME_IMMUTABLEP(obj)) { - obj = (Scheme_Object *)SCHEME_PTR_VAL(obj); - } else { - obj = (Scheme_Object *)SCHEME_PTR_VAL(obj); - while (SAME_TYPE(SCHEME_TYPE(obj), scheme_placeholder_type)) { - if (SAME_OBJ(start, obj)) { - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read: illegal cycle"); - return NULL; - } - obj = (Scheme_Object *)SCHEME_PTR_VAL(obj); + if (SAME_TYPE(SCHEME_TYPE(obj), ph_type)) { + Scheme_Object *start = obj; + while (SAME_TYPE(SCHEME_TYPE(obj), ph_type)) { + if (SCHEME_IMMUTABLEP(obj)) { + /* Placeholder generated by recursive read. */ + break; + } else { + obj = (Scheme_Object *)SCHEME_PTR_VAL(obj); + if (SAME_OBJ(start, obj)) { + scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, + "read: illegal cycle"); + return NULL; + } } - 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) - l = scheme_syntax_to_datum(l, 0, NULL); + if (mkstx && dht) { + /* 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); - 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); + 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; } diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 43d9636ed6..dacaf3cb70 100644 --- a/src/mzscheme/src/schpriv.h +++ b/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); diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 20dc4d4f06..249dc0ef28 100644 --- a/src/mzscheme/src/stxobj.c +++ b/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; diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c index 21dc2c7218..b0fb909c7b 100644 --- a/src/mzscheme/src/type.c +++ b/src/mzscheme/src/type.c @@ -26,6 +26,9 @@ #include "schpriv.h" #include +/* 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, ""); set_name(scheme_module_registry_type, ""); set_name(scheme_case_closure_type, ""); - set_name(scheme_multiple_values_type, ""); set_name(scheme_placeholder_type, ""); + set_name(scheme_stx_placeholder_type, "datum-placeholder>"); set_name(scheme_weak_box_type, ""); set_name(scheme_ephemeron_type, ""); set_name(scheme_rational_type, ""); @@ -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);