add "externals" fasl support, allow non-strings in sfd
"Externals" supports fasling with some values lifted out an provided separately. Lifting the restriction on source file descriptor paths, formerly to strings, means that paths can be represented in a different way, and they can be fasled through a different means than the built-in encodings. original commit: b6b0ae67b08f2e9bc8b7fafe5ebad0375b6ce9db
This commit is contained in:
Matthew Flatt
parent
f73220d0ec
commit
ec05bac0cf
|
|
@ -107,8 +107,8 @@ extern void S_phantom_bytevector_adjust PROTO((ptr ph, uptr new_sz));
|
|||
|
||||
/* fasl.c */
|
||||
extern void S_fasl_init PROTO((void));
|
||||
ptr S_fasl_read PROTO((INT fd, IFASLCODE situation, ptr path));
|
||||
ptr S_bv_fasl_read PROTO((ptr bv, int ty, uptr offset, uptr len, ptr path));
|
||||
ptr S_fasl_read PROTO((INT fd, IFASLCODE situation, ptr path, ptr externals));
|
||||
ptr S_bv_fasl_read PROTO((ptr bv, int ty, uptr offset, uptr len, ptr path, ptr externals));
|
||||
ptr S_boot_read PROTO((INT fd, const char *path));
|
||||
char *S_format_scheme_version PROTO((uptr n));
|
||||
char *S_lookup_machine_type PROTO((uptr n));
|
||||
|
|
|
|||
33
c/fasl.c
33
c/fasl.c
|
|
@ -218,8 +218,8 @@ typedef struct faslFileObj {
|
|||
static INT uf_read PROTO((unbufFaslFile uf, octet *s, iptr n));
|
||||
static octet uf_bytein PROTO((unbufFaslFile uf));
|
||||
static uptr uf_uptrin PROTO((unbufFaslFile uf, INT *bytes_consumed));
|
||||
static ptr fasl_entry PROTO((ptr tc, IFASLCODE situation, unbufFaslFile uf));
|
||||
static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, IFASLCODE ty, uptr offset, uptr len, unbufFaslFile uf));
|
||||
static ptr fasl_entry PROTO((ptr tc, IFASLCODE situation, unbufFaslFile uf, ptr externals));
|
||||
static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, IFASLCODE ty, uptr offset, uptr len, unbufFaslFile uf, ptr externals));
|
||||
static void fillFaslFile PROTO((faslFile f));
|
||||
static void bytesin PROTO((octet *s, iptr n, faslFile f));
|
||||
static void toolarge PROTO((ptr path));
|
||||
|
|
@ -298,7 +298,7 @@ void S_fasl_init() {
|
|||
#endif
|
||||
}
|
||||
|
||||
ptr S_fasl_read(INT fd, IFASLCODE situation, ptr path) {
|
||||
ptr S_fasl_read(INT fd, IFASLCODE situation, ptr path, ptr externals) {
|
||||
ptr tc = get_thread_context();
|
||||
ptr x; struct unbufFaslFileObj uffo;
|
||||
|
||||
|
|
@ -307,12 +307,12 @@ ptr S_fasl_read(INT fd, IFASLCODE situation, ptr path) {
|
|||
uffo.path = path;
|
||||
uffo.type = UFFO_TYPE_FD;
|
||||
uffo.fd = fd;
|
||||
x = fasl_entry(tc, situation, &uffo);
|
||||
x = fasl_entry(tc, situation, &uffo, externals);
|
||||
tc_mutex_release()
|
||||
return x;
|
||||
}
|
||||
|
||||
ptr S_bv_fasl_read(ptr bv, int ty, uptr offset, uptr len, ptr path) {
|
||||
ptr S_bv_fasl_read(ptr bv, int ty, uptr offset, uptr len, ptr path, ptr externals) {
|
||||
ptr tc = get_thread_context();
|
||||
ptr x; struct unbufFaslFileObj uffo;
|
||||
|
||||
|
|
@ -320,7 +320,7 @@ ptr S_bv_fasl_read(ptr bv, int ty, uptr offset, uptr len, ptr path) {
|
|||
tc_mutex_acquire()
|
||||
uffo.path = path;
|
||||
uffo.type = UFFO_TYPE_BV;
|
||||
x = bv_fasl_entry(tc, bv, ty, offset, len, &uffo);
|
||||
x = bv_fasl_entry(tc, bv, ty, offset, len, &uffo, externals);
|
||||
tc_mutex_release()
|
||||
return x;
|
||||
}
|
||||
|
|
@ -332,7 +332,7 @@ ptr S_boot_read(INT fd, const char *path) {
|
|||
uffo.path = Sstring_utf8(path, -1);
|
||||
uffo.type = UFFO_TYPE_FD;
|
||||
uffo.fd = fd;
|
||||
return fasl_entry(tc, fasl_type_visit_revisit, &uffo);
|
||||
return fasl_entry(tc, fasl_type_visit_revisit, &uffo, S_G.null_vector);
|
||||
}
|
||||
|
||||
#ifdef WIN32
|
||||
|
|
@ -432,7 +432,7 @@ char *S_lookup_machine_type(uptr n) {
|
|||
return "unknown";
|
||||
}
|
||||
|
||||
static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf) {
|
||||
static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf, ptr externals) {
|
||||
ptr x; ptr strbuf = S_G.null_string;
|
||||
octet tybuf[1]; IFASLCODE ty; iptr size;
|
||||
/* gcc (GCC) 4.8.5 20150623 (Red Hat 4.8.5-28) co-locates buf and x if we put the declaration of buf down where we use it */
|
||||
|
|
@ -534,7 +534,7 @@ static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf) {
|
|||
}
|
||||
switch (kind) {
|
||||
case fasl_type_fasl:
|
||||
faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
|
||||
faslin(tc, &x, externals, &strbuf, &ffo);
|
||||
break;
|
||||
case fasl_type_vfasl:
|
||||
x = S_vfasl(bv, uf, 0, ffo.size);
|
||||
|
|
@ -551,7 +551,7 @@ static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf) {
|
|||
}
|
||||
}
|
||||
|
||||
static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFaslFile uf) {
|
||||
static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFaslFile uf, ptr externals) {
|
||||
ptr x; ptr strbuf = S_G.null_string;
|
||||
struct faslFileObj ffo;
|
||||
|
||||
|
|
@ -563,7 +563,7 @@ static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFas
|
|||
ffo.end = &BVIT(bv, offset + len);
|
||||
ffo.uf = uf;
|
||||
|
||||
faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
|
||||
faslin(tc, &x, externals, &strbuf, &ffo);
|
||||
} else {
|
||||
S_error1("", "bad entry type (got ~s)", FIX(ty));
|
||||
}
|
||||
|
|
@ -1053,9 +1053,16 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
|
|||
case fasl_type_phantom:
|
||||
*x = S_phantom_bytevector(uptrin(f));
|
||||
return;
|
||||
case fasl_type_graph:
|
||||
faslin(tc, x, S_vector(uptrin(f)), pstrbuf, f);
|
||||
case fasl_type_graph: {
|
||||
uptr len = uptrin(f), len2, i;
|
||||
ptr new_t = S_vector(len);
|
||||
len2 = Svector_length(t);
|
||||
if (len2 > len) len2 = len;
|
||||
for (i = 0; i < len2; i++)
|
||||
INITVECTIT(new_t, i+(len-len2)) = Svector_ref(t, i);
|
||||
faslin(tc, x, new_t, pstrbuf, f);
|
||||
return;
|
||||
}
|
||||
case fasl_type_graph_def: {
|
||||
ptr *p;
|
||||
p = &INITVECTIT(t, uptrin(f));
|
||||
|
|
|
|||
26
csug/io.stex
26
csug/io.stex
|
|
@ -3379,17 +3379,32 @@ input port, must be used instead.
|
|||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{fasl-write}{\categoryprocedure}{(fasl-write \var{obj} \var{binary-output-port})}
|
||||
\formdef{fasl-write}{\categoryprocedure}{(fasl-write \var{obj} \var{binary-output-port} \var{external-pred})}
|
||||
\returns unspecified
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\noindent
|
||||
If \var{externals-pred} is provided, it must be a procedure or \scheme{#f}.
|
||||
|
||||
\scheme{fasl-write} writes the fasl representation of \var{obj} to
|
||||
\var{binary-output-port}.
|
||||
An exception is raised with condition-type \scheme{&assertion} if
|
||||
\var{obj} or any portion of \var{obj} has no external fasl representation,
|
||||
e.g., if \var{obj} is or contains a procedure.
|
||||
|
||||
If \var{externals-pred} is provided and not \scheme{#f}, then it is
|
||||
applied to each distinct object encountered in \var{obj}. If
|
||||
\var{externals-pred} returns true for an object, that object is not
|
||||
written to the fasl representation. Instead, a placeholder is written
|
||||
containing as position as the number of preceding calls to
|
||||
\var{externals-pred} that had returned true. Typically, for each
|
||||
object where it returns true, \var{externals-pred} saves the object
|
||||
through its closure. When the fasl representation is read with
|
||||
\scheme{fasl-read}, a vector with as many items as generated positions
|
||||
must be provided, and each placeholder is replaced with the
|
||||
corresponding vector element.
|
||||
|
||||
The fasl representation of \var{obj} is compressed if the parameter
|
||||
\scheme{fasl-compressed}, described below, is set to \scheme{#t},
|
||||
its default value.
|
||||
|
|
@ -3415,14 +3430,16 @@ fasl objects from a compressed file.
|
|||
\entryheader
|
||||
\formdef{fasl-read}{\categoryprocedure}{(fasl-read \var{binary-input-port})}
|
||||
\formdef{fasl-read}{\categoryprocedure}{(fasl-read \var{binary-input-port \var{situation}})}
|
||||
\formdef{fasl-read}{\categoryprocedure}{(fasl-read \var{binary-input-port \var{situation} \var{externals}})}
|
||||
\returns unspecified
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\noindent
|
||||
If present, \var{situation} must be one of the symbols \scheme{load},
|
||||
\scheme{visit}, or \scheme{revisit}.
|
||||
It defaults to \scheme{load}.
|
||||
\scheme{visit}, or \scheme{revisit}, and it defaults to \scheme{load}.
|
||||
If present, \var{exterrnals} must be a vector, and it defaults to
|
||||
\scheme{'#()}.
|
||||
|
||||
\scheme{fasl-read} reads one object from
|
||||
\var{binary-input-port}, which must be positioned at the
|
||||
|
|
@ -3439,6 +3456,11 @@ corresponding to source code within an \scheme{eval-when} form with
|
|||
situation \scheme{load} or situations \scheme{visit} and \scheme{revisit})
|
||||
are never skipped.
|
||||
|
||||
The \var{externals} vector should have the same length as the number
|
||||
of true-returning calls to \var{external-pred} during the
|
||||
\scheme{fasl-write} call that produced the fasl rrepresentation. See
|
||||
\scheme{fasl-write} for more information.
|
||||
|
||||
\scheme{fasl-read} automatically decompresses the representation
|
||||
of each fasl object written in compressed format by \scheme{fasl-write}.
|
||||
Thus, \var{binary-input-port} generally should not be opened with
|
||||
|
|
|
|||
|
|
@ -1613,7 +1613,7 @@ source file to make sure that the proper file has been found and
|
|||
has not been modified.
|
||||
Source-file descriptors can be created with
|
||||
\index{\scheme{make-source-file-descriptor}}\scheme{make-source-file-descriptor},
|
||||
which accepts two arguments: a string naming the path and a binary
|
||||
which accepts two arguments: an object (usually a string) naming the path and a binary
|
||||
input port, along with an optional third boolean argument, \var{reset?},
|
||||
which defaults to false.
|
||||
\scheme{make-source-file-descriptor} computes a checksum based on
|
||||
|
|
@ -1642,8 +1642,8 @@ and described in more detail later in this section.
|
|||
(source-object-line \var{source-object}) ;-> \var{uint} or #f
|
||||
(source-object-column \var{source-object}) ;-> \var{uint} or #f
|
||||
|
||||
(make-source-file-descriptor \var{string} \var{binary-input-port}) ;-> \var{sfd}
|
||||
(make-source-file-descriptor \var{string} \var{binary-input-port} \var{reset?}) ;-> \var{sfd}
|
||||
(make-source-file-descriptor \var{obj} \var{binary-input-port}) ;-> \var{sfd}
|
||||
(make-source-file-descriptor \var{obj} \var{binary-input-port} \var{reset?}) ;-> \var{sfd}
|
||||
(source-file-descriptor? \var{obj}) ;-> \var{boolean}
|
||||
(source-file-descriptor-checksum \var{sfd}) ;-> \var{obj}
|
||||
(source-file-descriptor-path \var{sfd}) ;-> \var{obj}
|
||||
|
|
@ -1836,8 +1836,8 @@ to a file-position object, instead of delaying the conversion to
|
|||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{make-source-file-descriptor}{\categoryprocedure}{(make-source-file-descriptor \var{string} \var{binary-input-port})}
|
||||
\formdef{make-source-file-descriptor}{\categoryprocedure}{(make-source-file-descriptor \var{string} \var{binary-input-port} \var{reset?})}
|
||||
\formdef{make-source-file-descriptor}{\categoryprocedure}{(make-source-file-descriptor \var{obj} \var{binary-input-port})}
|
||||
\formdef{make-source-file-descriptor}{\categoryprocedure}{(make-source-file-descriptor \var{obj} \var{binary-input-port} \var{reset?})}
|
||||
\returns a source-file descriptor
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
|
@ -1870,16 +1870,17 @@ Otherwise, it is left pointing at end-of-file.
|
|||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\var{sfd} must be a source-file descriptor.
|
||||
\var{sfd} must be a source-file descriptor. The result is typically a string, but a
|
||||
source file descriptor can have any value representing a path.
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{source-file-descriptor}{\categoryprocedure}{(source-file-descriptor \var{path} \var{checksum})}
|
||||
\formdef{source-file-descriptor}{\categoryprocedure}{(source-file-descriptor \var{obj} \var{checksum})}
|
||||
\returns a new source-file-descriptor
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\var{path} must be a string, and \var{checksum} must be an exact nonnegative integer.
|
||||
\var{checksum} must be an exact nonnegative integer.
|
||||
This procedure can be used to construct custom source-file descriptors or to reconstitute
|
||||
source-file descriptors from the \var{path} and \var{checksum} components.
|
||||
|
||||
|
|
@ -1958,7 +1959,7 @@ exact nonnegative integer.
|
|||
This procedure either uses cached information from a previous
|
||||
request for \var{sfd} (only when \var{use-cache?} is provided as true)
|
||||
or attempts to locate and open the source file identified
|
||||
by \var{sfd}.
|
||||
by \var{sfd} (which can only work when its path is a string).
|
||||
If successful, it returns three values: a string \var{path}, an exact
|
||||
nonnegative integer \var{line}, and an exact nonnegative integer \var{char}
|
||||
representing the absolute pathname, line, and character position within
|
||||
|
|
|
|||
|
|
@ -1031,6 +1031,7 @@ will occur when the files are actually loaded.
|
|||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{load-compiled-from-port}{\categoryprocedure}{(load-compiled-from-port \var{input-port})}
|
||||
\formdef{load-compiled-from-port}{\categoryprocedure}{(load-compiled-from-port \var{input-port} \var{externals})}
|
||||
\returns result of the last compiled expression
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
|
@ -1041,6 +1042,11 @@ of \var{input-port} as previously created by functions like \scheme{compile-file
|
|||
\scheme{compile-script}, \scheme{compile-library}, and
|
||||
\scheme{compile-to-port}.
|
||||
|
||||
The \var{externals} argument, if supplied, must be a vector. It should
|
||||
cooperate with an \var{external-pred} procedure passed to
|
||||
\scheme{compile-to-port}, analogous to the way a procedure and vector
|
||||
cooperate with \scheme{fasl-write} and \scheme{fasl-read}.
|
||||
|
||||
The return value is the value of the last expression whose compiled
|
||||
form is in \var{input-port}. If \var{input-port} is empty, then the
|
||||
result value is unspecified.
|
||||
|
|
@ -1520,6 +1526,7 @@ will take care of closing the ports.
|
|||
\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd})}
|
||||
\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd} \var{wpo-port})}
|
||||
\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd} \var{wpo-port} \var{covop})}
|
||||
\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd} \var{wpo-port} \var{covop} \var{external-pred})}
|
||||
\returns see below
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
|
@ -1533,6 +1540,8 @@ expression, \scheme{compile-to-port} raises an exception with
|
|||
condition type \scheme{&syntax}.
|
||||
\var{output-port} and, if present, \var{wpo-port} must be binary output ports.
|
||||
If present, \var{sfd} must be a source-file descriptor.
|
||||
If present, \var{external-pred} must be \scheme{#f} or a procedure,
|
||||
and it must be \scheme{#f} if \var{obj-list} does not have exactlty one element.
|
||||
|
||||
\scheme{compile-to-port} is like \scheme{compile-file} except that it takes
|
||||
input from a list of objects and sends output to an arbitrary binary
|
||||
|
|
@ -1549,6 +1558,12 @@ The ports are not closed automatically after compilation under the assumption
|
|||
the program that opens the port and invokes \scheme{compile-to-port}
|
||||
will take care of closing the port.
|
||||
|
||||
If \var{external-pred} is present and not \scheme{#f}, it is used like
|
||||
the predicate supplied to \scheme{fasl-write}. In that case, a
|
||||
corresponding vector must be provided to
|
||||
\scheme{load-compiled-from-port} to load the compiled code, analogous
|
||||
to the vector supplied to \scheme{fasl-read}.
|
||||
|
||||
When \var{obj-list} contains a single list-structured element whose
|
||||
first-element is the symbol \scheme{top-level-program},
|
||||
\scheme{compile-to-port} returns a list of the libraries the top-level
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ InstallLZ4Target=
|
|||
# no changes should be needed below this point #
|
||||
###############################################################################
|
||||
|
||||
Version=csv9.5.3.33
|
||||
Version=csv9.5.3.34
|
||||
Include=boot/$m
|
||||
PetiteBoot=boot/$m/petite.boot
|
||||
SchemeBoot=boot/$m/scheme.boot
|
||||
|
|
|
|||
12
mats/6.ms
12
mats/6.ms
|
|
@ -993,6 +993,18 @@
|
|||
(weak-pair? (cddr ls))
|
||||
(weak-pair? (cdddr ls)))))
|
||||
'(#t #f #t #t #f #t))
|
||||
|
||||
(error? (fasl-write 'any (let-values ([(o get) (open-bytevector-output-port)]) o) '#()))
|
||||
(error? (fasl-write 'any (let-values ([(o get) (open-bytevector-output-port)]) o) 10))
|
||||
(error? (fasl-read (open-bytevector-input-port #vu8()) 'load #f))
|
||||
(error? (fasl-read (open-bytevector-input-port #vu8()) 'load 10))
|
||||
|
||||
(let-values ([(o get) (open-bytevector-output-port)])
|
||||
(fasl-write '(apple (banana cream pie) (vector coconut banana cream)) o (lambda (v)
|
||||
(or (eq? v 'banana)
|
||||
(eq? v 'coconut))))
|
||||
(equal? '(apple (B cream pie) (vector C B cream))
|
||||
(fasl-read (open-bytevector-input-port (get)) 'load '#(B C))))
|
||||
)
|
||||
|
||||
(mat fasl-depth
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@
|
|||
)
|
||||
|
||||
(mat load-compiled-from-port
|
||||
(begin
|
||||
(let ()
|
||||
(define-values (o get) (open-bytevector-output-port))
|
||||
(compile-to-port '((define lcfp1 'worked) 'loaded) o)
|
||||
(eq? 'loaded (load-compiled-from-port (open-bytevector-input-port (get)))))
|
||||
|
|
@ -138,6 +138,12 @@
|
|||
(equal?
|
||||
(with-output-to-string (lambda () (printf "result = ~s\n" (revisit-compiled-from-port (open-bytevector-input-port lcfp-bv)))))
|
||||
"revisit\nvisit-revisit\nresult = revisit-return\n")
|
||||
|
||||
|
||||
(let ()
|
||||
(define-values (o get) (open-bytevector-output-port))
|
||||
(compile-to-port '((lambda () 'banana)) o #f #f #f (machine-type) #f (lambda (v) (eq? v 'banana)))
|
||||
(eq? 'apple ((load-compiled-from-port (open-bytevector-input-port (get)) '#(apple)))))
|
||||
)
|
||||
|
||||
(mat compile-to-file
|
||||
|
|
|
|||
|
|
@ -11356,8 +11356,8 @@
|
|||
)
|
||||
|
||||
(mat annotations
|
||||
(error? ; #f is not a string
|
||||
(make-source-file-descriptor #f
|
||||
(source-file-descriptor?
|
||||
(make-source-file-descriptor #f ; anything is allowed as a path
|
||||
(open-bytevector-input-port (string->utf8 "hello"))))
|
||||
(error? ; 17 is not a binary-input port
|
||||
(make-source-file-descriptor "foo" 17))
|
||||
|
|
@ -11584,7 +11584,7 @@
|
|||
(eq? (source-object-sfd source) sfd)
|
||||
(eqv? (source-object-bfp source) 0)
|
||||
(eqv? (source-object-efp source) (string-length str))
|
||||
(error? ; not a string
|
||||
(source-file-descriptor?
|
||||
(source-file-descriptor 'spam 0))
|
||||
(error? ; not an exact nonnegative integer
|
||||
(source-file-descriptor "spam" -1))
|
||||
|
|
@ -11605,6 +11605,7 @@
|
|||
(error? ; not an exact nonnegative integer
|
||||
(locate-source sfd 'a))
|
||||
(let-values ([() (locate-source sfd 7)]) #t)
|
||||
(let-values ([() (locate-source (source-file-descriptor 'something-else 0) 7)]) #t)
|
||||
(begin
|
||||
(with-output-to-file "testfile.ss"
|
||||
(lambda ()
|
||||
|
|
|
|||
|
|
@ -33,6 +33,8 @@ primvars.mo:Expected error testing (fxpopcount (quote #!eof)): Exception in fxpo
|
|||
primvars.mo:Expected error testing (fxpopcount (quote #f)): Exception in fxpopcount32: #f is not a non-negative fixnum
|
||||
primvars.mo:Expected error testing (hashtable-cells (quote ((a . b)))): Exception in hashtable-size: ((a . b)) is not a hashtable
|
||||
primvars.mo:Expected error testing (hashtable-cells (quote #f)): Exception in hashtable-size: #f is not a hashtable
|
||||
primvars.mo:Expected error testing (load-compiled-from-port 1.0+2.0i (quote "a")): Exception in load-compiled-from-port: 1.0+2.0i is not a binary input port
|
||||
primvars.mo:Expected error testing (load-compiled-from-port 1.0+2.0i (quote #f)): Exception in load-compiled-from-port: 1.0+2.0i is not a binary input port
|
||||
primvars.mo:Expected error testing (make-input-port (quote 0) "a"): Exception in make-input-port: fixnum handler no longer supported; use open-fd-input-port
|
||||
primvars.mo:Expected error testing (make-input/output-port (quote 0) "a" "a"): Exception in make-input/output-port: fixnum handler no longer supported; use open-fd-input-port
|
||||
primvars.mo:Expected error testing (make-output-port (quote 0) "a"): Exception in make-output-port: fixnum handler no longer supported; use open-fd-input-port
|
||||
|
|
@ -4452,6 +4454,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
|
|||
6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
|
||||
6.mo:Expected error in mat fasl: "separate-eval: Warning in fasl-write: fasl file content is compressed internally; compressing the file (#<binary output port testfile.ss>) is redundant and can slow fasl writing and reading significantly
|
||||
6.mo:Expected error in mat fasl: "separate-eval: Warning in fasl-read: fasl file content is compressed internally; compressing the file (#<binary input port testfile.ss>) is redundant and can slow fasl writing and reading significantly
|
||||
6.mo:Expected error in mat fasl: "fasl-write: #() is not #f or a procedure".
|
||||
6.mo:Expected error in mat fasl: "fasl-write: 10 is not #f or a procedure".
|
||||
6.mo:Expected error in mat fasl: "fasl-read: not a vector #f".
|
||||
6.mo:Expected error in mat fasl: "fasl-read: not a vector 10".
|
||||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format".
|
||||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~a~a~a~s" in call to format".
|
||||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format at line 1, char 28 of testfile.ss".
|
||||
|
|
@ -8951,7 +8957,6 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
|
|||
8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: cannot modify immutable environment #<environment>".
|
||||
8.mo:Expected error in mat top-level-syntax-functions: "top-level-syntax: p is not defined".
|
||||
8.mo:Expected error in mat top-level-syntax-functions: "top-level-syntax: cond is not defined".
|
||||
8.mo:Expected error in mat annotations: "make-source-file-descriptor: #f is not a string".
|
||||
8.mo:Expected error in mat annotations: "make-source-file-descriptor: 17 is not a binary input port".
|
||||
8.mo:Expected error in mat annotations: "make-source-file-descriptor: #<input port string> is not a binary input port".
|
||||
8.mo:Expected error in mat annotations: "make-source-file-descriptor: #<binary input port foo> does not support port-position and set-port-position!".
|
||||
|
|
@ -9005,7 +9010,6 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
|
|||
8.mo:Expected error in mat annotations: "get-datum/annotations: #<sfd foo> is not a valid file position".
|
||||
8.mo:Expected error in mat annotations: "get-datum/annotations: -5 is not a valid file position".
|
||||
8.mo:Expected error in mat annotations: "get-datum/annotations: 5.0 is not a valid file position".
|
||||
8.mo:Expected error in mat annotations: "source-file-descriptor: spam is not a string".
|
||||
8.mo:Expected error in mat annotations: "source-file-descriptor: -1 is not an exact nonnegative integer".
|
||||
8.mo:Expected error in mat annotations: "source-file-descriptor: 1.0 is not an exact nonnegative integer".
|
||||
8.mo:Expected error in mat annotations: "locate-source: "spam" is not a source-file descriptor".
|
||||
|
|
|
|||
58
s/7.ss
58
s/7.ss
|
|
@ -134,8 +134,8 @@
|
|||
|
||||
(set-who! fasl-read
|
||||
(let ()
|
||||
(define $fasl-read (foreign-procedure "(cs)fasl_read" (int fixnum ptr) ptr))
|
||||
(define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr int uptr uptr ptr) ptr))
|
||||
(define $fasl-read (foreign-procedure "(cs)fasl_read" (int fixnum ptr ptr) ptr))
|
||||
(define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr int uptr uptr ptr ptr) ptr))
|
||||
(define (get-uptr p)
|
||||
(let ([k (get-u8 p)])
|
||||
(let f ([k k] [n (fxand k #x7F)])
|
||||
|
|
@ -190,13 +190,13 @@
|
|||
;; Call `get-bytevector-n`, etc. with interrupts reenabled
|
||||
(lambda ()
|
||||
(proc (get-bytevector-n p len) 0))])))))
|
||||
(define (go p situation)
|
||||
(define (go p situation externals)
|
||||
(define (go1)
|
||||
(if (and ($port-flags-set? p (constant port-flag-file))
|
||||
(or (not ($port-flags-set? p (constant port-flag-compressed)))
|
||||
(begin ($compressed-warning who p) #f))
|
||||
(eqv? (binary-port-input-count p) 0))
|
||||
($fasl-read ($port-info p) situation (port-name p))
|
||||
($fasl-read ($port-info p) situation (port-name p) externals)
|
||||
(let fasl-entry ()
|
||||
(let ([ty (get-u8 p)])
|
||||
(cond
|
||||
|
|
@ -232,26 +232,31 @@
|
|||
(if (eqv? compressed-flag (constant fasl-type-gzip))
|
||||
(constant COMPRESS-GZIP)
|
||||
(constant COMPRESS-LZ4)))))])
|
||||
($bv-fasl-read bv kind 0 dest-size (port-name p))))]
|
||||
($bv-fasl-read bv kind 0 dest-size (port-name p) externals)))]
|
||||
[(eqv? compressed-flag (constant fasl-type-uncompressed))
|
||||
(let ([len (- n 2)])
|
||||
(call-with-bytevector-and-offset
|
||||
p len
|
||||
(lambda (bv offset)
|
||||
($bv-fasl-read bv kind offset len (port-name p)))))]
|
||||
($bv-fasl-read bv kind offset len (port-name p) externals))))]
|
||||
[else (malformed p "invalid compression")])))))
|
||||
(unless (and (input-port? p) (binary-port? p))
|
||||
($oops who "~s is not a binary input port" p))
|
||||
(go1))
|
||||
(define (parse-situation situation)
|
||||
(case situation
|
||||
[(visit) (constant fasl-type-visit)]
|
||||
[(revisit) (constant fasl-type-revisit)]
|
||||
[(load) (constant fasl-type-visit-revisit)]
|
||||
[else ($oops who "invalid situation ~s" situation)]))
|
||||
(case-lambda
|
||||
[(p) (go p (constant fasl-type-visit-revisit))]
|
||||
[(p situation)
|
||||
(go p
|
||||
(case situation
|
||||
[(visit) (constant fasl-type-visit)]
|
||||
[(revisit) (constant fasl-type-revisit)]
|
||||
[(load) (constant fasl-type-visit-revisit)]
|
||||
[else ($oops who "invalid situation ~s" situation)]))])))
|
||||
[(p) (go p (constant fasl-type-visit-revisit) '#())]
|
||||
[(p situation) (go p (parse-situation situation) '#())]
|
||||
[(p situation externals)
|
||||
(let ([situation (parse-situation situation)])
|
||||
(unless (vector? externals)
|
||||
($oops who "not a vector ~s" externals))
|
||||
(go p situation externals))])))
|
||||
|
||||
(define ($compiled-file-header? ip)
|
||||
(let ([pos (port-position ip)])
|
||||
|
|
@ -265,12 +270,12 @@
|
|||
|
||||
(let ()
|
||||
(define do-load-binary
|
||||
(lambda (who fn ip situation for-import? importer)
|
||||
(lambda (who fn ip situation for-import? importer externals)
|
||||
(let ([load-binary (make-load-binary who fn situation for-import? importer)])
|
||||
(let ([x (fasl-read ip situation)])
|
||||
(let ([x (fasl-read ip situation externals)])
|
||||
(unless (eof-object? x)
|
||||
(let loop ([x x])
|
||||
(let ([next-x (fasl-read ip situation)])
|
||||
(let ([next-x (fasl-read ip situation externals)])
|
||||
(if (eof-object? next-x)
|
||||
(load-binary x)
|
||||
(begin (load-binary x) (loop next-x))))))))))
|
||||
|
|
@ -323,7 +328,7 @@
|
|||
(begin (set-port-position! ip start-pos) 0)))])
|
||||
(if ($compiled-file-header? ip)
|
||||
(begin
|
||||
(do-load-binary who fn ip situation for-import? importer)
|
||||
(do-load-binary who fn ip situation for-import? importer '#())
|
||||
(close-port ip))
|
||||
(begin
|
||||
(unless ksrc
|
||||
|
|
@ -341,22 +346,27 @@
|
|||
(make-load-binary '$make-load-binary fn 'load #f #f)))
|
||||
|
||||
(set-who! load-compiled-from-port
|
||||
(lambda (ip)
|
||||
(unless (and (input-port? ip) (binary-port? ip))
|
||||
($oops who "~s is not a binary input port" ip))
|
||||
(do-load-binary who (port-name ip) ip 'load #f #f)))
|
||||
(rec load-compiled-from-port
|
||||
(case-lambda
|
||||
[(ip) (load-compiled-from-port ip '#())]
|
||||
[(ip externals)
|
||||
(unless (and (input-port? ip) (binary-port? ip))
|
||||
($oops who "~s is not a binary input port" ip))
|
||||
(unless (vector? externals)
|
||||
($oops who "~s is not a vector" ip))
|
||||
(do-load-binary who (port-name ip) ip 'load #f #f externals)])))
|
||||
|
||||
(set-who! visit-compiled-from-port
|
||||
(lambda (ip)
|
||||
(unless (and (input-port? ip) (binary-port? ip))
|
||||
($oops who "~s is not a binary input port" ip))
|
||||
(do-load-binary who (port-name ip) ip 'visit #f #f)))
|
||||
(do-load-binary who (port-name ip) ip 'visit #f #f '#())))
|
||||
|
||||
(set-who! revisit-compiled-from-port
|
||||
(lambda (ip)
|
||||
(unless (and (input-port? ip) (binary-port? ip))
|
||||
($oops who "~s is not a binary input port" ip))
|
||||
(do-load-binary who (port-name ip) ip 'revisit #f #f)))
|
||||
(do-load-binary who (port-name ip) ip 'revisit #f #f '#())))
|
||||
|
||||
(set-who! load-program
|
||||
(rec load-program
|
||||
|
|
|
|||
|
|
@ -348,7 +348,7 @@
|
|||
;; ---------------------------------------------------------------------
|
||||
;; Version and machine types:
|
||||
|
||||
(define-constant scheme-version #x09050321)
|
||||
(define-constant scheme-version #x09050322)
|
||||
|
||||
(define-syntax define-machine-types
|
||||
(lambda (x)
|
||||
|
|
|
|||
56
s/compile.ss
56
s/compile.ss
|
|
@ -457,8 +457,8 @@
|
|||
[else (c-assembler-output-error c)])]))))))]
|
||||
[else (c-assembler-output-error x)])))
|
||||
|
||||
(define (c-print-fasl x p situation)
|
||||
(let ([t ($fasl-table)]
|
||||
(define (c-print-fasl x p situation external?-pred)
|
||||
(let ([t ($fasl-table external?-pred)]
|
||||
[a? (let ([flags (fxlogor
|
||||
(if (generate-inspector-information) (constant annotation-debug) 0)
|
||||
(if (eq? ($compile-profile) 'source) (constant annotation-profile) 0))])
|
||||
|
|
@ -520,7 +520,7 @@
|
|||
x)))
|
||||
|
||||
(define compile-file-help
|
||||
(lambda (op hostop wpoop source-table machine sfd do-read outfn)
|
||||
(lambda (op hostop wpoop source-table machine sfd do-read outfn external?-pred)
|
||||
(parameterize ([$target-machine machine]
|
||||
[$sfd sfd]
|
||||
[$current-mso ($current-mso)]
|
||||
|
|
@ -548,7 +548,7 @@
|
|||
(let cfh0 ([n 1] [rrcinfo** '()] [rlpinfo** '()] [rfinal** '()])
|
||||
(let ([x0 ($pass-time 'read do-read)])
|
||||
(if (eof-object? x0)
|
||||
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**))
|
||||
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**) external?-pred)
|
||||
(let ()
|
||||
(define source-info-string
|
||||
(and (or ($assembly-output) (expand-output) (expand/optimize-output))
|
||||
|
|
@ -748,7 +748,7 @@
|
|||
[else (finish-compile x1 values)]))))))
|
||||
|
||||
(define compile-file-help2
|
||||
(lambda (op rcinfo** lpinfo** final**)
|
||||
(lambda (op rcinfo** lpinfo** final** external?-pred)
|
||||
(define (libreq-hash x) (symbol-hash (libreq-uid x)))
|
||||
(define (libreq=? x y) (eq? (libreq-uid x) (libreq-uid y)))
|
||||
(let ([import-ht (make-hashtable libreq-hash libreq=?)]
|
||||
|
|
@ -767,18 +767,19 @@
|
|||
rcinfo**)
|
||||
(let ([import-req* (vector->list (hashtable-keys import-ht))]
|
||||
[include-req* (vector->list (hashtable-keys include-ht))])
|
||||
; the first entry is always a recompile-info record with recompile information for the entire object file
|
||||
; the first entry is always, if needed, a recompile-info record with recompile information for the entire object file
|
||||
($pass-time 'pfasl
|
||||
(lambda ()
|
||||
(c-print-fasl `(object ,(make-recompile-info import-req* include-req*)) op (constant fasl-type-visit-revisit))
|
||||
(unless (and (compile-omit-concatenate-support) (null? import-req*) (null? include-req*))
|
||||
(c-print-fasl `(object ,(make-recompile-info import-req* include-req*)) op (constant fasl-type-visit-revisit) #f))
|
||||
(for-each
|
||||
(lambda (final*)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(record-case x
|
||||
[(visit-stuff) x (c-print-fasl x op (constant fasl-type-visit))]
|
||||
[(revisit-stuff) x (c-print-fasl x op (constant fasl-type-revisit))]
|
||||
[else (c-print-fasl x op (constant fasl-type-visit-revisit))]))
|
||||
[(visit-stuff) x (c-print-fasl x op (constant fasl-type-visit) external?-pred)]
|
||||
[(revisit-stuff) x (c-print-fasl x op (constant fasl-type-revisit) external?-pred)]
|
||||
[else (c-print-fasl x op (constant fasl-type-visit-revisit) external?-pred)]))
|
||||
final*))
|
||||
(append lpinfo**
|
||||
(if (compile-omit-concatenate-support)
|
||||
|
|
@ -857,7 +858,7 @@
|
|||
(emit-header op (constant scheme-version) (constant machine-type))
|
||||
(let loop ([x1* (reverse rx1*)] [rrcinfo** (list rcinfo*)] [rlpinfo** '()] [rfinal** '()])
|
||||
(if (null? x1*)
|
||||
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**))
|
||||
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**) #f)
|
||||
(let-values ([(rcinfo* lpinfo* final*)
|
||||
(let ([x1 (car x1*)])
|
||||
(if (recompile-info? x1)
|
||||
|
|
@ -1565,7 +1566,7 @@
|
|||
(when source-table ($insert-profile-src! source-table x1))
|
||||
(emit-header op (constant scheme-version) (constant machine-type))
|
||||
(let-values ([(rcinfo* lpinfo* final*) (compile-file-help1 x1 msg)])
|
||||
(compile-file-help2 op (list rcinfo*) (list lpinfo*) (list final*))))))))))
|
||||
(compile-file-help2 op (list rcinfo*) (list lpinfo*) (list final*) #f)))))))))
|
||||
|
||||
(define write-wpo-file
|
||||
(lambda (who ofn ir*)
|
||||
|
|
@ -1717,8 +1718,8 @@
|
|||
(emit-header op (constant scheme-version) (constant machine-type) (map path-root (map path-last bootfiles)))
|
||||
(when (null? bootfiles)
|
||||
(parameterize ([$target-machine machine] [$sfd #f])
|
||||
(c-print-fasl ($np-boot-code 'error-invoke) op (constant fasl-type-visit-revisit))
|
||||
(c-print-fasl ($np-boot-code 'invoke) op (constant fasl-type-visit-revisit))
|
||||
(c-print-fasl ($np-boot-code 'error-invoke) op (constant fasl-type-visit-revisit) #f)
|
||||
(c-print-fasl ($np-boot-code 'invoke) op (constant fasl-type-visit-revisit) #f)
|
||||
($fasl-base-rtd #!base-rtd op)))))
|
||||
|
||||
(define do-make-boot-file
|
||||
|
|
@ -1762,7 +1763,7 @@
|
|||
(let ([sfd ($source-file-descriptor infn ip)])
|
||||
; whack ip so close-port calls close the text port
|
||||
(set! ip (transcoded-port ip (current-transcoder)))
|
||||
(compile-file-help op #f #f source-table machine sfd ($make-read ip sfd 0) outfn))))
|
||||
(compile-file-help op #f #f source-table machine sfd ($make-read ip sfd 0) outfn #f))))
|
||||
(close-port ip)))
|
||||
infn*)))))))
|
||||
|
||||
|
|
@ -1893,7 +1894,7 @@
|
|||
(c-print-fasl `(object ,(make-recompile-info
|
||||
(vector->list (hashtable-keys import-ht))
|
||||
(vector->list (hashtable-keys include-ht))))
|
||||
op (constant fasl-type-visit-revisit))
|
||||
op (constant fasl-type-visit-revisit) #f)
|
||||
(for-each (lambda (ip)
|
||||
(let loop () ;; NB: This loop consumes one entry past the last library/program info record,
|
||||
;; which we presume is the #t end-of-header marker.
|
||||
|
|
@ -1902,11 +1903,11 @@
|
|||
;; perhaps should verify ty here.
|
||||
(let ([x (fasl-read ip)])
|
||||
(when (or (library-info? x) (program-info? x))
|
||||
(c-print-fasl `(object ,x) op ty)
|
||||
(c-print-fasl `(object ,x) op ty #f)
|
||||
(loop)))))))
|
||||
ip*)
|
||||
;; inserting #t after lpinfo as an end-of-header marker
|
||||
(c-print-fasl `(object #t) op (constant fasl-type-visit-revisit))
|
||||
(c-print-fasl `(object #t) op (constant fasl-type-visit-revisit) #f)
|
||||
(let* ([bufsiz (file-buffer-size)] [buf (make-bytevector bufsiz)])
|
||||
(for-each (lambda (ip)
|
||||
(let loop ()
|
||||
|
|
@ -1976,7 +1977,7 @@
|
|||
(if ($port-flags-set? ip (constant port-flag-char-positions))
|
||||
fp
|
||||
(and (eqv? fp 0) fp))))])
|
||||
(compile-file-help op hostop wpoop source-table machine sfd ($make-read ip sfd fp) #f)
|
||||
(compile-file-help op hostop wpoop source-table machine sfd ($make-read ip sfd fp) #f #f)
|
||||
(when covop (put-source-table covop source-table))))])))
|
||||
|
||||
(set-who! compile-to-port
|
||||
|
|
@ -1987,7 +1988,8 @@
|
|||
[(sexpr* op sfd wpoop) (compile-to-port sexpr* op sfd wpoop #f)]
|
||||
[(sexpr* op sfd wpoop covop) (compile-to-port sexpr* op sfd wpoop covop (constant machine-type-name))]
|
||||
[(sexpr* op sfd wpoop covop machine) (compile-to-port sexpr* op sfd wpoop covop machine #f)]
|
||||
[(sexpr* op sfd wpoop covop machine hostop)
|
||||
[(sexpr* op sfd wpoop covop machine hostop) (compile-to-port sexpr* op sfd wpoop covop machine hostop #f)]
|
||||
[(sexpr* op sfd wpoop covop machine hostop external?-pred)
|
||||
(define do-compile-to-port
|
||||
(lambda ()
|
||||
(let ([source-table (and covop (make-source-table))])
|
||||
|
|
@ -1998,7 +2000,8 @@
|
|||
(let ([x (car sexpr*)])
|
||||
(set! sexpr* (cdr sexpr*))
|
||||
x)))
|
||||
(port-name op))
|
||||
(port-name op)
|
||||
external?-pred)
|
||||
(when covop (put-source-table covop source-table)))))
|
||||
(unless (list? sexpr*)
|
||||
($oops who "~s is not a proper list" sexpr*))
|
||||
|
|
@ -2022,6 +2025,11 @@
|
|||
(unless (and (output-port? hostop) (binary-port? hostop))
|
||||
($oops who "~s is not a binary output port or #f" hostop))
|
||||
(when ($port-flags-set? hostop (constant port-flag-compressed)) ($compressed-warning who hostop)))
|
||||
(when external?-pred
|
||||
(unless (procedure? external?-pred)
|
||||
($oops who "~s is not a procedure or #f" external?-pred))
|
||||
(unless (= (length sexpr*) 1)
|
||||
($oops who "external predicate allowed only with a single expression")))
|
||||
(if (and (= (length sexpr*) 1) (pair? (car sexpr*)) (eq? (caar sexpr*) 'top-level-program))
|
||||
(let ([library-collector (make-parameter '())])
|
||||
(parameterize ([$require-libraries library-collector])
|
||||
|
|
@ -2046,7 +2054,7 @@
|
|||
(lambda (wpoop)
|
||||
(with-coverage-file who out
|
||||
(lambda (source-table)
|
||||
(compile-file-help op hostop wpoop source-table machine sfd do-read out))))))))))
|
||||
(compile-file-help op hostop wpoop source-table machine sfd do-read out #f))))))))))
|
||||
|
||||
(define (do-compile-file who in out hostout machine r6rs?)
|
||||
(unless (string? in) ($oops who "~s is not a string" in))
|
||||
|
|
@ -2126,7 +2134,7 @@
|
|||
(when wpoop (put-u8 wpoop n)))
|
||||
(let ([fp (+ fp 1)])
|
||||
(if (char=? c #\newline) fp (loop fp)))))])
|
||||
(compile-file-help op #f wpoop source-table machine sfd ((if r6rs? $make-read-program $make-read) ip sfd fp) out))))))))
|
||||
(compile-file-help op #f wpoop source-table machine sfd ((if r6rs? $make-read-program $make-read) ip sfd fp) out #f))))))))
|
||||
; no #! line
|
||||
(with-object-file who out
|
||||
(lambda (op)
|
||||
|
|
@ -2135,7 +2143,7 @@
|
|||
(lambda (wpoop)
|
||||
(with-coverage-file who out
|
||||
(lambda (source-table)
|
||||
(compile-file-help op #f wpoop source-table machine sfd ((if r6rs? $make-read-program $make-read) ip sfd 0) out)))))))))))
|
||||
(compile-file-help op #f wpoop source-table machine sfd ((if r6rs? $make-read-program $make-read) ip sfd 0) out #f)))))))))))
|
||||
(close-port ip))
|
||||
(unless-feature windows (chmod out #o755)))
|
||||
|
||||
|
|
|
|||
73
s/fasl.ss
73
s/fasl.ss
|
|
@ -41,13 +41,15 @@
|
|||
(define rtd-flags (csv7:record-field-accessor #!base-rtd 'flags))
|
||||
|
||||
(define-record-type table
|
||||
(fields (mutable count) (immutable hash))
|
||||
(fields (mutable count) (immutable hash)
|
||||
(immutable external?-pred) (mutable external-count) (mutable externals))
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda ()
|
||||
(new 0 (make-eq-hashtable))))))
|
||||
(lambda (new)
|
||||
(case-lambda
|
||||
[() (new 0 (make-eq-hashtable) #f 0 '())]
|
||||
[(external?-pred) (new 0 (make-eq-hashtable) external?-pred 0 '())]))))
|
||||
|
||||
(include "fasl-helpers.ss")
|
||||
|
||||
|
|
@ -112,7 +114,7 @@
|
|||
(lambda (x t a? d)
|
||||
(void)))
|
||||
|
||||
(module (bld-graph dump-graph reset-dump-graph)
|
||||
(module (bld-graph dump-graph reset-dump-graph shift-externals!)
|
||||
(define enable-dump-graph? #f)
|
||||
(define vcat (if enable-dump-graph?
|
||||
`#((code . ,(lambda (x) (and (pair? x) (eq? (car x) 'code))))
|
||||
|
|
@ -153,22 +155,40 @@
|
|||
#;(let ([n (hashtable-size (table-hash t))])
|
||||
(when (fx= (modulo n 10000) 0)
|
||||
(printf "entries = ~s, ba = ~s, count = ~s\n" n (bytes-allocated) (table-count t))))
|
||||
(record! ventry x)
|
||||
(cond
|
||||
[(fx>= d 500)
|
||||
;; Limit depth of recursion by lifting to a `fasl-begin` graph:
|
||||
(let ([n (table-count t)])
|
||||
(set-cdr! a (cons n (if inner? 'inner-begin 'begin)))
|
||||
(table-count-set! t (fx+ n 1)))
|
||||
(handler x t a? 0)]
|
||||
[else
|
||||
(set-cdr! a #f)
|
||||
(handler x t a? (fx+ d 1))])]
|
||||
[(let ([pred (table-external?-pred t)])
|
||||
(and pred (pred x)))
|
||||
;; Don't traverse; just record as external. We'll
|
||||
;; assign positions to externals after the graph
|
||||
;; has been fully traversed.
|
||||
(let ([p (cons (table-external-count t) #f)])
|
||||
(set-cdr! a p)
|
||||
(table-external-count-set! t (fx+ (table-external-count t) 1))
|
||||
(table-externals-set! t (cons p (table-externals t))))]
|
||||
[else
|
||||
(record! ventry x)
|
||||
(cond
|
||||
[(fx>= d 500)
|
||||
;; Limit depth of recursion by lifting to a `fasl-begin` graph:
|
||||
(let ([n (table-count t)])
|
||||
(set-cdr! a (cons n (if inner? 'inner-begin 'begin)))
|
||||
(table-count-set! t (fx+ n 1)))
|
||||
(handler x t a? 0)]
|
||||
[else
|
||||
(set-cdr! a #f)
|
||||
(handler x t a? (fx+ d 1))])])]
|
||||
[(not p)
|
||||
(record! vdup x)
|
||||
(let ([n (table-count t)])
|
||||
(set-cdr! a (cons n #t))
|
||||
(table-count-set! t (fx+ n 1)))])))))
|
||||
(define (shift-externals! t)
|
||||
(unless (null? (table-externals t))
|
||||
(let ([c (table-count t)])
|
||||
(table-count-set! t (fx+ c (table-external-count t)))
|
||||
(for-each (lambda (p)
|
||||
(set-car! p (fx+ (car p) c)))
|
||||
(table-externals t)))))
|
||||
(reset-dump-graph))
|
||||
|
||||
(define bld
|
||||
|
|
@ -640,6 +660,7 @@
|
|||
(module (start)
|
||||
(define start
|
||||
(lambda (p t situation proc)
|
||||
(shift-externals! t)
|
||||
(dump-graph)
|
||||
(let-values ([(bv* size)
|
||||
(let-values ([(p extractor) ($open-bytevector-list-output-port)])
|
||||
|
|
@ -687,18 +708,22 @@
|
|||
; when called from fasl-write or fasl-file, always preserve annotations;
|
||||
; otherwise use value passed in by the compiler
|
||||
(define fasl-one
|
||||
(lambda (x p)
|
||||
(let ([t (make-table)])
|
||||
(lambda (x p external?-pred)
|
||||
(let ([t (make-table external?-pred)])
|
||||
(bld x t (constant annotation-all) 0)
|
||||
(start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf x p t (constant annotation-all)))))))
|
||||
|
||||
(define-who fasl-write
|
||||
(lambda (x p)
|
||||
(case-lambda
|
||||
[(x p) (fasl-write x p #f)]
|
||||
[(x p external?-pred)
|
||||
(unless (and (output-port? p) (binary-port? p))
|
||||
($oops who "~s is not a binary output port" p))
|
||||
(unless (or (not external?-pred) (procedure? external?-pred))
|
||||
($oops who "~s is not #f or a procedure" external?-pred))
|
||||
(when ($port-flags-set? p (constant port-flag-compressed)) ($compressed-warning who p))
|
||||
(emit-header p (constant scheme-version) (constant machine-type-any))
|
||||
(fasl-one x p)))
|
||||
(fasl-one x p external?-pred)]))
|
||||
|
||||
(define-who fasl-file
|
||||
(lambda (in out)
|
||||
|
|
@ -717,7 +742,7 @@
|
|||
(let fasl-loop ()
|
||||
(let ([x (read ip)])
|
||||
(unless (eof-object? x)
|
||||
(fasl-one x op)
|
||||
(fasl-one x op #f)
|
||||
(fasl-loop)))))
|
||||
(close-port op))
|
||||
(close-port ip)))))
|
||||
|
|
@ -742,10 +767,14 @@
|
|||
(set! $fasl-enter (lambda (x t a? d) ((target-fasl-enter (fasl-target)) x t a? d)))
|
||||
(set! $fasl-out (lambda (x p t a?) ((target-fasl-out (fasl-target)) x p t a?)))
|
||||
(set! $fasl-start (lambda (p t situation proc) ((target-fasl-start (fasl-target)) p t situation proc)))
|
||||
(set! $fasl-table (lambda () ((target-fasl-table (fasl-target)))))
|
||||
(set! $fasl-table (case-lambda
|
||||
[() ((target-fasl-table (fasl-target)))]
|
||||
[(external?-pred) ((target-fasl-table (fasl-target)) external?-pred)]))
|
||||
(set! $fasl-wrf-graph (lambda (x p t a? handler) ((target-fasl-wrf-graph (fasl-target)) x p t a? handler)))
|
||||
(set! $fasl-base-rtd (lambda (x p) ((target-fasl-base-rtd (fasl-target)) x p)))
|
||||
(set! fasl-write (lambda (x p) ((target-fasl-write (fasl-target)) x p)))
|
||||
(set! fasl-write (case-lambda
|
||||
[(x p) ((target-fasl-write (fasl-target)) x p)]
|
||||
[(x p externals) ((target-fasl-write (fasl-target)) x p externals)]))
|
||||
(set! fasl-file (lambda (in out) ((target-fasl-file (fasl-target)) in out))))
|
||||
|
||||
(when ($unbound-object? (#%$top-level-value '$capture-fasl-target))
|
||||
|
|
|
|||
20
s/pdhtml.ss
20
s/pdhtml.ss
|
|
@ -74,13 +74,13 @@
|
|||
(lambda (new)
|
||||
(lambda ()
|
||||
(define sfd-hash
|
||||
(lambda (sfd)
|
||||
(lambda (sfd)<
|
||||
(source-file-descriptor-crc sfd)))
|
||||
(define sfd=?
|
||||
(lambda (sfd1 sfd2)
|
||||
(and (fx= (source-file-descriptor-crc sfd1) (source-file-descriptor-crc sfd2))
|
||||
(= (source-file-descriptor-length sfd1) (source-file-descriptor-length sfd2))
|
||||
(string=? (source-file-descriptor-name sfd1) (source-file-descriptor-name sfd2)))))
|
||||
(equal? (source-file-descriptor-name sfd1) (source-file-descriptor-name sfd2)))))
|
||||
(new (make-hashtable sfd-hash sfd=?))))))
|
||||
(define *local-profile-trackers* '())
|
||||
(define op+ car)
|
||||
|
|
@ -496,9 +496,11 @@
|
|||
(source-file-descriptor-crc y))
|
||||
(= (source-file-descriptor-length x)
|
||||
(source-file-descriptor-length y))
|
||||
(string=?
|
||||
(path-last (source-file-descriptor-name x))
|
||||
(path-last (source-file-descriptor-name y)))))))])
|
||||
(let ([maybe-path-last (lambda (p)
|
||||
(if (string? p) (path-last p) p))])
|
||||
(equal?
|
||||
(maybe-path-last (source-file-descriptor-name x))
|
||||
(maybe-path-last (source-file-descriptor-name y))))))))])
|
||||
(define (open-source sfd)
|
||||
(cond
|
||||
[(hashtable-ref fdata-ht sfd #f)]
|
||||
|
|
@ -622,9 +624,11 @@
|
|||
(source-file-descriptor-crc y))
|
||||
(= (source-file-descriptor-length x)
|
||||
(source-file-descriptor-length y))
|
||||
(string=?
|
||||
(path-last (source-file-descriptor-name x))
|
||||
(path-last (source-file-descriptor-name y)))))))))
|
||||
(let ([maybe-path-last (lambda (p)
|
||||
(if (string? p) (path-last p) p))])
|
||||
(string=?
|
||||
(maybe-path-last (source-file-descriptor-name x))
|
||||
(maybe-path-last (source-file-descriptor-name y))))))))))
|
||||
|
||||
(define profile-database #f)
|
||||
(define profile-source-data? #f)
|
||||
|
|
|
|||
|
|
@ -1237,7 +1237,7 @@
|
|||
(compile-time-value? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
|
||||
(compile-time-value-value [sig [(compile-time-value) -> (ptr)]] [flags pure mifoldable discard])
|
||||
(compile-to-file [sig [(list pathname) (list pathname maybe-sfd) -> (void/list)]] [flags true])
|
||||
(compile-to-port [sig [(list binary-output-port) (list binary-output-port maybe-sfd) (list binary-output-port maybe-sfd maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port) -> (void/list)]] [flags true])
|
||||
(compile-to-port [sig [(list binary-output-port) (list binary-output-port maybe-sfd) (list binary-output-port maybe-sfd maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port ptr) -> (void/list)]] [flags true])
|
||||
(compile-whole-program [sig [(string string) (string string ptr) -> (void)]] [flags])
|
||||
(compile-whole-library [sig [(string string) -> (void)]] [flags])
|
||||
(compute-composition [sig [(ptr) -> (list)] [(ptr sub-ufixnum) -> (list)]] [flags alloc])
|
||||
|
|
@ -1309,8 +1309,8 @@
|
|||
(expand/optimize [sig [(ptr) (ptr environment) -> (ptr)]] [flags])
|
||||
(expt-mod [sig [(integer integer integer) -> (integer)]] [flags arith-op mifoldable discard])
|
||||
(fasl-file [sig [(pathname pathname) -> (void)]] [flags true])
|
||||
(fasl-read [sig [(binary-input-port) (binary-input-port sub-symbol) -> (ptr)]] [flags])
|
||||
(fasl-write [sig [(sub-ptr binary-output-port) -> (void)]] [flags true])
|
||||
(fasl-read [sig [(binary-input-port) (binary-input-port sub-symbol) (binary-input-port sub-symbol vector) -> (ptr)]] [flags])
|
||||
(fasl-write [sig [(sub-ptr binary-output-port) (sub-ptr binary-output-port ptr) -> (void)]] [flags true])
|
||||
(vfasl-convert-file [sig [(ptr ptr ptr) -> (void)]] [flags])
|
||||
(file-access-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard])
|
||||
(file-change-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard])
|
||||
|
|
@ -1445,7 +1445,7 @@
|
|||
(list-head [sig [(sub-ptr sub-index) -> (list)]] [flags alloc])
|
||||
(literal-identifier=? [sig [(identifier identifier) -> (boolean)]] [flags pure mifoldable discard cp03])
|
||||
(load [sig [(pathname) (pathname procedure) -> (void)]] [flags true ieee r5rs])
|
||||
(load-compiled-from-port [sig [(ptr) -> (ptr ...)]] [flags])
|
||||
(load-compiled-from-port [sig [(ptr) (ptr vector) -> (ptr ...)]] [flags])
|
||||
(load-library [sig [(pathname) (pathname procedure) -> (void)]] [flags true])
|
||||
(load-program [sig [(pathname) (pathname procedure) -> (void)]] [flags true])
|
||||
(load-shared-object [sig [(maybe-pathname) -> (void)]] [flags true])
|
||||
|
|
@ -1493,7 +1493,7 @@
|
|||
(make-record-type [sig [(sub-ptr sub-list) (maybe-rtd sub-ptr sub-list) -> (rtd)]] [flags pure alloc cp02])
|
||||
(make-record-type-descriptor* [sig [(symbol maybe-rtd maybe-symbol ptr ptr ufixnum exact-integer) -> (rtd)]] [flags pure alloc cp02])
|
||||
(make-source-condition [sig [(ptr) -> (condition)]] [flags pure unrestricted mifoldable discard])
|
||||
(make-source-file-descriptor [sig [(string binary-input-port) (string binary-input-port ptr) -> (sfd)]] [flags true])
|
||||
(make-source-file-descriptor [sig [(ptr binary-input-port) (ptr binary-input-port ptr) -> (sfd)]] [flags true])
|
||||
(make-source-object [sig [(sfd uint uint) (sfd uint uint nzuint nzuint) -> (source-object)]] [flags pure true mifoldable discard])
|
||||
(make-sstats [sig [(time time exact-integer exact-integer time time exact-integer) -> (sstats)]] [flags alloc])
|
||||
(make-thread-parameter [feature pthreads] [sig [(ptr) (ptr procedure) -> (thread-parameter)]] [flags true cp02 cp03])
|
||||
|
|
@ -1672,10 +1672,10 @@
|
|||
(sort! [sig [(procedure list) -> (list)]] [flags true])
|
||||
(source-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
|
||||
(source-condition-form [sig [(source-condition) -> (ptr)]] [flags pure mifoldable discard])
|
||||
(source-file-descriptor [sig [(string uint) -> (sfd)]] [flags alloc])
|
||||
(source-file-descriptor [sig [(ptr uint) -> (sfd)]] [flags alloc])
|
||||
(source-file-descriptor? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
|
||||
(source-file-descriptor-checksum [sig [(sfd) -> (sint)]] [flags pure mifoldable discard true])
|
||||
(source-file-descriptor-path [sig [(sfd) -> (string)]] [flags pure mifoldable discard true])
|
||||
(source-file-descriptor-path [sig [(sfd) -> (ptr)]] [flags pure mifoldable discard])
|
||||
(source-object? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
|
||||
(source-object-bfp [sig [(source-object) -> (uint)]] [flags pure mifoldable discard])
|
||||
(source-object-column [sig [(source-object) -> (maybe-uint)]] [flags pure mifoldable discard])
|
||||
|
|
|
|||
15
s/read.ss
15
s/read.ss
|
|
@ -1633,13 +1633,14 @@
|
|||
dir name))))
|
||||
(search name (cdr dir*)))))
|
||||
(let ([name (source-file-descriptor-name sfd)])
|
||||
(or (and ($fixed-path? name) (source-port name))
|
||||
(let ([dir* (append (source-directories) (map car (library-directories)))])
|
||||
(let pathloop ([name name])
|
||||
(or (search name dir*)
|
||||
(let ([rest (path-rest name)])
|
||||
(and (not (string=? rest name))
|
||||
(pathloop rest))))))))))
|
||||
(and (string? name)
|
||||
(or (and ($fixed-path? name) (source-port name))
|
||||
(let ([dir* (append (source-directories) (map car (library-directories)))])
|
||||
(let pathloop ([name name])
|
||||
(or (search name dir*)
|
||||
(let ([rest (path-rest name)])
|
||||
(and (not (string=? rest name))
|
||||
(pathloop rest)))))))))))
|
||||
|
||||
(let ([source-lines-cache (make-weak-eq-hashtable)])
|
||||
|
||||
|
|
|
|||
22
s/strip.ss
22
s/strip.ss
|
|
@ -469,25 +469,21 @@
|
|||
|
||||
(define write-entry
|
||||
(lambda (p x)
|
||||
(define (append-bvs bv*)
|
||||
(let f ([bv* bv*] [n 0])
|
||||
(if (null? bv*)
|
||||
(if (fixnum? n)
|
||||
(make-bytevector n)
|
||||
($oops 'fasl-write "fasl output is too large to compress"))
|
||||
(let ([bv1 (car bv*)])
|
||||
(let ([m (bytevector-length bv1)])
|
||||
(let ([bv2 (f (cdr bv*) (+ n m))])
|
||||
(bytevector-copy! bv1 0 bv2 n m)
|
||||
bv2))))))
|
||||
(fasl-case x
|
||||
[header (version machine dependencies)
|
||||
(emit-header p version machine dependencies)]
|
||||
[entry (situation fasl)
|
||||
(let ([t (make-table)])
|
||||
(build! fasl t)
|
||||
($fasl-start p t situation
|
||||
(lambda (p) (write-fasl p t fasl))))]
|
||||
(let-values ([(bv* size)
|
||||
(let-values ([(p extractor) ($open-bytevector-list-output-port)])
|
||||
(let ([n (table-count t)])
|
||||
(unless (fx= n 0)
|
||||
(put-u8 p (constant fasl-type-graph))
|
||||
(put-uptr p n)))
|
||||
(write-fasl p t fasl)
|
||||
(extractor))])
|
||||
($write-fasl-bytevectors p bv* size situation (constant fasl-type-fasl))))]
|
||||
[else (sorry! "unrecognized top-level fasl-record-type ~s" x)])))
|
||||
|
||||
(define write-graph
|
||||
|
|
|
|||
|
|
@ -10270,7 +10270,6 @@
|
|||
(case-lambda
|
||||
[(ifn bip) (make-source-file-descriptor ifn bip #f)]
|
||||
[(ifn bip reset?)
|
||||
(unless (string? ifn) ($oops who "~s is not a string" ifn))
|
||||
(unless (and (input-port? bip) (binary-port? bip))
|
||||
($oops who "~s is not a binary input port" bip))
|
||||
(when reset?
|
||||
|
|
@ -10279,7 +10278,6 @@
|
|||
($source-file-descriptor ifn bip reset?)])))
|
||||
(set-who! source-file-descriptor
|
||||
(lambda (path checksum)
|
||||
(unless (string? path) ($oops who "~s is not a string" path))
|
||||
(unless (if (fixnum? checksum) (fx>= checksum 0) (and (bignum? checksum) ($bigpositive? checksum)))
|
||||
($oops who "~s is not an exact nonnegative integer" checksum))
|
||||
(%make-source-file-descriptor path (ash checksum -16) (logand checksum #xffff))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user