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

add "externals" fasl support, allow non-strings in sfd

Browse Source 
"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 2020-07-14 12:26:12 -06:00
parent f73220d0ec
commit ec05bac0cf
19 changed files with 255 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
c/externs.h
View File

@ -107,8 +107,8 @@ extern void S_phantom_bytevector_adjust PROTO((ptr ph, uptr new_sz));
/* fasl.c */ /* fasl.c */
extern void S_fasl_init PROTO((void)); extern void S_fasl_init PROTO((void));
ptr S_fasl_read PROTO((INT fd, IFASLCODE situation, 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 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)); ptr S_boot_read PROTO((INT fd, const char *path));
char *S_format_scheme_version PROTO((uptr n)); char *S_format_scheme_version PROTO((uptr n));
char *S_lookup_machine_type PROTO((uptr n)); char *S_lookup_machine_type PROTO((uptr n));

33
c/fasl.c
View File

@ -218,8 +218,8 @@ typedef struct faslFileObj {
static INT uf_read PROTO((unbufFaslFile uf, octet *s, iptr n)); static INT uf_read PROTO((unbufFaslFile uf, octet *s, iptr n));
static octet uf_bytein PROTO((unbufFaslFile uf)); static octet uf_bytein PROTO((unbufFaslFile uf));
static uptr uf_uptrin PROTO((unbufFaslFile uf, INT *bytes_consumed)); static uptr uf_uptrin PROTO((unbufFaslFile uf, INT *bytes_consumed));
static ptr fasl_entry PROTO((ptr tc, IFASLCODE situation, 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)); 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 fillFaslFile PROTO((faslFile f));
static void bytesin PROTO((octet *s, iptr n, faslFile f)); static void bytesin PROTO((octet *s, iptr n, faslFile f));
static void toolarge PROTO((ptr path)); static void toolarge PROTO((ptr path));
@ -298,7 +298,7 @@ void S_fasl_init() {
#endif #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 tc = get_thread_context();
ptr x; struct unbufFaslFileObj uffo; ptr x; struct unbufFaslFileObj uffo;
@ -307,12 +307,12 @@ ptr S_fasl_read(INT fd, IFASLCODE situation, ptr path) {
uffo.path = path; uffo.path = path;
uffo.type = UFFO_TYPE_FD; uffo.type = UFFO_TYPE_FD;
uffo.fd = fd; uffo.fd = fd;
x = fasl_entry(tc, situation, &uffo); x = fasl_entry(tc, situation, &uffo, externals);
tc_mutex_release() tc_mutex_release()
return x; 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 tc = get_thread_context();
ptr x; struct unbufFaslFileObj uffo; 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() tc_mutex_acquire()
uffo.path = path; uffo.path = path;
uffo.type = UFFO_TYPE_BV; 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() tc_mutex_release()
return x; return x;
} }
@ -332,7 +332,7 @@ ptr S_boot_read(INT fd, const char *path) {
uffo.path = Sstring_utf8(path, -1); uffo.path = Sstring_utf8(path, -1);
uffo.type = UFFO_TYPE_FD; uffo.type = UFFO_TYPE_FD;
uffo.fd = 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 #ifdef WIN32
@ -432,7 +432,7 @@ char *S_lookup_machine_type(uptr n) {
return "unknown"; 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; ptr x; ptr strbuf = S_G.null_string;
octet tybuf[1]; IFASLCODE ty; iptr size; 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 */ /* 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) { switch (kind) {
case fasl_type_fasl: case fasl_type_fasl:
faslin(tc, &x, S_G.null_vector, &strbuf, &ffo); faslin(tc, &x, externals, &strbuf, &ffo);
break; break;
case fasl_type_vfasl: case fasl_type_vfasl:
x = S_vfasl(bv, uf, 0, ffo.size); 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; ptr x; ptr strbuf = S_G.null_string;
struct faslFileObj ffo; 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.end = &BVIT(bv, offset + len);
ffo.uf = uf; ffo.uf = uf;
faslin(tc, &x, S_G.null_vector, &strbuf, &ffo); faslin(tc, &x, externals, &strbuf, &ffo);
} else { } else {
S_error1("", "bad entry type (got ~s)", FIX(ty)); 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: case fasl_type_phantom:
*x = S_phantom_bytevector(uptrin(f)); *x = S_phantom_bytevector(uptrin(f));
return; return;
case fasl_type_graph: case fasl_type_graph: {
faslin(tc, x, S_vector(uptrin(f)), pstrbuf, f); 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; return;
}
case fasl_type_graph_def: { case fasl_type_graph_def: {
ptr *p; ptr *p;
p = &INITVECTIT(t, uptrin(f)); p = &INITVECTIT(t, uptrin(f));

26
csug/io.stex
View File

@ -3379,17 +3379,32 @@ input port, must be used instead.
%---------------------------------------------------------------------------- %----------------------------------------------------------------------------
\entryheader \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})}
\formdef{fasl-write}{\categoryprocedure}{(fasl-write \var{obj} \var{binary-output-port} \var{external-pred})}
\returns unspecified \returns unspecified
\listlibraries \listlibraries
\endentryheader \endentryheader
\noindent \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 \scheme{fasl-write} writes the fasl representation of \var{obj} to
\var{binary-output-port}. \var{binary-output-port}.
An exception is raised with condition-type \scheme{&assertion} if An exception is raised with condition-type \scheme{&assertion} if
\var{obj} or any portion of \var{obj} has no external fasl representation, \var{obj} or any portion of \var{obj} has no external fasl representation,
e.g., if \var{obj} is or contains a procedure. 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 The fasl representation of \var{obj} is compressed if the parameter
\scheme{fasl-compressed}, described below, is set to \scheme{#t}, \scheme{fasl-compressed}, described below, is set to \scheme{#t},
its default value. its default value.
@ -3415,14 +3430,16 @@ fasl objects from a compressed file.
\entryheader \entryheader
\formdef{fasl-read}{\categoryprocedure}{(fasl-read \var{binary-input-port})} \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}})}
\formdef{fasl-read}{\categoryprocedure}{(fasl-read \var{binary-input-port \var{situation} \var{externals}})}
\returns unspecified \returns unspecified
\listlibraries \listlibraries
\endentryheader \endentryheader
\noindent \noindent
If present, \var{situation} must be one of the symbols \scheme{load}, If present, \var{situation} must be one of the symbols \scheme{load},
\scheme{visit}, or \scheme{revisit}. \scheme{visit}, or \scheme{revisit}, and it defaults to \scheme{load}.
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 \scheme{fasl-read} reads one object from
\var{binary-input-port}, which must be positioned at the \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}) situation \scheme{load} or situations \scheme{visit} and \scheme{revisit})
are never skipped. 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 \scheme{fasl-read} automatically decompresses the representation
of each fasl object written in compressed format by \scheme{fasl-write}. of each fasl object written in compressed format by \scheme{fasl-write}.
Thus, \var{binary-input-port} generally should not be opened with Thus, \var{binary-input-port} generally should not be opened with

19
csug/syntax.stex
View File

@ -1613,7 +1613,7 @@ source file to make sure that the proper file has been found and
has not been modified. has not been modified.
Source-file descriptors can be created with Source-file descriptors can be created with
\index{\scheme{make-source-file-descriptor}}\scheme{make-source-file-descriptor}, \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?}, input port, along with an optional third boolean argument, \var{reset?},
which defaults to false. which defaults to false.
\scheme{make-source-file-descriptor} computes a checksum based on \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-line \var{source-object}) ;-> \var{uint} or #f
(source-object-column \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{obj} \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{reset?}) ;-> \var{sfd}
(source-file-descriptor? \var{obj}) ;-> \var{boolean} (source-file-descriptor? \var{obj}) ;-> \var{boolean}
(source-file-descriptor-checksum \var{sfd}) ;-> \var{obj} (source-file-descriptor-checksum \var{sfd}) ;-> \var{obj}
(source-file-descriptor-path \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 \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{obj} \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} \var{reset?})}
\returns a source-file descriptor \returns a source-file descriptor
\listlibraries \listlibraries
\endentryheader \endentryheader
@ -1870,16 +1870,17 @@ Otherwise, it is left pointing at end-of-file.
\listlibraries \listlibraries
\endentryheader \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 \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 \returns a new source-file-descriptor
\listlibraries \listlibraries
\endentryheader \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 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. 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 This procedure either uses cached information from a previous
request for \var{sfd} (only when \var{use-cache?} is provided as true) request for \var{sfd} (only when \var{use-cache?} is provided as true)
or attempts to locate and open the source file identified 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 If successful, it returns three values: a string \var{path}, an exact
nonnegative integer \var{line}, and an exact nonnegative integer \var{char} nonnegative integer \var{line}, and an exact nonnegative integer \var{char}
representing the absolute pathname, line, and character position within representing the absolute pathname, line, and character position within

15
csug/system.stex
View File

@ -1031,6 +1031,7 @@ will occur when the files are actually loaded.
%---------------------------------------------------------------------------- %----------------------------------------------------------------------------
\entryheader \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})}
\formdef{load-compiled-from-port}{\categoryprocedure}{(load-compiled-from-port \var{input-port} \var{externals})}
\returns result of the last compiled expression \returns result of the last compiled expression
\listlibraries \listlibraries
\endentryheader \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-script}, \scheme{compile-library}, and
\scheme{compile-to-port}. \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 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 form is in \var{input-port}. If \var{input-port} is empty, then the
result value is unspecified. 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})}
\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})}
\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})}
\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 \returns see below
\listlibraries \listlibraries
\endentryheader \endentryheader
@ -1533,6 +1540,8 @@ expression, \scheme{compile-to-port} raises an exception with
condition type \scheme{&syntax}. condition type \scheme{&syntax}.
\var{output-port} and, if present, \var{wpo-port} must be binary output ports. \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{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 \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 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} the program that opens the port and invokes \scheme{compile-to-port}
will take care of closing the 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 When \var{obj-list} contains a single list-structured element whose
first-element is the symbol \scheme{top-level-program}, first-element is the symbol \scheme{top-level-program},
\scheme{compile-to-port} returns a list of the libraries the top-level \scheme{compile-to-port} returns a list of the libraries the top-level

2
makefiles/Mf-install.in
View File

@ -62,7 +62,7 @@ InstallLZ4Target=
# no changes should be needed below this point # # no changes should be needed below this point #
############################################################################### ###############################################################################
Version=csv9.5.3.33 Version=csv9.5.3.34
Include=boot/$m Include=boot/$m
PetiteBoot=boot/$m/petite.boot PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot SchemeBoot=boot/$m/scheme.boot

12
mats/6.ms
View File

@ -993,6 +993,18 @@
(weak-pair? (cddr ls)) (weak-pair? (cddr ls))
(weak-pair? (cdddr ls))))) (weak-pair? (cdddr ls)))))
'(#t #f #t #t #f #t)) '(#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 (mat fasl-depth

8
mats/7.ms
View File

@ -113,7 +113,7 @@
) )
(mat load-compiled-from-port (mat load-compiled-from-port
(begin (let ()
(define-values (o get) (open-bytevector-output-port)) (define-values (o get) (open-bytevector-output-port))
(compile-to-port '((define lcfp1 'worked) 'loaded) o) (compile-to-port '((define lcfp1 'worked) 'loaded) o)
(eq? 'loaded (load-compiled-from-port (open-bytevector-input-port (get))))) (eq? 'loaded (load-compiled-from-port (open-bytevector-input-port (get)))))
@ -138,6 +138,12 @@
(equal? (equal?
(with-output-to-string (lambda () (printf "result = ~s\n" (revisit-compiled-from-port (open-bytevector-input-port lcfp-bv))))) (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") "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 (mat compile-to-file

7
mats/8.ms
View File

@ -11356,8 +11356,8 @@
) )
(mat annotations (mat annotations
(error? ; #f is not a string (source-file-descriptor?
(make-source-file-descriptor #f (make-source-file-descriptor #f ; anything is allowed as a path
(open-bytevector-input-port (string->utf8 "hello")))) (open-bytevector-input-port (string->utf8 "hello"))))
(error? ; 17 is not a binary-input port (error? ; 17 is not a binary-input port
(make-source-file-descriptor "foo" 17)) (make-source-file-descriptor "foo" 17))
@ -11584,7 +11584,7 @@
(eq? (source-object-sfd source) sfd) (eq? (source-object-sfd source) sfd)
(eqv? (source-object-bfp source) 0) (eqv? (source-object-bfp source) 0)
(eqv? (source-object-efp source) (string-length str)) (eqv? (source-object-efp source) (string-length str))
(error? ; not a string (source-file-descriptor?
(source-file-descriptor 'spam 0)) (source-file-descriptor 'spam 0))
(error? ; not an exact nonnegative integer (error? ; not an exact nonnegative integer
(source-file-descriptor "spam" -1)) (source-file-descriptor "spam" -1))
@ -11605,6 +11605,7 @@
(error? ; not an exact nonnegative integer (error? ; not an exact nonnegative integer
(locate-source sfd 'a)) (locate-source sfd 'a))
(let-values ([() (locate-source sfd 7)]) #t) (let-values ([() (locate-source sfd 7)]) #t)
(let-values ([() (locate-source (source-file-descriptor 'something-else 0) 7)]) #t)
(begin (begin
(with-output-to-file "testfile.ss" (with-output-to-file "testfile.ss"
(lambda () (lambda ()

8
mats/root-experr-compile-0-f-f-f
View File

@ -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 (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 ((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 (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-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-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 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 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-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: "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 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 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". 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: "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: 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 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: 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: #<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!". 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: #<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 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: "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 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: "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". 8.mo:Expected error in mat annotations: "locate-source: "spam" is not a source-file descriptor".

48
s/7.ss
View File

@ -134,8 +134,8 @@
(set-who! fasl-read (set-who! fasl-read
(let () (let ()
(define $fasl-read (foreign-procedure "(cs)fasl_read" (int fixnum 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)) (define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr int uptr uptr ptr ptr) ptr))
(define (get-uptr p) (define (get-uptr p)
(let ([k (get-u8 p)]) (let ([k (get-u8 p)])
(let f ([k k] [n (fxand k #x7F)]) (let f ([k k] [n (fxand k #x7F)])
@ -190,13 +190,13 @@
;; Call `get-bytevector-n`, etc. with interrupts reenabled ;; Call `get-bytevector-n`, etc. with interrupts reenabled
(lambda () (lambda ()
(proc (get-bytevector-n p len) 0))]))))) (proc (get-bytevector-n p len) 0))])))))
(define (go p situation) (define (go p situation externals)
(define (go1) (define (go1)
(if (and ($port-flags-set? p (constant port-flag-file)) (if (and ($port-flags-set? p (constant port-flag-file))
(or (not ($port-flags-set? p (constant port-flag-compressed))) (or (not ($port-flags-set? p (constant port-flag-compressed)))
(begin ($compressed-warning who p) #f)) (begin ($compressed-warning who p) #f))
(eqv? (binary-port-input-count p) 0)) (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 fasl-entry ()
(let ([ty (get-u8 p)]) (let ([ty (get-u8 p)])
(cond (cond
@ -232,26 +232,31 @@
(if (eqv? compressed-flag (constant fasl-type-gzip)) (if (eqv? compressed-flag (constant fasl-type-gzip))
(constant COMPRESS-GZIP) (constant COMPRESS-GZIP)
(constant COMPRESS-LZ4)))))]) (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)) [(eqv? compressed-flag (constant fasl-type-uncompressed))
(let ([len (- n 2)]) (let ([len (- n 2)])
(call-with-bytevector-and-offset (call-with-bytevector-and-offset
p len p len
(lambda (bv offset) (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")]))))) [else (malformed p "invalid compression")])))))
(unless (and (input-port? p) (binary-port? p)) (unless (and (input-port? p) (binary-port? p))
($oops who "~s is not a binary input port" p)) ($oops who "~s is not a binary input port" p))
(go1)) (go1))
(case-lambda (define (parse-situation situation)
[(p) (go p (constant fasl-type-visit-revisit))]
[(p situation)
(go p
(case situation (case situation
[(visit) (constant fasl-type-visit)] [(visit) (constant fasl-type-visit)]
[(revisit) (constant fasl-type-revisit)] [(revisit) (constant fasl-type-revisit)]
[(load) (constant fasl-type-visit-revisit)] [(load) (constant fasl-type-visit-revisit)]
[else ($oops who "invalid situation ~s" situation)]))]))) [else ($oops who "invalid situation ~s" situation)]))
(case-lambda
[(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) (define ($compiled-file-header? ip)
(let ([pos (port-position ip)]) (let ([pos (port-position ip)])
@ -265,12 +270,12 @@
(let () (let ()
(define do-load-binary (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 ([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) (unless (eof-object? x)
(let loop ([x 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) (if (eof-object? next-x)
(load-binary x) (load-binary x)
(begin (load-binary x) (loop next-x)))))))))) (begin (load-binary x) (loop next-x))))))))))
@ -323,7 +328,7 @@
(begin (set-port-position! ip start-pos) 0)))]) (begin (set-port-position! ip start-pos) 0)))])
(if ($compiled-file-header? ip) (if ($compiled-file-header? ip)
(begin (begin
(do-load-binary who fn ip situation for-import? importer) (do-load-binary who fn ip situation for-import? importer '#())
(close-port ip)) (close-port ip))
(begin (begin
(unless ksrc (unless ksrc
@ -341,22 +346,27 @@
(make-load-binary '$make-load-binary fn 'load #f #f))) (make-load-binary '$make-load-binary fn 'load #f #f)))
(set-who! load-compiled-from-port (set-who! load-compiled-from-port
(lambda (ip) (rec load-compiled-from-port
(case-lambda
[(ip) (load-compiled-from-port ip '#())]
[(ip externals)
(unless (and (input-port? ip) (binary-port? ip)) (unless (and (input-port? ip) (binary-port? ip))
($oops who "~s is not a binary input port" ip)) ($oops who "~s is not a binary input port" ip))
(do-load-binary who (port-name ip) ip 'load #f #f))) (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 (set-who! visit-compiled-from-port
(lambda (ip) (lambda (ip)
(unless (and (input-port? ip) (binary-port? ip)) (unless (and (input-port? ip) (binary-port? ip))
($oops who "~s is not a binary input 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 (set-who! revisit-compiled-from-port
(lambda (ip) (lambda (ip)
(unless (and (input-port? ip) (binary-port? ip)) (unless (and (input-port? ip) (binary-port? ip))
($oops who "~s is not a binary input 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 (set-who! load-program
(rec load-program (rec load-program

2
s/cmacros.ss
View File

@ -348,7 +348,7 @@
;; --------------------------------------------------------------------- ;; ---------------------------------------------------------------------
;; Version and machine types: ;; Version and machine types:
(define-constant scheme-version #x09050321) (define-constant scheme-version #x09050322)
(define-syntax define-machine-types (define-syntax define-machine-types
(lambda (x) (lambda (x)

56
s/compile.ss
View File

@ -457,8 +457,8 @@
[else (c-assembler-output-error c)])]))))))] [else (c-assembler-output-error c)])]))))))]
[else (c-assembler-output-error x)]))) [else (c-assembler-output-error x)])))
(define (c-print-fasl x p situation) (define (c-print-fasl x p situation external?-pred)
(let ([t ($fasl-table)] (let ([t ($fasl-table external?-pred)]
[a? (let ([flags (fxlogor [a? (let ([flags (fxlogor
(if (generate-inspector-information) (constant annotation-debug) 0) (if (generate-inspector-information) (constant annotation-debug) 0)
(if (eq? ($compile-profile) 'source) (constant annotation-profile) 0))]) (if (eq? ($compile-profile) 'source) (constant annotation-profile) 0))])
@ -520,7 +520,7 @@
x))) x)))
(define compile-file-help (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] (parameterize ([$target-machine machine]
[$sfd sfd] [$sfd sfd]
[$current-mso ($current-mso)] [$current-mso ($current-mso)]
@ -548,7 +548,7 @@
(let cfh0 ([n 1] [rrcinfo** '()] [rlpinfo** '()] [rfinal** '()]) (let cfh0 ([n 1] [rrcinfo** '()] [rlpinfo** '()] [rfinal** '()])
(let ([x0 ($pass-time 'read do-read)]) (let ([x0 ($pass-time 'read do-read)])
(if (eof-object? x0) (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 () (let ()
(define source-info-string (define source-info-string
(and (or ($assembly-output) (expand-output) (expand/optimize-output)) (and (or ($assembly-output) (expand-output) (expand/optimize-output))
@ -748,7 +748,7 @@
[else (finish-compile x1 values)])))))) [else (finish-compile x1 values)]))))))
(define compile-file-help2 (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-hash x) (symbol-hash (libreq-uid x)))
(define (libreq=? x y) (eq? (libreq-uid x) (libreq-uid y))) (define (libreq=? x y) (eq? (libreq-uid x) (libreq-uid y)))
(let ([import-ht (make-hashtable libreq-hash libreq=?)] (let ([import-ht (make-hashtable libreq-hash libreq=?)]
@ -767,18 +767,19 @@
rcinfo**) rcinfo**)
(let ([import-req* (vector->list (hashtable-keys import-ht))] (let ([import-req* (vector->list (hashtable-keys import-ht))]
[include-req* (vector->list (hashtable-keys include-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 ($pass-time 'pfasl
(lambda () (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 (for-each
(lambda (final*) (lambda (final*)
(for-each (for-each
(lambda (x) (lambda (x)
(record-case x (record-case x
[(visit-stuff) x (c-print-fasl x op (constant fasl-type-visit))] [(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))] [(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))])) [else (c-print-fasl x op (constant fasl-type-visit-revisit) external?-pred)]))
final*)) final*))
(append lpinfo** (append lpinfo**
(if (compile-omit-concatenate-support) (if (compile-omit-concatenate-support)
@ -857,7 +858,7 @@
(emit-header op (constant scheme-version) (constant machine-type)) (emit-header op (constant scheme-version) (constant machine-type))
(let loop ([x1* (reverse rx1*)] [rrcinfo** (list rcinfo*)] [rlpinfo** '()] [rfinal** '()]) (let loop ([x1* (reverse rx1*)] [rrcinfo** (list rcinfo*)] [rlpinfo** '()] [rfinal** '()])
(if (null? x1*) (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-values ([(rcinfo* lpinfo* final*)
(let ([x1 (car x1*)]) (let ([x1 (car x1*)])
(if (recompile-info? x1) (if (recompile-info? x1)
@ -1565,7 +1566,7 @@
(when source-table ($insert-profile-src! source-table x1)) (when source-table ($insert-profile-src! source-table x1))
(emit-header op (constant scheme-version) (constant machine-type)) (emit-header op (constant scheme-version) (constant machine-type))
(let-values ([(rcinfo* lpinfo* final*) (compile-file-help1 x1 msg)]) (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 (define write-wpo-file
(lambda (who ofn ir*) (lambda (who ofn ir*)
@ -1717,8 +1718,8 @@
(emit-header op (constant scheme-version) (constant machine-type) (map path-root (map path-last bootfiles))) (emit-header op (constant scheme-version) (constant machine-type) (map path-root (map path-last bootfiles)))
(when (null? bootfiles) (when (null? bootfiles)
(parameterize ([$target-machine machine] [$sfd #f]) (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 'error-invoke) op (constant fasl-type-visit-revisit) #f)
(c-print-fasl ($np-boot-code 'invoke) op (constant fasl-type-visit-revisit)) (c-print-fasl ($np-boot-code 'invoke) op (constant fasl-type-visit-revisit) #f)
($fasl-base-rtd #!base-rtd op))))) ($fasl-base-rtd #!base-rtd op)))))
(define do-make-boot-file (define do-make-boot-file
@ -1762,7 +1763,7 @@
(let ([sfd ($source-file-descriptor infn ip)]) (let ([sfd ($source-file-descriptor infn ip)])
; whack ip so close-port calls close the text port ; whack ip so close-port calls close the text port
(set! ip (transcoded-port ip (current-transcoder))) (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))) (close-port ip)))
infn*))))))) infn*)))))))
@ -1893,7 +1894,7 @@
(c-print-fasl `(object ,(make-recompile-info (c-print-fasl `(object ,(make-recompile-info
(vector->list (hashtable-keys import-ht)) (vector->list (hashtable-keys import-ht))
(vector->list (hashtable-keys include-ht)))) (vector->list (hashtable-keys include-ht))))
op (constant fasl-type-visit-revisit)) op (constant fasl-type-visit-revisit) #f)
(for-each (lambda (ip) (for-each (lambda (ip)
(let loop () ;; NB: This loop consumes one entry past the last library/program info record, (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. ;; which we presume is the #t end-of-header marker.
@ -1902,11 +1903,11 @@
;; perhaps should verify ty here. ;; perhaps should verify ty here.
(let ([x (fasl-read ip)]) (let ([x (fasl-read ip)])
(when (or (library-info? x) (program-info? x)) (when (or (library-info? x) (program-info? x))
(c-print-fasl `(object ,x) op ty) (c-print-fasl `(object ,x) op ty #f)
(loop))))))) (loop)))))))
ip*) ip*)
;; inserting #t after lpinfo as an end-of-header marker ;; 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)]) (let* ([bufsiz (file-buffer-size)] [buf (make-bytevector bufsiz)])
(for-each (lambda (ip) (for-each (lambda (ip)
(let loop () (let loop ()
@ -1976,7 +1977,7 @@
(if ($port-flags-set? ip (constant port-flag-char-positions)) (if ($port-flags-set? ip (constant port-flag-char-positions))
fp fp
(and (eqv? fp 0) 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))))]))) (when covop (put-source-table covop source-table))))])))
(set-who! compile-to-port (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) (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) (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) (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 (define do-compile-to-port
(lambda () (lambda ()
(let ([source-table (and covop (make-source-table))]) (let ([source-table (and covop (make-source-table))])
@ -1998,7 +2000,8 @@
(let ([x (car sexpr*)]) (let ([x (car sexpr*)])
(set! sexpr* (cdr sexpr*)) (set! sexpr* (cdr sexpr*))
x))) x)))
(port-name op)) (port-name op)
external?-pred)
(when covop (put-source-table covop source-table))))) (when covop (put-source-table covop source-table)))))
(unless (list? sexpr*) (unless (list? sexpr*)
($oops who "~s is not a proper list" sexpr*)) ($oops who "~s is not a proper list" sexpr*))
@ -2022,6 +2025,11 @@
(unless (and (output-port? hostop) (binary-port? hostop)) (unless (and (output-port? hostop) (binary-port? hostop))
($oops who "~s is not a binary output port or #f" 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 ($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)) (if (and (= (length sexpr*) 1) (pair? (car sexpr*)) (eq? (caar sexpr*) 'top-level-program))
(let ([library-collector (make-parameter '())]) (let ([library-collector (make-parameter '())])
(parameterize ([$require-libraries library-collector]) (parameterize ([$require-libraries library-collector])
@ -2046,7 +2054,7 @@
(lambda (wpoop) (lambda (wpoop)
(with-coverage-file who out (with-coverage-file who out
(lambda (source-table) (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?) (define (do-compile-file who in out hostout machine r6rs?)
(unless (string? in) ($oops who "~s is not a string" in)) (unless (string? in) ($oops who "~s is not a string" in))
@ -2126,7 +2134,7 @@
(when wpoop (put-u8 wpoop n))) (when wpoop (put-u8 wpoop n)))
(let ([fp (+ fp 1)]) (let ([fp (+ fp 1)])
(if (char=? c #\newline) fp (loop fp)))))]) (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 ; no #! line
(with-object-file who out (with-object-file who out
(lambda (op) (lambda (op)
@ -2135,7 +2143,7 @@
(lambda (wpoop) (lambda (wpoop)
(with-coverage-file who out (with-coverage-file who out
(lambda (source-table) (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)) (close-port ip))
(unless-feature windows (chmod out #o755))) (unless-feature windows (chmod out #o755)))

53
s/fasl.ss
View File

@ -41,13 +41,15 @@
(define rtd-flags (csv7:record-field-accessor #!base-rtd 'flags)) (define rtd-flags (csv7:record-field-accessor #!base-rtd 'flags))
(define-record-type table (define-record-type table
(fields (mutable count) (immutable hash)) (fields (mutable count) (immutable hash)
(immutable external?-pred) (mutable external-count) (mutable externals))
(nongenerative) (nongenerative)
(sealed #t) (sealed #t)
(protocol (protocol
(lambda (new) (lambda (new)
(lambda () (case-lambda
(new 0 (make-eq-hashtable)))))) [() (new 0 (make-eq-hashtable) #f 0 '())]
[(external?-pred) (new 0 (make-eq-hashtable) external?-pred 0 '())]))))
(include "fasl-helpers.ss") (include "fasl-helpers.ss")
@ -112,7 +114,7 @@
(lambda (x t a? d) (lambda (x t a? d)
(void))) (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 enable-dump-graph? #f)
(define vcat (if enable-dump-graph? (define vcat (if enable-dump-graph?
`#((code . ,(lambda (x) (and (pair? x) (eq? (car x) 'code)))) `#((code . ,(lambda (x) (and (pair? x) (eq? (car x) 'code))))
@ -153,6 +155,17 @@
#;(let ([n (hashtable-size (table-hash t))]) #;(let ([n (hashtable-size (table-hash t))])
(when (fx= (modulo n 10000) 0) (when (fx= (modulo n 10000) 0)
(printf "entries = ~s, ba = ~s, count = ~s\n" n (bytes-allocated) (table-count t)))) (printf "entries = ~s, ba = ~s, count = ~s\n" n (bytes-allocated) (table-count t))))
(cond
[(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) (record! ventry x)
(cond (cond
[(fx>= d 500) [(fx>= d 500)
@ -163,12 +176,19 @@
(handler x t a? 0)] (handler x t a? 0)]
[else [else
(set-cdr! a #f) (set-cdr! a #f)
(handler x t a? (fx+ d 1))])] (handler x t a? (fx+ d 1))])])]
[(not p) [(not p)
(record! vdup x) (record! vdup x)
(let ([n (table-count t)]) (let ([n (table-count t)])
(set-cdr! a (cons n #t)) (set-cdr! a (cons n #t))
(table-count-set! t (fx+ n 1)))]))))) (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)) (reset-dump-graph))
(define bld (define bld
@ -640,6 +660,7 @@
(module (start) (module (start)
(define start (define start
(lambda (p t situation proc) (lambda (p t situation proc)
(shift-externals! t)
(dump-graph) (dump-graph)
(let-values ([(bv* size) (let-values ([(bv* size)
(let-values ([(p extractor) ($open-bytevector-list-output-port)]) (let-values ([(p extractor) ($open-bytevector-list-output-port)])
@ -687,18 +708,22 @@
; when called from fasl-write or fasl-file, always preserve annotations; ; when called from fasl-write or fasl-file, always preserve annotations;
; otherwise use value passed in by the compiler ; otherwise use value passed in by the compiler
(define fasl-one (define fasl-one
(lambda (x p) (lambda (x p external?-pred)
(let ([t (make-table)]) (let ([t (make-table external?-pred)])
(bld x t (constant annotation-all) 0) (bld x t (constant annotation-all) 0)
(start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf x p t (constant annotation-all))))))) (start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf x p t (constant annotation-all)))))))
(define-who fasl-write (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)) (unless (and (output-port? p) (binary-port? p))
($oops who "~s is not a binary output 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)) (when ($port-flags-set? p (constant port-flag-compressed)) ($compressed-warning who p))
(emit-header p (constant scheme-version) (constant machine-type-any)) (emit-header p (constant scheme-version) (constant machine-type-any))
(fasl-one x p))) (fasl-one x p external?-pred)]))
(define-who fasl-file (define-who fasl-file
(lambda (in out) (lambda (in out)
@ -717,7 +742,7 @@
(let fasl-loop () (let fasl-loop ()
(let ([x (read ip)]) (let ([x (read ip)])
(unless (eof-object? x) (unless (eof-object? x)
(fasl-one x op) (fasl-one x op #f)
(fasl-loop))))) (fasl-loop)))))
(close-port op)) (close-port op))
(close-port ip))))) (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-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-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-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-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-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)))) (set! fasl-file (lambda (in out) ((target-fasl-file (fasl-target)) in out))))
(when ($unbound-object? (#%$top-level-value '$capture-fasl-target)) (when ($unbound-object? (#%$top-level-value '$capture-fasl-target))

18
s/pdhtml.ss
View File

@ -74,13 +74,13 @@
(lambda (new) (lambda (new)
(lambda () (lambda ()
(define sfd-hash (define sfd-hash
(lambda (sfd) (lambda (sfd)<
(source-file-descriptor-crc sfd))) (source-file-descriptor-crc sfd)))
(define sfd=? (define sfd=?
(lambda (sfd1 sfd2) (lambda (sfd1 sfd2)
(and (fx= (source-file-descriptor-crc sfd1) (source-file-descriptor-crc sfd2)) (and (fx= (source-file-descriptor-crc sfd1) (source-file-descriptor-crc sfd2))
(= (source-file-descriptor-length sfd1) (source-file-descriptor-length 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=?)))))) (new (make-hashtable sfd-hash sfd=?))))))
(define *local-profile-trackers* '()) (define *local-profile-trackers* '())
(define op+ car) (define op+ car)
@ -496,9 +496,11 @@
(source-file-descriptor-crc y)) (source-file-descriptor-crc y))
(= (source-file-descriptor-length x) (= (source-file-descriptor-length x)
(source-file-descriptor-length y)) (source-file-descriptor-length y))
(string=? (let ([maybe-path-last (lambda (p)
(path-last (source-file-descriptor-name x)) (if (string? p) (path-last p) p))])
(path-last (source-file-descriptor-name y)))))))]) (equal?
(maybe-path-last (source-file-descriptor-name x))
(maybe-path-last (source-file-descriptor-name y))))))))])
(define (open-source sfd) (define (open-source sfd)
(cond (cond
[(hashtable-ref fdata-ht sfd #f)] [(hashtable-ref fdata-ht sfd #f)]
@ -622,9 +624,11 @@
(source-file-descriptor-crc y)) (source-file-descriptor-crc y))
(= (source-file-descriptor-length x) (= (source-file-descriptor-length x)
(source-file-descriptor-length y)) (source-file-descriptor-length y))
(let ([maybe-path-last (lambda (p)
(if (string? p) (path-last p) p))])
(string=? (string=?
(path-last (source-file-descriptor-name x)) (maybe-path-last (source-file-descriptor-name x))
(path-last (source-file-descriptor-name y))))))))) (maybe-path-last (source-file-descriptor-name y))))))))))
(define profile-database #f) (define profile-database #f)
(define profile-source-data? #f) (define profile-source-data? #f)

14
s/primdata.ss
View File

@ -1237,7 +1237,7 @@
(compile-time-value? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (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-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-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-program [sig [(string string) (string string ptr) -> (void)]] [flags])
(compile-whole-library [sig [(string string) -> (void)]] [flags]) (compile-whole-library [sig [(string string) -> (void)]] [flags])
(compute-composition [sig [(ptr) -> (list)] [(ptr sub-ufixnum) -> (list)]] [flags alloc]) (compute-composition [sig [(ptr) -> (list)] [(ptr sub-ufixnum) -> (list)]] [flags alloc])
@ -1309,8 +1309,8 @@
(expand/optimize [sig [(ptr) (ptr environment) -> (ptr)]] [flags]) (expand/optimize [sig [(ptr) (ptr environment) -> (ptr)]] [flags])
(expt-mod [sig [(integer integer integer) -> (integer)]] [flags arith-op mifoldable discard]) (expt-mod [sig [(integer integer integer) -> (integer)]] [flags arith-op mifoldable discard])
(fasl-file [sig [(pathname pathname) -> (void)]] [flags true]) (fasl-file [sig [(pathname pathname) -> (void)]] [flags true])
(fasl-read [sig [(binary-input-port) (binary-input-port sub-symbol) -> (ptr)]] [flags]) (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) -> (void)]] [flags true]) (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]) (vfasl-convert-file [sig [(ptr ptr ptr) -> (void)]] [flags])
(file-access-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard]) (file-access-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard])
(file-change-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]) (list-head [sig [(sub-ptr sub-index) -> (list)]] [flags alloc])
(literal-identifier=? [sig [(identifier identifier) -> (boolean)]] [flags pure mifoldable discard cp03]) (literal-identifier=? [sig [(identifier identifier) -> (boolean)]] [flags pure mifoldable discard cp03])
(load [sig [(pathname) (pathname procedure) -> (void)]] [flags true ieee r5rs]) (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-library [sig [(pathname) (pathname procedure) -> (void)]] [flags true])
(load-program [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]) (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 [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-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-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-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-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]) (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]) (sort! [sig [(procedure list) -> (list)]] [flags true])
(source-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (source-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(source-condition-form [sig [(source-condition) -> (ptr)]] [flags pure 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? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(source-file-descriptor-checksum [sig [(sfd) -> (sint)]] [flags pure mifoldable discard true]) (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? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(source-object-bfp [sig [(source-object) -> (uint)]] [flags pure 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]) (source-object-column [sig [(source-object) -> (maybe-uint)]] [flags pure mifoldable discard])

3
s/read.ss
View File

@ -1633,13 +1633,14 @@
dir name)))) dir name))))
(search name (cdr dir*))))) (search name (cdr dir*)))))
(let ([name (source-file-descriptor-name sfd)]) (let ([name (source-file-descriptor-name sfd)])
(and (string? name)
(or (and ($fixed-path? name) (source-port name)) (or (and ($fixed-path? name) (source-port name))
(let ([dir* (append (source-directories) (map car (library-directories)))]) (let ([dir* (append (source-directories) (map car (library-directories)))])
(let pathloop ([name name]) (let pathloop ([name name])
(or (search name dir*) (or (search name dir*)
(let ([rest (path-rest name)]) (let ([rest (path-rest name)])
(and (not (string=? rest name)) (and (not (string=? rest name))
(pathloop rest)))))))))) (pathloop rest)))))))))))
(let ([source-lines-cache (make-weak-eq-hashtable)]) (let ([source-lines-cache (make-weak-eq-hashtable)])

22
s/strip.ss
View File

@ -469,25 +469,21 @@
(define write-entry (define write-entry
(lambda (p x) (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 (fasl-case x
[header (version machine dependencies) [header (version machine dependencies)
(emit-header p version machine dependencies)] (emit-header p version machine dependencies)]
[entry (situation fasl) [entry (situation fasl)
(let ([t (make-table)]) (let ([t (make-table)])
(build! fasl t) (build! fasl t)
($fasl-start p t situation (let-values ([(bv* size)
(lambda (p) (write-fasl p t fasl))))] (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)]))) [else (sorry! "unrecognized top-level fasl-record-type ~s" x)])))
(define write-graph (define write-graph

2
s/syntax.ss
View File

@ -10270,7 +10270,6 @@
(case-lambda (case-lambda
[(ifn bip) (make-source-file-descriptor ifn bip #f)] [(ifn bip) (make-source-file-descriptor ifn bip #f)]
[(ifn bip reset?) [(ifn bip reset?)
(unless (string? ifn) ($oops who "~s is not a string" ifn))
(unless (and (input-port? bip) (binary-port? bip)) (unless (and (input-port? bip) (binary-port? bip))
($oops who "~s is not a binary input port" bip)) ($oops who "~s is not a binary input port" bip))
(when reset? (when reset?
@ -10279,7 +10278,6 @@
($source-file-descriptor ifn bip reset?)]))) ($source-file-descriptor ifn bip reset?)])))
(set-who! source-file-descriptor (set-who! source-file-descriptor
(lambda (path checksum) (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))) (unless (if (fixnum? checksum) (fx>= checksum 0) (and (bignum? checksum) ($bigpositive? checksum)))
($oops who "~s is not an exact nonnegative integer" checksum)) ($oops who "~s is not an exact nonnegative integer" checksum))
(%make-source-file-descriptor path (ash checksum -16) (logand checksum #xffff)))) (%make-source-file-descriptor path (ash checksum -16) (logand checksum #xffff))))