suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r6759
This commit is contained in:
Matthew Flatt 2007-06-28 22:59:06 +00:00
parent 2bc5b127f7
commit b883f4ef76
15 changed files with 486 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mzlib/cm.ss
View File

@ -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"))

66
collects/scribble/eval.ss
View File

@ -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)

42
collects/scribble/html-render.ss
View File

@ -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)

13
collects/scribble/scheme.ss
View File

@ -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?)

7
collects/scribble/scribble.css
View File

@ -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 {

2
collects/scribblings/guide/data.scrbl
View File

@ -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

8
collects/scribblings/guide/guide.scrbl
View File

@ -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)}

245
collects/scribblings/guide/io.scrbl
View File

@ -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}

24
collects/tests/mzscheme/optimize.ss
View File

@ -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)

10
collects/tests/mzscheme/read.ss
View File

@ -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)

8
src/mzscheme/gc2/sighand.c
View File

@ -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 ========== */

154
src/mzscheme/src/read.c
View File

@ -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;
}

2
src/mzscheme/src/schpriv.h
View File

@ -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);

15
src/mzscheme/src/stxobj.c
View File

@ -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;

7
src/mzscheme/src/type.c
View File

@ -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);