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

various library-manager improvements including the ability to verify

Browse Source 
loadability without actually loading; also, support for unregistering
guarded objects.
- improved error reporting for library compilation-instance errors:
  now including the name of the object file from which the "wrong"
  compilation instance was loaded, if it was loaded from (or compiled
  to) an object file and the original importing library, if it was
  previously loaded from an object file due to a library import.
    syntax.ss, 7.ss, interpret.ss,
    8.ms, root-experr*
- removed situation and for-input? arguments from $make-load-binary,
  since the only consumer always passes 'load and #f.
    7.ss,
    scheme.c
- $separate-eval now prints the stderr and stdout of the subprocess
  to help in diagnosing separate-eval and separate-compile issues.
    mat.ss
- added unregister-guardian, which can be used to unregister
  the unressurected objects registered with any guardian.  guardian?
  can be used to distinguish guardian procedures from other objects.
    cp0.ss, cmacros.ss, cpnanopass.ss, ftype.ss, primdata.ss,
    prims.ss,
    gcwrapper.c, prim.c, externs.h,
    4.ms, primvars.ms
    release_notes.stex
    smgmt.stex, threads.stex
- added verify-loadability.  given a situation (visit, revisit,
  or load) and zero or more pathnames (each of which may be optionally
  paired with a library search path), verity-loadability checks
  whether the set of object files named by those pathnames and any
  additional object files required by library requirements in the
  given situation can be loaded together.  it raises an exception
  in each case where actually attempting to load the files would
  raise an exception and additionally in cases where loading files
  would result in the compilation or loading of source files in
  place of the object files.  if the check is successful,
  verity-loadability returns an unspecified value.  in either case,
  although portions of the object files are read, none of the
  information read from the object files is retained, and none of
  the object code is read, so there are no side effects other than
  the file operations and possibly the raising of an exception.
  library and program info records are now moved to the top of each
  object file produced by one of the file compilation routines,
  just after recompile info, with a marker to allow verity-loadability
  to stop reading once it reads all such records.  this change is
  not entirely backward compatible; the repositioning of the records
  can be detected by a call to list-library made from a loaded file
  before the definition of one or more libraries.  it is fully
  backward compatible for typical library files that contain a
  single library definition and nothing else.  adding this feature
  required changes to the object-file format and corresponding
  changes in the compiler and library manager.  it also required
  moving cross-library optimization information from library/ct-info
  records (which verity-loadability must read) to the invoke-code
  for each library (which verity-loadability  does not read) to
  avoid reading and permanently associating record-type descriptors
  in the code with their uids.
    compile.ss, syntax.ss, expand-lang.ss, primdata.ss, 7.ss,
    7.ms, misc.ms, root-experr*, patch*,
    system.stex, release_notes.stex
- fixed a bug that bit only with the compiler compiled at
  optimize-level 2: add-library/rt-records was building a library/ct-info
  wrapper rather than a library/rt-info wrapper.
    compile.ss
- fixed a bug in visit-library that could result in an indefinite
  recursion: it was not checking to make sure the call to $visit
  actually added compile-time info to the libdesc record.  it's not
  clear, however, whether the libdesc record can be missing
  compile-time information on entry to visit-library, so the code
  that calls $visit (and now checks for compile-time information
  having been added) might not be reachable.  ditto for
  revisit-library.
    syntax.ss
    syntax.ss, primdata.ss,
    7.ms, root-experr*, patch*,
    system.stex, release_notes.stex
- added some argument-error checks for library-directories and
  library-extensions, and fixed up the error messages a bit.
    syntax.ss,
    7.ms, root-experr*
- compile-whole-program now inserts the program record into the
  object file for the benefit of verify-loadability.
    syntax.ss,
    7.ms, root-experr*
- changed 'loading' import-notify messages to the more precise
  'visiting' or 'revisiting' in a couple of places.
    syntax.ss,
    7.ms, 8.ms

original commit: b911ed47190727b0e1d6a88c0e473d1757accdcd
This commit is contained in:
dybvig 2020-01-23 10:43:17 -08:00
parent c1a4de6f4f
commit 48db0a9405
33 changed files with 2176 additions and 662 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
LOG
View File

@ -1773,3 +1773,88 @@
whose body result is compiled to an allocation, inline form, or
foreign call
cpnanopass.ss, 3.ms
- improved error reporting for library compilation-instance errors:
now including the name of the object file from which the "wrong"
compilation instance was loaded, if it was loaded from (or compiled
to) an object file and the original importing library, if it was
previously loaded from an object file due to a library import.
syntax.ss, 7.ss, interpret.ss,
8.ms, root-experr*
- removed situation and for-input? arguments from $make-load-binary,
since the only consumer always passes 'load and #f.
7.ss,
scheme.c
- $separate-eval now prints the stderr and stdout of the subprocess
to help in diagnosing separate-eval and separate-compile issues.
mat.ss
- added unregister-guardian, which can be used to unregister
the unressurected objects registered with any guardian. guardian?
can be used to distinguish guardian procedures from other objects.
cp0.ss, cmacros.ss, cpnanopass.ss, ftype.ss, primdata.ss,
prims.ss,
gcwrapper.c, prim.c, externs.h,
4.ms, primvars.ms
release_notes.stex
smgmt.stex, threads.stex
- added verify-loadability. given a situation (visit, revisit,
or load) and zero or more pathnames (each of which may be optionally
paired with a library search path), verity-loadability checks
whether the set of object files named by those pathnames and any
additional object files required by library requirements in the
given situation can be loaded together. it raises an exception
in each case where actually attempting to load the files would
raise an exception and additionally in cases where loading files
would result in the compilation or loading of source files in
place of the object files. if the check is successful,
verity-loadability returns an unspecified value. in either case,
although portions of the object files are read, none of the
information read from the object files is retained, and none of
the object code is read, so there are no side effects other than
the file operations and possibly the raising of an exception.
library and program info records are now moved to the top of each
object file produced by one of the file compilation routines,
just after recompile info, with a marker to allow verity-loadability
to stop reading once it reads all such records. this change is
not entirely backward compatible; the repositioning of the records
can be detected by a call to list-library made from a loaded file
before the definition of one or more libraries. it is fully
backward compatible for typical library files that contain a
single library definition and nothing else. adding this feature
required changes to the object-file format and corresponding
changes in the compiler and library manager. it also required
moving cross-library optimization information from library/ct-info
records (which verity-loadability must read) to the invoke-code
for each library (which verity-loadability does not read) to
avoid reading and permanently associating record-type descriptors
in the code with their uids.
compile.ss, syntax.ss, expand-lang.ss, primdata.ss, 7.ss,
7.ms, misc.ms, root-experr*, patch*,
system.stex, release_notes.stex
- fixed a bug that bit only with the compiler compiled at
optimize-level 2: add-library/rt-records was building a library/ct-info
wrapper rather than a library/rt-info wrapper.
compile.ss
- fixed a bug in visit-library that could result in an indefinite
recursion: it was not checking to make sure the call to $visit
actually added compile-time info to the libdesc record. it's not
clear, however, whether the libdesc record can be missing
compile-time information on entry to visit-library, so the code
that calls $visit (and now checks for compile-time information
having been added) might not be reachable. ditto for
revisit-library.
syntax.ss
syntax.ss, primdata.ss,
7.ms, root-experr*, patch*,
system.stex, release_notes.stex
- added some argument-error checks for library-directories and
library-extensions, and fixed up the error messages a bit.
syntax.ss,
7.ms, root-experr*
- compile-whole-program now inserts the program record into the
object file for the benefit of verify-loadability.
syntax.ss,
7.ms, root-experr*
- changed 'loading' import-notify messages to the more precise
'visiting' or 'revisiting' in a couple of places.
syntax.ss,
7.ms, 8.ms

1
c/externs.h
View File

@ -139,6 +139,7 @@ extern void S_set_enable_object_counts PROTO((IBOOL eoc));
extern ptr S_object_counts PROTO((void));
extern void S_do_gc PROTO((IGEN g, IGEN gtarget));
extern ptr S_locked_objects PROTO((void));
extern ptr S_unregister_guardian PROTO((ptr tconc));
extern void S_compact_heap PROTO((void));
extern void S_check_heap PROTO((IBOOL aftergc));

27
c/gcwrapper.c
View File

@ -271,6 +271,33 @@ void Sunlock_object(x) ptr x; {
tc_mutex_release()
}
ptr s_help_unregister_guardian(ptr *pls, ptr tconc, ptr result) {
ptr rep, ls;
while ((ls = *pls) != Snil) {
if (GUARDIANTCONC(ls) == tconc) {
result = Scons(((rep = GUARDIANREP(ls)) == ftype_guardian_rep ? GUARDIANOBJ(ls) : rep), result);
*pls = ls = GUARDIANNEXT(ls);
} else {
ls = *(pls = &GUARDIANNEXT(ls));
}
}
return result;
}
ptr S_unregister_guardian(ptr tconc) {
ptr result, tc; IGEN g;
tc_mutex_acquire()
tc = get_thread_context();
/* in the interest of thread safety, gather entries only in the current thread, ignoring any others */
result = s_help_unregister_guardian(&GUARDIANENTRIES(tc), tconc, Snil);
/* plus, of course, any already known to the storage-management system */
for (g = 0; g <= static_generation; INCRGEN(g)) {
result = s_help_unregister_guardian(&S_G.guardians[g], tconc, result);
}
tc_mutex_release()
return result;
}
#ifndef WIN32
void S_register_child_process(INT child) {
tc_mutex_acquire()

1
c/prim.c
View File

@ -183,6 +183,7 @@ void S_prim_init() {
Sforeign_symbol("(cs)enable_object_counts", (void *)S_enable_object_counts);
Sforeign_symbol("(cs)set_enable_object_counts", (void *)S_set_enable_object_counts);
Sforeign_symbol("(cs)object_counts", (void *)S_object_counts);
Sforeign_symbol("(cs)unregister_guardian", (void *)S_unregister_guardian);
Sforeign_symbol("(cs)fire_collector", (void *)S_fire_collector);
}

2
c/scheme.c
View File

@ -851,7 +851,7 @@ static int set_load_binary(iptr n) {
if (!Ssymbolp(SYMVAL(S_G.scheme_version_id))) return 0; // set by back.ss
ptr make_load_binary = SYMVAL(S_G.make_load_binary_id);
if (Sprocedurep(make_load_binary)) {
S_G.load_binary = Scall3(make_load_binary, Sstring_utf8(bd[n].path, -1), Sstring_to_symbol("load"), Sfalse);
S_G.load_binary = Scall1(make_load_binary, Sstring_utf8(bd[n].path, -1));
return 1;
}
return 0;

88
csug/smgmt.stex
View File

@ -275,7 +275,12 @@ e.g.:
Collection can also be temporarily disabled using
\scheme{critical-section}, which prevents any interrupts from
occurring.
being handled.
In the threaded versions of {\ChezScheme}, the collect-request
handler is invoked by a single thread with all other threads
temporarily suspended.
%----------------------------------------------------------------------------
\entryheader
@ -547,7 +552,6 @@ reference, and that non-weak reference prevents the car field from becoming
(bwp-object? (car p)) ;=> #t
\endschemedisplay
%----------------------------------------------------------------------------
\entryheader
\formdef{make-guardian}{\categoryprocedure}{(make-guardian)}
@ -792,6 +796,86 @@ foreign address as an argument.
This would allow the header to be dropped from the Scheme
heap as soon as it becomes inaccessible.
Guardians can also be created via
\index{\scheme{ftype-guardian}}\scheme{ftype-guardian}, which
supports reference counting of foreign objects.
%----------------------------------------------------------------------------
\entryheader
\formdef{guardian?}{\categoryprocedure}{(guardian? \var{obj})}
\returns \scheme{#t} if obj is a guardian, \scheme{#f} otherwise
\listlibraries
\endentryheader
\schemedisplay
(guardian? (make-guardian)) ;=> #t
(guardian? (ftype-guardian iptr)) ;=> #t
(guardian? (lambda x x)) ;=> #f
(guardian? "oops") ;=> #f
\endschemedisplay
%----------------------------------------------------------------------------
\entryheader
\formdef{unregister-guardian}{\categoryprocedure}{(unregister-guardian \var{guardian})}
\returns see below
\listlibraries
\endentryheader
\noindent
\scheme{unregister-guardian} unregisters the
as-yet unresurrected objects currently registered with the guardian,
with one caveat.
The caveat, which applies only to threaded versions of {\ChezScheme},
is that objects registered with the guardian by other threads since
the last garbage collection might not be unregistered.
To ensure that all objects are unregistered in a multithreaded
application, a single thread can be used both to register and
unregister objects.
Alternatively, an application can arrange to define a
\index{\scheme{collect-request-handler}}collect-request
handler that calls \scheme{unregister-guardian} after it calls
\scheme{collect}.
In any case, \scheme{unregister-guardian} returns a list containing each object
(or its representative, if specified) that it unregisters, with
duplicates as appropriate if the same object is registered more
than once with the guardian.
Objects already resurrected but not yet retrieved from the guardian
are not included in the list but remain retrievable from the
guardian.
In the current implementation, \scheme{unregister-guardian} takes time proportional
to the number of unresurrected objects currently registered with
all guardians rather than those registered just with
the corresponding guardian.
The example below assumes no collections occur except for those resulting from
explicit calls to \scheme{collect}.
\schemedisplay
(define g (make-guardian))
(define x (cons 'a 'b))
(define y (cons 'c 'd))
(g x)
(g x)
(g y)
(g y)
(set! y #f)
(collect 0 0)
(unregister-guardian g) ;=> ((a . b) (a . b))
(g) ;=> (c . d)
(g) ;=> (c . d)
(g) ;=> #f
\endschemedisplay
\scheme{unregister-guardian} can also be used to unregister ftype
pointers registered with guardians created by
\index{\scheme{ftype-guardian}}\scheme{ftype-guardian}
(Section~\ref{SECTTHREADFTYPEGUARDIANS}).
\section{Locking Objects\label{SECTSMGMTLOCKING}}
All pointers from C variables or data structures to Scheme objects

46
csug/system.stex
View File

@ -979,6 +979,52 @@ The parameter \scheme{source-directories} (Section~\ref{SECTSYSTEMSOURCE})
determines the set of directories searched for source files not identified
by absolute path names.
%----------------------------------------------------------------------------
\entryheader
\formdef{verify-loadability}{\categoryprocedure}{(verify-loadability \var{situation} \var{input} \dots)}
\returns unspecified
\listlibraries
\endentryheader
\noindent
\var{situation} must be one of the symbols \scheme{visit}, \scheme{revisit}, or \scheme{load}.
Each \var{input} must be a string pathname or a pair of a string pathname and a library search path.
Each of the pathnames should name a file containing object code for a set of libraries and
top-level programs, such as would be produced by
\index{\scheme{compile-program}}\scheme{compile-program},
\index{\scheme{compile-library}}\scheme{compile-library},
\index{\scheme{compile-whole-program}}\scheme{compile-whole-program},
or
\index{\scheme{compile-whole-library}}\scheme{compile-whole-library}.
A library search path must be a suitable argument for
\index{\scheme{library-directories}}\scheme{library-directories}.
\scheme{verify-loadability} verifies, without actually loading any
code or definining any libraries, whether the object files named
by the specified pathnames and their library dependencies, direct
or indirect, are present, readable, and mutually compatible.
The type of dependencies for each named object file is determined
by the \var{situation} argument: compile-time dependencies for
\var{visit}, run-time dependencies for \var{revisit} and both for
\var{load}.
For each input pathname that is paired with a search path,
the \scheme{library-directories} parameter is parameterized to the
library search path during the recursive search for dependencies
of the programs and libraries found in the object file named by the
pathname.
If \scheme{verify-loadabilty} finds a problem, such as a missing
library dependency or compilation-instance mismatch, it raises an
exception with an appropriate condition.
Otherwise, it returns an unspecified value.
Since \scheme{verify-loadability} does not load or run any code
from the files it processes, it cannot determine whether errors
unrelated to missing or unreadable files or mutual compatibility
will occur when the files are actually loaded.
%----------------------------------------------------------------------------
\entryheader

9
csug/threads.stex
View File

@ -452,6 +452,14 @@ When the count reaches zero, the object is no longer needed and the
memory it formerly occupied can be made available for some other
purpose.
Ftype guardians are similar to guardians created by
\index{\scheme{make-guardian}}\scheme{make-guardian}
(Section~\ref{SECTGUARDWEAKPAIRS}).
The \index{\scheme{guardian?}}\scheme{guardian?} procedure returns
true for both, and the
\index{\scheme{unregister-guardian}}\scheme{unregister-guardian}
procedure can be used to unregister objects registered with either.
\entryheader
\formdef{ftype-guardian}{\categorysyntax}{(ftype-guardian \var{ftype-name})}
\returns a new ftype guardian
@ -551,6 +559,7 @@ objects whose reference counts should also be incremented upon
allocation of the containing object and decremented upon freeing
of the containing object.
\section{Thread Parameters\label{SECTTHREADPARAMETERS}}
%----------------------------------------------------------------------------

126
mats/4.ms
View File

@ -3479,6 +3479,52 @@
(error #f "no static-generation fraz in object-counts list"))
(pretty-print (cons g x)) ; keep 'em live
#t)
(parameterize ([collect-request-handler void])
(define (get-all g) (let ([q (g)]) (if q (cons q (get-all g)) '())))
(module (insist)
(define ($insist e? expr expected got)
(unless (e? got expected)
(errorf #f "expected ~s to return ~s, got ~s" expr expected got)))
(define-syntax insist
(syntax-rules ()
[(_ ?e? ?expr ?expected)
($insist ?e? '?expr ?expected ?expr)])))
(let ([g1 (make-guardian)] [g2 (make-guardian)])
(let ([x (box (cons 'a 'b))] [y (box (cons 'c 'd))])
(insist eq? (unregister-guardian g1) '())
(insist eq? (unregister-guardian g2) '())
(g1 (unbox x))
(g1 (unbox y))
(g2 (unbox x))
(g1 (unbox y))
(g1 (unbox x))
(collect 0 0)
(g2 (unbox x))
(g1 (cons 'e 'f))
(g2 (unbox x))
(g1 (unbox x))
(g2 (cons 'g 'h))
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(let ([q (unregister-guardian g2)])
(unless (and (= (length q) 4) (equal? (remove '(g . h) q) (list (unbox x) (unbox x) (unbox x))))
(errorf #f "expected (unregister-guardian g2) to contain x = (a . b), x = (a . b), and (g . h), got ~s" q)))
(insist eq? (unregister-guardian g2) '())
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(collect 0 0)
(insist equal? (get-all g1) '((e . f)))
(insist eq? (get-all g2) '())
(g2 (unbox x))
(set-box! x #f)
(collect 0 0)
(insist equal? (get-all g1) '((a . b) (a . b) (a . b)))
(insist equal? (get-all g2) '((a . b)))
(insist equal? (unregister-guardian g1) '((c . d) (c . d)))
(insist eq? (unregister-guardian g2) '())
(pretty-print (list g1 g2 x y)))) ; keep 'em live
#t)
)
(mat refcount-guardians
@ -3620,6 +3666,86 @@
(assert (not (regular-g)))
(assert (not (g)))
#t))
(parameterize ([collect-request-handler void])
(define-ftype A (struct (refcount iptr) (uid int)))
(define (get-all g)
(let ([a (g)])
(if a
(begin
(unless (eqv? (ftype-ref A (refcount) a) 0)
(errorf 'get-all "nonzero refcount ~s, uid ~s" (ftype-ref A (refcount) a) (ftype-ref A (uid) a)))
(cons a (get-all g)))
'())))
(module (insist)
(define ($insist e? expr expected got)
(unless (e? got expected)
(errorf #f "expected ~s to return ~s, got ~s" expr expected got)))
(define-syntax insist
(syntax-rules ()
[(_ ?e? ?expr ?expected)
($insist ?e? '?expr ?expected ?expr)])))
(define (get-uid a) (ftype-ref A (uid) a))
(define (fritter addr refcount uid)
(let ([a (make-ftype-pointer A addr)])
(ftype-set! A (refcount) a refcount)
(ftype-set! A (uid) a uid)
(box a)))
(let ([x-addr (foreign-alloc (ftype-sizeof A))] [y-addr (foreign-alloc (ftype-sizeof A))] [z-addr (foreign-alloc (ftype-sizeof A))])
(let ([x1 (fritter x-addr 6 73)] [x2 (box (make-ftype-pointer A x-addr))] [y (fritter y-addr 2 57)] [z (fritter z-addr 2 91)])
(let ([g1 (ftype-guardian A)] [g2 (ftype-guardian A)])
(insist eq? (unregister-guardian g1) '())
(insist eq? (unregister-guardian g2) '())
(g1 (unbox x1))
(g2 (unbox x1))
(g1 (unbox x1))
(g1 (unbox x2))
(g2 (unbox x1))
(g1 (unbox y))
(g1 (unbox y))
(g2 (unbox z))
(g1 (unbox z))
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(let ([q (unregister-guardian g2)])
(define (decr-refcount! a) (ftype-locked-decr! A (refcount) a))
(unless (and (= (length q) 3) (memq (unbox x1) (memq (unbox x1) q)) (memq (unbox z) q))
(errorf #f "expected (unregister-guardian g2) to contain x/uid 73, x/uid 73, and z/uid 91, got ~s" (map get-uid q)))
(map decr-refcount! q))
(insist eq? (unregister-guardian g2) '())
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(pretty-print z) ; keep it live
(set-box! z #f)
(collect 0 0)
(insist equal? (map get-uid (get-all g1)) '(91))
(insist eq? (get-all g2) '())
(g2 (unbox x1))
(pretty-print x1) ; keep it live
(set-box! x1 #f)
(collect 0 0)
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(insist eq? (unregister-guardian g2) '())
(insist eqv? (ftype-ref A (refcount) (unbox x2)) 1)
(pretty-print x2) ; keep it live
(set-box! x2 #f)
(collect 0 0)
(insist equal? (map get-uid (get-all g1)) '(73))
(insist equal? (map get-uid (get-all g2)) '())
(insist eq? (unregister-guardian g2) '())
(pretty-print y) ; keep it live
(set-box! y #f)
(collect 0 0)
(insist equal? (map get-uid (get-all g1)) '(57))
(insist equal? (map get-uid (get-all g2)) '())
(insist eq? (unregister-guardian g1) '())
(insist eq? (unregister-guardian g2) '())
(pretty-print (list g1 g2 x y)))) ; keep 'em live
(foreign-free x-addr)
(foreign-free y-addr)
(foreign-free z-addr))
#t)
)
(mat weak-cons

584
mats/7.ms
View File

@ -1999,6 +1999,11 @@ evaluating module init
(separate-eval '(load-program "testfile-wpo-prog4-all.so"))
"40320\n")
(eqv?
(separate-eval
'(verify-loadability 'load "testfile-wpo-prog4-all.so"))
"")
(delete-file "testfile-wpo-c4.so")
(error? ; library (testfile-wpo-c4) not found
@ -2114,14 +2119,28 @@ evaluating module init
(separate-eval '(load-program "testfile-wpo-prog6-all.so"))
"invoke a\ninvoke b\n==== (3 14 17) ======== (3 19 17) ====")
(eqv?
(separate-eval
'(verify-loadability 'load "testfile-wpo-prog6-all.so"))
"")
(begin
(with-output-to-file "testfile-wpo-aa7.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-aa7)
(export ax)
(import (chezscheme))
(define ax (gensym))
(printf "invoking aa\n"))))
'replace)
(with-output-to-file "testfile-wpo-a7.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-a7)
(export x)
(import (chezscheme))
(define x (gensym))
(import (chezscheme) (testfile-wpo-aa7))
(define x (cons ax (gensym)))
(printf "invoking a\n"))))
'replace)
(with-output-to-file "testfile-wpo-b7.ss"
@ -2160,7 +2179,7 @@ evaluating module init
(equal?
(separate-eval '(load "testfile-wpo-ab7.so"))
"invoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n")
"invoking aa\ninvoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n")
(delete-file "testfile-wpo-c7.ss")
(delete-file "testfile-wpo-c7.wpo")
@ -2175,7 +2194,7 @@ evaluating module init
(equal?
(separate-eval '(load "testfile-wpo-ab7-all.so"))
"invoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n")
"invoking aa\ninvoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n")
(begin
(with-output-to-file "testfile-wpo-extlib.chezscheme.sls"
@ -2248,6 +2267,53 @@ evaluating module init
(lambda (ip)
(get-bytevector-n ip (string-length $hash-bang-line))))
(string->utf8 $hash-bang-line))
(eqv?
(separate-eval
'(verify-loadability 'load "testfile-wpo-c8-all.so"))
"")
(begin
(mkfile "testfile-wpo-a9.ss"
'(library (testfile-wpo-a9)
(export x)
(import (chezscheme))
(define x (eval 'x (environment '(testfile-wpo-a9))))))
(mkfile "testfile-wpo-b9.ss"
'(import (chezscheme) (testfile-wpo-a9))
'(printf "x = ~s\n" x))
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t] [compile-imported-libraries #t])
(compile-program x)))
'wpo-b9)
(separate-compile
'(lambda (x)
(compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t))
'wpo-b9)
(separate-compile
'(lambda (x)
(compile-whole-library (format "~a.wpo" x) (format "~a-all.so" x)))
'wpo-a9)
#t)
(error? ; invoke cycle
(separate-eval
'(load-library "testfile-wpo-a9.so")
'(let () (import (testfile-wpo-a9)) x)))
(error? ; invoke cycle
(separate-eval
'(load-library "testfile-wpo-a9-all.so")
'(let () (import (testfile-wpo-a9)) x)))
(error? ; invoke cycle
(separate-eval
'(load-program "testfile-wpo-b9.so")))
(error? ; invoke cycle
(separate-eval
'(load-program "testfile-wpo-b9-all.so")))
)
(mat compile-whole-library
@ -2304,6 +2370,11 @@ evaluating module init
(printf ">~s\n" (y))))
"invoke a\ninvoke b\n>(3 14 17)\n>(3 19 17)\n")
(eqv?
(separate-eval
'(verify-loadability 'load "testfile-cwl-b1.so"))
"")
(error? ; library (testfile-cwl-a1) not found
(separate-eval
'(begin
@ -2383,6 +2454,11 @@ evaluating module init
(main)))
"3628800\n")
(eqv?
(separate-eval
'(verify-loadability 'load "testfile-cwl-b2.so"))
"")
(equal?
(separate-compile
'(lambda (x)
@ -3906,6 +3982,11 @@ evaluating module init
(eqv?
(let () (import (testfile-cwl-a14)) a)
123)
(eqv?
(separate-eval
'(verify-loadability 'load "testfile-cwl-a14.library"))
"")
)
(mat maybe-compile-whole
@ -4185,7 +4266,7 @@ evaluating module init
"import: found source file \"testfile-lm-a.ss\"\n"
"import: found corresponding object file \"testfile-lm-a.so\"\n"
"import: object file is not older\n"
"import: loading object file \"testfile-lm-a.so\"\n"
"import: visiting object file \"testfile-lm-a.so\"\n"
"ct-a rhs\n"
"b = \"odd\"\n"))
(equal?
@ -4199,7 +4280,7 @@ evaluating module init
"import: found source file \"testfile-lm-a.ss\"\n"
"import: found corresponding object file \"testfile-lm-a.so\"\n"
"import: object file is not older\n"
"import: loading object file \"testfile-lm-a.so\"\n"
"import: visiting object file \"testfile-lm-a.so\"\n"
"attempting to 'revisit' previously 'visited' \"testfile-lm-a.so\" for library (testfile-lm-a) run-time info\n"
"rt-a rhs\n"
"c = 456\n"))
@ -4215,7 +4296,7 @@ evaluating module init
"import: found source file \"testfile-lm-c.ss\"\n"
"import: found corresponding object file \"testfile-lm-c.so\"\n"
"import: object file is not older\n"
"import: loading object file \"testfile-lm-c.so\"\n"
"import: visiting object file \"testfile-lm-c.so\"\n"
"import: attempting to 'revisit' previously 'visited' \"testfile-lm-c.so\" for library (testfile-lm-c) run-time info\n"
"import: attempting to 'revisit' previously 'visited' \"testfile-lm-a.so\" for library (testfile-lm-a) run-time info\n"
"rt-a rhs\n"
@ -4232,7 +4313,7 @@ evaluating module init
"import: found source file \"testfile-lm-b.ss\"\n"
"import: found corresponding object file \"testfile-lm-b.so\"\n"
"import: object file is not older\n"
"import: loading object file \"testfile-lm-b.so\"\n"
"import: visiting object file \"testfile-lm-b.so\"\n"
"import: attempting to 'visit' previously 'revisited' \"testfile-lm-a.so\" for library (testfile-lm-a) compile-time info\n"
"import: attempting to 'revisit' previously 'visited' \"testfile-lm-b.so\" for library (testfile-lm-b) run-time info\n"
"\"odd\"\n"))
@ -4308,6 +4389,493 @@ evaluating module init
"\"odd\"\n"))
)
(mat verify-loadability
(error? ; invalid argument
(verify-loadability 'never))
(error? ; invalid argument
(verify-loadability 'never "hello.so"))
(error? ; invalid argument
(verify-loadability #f "hello.so" "goodbye.so"))
(error? ; invalid argument
(verify-loadability 'load 'hello))
(error? ; invalid argument
(verify-loadability 'load '(a . "testdir")))
(error? ; invalid argument
(verify-loadability 'load '#("a" "testdir")))
(error? ; invalid argument
(verify-loadability 'load "testfile1.so" "testfile2.so" 'hello))
(error? ; invalid argument
(verify-loadability 'load "testfile1.so" "testfile2.so" '(a . "testdir")))
(error? ; invalid argument
(verify-loadability 'load '("a" . hello)))
(error? ; invalid argument
(verify-loadability 'load '("a" . ("src" . "obj"))))
(error? ; invalid argument
(verify-loadability 'load '("a" . (("src" "obj")))))
(error? ; invalid argument
(verify-loadability 'load '("a" . ((("src" "obj"))))))
(begin
(define install
(lambda (dir . fn*)
(for-each
(lambda (fn)
(call-with-port (open-file-input-port fn)
(lambda (ip)
(call-with-port (open-file-output-port (format "~a/~a" dir (path-last fn)))
(lambda (op)
(put-bytevector op (get-bytevector-all ip)))))))
fn*)))
#t)
(eq? (verify-loadability 'visit) (void))
(eq? (verify-loadability 'revisit) (void))
(eq? (verify-loadability 'load) (void))
(error? ; not found
(verify-loadability 'load "probably not found"))
(begin
(mkfile "testfile-clA.ss"
'(import (chezscheme) (testfile-clB) (testfile-clC))
'(printf "~a, ~a\n" b c))
(mkfile "testfile-clB.ss"
'(library (testfile-clB)
(export b)
(import (chezscheme) (testfile-clB1))
(define-syntax go (lambda (x) (datum->syntax #'* (b1))))
(define b (go))))
(mkfile "testfile-clB1.ss"
'(library (testfile-clB1)
(export b1)
(import (chezscheme))
(define b1 (lambda () "hello from B1"))))
(mkfile "testfile-clC.ss"
'(library (testfile-clC)
(export c)
(import (chezscheme) (testfile-clC1))
(define c (c1))))
(mkfile "testfile-clC1.ss"
'(library (testfile-clC1)
(export c1)
(import (chezscheme))
(define-syntax c1 (syntax-rules () [(_) "hello from C1"]))))
(rm-rf "testdir-obj1")
(rm-rf "testdir-obj2")
(mkdir "testdir-obj1")
(mkdir "testdir-obj2")
(separate-eval
'(parameterize ([library-directories '(("." . "testdir-obj1"))] [compile-imported-libraries #t])
(compile-program "testfile-clA.ss" "testdir-obj1/testfile-clA.so")))
(separate-eval
'(parameterize ([library-directories '(("." . "testdir-obj2"))] [compile-imported-libraries #t])
(compile-program "testfile-clA.ss" "testdir-obj2/testfile-clA.so")))
#t)
(begin
(rm-rf "testdir-dist1")
(mkdir "testdir-dist1")
(install "testdir-dist1" "testdir-obj1/testfile-clA.so" "testdir-obj1/testfile-clB.so" "testdir-obj1/testfile-clC.so")
#t)
(eqv?
(separate-eval
'(parameterize ([cd "testdir-dist1"])
(verify-loadability 'visit "testfile-clA.so")
(verify-loadability 'revisit "testfile-clA.so")
(verify-loadability 'load "testfile-clA.so")))
"")
(equal?
(separate-eval
'(parameterize ([cd "testdir-dist1"])
(load-program "testfile-clA.so")))
"hello from B1, hello from C1\n")
(error? ; missing B1
(separate-eval
'(parameterize ([cd "testdir-dist1"])
(verify-loadability 'visit "testfile-clB.so"))))
(error? ; missing B1
(separate-eval
'(parameterize ([cd "testdir-dist1"])
(verify-loadability 'load "testfile-clB.so"))))
(error? ; missing C1
(separate-eval
'(parameterize ([cd "testdir-dist1"])
(verify-loadability 'visit "testfile-clC.so"))))
(error? ; missing C1
(separate-eval
'(parameterize ([cd "testdir-dist1"])
(verify-loadability 'load "testfile-clC.so"))))
(begin
(rm-rf "testdir-dist2")
(mkdir "testdir-dist2")
(install "testdir-dist2" "testdir-obj2/testfile-clA.so" "testdir-obj2/testfile-clB.so" "testdir-obj2/testfile-clC.so")
#t)
(equal?
(separate-eval
'(parameterize ([cd "testdir-dist2"])
(load-program "testfile-clA.so")))
"hello from B1, hello from C1\n")
(error? ; mismatched compilation instance
(separate-eval
'(verify-loadability 'revisit
'("testdir-dist1/testfile-clA.so" . "testdir-dist1")
'("testdir-dist2/testfile-clA.so" . "testdir-dist2"))))
(error? ; mismatched compilation instance
(separate-eval
'(verify-loadability 'load
'("testdir-dist1/testfile-clA.so" . "testdir-dist1")
'("testdir-dist2/testfile-clA.so" . "testdir-dist2"))))
(begin
(rm-rf "testdir-dist3")
(mkdir "testdir-dist3")
(install "testdir-dist3" "testdir-obj1/testfile-clA.so" "testdir-obj1/testfile-clB.so" "testdir-obj2/testfile-clC.so")
#t)
(error? ; mismatched compilation instance
(separate-eval
'(parameterize ([cd "testdir-dist3"])
(load-program "testfile-clA.so"))))
(eqv? ; no compile-time requirements, so no problem
(separate-eval
'(parameterize ([cd "testdir-dist3"])
(verify-loadability 'visit "testfile-clA.so")))
"")
(error? ; mismatched compilation instance
(separate-eval
'(parameterize ([cd "testdir-dist3"])
(verify-loadability 'revisit "testfile-clA.so"))))
(error? ; mismatched compilation instance
(separate-eval
'(parameterize ([cd "testdir-dist3"])
(verify-loadability 'load "testfile-clA.so"))))
(equal?
(separate-eval
'(parameterize ([cd "testdir-dist3"])
(unless (guard (c [else (printf "yes\n")]) (verify-loadability 'load "testfile-clA.so") #f)
(errorf #f "oops")))
'(parameterize ([cd "testdir-dist1"])
(printf "~s\n" (verify-loadability 'load "testfile-clA.so")))
'(parameterize ([cd "testdir-dist2"])
(printf "~s\n" (verify-loadability 'load "testfile-clA.so")))
'(let* ([ls (library-list)] [f (lambda (x) (and (member x ls) #t))])
(printf "~s\n" (map f '((testfile-clB) (testfile-clB1) (testfile-clC) (testfile-clC1)))))
'(parameterize ([cd "testdir-dist1"])
(load-program "testfile-clA.so"))
'(let* ([ls (library-list)] [f (lambda (x) (and (member x ls) #t))])
(printf "~s\n" (map f '((testfile-clB) (testfile-clB1) (testfile-clC) (testfile-clC1))))))
"yes\n#<void>\n#<void>\n(#f #f #f #f)\nhello from B1, hello from C1\n(#t #f #t #f)\n")
(equal?
(separate-eval
'(parameterize ([cd "testdir-dist3"])
(unless (guard (c [else (printf "yes\n")]) (verify-loadability 'load "testfile-clA.so") #f)
(errorf #f "oops")))
'(parameterize ([cd "testdir-dist1"])
(printf "~s\n" (verify-loadability 'load "testfile-clA.so")))
'(parameterize ([cd "testdir-dist2"])
(printf "~s\n" (verify-loadability 'load "testfile-clA.so")))
'(let* ([ls (library-list)] [f (lambda (x) (and (member x ls) #t))])
(printf "~s\n" (map f '((testfile-clB) (testfile-clB1) (testfile-clC) (testfile-clC1)))))
'(parameterize ([cd "testdir-dist2"])
(load-program "testfile-clA.so"))
'(let* ([ls (library-list)] [f (lambda (x) (and (member x ls) #t))])
(printf "~s\n" (map f '((testfile-clB) (testfile-clB1) (testfile-clC) (testfile-clC1))))))
"yes\n#<void>\n#<void>\n(#f #f #f #f)\nhello from B1, hello from C1\n(#t #f #t #f)\n")
(error? ; mismatched compilation instance
(separate-eval
'(parameterize ([library-directories '(("testdir-dist1" . "testdir-dist1"))])
(verify-loadability 'load "testdir-dist2/testfile-clA.so"))))
(error? ; mismatched compilation instance
(separate-eval
'(parameterize ([library-directories '(("testdir-dist1" . "testdir-dist1"))])
(verify-loadability 'load "testdir-dist1/testfile-clA.so" "testdir-dist2/testfile-clA.so"))))
(begin
(mkfile "testfile-clPD.ss"
'(import (chezscheme) (testfile-clD))
'(printf "~s\n" (make-Q)))
(mkfile "testfile-clPE.ss"
'(import (chezscheme) (testfile-clE))
'(printf "~s\n" (make-Q 73)))
(mkfile "testfile-clD.ss"
'(library (testfile-clD) (export make-Q Q? Q-x) (import (chezscheme) (testfile-clF))
(define-record-type Q
(nongenerative Q)
(fields x)
(protocol (lambda (new) (lambda () (new f)))))))
(mkfile "testfile-clE.ss"
'(library (testfile-clE) (export make-Q Q? Q-x) (import (chezscheme) (testfile-clG))
(define-record-type Q
(nongenerative Q)
(fields x y)
(protocol (lambda (new) (lambda (y) (new g y)))))))
(mkfile "testfile-clF.ss"
'(library (testfile-clF) (export f) (import (chezscheme)) (define f 77)))
(mkfile "testfile-clG.ss"
'(library (testfile-clG) (export g) (import (chezscheme)) (define g 123)))
(rm-rf "testdir-obj")
(mkdir "testdir-obj")
(separate-eval
'(parameterize ([library-directories '(("." . "testdir-obj"))] [compile-imported-libraries #t])
(compile-program "testfile-clPD.ss" "testdir-obj/testfile-clPD.so")))
(separate-eval
'(parameterize ([library-directories '(("." . "testdir-obj"))] [compile-imported-libraries #t])
(compile-program "testfile-clPE.ss" "testdir-obj/testfile-clPE.so")))
#t)
(begin
(rm-rf "testdir-dist")
(mkdir "testdir-dist")
(install "testdir-dist" "testdir-obj/testfile-clPD.so" "testdir-obj/testfile-clD.so" "testdir-obj/testfile-clF.so")
(install "testdir-dist" "testdir-obj/testfile-clPE.so" "testdir-obj/testfile-clE.so" "testdir-obj/testfile-clG.so")
#t)
(error? ; incompatible record-type Q
(separate-eval
'(cd "testdir-dist")
'(load-program "testfile-clPD.so")
'(load-program "testfile-clPE.so")))
(equal?
(separate-eval
'(cd "testdir-dist")
'(verify-loadability 'visit "testfile-clPD.so" "testfile-clPE.so")
'(verify-loadability 'visit "testfile-clD.so" "testfile-clE.so")
'(verify-loadability 'visit "testfile-clF.so" "testfile-clG.so")
'(verify-loadability 'revisit "testfile-clPD.so" "testfile-clPE.so")
'(verify-loadability 'revisit "testfile-clD.so" "testfile-clE.so")
'(verify-loadability 'revisit "testfile-clF.so" "testfile-clG.so")
'(verify-loadability 'load "testfile-clPD.so" "testfile-clPE.so")
'(verify-loadability 'load "testfile-clD.so" "testfile-clE.so")
'(verify-loadability 'load "testfile-clF.so" "testfile-clG.so")
'(verify-loadability 'load "testfile-clPD.so" "testfile-clPE.so" "testfile-clD.so" "testfile-clE.so" "testfile-clF.so" "testfile-clG.so")
'(load-program "testfile-clPD.so")
'(verify-loadability 'load "testfile-clPD.so" "testfile-clE.so"))
"#[Q 77]\n")
(equal?
(separate-eval
'(cd "testdir-dist")
'(verify-loadability 'visit "testfile-clPD.so" "testfile-clE.so")
'(verify-loadability 'visit "testfile-clD.so" "testfile-clE.so")
'(verify-loadability 'visit "testfile-clF.so" "testfile-clG.so")
'(verify-loadability 'revisit "testfile-clPD.so" "testfile-clE.so")
'(verify-loadability 'revisit "testfile-clD.so" "testfile-clE.so")
'(verify-loadability 'revisit "testfile-clF.so" "testfile-clG.so")
'(verify-loadability 'load "testfile-clPD.so" "testfile-clE.so")
'(verify-loadability 'load "testfile-clD.so" "testfile-clE.so")
'(verify-loadability 'load "testfile-clF.so" "testfile-clG.so")
'(verify-loadability 'load "testfile-clPD.so" "testfile-clPE.so" "testfile-clD.so" "testfile-clE.so" "testfile-clF.so" "testfile-clG.so")
'(load-program "testfile-clPE.so")
'(verify-loadability 'load "testfile-clPD.so" "testfile-clE.so"))
"#[Q 123 73]\n")
(begin
(mkfile "testfile-clH0.ss"
'(library (testfile-clH0) (export h0) (import (chezscheme))
(define h0 (lambda (x) (cons x 'a)))))
(mkfile "testfile-clH1.ss"
'(top-level-program
(import (chezscheme) (testfile-clH0))
(printf "~s\n" (h0 73))))
(mkfile "testfile-clH2.ss"
'(include "testfile-clH0.ss")
'(top-level-program
(import (chezscheme) (testfile-clH0))
(printf "~s\n" (h0 37))))
(rm-rf "testdir-obj")
(mkdir "testdir-obj")
(separate-eval
'(parameterize ([library-directories '(("." . "testdir-obj"))] [compile-imported-libraries #t])
(compile-file "testfile-clH1.ss" "testdir-obj/testfile-clH1.so")))
(separate-eval
'(parameterize ([library-directories '(("." . "testdir-obj"))] [compile-imported-libraries #t])
(compile-file "testfile-clH2.ss" "testdir-obj/testfile-clH2.so")))
#t)
(equal?
(separate-eval
'(parameterize ([library-directories '(("testdir-obj" . "testdir-obj"))])
(revisit "testdir-obj/testfile-clH1.so")))
"(73 . a)\n")
(equal?
(separate-eval
'(parameterize ([library-directories '(("testdir-obj" . "testdir-obj"))])
(revisit "testdir-obj/testfile-clH2.so")))
"(37 . a)\n")
(eqv?
(separate-eval
'(let ([libdirs '(("testdir-obj" . "testdir-obj"))])
(verify-loadability 'revisit (cons "testdir-obj/testfile-clH1.so" libdirs) (cons "testdir-obj/testfile-clH2.so" libdirs))))
"")
(error? ; mismatched compilation instance
(separate-eval
'(let ([libdirs '(("testdir-obj" . "testdir-obj"))])
(verify-loadability 'revisit (cons "testdir-obj/testfile-clH2.so" libdirs) (cons "testdir-obj/testfile-clH1.so" libdirs)))))
; make sure verify-loadability respects eval-when forms
(begin
(mkfile "testfile-clI0.ss"
'(library (testfile-clI0) (export x) (import (chezscheme)) (define x 10) (printf "invoking I0\n")))
(mkfile "testfile-clI1.ss"
'(eval-when (visit)
(top-level-program
(import (chezscheme) (testfile-clI0))
(printf "running I1, x = ~s\n" x))))
(separate-eval
'(parameterize ([compile-imported-libraries #t])
(compile-file "testfile-clI1")))
#t)
(equal?
(separate-eval '(visit "testfile-clI1.so"))
"invoking I0\nrunning I1, x = 10\n")
(equal?
(separate-eval '(revisit "testfile-clI1.so"))
"")
(equal?
(separate-eval '(load "testfile-clI1.so"))
"invoking I0\nrunning I1, x = 10\n")
(eq?
(verify-loadability 'visit "testfile-clI1.so")
(void))
(eq?
(verify-loadability 'revisit "testfile-clI1.so")
(void))
(eq?
(verify-loadability 'load "testfile-clI1.so")
(void))
(delete-file "testfile-clI0.ss")
(delete-file "testfile-clI0.so")
(error?
(verify-loadability 'visit "testfile-clI1.so"))
(eq?
(verify-loadability 'revisit "testfile-clI1.so")
(void))
(error?
(verify-loadability 'load "testfile-clI1.so"))
; make sure compile-whole-program perserves the information verify-loadability needs
(begin
(mkfile "testfile-clJ0.ss"
'(library (testfile-clJ0) (export x0) (import (chezscheme)) (define x0 'eat) (printf "invoking J0\n")))
(mkfile "testfile-clJ1.ss"
'(library (testfile-clJ1) (export x1) (import (chezscheme) (testfile-clJ0)) (define x1 (list x0 'oats)) (printf "invoking J1\n")))
(mkfile "testfile-clJ2.ss"
'(library (testfile-clJ2) (export x2) (import (chezscheme) (testfile-clJ1)) (define x2 (cons 'mares x1)) (printf "invoking J2\n")))
(mkfile "testfile-clJ3.ss"
'(import (chezscheme) (testfile-clJ2))
'(printf "running J3, x2 = ~s\n" x2))
(separate-eval
'(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(compile-program "testfile-clJ3")))
#t)
(equal?
(separate-eval '(verify-loadability 'load "testfile-clJ3.so"))
"")
(equal?
(separate-eval '(load-program "testfile-clJ3.so"))
"invoking J0\ninvoking J1\ninvoking J2\nrunning J3, x2 = (mares eat oats)\n")
(delete-file "testfile-clJ0.ss")
(delete-file "testfile-clJ0.wpo")
(delete-file "testfile-clJ2.ss")
(delete-file "testfile-clJ2.wpo")
((lambda (x ls) (and (member x ls) #t))
(separate-eval
'(compile-whole-program "testfile-clJ3.wpo" "testfile-clJ3-all.so"))
'("((testfile-clJ0) (testfile-clJ2))\n"
"((testfile-clJ2) (testfile-clJ0))\n"))
(delete-file "testfile-clJ1.ss")
(delete-file "testfile-clJ1.wpo")
(delete-file "testfile-clJ1.so")
(equal?
(separate-eval '(verify-loadability 'load "testfile-clJ3-all.so"))
"")
(equal?
(separate-eval '(load-program "testfile-clJ3-all.so"))
"invoking J0\ninvoking J1\ninvoking J2\nrunning J3, x2 = (mares eat oats)\n")
(eq?
(rename-file "testfile-clJ0.so" "testfile-clJ0.sav")
(void))
(error? ; missing testfile-clJ0.so
(separate-eval '(verify-loadability 'load "testfile-clJ3-all.so")))
(error? ; missing testfile-clJ0.so
(separate-eval '(load-program "testfile-clJ3-all.so")))
(eq?
(rename-file "testfile-clJ0.sav" "testfile-clJ0.so")
(void))
(delete-file "testfile-clJ2.so")
(error? ; missing testfile-clJ2.so
(separate-eval '(verify-loadability 'load "testfile-clJ3-all.so")))
(error? ; missing testfile-clJ2.so
(separate-eval '(load-program "testfile-clJ3-all.so")))
(begin
(mkfile "testfile-clK0.ss"
'(library (testfile-clK0) (export x0) (import (chezscheme)) (define x0 "chocolate") (printf "invoking K0\n")))
(mkfile "testfile-clK1.ss"
'(library (testfile-clK1) (export x1) (import (chezscheme) (testfile-clK0)) (define x1 (format "~a chip" x0)) (printf "invoking K1\n")))
(mkfile "testfile-clK2.ss"
'(import (chezscheme) (testfile-clK1))
'(printf "running K2, x1 = ~s\n" x1))
(separate-eval
'(parameterize ([compile-imported-libraries #t])
(compile-program "testfile-clK2")))
#t)
(eq?
(verify-loadability 'visit "testfile-clK1.so")
(void))
(eq?
(verify-loadability 'revisit "testfile-clK1.so")
(void))
(eq?
(verify-loadability 'load "testfile-clK1.so")
(void))
(eq?
(verify-loadability 'visit "testfile-clK1.so" "testfile-clK2.so")
(void))
(eq?
(verify-loadability 'revisit "testfile-clK1.so" "testfile-clK2.so")
(void))
(eq?
(verify-loadability 'load "testfile-clK1.so" "testfile-clK2.so")
(void))
(eq?
(verify-loadability 'visit "testfile-clK2.so" "testfile-clK1.so")
(void))
(eq?
(verify-loadability 'revisit "testfile-clK2.so" "testfile-clK1.so")
(void))
(eq?
(verify-loadability 'load "testfile-clK2.so" "testfile-clK1.so")
(void))
(equal?
(separate-eval
'(visit "testfile-clK1.so")
'(let () (import (testfile-clK1)) x1))
"invoking K0\ninvoking K1\n\"chocolate chip\"\n")
(equal?
(separate-eval '(revisit "testfile-clK2.so"))
"invoking K0\ninvoking K1\nrunning K2, x1 = \"chocolate chip\"\n")
(eq?
(strip-fasl-file "testfile-clK0.so" "testfile-clK0.so"
(fasl-strip-options compile-time-information))
(void))
(error? ; missing compile-time info for K0
(verify-loadability 'visit "testfile-clK1.so"))
(eq?
(verify-loadability 'revisit "testfile-clK1.so")
(void))
(error? ; missing compile-time info for K0
(verify-loadability 'load "testfile-clK1.so"))
(error? ; missing compile-time info
(separate-eval
'(visit "testfile-clK1.so")
'(let () (import (testfile-clK1)) x1)))
(equal?
(separate-eval '(revisit "testfile-clK2.so"))
"invoking K0\ninvoking K1\nrunning K2, x1 = \"chocolate chip\"\n")
)
;;; section 7.2:
(mat top-level-value-functions

119
mats/8.ms
View File

@ -8747,6 +8747,105 @@
"revisiting testfile-l6-prog1\n#((10 . 12))\n")
)
(mat library7
(begin
(mkfile "testfile-l7-a1.ss"
'(library (testfile-l7-a1) (export a-macro a) (import (chezscheme)) (define-syntax a-macro (identifier-syntax 'aaa)) (define (a x) (+ x (* x x)))))
(mkfile "testfile-l7-b1.ss"
'(library (testfile-l7-b1) (export b) (import (chezscheme) (testfile-l7-a1)) (define (b x) (cons 'b a-macro))))
(mkfile "testfile-l7-c1.ss"
'(library (testfile-l7-c1) (export c) (import (chezscheme) (testfile-l7-a1)) (define (c x) (cons 'c (a x)))))
(mkfile "testfile-l7-d1.ss"
'(library (testfile-l7-d1) (export d) (import (chezscheme) (testfile-l7-a1)) (define (d x) (list 'd a-macro (a x)))))
(separate-compile
'(lambda (x) (for-each compile-library x))
'(list "testfile-l7-a1" "testfile-l7-b1" "testfile-l7-c1" "testfile-l7-d1"))
#t)
(equal?
(separate-eval
'(let () (import (testfile-l7-b1)) (b 7))
'(let () (import (testfile-l7-c1)) (c 7))
'(let () (import (testfile-l7-d1)) (d 7)))
"(b . aaa)\n(c . 56)\n(d aaa 56)\n")
(begin
(separate-compile
'(lambda (x) (for-each compile-library x))
'(list "testfile-l7-a1" "testfile-l7-b1" "testfile-l7-c1"))
#t)
(equal?
(separate-eval
'(let () (import (testfile-l7-b1)) (b 7))
'(let () (import (testfile-l7-c1)) (c 7))
; this should reload from source, since dependency is out-of-date
'(let () (import (testfile-l7-d1)) (d 7)))
"(b . aaa)\n(c . 56)\n(d aaa 56)\n")
(equal?
(separate-eval
; this should reload from source, since dependency is out-of-date
'(let () (import (testfile-l7-d1)) (d 7))
'(let () (import (testfile-l7-c1)) (c 7))
'(let () (import (testfile-l7-b1)) (b 7)))
"(d aaa 56)\n(c . 56)\n(b . aaa)\n")
(error? ; expected different compilation instance
(separate-eval
'(let () (import (testfile-l7-b1)) (b 7))
'(let () (import (testfile-l7-c1)) (c 7))
'(load-library "testfile-l7-d1.so")
'(let () (import (testfile-l7-d1)) (d 7))))
(error? ; expected different compilation instance
(separate-eval
'(load-library "testfile-l7-d1.so")
'(let () (import (testfile-l7-d1)) (d 7))))
(equal?
(separate-eval
'(load-library "testfile-l7-b1.ss")
'(let () (import (testfile-l7-b1)) (b 7))
; this should reload from source, since dependency is out-of-date
'(let () (import (testfile-l7-c1)) (c 7))
; this should reload from source, since dependency is out-of-date
'(let () (import (testfile-l7-d1)) (d 7)))
"(b . aaa)\n(c . 56)\n(d aaa 56)\n")
(error? ; expected different compilation instance
(separate-eval
'(load-library "testfile-l7-b1.ss")
'(load-library "testfile-l7-c1.ss")
'(load-library "testfile-l7-d1.so")
'(let () (import (testfile-l7-d1)) (d 7))))
(begin
(delete-file "testfile-l7-a1.so")
#t)
(equal?
(separate-eval
'(parameterize ([compile-imported-libraries #t]) (compile-library "testfile-l7-b1.ss"))
'(let () (import (testfile-l7-b1)) (b 7))
; this should reload from source, since dependency is out-of-date
'(let () (import (testfile-l7-c1)) (c 7))
'(let () (import (testfile-l7-d1)) (d 7)))
"compiling testfile-l7-b1.ss with output to testfile-l7-b1.so\ncompiling testfile-l7-a1.ss with output to testfile-l7-a1.so\n(b . aaa)\n(c . 56)\n(d aaa 56)\n")
(begin
(delete-file "testfile-l7-a1.so")
#t)
(error? ; expected different compilation instance
(separate-eval
'(parameterize ([compile-imported-libraries #t]) (compile-library "testfile-l7-b1.ss"))
'(load-library "testfile-l7-c1.so")
'(let () (import (testfile-l7-c1)) (c 7))))
(equal?
(separate-eval
'(library (testfile-l7-a1) (export a-macro a) (import (chezscheme)) (define-syntax a-macro (identifier-syntax 'aaa2)) (define (a x) (* x 11)))
'(let () (import (testfile-l7-b1)) (b 7))
'(let () (import (testfile-l7-c1)) (c 7))
'(let () (import (testfile-l7-d1)) (d 7)))
"(b . aaa2)\n(c . 77)\n(d aaa2 77)\n")
(error? ; expected different compilation instance
(separate-eval
'(library (testfile-l7-a1) (export a-macro a) (import (chezscheme)) (define-syntax a-macro (identifier-syntax 'aaa2)) (define (a x) (* x 11)))
'(let () (import (testfile-l7-b1)) (b 7))
'(let () (import (testfile-l7-c1)) (c 7))
'(load-library "testfile-l7-d1.so")
'(let () (import (testfile-l7-d1)) (d 7))))
)
(mat library-regression
; test that failing invoke code does not result in cyclic dependency problem on re-run
(equal?
@ -9568,6 +9667,16 @@
)
(mat library-directories
(error? ; invalid argument
(library-directories '("a" . hello)))
(error? ; invalid argument
(library-directories '("a" . ("src" . "obj"))))
(error? ; invalid argument
(library-directories '("a" . (("src")))))
(error? ; invalid argument
(library-directories '("a" . (("src" "obj")))))
(error? ; invalid argument
(library-directories '("a" . ((("src" "obj"))))))
(let ([x (library-directories)])
(and (list? x)
(andmap (lambda (x) (and (pair? x) (string? (car x)) (string? (cdr x)))) x)))
@ -9607,6 +9716,14 @@
)
(mat library-extensions
(error? ; invalid argument
(library-extensions '.a1.sls))
(error? ; invalid argument
(library-extensions '((".foo"))))
(error? ; invalid argument
(library-extensions '((".foo" ".bar"))))
(error? ; invalid argument
(library-extensions '(((".junk")))))
(let ([x (library-extensions)])
(and (list? x)
(andmap (lambda (x) (and (pair? x) (string? (car x)) (string? (cdr x)))) x)))
@ -10381,7 +10498,7 @@
(parameterize ([console-output-port (open-output-string)])
(eval '(lambda () (import (testfile-imno2)) y))
(get-output-string (console-output-port)))
"import: did not find source file \"testfile-imno2.chezscheme.sls\"\nimport: found source file \"testfile-imno2.ss\"\nimport: did not find corresponding object file \"testfile-imno2.so\"\nimport: loading source file \"testfile-imno2.ss\"\nimport: did not find source file \"testfile-imno1.chezscheme.sls\"\nimport: found source file \"testfile-imno1.ss\"\nimport: found corresponding object file \"testfile-imno1.so\"\nimport: object file is not older\nimport: loading object file \"testfile-imno1.so\"\nattempting to 'revisit' previously 'visited' \"testfile-imno1.so\" for library (testfile-imno1) run-time info\n")
"import: did not find source file \"testfile-imno2.chezscheme.sls\"\nimport: found source file \"testfile-imno2.ss\"\nimport: did not find corresponding object file \"testfile-imno2.so\"\nimport: loading source file \"testfile-imno2.ss\"\nimport: did not find source file \"testfile-imno1.chezscheme.sls\"\nimport: found source file \"testfile-imno1.ss\"\nimport: found corresponding object file \"testfile-imno1.so\"\nimport: object file is not older\nimport: visiting object file \"testfile-imno1.so\"\nattempting to 'revisit' previously 'visited' \"testfile-imno1.so\" for library (testfile-imno1) run-time info\n")
(eq? (import-notify #f) (void))
)

19
mats/mat.ss
View File

@ -458,7 +458,11 @@
(close-port to-stdin)
(let* ([stdout-stuff (slurp from-stdout)]
[stderr-stuff (slurp from-stderr)])
(unless (string=? stderr-stuff "") (errorf who "~a" stderr-stuff))
(when (string=? stderr-stuff "")
(printf "$separate-eval command succeeeded with\nSTDERR:\n~a\nSTDOUT:\n~a\nEND\n" stderr-stuff stdout-stuff))
(unless (string=? stderr-stuff "")
(printf "$separate-eval command failed with\nSTDERR:\n~a\nSTDOUT:\n~a\nEND\n" stderr-stuff stdout-stuff)
(errorf who "~a" stderr-stuff))
(close-port from-stdout)
(close-port from-stderr)
stdout-stuff)))
@ -516,12 +520,13 @@
(define test-cp0-expansion
(rec test-cp0-expansion
(case-lambda
[(expr result) (test-cp0-expansion equivalent-expansion? expr result)]
[(equiv? expr result)
(equiv?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize `(let () (import scheme) ,expr)))
result)])))
[(expr expected) (test-cp0-expansion equivalent-expansion? expr expected)]
[(equiv? expr expected)
(let ([actual (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize `(let () (import scheme) ,expr)))])
(unless (equiv? actual expected)
(errorf 'test-cp0-expansion "expected ~s for ~s, got ~s\n" expected expr actual))
#t)])))
(define rm-rf
(lambda (path)

47
mats/misc.ms
View File

@ -1720,6 +1720,53 @@
(strip-fasl-file "testfile-sff-3.so" "testfile-sff-3.so"
(fasl-strip-options compile-time-information))
(= (object-file-size "testfile-sff-3.so") n))
(begin
(mkfile "testfile-sff-4.ss"
'(library (testfile-sff-4) (export a b c) (import (chezscheme))
(define-syntax a (identifier-syntax 12))
(define b 13)
(meta define c 14)))
(mkfile "testfile-sff-4p.ss"
'(import (chezscheme) (testfile-sff-4))
'(write b))
(separate-compile
'(lambda (x) (parameterize ([compile-imported-libraries #t]) (compile-program x)))
'sff-4p)
#t)
(equal?
(separate-eval
'(let ()
(import (testfile-sff-4))
(define-syntax cc (lambda (x) c))
(printf "a = ~s, b = ~s, c = ~s\n" a b cc)))
"a = 12, b = 13, c = 14\n")
(equal?
(separate-eval
'(let ([x (with-output-to-string (lambda () (load-program "testfile-sff-4p.so")))])
(printf "b = ~a, a = ~s\n" x (eval 'a (environment '(testfile-sff-4))))))
"b = 13, a = 12\n")
(begin
(strip-fasl-file "testfile-sff-4.so" "testfile-sff-4.so"
(fasl-strip-options compile-time-information))
#t)
(error? ; no compile-time info
(separate-eval
'(let ()
(import (testfile-sff-4))
(list a b))))
(error? ; no compile-time info
(separate-eval
'(let ([x (with-output-to-string (lambda () (load-program "testfile-sff-4p.so")))])
(printf "b = ~a, a = ~s\n" x (eval 'a (environment '(testfile-sff-4)))))))
(error? ; no compile-time info
(separate-eval
'(let ([x (with-output-to-string (lambda () (load-program "testfile-sff-4p.so")))])
(printf "b = ~a, a = ~s\n" x (eval '(let () (import (testfile-sff-4)) a))))))
(error? ; no compile-time info
(separate-eval
'(parameterize ([import-notify #t])
(let ([x (with-output-to-string (lambda () (load-program "testfile-sff-4p.so")))])
(printf "b = ~a, a = ~s\n" x (eval '(let () (import (testfile-sff-4)) a)))))))
)
(mat $fasl-file-equal?

40
mats/patch-compile-0-f-t-f
View File

@ -1,7 +1,7 @@
*** errors-compile-0-f-f-f 2019-09-03 15:44:15.000000000 -0700
--- errors-compile-0-f-t-f 2019-09-03 15:14:11.000000000 -0700
*** errors-compile-0-f-f-f 2020-01-21 14:14:21.000000000 -0800
--- errors-compile-0-f-t-f 2020-01-21 13:41:38.000000000 -0800
***************
*** 176,182 ****
*** 178,184 ****
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable c".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable m".
@ -9,7 +9,7 @@
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable y".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
--- 176,182 ----
--- 178,184 ----
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable c".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable m".
@ -18,7 +18,7 @@
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
***************
*** 195,201 ****
*** 197,203 ****
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable b".
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable a".
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable g".
@ -26,7 +26,7 @@
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable f".
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable c".
3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x".
--- 195,201 ----
--- 197,203 ----
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable b".
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable a".
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable g".
@ -35,7 +35,7 @@
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable c".
3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x".
***************
*** 242,251 ****
*** 244,253 ****
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned zero values to single value return context".
@ -46,7 +46,7 @@
3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound".
3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17".
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
--- 242,251 ----
--- 244,253 ----
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned zero values to single value return context".
@ -58,7 +58,7 @@
3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17".
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
***************
*** 3792,3798 ****
*** 3794,3800 ****
misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar".
@ -66,7 +66,7 @@
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
--- 3792,3798 ----
--- 3794,3800 ----
misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar".
@ -75,7 +75,7 @@
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
***************
*** 7243,7250 ****
*** 7288,7295 ****
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat error: "a: hit me!".
7.mo:Expected error in mat error: "f: n is 0".
@ -84,7 +84,7 @@
record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
--- 7243,7250 ----
--- 7288,7295 ----
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat error: "a: hit me!".
7.mo:Expected error in mat error: "f: n is 0".
@ -94,7 +94,7 @@
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
***************
*** 7252,7266 ****
*** 7297,7311 ****
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@ -110,7 +110,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid input #f".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
--- 7252,7266 ----
--- 7297,7311 ----
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@ -127,7 +127,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
***************
*** 7273,7298 ****
*** 7318,7343 ****
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@ -154,7 +154,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
--- 7273,7298 ----
--- 7318,7343 ----
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@ -182,7 +182,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
***************
*** 7423,7461 ****
*** 7468,7506 ****
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@ -222,7 +222,7 @@
record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
--- 7423,7461 ----
--- 7468,7506 ----
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@ -263,7 +263,7 @@
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
***************
*** 7470,7526 ****
*** 7515,7571 ****
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
@ -321,7 +321,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
--- 7470,7526 ----
--- 7515,7571 ----
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".

660
mats/patch-compile-0-t-f-f
View File

File diff suppressed because it is too large Load Diff

52
mats/patch-interpret-0-f-f-f
View File

@ -1,5 +1,5 @@
*** errors-compile-0-f-f-f 2019-09-03 15:44:15.000000000 -0700
--- errors-interpret-0-f-f-f 2019-09-03 15:28:53.000000000 -0700
*** errors-compile-0-f-f-f 2020-01-21 14:14:21.000000000 -0800
--- errors-interpret-0-f-f-f 2020-01-21 13:57:44.000000000 -0800
***************
*** 1,3 ****
--- 1,9 ----
@ -32,7 +32,7 @@
primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f)): Exception in sc-expand: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b))) 1.0+2.0i): Exception in sc-expand: ((a . b)) is not an environment
***************
*** 52,58 ****
*** 54,60 ****
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -40,7 +40,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: a is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
--- 58,64 ----
--- 60,66 ----
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -49,7 +49,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
***************
*** 79,149 ****
*** 81,151 ****
primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36".
primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure".
primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port".
@ -121,7 +121,7 @@
3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) (eq? x (...))))".
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
--- 85,155 ----
--- 87,157 ----
primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36".
primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure".
primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port".
@ -194,7 +194,7 @@
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
***************
*** 242,253 ****
*** 244,255 ****
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned zero values to single value return context".
@ -207,7 +207,7 @@
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
3.mo:Expected error in mat mrvs: "cdr: a is not a pair".
--- 248,259 ----
--- 250,261 ----
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned zero values to single value return context".
@ -221,7 +221,7 @@
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
3.mo:Expected error in mat mrvs: "cdr: a is not a pair".
***************
*** 4131,4146 ****
*** 4137,4152 ****
6.mo:Expected error in mat pretty-print: "incorrect argument count in call (pretty-format (quote foo) (quote x) (quote x))".
6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
@ -238,9 +238,9 @@
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
--- 4137,4146 ----
--- 4143,4152 ----
***************
*** 7105,7111 ****
*** 7111,7117 ****
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@ -248,7 +248,7 @@
7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
--- 7105,7111 ----
--- 7111,7117 ----
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@ -257,7 +257,7 @@
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
***************
*** 7434,7440 ****
*** 7479,7485 ****
record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
@ -265,7 +265,7 @@
record.mo:Expected error in mat record25: "invalid value 12.0 for foreign type long-long".
record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
--- 7434,7440 ----
--- 7479,7485 ----
record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
@ -274,7 +274,7 @@
record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
***************
*** 8676,8688 ****
*** 8735,8747 ****
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -288,7 +288,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
--- 8676,8688 ----
--- 8735,8747 ----
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -303,7 +303,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
***************
*** 9443,9467 ****
*** 9502,9526 ****
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@ -329,7 +329,7 @@
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier booleen".
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
--- 9443,9467 ----
--- 9502,9526 ----
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@ -356,7 +356,7 @@
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
***************
*** 9474,9505 ****
*** 9533,9564 ****
foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@ -389,7 +389,7 @@
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
--- 9474,9505 ----
--- 9533,9564 ----
foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@ -423,7 +423,7 @@
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
***************
*** 9507,9532 ****
*** 9566,9591 ****
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@ -450,7 +450,7 @@
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
--- 9507,9532 ----
--- 9566,9591 ----
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@ -478,7 +478,7 @@
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
***************
*** 9537,9571 ****
*** 9596,9630 ****
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@ -514,7 +514,7 @@
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
--- 9537,9571 ----
--- 9596,9630 ----
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@ -551,7 +551,7 @@
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
***************
*** 10172,10181 ****
*** 10231,10240 ****
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
@ -562,7 +562,7 @@
oop.mo:Expected error in mat oop: "m1: not applicable to 17".
oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
--- 10172,10181 ----
--- 10231,10240 ----
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".

48
mats/patch-interpret-0-f-t-f
View File

@ -1,5 +1,5 @@
*** errors-compile-0-f-t-f 2019-09-03 15:14:11.000000000 -0700
--- errors-interpret-0-f-t-f 2019-09-03 15:36:44.000000000 -0700
*** errors-compile-0-f-t-f 2020-01-21 13:41:38.000000000 -0800
--- errors-interpret-0-f-t-f 2020-01-21 14:05:55.000000000 -0800
***************
*** 1,3 ****
--- 1,9 ----
@ -32,7 +32,7 @@
primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f)): Exception in sc-expand: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b))) 1.0+2.0i): Exception in sc-expand: ((a . b)) is not an environment
***************
*** 52,58 ****
*** 54,60 ****
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -40,7 +40,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: a is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
--- 58,64 ----
--- 60,66 ----
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -49,7 +49,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
***************
*** 79,149 ****
*** 81,151 ****
primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36".
primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure".
primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port".
@ -121,7 +121,7 @@
3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) (eq? x (...))))".
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
--- 85,155 ----
--- 87,157 ----
primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36".
primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure".
primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port".
@ -194,7 +194,7 @@
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
***************
*** 4131,4146 ****
*** 4137,4152 ****
6.mo:Expected error in mat pretty-print: "incorrect argument count in call (pretty-format (quote foo) (quote x) (quote x))".
6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
@ -211,9 +211,9 @@
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
--- 4137,4146 ----
--- 4143,4152 ----
***************
*** 7105,7111 ****
*** 7111,7117 ****
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@ -221,7 +221,7 @@
7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
--- 7105,7111 ----
--- 7111,7117 ----
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@ -230,7 +230,7 @@
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
***************
*** 7243,7250 ****
*** 7288,7295 ****
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat error: "a: hit me!".
7.mo:Expected error in mat error: "f: n is 0".
@ -239,7 +239,7 @@
record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
--- 7243,7250 ----
--- 7288,7295 ----
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat error: "a: hit me!".
7.mo:Expected error in mat error: "f: n is 0".
@ -249,7 +249,7 @@
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
***************
*** 7252,7266 ****
*** 7297,7311 ****
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@ -265,7 +265,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid input #f".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
--- 7252,7266 ----
--- 7297,7311 ----
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@ -282,7 +282,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
***************
*** 7273,7298 ****
*** 7318,7343 ****
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@ -309,7 +309,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
--- 7273,7298 ----
--- 7318,7343 ----
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@ -337,7 +337,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
***************
*** 7423,7461 ****
*** 7468,7506 ****
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@ -377,7 +377,7 @@
record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
--- 7423,7461 ----
--- 7468,7506 ----
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@ -418,7 +418,7 @@
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
***************
*** 7470,7526 ****
*** 7515,7571 ****
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
@ -476,7 +476,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
--- 7470,7526 ----
--- 7515,7571 ----
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
@ -535,7 +535,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
***************
*** 8676,8688 ****
*** 8735,8747 ****
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -549,7 +549,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
--- 8676,8688 ----
--- 8735,8747 ----
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -564,7 +564,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
***************
*** 10172,10181 ****
*** 10231,10240 ****
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
@ -575,7 +575,7 @@
oop.mo:Expected error in mat oop: "m1: not applicable to 17".
oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
--- 10172,10181 ----
--- 10231,10240 ----
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".

4
mats/patch-interpret-3-f-f-f
View File

@ -1,5 +1,5 @@
*** errors-compile-3-f-f-f 2019-09-03 15:10:42.000000000 -0700
--- errors-interpret-3-f-f-f 2019-09-03 15:48:13.000000000 -0700
*** errors-compile-3-f-f-f 2020-01-21 13:37:52.000000000 -0800
--- errors-interpret-3-f-f-f 2020-01-21 14:18:32.000000000 -0800
***************
*** 1,3 ****
--- 1,9 ----

4
mats/patch-interpret-3-f-t-f
View File

@ -1,5 +1,5 @@
*** errors-compile-3-f-t-f 2019-09-03 15:17:31.000000000 -0700
--- errors-interpret-3-f-t-f 2019-09-03 15:40:34.000000000 -0700
*** errors-compile-3-f-t-f 2020-01-21 13:45:08.000000000 -0800
--- errors-interpret-3-f-t-f 2020-01-21 14:10:19.000000000 -0800
***************
*** 1,3 ****
--- 1,9 ----

1
mats/primvars.ms
View File

@ -401,6 +401,7 @@
[(ftype-pointer) *ftype-pointer 0 *time #f]
[(fxvector) '#vfx(0) "a" #f]
[(gensym) *genny 'sym #f]
[(guardian) (make-guardian) values "oops" #f]
[(hashtable) *eq-hashtable '((a . b)) #f]
[(identifier) #'x 'x 17 #f]
[(import-spec) '(chezscheme) 0 '(a . b) #f]

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

@ -49,6 +49,8 @@ primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fi
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (quote 2.0)): Exception in make-sstats: gc-bytes value 2.0 is not an exact integer
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (quote 1/2)): Exception in make-sstats: gc-bytes value 1/2 is not an exact integer
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (quote #f)): Exception in make-sstats: gc-bytes value #f is not an exact integer
primvars.mo:Expected error testing (verify-loadability (quote #!eof)): Exception in verify-loadability: invalid situation #!eof; should be one of load, visit, or revisit
primvars.mo:Expected error testing (verify-loadability (quote #f)): Exception in verify-loadability: invalid situation #f; should be one of load, visit, or revisit
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -3802,6 +3804,10 @@ misc.mo:Expected error in mat strip-fasl-file: "invalid fasl strip option ratfin
misc.mo:Expected error in mat strip-fasl-file: "strip-fasl-file: #<enum-set> is not a string".
misc.mo:Expected error in mat strip-fasl-file: "strip-fasl-file: #<enum-set> is not a string".
misc.mo:Expected error in mat strip-fasl-file: "strip-fasl-file: "testfile.so" is not a fasl-strip-options object".
misc.mo:Expected error in mat strip-fasl-file: "separate-eval: Exception: loading testfile-sff-4.so did not define library (testfile-sff-4)
misc.mo:Expected error in mat strip-fasl-file: "separate-eval: Exception in environment: loading testfile-sff-4.so did not define compile-time information for library (testfile-sff-4)
misc.mo:Expected error in mat strip-fasl-file: "separate-eval: Exception: loading testfile-sff-4.so did not define compile-time information for library (testfile-sff-4)
misc.mo:Expected error in mat strip-fasl-file: "separate-eval: Exception: loading testfile-sff-4.so did not define compile-time information for library (testfile-sff-4)
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: testfile-fatfib1.so is not a string".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: testfile-fatfib1.so is not a string".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: 13.4 is not a string".
@ -3810,7 +3816,7 @@ misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: record comparison failed while comparing testfile-fatfib1.so and testfile-fatfib3.so within fasl entry 3".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: record comparison failed while comparing testfile-fatfib1.so and testfile-fatfib3.so within fasl entry 4".
misc.mo:Expected error in mat cost-center: "incorrect argument count in call (make-cost-center (quote foo))".
misc.mo:Expected error in mat cost-center: "with-cost-center: foo is not a cost center".
misc.mo:Expected error in mat cost-center: "with-cost-center: bar is not a procedure".
@ -7130,6 +7136,10 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-a4) not found
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-c4) not found
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke library (testfile-wpo-c5) while it is still being loaded
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke library (testfile-wpo-a9) while it is still being loaded
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: library (testfile-cwl-a1) not found
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: attempting to re-install compile-time part of library (testfile-cwl-a5)
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception in environment: attempting to re-install compile-time part of library (testfile-cwl-a5)
@ -7140,6 +7150,41 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: library (testfile-cwl-c6) not found
7.mo:Expected error in mat compile-whole-library: "separate-compile: Exception in compile-whole-library: encountered visit-only run-time library (testfile-cwl-a9) while processing file "testfile-cwl-a9.wpo"
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception in compile-whole-program: encountered library (testfile-deja-vu-one) in testfile-deja-vu-dup.wpo, but had already encountered it in testfile-deja-vu-two.wpo
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid situation never; should be one of load, visit, or revisit".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid situation never; should be one of load, visit, or revisit".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid situation #f; should be one of load, visit, or revisit".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input hello: expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input (a . "testdir"): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input #("a" "testdir"): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input hello: expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input (a . "testdir"): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input ("a" . hello): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input ("a" "src" . "obj"): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input ("a" ("src" "obj")): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input ("a" (("src" "obj"))): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: failed for probably not found: no such file or directory".
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clB1)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clB1)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clC1)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clC1)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: testdir-dist2/testfile-clA.so requires a different compilation instance of (testfile-clB) from the one previously compiled
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: testdir-dist2/testfile-clA.so requires a different compilation instance of (testfile-clB) from the one previously compiled
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: loading testfile-clC.so yielded a different compilation instance of (testfile-clC) from that required by compiled program
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: loading testfile-clC.so yielded a different compilation instance of (testfile-clC) from that required by testfile-clA.so
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: loading testfile-clC.so yielded a different compilation instance of (testfile-clC) from that required by testfile-clA.so
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: loading testdir-dist1/testfile-clB.so yielded a different compilation instance of (testfile-clB) from that required by testdir-dist2/testfile-clA.so
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: testdir-dist2/testfile-clA.so requires a different compilation instance of (testfile-clB) from the one previously compiled
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: incompatible record type Q in testfile-clPE.so
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: testdir-obj/testfile-clH1.so requires a different compilation instance of (testfile-clH0) from the one previously compiled
7.mo:Expected error in mat verify-loadability: "verify-loadability: cannot find object file for library (testfile-clI0)".
7.mo:Expected error in mat verify-loadability: "verify-loadability: cannot find object file for library (testfile-clI0)".
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clJ0)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: library (testfile-clJ0) not found
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clJ2)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: library (testfile-clJ2) not found
7.mo:Expected error in mat verify-loadability: "verify-loadability: loading "testfile-clK0.so" did not define library (testfile-clK0)".
7.mo:Expected error in mat verify-loadability: "verify-loadability: visiting "testfile-clK0.so" does not define compile-time information for (testfile-clK0)".
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: loading testfile-clK0.so did not define library (testfile-clK0)
7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: "hello" is not a symbol".
7.mo:Expected error in mat top-level-value-functions: "incorrect argument count in call (top-level-bound?)".
7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: 45 is not a symbol".
@ -8410,7 +8455,7 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat library1: "attempt to export assigned variable $l1-x".
8.mo:Expected error in mat library1: "attempt to export assigned variable $l1-x".
8.mo:Expected error in mat library1: "library ($l1-ham) not found".
8.mo:Expected error in mat library1: "compiled program requires different compilation instance of (testfile-b2) from one found in testfile-b2.ss".
8.mo:Expected error in mat library1: "loading testfile-b2.ss yielded a different compilation instance of (testfile-b2) from that required by compiled program".
8.mo:Expected error in mat library1: "attempt to reference unbound identifier cons".
8.mo:Expected error in mat library1: "invalid library reference (add-prefix (rnrs eval) x)".
8.mo:Expected error in mat library1: "invalid library reference (drop-prefix (rnrs eval) x)".
@ -8445,6 +8490,11 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat library2: "invalid context for library form (library (foo) (export) (import (scheme)) (library (bar) (export) (import)))".
8.mo:Expected error in mat library2: "invalid context for library form (library (foo) (export) (import))".
8.mo:Expected error in mat library2: "invalid context for library form (library (bar) (export) (import))".
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so and originally imported by (testfile-l7-b1)
8.mo:Expected error in mat library7: "separate-eval: Exception: loading testfile-l7-a1.ss yielded a different compilation instance of (testfile-l7-a1) from that required by compiled (testfile-l7-d1)
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-c1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously compiled
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl1.ss did not define library (testfile-ewl1)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl3.ss did not define library (testfile-ewl3)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl4.ss did not define library (testfile-ewl4)".
@ -8453,7 +8503,16 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl1.so did not define library (testfile-ewl1)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl2.so did not define library (testfile-ewl2)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl6.so did not define library (testfile-ewl6)".
8.mo:Expected error in mat library-directories: "library-directories: invalid path list ("a" . hello)".
8.mo:Expected error in mat library-directories: "library-directories: invalid path list ("a" "src" . "obj")".
8.mo:Expected error in mat library-directories: "library-directories: invalid path-list element ("src")".
8.mo:Expected error in mat library-directories: "library-directories: invalid path-list element ("src" "obj")".
8.mo:Expected error in mat library-directories: "library-directories: invalid path-list element (("src" "obj"))".
8.mo:Expected error in mat library-directories: "library (testfile-ld1) not found".
8.mo:Expected error in mat library-extensions: "library-extensions: invalid extension list \x2E;a1.sls".
8.mo:Expected error in mat library-extensions: "library-extensions: invalid extension-list element (".foo")".
8.mo:Expected error in mat library-extensions: "library-extensions: invalid extension-list element (".foo" ".bar")".
8.mo:Expected error in mat library-extensions: "library-extensions: invalid extension-list element ((".junk"))".
8.mo:Expected error in mat library-search-handler: "default-library-search-handler: "not-symbol" is not a symbol".
8.mo:Expected error in mat library-search-handler: "default-library-search-handler: invalid library name bad-library-name".
8.mo:Expected error in mat library-search-handler: "default-library-search-handler: invalid path list (("invalid" "path" "list"))".
@ -8462,7 +8521,7 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat library-search-handler: "library-search-handler: returned invalid object-file path (bad object path)".
8.mo:Expected error in mat library-search-handler: "library-search-handler: claimed object file was found but returned no object-file path".
8.mo:Expected error in mat top-level-program: "invalid syntax (if (inc 3)) at line 4, char 1 of testfile.ss".
8.mo:Expected error in mat top-level-program: "compiled program requires different compilation instance of (testfile-tlp1) from one already loaded".
8.mo:Expected error in mat top-level-program: "compiled program requires a different compilation instance of (testfile-tlp1) from the one previously compiled".
8.mo:Expected error in mat top-level-program: "read: #<n>(...) vector syntax is not allowed in #!r6rs mode at line 4, char 19 of testfile-tlp1.ss".
8.mo:Expected error in mat top-level-program: "read: #<n>(...) vector syntax is not allowed in #!r6rs mode at line 2, char 31 of testfile-tlp.ss".
8.mo:Expected error in mat top-level-program: "read: #<n>(...) vector syntax is not allowed in #!r6rs mode at line 4, char 19 of testfile-tlp1.ss".

65
mats/root-experr-compile-2-f-f-f
View File

@ -49,6 +49,8 @@ primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fi
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (quote 2.0)): Exception in make-sstats: gc-bytes value 2.0 is not an exact integer
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (quote 1/2)): Exception in make-sstats: gc-bytes value 1/2 is not an exact integer
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (quote #f)): Exception in make-sstats: gc-bytes value #f is not an exact integer
primvars.mo:Expected error testing (verify-loadability (quote #!eof)): Exception in verify-loadability: invalid situation #!eof; should be one of load, visit, or revisit
primvars.mo:Expected error testing (verify-loadability (quote #f)): Exception in verify-loadability: invalid situation #f; should be one of load, visit, or revisit
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -3802,6 +3804,10 @@ misc.mo:Expected error in mat strip-fasl-file: "invalid fasl strip option ratfin
misc.mo:Expected error in mat strip-fasl-file: "strip-fasl-file: #<enum-set> is not a string".
misc.mo:Expected error in mat strip-fasl-file: "strip-fasl-file: #<enum-set> is not a string".
misc.mo:Expected error in mat strip-fasl-file: "strip-fasl-file: "testfile.so" is not a fasl-strip-options object".
misc.mo:Expected error in mat strip-fasl-file: "separate-eval: Exception: loading testfile-sff-4.so did not define library (testfile-sff-4)
misc.mo:Expected error in mat strip-fasl-file: "separate-eval: Exception in environment: loading testfile-sff-4.so did not define compile-time information for library (testfile-sff-4)
misc.mo:Expected error in mat strip-fasl-file: "separate-eval: Exception: loading testfile-sff-4.so did not define compile-time information for library (testfile-sff-4)
misc.mo:Expected error in mat strip-fasl-file: "separate-eval: Exception: loading testfile-sff-4.so did not define compile-time information for library (testfile-sff-4)
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: testfile-fatfib1.so is not a string".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: testfile-fatfib1.so is not a string".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: 13.4 is not a string".
@ -3810,7 +3816,7 @@ misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: record comparison failed while comparing testfile-fatfib1.so and testfile-fatfib3.so within fasl entry 3".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: record comparison failed while comparing testfile-fatfib1.so and testfile-fatfib3.so within fasl entry 4".
misc.mo:Expected error in mat cost-center: "incorrect argument count in call (make-cost-center (quote foo))".
misc.mo:Expected error in mat cost-center: "with-cost-center: foo is not a cost center".
misc.mo:Expected error in mat cost-center: "with-cost-center: bar is not a procedure".
@ -7130,6 +7136,10 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-a4) not found
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-c4) not found
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke library (testfile-wpo-c5) while it is still being loaded
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke library (testfile-wpo-a9) while it is still being loaded
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: library (testfile-cwl-a1) not found
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: attempting to re-install compile-time part of library (testfile-cwl-a5)
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception in environment: attempting to re-install compile-time part of library (testfile-cwl-a5)
@ -7140,6 +7150,41 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: library (testfile-cwl-c6) not found
7.mo:Expected error in mat compile-whole-library: "separate-compile: Exception in compile-whole-library: encountered visit-only run-time library (testfile-cwl-a9) while processing file "testfile-cwl-a9.wpo"
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception in compile-whole-program: encountered library (testfile-deja-vu-one) in testfile-deja-vu-dup.wpo, but had already encountered it in testfile-deja-vu-two.wpo
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid situation never; should be one of load, visit, or revisit".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid situation never; should be one of load, visit, or revisit".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid situation #f; should be one of load, visit, or revisit".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input hello: expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input (a . "testdir"): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input #("a" "testdir"): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input hello: expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input (a . "testdir"): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input ("a" . hello): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input ("a" "src" . "obj"): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input ("a" ("src" "obj")): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input ("a" (("src" "obj"))): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: failed for probably not found: no such file or directory".
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clB1)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clB1)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clC1)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clC1)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: testdir-dist2/testfile-clA.so requires a different compilation instance of (testfile-clB) from the one previously compiled
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: testdir-dist2/testfile-clA.so requires a different compilation instance of (testfile-clB) from the one previously compiled
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: loading testfile-clC.so yielded a different compilation instance of (testfile-clC) from that required by compiled program
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: loading testfile-clC.so yielded a different compilation instance of (testfile-clC) from that required by testfile-clA.so
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: loading testfile-clC.so yielded a different compilation instance of (testfile-clC) from that required by testfile-clA.so
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: loading testdir-dist1/testfile-clB.so yielded a different compilation instance of (testfile-clB) from that required by testdir-dist2/testfile-clA.so
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: testdir-dist2/testfile-clA.so requires a different compilation instance of (testfile-clB) from the one previously compiled
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: incompatible record type Q in testfile-clPE.so
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: testdir-obj/testfile-clH1.so requires a different compilation instance of (testfile-clH0) from the one previously compiled
7.mo:Expected error in mat verify-loadability: "verify-loadability: cannot find object file for library (testfile-clI0)".
7.mo:Expected error in mat verify-loadability: "verify-loadability: cannot find object file for library (testfile-clI0)".
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clJ0)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: library (testfile-clJ0) not found
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clJ2)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: library (testfile-clJ2) not found
7.mo:Expected error in mat verify-loadability: "verify-loadability: loading "testfile-clK0.so" did not define library (testfile-clK0)".
7.mo:Expected error in mat verify-loadability: "verify-loadability: visiting "testfile-clK0.so" does not define compile-time information for (testfile-clK0)".
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: loading testfile-clK0.so did not define library (testfile-clK0)
7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: "hello" is not a symbol".
7.mo:Expected error in mat top-level-value-functions: "incorrect argument count in call (top-level-bound?)".
7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: 45 is not a symbol".
@ -8410,7 +8455,7 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat library1: "attempt to export assigned variable $l1-x".
8.mo:Expected error in mat library1: "attempt to export assigned variable $l1-x".
8.mo:Expected error in mat library1: "library ($l1-ham) not found".
8.mo:Expected error in mat library1: "compiled program requires different compilation instance of (testfile-b2) from one found in testfile-b2.ss".
8.mo:Expected error in mat library1: "loading testfile-b2.ss yielded a different compilation instance of (testfile-b2) from that required by compiled program".
8.mo:Expected error in mat library1: "attempt to reference unbound identifier cons".
8.mo:Expected error in mat library1: "invalid library reference (add-prefix (rnrs eval) x)".
8.mo:Expected error in mat library1: "invalid library reference (drop-prefix (rnrs eval) x)".
@ -8445,6 +8490,11 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat library2: "invalid context for library form (library (foo) (export) (import (scheme)) (library (bar) (export) (import)))".
8.mo:Expected error in mat library2: "invalid context for library form (library (foo) (export) (import))".
8.mo:Expected error in mat library2: "invalid context for library form (library (bar) (export) (import))".
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so and originally imported by (testfile-l7-b1)
8.mo:Expected error in mat library7: "separate-eval: Exception: loading testfile-l7-a1.ss yielded a different compilation instance of (testfile-l7-a1) from that required by compiled (testfile-l7-d1)
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-c1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously compiled
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl1.ss did not define library (testfile-ewl1)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl3.ss did not define library (testfile-ewl3)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl4.ss did not define library (testfile-ewl4)".
@ -8453,7 +8503,16 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl1.so did not define library (testfile-ewl1)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl2.so did not define library (testfile-ewl2)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl6.so did not define library (testfile-ewl6)".
8.mo:Expected error in mat library-directories: "library-directories: invalid path list ("a" . hello)".
8.mo:Expected error in mat library-directories: "library-directories: invalid path list ("a" "src" . "obj")".
8.mo:Expected error in mat library-directories: "library-directories: invalid path-list element ("src")".
8.mo:Expected error in mat library-directories: "library-directories: invalid path-list element ("src" "obj")".
8.mo:Expected error in mat library-directories: "library-directories: invalid path-list element (("src" "obj"))".
8.mo:Expected error in mat library-directories: "library (testfile-ld1) not found".
8.mo:Expected error in mat library-extensions: "library-extensions: invalid extension list \x2E;a1.sls".
8.mo:Expected error in mat library-extensions: "library-extensions: invalid extension-list element (".foo")".
8.mo:Expected error in mat library-extensions: "library-extensions: invalid extension-list element (".foo" ".bar")".
8.mo:Expected error in mat library-extensions: "library-extensions: invalid extension-list element ((".junk"))".
8.mo:Expected error in mat library-search-handler: "default-library-search-handler: "not-symbol" is not a symbol".
8.mo:Expected error in mat library-search-handler: "default-library-search-handler: invalid library name bad-library-name".
8.mo:Expected error in mat library-search-handler: "default-library-search-handler: invalid path list (("invalid" "path" "list"))".
@ -8462,7 +8521,7 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat library-search-handler: "library-search-handler: returned invalid object-file path (bad object path)".
8.mo:Expected error in mat library-search-handler: "library-search-handler: claimed object file was found but returned no object-file path".
8.mo:Expected error in mat top-level-program: "invalid syntax (if (inc 3)) at line 4, char 1 of testfile.ss".
8.mo:Expected error in mat top-level-program: "compiled program requires different compilation instance of (testfile-tlp1) from one already loaded".
8.mo:Expected error in mat top-level-program: "compiled program requires a different compilation instance of (testfile-tlp1) from the one previously compiled".
8.mo:Expected error in mat top-level-program: "read: #<n>(...) vector syntax is not allowed in #!r6rs mode at line 4, char 19 of testfile-tlp1.ss".
8.mo:Expected error in mat top-level-program: "read: #<n>(...) vector syntax is not allowed in #!r6rs mode at line 2, char 31 of testfile-tlp.ss".
8.mo:Expected error in mat top-level-program: "read: #<n>(...) vector syntax is not allowed in #!r6rs mode at line 4, char 19 of testfile-tlp1.ss".

28
release_notes/release_notes.stex
View File

@ -2,7 +2,7 @@
\thisversion{Version 9.5.3}
\thatversion{Version 8.4}
\pubmonth{September}
\pubmonth{December}
\pubyear{2019}
\begin{document}
@ -58,6 +58,32 @@ Online versions of both books can be found at
%-----------------------------------------------------------------------------
\section{Functionality Changes}\label{section:functionality}
\subsection{Verifying loadability of libraries and programs (9.5.3)}
The new procedure \scheme{verify-loadability} can be used to
determine, without actually loading any object code or defining any
libraries, whether a set of object files and the object files
satisfying their library dependencies, direct or indirect, are
present, readable, and mutually compatible.
To support loadability verification, information about libraries
and top-level programs within an object file is now placed at the
top of the file, just after recompile information. This change can
be detected by unusual setups, e.g., a source file that interleaves
library definitions and top-level forms that call library-list, but
is backward compatible for standard use cases in which each file
contains one or more libraries possibly followed by a top-level
program.
\subsection{Unregistering objects from guardians (9.5.3)}
The set of as-yet unresurrected objects registered with a guardian
can be unregistered and retrieved by means of the new primitive
\scheme{unregister-guardian}.
Consult the user's guide for usage and caveats.
Guardians can now be distinguished from other procedures (and other
objects) via the new primitive \scheme{guardian?}.
\subsection{Coverage support and source tables (9.5.3)}
When the new parameter \scheme{generate-covin-files} is set to \scheme{#t}

52
s/7.ss
View File

@ -213,8 +213,8 @@
(let ()
(define do-load-binary
(lambda (who fn ip situation for-import?)
(let ([load-binary (make-load-binary who fn situation for-import?)])
(lambda (who fn ip situation for-import? importer)
(let ([load-binary (make-load-binary who fn situation for-import? importer)])
(let ([x (fasl-read ip situation)])
(unless (eof-object? x)
(let loop ([x x])
@ -223,7 +223,7 @@
(load-binary x)
(begin (load-binary x) (loop next-x))))))))))
(define (make-load-binary who fn situation for-import?)
(define (make-load-binary who fn situation for-import? importer)
(module (Lexpand? recompile-info? library/ct-info? library/rt-info? program-info?)
(import (nanopass))
(include "base-lang.ss")
@ -231,14 +231,16 @@
(lambda (x)
(cond
[(procedure? x) (x)]
[(library/rt-info? x) ($install-library/rt-desc x for-import? fn)]
[(library/ct-info? x) ($install-library/ct-desc x for-import? fn)]
[(library/rt-info? x) ($install-library/rt-desc x for-import? importer fn)]
[(library/ct-info? x) ($install-library/ct-desc x for-import? importer fn)]
[(program-info? x) ($install-program-desc x)]
[(recompile-info? x) (void)]
[(Lexpand? x) ($interpret-backend x situation for-import? fn)]
[(Lexpand? x) ($interpret-backend x situation for-import? importer fn)]
; NB: this is here to support the #t inserted by compile-file-help2 after header information
[(eq? x #t) (void)]
[else ($oops who "unexpected value ~s read from ~a" x fn)])))
(define (do-load who fn situation for-import? ksrc)
(define (do-load who fn situation for-import? importer ksrc)
(let ([ip ($open-file-input-port who fn)])
(on-reset (close-port ip)
(let ([fp (let ([start-pos (port-position ip)])
@ -257,7 +259,7 @@
(port-file-compressed! ip)
(if ($compiled-file-header? ip)
(begin
(do-load-binary who fn ip situation for-import?)
(do-load-binary who fn ip situation for-import? importer)
(close-port ip))
(begin
(when ($port-flags-set? ip (constant port-flag-compressed))
@ -274,26 +276,26 @@
(ksrc ip sfd ($make-read ip sfd fp)))))))))
(set! $make-load-binary
(lambda (fn situation for-import?)
(make-load-binary '$make-load-binary fn situation for-import?)))
(lambda (fn)
(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)))
(do-load-binary who (port-name ip) ip 'load #f #f)))
(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)))
(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)))
(do-load-binary who (port-name ip) ip 'revisit #f #f)))
(set-who! load-program
(rec load-program
@ -304,7 +306,7 @@
(unless (procedure? ev) ($oops who "~s is not a procedure" ev))
(with-source-path who fn
(lambda (fn)
(do-load who fn 'load #f
(do-load who fn 'load #f #f
(lambda (ip sfd do-read)
($set-port-flags! ip (constant port-flag-r6rs))
(let loop ([x* '()])
@ -325,7 +327,7 @@
(unless (procedure? ev) ($oops who "~s is not a procedure" ev))
(with-source-path who fn
(lambda (fn)
(do-load who fn 'load #f
(do-load who fn 'load #f #f
(lambda (ip sfd do-read)
($set-port-flags! ip (constant port-flag-r6rs))
(let loop ()
@ -339,11 +341,11 @@
; like load, but sets #!r6rs mode and does not use with-source-path,
; since syntax.ss load-library has already determined the path.
; adds fn's directory to source-directories
(lambda (fn situation)
(lambda (fn situation importer)
(define who 'import)
(let ([fn (let ([host-fn (format "~a.~s" (path-root fn) (machine-type))])
(if (file-exists? host-fn) host-fn fn))])
(do-load who fn situation #t
(do-load who fn situation #t importer
(lambda (ip sfd do-read)
($set-port-flags! ip (constant port-flag-r6rs))
(parameterize ([source-directories (cons (path-parent fn) (source-directories))])
@ -363,7 +365,7 @@
(unless (procedure? ev) ($oops who "~s is not a procedure" ev))
(with-source-path who fn
(lambda (fn)
(do-load who fn 'load #f
(do-load who fn 'load #f #f
(lambda (ip sfd do-read)
(let loop ()
(let ([x (do-read)])
@ -373,20 +375,20 @@
(close-port ip)))))])))
(set! $visit
(lambda (who fn)
(do-load who fn 'visit #t #f)))
(lambda (who fn importer)
(do-load who fn 'visit #t importer #f)))
(set! $revisit
(lambda (who fn)
(do-load who fn 'revisit #t #f)))
(lambda (who fn importer)
(do-load who fn 'revisit #t importer #f)))
(set-who! visit
(lambda (fn)
(do-load who fn 'visit #f #f)))
(do-load who fn 'visit #f #f #f)))
(set-who! revisit
(lambda (fn)
(do-load who fn 'revisit #f #f))))
(do-load who fn 'revisit #f #f #f))))
(let ()
(module sstats-record (make-sstats sstats? sstats-cpu sstats-real
@ -655,7 +657,7 @@
(lambda ()
(unless s
(set! s
(format "~:[Petite ~;~]Chez Scheme Version ~a"
(format "~:[Petite ~;~]Cisco-internal Chez Scheme Version ~a"
$compiler-is-loaded?
$scheme-version)))
s)))

8
s/cmacros.ss
View File

@ -757,6 +757,7 @@
(define-constant code-flag-system #b0001)
(define-constant code-flag-continuation #b0010)
(define-constant code-flag-template #b0100)
(define-constant code-flag-guardian #b1000)
(define-constant fixnum-bits
(case (constant ptr-bits)
@ -843,6 +844,10 @@
(fxlogor (constant type-code)
(fxsll (constant code-flag-continuation)
(constant code-flags-offset))))
(define-constant type-guardian-code
(fxlogor (constant type-code)
(fxsll (constant code-flag-guardian)
(constant code-flags-offset))))
;; type checks are generally performed by applying the mask to the object
;; then comparing against the type code. a mask equal to
@ -918,6 +923,9 @@
(define-constant mask-continuation-code
(fxlogor (fxsll (constant code-flag-continuation) (constant code-flags-offset))
(fx- (fxsll 1 (constant code-flags-offset)) 1)))
(define-constant mask-guardian-code
(fxlogor (fxsll (constant code-flag-guardian) (constant code-flags-offset))
(fx- (fxsll 1 (constant code-flags-offset)) 1)))
(define-constant mask-thread (constant byte-constant-mask))
(define-constant mask-tlc (constant byte-constant-mask))

110
s/compile.ss
View File

@ -447,7 +447,7 @@
(define with-whacked-optimization-locs
(lambda (x1 th)
(define ht (make-hashtable symbol-hash eq?))
(define ht (make-eq-hashtable))
(define-pass whack! : Lexpand (ir f) -> * ()
(Outer : Outer (ir) -> * ()
[,inner (Inner ir)]
@ -456,17 +456,20 @@
[(revisit-only ,[]) (values)]
[else (values)])
(Inner : Inner (ir) -> * ()
[(library/ct-info ,linfo/ct) (for-each f (library/ct-info-clo* linfo/ct)) (values)]
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
(for-each f db*)
(values)]
[else (values)]))
(whack! x1
(lambda (x)
(let ([b (cdr x)])
(symbol-hashtable-set! ht (car x) (unbox b))
(set-box! b '()))))
(lambda (db)
(when db
(eq-hashtable-set! ht db (unbox db))
(set-box! db '()))))
(th)
(whack! x1
(lambda (x)
(set-box! (cdr x) (symbol-hashtable-ref ht (car x) '()))))))
(lambda (db)
(when db
(set-box! db (eq-hashtable-ref ht db '())))))))
(define check-prelex-flags
(lambda (x after)
@ -495,10 +498,10 @@
(emit-header op (constant machine-type))
(when hostop (emit-header hostop (host-machine-type)))
(when wpoop (emit-header wpoop (host-machine-type)))
(let cfh0 ([n 1] [rrcinfo** '()] [rfinal** '()])
(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 rfinal**))
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**))
(let ()
(define source-info-string
(and (or ($assembly-output) (expand-output) (expand/optimize-output))
@ -538,7 +541,7 @@
(let ([t ($fasl-table)])
($fasl-enter x1 t (constant annotation-all))
($fasl-start wpoop t (constant fasl-type-visit-revisit) (lambda (p) ($fasl-out x1 p t (constant annotation-all)))))))))))
(let-values ([(rcinfo* final*) (compile-file-help1 x1 source-info-string)])
(let-values ([(rcinfo* lpinfo* final*) (compile-file-help1 x1 source-info-string)])
(when hostop
; the host library file contains expander output possibly augmented with
; cross-library optimization information inserted by cp0. this write must come
@ -549,7 +552,7 @@
(let ([t ($fasl-table)])
($fasl-enter x1 t (constant annotation-all))
($fasl-start hostop t (constant fasl-type-visit-revisit) (lambda (p) ($fasl-out x1 p t (constant annotation-all)))))))))
(cfh0 (+ n 1) (cons rcinfo* rrcinfo**) (cons final* rfinal**)))))))))))
(cfh0 (+ n 1) (cons rcinfo* rrcinfo**) (cons lpinfo* rlpinfo**) (cons final* rfinal**)))))))))))
(define library/program-info?
(lambda (x)
@ -631,7 +634,7 @@
(fprintf (expand-output) "~%;; expand output for ~a\n" source-info-string))
(pretty-print ($uncprep x1) (expand-output))
(flush-output-port (expand-output)))
(let loop ([chunk* (expand-Lexpand x1)] [rx2b* '()] [rfinal* '()] [rrcinfo* '()])
(let loop ([chunk* (expand-Lexpand x1)] [rx2b* '()] [rfinal* '()] [rlpinfo* '()] [rrcinfo* '()])
(if (null? chunk*)
(begin
(when (expand/optimize-output)
@ -658,12 +661,12 @@
rx2b*)])
(pretty-print (if (fx= (length e*) 1) (car e*) `(begin ,@(reverse e*))) (expand/optimize-output))
(flush-output-port (expand/optimize-output))))
(values (reverse rrcinfo*) (reverse rfinal*)))
(values (reverse rrcinfo*) (reverse rlpinfo*) (reverse rfinal*)))
(let ([x1 (car chunk*)] [chunk* (cdr chunk*)])
(define finish-compile
(lambda (x1 f)
(if (library/program-info? x1)
(loop chunk* (cons (f x1) rx2b*) (cons (f `(object ,x1)) rfinal*) rrcinfo*)
(loop chunk* (cons (f x1) rx2b*) rfinal* (cons (f `(object ,x1)) rlpinfo*) rrcinfo*)
(let* ([waste (check-prelex-flags x1 'before-cpvalid)]
[x2 ($pass-time 'cpvalid (lambda () (do-trace $cpvalid x1)))]
[waste (check-prelex-flags x2 'cpvalid)]
@ -688,15 +691,15 @@
[waste (check-prelex-flags x2b 'cpcommonize)]
[x7 (do-trace $np-compile x2b #t)]
[x8 ($c-make-closure x7)])
(loop chunk* (cons (f x2b) rx2b*) (cons (f x8) rfinal*) rrcinfo*)))))
(loop chunk* (cons (f x2b) rx2b*) (cons (f x8) rfinal*) rlpinfo* rrcinfo*)))))
(cond
[(recompile-info? x1) (loop chunk* (cons x1 rx2b*) rfinal* (cons x1 rrcinfo*))]
[(recompile-info? x1) (loop chunk* (cons x1 rx2b*) rfinal* rlpinfo* (cons x1 rrcinfo*))]
[(visit-chunk? x1) (finish-compile (visit-chunk-chunk x1) (lambda (x) `(visit-stuff . ,x)))]
[(revisit-chunk? x1) (finish-compile (revisit-chunk-chunk x1) (lambda (x) `(revisit-stuff . ,x)))]
[else (finish-compile x1 values)]))))))
(define compile-file-help2
(lambda (op rcinfo** final**)
(lambda (op rcinfo** lpinfo** final**)
(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=?)]
@ -728,7 +731,8 @@
[(revisit-stuff) x (c-print-fasl x op (constant fasl-type-revisit))]
[else (c-print-fasl x op (constant fasl-type-visit-revisit))]))
final*))
final**)))))))
; inserting #t after lpinfo as an end-of-header marker
(append lpinfo** (cons (list `(object #t)) final**)))))))))
(define (new-extension new-ext fn)
(let ([old-ext (path-extension fn)])
@ -809,15 +813,15 @@
(with-object-file who iofn
(lambda (op)
(emit-header op (constant machine-type))
(let loop ([x1* (reverse rx1*)] [rrcinfo** (list rcinfo*)] [rfinal** '()])
(let loop ([x1* (reverse rx1*)] [rrcinfo** (list rcinfo*)] [rlpinfo** '()] [rfinal** '()])
(if (null? x1*)
(compile-file-help2 op (reverse rrcinfo**) (reverse rfinal**))
(let-values ([(rcinfo* final*)
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**))
(let-values ([(rcinfo* lpinfo* final*)
(let ([x1 (car x1*)])
(if (recompile-info? x1)
(values (list x1) '())
(values (list x1) '() '())
(compile-file-help1 (car x1*) "host library")))])
(loop (cdr x1*) (cons rcinfo* rrcinfo**) (cons final* rfinal**))))))))]
(loop (cdr x1*) (cons rcinfo* rrcinfo**) (cons lpinfo* rlpinfo**) (cons final* rfinal**))))))))]
[(recompile-info? x1) (loop rx1* (cons x1 rcinfo*) rother*)]
[(Lexpand? x1) (loop (cons x1 rx1*) rcinfo* rother*)]
[else (loop rx1* rcinfo* (cons x1 rother*))])))))))
@ -959,6 +963,8 @@
(let ([node (record-rt-lib! x #t fn libs-visible?)])
(when node (set! libs-in-file (cons node libs-in-file))))]
[(program-info? x) ($oops who "found program while looking for library ~s in ~a" path fn)]
; NB: this is here to support the #t inserted by compile-file-help2 after header information
[(eq? x #t)]
[else ($oops who "unexpected value ~s read from ~a" x fn)])
(loop!))))))
($oops who "malformed binary input file ~s" fn)))))))
@ -1406,7 +1412,7 @@
(let* ([info (library-node-rtinfo node)]
[uid (library-info-uid info)])
`(group (revisit-only
(library/ct-info
(library/rt-info
,(make-library/rt-info
(library-info-path info)
(library-info-version info)
@ -1435,13 +1441,20 @@
(library/ct-info-import-req* info)
(and maybe-ht (symbol-hashtable-ref maybe-ht uid #f)))
(library/ct-info-visit-visit-req* info)
(library/ct-info-visit-req* info)
(if (library-node-visible? visit-lib)
(library/ct-info-clo* info)
'()))))
(library/ct-info-visit-req* info))))
,body))))
body visit-lib*)))
(define add-program-record
(lambda (node body)
`(group (revisit-only
(program-info
,(make-program-info
(program-node-uid node)
; NB: possibly list direct or indirect binary library reqs here
(program-node-invoke-req* node))))
,body)))
(define add-visit-lib-install*
(lambda (visit-lib* body)
(fold-left (lambda (body visit-lib)
@ -1481,9 +1494,10 @@
(add-library/rt-records #f node*
(add-library/ct-records #f visit-lib*
(add-library/ct-records #f invisible*
(add-visit-lib-install* visit-lib*
(add-visit-lib-install* invisible*
`(revisit-only ,(build-combined-program-ir program-entry node*))))))))))
(add-program-record program-entry
(add-visit-lib-install* visit-lib*
(add-visit-lib-install* invisible*
`(revisit-only ,(build-combined-program-ir program-entry node*)))))))))))
(define build-library-body
(lambda (node* visit-lib* rcinfo*)
@ -1509,8 +1523,8 @@
[$block-counter 0])
(when source-table ($insert-profile-src! source-table x1))
(emit-header op (constant machine-type))
(let-values ([(rcinfo* final*) (compile-file-help1 x1 msg)])
(compile-file-help2 op (list rcinfo*) (list final*))))))))))
(let-values ([(rcinfo* lpinfo* final*) (compile-file-help1 x1 msg)])
(compile-file-help2 op (list rcinfo*) (list lpinfo*) (list final*))))))))))
(define write-wpo-file
(lambda (who ofn ir*)
@ -1529,19 +1543,21 @@
(define build-required-library-list
(lambda (node* visit-lib*)
(fold-left (lambda (ls visit-lib)
(if (library-node-binary? visit-lib)
(let ([path (library-node-path visit-lib)])
(if (member path ls)
ls
(cons path ls)))
ls))
(fold-left (lambda (ls node)
(if (library-node-binary? node)
(cons (library-node-path node) ls)
ls))
'() node*)
visit-lib*)))
(let ([ht (make-hashtable symbol-hash eq?)])
(fold-left
(lambda (ls node)
(if (and (library-node-binary? node) (not (symbol-hashtable-contains? ht (library-node-uid node))))
(cons (library-node-path node) ls)
ls))
(fold-left
(lambda (ls node)
(if (library-node-binary? node)
(begin
(symbol-hashtable-set! ht (library-node-uid node) #t)
(cons (library-node-path node) ls))
ls))
'() node*)
visit-lib*))))
;; TODO: Add automatic recompliation ala scheme import/load-library
(set-who! compile-whole-program

9
s/cp0.ss
View File

@ -4395,13 +4395,17 @@
(and likely-to-be-compiled?
(cp0
(let* ([tc (cp0-make-temp #t)] [ref-tc (build-ref tc)])
; if the free variables of the closure created for a guardian changes, the code
; for unregister-guardian in prims.ss might also need to be updated
(build-lambda formal*
(build-let (list tc)
(list (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
(let ([zero `(quote 0)])
(build-let (list x) (list (build-primcall 3 'cons (list zero zero)))
(build-primcall 3 'cons (list ref-x ref-x))))))
(build-case-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt))
(build-case-lambda (let ([preinfo (app-preinfo ctxt)])
(make-preinfo-lambda (preinfo-src preinfo) (preinfo-sexpr preinfo) #f #f
(constant code-flag-guardian)))
(cons
(list '()
(let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
@ -4424,8 +4428,7 @@
ctxt empty-env sc wd name moi))))
(define-inline 2 make-guardian
[() (inline-make-guardian ctxt empty-env sc wd name moi
'()
[() (inline-make-guardian ctxt empty-env sc wd name moi '()
(lambda (ref-tc)
(list
(let* ([obj (cp0-make-temp #t)] [ref-obj (build-ref obj)])

12
s/cpnanopass.ss
View File

@ -5407,6 +5407,18 @@
(set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries))
(set! ,(%tc-ref guardian-entries) ,t))))])
(define-inline 2 guardian?
[(e)
(bind #t (e)
(build-and
(%type-check mask-closure type-closure ,e)
(%type-check mask-guardian-code type-guardian-code
,(%mref
,(%inline -
,(%mref ,e ,(constant closure-code-disp))
,(%constant code-data-disp))
,(constant code-type-disp)))))])
(define-inline 2 virtual-register-count
[() `(quote ,(constant virtual-register-count))])
(let ()

5
s/expand-lang.ss
View File

@ -40,9 +40,8 @@
(fields
(immutable import-req*)
(immutable visit-visit-req*)
(immutable visit-req*)
(immutable clo*))
(nongenerative #{library/ct-info fgf0koeh2zn6ajlujfyoyf-4})
(immutable visit-req*))
(nongenerative #{library/ct-info fgf0koeh2zn6ajlujfyoyf-3})
(sealed #t))
(define-record-type library/rt-info

12
s/interpret.ss
View File

@ -645,7 +645,7 @@
(c-var-index-set! (car vars) i)
(loop (cdr vars) regs (fx+ i 1))])))))
(define-pass interpret-Lexpand : Lexpand (ir situation for-import? ofn eoo) -> * (val)
(define-pass interpret-Lexpand : Lexpand (ir situation for-import? importer ofn eoo) -> * (val)
(definitions
(define (ibeval x1)
($rt (parameterize ([$target-machine (machine-type)] [$sfd #f])
@ -673,8 +673,8 @@
(ibeval ($build-install-library/ct-code uid export-id* import-code visit-code))]
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
(ibeval ($build-install-library/rt-code uid dl* db* dv* de* body))]
[(library/rt-info ,linfo/rt) ($install-library/rt-desc linfo/rt for-import? ofn)]
[(library/ct-info ,linfo/ct) ($install-library/ct-desc linfo/ct for-import? ofn)]
[(library/rt-info ,linfo/rt) ($install-library/rt-desc linfo/rt for-import? importer ofn)]
[(library/ct-info ,linfo/ct) ($install-library/ct-desc linfo/ct for-import? importer ofn)]
[(program-info ,pinfo) ($install-program-desc pinfo)]
[else (sorry! who "unexpected language form ~s" ir)])
(Outer : Outer (ir) -> * (val)
@ -704,11 +704,11 @@
($uncprep x1 #t) ; populate preinfo sexpr fields
(when (and (expand-output) (not ($noexpand? x0)))
(pretty-print ($uncprep x1) (expand-output)))
(interpret-Lexpand x1 'load #f #f (and (not ($noexpand? x0)) (expand/optimize-output))))])))
(interpret-Lexpand x1 'load #f #f #f (and (not ($noexpand? x0)) (expand/optimize-output))))])))
(set! $interpret-backend
(lambda (x situation for-import? ofn)
(interpret-Lexpand x situation for-import? ofn (expand/optimize-output))))
(lambda (x situation for-import? importer ofn)
(interpret-Lexpand x situation for-import? importer ofn (expand/optimize-output))))
)
(current-eval interpret)

5
s/primdata.ss
View File

@ -1378,6 +1378,7 @@
(get-string-some! [sig [(textual-input-port string length length) -> (ptr)]] [flags true])
(getenv [sig [(string) -> (maybe-string)]] [flags discard])
(getprop [sig [(symbol ptr) (symbol ptr ptr) -> (ptr)]] [flags discard])
(guardian? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(hash-table? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(hashtable-ephemeron? [sig [(hashtable) -> (boolean)]] [flags pure mifoldable discard])
(hash-table-for-each [sig [(old-hash-table procedure) -> (void)]] [flags])
@ -1442,7 +1443,7 @@
(make-engine [sig [(procedure) -> (engine)]] [flags pure alloc])
(make-format-condition [sig [() -> (condition)]] [flags pure unrestricted mifoldable discard])
(make-fxvector [sig [(length) (length fixnum) -> (fxvector)]] [flags alloc])
(make-guardian [sig [() -> (procedure)]] [flags alloc cp02])
(make-guardian [sig [() -> (procedure)]] [flags unrestricted alloc cp02])
(make-hash-table [sig [() (ptr) -> (old-hash-table)]] [flags unrestricted alloc])
(make-input-port [sig [(procedure string) -> (textual-input-port)]] [flags alloc])
(make-input/output-port [sig [(procedure string string) -> (textual-input/output-port)]] [flags alloc])
@ -1712,6 +1713,7 @@
(unget-char [sig [(textual-input-port ptr) -> (void)]] [flags true])
(unlock-object [sig [(ptr) -> (void)]] [flags unrestricted true])
(unread-char [sig [(char) (char textual-input-port) -> (void)]] [flags true])
(unregister-guardian [sig [(guardian) -> (list)]] [flags true])
(utf-16-codec [sig [() -> (codec)] [(sub-symbol) -> (codec)]] [flags pure true]) ; has optional eness argument
(utf-16le-codec [sig [() -> (codec)]] [flags pure unrestricted true])
(utf-16be-codec [sig [() -> (codec)]] [flags pure unrestricted true])
@ -1719,6 +1721,7 @@
(vector-copy [sig [(vector) -> (vector)]] [flags alloc])
(vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc])
(vector-set-fixnum! [sig [(vector sub-index fixnum) -> (void)]] [flags true])
(verify-loadability [sig [(sub-symbol sub-ptr ...) -> (void)]] [flags true])
(virtual-register [sig [(sub-index) -> (ptr)]] [flags discard])
(virtual-register-count [sig [() -> (length)]] [flags pure unrestricted true cp02])
(visit [sig [(pathname) -> (void)]] [flags true])

22
s/prims.ss
View File

@ -1417,6 +1417,28 @@
; tconc is assumed to be valid at all call sites
(#3%$install-ftype-guardian obj tconc)))
(define guardian?
(lambda (g)
(#3%guardian? g)))
(define-who unregister-guardian
(let ([fp (foreign-procedure "(cs)unregister_guardian" (scheme-object) scheme-object)])
(define probable-tconc? ; full tconc? could be expensive ...
(lambda (x)
(and (pair? x) (pair? (car x)) (pair? (cdr x)))))
(lambda (g)
(unless (guardian? g) ($oops who "~s is not a guardian" g))
; at present, guardians should have either one free variable (the tcond) or two(the tconc and an ftd)
; but we just look for a probable tconc among whatever free variables it has
(fp (let ([n ($code-free-count ($closure-code g))])
(let loop ([i 0])
(if (fx= i n)
($oops #f "failed to find a tconc among the free variables of guardian ~s" g)
(let ([x ($closure-ref g i)])
(if (probable-tconc? x)
x
(loop (fx+ i 1)))))))))))
(define-who $ftype-guardian-oops
(lambda (ftd obj)
($oops 'ftype-guardian "~s is not an ftype pointer of the expected type ~s" obj ftd)))

482
s/syntax.ss
View File

@ -2360,10 +2360,11 @@
(immutable path)
(immutable version)
(immutable outfn) ; string if imported from or compiled to an object file, else #f
(immutable importer) ; string if we know why this was imported, for error messages
(immutable system?)
(immutable ctdesc)
(immutable rtdesc))
(nongenerative #{libdesc c9z2lszhwazzhbi56x5v5p-1})
(nongenerative #{libdesc c9z2lszhwazzhbi56x5v5p-2})
(sealed #t))
(define-record-type ctdesc
@ -2371,13 +2372,12 @@
(immutable import-req*) ; libraries imported when this library was imported
(immutable visit-visit-req*) ; libraries that must be visited (for meta definitions) when this library is visited
(immutable visit-req*) ; libraries that must be invoked (for regular definitions) when this library is visited
(mutable clo*) ; cross-library optimization information
(mutable loaded-import-reqs)
(mutable loaded-visit-reqs)
(mutable export-id*) ; ids that need to be reset when visit-code raises an exception
(mutable import-code)
(mutable visit-code))
(nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-3})
(nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-4})
(sealed #t))
(define-record-type rtdesc
@ -2393,8 +2393,7 @@
libdesc-loaded-visit-reqs libdesc-loaded-visit-reqs-set!
libdesc-import-code libdesc-import-code-set!
libdesc-visit-code libdesc-visit-code-set!
libdesc-visit-id* libdesc-visit-id*-set!
libdesc-clo* libdesc-clo*-set!)
libdesc-visit-id* libdesc-visit-id*-set!)
(define get-ctdesc
(lambda (desc)
(or (libdesc-ctdesc desc)
@ -2437,13 +2436,7 @@
(ctdesc-export-id* (get-ctdesc desc))))
(define libdesc-visit-id*-set!
(lambda (desc x)
(ctdesc-export-id*-set! (get-ctdesc desc) x)))
(define libdesc-clo*
(lambda (desc)
(ctdesc-clo* (get-ctdesc desc))))
(define libdesc-clo*-set!
(lambda (desc x)
(ctdesc-clo*-set! (get-ctdesc desc) x))))
(ctdesc-export-id*-set! (get-ctdesc desc) x))))
(module (libdesc-invoke-req*
libdesc-loaded-invoke-reqs libdesc-loaded-invoke-reqs-set!
@ -2478,55 +2471,69 @@
(define visit-library
; library must already have been loaded, as well as those in its visit-req* list
(lambda (uid)
(define (go desc)
(cond
[(libdesc-visit-code desc) =>
(lambda (p)
(when (eq? p 'loading)
($oops #f "attempt to visit library ~s while it is still being loaded" (libdesc-path desc)))
(when (eq? p 'pending)
($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc)))
(libdesc-visit-code-set! desc 'pending)
(on-reset
(begin
(for-each (lambda (id) ($sc-put-cte id (make-binding 'visit uid) #f)) (libdesc-visit-id* desc))
(libdesc-visit-code-set! desc p))
(for-each (lambda (req) (visit-library (libreq-uid req))) (libdesc-visit-visit-req* desc))
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-visit-req* desc))
(p))
(libdesc-visit-code-set! desc #f)
(libdesc-visit-id*-set! desc '()))]))
(cond
[(get-library-descriptor uid) =>
(lambda (desc)
(cond
[(not (libdesc-ctdesc desc))
(with-message (format "attempting to 'visit' previously 'revisited' ~s for library ~s compile-time info" (libdesc-outfn desc) (libdesc-path desc))
($visit #f (libdesc-outfn desc)))
(visit-library uid)]
[(libdesc-visit-code desc) =>
(lambda (p)
(when (eq? p 'loading)
($oops #f "attempt to visit library ~s while it is still being loaded" (libdesc-path desc)))
(when (eq? p 'pending)
($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc)))
(libdesc-visit-code-set! desc 'pending)
(on-reset
(begin
(for-each (lambda (id) ($sc-put-cte id (make-binding 'visit uid) #f)) (libdesc-visit-id* desc))
(libdesc-visit-code-set! desc p))
(for-each (lambda (req) (visit-library (libreq-uid req))) (libdesc-visit-visit-req* desc))
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-visit-req* desc))
(p))
(libdesc-visit-code-set! desc #f)
(libdesc-visit-id*-set! desc '()))]))]
(if (libdesc-ctdesc desc)
(go desc)
(let ([fn (libdesc-outfn desc)])
; this probably can't happen...we have probably already imported the library
; for us to encounter something that forces us to visit the library
(with-message (format "attempting to 'visit' previously 'revisited' ~s for library ~s compile-time info" fn (libdesc-path desc))
($visit #f fn #f))
(let ([desc (get-library-descriptor uid)])
(unless (libdesc-ctdesc desc)
($oops #f "visiting ~a did not define compile-time information for library ~s" fn (libdesc-path desc)))
(go desc)))))]
[else ($oops #f "library ~:s is not defined" uid)])))
(define invoke-library
; library must already have been loaded, as well as those in its invoke-req* list
(lambda (uid)
(define (go desc)
(cond
[(libdesc-invoke-code desc) =>
(lambda (p)
(when (eq? p 'loading)
($oops #f "attempt to invoke library ~s while it is still being loaded" (libdesc-path desc)))
(when (eq? p 'pending)
($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc)))
(libdesc-invoke-code-set! desc 'pending)
(on-reset (libdesc-invoke-code-set! desc p)
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
(p))
(libdesc-invoke-code-set! desc #f))]))
(cond
[(get-library-descriptor uid) =>
(lambda (desc)
(cond
[(not (libdesc-rtdesc desc))
(with-message (format "attempting to 'revisit' previously 'visited' ~s for library ~s run-time info" (libdesc-outfn desc) (libdesc-path desc))
($revisit #f (libdesc-outfn desc)))
(invoke-library uid)]
[(libdesc-invoke-code desc) =>
(lambda (p)
(when (eq? p 'loading)
($oops #f "attempt to invoke library ~s while it is still being loaded" (libdesc-path desc)))
(when (eq? p 'pending)
($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc)))
(libdesc-invoke-code-set! desc 'pending)
(on-reset (libdesc-invoke-code-set! desc p)
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
(p))
(libdesc-invoke-code-set! desc #f))]))]
[else ($oops #f "library ~:s is not defined" uid)])))
(if (libdesc-rtdesc desc)
(go desc)
(let ([fn (libdesc-outfn desc)])
(with-message (format "attempting to 'revisit' previously 'visited' ~s for library ~s run-time info" fn (libdesc-path desc))
($revisit #f fn #f))
(let ([desc (get-library-descriptor uid)])
(unless (libdesc-ctdesc desc)
($oops #f "revisiting ~a did not define run-time information for library ~s" fn (libdesc-path desc)))
(go desc)))))]
[else ($oops #f "library ~:s is not defined" uid)])))
(define-threaded require-invoke
(lambda (uid)
@ -2566,7 +2573,7 @@
(cond
[(not (libdesc-rtdesc desc))
(with-message (format "attempting to 'revisit' previously 'visited' ~s for library ~s run-time info" (libdesc-outfn desc) (libdesc-path desc))
($revisit #f (libdesc-outfn desc)))
($revisit #f (libdesc-outfn desc) #f))
(retry)]
[(libdesc-invoke-code desc) =>
(lambda (p)
@ -2674,8 +2681,8 @@
(vthunk) ; might as well do this now. visit-req* have already been invoked
(install-library library-path library-uid
; import-code & visit-code is #f because vthunk invocation has already set up compile-time environment
(make-libdesc library-path library-version outfn #f
(make-ctdesc import-req* visit-visit-req* visit-req* '() #t #t '() #f #f)
(make-libdesc library-path library-version outfn #f #f
(make-ctdesc import-req* visit-visit-req* visit-req* #t #t '() #f #f)
(make-rtdesc invoke-req* #t
(top-level-eval-hook
(build-lambda no-source '()
@ -2701,12 +2708,7 @@
(lambda ()
(build-library/ct-info
(make-library/ct-info library-path library-version library-uid
import-req* visit-visit-req* visit-req*
(fold-left (lambda (clo* dl db)
(if dl
(cons (cons dl db) clo*)
clo*))
'() dl* db*)))))
import-req* visit-visit-req* visit-req*))))
,(rt-eval/residualize rtem
build-void
(lambda ()
@ -2724,14 +2726,22 @@
(cons label ls)
ls)))
'() env*)
; setup code
; import code
`(,(build-cte-install bound-id (build-data no-source interface-binding) '*system*)
,@(if (null? env*)
'()
`(,(build-sequence no-source
(map (lambda (x)
(build-cte-install (car x) (build-data no-source (cdr x)) #f))
env*)))))
,@(let ([clo* (fold-left (lambda (clo* dl db)
(if dl
(cons (cons dl db) clo*)
clo*))
'() dl* db*)])
(if (null? clo*)
'()
`(,(build-primcall #f 3 '$install-library-clo-info (build-data #f clo*)))))
,@(if (null? env*)
'()
`(,(build-sequence no-source
(map (lambda (x)
(build-cte-install (car x) (build-data no-source (cdr x)) #f))
env*)))))
; visit code
vcode*)))))))))
(let ([mb (car mb*)] [mb* (cdr mb*)])
@ -4574,7 +4584,7 @@
(module (install-library install-library/ct-desc install-library/rt-desc
install-library/ct-code install-library/rt-code uninstall-library
create-library-uid load-library lookup-library)
(module (search-loaded-libraries record-loaded-library! delete-loaded-library! list-loaded-libraries)
(module (search-loaded-libraries record-loaded-library delete-loaded-library list-loaded-libraries loaded-libraries-root)
(module (make-root insert-path delete-path search-path list-paths)
(define-record-type dir
(fields (immutable name) (immutable dir*) (immutable file*))
@ -4652,42 +4662,48 @@
(Dir '() root '()))))
(define root (make-root))
(define search-loaded-libraries
(lambda (path)
(search-path root path)))
(define delete-loaded-library!
(lambda (path)
(set! root (delete-path root path))))
(define record-loaded-library!
(lambda (path uid)
(set! root (insert-path root path uid))))
(case-lambda
[(path) (search-path root path)]
[(root path) (search-path root path)]))
(define delete-loaded-library
(case-lambda
[(path) (set! root (delete-path root path))]
[(root path) (delete-path root path)]))
(define record-loaded-library
(case-lambda
[(path uid) (set! root (insert-path root path uid))]
[(root path uid) (insert-path root path uid)]))
(define list-loaded-libraries
(lambda ()
(list-paths root))))
(case-lambda
[() (list-paths root)]
[(root) (list-paths root)]))
(define loaded-libraries-root
(lambda () root)))
(define install-library/ct-desc
(lambda (path version uid outfn ctdesc)
(lambda (path version uid outfn importer ctdesc)
(with-tc-mutex
(record-loaded-library! path uid)
(record-loaded-library path uid)
(put-library-descriptor uid
(make-libdesc path version outfn #f
ctdesc
(let ([desc (get-library-descriptor uid)])
(let ([desc (get-library-descriptor uid)])
(make-libdesc path version outfn (or (and desc (libdesc-importer desc)) importer) #f
ctdesc
(and desc (libdesc-rtdesc desc))))))))
(define install-library/rt-desc
(lambda (path version uid outfn rtdesc)
(lambda (path version uid outfn importer rtdesc)
(with-tc-mutex
(record-loaded-library! path uid)
(record-loaded-library path uid)
(put-library-descriptor uid
(make-libdesc path version outfn #f
(let ([desc (get-library-descriptor uid)])
(and desc (libdesc-ctdesc desc)))
rtdesc)))))
(let ([desc (get-library-descriptor uid)])
(make-libdesc path version outfn (or (and desc (libdesc-importer desc)) importer) #f
(and desc (libdesc-ctdesc desc))
rtdesc))))))
(define install-library
(lambda (path uid desc)
(with-tc-mutex
(record-loaded-library! path uid)
(record-loaded-library path uid)
(when desc (put-library-descriptor uid desc)))))
(define-who install-library/ct-code
@ -4712,7 +4728,7 @@
(lambda (path uid)
(with-tc-mutex
(rem-library-descriptor uid)
(delete-loaded-library! path))))
(delete-loaded-library path))))
(define create-library-uid
(lambda (name)
@ -4846,17 +4862,28 @@
(lambda (found-uid src-file-path)
(when needed-uid
(unless (eq? found-uid needed-uid)
(if src-file-path
($oops/c #f ($make-recompile-condition importer-path)
"compiled ~s requires different compilation instance of ~s from one found in ~a"
(or importer-path 'program) path src-file-path)
($oops/c #f ($make-recompile-condition importer-path)
"compiled ~s requires different compilation instance of ~s from one already loaded"
(or importer-path 'program) path))))))
(let ([c ($make-recompile-condition importer-path)] [importer-path (or importer-path 'program)])
(if src-file-path
($oops/c #f c
"loading ~a yielded a different compilation instance of ~s from that required by compiled ~s"
src-file-path
path
importer-path)
(let-values ([(outfn original-importer)
(let ([desc (get-library-descriptor found-uid)])
(if desc
(values (libdesc-outfn desc) (libdesc-importer desc))
(values #f #f)))])
($oops/c #f c
"compiled ~s requires a different compilation instance of ~s from the one previously ~:[compiled~;~:*loaded from ~a~]~@[ and originally imported by ~a~]"
importer-path
path
outfn
original-importer))))))))
(define do-load-library
(lambda (file-path situation)
(parameterize ([source-directories (cons (path-parent file-path) (source-directories))])
($load-library file-path situation))
($load-library file-path situation importer-path))
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
@ -4889,7 +4916,7 @@
(maybe-compile-library src-path obj-path)
(unless compiled?
(with-message (format "no need to recompile, so loading ~s" obj-path)
($load-library obj-path (if ct? 'visit 'revisit)))))
($load-library obj-path (if ct? 'visit 'revisit) importer-path))))
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
@ -4937,36 +4964,37 @@
; (a) and (b) but only (b) is one of the dependencies, we won't necessarily
; reload if a.ss is newer than a.so.
(with-message "object file is not older"
(with-message (format "loading object file ~s" obj-path)
(let ([found-uid (guard (c [(and ($recompile-condition? c) (eq? ($recompile-importer-path c) path))
(with-message (format "reloading ~s because a dependency has changed" src-path)
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))])
($load-library src-path 'load)))
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(load-deps found-uid)
found-uid)]
[else ($oops #f "reloading ~a did not define library ~s" src-path path)])])
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))])
(guard (c [(and (irritants-condition? c) (member obj-path (condition-irritants c)))
(with-message (with-output-to-string
(lambda ()
(display-string "failed to load object file: ")
(display-condition c)))
($oops/c #f ($make-recompile-condition path)
"problem loading object file ~a ~s" obj-path c))])
($load-library obj-path (if ct? 'visit 'revisit))))
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(load-deps found-uid)
found-uid)]
[else ($oops #f "loading ~a did not define library ~s" obj-path path)]))])
(verify-uid found-uid src-path)
found-uid)))
(let ([found-uid (guard (c [(and ($recompile-condition? c) (eq? ($recompile-importer-path c) path))
(with-message (format "reloading ~s because a dependency has changed" src-path)
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))])
($load-library src-path 'load importer-path)))
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(load-deps found-uid)
found-uid)]
[else ($oops #f "reloading ~a did not define library ~s" src-path path)])])
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))])
(guard (c [(and (irritants-condition? c) (member obj-path (condition-irritants c)))
(with-message (with-output-to-string
(lambda ()
(display-string "failed to load object file: ")
(display-condition c)))
($oops/c #f ($make-recompile-condition path)
"problem loading object file ~a ~s" obj-path c))])
(let ([situation (if ct? 'visit 'revisit)])
(with-message (format "~sing object file ~s" situation obj-path)
($load-library obj-path situation importer-path)))))
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(load-deps found-uid)
found-uid)]
[else ($oops #f "loading ~a did not define library ~s" obj-path path)]))])
(verify-uid found-uid src-path)
found-uid))
(load-source)))
(load-source)))))
($pass-time 'load-library
@ -4980,10 +5008,10 @@
(if ct?
(unless (libdesc-ctdesc desc)
(with-message (format "attempting to 'visit' previously 'revisited' ~s for library ~s compile-time info" (libdesc-outfn desc) path)
($visit #f (libdesc-outfn desc))))
($visit #f (libdesc-outfn desc) importer-path)))
(unless (libdesc-rtdesc desc)
(with-message (format "attempting to 'revisit' previously 'visited' ~s for library ~s run-time info" (libdesc-outfn desc) path)
($revisit #f (libdesc-outfn desc))))))
($revisit #f (libdesc-outfn desc) importer-path)))))
; need to call load-deps even if our library was already loaded,
; since we might, say, have previously loaded its invoke dependencies and
; now want to load its import dependencies
@ -5011,8 +5039,9 @@
(with-message (format "loading source file ~s" src-path)
(do-load-library src-path 'load))))
(if obj-exists?
(with-message (format "loading object file ~s" obj-path)
(do-load-library obj-path (if ct? 'visit 'revisit)))
(let ([situation (if ct? 'visit 'revisit)])
(with-message (format "~sing object file ~s" situation obj-path)
(do-load-library obj-path situation)))
($oops #f "library ~s not found" path))))])))))
(define version-okay?
@ -5120,6 +5149,168 @@
(lambda ()
(list-loaded-libraries)))
(set-who! verify-loadability
(lambda (situation . input*)
(define (parse-inputs input*)
(let ([default-libdirs (library-directories)])
(let loop ([input* input*] [rlibdirs* '()] [rfn* '()])
(if (null? input*)
(values (reverse rlibdirs*) (reverse rfn*))
(let ([input (car input*)] [input* (cdr input*)])
(cond
[(string? input) (loop input* (cons default-libdirs rlibdirs*) (cons input rfn*))]
[(and (pair? input) (string? (car input)) (guard (c [else #f]) (parameterize ([library-directories (cdr input)]) #t)))
(loop input* (cons (cdr input) rlibdirs*) (cons (car input) rfn*))]
[else ($oops who "invalid input ~s: expected either a string or a pair of a string and a valid library-directories value" input)]))))))
(define (get-lpinfo fn situation)
(let ([fn (let ([host-fn (format "~a.~s" (path-root fn) (machine-type))])
(if (file-exists? host-fn) host-fn fn))])
(let ([ip ($open-file-input-port who fn)])
(on-reset (close-port ip)
(let ([fp (let ([start-pos (port-position ip)])
(if (and (eqv? (get-u8 ip) (char->integer #\#))
(eqv? (get-u8 ip) (char->integer #\!))
(let ([b (get-u8 ip)]) (or (eqv? b (char->integer #\space)) (eqv? b (char->integer #\/)))))
(let loop ([fp 3])
(let ([b (get-u8 ip)])
(if (eof-object? b)
fp
(let ([fp (+ fp 1)])
(if (eqv? b (char->integer #\newline))
fp
(loop fp))))))
(begin (set-port-position! ip start-pos) 0)))])
(port-file-compressed! ip)
(unless ($compiled-file-header? ip) ($oops who "missing header for compiled file ~s" fn))
(let ([x (fasl-read ip)])
(unless (recompile-info? x) ($oops who "expected recompile info at start of ~s, found ~a" fn x)))
(let loop ([rlpinfo* '()])
(let ([x (fasl-read ip situation)])
(if (or (library-info? x) (program-info? x))
(loop (cons x rlpinfo*))
(begin (close-port ip) (reverse rlpinfo*))))))))))
(unless (memq situation '(load visit revisit)) ($oops who "invalid situation ~s; should be one of load, visit, or revisit" situation))
(let-values ([(libdirs* fn*) (parse-inputs input*)])
(let ([root (loaded-libraries-root)] [uid-ht (make-eq-hashtable)])
(define (check-ctdesc-libreqs! ctdesc importer)
(unless (ctdesc-loaded-import-reqs ctdesc)
(for-each (check-libreq! #t importer) (ctdesc-import-req* ctdesc))
(ctdesc-loaded-import-reqs-set! ctdesc #t))
(unless (ctdesc-loaded-visit-reqs ctdesc)
(for-each (check-libreq! #t importer) (ctdesc-visit-visit-req* ctdesc))
(for-each (check-libreq! #f importer) (ctdesc-visit-req* ctdesc))
(ctdesc-loaded-visit-reqs-set! ctdesc #t)))
(define (check-rtdesc-libreqs! rtdesc importer)
(unless (rtdesc-loaded-invoke-reqs rtdesc)
(for-each (check-libreq! #f importer) (rtdesc-invoke-req* rtdesc))
(rtdesc-loaded-invoke-reqs-set! rtdesc #t)))
(define (check-libreq! visit? importer)
(lambda (libreq)
(let ([path (libreq-path libreq)])
(define (check-uid! found-uid obj-path)
(unless (eq? found-uid (libreq-uid libreq))
(if obj-path
($oops who
"loading ~a yielded a different compilation instance of ~s from that required by ~a"
obj-path
path
importer)
(let-values ([(outfn original-importer)
(let ([desc (get-library-descriptor found-uid)])
(if desc
(values (libdesc-outfn desc) (libdesc-importer desc))
(values #f #f)))])
($oops who
"~a requires a different compilation instance of ~s from the one previously ~:[compiled~;~:*loaded from ~a~]~@[ and originally imported by ~a~]"
importer
path
outfn
original-importer)))))
(cond
[(search-loaded-libraries root path) =>
(lambda (found-uid)
(with-message (format "~s is already loaded...checking for compatibility" path)
(check-uid! found-uid #f)
(let ([desc (or (hashtable-ref uid-ht found-uid #f) (get-library-descriptor found-uid))])
(unless desc ($oops who "cyclic dependency involving import of library ~s" path))
(if visit?
(cond
[(libdesc-ctdesc desc) => (lambda (ctdesc) (check-ctdesc-libreqs! ctdesc importer))]
[else
(with-message "~s compile-time info for ~s has not yet been loaded...loading now"
(check-fn! 'visit (libdesc-outfn desc) importer)
(let ([desc (hashtable-ref uid-ht found-uid #f)])
(unless (and desc (libdesc-ctdesc desc))
($oops who "visiting ~s does not define compile-time information for ~s" (libdesc-outfn desc) path))))])
(cond
[(libdesc-rtdesc desc) => (lambda (rtdesc) (check-rtdesc-libreqs! rtdesc importer))]
[else
(with-message "~s run-time info for ~s has not yet been loaded...loading now"
(check-fn! 'revisit (libdesc-outfn desc) importer)
(let ([desc (hashtable-ref uid-ht found-uid #f)])
(unless (and desc (libdesc-rtdesc desc))
($oops who "revisiting ~s does not define run-time information for ~s" (libdesc-outfn desc) path))))])))))]
[else
(let-values ([(src-path obj-path obj-exists?) (library-search who path (library-directories) (library-extensions))])
(unless obj-exists? ($oops who "cannot find object file for library ~s" path))
(check-fn! (if visit? 'visit 'revisit) obj-path importer)
(let ([found-uid (search-loaded-libraries root path)])
(unless found-uid ($oops who "loading ~s did not define library ~s" obj-path path))
(check-uid! found-uid obj-path)
(let ([desc (hashtable-ref uid-ht found-uid #f)])
(if visit?
(unless (and desc (libdesc-ctdesc desc))
($oops who "visiting ~s does not define compile-time information for ~s" obj-path path))
(unless (and desc (libdesc-rtdesc desc))
($oops who "revisiting ~s does not define run-time information for ~s" obj-path path))))))]))))
(define (check-fn! situation fn importer)
(with-message (format "checking ~aability of ~a" situation fn)
; register each of the libraries in the file before chasing any of the dependencies
; to handle out-of-order info records and whole programs or libraries that depend on a
; binary library which in turn depends on an embedded library. this also more closely
; mirrors what happens when the file is actually loaded
((fold-left
(lambda (th lpinfo)
(cond
[(library/ct-info? lpinfo)
(with-message (format "found ~a import-req* = ~s, visit-visit-req* = ~s, visit-req* = ~s" fn
(map libreq-path (library/ct-info-import-req* lpinfo))
(map libreq-path (library/ct-info-visit-visit-req* lpinfo))
(map libreq-path (library/ct-info-visit-req* lpinfo)))
(let ([ctdesc (make-ctdesc
(library/ct-info-import-req* lpinfo)
(library/ct-info-visit-visit-req* lpinfo)
(library/ct-info-visit-req* lpinfo)
#f #f '() 'loading 'loading)])
(let ([path (library-info-path lpinfo)] [uid (library-info-uid lpinfo)])
(set! root (record-loaded-library root path uid))
(hashtable-set! uid-ht uid
(let ([desc (or (hashtable-ref uid-ht uid #f) (get-library-descriptor uid))])
(make-libdesc path (library-info-version lpinfo) fn (or (and desc (libdesc-importer desc)) importer) #f
ctdesc
(and desc (libdesc-rtdesc desc))))))
(lambda () (th) (check-ctdesc-libreqs! ctdesc fn))))]
[(library/rt-info? lpinfo)
(with-message (format "found ~a invoke-req* = ~s" fn
(map libreq-path (library/rt-info-invoke-req* lpinfo)))
(let ([rtdesc (make-rtdesc (library/rt-info-invoke-req* lpinfo) #f 'loading)])
(let ([path (library-info-path lpinfo)] [uid (library-info-uid lpinfo)])
(set! root (record-loaded-library root path uid))
(hashtable-set! uid-ht uid
(let ([desc (or (hashtable-ref uid-ht uid #f) (get-library-descriptor uid))])
(make-libdesc path (library-info-version lpinfo) fn (or (and desc (libdesc-importer desc)) importer) #f
(and desc (libdesc-ctdesc desc))
rtdesc))))
(lambda () (th) (check-rtdesc-libreqs! rtdesc fn))))]
[(program-info? lpinfo)
(with-message (format "found ~a invoke-req* = ~s" fn
(map libreq-path (program-info-invoke-req* lpinfo)))
(lambda () (th) (for-each (check-libreq! #f fn) (program-info-invoke-req* lpinfo))))]
[else ($oops who "unexpected library/program info record ~s" lpinfo)]))
void
(get-lpinfo fn situation)))))
(for-each (lambda (libdirs fn) (parameterize ([library-directories libdirs]) (check-fn! situation fn #f))) libdirs* fn*)))))
(let ()
(define maybe-get-lib
(lambda (who libref)
@ -5276,8 +5467,6 @@
(libdesc-import-code-set! desc #f)
(on-reset (libdesc-import-code-set! desc p)
(for-each (lambda (req) (import-library (libreq-uid req))) (libdesc-import-req* desc))
($install-library-clo-info (libdesc-clo* desc))
(libdesc-clo*-set! desc '())
(p)))]))]
[else ($oops #f "library ~:s is not defined" uid)])))
@ -5433,7 +5622,7 @@
(s2 i (fx+ i 1)))))
(s0 0)))
(define (parse-list who ls make-obj)
(define (parse-list who what ls make-obj)
(let f ([ls ls])
(if (null? ls)
'()
@ -5442,7 +5631,7 @@
[(string? x) (cons (cons x (make-obj x)) (f (cdr ls)))]
[(and (pair? x) (string? (car x)) (string? (cdr x)))
(cons (cons (car x) (cdr x)) (f (cdr ls)))]
[else ($oops who "invalid input-list element ~s" x)])))))
[else ($oops who (format "invalid ~a element ~~s" what) x)])))))
(set-who! library-directories
(rec library-directories
@ -5451,7 +5640,7 @@
(lambda (x)
(cond
[(string? x) (parse-string x (library-directories) values)]
[(list? x) (parse-list who x values)]
[(list? x) (parse-list who "path-list" x values)]
[else ($oops who "invalid path list ~s" x)])))))
(set-who! library-extensions
@ -5468,7 +5657,7 @@
(string-append (path-root src-ext) ".so")))
(cond
[(string? x) (parse-string x (library-extensions) default-obj-ext)]
[(list? x) (parse-list who x default-obj-ext)]
[(list? x) (parse-list who "extension-list" x default-obj-ext)]
[else ($oops who "invalid extension list ~s" x)]))))))
(set! $install-program-desc
@ -5493,27 +5682,26 @@
clo*)))
(set! $install-library/ct-desc
(lambda (linfo/ct for-import? ofn)
(lambda (linfo/ct for-import? importer ofn)
(let ([uid (library-info-uid linfo/ct)])
(when for-import?
(when (let ([desc (get-library-descriptor uid)]) (and desc (libdesc-ctdesc desc)))
($oops #f "attempting to re-install compile-time part of library ~s" (library-info-path linfo/ct))))
(install-library/ct-desc (library-info-path linfo/ct) (library-info-version linfo/ct) uid ofn
(install-library/ct-desc (library-info-path linfo/ct) (library-info-version linfo/ct) uid ofn importer
(make-ctdesc
(library/ct-info-import-req* linfo/ct)
(library/ct-info-visit-visit-req* linfo/ct)
(library/ct-info-visit-req* linfo/ct)
(library/ct-info-clo* linfo/ct)
#f #f '() 'loading 'loading)))))
(set! $install-library/rt-desc
(lambda (linfo/rt for-import? ofn)
(lambda (linfo/rt for-import? importer ofn)
(let ([uid (library-info-uid linfo/rt)])
(when for-import?
(when (let ([desc (get-library-descriptor uid)]) (and desc (libdesc-rtdesc desc)))
($oops #f "attempting to re-install run-time part of library ~s" (library-info-path linfo/rt))))
(install-library/rt-desc (library-info-path linfo/rt) (library-info-version linfo/rt)
uid ofn (make-rtdesc (library/rt-info-invoke-req* linfo/rt) #f 'loading)))))
(install-library/rt-desc (library-info-path linfo/rt) (library-info-version linfo/rt) uid ofn importer
(make-rtdesc (library/rt-info-invoke-req* linfo/rt) #f 'loading)))))
(set! $install-library/ct-code
(lambda (uid export-id* import-code visit-code)
@ -5592,8 +5780,8 @@
(define-who install-system-library
(lambda (path uid)
(install-library path uid
(make-libdesc path (if (eq? (car path) 'rnrs) '(6) '()) #f #t
(make-ctdesc '() '() '() '() #t #t '() #f #f)
(make-libdesc path (if (eq? (car path) 'rnrs) '(6) '()) #f #f #t
(make-ctdesc '() '() '() #t #t '() #f #f)
(make-rtdesc '() #t #f)))))
(set! $make-base-modules
(lambda ()