Merge github.com:cisco/ChezScheme

original commit: 8cf52012e2a7b5928cb2602bb17e0128ae0f2776

BUILDING

@@ -229,9 +229,9 @@ trouble, try running configure with --libkernel so that the build
 avoids running ld directly.
 
 On OpenBSD, Chez Scheme must be built and installed on a filesystem
-that is mounted with wxneeded.
+that is mounted with wxallowed.
 
-On NetNSD, note that the makefiles run "paxctl +m" to enable WX pages
+On NetBSD, note that the makefiles run "paxctl +m" to enable WX pages
 (i.e., pages that have both write and execute enabled).
 
 WINDOWS

LOG

@@ -1423,7 +1423,7 @@
     prim5.c, system.stex
 - restore {Free,Open,Net}BSD build, support Windows cross-compile
   via MinGW, add configuration options, and add helper makefile targets
-    expenditor.c, thread.c, stats.c, statics.c, scheme.c, main.c, types.h,
+    expeditor.c, thread.c, stats.c, statics.c, scheme.c, main.c, types.h,
     externs.h, globals.h, nocurses.h, version.h, system.h, segment.h,
     a6ob.def, ta6ob.def, a6nb.def, ta6nb.def, i3nt.def, ti3nt.def,
     c/Mf-*, build.bat, makefiles/Makefile.in, makefiles/Mf-install.in,
@@ -1436,3 +1436,557 @@
     scheme.c
 - remove dead stores in files
     compress-io.c, new-io.c
+- fixed tab character in makefiles
+    c/Mf-*nt
+- use case-insensitive search for ".exe" on Windows
+    c/scheme.c
+- fix __collect_safe for x86_64 and floating-point arguments or results
+    x86_64.ss, foreign.ms, release_notes.stex
+- annotations are now preserved in object files for debug
+  only, for profiling only, for both, or not at all, depending
+  on the settings of generate-inspector-information and
+  compile-profile.  in particular, when inspector information
+  is not enabled but profiling is, source information does
+  not leak into error messages and inspector output, though it is
+  still available via the profile tools.  The mechanics of this
+  involved repurposing the fasl a? parameter to hold an annotation
+  flags value when it is not #f and remaking annotations with
+  new flags if necessary before emitting them.
+    compile.ss, fasl.ss, misc.ms
+- altered a number of mats to produce correct results even
+  when the 's' directory is profiled.
+    misc.ms, cp0.ms, record.ms
+- profile-release-counters is now generation-friendly; that is,
+  it doesn't look for dropped code objects in generations that have
+  not been collected since the last call to profile-release-counters.
+  also, it no longer allocates memory when it releases counters.
+    pdhtml.ss,
+    gc.c, gcwrapper.c, globals.h, prim5.c
+- removed unused entry points S_ifile, S_ofile, and S_iofile
+    alloc.c, externs.h
+- mats that test loading profile info into the compiler's database
+  to guide optimization now weed out preexisting entries, in case
+  the 's' directory is profiled.
+    4.ms, mat.ss, misc.ms, primvars.ms
+- counters for dropped code objects are now released at the start
+  of each mat group.
+    mat.ss
+- replaced ehc (enable-heap-check) option with hci (heap-check-interval)
+  option that allows heap checks to be performed periodically rather
+  than on each collection.  hci=0 is equivalent to ehc=f (disabling
+  heap checks) and hci=1 is equivalent to ehc=t (enabling heap
+  checks every collection), while hci=100 enables heap checks only
+  every 100th collection.  allx and bullyx mats use this feature
+  to reduce heap-checking overhead to a more reasonable level.  this
+  is particularly important when the 's' directory is profiled,
+  since the amount of static memory to be checked is greatly increased
+  due to the counters.
+    mats/Mf-base, mat.ss, primvars.ms
+- added a mat that calls #%show-allocation, which was otherwise not
+  being tested.
+    misc.ms
+- removed a broken primvars mat and updated two others.  in each case,
+  the mat was looking for information about primitives in the wrong
+  (i.e., old) place and silently succeeding when it didn't find any
+  primitives to test.  the revised mats (along with a few others) now
+  check to make sure at least one identifier has the information they
+  look for.  the removed mat was checking for library information that
+  is now compiled in, so the mat is now unnecessary.  the others were
+  (not) doing argument-error checks.  fixing these turned up a handful of
+  problems that have also been fixed: a couple of unbound variables in the
+  mat driver, two broken primdata declarations, a tardy argument check
+  by profile-load-data, and a bug in char-ready?, which was requiring
+  an argument rather than defaulting it to the current input port.
+    primdata.ss, pdhtml.ss, io.ms,
+    primdvars.ms, 4.ms, 6.ms, misc.ms, patch*
+- added initial support for recording coverage information.  when the
+  new parameter generate-covin-files is set, the compiler generates
+  .covin files containing the universe of all source objects for which
+  profile forms are present in the expander output.  when profiling
+  and generation of covin files are enabled in the 's' directory, the
+  mats optionally generate .covout files for each mat file giving
+  the subset of the universe covered by the mat file, along with an
+  all.covout in each mat output directory aggregating the coverage
+  for the directory and another all.covout in the top-level mat
+  directory aggregating the coverage for all directories.
+    back.ss, compile.ss, cprep.ss, primdata.ss, s/Mf-base,
+    mat.ss, mats/Mf-base, mats/primvars.ms
+- support for generating covout files is now built in.  with-coverage-output
+  gathers and dumps coverage information, and aggregate-coverage-output
+  combines (aggregates) covout files.
+    pdhtml.ss, primdata.ss, compile.ss,
+    mat.ss, mats/Mf-base, primvars.ms
+- profile-clear now adjusts active coverage trackers to avoid losing
+  coverage information.
+    pdhtml.ss,
+    prim5.c
+- nested with-coverage calls are now supported.
+    pdhtml.ss
+- switched to a more compact representation for covin and covout files;
+  reduces disk space (compressed or not) by about a factor of four
+  and read time by about a factor of two with no increase in write time.
+    primdata.ss, pdhtml.ss, cprep.ss, compile.ss,
+    mat.ss, mats/Mf-base
+- added support for determining coverage for an entire run, including
+  coverage for expressions hit during boot time.  'all' mats now produce
+  run.covout files in each output directory, and 'allx' mats produce
+  an aggregate run.covout file in the mat directory.
+    pdhtml.ss,
+    mat.ss, mats/Mf-base
+- profile-release-counters now adjusts active coverage trackers to
+  account for the counters that have been released.
+    pdhtml.ss,
+    prim5.c
+- replaced the artificial "examples" target with a real "build-examples"
+  target so make won't think it always has to mats that depend upon
+  the examples directory having been compiled.  mats make clean now
+  runs make clean in the examples directory.
+    mats/Mf-base
+- importing a library from an object file now just visits the object
+  file rather than doing a full load so that the run-time code for
+  the library is not retained.  The run-time code is still read
+  because the current fasl format forces the entire file to be read,
+  but not retaining the code can lower heap size and garbage-collection
+  cost, particularly when many object-code libraries are imported.
+  The downside is that the file must be revisited if the run-time
+  code turns out to be required.   This change exposed several
+  places where the code was failing to check if a revisit is needed.
+    syntax.ss,
+    7.ms, 8.ms, misc.ms, root-experr*
+- fixed typos: was passing unquoted load rather than quoted load
+  to $load-library along one path (where it is loading source code
+  and therefore irrelevant), and was reporting src-path rather than
+  obj-path in a message about failing to define a library.
+    syntax.ss
+- compile-file and friends now put all recompile information in
+  the first fasl object after the header so the library manager can
+  find it without loading the entire fasl file.  The library manager
+  now does so.  It also now checks to see if library object files
+  need to be recreated before loading them rather than loading them and
+  possibly recompiling them after discovering they are out of date, since
+  the latter requires loading the full object file even if it's out of
+  date, while the former takes advantage of the ability to extract just
+  recompile information.  as well as reducing overhead, this eliminates
+  possibly undesirable side effects, such as creation and registration
+  of out-of-date nongenerative record-type descriptors.  because the
+  library manager expects to find recompile information at the front of
+  an object file, it will not find all recompile information if object
+  files are "catted" together.  also, compile-file has to hold in memory
+  the object code for all expressions in the file so that it can emit the
+  unified recompile information, rather than writing to the object file
+  incrementally, which can significantly increase the memory required
+  to compile a large file full of individual top-level forms.  This does
+  not affect top-level programs, which were already handled as a whole,
+  or a typical library file that contains just a single library form.
+    compile.ss, syntax.ss
+- the library manager now checks include files before library dependencies
+  when compile-imported-libraries is false (as it already did when
+  compile-imported-libraries is true) in case a source change affects
+  the set of imported libraries.  (A library change can affect the set
+  of include files as well, but checking dependencies before include
+  files can cause unneeded libraries to be loaded.)  The include-file
+  check is based on recompile-info rather than dependencies, but the
+  library checks are still based on dependencies.
+    syntax.ss
+- fixed check for binding of scheme-version. (the check prevents
+  premature treatment of recompile-info records as Lexpand forms
+  to be passed to $interpret-backend.)
+    scheme.c
+- strip-fasl-file now preserves recompile-info when compile-time info
+  is stripped.
+    strip.ss
+- removed include-req* from library/ct-info and ctdesc records; it
+  is no longer needed now that all recompile information is maintained
+  separately.
+    expand-lang.ss, syntax.ss, compile.ss, cprep.ss, syntax.ss
+- changed the fasl format and reworked a lot of code in the expander,
+  compiler, fasl writer, and fasl reader to allow the fasl reader
+  to skip past run-time information when it isn't needed and
+  compile-time information when it isn't needed.  Skipping past
+  still involves reading and decoding when encrypted, but the fasl
+  reader no longer parses or allocates code and data in the portions
+  to be skipped.  Side effects of associating record uids with rtds
+  are also avoided, as are the side effects of interning symbols
+  present only in the skipped data.  Skipping past code objects
+  also reduces or eliminates the need to synchronize data and
+  instruction caches.  Since the fasl reader no longer returns
+  compile-time (visit) or run-time (revisit) code and data when not
+  needed, the fasl reader no longer wraps these objects in a pair
+  with a 0 or 1 visit or revisit marker.  To support this change,
+  the fasl writer generates separate top-level fasl entries (and
+  graphs) for separate forms in the same top-level source form
+  (e.g., begin or library).  This reliably breaks eq-ness of shared
+  structure across these forms, which was previously broken only
+  when visit or revisit code was loaded at different times (this
+  is an incompatible change).  Because of the change, fasl "groups"
+  are no longer needed, so they are no longer handled.
+    7.ss, cmacros.ss, compile.ss, expand-lang.ss, strip.ss,
+    externs.h, fasl.c, scheme.c,
+    hash.ms
+- the change above is surfaced in an optional fasl-read "situation"
+  argument (visit, revisit, or load).  The default is load.  visit
+  causes it to skip past revisit code and data; revisit causes it
+  to skip past visit code and data; and load causes it not to skip
+  past either.  visit-revisit data produced by (eval-when (visit
+  revisit) ---) is never skipped.
+    7.ss, primdata.ss,
+    io.stex
+- to improve compile-time and run-time error checking, the
+  Lexpand recompile-info, library/rt-info, library-ct-info, and
+  program-info forms have been replaced with list-structured forms,
+  e.g., (recompile-info ,rcinfo).
+    expand-lang.ss, compile.ss, cprep.ss, interpret.ss, syntax.ss
+- added visit-compiled-from-port and revisit-compiled-from-port
+  to complement the existing load-compiled-from-port.
+    7.ss, primdata.ss,
+    7.ms,
+    system.stex
+- increased amount read when seeking an lz4-compressed input
+  file from 32 to 1024 bytes at a time
+    compress-io.c
+- replaced the fasl a? parameter value #t with an "all" flag value
+  so it's value is consistently a mask.
+    cmacros.ss, fasl.ss, compile.ss
+- split off profile mats into a separate file
+    misc.ms, profile.ms (new), root-experr*, mats/Mf-base
+- added coverage percent computations to mat allx/bullyx output
+    mat.ss, mats/Mf-base, primvars.ms
+- replaced coverage tables with more generic and generally useful
+  source tables, which map source objects to arbitrary values.
+    pdhtml.ss, compile.ss, cprep.ss, primdata.ss,
+    mat.ss, mats/Mf-base, primvars.ms, profile.ms,
+    syntax.stex
+- reduced profile counting overhead by using calls to fold-left
+  instead of calls to apply and map and by using fixnum operations
+  for profile counts on 64-bit machines.
+    pdhtml.ss
+- used a critical section to fix a race condition in the calculations
+  of profile counts that sometimes resulted in bogus (including
+  negative) counts, especially when the 's' directory is profiled.
+    pdhtml.ss
+- added discard flag to declaration for hashtable-size
+    primdata.ss
+- redesigned the printed representation of source tables and rewrote
+  get-source-table! to read and store incrementally to reduce memory
+  overhead.
+    compile.ss
+- added generate-covin-files to the set of parameters preserved
+  by compile-file, etc.
+    compile.ss,
+    system.stex
+- moved covop argument before the undocumented machine and hostop
+  arguments to compile-port and compile-to-port.  removed the
+  undocumented ofn argument from compile-to-port; using
+  (port-name ip) instead.
+    compile.ss, primdata.ss,
+    7.ms,
+    system.stex
+- compile-port now tries to come up with a file position to supply
+  to make-read, which it can do if the port's positions are character
+  positions (presently string ports) or if the port is positioned
+  at zero.
+    compile.ss
+- audited the argument-type-error fuzz mat exceptions and fixed a
+  host of problems this turned up (entries follow).  added #f as
+  an invalid argument for every type for which #f is indeed invalid
+  to catch places where the maybe- prefix was missing on the argument
+  type.  the mat tries hard to determine if the condition raised
+  (if any) as the result of an invalid argument is appropriate and
+  redirects the remainder to the mat-output (.mo) file prefixed
+  with 'Expected error', causing them to show up in the expected
+  error output so developers will be encouraged to audit them in
+  the future.
+    primvars.ms, mat.ss
+- added an initial symbol? test on machine type names so we produce
+  an invalid machine type error message rather than something
+  confusing like "machine type #f is not supported".
+    compile.ss
+- fixed declarations for many primitives that were specified as
+  accepting arguments of more general types than they actually
+  accept, such as number -> real for various numeric operations,
+  symbol -> endianness for various bytevector operations,
+  time -> time-utc for time-utc->date, and list -> list-of-string-pairs
+  for default-library-search-handler.   also replaced some of the
+  sub-xxxx types with specific types such as sub-symbol -> endianness
+  in utf16->string, but only where they were causing issues with
+  the primvars argument-type-error fuzz mat.  (this should be done
+  more generally.)
+    primdata.ss
+- fixed incorrect who arguments (was map instead of fold-right,
+  current-date instead of time-utc->date); switched to using
+  define-who/set-who! generally.
+    4.ss, date.ss
+- append! now checks all arguments before any mutation
+    5_2.ss
+- with-source-path now properly supplies itself as who for the
+  string? argument check; callers like load now do their own checks.
+    7.ss
+- added missing integer? check to $fold-bytevector-native-ref whose
+  lack could have resulted in a compile-time error.
+    cp0.ss
+- fixed typo in output-port-buffer-mode error message
+    io.ss
+- fixed who argument (was fx< rather than fx<?)
+    library.ss
+- fixed declaration of first source-file-descriptor argument (was
+  sfd, now string)
+    primdata.ss
+- added missing article 'a' in a few error messages
+    prims.ss
+- fixed the copy-environment argument-type error message for the list
+  of symbols argument.
+    syntax.ss
+- the environment procedure now catches exceptions that occur and
+  reraises the exception with itself as who if the condition isn't
+  already a who condition.
+    syntax.ss
+- updated experr and allx patch files for changes to argument-count
+  fuzz mat and fixes for problems turned up by them.
+    root-experr*, patch*
+- fixed a couple of issues setting port sizes: string and bytevector
+  output port put handlers don't need room to store the character
+  or byte, so they now set the size to the buffer length rather
+  than one less.  binary-file-port-clear-output now sets the index
+  rather than size to zero; setting the size to zero is inappropriate
+  for some types of ports and could result in loss of buffering and
+  even suppression of future output.  removed a couple of redundant
+  sets of the size that occur immediately after setting the buffer.
+    io.ss
+- it is now possible to return from a call to with-profile-tracker
+  multiple times and not double-count (or worse) any counts.
+    pdhtml.ss, profile.ms
+- read-token now requires a file position when it is handed a
+  source-file descriptor (since the source-file descriptor isn't
+  otherwise useful), and the source-file descriptor argument can
+  no longer be #f.  the input file position plays the same role as
+  the input file position in get-datum/annotations.  these extra
+  read-token arguments are now documented.
+    read.ss,
+    6.ms,
+    io.stex
+- the source-file descriptor argument to get-datum/annotations can
+  no longer be #f.  it was already documented that way.
+    read.ss
+- read-token and do-read now look for the character-positions port
+  flag before asking if the port has port-position, since the latter
+  is slightly more expensive.
+    read.ss
+- rd-error now reports the current port position if it can be determined
+  when fp isn't already set, i.e., when reading from a port without
+  character positions (presently any non string port) and fp has not
+  been passed in explicitly (to read-token or get-datum/annotations).
+  the port position might not be a character position, but it should be
+  better than nothing.
+    read.ss
+- added comment noting an invariant for s_profile_release_counters.
+    prim5.c
+- restored accidentally dropped fasl-write formdef and dropped
+  duplicate fasl-read formdef
+    io.stex
+- added a 'coverage' target that tests the coverage of the Scheme-code
+  portions of Chez Scheme by the mats.
+    Makefile.in, Makefile-workarea.in
+- added .PHONY declarations for all of the targets in the top-level
+  and workarea make files, and renamed the create-bintar, create-rpm,
+  and create-pkg targets bintar, rpm, and pkg.
+    Makefile.in, Makefile-workarea.in
+- added missing --retain-static-relocation command-line argument and
+  updated the date
+    scheme.1.in
+- removed a few redundant conditional variable settings
+    configure
+- fixed declaration of condition wait (timeout -> maybe-timeout)
+    primdata.ms
+- added "invalid code page ~s" to set of messages considered valid
+  argument-type-check error messages, for Windows multibyte->string
+  and string->multibyte.
+    primvars.ms
+- used with-object-file to restore accidentally dropped close-port in
+  compile-whole-program and compile-whole-library
+    compile.ss
+- initialized variable to enable compilation with gcc 9.1.0 at -O3
+    c/scheme.c
+- added missing Inner wrappers around the library/ct-info and
+  library-rt-info records in the code for compile-whole-xxx.
+    compile.ss,
+    7.ms
+- local-eval-hook now calls eval rather than interpret when profiling
+  is enabled, so local transformer code can be profiled.
+    syntax.ss,
+    profile.ms
+- fix compiler bug related to call-with-values and a first argument
+  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
+- added concatenate-object-files
+    compile.ss, primdata.ss
+    7.ms, root-experr*
+    system.stex, use.stex, release_notes.stex
+- added invoke-library
+    syntax.ss, primdata.ss,
+    8.ms, root-experr*,
+    libraries.stex, release_notes.stex
+- updated the date
+    release_notes.stex
+- libraries contained within a whole program or library are now
+  marked pending before their invoke code is run so that invoke
+  cycles are reported as such rather than as attempts to invoke
+  while still loading.
+    compile.ss, syntax.ss, primdata.ss,
+    7.ms, root-experr*
+- the library manager now protects against unbound references 
+  from separately compiled libraries or programs to identifiers
+  ostensibly but not actually exported by (invisible) libraries
+  that exist only locally within a whole program.  this is done by
+  marking the invisibility of the library in the library-info and
+  propagating it to libdesc records; the latter is checked upon
+  library import, visit, and invoke as well as by verify-loadability.
+  the import and visit code of each invisible no longer complains
+  about invisibility since it shouldn't be reachable.
+    syntax.ss, compile.ss, expand-lang.ss,
+    7.ms, 8.ms, root-experr*, patch*
+- documented that compile-whole-xxx's linearization of the
+  library initialization code based on static dependencies might
+  not work for dynamic dependencies.
+    system.stex
+- optimized bignum right shifts so the code (1) doesn't look at
+  shifted-off bigits if the bignum is positive, since it doesn't
+  need to know in that case if any bits are set; (2) doesn't look
+  at shifted-off bigits if the bignum is negative if it determines
+  that at least one bit is set in the bits shifted off the low-order
+  partially retained bigit; (3) quits looking, if it must look, for
+  one bits as soon as it finds one; (4) looks from both ends under
+  the assumption that set bits, if any, are most likely to be found
+  toward the high or low end of the bignum rather than just in the
+  middle; and (5) doesn't copy the retained bigits and then shift;
+  rather shifts as it copies.  This leads to dramatic improvements
+  when the shift count is large and often significant improvements
+  otherwise.
+    number.c,
+    5_3.ms,
+    release_notes.stex
+- threaded tc argument through to all calls to S_bignum and
+  S_trunc_rem so they don't have to call get_thread_context()
+  when it might already have been called.
+    alloc.c, number.c, fasl.c, print.c, prim5.c, externs.h
+- added an expand-primitive handler to partially inline integer?.
+    cpnanopass.ss
+- added some special cases for basic arithmetic operations (+, -, *,
+  /, quotient, remainder, and the div/div0/mod/mod0 operations) to
+  avoid doing unnecessary work for large bignums when the result
+  will be zero (e.g,. multiplying by 0), the same as one of the
+  inputs (e.g., adding 0 or multiplying by 1), or the additive
+  inverse of one of the inputs (e.g., subtracting from 0, dividing
+  by -1).  This can have a major beneficial affect when operating
+  on large bignums in the cases handled.  also converted some uses
+  of / into integer/ where going through the former would just add
+  overhead without the possibility of optimization.
+    5_3.ss,
+    number.c, externs.h, prim5.c,
+    5_3.ms, root-experr, patch*,
+    release_notes.stex
+- added a queue to hold pending signals for which handlers have
+  been registered via register-signal-handler so up to 63 (configurable
+  in the source code) unhandled signals are buffered before the
+  handler has to start dropping them.
+    cmacros.ss, library.ss, prims.ss, primdata.ss,
+    schsig.c, externs.h, prim5.c, thread.c, gc.c,
+    unix.ms,
+    system.stex, release_notes.stex
+- bytevector-compress now selects the level of compression based
+  on the compress-level parameter.  Prior to this it always used a
+  default setting for compression.  the compress-level parameter
+  can now take on the new minimum in addition to low, medium, high,
+  and maximum.  minimum is presently treated the same as low
+  except in the case of lz4 bytevector compression, where it
+  results in the use of LZ4_compress_default rather than the
+  slower but more effective LZ4_compress_HC.
+    cmacros,ss, back.ss,
+    compress_io.c, new_io.c, externs.h,
+    bytevector.ms, mats/Mf-base, root-experr*
+    io.stex, objects.stex, release_notes.stex

c/Mf-a6nt

@@ -55,7 +55,7 @@ ${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
 
 ../zlib/configure.log:
 	echo "all:" >> ../zlib/Makefile
-	echo '\t$$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile
+	echo '	$$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile
 	touch ../zlib/configure.log
 
 ../lz4/lib/liblz4.a: ${LZ4Sources}

c/Mf-i3nt

@@ -55,7 +55,7 @@ ${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
 
 ../zlib/configure.log:
 	echo "all:" >> ../zlib/Makefile
-	echo '\t$$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile
+	echo '	$$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile
 	touch ../zlib/configure.log
 
 ../lz4/lib/liblz4.a: ${LZ4Sources}

c/Mf-ta6nt

@@ -55,7 +55,7 @@ ${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
 
 ../zlib/configure.log:
 	echo "all:" >> ../zlib/Makefile
-	echo '\t$$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile
+	echo '	$$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile
 	touch ../zlib/configure.log
 
 ../lz4/lib/liblz4.a: ${LZ4Sources}

c/Mf-ti3nt

@@ -55,7 +55,7 @@ ${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
 
 ../zlib/configure.log:
 	echo "all:" >> ../zlib/Makefile
-	echo '\t$$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile
+	echo '	$$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile
 	touch ../zlib/configure.log
 
 ../lz4/lib/liblz4.a: ${LZ4Sources}

c/alloc.c

@@ -688,64 +688,6 @@ ptr S_exactnum(a, b) ptr a, b; {
     return p;
 }
 
-ptr S_ifile(icount, name, fd, info, flags, ilast, ibuf)
-        iptr flags, icount; char *ilast; iptr fd; ptr name, ibuf, info; {
-    ptr tc = get_thread_context();
-    ptr p;
-
-    thread_find_room(tc, type_typed_object, size_port, p);
-    PORTTYPE(p) = flags | type_port;
-    PORTNAME(p) = name;
-  /* PORTHANDLER is really a ptr only when PORTTYPE & PORT_FLAG_PROC_HANDLER is true */
-    PORTHANDLER(p) = (ptr)fd;
-    PORTINFO(p) = info;
-    PORTICNT(p) = icount;
-    PORTILAST(p) = (ptr)ilast;
-    PORTIBUF(p) = ibuf;
-  /* leave output buffer and last uninitialized for input only ports */
-    PORTOCNT(p) = 0;
-    return p;
-}
-
-ptr S_ofile(ocount, name, fd, info, flags, olast, obuf)
-        iptr flags, ocount; char *olast; iptr fd; ptr name, obuf, info; {
-    ptr tc = get_thread_context();
-    ptr p;
-
-    thread_find_room(tc, type_typed_object, size_port, p);
-    PORTTYPE(p) = flags | type_port;
-    PORTNAME(p) = name;
-  /* PORTHANDLER is really a ptr only when PORTTYPE & PORT_FLAG_PROC_HANDLER is true */
-    PORTHANDLER(p) = (ptr)fd;
-    PORTINFO(p) = info;
-    PORTOCNT(p) = ocount;
-    PORTOLAST(p) = (ptr)olast;
-    PORTOBUF(p) = obuf;
-  /* leave input buffer and last uninitialized for output only ports */
-    PORTICNT(p) = 0;
-    return p;
-}
-
-ptr S_iofile(icount, ocount, name, fd, info, flags, ilast, ibuf, olast, obuf)
-        iptr flags, icount, ocount; char *ilast, *olast; iptr fd; ptr name, ibuf, obuf, info; {
-    ptr tc = get_thread_context();
-    ptr p;
-
-    thread_find_room(tc, type_typed_object, size_port, p);
-    PORTTYPE(p) = flags | type_port;
-    PORTNAME(p) = name;
-  /* PORTHANDLER is really a ptr only when PORTTYPE & PORT_FLAG_PROC_HANDLER is true */
-    PORTHANDLER(p) = (ptr)fd;
-    PORTINFO(p) = info;
-    PORTICNT(p) = icount;
-    PORTILAST(p) = (ptr)ilast;
-    PORTIBUF(p) = ibuf;
-    PORTOCNT(p) = ocount;
-    PORTOLAST(p) = (ptr)olast;
-    PORTOBUF(p) = obuf;
-    return p;
-}
-
 /* S_string returns a new string of length n.  If s is not NULL, it is
  * copied into the new string.  If n < 0, then s must be non-NULL,
  * and the length of s (by strlen) determines the length of the string */
@@ -906,8 +848,7 @@ ptr Sstring_utf8(s, n) const char *s; iptr n; {
   return p;
 }
 
-ptr S_bignum(n, sign) iptr n; IBOOL sign; {
+ptr S_bignum(tc, n, sign) ptr tc; iptr n; IBOOL sign; {
-    ptr tc = get_thread_context();
     ptr p; iptr d;
 
     if ((uptr)n > (uptr)maximum_bignum_length)

c/compress-io.c

@@ -91,6 +91,23 @@ static INT glzread_lz4(lz4File_in *lz4, void *buffer, UINT count);
 static INT glzemit_lz4(lz4File_out *lz4, void *buffer, UINT count);
 static INT glzwrite_lz4(lz4File_out *lz4, void *buffer, UINT count);
 
+INT S_zlib_compress_level(INT compress_level) {
+  switch (compress_level) {
+    case COMPRESS_MIN:
+    case COMPRESS_LOW:
+      return Z_BEST_SPEED;
+    case COMPRESS_MEDIUM:
+      return (Z_BEST_SPEED + Z_BEST_COMPRESSION) / 2;
+    case COMPRESS_HIGH:
+      return (Z_BEST_SPEED + (3 * Z_BEST_COMPRESSION)) / 4;
+    case COMPRESS_MAX:
+      return Z_BEST_COMPRESSION;
+    default:
+      S_error1("S_zlib_compress_level", "unexpected compress level ~s", Sinteger(compress_level));
+      return 0;
+  }
+}
+
 static glzFile glzdopen_output_gz(INT fd, INT compress_level) {
   gzFile gz;
   glzFile glz;
@@ -105,24 +122,7 @@ static glzFile glzdopen_output_gz(INT fd, INT compress_level) {
 
   if ((gz = gzdopen(fd, as_append ? "ab" : "wb")) == Z_NULL) return Z_NULL;
 
-  switch (compress_level) {
+  level = S_zlib_compress_level(compress_level);
-    case COMPRESS_LOW:
-      level = Z_BEST_SPEED;
-      break;
-    case COMPRESS_MEDIUM:
-      level = (Z_BEST_SPEED + Z_BEST_COMPRESSION) / 2;
-      break;
-    case COMPRESS_HIGH:
-      level = (Z_BEST_SPEED + (3 * Z_BEST_COMPRESSION)) / 4;
-      break;
-    case COMPRESS_MAX:
-      level = Z_BEST_COMPRESSION;
-      break;
-    default:
-      S_error1("glzdopen_output_gz", "unexpected compress level ~s", Sinteger(compress_level));
-      level = 0;
-      break;
-  }
 
   gzsetparams(gz, level, Z_DEFAULT_STRATEGY);
 
@@ -137,29 +137,29 @@ static glzFile glzdopen_output_gz(INT fd, INT compress_level) {
   return glz;
 }
 
+INT S_lz4_compress_level(INT compress_level) {
+  switch (compress_level) {
+    case COMPRESS_MIN:
+    case COMPRESS_LOW:
+      return 1;
+    case COMPRESS_MEDIUM:
+      return LZ4HC_CLEVEL_MIN;
+    case COMPRESS_HIGH:
+      return (LZ4HC_CLEVEL_MIN + LZ4HC_CLEVEL_MAX) / 2;
+    case COMPRESS_MAX:
+      return LZ4HC_CLEVEL_MAX;
+    default:
+      S_error1("S_lz4_compress_level", "unexpected compress level ~s", Sinteger(compress_level));
+      return 0;
+  }
+}
+
 static glzFile glzdopen_output_lz4(INT fd, INT compress_level) {
   glzFile glz;
   lz4File_out *lz4;
   INT level;
 
-  switch (compress_level) {
+  level = S_lz4_compress_level(compress_level);
-    case COMPRESS_LOW:
-      level = 1;
-      break;
-    case COMPRESS_MEDIUM:
-      level = LZ4HC_CLEVEL_MIN;
-      break;
-    case COMPRESS_HIGH:
-      level = (LZ4HC_CLEVEL_MIN + LZ4HC_CLEVEL_MAX) / 2;
-      break;
-    case COMPRESS_MAX:
-      level = LZ4HC_CLEVEL_MAX;
-      break;
-    default:
-      S_error1("glzdopen_output_lz4", "unexpected compress level ~s", Sinteger(compress_level));
-      level = 0;
-      break;
-  }
 
   if ((lz4 = malloc(sizeof(lz4File_out))) == NULL) return Z_NULL;
   memset(&lz4->preferences, 0, sizeof(LZ4F_preferences_t));
@@ -561,7 +561,7 @@ long S_glzseek(glzFile glz, long offset, INT whence) {
           lz4->stream_pos = 0;
         }
         while ((size_t)offset > lz4->stream_pos) {
-          char buffer[32];
+          static char buffer[1024];
           size_t amt = (size_t)offset - lz4->stream_pos;
           if (amt > sizeof(buffer)) amt = sizeof(buffer);
           if (glzread_lz4(lz4, buffer, (UINT)amt) < 0)

c/externs.h

@@ -91,14 +91,8 @@ extern ptr S_mkcontinuation PROTO((ISPC s, IGEN g, ptr nuate, ptr stack,
 extern ptr S_inexactnum PROTO((double rp, double ip));
 extern ptr S_exactnum PROTO((ptr a, ptr b));
 extern ptr S_thread PROTO((ptr tc));
-extern ptr S_ifile PROTO((iptr icount, ptr name, iptr fd, ptr info, iptr flags, char *ilast,
-                  ptr ibuf));
-extern ptr S_ofile PROTO((iptr ocount, ptr name, iptr fd, ptr info, iptr flags, char *olast,
-            ptr obuf));
-extern ptr S_iofile PROTO((iptr icount, iptr ocount, ptr name, iptr fd, ptr info, iptr flags,
-            char *ilast, ptr ibuf, char *olast, ptr obuf));
 extern ptr S_string PROTO((const char *s, iptr n));
-extern ptr S_bignum PROTO((iptr n, IBOOL sign));
+extern ptr S_bignum PROTO((ptr tc, iptr n, IBOOL sign));
 extern ptr S_code PROTO((ptr tc, iptr type, iptr n));
 extern ptr S_relocation_table PROTO((iptr n));
 extern ptr S_weak_cons PROTO((ptr car, ptr cdr));
@@ -107,7 +101,7 @@ extern void S_phantom_bytevector_adjust PROTO((ptr ph, uptr new_sz));
 
 /* fasl.c */
 extern void S_fasl_init PROTO((void));
-ptr S_fasl_read PROTO((ptr file, IBOOL gzflag, ptr path));
+ptr S_fasl_read PROTO((ptr file, IBOOL gzflag, IFASLCODE situation, ptr path));
 ptr S_bv_fasl_read PROTO((ptr bv, int ty, uptr offset, uptr len, ptr path));
 /* S_boot_read's f argument is really gzFile, but zlib.h is not included everywhere */
 ptr S_boot_read PROTO((glzFile file, const char *path));
@@ -163,6 +157,7 @@ extern void S_set_enable_object_backreferences PROTO((IBOOL eoc));
 extern ptr S_object_backreferences 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));
 
@@ -200,6 +195,8 @@ extern wchar_t *S_malloc_wide_pathname PROTO((const char *inpath));
 extern IBOOL S_fixedpathp PROTO((const char *inpath));
 
 /* compress-io.c */
+extern INT S_zlib_compress_level PROTO((INT compress_level));
+extern INT S_lz4_compress_level PROTO((INT compress_level));
 extern glzFile S_glzdopen_output PROTO((INT fd, INT compress_format, INT compress_level));
 extern glzFile S_glzdopen_input PROTO((INT fd));
 extern glzFile S_glzopen_input PROTO((const char *path));
@@ -285,13 +282,14 @@ extern iptr S_integer_value PROTO((const char *who, ptr x));
 extern I64 S_int64_value PROTO((char *who, ptr x));
 extern IBOOL S_big_eq PROTO((ptr x, ptr y));
 extern IBOOL S_big_lt PROTO((ptr x, ptr y));
+extern ptr S_big_negate PROTO((ptr x));
 extern ptr S_add PROTO((ptr x, ptr y));
 extern ptr S_sub PROTO((ptr x, ptr y));
 extern ptr S_mul PROTO((ptr x, ptr y));
 extern ptr S_div PROTO((ptr x, ptr y));
 extern ptr S_rem PROTO((ptr x, ptr y));
 extern ptr S_trunc PROTO((ptr x, ptr y));
-extern void S_trunc_rem PROTO((ptr x, ptr y, ptr *q, ptr *r));
+extern void S_trunc_rem PROTO((ptr tc, ptr x, ptr y, ptr *q, ptr *r));
 extern ptr S_gcd PROTO((ptr x, ptr y));
 extern ptr S_ash PROTO((ptr x, ptr n));
 extern ptr S_big_positive_bit_field PROTO((ptr x, ptr fxstart, ptr fxend));
@@ -351,6 +349,8 @@ extern void S_handle_nonprocedure_symbol PROTO((void));
 extern void S_handle_values_error PROTO((void));
 extern void S_handle_mvlet_error PROTO((void));
 extern void S_handle_event_detour PROTO((void));
+extern ptr S_allocate_scheme_signal_queue PROTO((void));
+extern ptr S_dequeue_scheme_signals PROTO((ptr tc));
 extern void S_register_scheme_signal PROTO((iptr sig));
 extern void S_fire_collector PROTO((void));
 extern NORETURN void S_noncontinuable_interrupt PROTO((void));

c/fasl.c

@@ -20,10 +20,13 @@
  *
  * <fasl-group> -> <fasl header><fasl-object>*
  *
- * <fasl-header> -> {header}\0\0\0chez<uptr version><uptr machine-type>
+ * <fasl-header> -> {header}\0\0\0chez<uptr version><uptr machine-type>(<bootfile-name> ...)
  *
- * <fasl-object> -> {fasl-size}<uptr size> # size in bytes of following <fasl>
+ * <bootfile-name> -> <octet char>*
- *                             <fasl>
+ *
+ * <fasl-object> -> <situation>{fasl-size}<uptr size><fasl> # size is the size in bytes of the following <fasl>
+ *
+ * <situation> -> {visit}{revisit}{visit-revisit}
  *
  * <fasl> -> {pair}<uptr n><fasl elt1>...<fasl eltn><fasl last-cdr>
  *
@@ -63,7 +66,7 @@
  *
  *        -> {library-code}<uptr index>
  *
- *        -> {graph}<uptr graph-length>
+ *        -> {graph}<uptr graph-length><fasl object>
  *
  *        -> {graph-def}<uptr index><fasl object>
  *
@@ -212,7 +215,7 @@ typedef struct faslFileObj {
 static INT uf_read PROTO((unbufFaslFile uf, octet *s, iptr n));
 static octet uf_bytein PROTO((unbufFaslFile uf));
 static uptr uf_uptrin PROTO((unbufFaslFile uf));
-static ptr fasl_entry PROTO((ptr tc, unbufFaslFile uf));
+static ptr fasl_entry PROTO((ptr tc, IFASLCODE situation, unbufFaslFile uf));
 static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, IFASLCODE ty, uptr offset, uptr len, unbufFaslFile uf));
 static void fillFaslFile PROTO((faslFile f));
 static void bytesin PROTO((octet *s, iptr n, faslFile f));
@@ -288,7 +291,7 @@ void S_fasl_init() {
 #endif
 }
 
-ptr S_fasl_read(ptr file, IBOOL gzflag, ptr path) {
+ptr S_fasl_read(ptr file, IBOOL gzflag, IFASLCODE situation, ptr path) {
   ptr tc = get_thread_context();
   ptr x; struct unbufFaslFileObj uffo;
 
@@ -302,7 +305,7 @@ ptr S_fasl_read(ptr file, IBOOL gzflag, ptr path) {
     uffo.type = UFFO_TYPE_FD;
     uffo.fd = GET_FD(file);
   }
-  x = fasl_entry(tc, &uffo);
+  x = fasl_entry(tc, situation, &uffo);
   tc_mutex_release()
   return x;
 }
@@ -327,7 +330,7 @@ ptr S_boot_read(glzFile file, const char *path) {
   uffo.path = Sstring_utf8(path, -1);
   uffo.type = UFFO_TYPE_GZ;
   uffo.file = file;
-  return fasl_entry(tc, &uffo);
+  return fasl_entry(tc, fasl_type_visit_revisit, &uffo);
 }
 
 #define GZ_IO_SIZE_T unsigned int
@@ -379,11 +382,27 @@ static INT uf_read(unbufFaslFile uf, octet *s, iptr n) {
   return 0;
 }
 
+
 int S_fasl_stream_read(void *stream, octet *dest, iptr n)
 {
   return uf_read((unbufFaslFile)stream, dest, n);
 }
 
+static void uf_skipbytes(unbufFaslFile uf, iptr n) {
+  switch (uf->type) {
+    case UFFO_TYPE_GZ:
+       if (S_glzseek(uf->file, (long)n, SEEK_CUR) == -1) {
+         S_error1("", "error seeking ~a", uf->path);
+       }
+       break;
+    case UFFO_TYPE_FD:
+       if (LSEEK(uf->fd, n, SEEK_CUR) == -1) {
+         S_error1("", "error seeking ~a", uf->path);
+       }
+       break;
+  }
+}
+
 static octet uf_bytein(unbufFaslFile uf) {
   octet buf[1];
   if (uf_read(uf, buf, 1) < 0)
@@ -429,11 +448,11 @@ char *S_lookup_machine_type(uptr n) {
     return "unknown";
 }
 
-static ptr fasl_entry(ptr tc, unbufFaslFile uf) {
+static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf) {
   ptr x; ptr strbuf = S_G.null_string;
-  octet tybuf[1]; IFASLCODE ty;
+  octet tybuf[1]; IFASLCODE ty, fmt; iptr size;
-  struct faslFileObj ffo; octet buf[SBUFSIZ];
 
+  for (;;) {
     if (uf_read(uf, tybuf, 1) < 0) return Seof_object; 
     ty = tybuf[0];
 
@@ -448,7 +467,7 @@ static ptr fasl_entry(ptr tc, unbufFaslFile uf) {
           uf_bytein(uf) != 'h' || 
           uf_bytein(uf) != 'e' || 
           uf_bytein(uf) != 'z')
-      S_error1("", "malformed fasl-object header found in ~a", uf->path);
+        S_error1("", "malformed fasl-object header (missing magic word) found in ~a", uf->path);
     
       if ((n = uf_uptrin(uf)) != scheme_version)
         S_error2("", "incompatible fasl-object version ~a found in ~a", S_string(S_format_scheme_version(n), -1), uf->path);
@@ -457,21 +476,36 @@ static ptr fasl_entry(ptr tc, unbufFaslFile uf) {
         S_error2("", "incompatible fasl-object machine-type ~a found in ~a", S_string(S_lookup_machine_type(n), -1), uf->path);
     
       if (uf_bytein(uf) != '(')
-      S_error1("", "malformed fasl-object header found in ~a", uf->path);
+        S_error1("", "malformed fasl-object header (missing open paren) found in ~a", uf->path);
     
       while ((c = uf_bytein(uf)) != ')')
-      if (c < 0) S_error1("", "malformed fasl-object header found in ~a", uf->path);
+        if (c < 0) S_error1("", "malformed fasl-object header (missing close paren) found in ~a", uf->path);
   
       ty = uf_bytein(uf);
     }
   
-  if ((ty != fasl_type_fasl_size)
+    switch (ty) {
-      && (ty != fasl_type_vfasl_size))
+      case fasl_type_visit:
-    S_error1("", "malformed fasl-object header found in ~a", uf->path);
+      case fasl_type_revisit:
+      case fasl_type_visit_revisit:
+        break;
+      default:
+        S_error2("", "malformed fasl-object header (missing situation, got ~s) found in ~a", FIX(ty), uf->path);
+        return (ptr)0;
+    }
 
-  ffo.size = uf_uptrin(uf);
+    fmt = uf_bytein(uf);
+    if ((fmt != fasl_type_fasl_size) && (fmt != fasl_type_vfasl_size))
+      S_error1("", "malformed fasl-object header (missing fasl-size) found in ~a", uf->path);
   
-  if (ty == fasl_type_vfasl_size) {
+    size = uf_uptrin(uf);
+  
+    if (ty == situation || situation == fasl_type_visit_revisit || ty == fasl_type_visit_revisit) {
+      struct faslFileObj ffo; octet buf[SBUFSIZ];
+
+      ffo.size = size;
+      
+      if (fmt == fasl_type_vfasl_size) {
         if (S_vfasl_boot_mode == -1) {
           S_vfasl_boot_mode = 1;
           Scompact_heap();
@@ -481,12 +515,14 @@ static ptr fasl_entry(ptr tc, unbufFaslFile uf) {
         ffo.buf = buf;
         ffo.next = ffo.end = ffo.buf;
         ffo.uf = uf;
-    
         faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
       }
-
       S_flush_instruction_cache(tc);
       return x;
+    } else {
+      uf_skipbytes(uf, size);
+    }
+  }
 }
 
 static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFaslFile uf) {
@@ -674,7 +710,6 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
             faslin(tc, &EXACTNUM_REAL_PART(*x), t, pstrbuf, f);
             faslin(tc, &EXACTNUM_IMAG_PART(*x), t, pstrbuf, f);
             return;
-        case fasl_type_group:
         case fasl_type_vector:
         case fasl_type_immutable_vector: {
             iptr n; ptr *p;
@@ -915,7 +950,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
             IBOOL sign; iptr n; ptr t; bigit *p;
             sign = bytein(f);
             n = uptrin(f);
-            t = S_bignum(n, sign);
+            t = S_bignum(tc, n, sign);
             p = &BIGIT(t, 0);
             while (n--) *p++ = (bigit)uptrin(f);
             *x = S_normalize_bignum(t);
@@ -1003,18 +1038,6 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
         case fasl_type_graph_ref:
             *x = Svector_ref(t, uptrin(f));
             return;
-        case fasl_type_visit: {
-            ptr p;
-            *x = p = Scons(FIX(visit_tag), FIX(0));
-            faslin(tc, &INITCDR(p), t, pstrbuf, f);
-            return;
-        }
-        case fasl_type_revisit: {
-            ptr p;
-            *x = p = Scons(FIX(revisit_tag), FIX(0));
-            faslin(tc, &INITCDR(p), t, pstrbuf, f);
-            return;
-        }
         case fasl_type_begin: {
             uptr n = uptrin(f) - 1; ptr v;
             while (n--)

c/gc.c

@@ -1536,7 +1536,7 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) {
         si->next = chunk->unused_segs;
         chunk->unused_segs = si;
 #ifdef WIPECLEAN
-        memset((void *)build_ptr(seg,0), 0xc7, bytes_per_segment);
+        memset((void *)build_ptr(si->number,0), 0xc7, bytes_per_segment);
 #endif
         if ((chunk->nused_segs -= 1) == 0) {
           if (chunk->bytes != (minimum_segment_request + 1) * bytes_per_segment) {
@@ -1609,6 +1609,9 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) {
     }
 
     S_resize_oblist();
+
+    /* tell profile_release_counters to look for bwp'd counters at least through tg */
+    if (S_G.prcgeneration < tg) S_G.prcgeneration = tg;
 }
 
 #define sweep_space(s, body)\
@@ -1891,6 +1894,7 @@ static void sweep_thread(p) ptr p; {
     /* immediate TIMERTICKS */
     /* immediate DISABLE_COUNT */
     /* immediate SIGNALINTERRUPTPENDING */
+    /* void* SIGNALINTERRUPTQUEUE(tc) */
     /* immediate KEYBOARDINTERRUPTPENDING */
     relocate(&THREADNO(tc))
     relocate(&CURRENTINPUT(tc))

c/gcwrapper.c

@@ -33,6 +33,7 @@ void S_gc_init() {
   S_checkheap = 0; /* 0 for disabled, 1 for enabled */
   S_checkheap_errors = 0; /* count of errors detected by checkheap */
   checkheap_noisy = 0; /* 0 for error output only; 1 for more noisy output */
+  S_G.prcgeneration = static_generation;
 
   if (S_checkheap) {
     printf(checkheap_noisy ? "NB: check_heap is enabled and noisy\n" : "NB: check_heap_is_enabled\n");
@@ -274,6 +275,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()
@@ -824,6 +852,9 @@ void S_do_gc(IGEN mcg, IGEN tg) {
       }
     }
 
+   /* tell profile_release_counters to scan only through new_g */
+    if (S_G.prcgeneration == old_g) S_G.prcgeneration = new_g;
+
    /* finally reset max_nonstatic_generation */
     S_G.min_free_gen = S_G.new_min_free_gen;
     S_G.max_nonstatic_generation = new_g;

c/globals.h

@@ -135,6 +135,7 @@ EXTERN struct S_G_struct {
     ptr countof_names;
     ptr gcbackreference[static_generation+1];
     uptr phantom_sizes[static_generation+1];
+    IGEN prcgeneration;
 
   /* intern.c */
     iptr oblist_length;

c/new-io.c

@@ -28,6 +28,7 @@
 #include <fcntl.h>
 #include "zlib.h"
 #include "lz4.h"
+#include "lz4hc.h"
 
 /* !!! UNLESS you enjoy spending endless days tracking down race conditions
    !!! involving the garbage collector, please note: DEACTIVATE and
@@ -814,6 +815,9 @@ uptr S_bytevector_compress_size(iptr s_count, INT compress_format) {
 ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
                           ptr src_bv, iptr s_start, iptr s_count,
                           INT compress_format) {
+  ptr tc = get_thread_context();
+  int compress_level = (INT)UNFIX(COMPRESSLEVEL(tc));
+
   /* On error, an message-template string with ~s for the bytevector */
   switch (compress_format) {
     case COMPRESS_GZIP:
@@ -826,7 +830,7 @@ ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
 
         destLen = (uLong)d_count;
 
-        r = compress(&BVIT(dest_bv, d_start), &destLen, &BVIT(src_bv, s_start), (uLong)s_count);
+        r = compress2(&BVIT(dest_bv, d_start), &destLen, &BVIT(src_bv, s_start), (uLong)s_count, S_zlib_compress_level(compress_level));
 
         if (r == Z_OK)
           return FIX(destLen);
@@ -842,7 +846,11 @@ ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
         if (!is_valid_lz4_length(s_count))
           return Sstring("source bytevector ~s is too large");
 
+        if (compress_level == COMPRESS_MIN) {
           destLen = LZ4_compress_default((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count);
+        } else {
+          destLen = LZ4_compress_HC((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count, S_lz4_compress_level(compress_level));
+        }
 
         if (destLen > 0)
           return Sfixnum(destLen);

c/number.c

@@ -25,9 +25,10 @@
 #include "system.h"
 
 /* locally defined functions */
-static ptr copy_normalize PROTO((bigit *p, iptr len, IBOOL sign, ptr clear_w_tc));
+         static ptr copy_normalize PROTO((ptr tc, const bigit *p, iptr len, IBOOL sign, IBOOL clear_w));
 static IBOOL abs_big_lt PROTO((ptr x, ptr y, iptr xl, iptr yl));
 static IBOOL abs_big_eq PROTO((ptr x, ptr y, iptr xl, iptr yl));
+static ptr big_negate PROTO((ptr tc, ptr x));
 static ptr big_add_pos PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign));
 static ptr big_add_neg PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign));
 static ptr big_add PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys));
@@ -37,7 +38,7 @@ static void big_trunc PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL qs, I
 static INT normalize PROTO((bigit *xp, bigit *yp, iptr xl, iptr yl));
 static bigit quotient_digit PROTO((bigit *xp, bigit *yp, iptr yl));
 static bigit qhat PROTO((bigit *xp, bigit *yp));
-static ptr big_short_gcd PROTO((ptr x, bigit y, iptr xl));
+static ptr big_short_gcd PROTO((ptr tc, ptr x, bigit y, iptr xl));
 static ptr big_gcd PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl));
 static ptr s_big_ash PROTO((ptr tc, bigit *xp, iptr xl, IBOOL sign, iptr cnt));
 static double big_short_floatify PROTO((ptr tc, ptr x, bigit s, iptr xl, IBOOL sign));
@@ -53,27 +54,27 @@ static ptr big_logor PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IB
 static ptr big_logxor PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys));
 
 /* use w/o trailing semicolon */
-#define PREPARE_BIGNUM(x,l)\
+#define PREPARE_BIGNUM(tc,x,l)\
- {if (x == FIX(0) || BIGLEN(x) < (l)) x = S_bignum((l)*2, 0);}
+ {if (x == FIX(0) || BIGLEN(x) < (l)) x = S_bignum(tc, (l)*2, 0);}
 
 #define bigit_mask (~(bigit)0)
 
-#define IBIGIT_TO_BIGNUM(B,x,cnt,sign) {\
+#define IBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) {\
   ibigit _i_ = x;\
-  PREPARE_BIGNUM(B, 1)\
+  PREPARE_BIGNUM(tc, B, 1)\
   *cnt = 1;\
   BIGIT(B,0) = (*sign = (_i_ < 0)) ? -_i_ : _i_;\
 }
 
-#define UBIGIT_TO_BIGNUM(B,u,cnt) {\
+#define UBIGIT_TO_BIGNUM(tc,B,u,cnt) {\
-  PREPARE_BIGNUM(B, 1)\
+  PREPARE_BIGNUM(tc, B, 1)\
   *cnt = 1;\
   BIGIT(B,0) = u;\
 }
 
-#define IBIGITBIGIT_TO_BIGNUM(B,x,cnt,sign) {\
+#define IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) {\
   ibigitbigit _i_ = x; bigitbigit _u_; bigit _b_;\
-  PREPARE_BIGNUM(B, 2)\
+  PREPARE_BIGNUM(tc, B, 2)\
   _u_ = (*sign = (_i_ < 0)) ? -_i_ : _i_;\
   if ((_b_ = (_u_ & (bigitbigit)bigit_mask)) == _u_) {\
     *cnt = 1;\
@@ -85,9 +86,9 @@ static ptr big_logxor PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, I
   }\
 }
 
-#define UBIGITBIGIT_TO_BIGNUM(B,x,cnt) {\
+#define UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt) {\
   bigitbigit _u_ = x; bigit _b_;\
-  PREPARE_BIGNUM(B, 2)\
+  PREPARE_BIGNUM(tc, B, 2)\
   if ((_b_ = (_u_ & (bigitbigit)bigit_mask)) == _u_) {\
     *cnt = 1;\
     BIGIT(B,0) = (bigit)_u_;\
@@ -101,20 +102,20 @@ static ptr big_logxor PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, I
 #define U32_bigits (32 / bigit_bits)
 
 #if (U32_bigits == 1)
-#define I32_TO_BIGNUM(B,x,cnt,sign) IBIGIT_TO_BIGNUM(B,x,cnt,sign)
+#define I32_TO_BIGNUM(tc,B,x,cnt,sign) IBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
-#define U32_TO_BIGNUM(B,x,cnt) UBIGIT_TO_BIGNUM(B,x,cnt)
+#define U32_TO_BIGNUM(tc,B,x,cnt) UBIGIT_TO_BIGNUM(tc,B,x,cnt)
 #endif
 
 #if (U32_bigits == 2)
-#define I32_TO_BIGNUM(B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(B,x,cnt,sign)
+#define I32_TO_BIGNUM(tc,B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
-#define U32_TO_BIGNUM(B,x,cnt) UBIGITBIGIT_TO_BIGNUM(B,x,cnt)
+#define U32_TO_BIGNUM(tc,B,x,cnt) UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt)
 #endif
 
 #define U64_bigits (64 / bigit_bits)
 
 #if (U64_bigits == 2)
-#define I64_TO_BIGNUM(B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(B,x,cnt,sign)
+#define I64_TO_BIGNUM(tc,B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
-#define U64_TO_BIGNUM(B,x,cnt) UBIGITBIGIT_TO_BIGNUM(B,x,cnt)
+#define U64_TO_BIGNUM(tc,B,x,cnt) UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt)
 #endif
 
 #if (U64_bigits == 4)
@@ -124,16 +125,16 @@ see v7.4 number.c for U64_TO_BIGNUM w/U64_bigits == 4
 #define ptr_bigits (ptr_bits / bigit_bits)
 
 #if (ptr_bigits == 1)
-#define IPTR_TO_BIGNUM(B,x,cnt,sign) IBIGIT_TO_BIGNUM(B,x,cnt,sign)
+#define IPTR_TO_BIGNUM(tc,B,x,cnt,sign) IBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
-#define UPTR_TO_BIGNUM(B,x,cnt) UBIGIT_TO_BIGNUM(B,x,cnt)
+#define UPTR_TO_BIGNUM(tc,B,x,cnt) UBIGIT_TO_BIGNUM(tc,B,x,cnt)
 #endif
 
 #if (ptr_bigits == 2)
-#define IPTR_TO_BIGNUM(B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(B,x,cnt,sign)
+#define IPTR_TO_BIGNUM(tc,B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
-#define UPTR_TO_BIGNUM(B,x,cnt) UBIGITBIGIT_TO_BIGNUM(B,x,cnt)
+#define UPTR_TO_BIGNUM(tc,B,x,cnt) UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt)
 #endif
 
-#define FIXNUM_TO_BIGNUM(B,p,cnt,sign) IPTR_TO_BIGNUM(B,UNFIX(p),cnt,sign)
+#define FIXNUM_TO_BIGNUM(tc,B,p,cnt,sign) IPTR_TO_BIGNUM(tc,B,UNFIX(p),cnt,sign)
 
 ptr S_normalize_bignum(ptr x) {
   uptr n = BIGIT(x, 0); iptr len = BIGLEN(x); IBOOL sign = BIGSIGN(x);
@@ -163,7 +164,7 @@ ptr S_normalize_bignum(ptr x) {
   return x;
 }
 
-static ptr copy_normalize(p,len,sign,clear_w_tc) bigit *p; iptr len; IBOOL sign; ptr clear_w_tc; {
+static ptr copy_normalize(tc, p, len, sign, clear_w) ptr tc; const bigit *p; iptr len; IBOOL sign, clear_w; {
   bigit *p1; uptr n; ptr b;
 
   for (;;) {
@@ -196,11 +197,11 @@ static ptr copy_normalize(p,len,sign,clear_w_tc) bigit *p; iptr len; IBOOL sign;
   }
 #endif
 
-  b = S_bignum(len, sign);
+  b = S_bignum(tc, len, sign);
   for (p1 = &BIGIT(b, 0); len--;) *p1++ = *p++;
 
-  if (clear_w_tc)
+  if (clear_w)
-    W(clear_w_tc) = FIX(0);
+    W(tc) = FIX(0);
 
   return b;
 }
@@ -341,7 +342,7 @@ ptr Sunsigned(u) uptr u; { /* convert arg to Scheme integer */
     return FIX(u);
   else {
     ptr x = FIX(0); iptr xl;
-    UPTR_TO_BIGNUM(x, u, &xl)
+    UPTR_TO_BIGNUM(get_thread_context(), x, u, &xl)
     SETBIGLENANDSIGN(x, xl, 0);
     return x;
   }
@@ -352,7 +353,7 @@ ptr Sinteger(i) iptr i; { /* convert arg to Scheme integer */
     return FIX(i);
   else {
     ptr x = FIX(0); iptr xl; IBOOL xs;
-    IPTR_TO_BIGNUM(x, i, &xl, &xs)
+    IPTR_TO_BIGNUM(get_thread_context(), x, i, &xl, &xs)
     SETBIGLENANDSIGN(x, xl, xs);
     return x;
   }
@@ -366,7 +367,7 @@ ptr Sunsigned32(u) U32 u; { /* convert arg to Scheme integer */
     return FIX((uptr)u);
   else {
     ptr x = FIX(0); iptr xl;
-    U32_TO_BIGNUM(x, u, &xl)
+    U32_TO_BIGNUM(get_thread_context(), x, u, &xl)
     SETBIGLENANDSIGN(x, xl, 0);
     return x;
   }
@@ -381,7 +382,7 @@ ptr Sinteger32(i) I32 i; { /* convert arg to Scheme integer */
     return FIX((iptr)i);
   else {
     ptr x = FIX(0); iptr xl; IBOOL xs;
-    I32_TO_BIGNUM(x, i, &xl, &xs)
+    I32_TO_BIGNUM(get_thread_context(), x, i, &xl, &xs)
     SETBIGLENANDSIGN(x, xl, xs);
     return x;
   }
@@ -393,7 +394,7 @@ ptr Sunsigned64(u) U64 u; { /* convert arg to Scheme integer */
     return FIX((uptr)u);
   else {
     ptr x = FIX(0); iptr xl;
-    U64_TO_BIGNUM(x, u, &xl)
+    U64_TO_BIGNUM(get_thread_context(), x, u, &xl)
     SETBIGLENANDSIGN(x, xl, 0);
     return x;
   }
@@ -404,7 +405,7 @@ ptr Sinteger64(i) I64 i; { /* convert arg to Scheme integer */
     return FIX((iptr)i);
   else {
     ptr x = FIX(0); iptr xl; IBOOL xs;
-    I64_TO_BIGNUM(x, i, &xl, &xs)
+    I64_TO_BIGNUM(get_thread_context(), x, i, &xl, &xs)
     SETBIGLENANDSIGN(x, xl, xs);
     return x;
   }
@@ -421,6 +422,11 @@ ptr Sinteger64(i) I64 i; { /* convert arg to Scheme integer */
   *(x) = _b_>>_n_ | *(k);\
   *(k) = _newk_;}
 
+#define ERSH2(n,x,y,k) { /* undefined when n == 0 */\
+  INT _n_ = (INT)(n); bigit _b_ = (x), _newk_ = _b_<<(bigit_bits-_n_);\
+  *(y) = _b_>>_n_ | *(k);\
+  *(k) = _newk_;}
+
 #define EADDC(a1, a2, sum, k) {\
   bigit _tmp1_, _tmp2_, _tmpk_;\
   _tmp1_ = (a1);\
@@ -509,13 +515,21 @@ addition/subtraction
 ***
 */
 
+static ptr big_negate(tc, x) ptr tc, x; {
+  return copy_normalize(tc, &BIGIT(x,0),BIGLEN(x),!BIGSIGN(x),0);
+}
+
+ptr S_big_negate(x) ptr x; {
+  return big_negate(get_thread_context(), x);
+}
+
 /* assumptions: BIGLEN(x) >= BIGLEN(y) */
 static ptr big_add_pos(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL sign; {
   iptr i;
   bigit *xp, *yp, *zp;
   bigit k = 0;
 
-  PREPARE_BIGNUM(W(tc),xl+1)
+  PREPARE_BIGNUM(tc, W(tc),xl+1)
 
   xp = &BIGIT(x,xl-1); yp = &BIGIT(y,yl-1); zp = &BIGIT(W(tc),xl);
 
@@ -528,7 +542,7 @@ static ptr big_add_pos(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL
 
   *zp = k;
 
-  return copy_normalize(zp,xl+1,sign,tc);
+  return copy_normalize(tc, zp,xl+1,sign, 1);
 }
 
 /* assumptions: x >= y */
@@ -537,7 +551,7 @@ static ptr big_add_neg(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL
   bigit *xp, *yp, *zp;
   bigit b = 0;
 
-  PREPARE_BIGNUM(W(tc),xl)
+  PREPARE_BIGNUM(tc, W(tc),xl)
 
   xp = &BIGIT(x,xl-1); yp = &BIGIT(y,yl-1); zp = &BIGIT(W(tc),xl-1);
 
@@ -548,7 +562,7 @@ static ptr big_add_neg(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL
   for (; i-- > 0; )
     *zp-- = *xp--;
 
-  return copy_normalize(zp+1,xl,sign,tc);
+  return copy_normalize(tc, zp+1,xl,sign, 1);
 }
 
 static ptr big_add(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL xs, ys; {
@@ -574,13 +588,13 @@ ptr S_add(x, y) ptr x, y; {
       return FIXRANGE(n) ? FIX(n) : Sinteger(n);
     } else {
       iptr xl; IBOOL xs;
-      FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
+      FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
       return big_add(tc, X(tc), y, xl, BIGLEN(y), xs, BIGSIGN(y));
     }
   } else {
     if (Sfixnump(y)) {
       iptr yl; IBOOL ys;
-      FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
+      FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
       return big_add(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
     } else {
       return big_add(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), BIGSIGN(y));
@@ -598,13 +612,13 @@ ptr S_sub(x, y) ptr x, y; {
       return FIXRANGE(n) ? FIX(n) : Sinteger(n);
     } else {
       iptr xl; IBOOL xs;
-      FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
+      FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
       return big_add(tc, X(tc), y, xl, BIGLEN(y), xs, !BIGSIGN(y));
     }
   } else {
     if (Sfixnump(y)) {
       iptr yl; IBOOL ys;
-      FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
+      FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
       return big_add(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), !ys);
     } else {
       return big_add(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), !BIGSIGN(y));
@@ -623,7 +637,7 @@ static ptr big_mul(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL sign
   bigit *xp, *yp, *zp, *zpa;
   bigit k, k1, prod;
 
-  PREPARE_BIGNUM(W(tc),xl+yl)
+  PREPARE_BIGNUM(tc, W(tc),xl+yl)
   for (xi = xl, zp = &BIGIT(W(tc),xl+yl-1); xi-- > 0; ) *zp-- = 0;
 
   for (yi=yl,yp= &BIGIT(y,yl-1),zp= &BIGIT(W(tc),xl+yl-1); yi-- > 0; yp--, zp--)
@@ -638,7 +652,7 @@ static ptr big_mul(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL sign
       *zpa = k;
     }
 
-  return copy_normalize(&BIGIT(W(tc),0),xl+yl,sign,tc);
+  return copy_normalize(tc, &BIGIT(W(tc),0),xl+yl,sign, 1);
 }
 
 /* SHORTRANGE is -floor(sqrt(most_positive_fixnum))..floor(sqrt(most_positive_fixnum)).
@@ -661,17 +675,17 @@ ptr S_mul(x, y) ptr x, y; {
       if (SHORTRANGE(xn) && SHORTRANGE(yn))
         return FIX(xn * yn);
       else {
-        FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs) x = X(tc);
+        FIXNUM_TO_BIGNUM(tc, X(tc),x,&xl,&xs) x = X(tc);
-        FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys) y = Y(tc);
+        FIXNUM_TO_BIGNUM(tc, Y(tc),y,&yl,&ys) y = Y(tc);
       }
     } else {
-      FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs) x = X(tc);
+      FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs) x = X(tc);
       yl = BIGLEN(y); ys = BIGSIGN(y);
     }
   } else {
     if (Sfixnump(y)) {
       xl = BIGLEN(x); xs = BIGSIGN(x);
-      FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys) y = Y(tc);
+      FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys) y = Y(tc);
     } else {
       xl = BIGLEN(x); xs = BIGSIGN(x);
       yl = BIGLEN(y); ys = BIGSIGN(y);
@@ -688,29 +702,34 @@ division
 
 /* arguments must be integers (fixnums or bignums), y must be nonzero */
 ptr S_div(x, y) ptr x, y; {
-  ptr g;
+  ptr g, n, d;
+  ptr tc = get_thread_context();
 
   g = S_gcd(x,y);
-  if (Sfixnump(y) ? UNFIX(y) < 0 : BIGSIGN(y)) g = S_sub(FIX(0),g);
+  if (Sfixnump(y) ? UNFIX(y) < 0 : BIGSIGN(y)) {
-  return S_rational(S_trunc(x,g), S_trunc(y,g));
+    g = Sfixnump(g) ? Sinteger(-UNFIX(g)) : big_negate(tc, g);
+  }
+
+  S_trunc_rem(tc, x, g, &n, (ptr *)NULL);
+  S_trunc_rem(tc, y, g, &d, (ptr *)NULL);
+
+  return S_rational(n, d);
 }
 
 ptr S_trunc(x, y) ptr x, y; {
   ptr q;
-  S_trunc_rem(x, y, &q, (ptr *)NULL);
+  S_trunc_rem(get_thread_context(), x, y, &q, (ptr *)NULL);
   return q;
 }
 
 ptr S_rem(x, y) ptr x, y; {
   ptr r;
-  S_trunc_rem(x, y, (ptr *)NULL, &r);
+  S_trunc_rem(get_thread_context(), x, y, (ptr *)NULL, &r);
   return r;
 }
 
 /* arguments must be integers (fixnums or bignums), y must be nonzero */
-void S_trunc_rem(origx, y, q, r) ptr origx, y, *q, *r; {
+void S_trunc_rem(tc, origx, y, q, r) ptr tc, origx, y, *q, *r; {
-  ptr tc = get_thread_context();
-
   iptr xl, yl; IBOOL xs, ys; ptr x = origx;
 
   if (Sfixnump(x)) {
@@ -726,13 +745,13 @@ void S_trunc_rem(origx, y, q, r) ptr origx, y, *q, *r; {
         return;
       }
     } else {
-      FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs) x = X(tc);
+      FIXNUM_TO_BIGNUM(tc, X(tc),x,&xl,&xs) x = X(tc);
       yl = BIGLEN(y); ys = BIGSIGN(y);
     }
   } else {
     if (Sfixnump(y)) {
       xl = BIGLEN(x); xs = BIGSIGN(x);
-      FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys) y = Y(tc);
+      FIXNUM_TO_BIGNUM(tc, Y(tc),y,&yl,&ys) y = Y(tc);
     } else {
       xl = BIGLEN(x); xs = BIGSIGN(x);
       yl = BIGLEN(y); ys = BIGSIGN(y);
@@ -754,13 +773,13 @@ static void big_short_trunc(ptr tc, ptr x, bigit s, iptr xl, IBOOL qs, IBOOL rs,
   bigit *xp, *zp;
   bigit k;
 
-  PREPARE_BIGNUM(W(tc),xl)
+  PREPARE_BIGNUM(tc, W(tc),xl)
 
   for (i = xl, k = 0, xp = &BIGIT(x,0), zp = &BIGIT(W(tc),0); i-- > 0; )
     EDIV(k, *xp++, s, zp++, &k)
 
-  if (q != (ptr *)NULL) *q = copy_normalize(&BIGIT(W(tc),0),xl,qs,0);
+  if (q != (ptr *)NULL) *q = copy_normalize(tc, &BIGIT(W(tc),0),xl,qs, 0);
-  if (r != (ptr *)NULL) *r = copy_normalize(&k,1,rs,0);
+  if (r != (ptr *)NULL) *r = copy_normalize(tc, &k,1,rs, 0);
 
   W(tc) = FIX(0);
 }
@@ -773,11 +792,11 @@ static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
   INT d;
   bigit k;
 
-  PREPARE_BIGNUM(U(tc), xl+1)
+  PREPARE_BIGNUM(tc, U(tc), xl+1)
   for (i = xl, xp = &BIGIT(U(tc),xl+1), p = &BIGIT(x,xl); i-- > 0;) *--xp = *--p;
   *--xp = 0;
 
-  PREPARE_BIGNUM(V(tc), yl)
+  PREPARE_BIGNUM(tc, V(tc), yl)
   for (i = yl, yp = &BIGIT(V(tc),yl), p = &BIGIT(y,yl); i-- > 0;) *--yp = *--p;
 
   d = normalize(xp, yp, xl, yl);
@@ -785,10 +804,10 @@ static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
   if (q == (ptr *)NULL) {
     for (i = m; i-- > 0 ; xp++) (void) quotient_digit(xp, yp, yl);
   } else {
-    PREPARE_BIGNUM(W(tc),m)
+    PREPARE_BIGNUM(tc, W(tc),m)
     p = &BIGIT(W(tc),0);
     for (i = m; i-- > 0 ; xp++) *p++ = quotient_digit(xp, yp, yl);
-    *q = copy_normalize(&BIGIT(W(tc),0),m,qs,tc);
+    *q = copy_normalize(tc, &BIGIT(W(tc),0),m,qs, 1);
   }
 
   if (r != (ptr *)NULL) {
@@ -796,7 +815,7 @@ static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
     if (d != 0) {
       for (i = yl, p = xp, k = 0; i-- > 0; p++) ERSH(d,p,&k)
     }
-    *r = copy_normalize(xp, yl, rs, 0);
+    *r = copy_normalize(tc, xp, yl, rs, 0);
   }
 
   U(tc) = FIX(0);
@@ -883,12 +902,12 @@ static ptr uptr_gcd(x, y) uptr x, y; {
 }
 
 /* sparc C compiler barfs w/o full declaration */
-static ptr big_short_gcd(ptr x, bigit y, iptr xl) {
+static ptr big_short_gcd(ptr tc, ptr x, bigit y, iptr xl) {
   bigit *xp;
   iptr i;
   bigit r, q;
 
-  if (y == 0) return BIGSIGN(x) ? S_sub(FIX(0),x) : x;
+  if (y == 0) return BIGSIGN(x) ? big_negate(tc, x) : x;
 
   for (i = xl, r = 0, xp = &BIGIT(x,0); i-- > 0; )
     EDIV(r, *xp++, y, &q, &r)
@@ -903,13 +922,13 @@ static ptr big_gcd(tc, x, y, xl, yl) ptr tc, x, y; iptr xl, yl; {
   ptr ret;
 
  /* Copy x to scratch bignum, with a leading zero */
-  PREPARE_BIGNUM(U(tc),xl+1)
+  PREPARE_BIGNUM(tc, U(tc),xl+1)
   xp = &BIGIT(U(tc),xl+1);
   for (i = xl, p = &BIGIT(x,xl); i-- > 0; ) *--xp = *--p;
   *--xp = 0;                /* leave xp pointing at leading 0-bigit */
 
  /* Copy y to scratch bignum, with a leading zero */
-  PREPARE_BIGNUM(V(tc),yl+1)
+  PREPARE_BIGNUM(tc, V(tc),yl+1)
   yp = &BIGIT(V(tc),yl+1);
   for (i = yl, p = &BIGIT(y,yl); i-- > 0; ) *--yp = *--p;
   *(yp-1) = 0;        /* leave yp pointing just after leading 0-bigit */
@@ -963,7 +982,7 @@ static ptr big_gcd(tc, x, y, xl, yl) ptr tc, x, y; iptr xl, yl; {
     if (asc != 0) {
       for (i = xl, p = xp, k = 0; i-- > 0; p++) ERSH(asc,p,&k)
     }
-    ret = copy_normalize(xp,xl,0,0);
+    return copy_normalize(tc, xp,xl,0, 0);
   } else {
     bigit d, r;
 
@@ -991,13 +1010,13 @@ ptr S_gcd(x, y) ptr x, y; {
                uptr_gcd((uptr)xi, (uptr)yi) :
                uptr_gcd((uptr)yi, (uptr)xi);
     } else {
-      FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs) x = X(tc);
+      FIXNUM_TO_BIGNUM(tc, X(tc),x,&xl,&xs) x = X(tc);
       yl = BIGLEN(y); ys = BIGSIGN(y);
     }
   else
     if (Sfixnump(y)) {
       xl = BIGLEN(x); xs = BIGSIGN(x);
-      FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys) y = Y(tc);
+      FIXNUM_TO_BIGNUM(tc, Y(tc),y,&yl,&ys) y = Y(tc);
     } else {
       xl = BIGLEN(x); xs = BIGSIGN(x);
       yl = BIGLEN(y); ys = BIGSIGN(y);
@@ -1008,10 +1027,10 @@ ptr S_gcd(x, y) ptr x, y; {
       uptr xu = BIGIT(x,0), yu = BIGIT(y,0);
       return xu >= yu ? uptr_gcd(xu, yu) : uptr_gcd(yu, xu);
     } else
-      return big_short_gcd(y, BIGIT(x,0), yl);
+      return big_short_gcd(tc, y, BIGIT(x,0), yl);
   else
     if (yl == 1)
-      return big_short_gcd(x, BIGIT(y,0), xl);
+      return big_short_gcd(tc, x, BIGIT(y,0), xl);
     else
       if (abs_big_lt(x, y, xl, yl))
         return big_gcd(tc, y, x, yl, xl);
@@ -1082,7 +1101,7 @@ static double big_short_floatify(ptr tc, ptr x, bigit s, iptr xl, IBOOL sign) {
   bigit *xp, *zp, k;
   double ret;
 
-  PREPARE_BIGNUM(W(tc),enough+1)
+  PREPARE_BIGNUM(tc, W(tc),enough+1)
 
  /* compute only as much of quotient as we need */
   for (i = 0, k = 0, xp = &BIGIT(x,0), zp = &BIGIT(W(tc),0); i < enough; i++)
@@ -1108,18 +1127,18 @@ static double big_floatify(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IB
 
  /* copy x to U(tc), scaling with added zero bigits as necessary */
   ul = xl < yl + enough-1 ? yl + enough-1 : xl;
-  PREPARE_BIGNUM(U(tc), ul+1)
+  PREPARE_BIGNUM(tc, U(tc), ul+1)
   for (i = ul - xl, xp = &BIGIT(U(tc),ul+1); i-- > 0;) *--xp = 0;
   for (i = xl, p = &BIGIT(x,xl); i-- > 0;) *--xp = *--p;
   *--xp = 0;
 
  /* copy y to V(tc) */
-  PREPARE_BIGNUM(V(tc), yl)
+  PREPARE_BIGNUM(tc, V(tc), yl)
   for (i = yl, yp = &BIGIT(V(tc),yl), p = &BIGIT(y,yl); i-- > 0;) *--yp = *--p;
 
   (void) normalize(xp, yp, ul, yl);
 
-  PREPARE_BIGNUM(W(tc),4)
+  PREPARE_BIGNUM(tc, W(tc),4)
   p = &BIGIT(W(tc),0);
 
  /* compute 'enough' bigits of the quotient */
@@ -1229,7 +1248,7 @@ static double floatify_ratnum(tc, p) ptr tc, p; {
 
  /* make sure we are dealing with bignums */
   if (Sfixnump(x)) {
-    FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
+    FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
     x = X(tc);
   } else {
     xl = BIGLEN(x);
@@ -1238,7 +1257,7 @@ static double floatify_ratnum(tc, p) ptr tc, p; {
 
   if (Sfixnump(y)) {
     IBOOL ys;
-    FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
+    FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
     y = Y(tc);
   } else {
     yl = BIGLEN(y);
@@ -1291,7 +1310,7 @@ ptr S_decode_float(d) double d; {
   else {
     iptr xl;
     x = FIX(0);
-    U64_TO_BIGNUM(x, m, &xl)
+    U64_TO_BIGNUM(get_thread_context(), x, m, &xl)
     SETBIGLENANDSIGN(x, xl, 0);
   }
 
@@ -1315,39 +1334,47 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si
   bigit *p1, *p2, k;
 
   if (cnt < 0) { /* shift to the right */
-    INT bit_bucket = 0;
+    iptr whole_bigits;
    
-    cnt = -cnt;
+    /* decrement length to shift by whole bigits */
+    if ((xl -= (whole_bigits = (cnt = -cnt) / bigit_bits)) <= 0) return sign ? FIX(-1) : FIX(0);
+    cnt -= whole_bigits * bigit_bits;
 
-   /* shift by whole bigits by decrementing length */
+    /* shift by remaining count to scratch bignum, tracking bits shifted off to the right */
-    while (cnt >= bigit_bits) {
+    PREPARE_BIGNUM(tc, W(tc),xl)
-      xl -= 1;
+    p1 = &BIGIT(W(tc), 0);
-      if (xl == 0) return sign ? FIX(-1) : FIX(0);
+    p2 = xp;
-      cnt -= bigit_bits;
-      bit_bucket |= *(xp + xl);
-    }
-
-   /* copy to scratch bignum */
-    PREPARE_BIGNUM(W(tc),xl)
-    p1 = &BIGIT(W(tc), xl);
-    for (i = xl, p2 = xp + xl; i-- > 0; ) *--p1 = *--p2;
-
-   /* shift by remaining count */
     k = 0;
-    if (cnt != 0) {
+    i = xl;
-      for (i = xl; i-- > 0; p1++) ERSH(cnt,p1,&k)
+    if (cnt == 0) {
+      do { *p1++ = *p2++; } while (--i > 0);
+    } else {
+      do { ERSH2(cnt,*p2,p1,&k); p1++; p2++; } while (--i > 0);
+    }
+
+    if (sign) {
+      if (k == 0) {
+        /* check for one bits in the shifted-off bigits, looking */
+        /* from both ends in an attempt to get out more quickly for what */
+        /* seem like the most likely patterns.  of course, there might */
+        /* be no one bits (in which case this won't help) or they might be */
+        /* only in the middle (in which case this will be slower) */
+        p2 = (p1 = xp + xl) + whole_bigits;
+        while (p1 != p2) {
+          if ((k = *p1++) || p1 == p2 || (k = *--p2)) break;
+        }
       }
-    bit_bucket |= k;
 
       /* round down negative numbers by incrementing the magnitude if any
-      one bits dropped into the bit bucket */
+         one bits were shifted off to the right */
-    if (sign && bit_bucket) {
+      if (k) {
         p1 = &BIGIT(W(tc), xl - 1);
         for (i = xl, k = 1; k != 0 && i-- > 0; p1 -= 1)
           EADDC(0, *p1, p1, &k)
       }
+    }
 
-    return copy_normalize(&BIGIT(W(tc), 0), xl, sign, tc);
+    return copy_normalize(tc, &BIGIT(W(tc), 0), xl, sign, 1);
   } else { /* shift to the left */
     iptr xlplus, newxl;
 
@@ -1361,7 +1388,7 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si
    /* maximum total length includes +1 for shift out of top bigit */
     newxl = xl + xlplus + 1;
 
-    PREPARE_BIGNUM(W(tc),newxl)
+    PREPARE_BIGNUM(tc, W(tc),newxl)
 
    /* fill bigits to right with zero */
     for (i = xlplus, p1 = &BIGIT(W(tc), newxl); i-- > 0; ) *--p1 = 0;
@@ -1373,7 +1400,7 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si
     }
     *--p1 = k;
 
-    return copy_normalize(p1, newxl, sign, tc);
+    return copy_normalize(tc, p1, newxl, sign, 1);
   }
 }
 
@@ -1388,7 +1415,7 @@ ptr S_ash(x, n) ptr x, n; {
       do much here anyway since semantics of signed >> are undefined in C */
     iptr xl; IBOOL xs;
 
-    FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs);
+    FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs);
     return s_big_ash(tc, &BIGIT(X(tc),0), xl, xs, cnt);
   } else
     return s_big_ash(tc, &BIGIT(x,0), BIGLEN(x), BIGSIGN(x), cnt);
@@ -1456,7 +1483,7 @@ ptr S_big_positive_bit_field(ptr x, ptr fxstart, ptr fxend) {
   }
 
  /* copy to scratch bignum */
-  PREPARE_BIGNUM(W(tc),wl)
+  PREPARE_BIGNUM(tc, W(tc),wl)
   p1 = &BIGIT(W(tc), wl);
   for (i = wl, p2 = xp + xl; i-- > 0; ) *--p1 = *--p2;
 
@@ -1469,7 +1496,7 @@ ptr S_big_positive_bit_field(ptr x, ptr fxstart, ptr fxend) {
     for (i = wl; i > 0; i -= 1, p1 += 1) ERSH(start,p1,&k)
   }
 
-  return copy_normalize(&BIGIT(W(tc), 0), wl, 0, tc);
+  return copy_normalize(tc, &BIGIT(W(tc), 0), wl, 0, 1);
 }
 
 /* logical operations simulate two's complement operations using the
@@ -1497,13 +1524,13 @@ ptr S_logand(x, y) ptr x, y; {
       return (ptr)((iptr)x & (iptr)y);
     } else {
       iptr xl; IBOOL xs;
-      FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
+      FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
       return big_logand(tc, y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs);
     }
   } else {
     if (Sfixnump(y)) {
       iptr yl; IBOOL ys;
-      FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
+      FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
       return big_logand(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
     } else {
       if (BIGLEN(x) >= BIGLEN(y))
@@ -1532,14 +1559,14 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
 
   if (xs == 0) {
     if (ys == 0) {
-      PREPARE_BIGNUM(W(tc),yl);
+      PREPARE_BIGNUM(tc, W(tc),yl);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl);
       for (i = yl; i > 0; i -= 1) *--zp = *--xp & *--yp;
-      return copy_normalize(zp, yl, 0, tc);
+      return copy_normalize(tc, zp, yl, 0, 1);
     } else {
       bigit yb;
 
-      PREPARE_BIGNUM(W(tc),xl);
+      PREPARE_BIGNUM(tc, W(tc),xl);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
       yb = 1;
       for (i = yl; i > 0; i -= 1) {
@@ -1550,13 +1577,13 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
      /* yb must be 0, since high-order bigit >= 1.  effectively, this
         means ~t2 would be all 1's from here on out. */
       for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
-      return copy_normalize(zp, xl, 0, tc);
+      return copy_normalize(tc, zp, xl, 0, 1);
     }
   } else {
     if (ys == 0) {
       bigit xb;
 
-      PREPARE_BIGNUM(W(tc),yl);
+      PREPARE_BIGNUM(tc, W(tc),yl);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl);
       xb = 1;
       for (i = yl; i > 0; i -= 1) {
@@ -1564,11 +1591,11 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         xb = t2 > t1;
         *--zp = *--yp & ~t2;
       }
-      return copy_normalize(zp, yl, 0, tc);
+      return copy_normalize(tc, zp, yl, 0, 1);
     } else {
       bigit xb, yb, k;
 
-      PREPARE_BIGNUM(W(tc),xl+1);
+      PREPARE_BIGNUM(tc, W(tc),xl+1);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1);
       k = yb = xb = 1;
       for (i = yl; i > 0; i -= 1) {
@@ -1587,7 +1614,8 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         *--zp = z2;
       }
       *--zp = k;
-      return copy_normalize(zp, xl+1, 1, tc);
+
+      return copy_normalize(tc, zp, xl+1, 1, 1);
     }
   }
 }
@@ -1602,13 +1630,13 @@ ptr S_logtest(x, y) ptr x, y; {
       return Sboolean((iptr)x & (iptr)y);
     } else {
       iptr xl; IBOOL xs;
-      FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
+      FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
       return big_logtest(y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs);
     }
   } else {
     if (Sfixnump(y)) {
       iptr yl; IBOOL ys;
-      FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
+      FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
       return big_logtest(x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
     } else {
       if (BIGLEN(x) >= BIGLEN(y))
@@ -1726,7 +1754,7 @@ ptr S_logbit0(k, x) ptr k, x; {
     } else {
       iptr xl; IBOOL xs;
 
-      FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs);
+      FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs);
       return big_logbit0(tc, x, n, X(tc), xl, xs);
     }
   } else {
@@ -1753,7 +1781,7 @@ static ptr big_logbit0(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
      /* we'd just be clearing a bit that's already (virtually) cleared */
       return origx;
     } else {
-      PREPARE_BIGNUM(W(tc),xl);
+      PREPARE_BIGNUM(tc, W(tc),xl);
       xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),xl);
       for (;;) {
         if (n < bigit_bits) break;
@@ -1762,13 +1790,13 @@ static ptr big_logbit0(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
       }
       *--zp = *--xp & ~(1 << n);
       for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
-      return copy_normalize(zp,xl,0, tc);
+      return copy_normalize(tc, zp,xl,0, 1);
     }
   } else {
     bigit xb, k, x1, x2, z1, z2;
     iptr zl = (yl > xl ? yl : xl) + 1;
 
-    PREPARE_BIGNUM(W(tc),zl);
+    PREPARE_BIGNUM(tc, W(tc),zl);
     xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),zl);
     k = xb = 1;
     i = xl;
@@ -1788,7 +1816,7 @@ static ptr big_logbit0(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
       *--zp = z2;
     }
     *--zp = k;
-    return copy_normalize(zp, zl, 1, tc);
+    return copy_normalize(tc, zp, zl, 1, 1);
   }
 }
 
@@ -1803,7 +1831,7 @@ ptr S_logbit1(k, x) ptr k, x; {
     } else {
       iptr xl; IBOOL xs;
 
-      FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs);
+      FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs);
       return big_logbit1(tc, x, n, X(tc), xl, xs);
     }
   } else {
@@ -1821,7 +1849,7 @@ static ptr big_logbit1(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
     bigit x1;
     iptr zl = yl > xl ? yl : xl;
 
-    PREPARE_BIGNUM(W(tc),zl);
+    PREPARE_BIGNUM(tc, W(tc),zl);
     xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),zl);
 
     i = xl;
@@ -1833,7 +1861,7 @@ static ptr big_logbit1(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
     }
     *--zp = x1 | ((U32)1 << n);
     for (; i > 0; i -= 1) *--zp = *--xp;
-    return copy_normalize(zp, zl, 0, tc);
+    return copy_normalize(tc, zp, zl, 0, 1);
   } else if (yl > xl) {
    /* we'd just be setting a bit that's already (virtually) set */
     return origx;
@@ -1841,7 +1869,7 @@ static ptr big_logbit1(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
     bigit xb, k, x1, x2, z1, z2;
     iptr zl = xl + 1;
 
-    PREPARE_BIGNUM(W(tc),zl);
+    PREPARE_BIGNUM(tc, W(tc),zl);
     xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),zl);
     k = xb = 1;
     for (;;) {
@@ -1862,7 +1890,7 @@ static ptr big_logbit1(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
       *--zp = z2;
     }
     *--zp = k;
-    return copy_normalize(zp, zl, 1, tc);
+    return copy_normalize(tc, zp, zl, 1, 1);
   }
 }
 
@@ -1874,13 +1902,13 @@ ptr S_logor(x, y) ptr x, y; {
       return (ptr)((iptr)x | (iptr)(y));
     } else {
       iptr xl; IBOOL xs;
-      FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
+      FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
       return big_logor(tc, y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs);
     }
   } else {
     if (Sfixnump(y)) {
       iptr yl; IBOOL ys;
-      FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
+      FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
       return big_logor(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
     } else {
       if (BIGLEN(x) >= BIGLEN(y))
@@ -1909,15 +1937,15 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
 
   if (xs == 0) {
     if (ys == 0) {
-      PREPARE_BIGNUM(W(tc),xl);
+      PREPARE_BIGNUM(tc, W(tc),xl);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
       for (i = yl; i > 0; i -= 1) *--zp = *--xp | *--yp;
       for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
-      return copy_normalize(zp, xl, 0, tc);
+      return copy_normalize(tc, zp, xl, 0, 1);
     } else {
       bigit yb, k;
 
-      PREPARE_BIGNUM(W(tc),yl+1);
+      PREPARE_BIGNUM(tc, W(tc),yl+1);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl+1);
       k = yb = 1;
       for (i = yl; i > 0; i -= 1) {
@@ -1928,13 +1956,13 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         *--zp = z2;
       }
       *--zp = k;
-      return copy_normalize(zp, yl+1, 1, tc);
+      return copy_normalize(tc, zp, yl+1, 1, 1);
     }
   } else {
     if (ys == 0) {
       bigit xb, k;
 
-      PREPARE_BIGNUM(W(tc),xl+1);
+      PREPARE_BIGNUM(tc, W(tc),xl+1);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1);
       k = xb = 1;
       for (i = yl; i > 0; i -= 1) {
@@ -1952,11 +1980,11 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         *--zp = z2;
       }
       *--zp = k;
-      return copy_normalize(zp, xl+1, 1, tc);
+      return copy_normalize(tc, zp, xl+1, 1, 1);
     } else {
       bigit xb, yb, k;
 
-      PREPARE_BIGNUM(W(tc),yl+1);
+      PREPARE_BIGNUM(tc, W(tc),yl+1);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl+1);
       k = yb = xb = 1;
       for (i = yl; i > 0; i -= 1) {
@@ -1968,7 +1996,7 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         *--zp = z2;
       }
       *--zp = k;
-      return copy_normalize(zp, yl+1, 1, tc);
+      return copy_normalize(tc, zp, yl+1, 1, 1);
     }
   }
 }
@@ -1981,13 +2009,13 @@ ptr S_logxor(x, y) ptr x, y; {
       return (ptr)((iptr)x ^ (iptr)(y));
     } else {
       iptr xl; IBOOL xs;
-      FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
+      FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
       return big_logxor(tc, y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs);
     }
   } else {
     if (Sfixnump(y)) {
       iptr yl; IBOOL ys;
-      FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
+      FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
       return big_logxor(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
     } else {
       if (BIGLEN(x) >= BIGLEN(y))
@@ -2016,15 +2044,15 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
 
   if (xs == 0) {
     if (ys == 0) {
-      PREPARE_BIGNUM(W(tc),xl);
+      PREPARE_BIGNUM(tc, W(tc),xl);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
       for (i = yl; i > 0; i -= 1) *--zp = *--xp ^ *--yp;
       for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
-      return copy_normalize(zp, xl, 0, tc);
+      return copy_normalize(tc, zp, xl, 0, 1);
     } else {
       bigit yb, k;
 
-      PREPARE_BIGNUM(W(tc),xl+1);
+      PREPARE_BIGNUM(tc, W(tc),xl+1);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1);
       k = yb = 1;
       for (i = yl; i > 0; i -= 1) {
@@ -2041,13 +2069,13 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         *--zp = z2;
       }
       *--zp = k;
-      return copy_normalize(zp, xl+1, 1, tc);
+      return copy_normalize(tc, zp, xl+1, 1, 1);
     }
   } else {
     if (ys == 0) {
       bigit xb, k;
 
-      PREPARE_BIGNUM(W(tc),xl+1);
+      PREPARE_BIGNUM(tc, W(tc),xl+1);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1);
       k = xb = 1;
       for (i = yl; i > 0; i -= 1) {
@@ -2065,11 +2093,11 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         *--zp = z2;
       }
       *--zp = k;
-      return copy_normalize(zp, xl+1, 1, tc);
+      return copy_normalize(tc, zp, xl+1, 1, 1);
     } else {
       bigit xb, yb;
 
-      PREPARE_BIGNUM(W(tc),xl);
+      PREPARE_BIGNUM(tc, W(tc),xl);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
       yb = xb = 1;
       for (i = yl; i > 0; i -= 1) {
@@ -2083,7 +2111,7 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
         *--zp = x2;
       }
-      return copy_normalize(zp, xl, 0, tc);
+      return copy_normalize(tc, zp, xl, 0, 1);
     }
   }
 }

c/prim.c

@@ -190,6 +190,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);
     Sforeign_symbol("(cs)enable_object_backreferences", (void *)S_enable_object_backreferences);
     Sforeign_symbol("(cs)set_enable_object_backreferences", (void *)S_set_enable_object_backreferences);

c/prim5.c

@@ -116,7 +116,7 @@ static ptr s_multibytetowidechar PROTO((unsigned cp, ptr inbv));
 static ptr s_widechartomultibyte PROTO((unsigned cp, ptr inbv));
 #endif
 static ptr s_profile_counters PROTO((void));
-static void s_set_profile_counters PROTO((ptr counters));
+static ptr s_profile_release_counters PROTO((void));
 
 #define require(test,who,msg,arg) if (!(test)) S_error1(who, msg, arg)
 
@@ -166,7 +166,7 @@ static iptr s_fxdiv(x, y) iptr x, y; {
 
 static ptr s_trunc_rem(x, y) ptr x, y; {
   ptr q, r;
-  S_trunc_rem(x, y, &q, &r);
+  S_trunc_rem(get_thread_context(), x, y, &q, &r);
   return Scons(q, r);
 }
 
@@ -1467,8 +1467,25 @@ static ptr s_profile_counters(void) {
   return S_G.profile_counters;
 }
 
-static void s_set_profile_counters(ptr counters) {
+/* s_profile_release_counters assumes and maintains the property that each pair's
-  S_G.profile_counters = counters;
+   tail is not younger than the pair and thereby avoids dirty sets. */
+static ptr s_profile_release_counters(void) {
+  ptr tossed, *p_keep, *p_toss, ls;
+  p_keep = &S_G.profile_counters;
+  p_toss = &tossed;
+  for (ls = *p_keep; ls != Snil && (MaybeSegInfo(ptr_get_segment(ls)))->generation <= S_G.prcgeneration; ls = Scdr(ls)) {
+    if (Sbwp_objectp(CAAR(ls))) {
+      *p_toss = ls;
+      p_toss = &Scdr(ls);
+    } else {
+      *p_keep = ls;
+      p_keep = &Scdr(ls);
+    }
+  }
+  *p_keep = ls;
+  *p_toss = Snil;
+  S_G.prcgeneration = 0;
+  return tossed;
 }
 
 void S_dump_tc(ptr tc) {
@@ -1606,6 +1623,7 @@ void S_prim5_init() {
     Sforeign_symbol("(cs)lognot", (void *)S_lognot);
     Sforeign_symbol("(cs)fxmul", (void *)s_fxmul);
     Sforeign_symbol("(cs)fxdiv", (void *)s_fxdiv);
+    Sforeign_symbol("(cs)s_big_negate", (void *)S_big_negate);
     Sforeign_symbol("(cs)add", (void *)S_add);
     Sforeign_symbol("(cs)gcd", (void *)S_gcd);
     Sforeign_symbol("(cs)mul", (void *)S_mul);
@@ -1641,6 +1659,7 @@ void S_prim5_init() {
 #else
     Sforeign_symbol("(cs)directory_list", (void *)S_directory_list);
 #endif
+    Sforeign_symbol("(cs)dequeue_scheme_signals", (void *)S_dequeue_scheme_signals);
     Sforeign_symbol("(cs)register_scheme_signal", (void *)S_register_scheme_signal);
 
     Sforeign_symbol("(cs)exp", (void *)s_exp);
@@ -1701,7 +1720,7 @@ void S_prim5_init() {
     Sforeign_symbol("(cs)s_widechartomultibyte", (void *)s_widechartomultibyte);
 #endif
     Sforeign_symbol("(cs)s_profile_counters", (void *)s_profile_counters);
-    Sforeign_symbol("(cs)s_set_profile_counters", (void *)s_set_profile_counters);
+    Sforeign_symbol("(cs)s_profile_release_counters", (void *)s_profile_release_counters);
 }
 
 static ptr s_get_reloc(co, with_offsets) ptr co; IBOOL with_offsets; {

c/print.c

@@ -287,7 +287,7 @@ static void pbignum(x) ptr x; {
 static void wrint(x) ptr x; {
   ptr q, r;
 
-  S_trunc_rem(x, FIX(10), &q, &r);
+  S_trunc_rem(get_thread_context(), x, FIX(10), &q, &r);
   if (q != 0) wrint(q);
   putchar((INT)UNFIX(r) + '0');
 }

c/scheme.c

@@ -576,7 +576,8 @@ static void check_boot_file_state PROTO((const char *who));
 
 static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IBOOL errorp; {
   char pathbuf[PATH_MAX], buf[PATH_MAX];
-  uptr n; INT c;
+  uptr n = 0;
+  INT c;
   const char *path;
 #ifdef WIN32
   wchar_t *expandedpath;
@@ -850,23 +851,11 @@ static INT zgetstr(file, s, max) glzFile file; char *s; iptr max; {
 static IBOOL loadecho = 0;
 #define LOADSKIP 0
 
-static void handle_visit_revisit(tc, p) ptr tc; ptr p; {
-  ptr a = Scar(p);
-
-  if (a == FIX(visit_tag) || a == FIX(revisit_tag)) {
-    ptr d = Scdr(p);
-    if (Sprocedurep(d)) {
-      S_initframe(tc, 0);
-      INITCDR(p) = boot_call(tc, d, 0);
-    }
-  }
-}
-
 static int set_load_binary(iptr n) {
-  if (SYMVAL(S_G.scheme_version_id) == sunbound) return 0; // set by back.ss
+  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;
@@ -916,12 +905,8 @@ static void load(tc, n, base) ptr tc; iptr n; IBOOL base; {
         if (Sprocedurep(y)) {
           S_initframe(tc, 0);
           INITVECTIT(x, j) = boot_call(tc, y, 0);
-        } else if (Spairp(y)) {
-          handle_visit_revisit(tc, y);
         }
       }
-    } else if (Spairp(x)) {
-      handle_visit_revisit(tc, x);
     }
     if (loadecho) {
       S_prin1(x);
@@ -1112,7 +1097,7 @@ extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_i
       iptr n;
 
       n = strlen(name) - 4;
-      if (n >= 0 && (strcmp(name + n, ".exe") == 0 || strcmp(name + n, ".EXE") == 0)) {
+      if (n >= 0 && (_stricmp(name + n, ".exe") == 0)) {
         strcpy(buf, name);
         buf[n] = 0;
         name = buf;

c/schsig.c

@@ -535,16 +535,24 @@ void S_noncontinuable_interrupt() {
 }
 
 #ifdef WIN32
+ptr S_dequeue_scheme_signals(ptr tc) {
+  return Snil;
+}
+
+ptr S_allocate_scheme_signal_queue() {
+  return (ptr)0;
+}
+
+void S_register_scheme_signal(sig) iptr sig; {
+  S_error("register_scheme_signal", "unsupported in this version");
+}
+
 /* code courtesy Bob Burger, burgerrg@sagian.com
    We cannot call noncontinuable_interrupt, because we are not allowed
    to perform a longjmp inside a signal handler; instead, we don't
    handle the signal, which will cause the process to terminate.
 */
 
-void S_register_scheme_signal(sig) iptr sig; {
-    S_error("register_scheme_signal", "unsupported in this version");
-}
-
 static BOOL WINAPI handle_signal(DWORD dwCtrlType) {
   switch (dwCtrlType) {
     case CTRL_C_EVENT:
@@ -572,6 +580,8 @@ static void init_signal_handlers() {
 #include <signal.h>
 
 static void handle_signal PROTO((INT sig, siginfo_t *si, void *data));
+static IBOOL enqueue_scheme_signal PROTO((ptr tc, INT sig));
+static ptr allocate_scheme_signal_queue PROTO((void));
 static void forward_signal_to_scheme PROTO((INT sig));
 
 #define RESET_SIGNAL {\
@@ -581,18 +591,88 @@ static void forward_signal_to_scheme PROTO((INT sig));
     sigprocmask(SIG_UNBLOCK,&set,(sigset_t *)0);\
 }
 
+/* we buffer up to SIGNALQUEUESIZE - 1 unhandled signals, the start dropping them. */
+#define SIGNALQUEUESIZE 64
+static IBOOL scheme_signals_registered;
+
+/* we use a simple queue for pending signals.  signals are enqueued only by the
+   C signal handler and dequeued only by the Scheme event handler.  since the signal
+   handler and event handler run in the same thread, there's no need for locks
+   or write barriers. */
+
+struct signal_queue {
+  INT head;
+  INT tail;
+  INT data[SIGNALQUEUESIZE];
+};
+
+static IBOOL enqueue_scheme_signal(ptr tc, INT sig) {
+  struct signal_queue *queue = (struct signal_queue *)(SIGNALINTERRUPTQUEUE(tc));
+  /* ignore the signal if we failed to allocate the queue */
+  if (queue == NULL) return 0;
+  INT tail = queue->tail;
+  INT next_tail = tail + 1;
+  if (next_tail == SIGNALQUEUESIZE) next_tail = 0;
+  /* ignore the signal if the queue is full */
+  if (next_tail == queue->head) return 0;
+  queue->data[tail] = sig;
+  queue->tail = next_tail;
+  return 1;
+}
+
+ptr S_dequeue_scheme_signals(ptr tc) {
+  ptr ls = Snil;
+  struct signal_queue *queue = (struct signal_queue *)(SIGNALINTERRUPTQUEUE(tc));
+  if (queue == NULL) return ls;
+  INT head = queue->head;
+  INT tail = queue->tail;
+  INT i = tail;
+  while (i != head) {
+    if (i == 0) i = SIGNALQUEUESIZE;
+    i -= 1;
+    ls = Scons(Sfixnum(queue->data[i]), ls);
+  }
+  queue->head = tail;
+  return ls;
+}
+
 static void forward_signal_to_scheme(sig) INT sig; {
   ptr tc = get_thread_context();
 
-  SIGNALINTERRUPTPENDING(tc) = Sfixnum(sig);
+  if (enqueue_scheme_signal(tc, sig)) {
+    SIGNALINTERRUPTPENDING(tc) = Strue;
     SOMETHINGPENDING(tc) = Strue;
+  }
   RESET_SIGNAL
 }
 
+static ptr allocate_scheme_signal_queue() {
+  /* silently fail to allocate space for signals if malloc returns NULL */
+  struct signal_queue *queue = malloc(sizeof(struct signal_queue));
+  if (queue != (struct signal_queue *)0) {
+    queue->head = queue->tail = 0;
+  }
+  return (ptr)queue;
+}
+
+ptr S_allocate_scheme_signal_queue() {
+  return scheme_signals_registered ? allocate_scheme_signal_queue() : (ptr)0;
+}
+
 void S_register_scheme_signal(sig) iptr sig; {
     struct sigaction act;
 
-    sigemptyset(&act.sa_mask);
+    tc_mutex_acquire()
+    if (!scheme_signals_registered) {
+      ptr ls;
+      scheme_signals_registered = 1;
+      for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
+        SIGNALINTERRUPTQUEUE(THREADTC(Scar(ls))) = S_allocate_scheme_signal_queue();
+      }
+    }
+    tc_mutex_release()
+
+    sigfillset(&act.sa_mask);
     act.sa_flags = 0;
     act.sa_handler = forward_signal_to_scheme;
     sigaction(sig, &act, (struct sigaction *)0);
@@ -731,6 +811,8 @@ void S_schsig_init() {
 
         S_protect(&S_G.event_and_resume_star_id);
         S_G.event_and_resume_star_id = S_intern((const unsigned char *)"$event-and-resume*");
+
+        scheme_signals_registered = 0;
     }
 
 

c/thread.c

@@ -97,6 +97,7 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; {
   TIMERTICKS(tc) = Sfalse;
   DISABLECOUNT(tc) = Sfixnum(0);
   SIGNALINTERRUPTPENDING(tc) = Sfalse;
+  SIGNALINTERRUPTQUEUE(tc) = S_allocate_scheme_signal_queue();
   KEYBOARDINTERRUPTPENDING(tc) = Sfalse;
 
   TARGETMACHINE(tc) = S_intern((const unsigned char *)MACHINE_TYPE);
@@ -229,6 +230,7 @@ static IBOOL destroy_thread(tc) ptr tc; {
       }
 
       if (LZ4OUTBUFFER(tc) != NULL) free(LZ4OUTBUFFER(tc));
+      if (SIGNALINTERRUPTQUEUE(tc) != NULL) free(SIGNALINTERRUPTQUEUE(tc));
 
       free((void *)tc);
       THREADTC(thread) = 0; /* mark it dead */

c/vfasl.c

@@ -747,6 +747,9 @@ IBOOL S_vfasl_can_combinep(ptr v)
   IBOOL installs;
   vfasl_info *vfi;
 
+  if (IMMEDIATE(v))
+    return 1;
+
   fasl_init_entry_tables();
 
   /* Run a "first pass" */

csug/io.stex

@@ -1020,7 +1020,7 @@ be significantly smaller.
 \noindent
 \scheme{compress-level} determines the amount of effort spent on
 compression and is thus relevant only for output.
-It can be set to one of the symbols \scheme{low},
+It can be set to one of the symbols \scheme{minimum}, \scheme{low},
 \scheme{medium}, \scheme{high}, or \scheme{maximum}, which are
 listed in order from shortest to longest expected compression time
 and least to greatest expected effectiveness.
@@ -1642,11 +1642,17 @@ the buffered input or a portion thereof is returned; otherwise
 \entryheader
 \formdef{read-token}{\categoryprocedure}{(read-token)}
 \formdef{read-token}{\categoryprocedure}{(read-token \var{textual-input-port})}
+\formdef{read-token}{\categoryprocedure}{(read-token \var{textual-input-port} \var{sfd} \var{bfp})}
 \returns see below
 \listlibraries
 \endentryheader
 
 \noindent
+\var{sfd} must be a source-file descriptor.
+\var{bfp} must be an exact nonnegative integer and should be the
+character position of the next character to be read from
+\var{textual-input-port}.
+
 Parsing of a Scheme datum is conceptually performed in two steps.
 First, the sequence of characters that form the datum are grouped into
 \scheme{tokens}, such as symbols, numbers, left parentheses, and
@@ -1671,13 +1677,18 @@ One token is read from the input port and returned as four values:
 \item[\var{value}:] the token value,
 
 \item[\var{start}:] the position of the first character of the token,
-relative to the starting position of the input port, and
+relative to the starting position of the input port (or \scheme{#f},
+if the position cannot be determined), and
 
 \item[\var{end}:] the first position beyond the token,
-relative to the starting position of the input port.
+relative to the starting position of the input port (or \scheme{#f},
+if the position cannot be determined).
 \end{description}
 
 \noindent
+The input port is left pointing to the first character position beyond
+the token.
+
 When the token type fully specifies the token,
 \scheme{read-token} returns \scheme{#f} for the value.
 The token types are listed below with the corresponding \var{value}
@@ -1715,8 +1726,18 @@ in parentheses.
 The set of token types is likely to change in future releases of the
 system; check the release notes for details on such changes.
 
-The input port is left pointing to the first character position beyond
+Specifying \var{sfd} and \var{bfp} improves the quality of error messages,
-the token, i.e., \var{end} characters from the starting position.
+guarantees \var{start} and \var{end} can be determined,
+and eliminates the overhead of asking for a file position on each call
+to \scheme{read-token}.
+In most cases, \var{bfp} should be 0 for the first call
+to \scheme{read-token} at the start of a file,
+and it should be the fourth return value (\var{end}) of the preceding
+call to \scheme{read-token} for each subsequent
+call.
+This protocol is necessary to handle files containing multiple-byte
+characters, since file positions do not necessarily correspond
+to character positions.
 
 \schemedisplay
 (define s (open-input-string "(a b c)"))
@@ -3358,7 +3379,6 @@ input port, must be used instead.
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{fasl-write}{\categoryprocedure}{(fasl-write \var{obj} \var{binary-output-port})}
-\formdef{fasl-read}{\categoryprocedure}{(fasl-read \var{binary-input-port})}
 \returns unspecified
 \listlibraries
 \endentryheader
@@ -3370,11 +3390,45 @@ An exception is raised with condition-type \scheme{&assertion} if
 \var{obj} or any portion of \var{obj} has no external fasl representation,
 e.g., if \var{obj} is or contains a procedure.
 
+\schemedisplay
+(define bop (open-file-output-port "tmp.fsl"))
+(fasl-write '(a b c) bop)
+(close-port bop)
+
+(define bip (open-file-input-port "tmp.fsl"))
+(fasl-read bip) ;=> (a b c)
+(fasl-read bip) ;=> #!eof
+(close-port bip)
+\endschemedisplay
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{fasl-read}{\categoryprocedure}{(fasl-read \var{binary-input-port})}
+\formdef{fasl-read}{\categoryprocedure}{(fasl-read \var{binary-input-port \var{situation}})}
+\returns unspecified
+\listlibraries
+\endentryheader
+
+\noindent
+If present, \var{situation} must be one of the symbols \scheme{load},
+\scheme{visit}, or \scheme{revisit}.
+It defaults to \scheme{load}.
+
 \scheme{fasl-read} reads one object from
 \var{binary-input-port}, which must be positioned at the
 front of an object written in fasl format.
 \scheme{fasl-read} returns the eof object if the file is positioned
 at the end of file.
+If the situation is \scheme{visit}, \scheme{fasl-read} skips over 
+any revisit (run-time-only) objects, and
+if the situation is \scheme{revisit}, \scheme{fasl-read} skips over 
+any visit (compile-time-only) objects.
+It doesn't skip any if the situation is \scheme{load}.
+Similarly, objects marked as both visit and revisit (e.g., object code
+corresponding to source code within an \scheme{eval-when} form with
+situation \scheme{load} or situations \scheme{visit} and \scheme{revisit})
+are never skipped.
 
 \schemedisplay
 (define bop (open-file-output-port "tmp.fsl"))

csug/libraries.stex

@@ -896,6 +896,57 @@ cannot be proven immutable, which inhibits important optimizations such
 as procedure inlining.
 This can result in significantly lower run-time performance.
 
+\section{Explicitly invoking libraries\label{SECTLIBRARYINVOCATION}}
+
+%----------------------------------------------------------------------------
+\noskipentryheader
+\formdef{invoke-library}{\categoryprocedure}{(invoke-library \var{libref})}
+\returns unspecified
+\listlibraries
+\endnoskipentryheader
+
+\var{libref} must be an s-expression in the form of a library reference.
+The syntax for library references is given in
+Chapter~\ref{TSPL:CHPTLIBRARIES} of {\TSPLFOUR} and in the Revised$^6$
+Report.
+
+A library is implicitly invoked when or before some expression
+outside the library (e.g., in another library or in a top-level
+program) evaluates a reference to one of the library's exported
+variables.
+When the library is invoked, its body expressions (the right-hand-sides
+of the library's variable definitions and its initialization
+expressions) are evaluated.
+Once invoked, the library is not invoked again within the same process,
+unless it is first explicitly redefined or reloaded.
+
+\scheme{invoke-library} explicitly invokes the library specified
+by \var{libref} if it has not already been invoked or has since
+been redefined or reloaded.
+If the library has not yet been loaded, \scheme{invoke-library}
+first loads the library via the process described in
+Section~\ref{SECTUSELIBRARIES}.
+
+\scheme{invoke-library} is typically only useful for libraries whose
+body expressions have side effects.
+It is useful to control when the side effects occur and to force
+invocation of a library that has no exported variables.
+Invoking a library does not force the compile-time code (macro
+transformer expressions and meta definitions) to be loaded or
+evaluated, nor does it cause the library's bindings to become
+visible.
+
+It is good practice to avoid externally visible side effects in
+library bodies so the library can be used equally well at compile
+time and run time.
+When feasible, consider moving the side effects of a library body
+to an initialization routine and adding a top-level program that
+imports the library and calls the initialization routine.
+With this structure, calls to \scheme{invoke-library} on the
+library can be replaced by calls to 
+\index{\scheme{load-program}}\scheme{load-program} on the
+top-level program.
+
 \section{Library Parameters\label{SECTLIBRARYPARAMETERS}}
 
 \index{\scheme{import}}%
@@ -915,7 +966,7 @@ The parameter \scheme{library-directories} determines where the files
 containing library source and object code are located in the file system,
 and the parameter \scheme{library-extensions} determines the filename
 extensions for the files holding the code, as described in
-section~\ref{SECTUSESCRIPTING}.
+section~\ref{SECTUSELIBRARIES}.
 The values of both parameters are lists of pairs of strings.
 The first string in each \scheme{library-directories} pair identifies a
 source-file root directory, and the second identifies the corresponding
@@ -974,7 +1025,7 @@ to a procedure that simply calls \scheme{compile-library}) on any imported libra
 the object file is missing, older than the corresponding source file,
 older than any source files included (via \index{\scheme{include}}\scheme{include}) when the
 object file was created, or itself requires a library that has or must
-be recompiled, as described in Section~\ref{SECTUSESCRIPTING}.
+be recompiled, as described in Section~\ref{SECTUSELIBRARIES}.
 The default initial value of this parameter is \scheme{#f}.
 It can be set to \scheme{#t} via the command-line option
 \index{\scheme{--compile-imported-libraries} command-line option}\scheme{--compile-imported-libraries}.
@@ -1056,7 +1107,7 @@ The set of libraries initially defined includes those listed in
 Section~\ref{SECTBUILTINLIBRARIES} above.
 
 %----------------------------------------------------------------------------
-\noskipentryheader
+\entryheader
 \formdef{library-version}{\categoryprocedure}{(library-version \var{libref})}
 \returns the version of the specified library
 \formdef{library-exports}{\categoryprocedure}{(library-exports \var{libref})}
@@ -1068,7 +1119,7 @@ Section~\ref{SECTBUILTINLIBRARIES} above.
 \formdef{library-object-filename}{\categoryprocedure}{(library-object-filename \var{libref})}
 \returns the name of the object file holding the specified library, if any
 \listlibraries
-\endnoskipentryheader
+\endentryheader
 
 Information can be obtained only for built-in libraries or libraries
 previously loaded into the system.

csug/objects.stex

@@ -1191,9 +1191,7 @@ the uncompressed size and the compression mode. The result does not include
 the header that is written by port-based compression using the
 \scheme{compressed} option. The compression format is determined by the
 \index{\scheme{compress-format}}\scheme{compress-format}
-parameter.
+parameter, and the compression level is determined by the
-The compression level is fixed to some default determined by the
-format; it is not affected by the
 \index{\scheme{compress-level}}\scheme{compress-level}
 parameter.
 

csug/smgmt.stex

@@ -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)}
@@ -814,6 +818,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

csug/syntax.stex

@@ -1767,7 +1767,7 @@ marked \scheme{profile} are used for profiling.
 \entryheader
 \formdef{make-source-object}{\categoryprocedure}{(make-source-object \var{sfd} \var{bfp} \var{efp})}
 \formdef{make-source-object}{\categoryprocedure}{(make-source-object \var{sfd} \var{bfp} \var{efp} \var{line} \var{column})}
-\returns a source-object
+\returns a source object
 \listlibraries
 \endentryheader
 
@@ -2007,3 +2007,167 @@ Adjust this parameter to control the way that source locations are
 extracted from source objects, possibly using recorded information,
 caches, and the filesystem in a way different from
 \scheme{locate-source-object-object}.
+
+
+\section{Source Tables\label{SECTSYNTAXSOURCETABLES}}
+
+Source tables provide an efficient way to associate information
+with source objects both in memory and on disk, such as the coverage information
+saved to \scheme{.covin} files when
+\index{\scheme{generate-covin-files}}\scheme{generate-covin-files} is
+set to \scheme{#t}
+and the profile counts associated with source objects by
+\index{\scheme{with-profile-tracker}}\scheme{with-profile-tracker}
+(Section~\ref{SECTMISCPROFILE}).
+
+Source tables are manipulated via hashtable-like accessors and setters
+(Section~\ref{SECTMISCHASHTABLES}, {\TSPLFOUR} Section~\ref{TSPL:SECTHASHTABLES}), e.g.,
+\index{\scheme{source-table-ref}}\scheme{source-table-ref} and \index{\scheme{source-table-set!}}\scheme{source-table-set!}.
+They can be saved to files via
+\index{\scheme{put-source-table}}\scheme{put-source-table}
+and restored via
+\index{\scheme{get-source-table!}}\scheme{get-source-table!}.
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{make-source-table}{\categoryprocedure}{(make-source-table)}
+\returns a source table
+\listlibraries
+\endentryheader
+
+A source table contains associations between source objects and arbitrary
+values.  For purposes of the source-table operations described below, two
+source objects are the same if they have the same source-file descriptor,
+equal beginning file positions and equal ending file positions.
+Two source-file descriptors are the same if they have the same path and
+checksum.
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{source-table?}{\categoryprocedure}{(source-table? \var{obj})}
+\returns \scheme{#t} if \var{obj} is a source-table; \scheme{#f} otherwise
+\listlibraries
+\endentryheader
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{source-table-set!}{\categoryprocedure}{(source-table-set! \var{source-table} \var{source-object} \var{obj})}
+\returns unspecified
+\listlibraries
+\endentryheader
+
+\scheme{source-table-set!} associates \var{source-object}
+with \var{obj} in \var{source-table}, replacing the
+existing association, if any.
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{source-table-ref}{\categoryprocedure}{(source-table-ref \var{source-table} \var{source-object} \var{default})}
+\returns see below
+\listlibraries
+\endentryheader
+
+\noindent
+\var{default} may be any Scheme value.
+
+\scheme{source-table-ref} returns the value
+associated with \var{source-object} in \var{source-table}.
+If no value is associated with \var{source-object} in \var{source-table},
+\scheme{source-table-ref} returns \var{default}.
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{source-table-contains?}{\categoryprocedure}{(source-table-contains? \var{source-table} \var{source-object})}
+\returns \scheme{#t} if an association for \var{source-object} exists in \var{source-table}, \scheme{#f} otherwise
+\listlibraries
+\endentryheader
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{source-table-cell}{\categoryprocedure}{(source-table-cell \var{source-table} \var{source-object} \var{default})}
+\returns a pair (see below)
+\listlibraries
+\endentryheader
+
+\noindent
+\var{default} may be any Scheme value.
+
+If no value is associated with \var{source-object} in \var{source-table},
+\scheme{source-table-cell} modifies \var{source-table} to associate \var{source-object} with
+\var{default}.
+Regardless, it returns a pair whose car is \var{source-object} and whose cdr is
+the associated value.
+Changing the cdr of this pair effectively updates the table to
+associate \var{source-object} with a new value.
+The car field of the pair should not be modified.
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{source-table-delete!}{\categoryprocedure}{(source-table-delete! \var{source-table} \var{source-object})}
+\returns unspecified
+\listlibraries
+\endentryheader
+
+\scheme{source-table-delete!} drops the association
+for \var{source-object} from \var{source-table}, if
+one exists.
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{source-table-size}{\categoryprocedure}{(source-table-size \var{source-table})}
+\returns the number of entries in \var{source-table}
+\listlibraries
+\endentryheader
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{put-source-table}{\categoryprocedure}{(put-source-table \var{textual-output-port} \var{source-table})}
+\returns unspecified
+\listlibraries
+\endentryheader
+
+\noindent
+This procedure writes a representation of the information stored in \var{source-table} to the port.
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{get-source-table!}{\categoryprocedure}{(get-source-table! \var{textual-input-port} \var{source-table})}
+\formdef{get-source-table!}{\categoryprocedure}{(get-source-table! \var{textual-input-port} \var{source-table} \var{combine})}
+\returns unspecified
+\listlibraries
+\endentryheader
+
+The port must be positioned at a representation of source-table
+information written by some previous call to \scheme{put-source-table},
+which reads the information and merges it into \scheme{source-table}.
+
+If present and non-false, \var{combine} must be a procedure and
+should accept two arguments.
+It is called whenever associations for the same source object are
+present both in \var{source-table} and in the information read from
+the port.
+In this case, \var{combine} is passed two arguments: the associated
+value from \var{source-table} and the associated value from the
+port (in that order) and must return one value, which is recorded
+as the new associated value for the source object in \var{source-table}.
+
+If \var{combine} is not present, \var{combine} is \scheme{#f}, or
+no association for a source object read from the port already exists
+in \var{source-table}, the value read from the port is recorded as
+the associated value of the source object in \var{source-table}.
+
+\schemedisplay
+(define st (make-source-table))
+(call-with-port (open-input-file "profile.out1")
+  (lambda (ip) (get-source-table! ip st)))
+(call-with-port (open-input-file "profile.out2")
+  (lambda (ip) (get-source-table! ip st +)))
+\endschemedisplay

csug/system.stex

@@ -521,6 +521,8 @@ It is generally not a good idea, therefore, to establish handlers for
 memory faults, illegal instructions, and the like, since the code that
 causes the fault or illegal instruction will continue to execute
 (presumably erroneously) for some time before the handler is invoked.
+A finite amount of storage is used to buffer as-yet unhandled
+signals, after which additional signals are dropped.
 
 \scheme{register-signal-handler} is supported only on Unix-based
 systems.
@@ -979,6 +981,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
@@ -996,6 +1044,45 @@ of \var{input-port} as previously created by functions like \scheme{compile-file
 The return value is the value of the last expression whose compiled
 form is in \var{input-port}. If \var{input-port} is empty, then the
 result value is unspecified.
+The port is left at end-of-file but is not closed.
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{visit-compiled-from-port}{\categoryprocedure}{(visit-compiled-from-port \var{input-port})}
+\returns result of the last compiled expression processed
+\listlibraries
+\endentryheader
+
+\noindent
+\scheme{visit-compiled-from-port} reads and evaluates the object-code contents
+of \var{input-port} as previously created by functions like \scheme{compile-file},
+\scheme{compile-script}, \scheme{compile-library}, and
+\scheme{compile-to-port}.  In the process, it skips any revisit (run-time-only) code.
+
+The return value is the value of the last expression whose last non-revisit compiled
+form is in \var{input-port}. If there are no such forms, then the
+result value is unspecified.
+The port is left at end-of-file but is not closed.
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{revisit-compiled-from-port}{\categoryprocedure}{(revisit-compiled-from-port \var{input-port})}
+\returns result of the last compiled expression processed
+\listlibraries
+\endentryheader
+
+\noindent
+\scheme{revisit-compiled-from-port} reads and evaluates the object-code contents
+of \var{input-port} as previously created by functions like \scheme{compile-file},
+\scheme{compile-script}, \scheme{compile-library}, and
+\scheme{compile-to-port}.  In the process, it skips any visit (compile-time-only) code.
+
+The return value is the value of the last expression whose last non-visit compiled
+form is in \var{input-port}. If there are no such forms, then the
+result value is unspecified.
+The port is left at end-of-file but is not closed.
 
 
 %----------------------------------------------------------------------------
@@ -1128,6 +1215,7 @@ cp0-outer-unroll-limit
 generate-inspector-information
 generate-procedure-source-information
 compile-profile
+generate-covin-files
 generate-interrupt-trap
 enable-cross-library-optimization
 enable-arithmetic-left-associative
@@ -1340,7 +1428,23 @@ The libraries incorporated into the resulting object file are visible (for
 use by \scheme{environment} and \scheme{eval}) if the \var{libs-visible?}
 argument is supplied and non-false.
 Any library incorporated into the resulting object file and required by
-an object file left to be loaded at run time is also visible.
+an object file left to be loaded at run time is also visible, as are any
+libraries the object file depends upon, regardless of the value of
+\var{libs-visible?}.
+
+\scheme{compile-whole-program} linearizes the initialization code for the
+set of incorporated libraries in a way that respects static
+dependencies among the libraries but not necessary dynamic dependencies
+deriving from initialization-time uses of \scheme{environment}
+or \scheme{eval}.
+Additional static dependencies can be added in most cases to force
+an ordering that allows the dynamic imports to succeed,
+though not in general since a different order might be required each
+time the program is run.
+Adding a static dependency of one library on a second requires
+adding an import of the second in the first as well as a run-time
+reference to one of the variables exported by the second in the
+body of the first.
 
 \var{input-filename} and \var{output-filename} must be strings.
 \var{input-filename} must identify a wpo file, and a wpo or object
@@ -1378,35 +1482,44 @@ all libraries are automatically made visible, and a new wpo file is
 produced (when \scheme{generate-wpo-files} is \scheme{#t}) as well
 as an object file for the resulting combination of libraries.
 
+The comment in the description of \scheme{compile-whole-program}
+about the effect of initialization-code linearization on dynamic
+dependencies applies to \scheme{compile-whole-library} as well.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{compile-port}{\categoryprocedure}{(compile-port \var{input-port} \var{output-port})}
 \formdef{compile-port}{\categoryprocedure}{(compile-port \var{input-port} \var{output-port} \var{sfd})}
 \formdef{compile-port}{\categoryprocedure}{(compile-port \var{input-port} \var{output-port} \var{sfd} \var{wpo-port})}
+\formdef{compile-port}{\categoryprocedure}{(compile-port \var{input-port} \var{output-port} \var{sfd} \var{wpo-port} \var{covop})}
 \returns unspecified
 \listlibraries
 \endentryheader
 
 \noindent
 \var{input-port} must be a textual input port.
-\var{output-port} and, if present, \var{wpo-port} must be binary output ports.
+\var{output-port} and, if present and non-false, \var{wpo-port} must be binary output ports.
-If present, \var{sfd} must be a source-file descriptor.
+If present and non-false, \var{sfd} must be a source-file descriptor.
+If present and non-false, \var{covop} must be a textual output port.
 
 \scheme{compile-port} is like \scheme{compile-file} except that it takes
 input from an arbitrary textual input port and sends output to an arbitrary
 binary output port.
-If \var{sfd} is present, it is passed to the reader so that source information
+If \var{sfd} is supplied, it is passed to the reader so that source information
 can be associated with the expressions read from \var{input-port}.
 It is also used to associate block-profiling information with the input
 file name encapsulated within \var{sfd}.
-If \var{wpo-port} is present, it sends whole-program optimization information
+If \var{wpo-port} is supplied, \scheme{compile-port} sends whole-program optimization information
-to \var{wpo-port} for use by \scheme{compile-whole-program}.
+to \var{wpo-port} for use by \scheme{compile-whole-program}, as if
+(and regardless of whether) \scheme{generate-wpo-files} is set.
+If \var{covop} is supplied, \scheme{compile-port} sends coverage information to
+\var{covop}, as if (and regardless of whether) \scheme{generate-covin-files} is set.
 
-None of the ports is closed automatically after compilation; it is assumed
+The ports are closed automatically after compilation under the assumption
-that the program that opens the ports and invokes \scheme{compile-port}
+the program that opens the ports and invokes \scheme{compile-port}
 will take care of closing the ports.
-The output will be compressed only if \var{binary-output-port} is set up
+Output will be compressed only if an output port is already set up to be
-to do compression, e.g., if it was opened with the \scheme{compressed}
+compressed, e.g., if it was opened with the \scheme{compressed}
 file option.
 
 %----------------------------------------------------------------------------
@@ -1414,6 +1527,7 @@ file option.
 \formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port})}
 \formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd})}
 \formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd} \var{wpo-port})}
+\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd} \var{wpo-port} \var{covop})}
 \returns see below
 \listlibraries
 \endentryheader
@@ -1433,15 +1547,17 @@ input from a list of objects and sends output to an arbitrary binary
 output port.
 \var{sfd} is used to associate block-profiling information with the
 input file name encapsulated within \var{sfd}.
-If \var{wpo-port} is present, it sends whole-program optimization information
+If \var{wpo-port} is present, \var{compile-to-port} sends whole-program optimization information
-to \var{wpo-port} for use by \scheme{compile-whole-program}.
+to \var{wpo-port} for use by \scheme{compile-whole-program}, as if
+(and regardless of whether) \scheme{generate-wpo-files} is set.
+If \var{covop} is present, \var{compile-to-port} sends coverage information to
+\var{covop}, as if (and regardless of whether) \scheme{generate-covin-files} is set.
 
-The output port is not closed automatically after compilation; it is assumed
+The ports are not closed automatically after compilation under the assumption
-that the program that opens the port and invokes \scheme{compile-to-port}
+the program that opens the port and invokes \scheme{compile-to-port}
 will take care of closing the port.
-
+Output will be compressed only if an output port is already set up to be
-The output will be compressed only if \var{binary-output-port} is set up
+compressed, e.g., if it was opened with the \scheme{compressed}
-to do compression, e.g., if it was opened with the \scheme{compressed}
 file option.
 
 When \var{obj-list} contains a single list-structured element whose
@@ -1479,6 +1595,21 @@ first-element is the symbol \scheme{top-level-program},
 program requires at run time, as with \scheme{compile-program}.
 Otherwise, the return value is unspecified.
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{concatenate-object-files}{\categoryprocedure}{(concatenate-object-files \var{out-file} \var{in-file_1} \var{in-file_2} \dots)}
+\returns unspecified
+\listlibraries
+\endentryheader
+
+\var{out-file} and each \var{in-file} must be strings.
+
+\scheme{concatenate-object-files} combines the header information
+contained in the object files named by each \var{in-file}.  It then
+writes the combined header information to the file named by
+\var{out-file}, followed by the remaining object code from each
+input file in turn.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{make-boot-file}{\categoryprocedure}{(make-boot-file \var{output-filename} \var{base-boot-list} \var{input-filename} \dots)}
@@ -2977,12 +3108,17 @@ With source profiling enabled, the compiler instruments the code
 it produces to count the number of times each source-code expression
 is executed.
 This information can be
-displayed in HTML format or packaged in a list for
+displayed in HTML format, or it can be packaged in a list or
-arbitrary user-defined processing.
+source table for arbitrary user-defined processing.
 It can also be dumped to a file to be loaded subsequently into the
 compiler's database of profile information for use in source-level
 optimizations, such as reordering the clauses of a \scheme{case}
 or \scheme{exclusive-cond} form.
+In connection with coverage-information (covin) files generated by the
+compiler when
+\index{\scheme{generate-covin-files}}\scheme{generate-covin-files}
+is \scheme{#t}, profile information can also be used to gauge coverage
+of a source-code base by a set of tests.
 
 The association between source-code expressions and profile counts
 is usually established via annotations produced by the reader and
@@ -3248,6 +3384,29 @@ counters explicitly via the procedure
 \index{\scheme{profile-release-counters}}\scheme{profile-release-counters}.
 
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{generate-covin-files}{\categorythreadparameter}{generate-covin-files}
+\listlibraries
+\endentryheader
+
+When this parameter is set to \scheme{#t}, the compiler generates
+``coverage-information'' (covin) files that can be used in connection with
+profile information to measure coverage of a source-code base by a
+set of tests.
+One covin file is created for each object file, with the object-file
+extension replaced by the extension \scheme{.covin}.
+Each covin file contains the printed representation of a source table
+(Section~\ref{SECTSYNTAXSOURCETABLES}), compressed when the parameter
+\scheme{compile-compressed} is true, mapping each profiled source
+expression found during the compilation of the corresponding source
+file to a count of zero.
+This information can be read via
+\index{\scheme{get-source-table!}}\scheme{get-source-table!} and used
+as a universe of source expressions to identify source expressions
+that are not evaluated during the running of a set of tests.
+
+
 \entryheader
 \formdef{profile}{\categorysyntax}{(profile \var{source-object})}
 \returns unspecified
@@ -3327,6 +3486,62 @@ descriptors.
 It might be used, for example, to dump profile information to a
 fasl file on one machine for subsequent processing on another.
 
+\index{\scheme{with-profile-tracker}}\scheme{with-profile-tracker}
+can be used to obtain the same set of counts as a source table.
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{with-profile-tracker}{\categoryprocedure}{(with-profile-tracker \var{thunk})}
+\formdef{with-profile-tracker}{\categoryprocedure}{(with-profile-tracker \var{preserve-existing?} \var{thunk})}
+\returns a source table and the values returned by \var{thunk}
+\listlibraries
+\endentryheader
+
+\var{thunk} must be a procedure and should accept zero arguments.
+It may return any number of values.
+
+\scheme{with-profile-tracker} invokes \var{thunk} without arguments.
+If \var{thunk} returns $n$ values \scheme{\var{x_1}, \var{x_2}, \dots, \var{x_n}}, \scheme{with-profile-tracker}
+returns $n+1$ values \scheme{\var{st}, \var{x_1}, \var{x_2}, \dots, \var{x_n}}, where \var{st} is a
+source table associating source objects with profile counts.
+If \var{preserve-existing?} is absent or \scheme{#f}, each count
+represents the number of times the source expression represented
+by the associated source object is evaluated during the invocation
+of \var{thunk}.
+Otherwise, each count represents the number of times the source
+expression represented by the associated source object is evaluated
+before or during the invocation of \var{thunk}.
+
+Profile data otherwise cleared by a call to
+\index{\scheme{profile-clear}}\scheme{profile-clear} or
+\index{\scheme{profile-release-counters}}\scheme{profile-release-counters}
+during the invocation of \var{thunk} is included in the
+resulting table.
+That is, invoking these procedures while \var{thunk} is running has
+no effect on the resulting counts.
+On the other hand, profile data cleared before \scheme{with-profile-tracker}
+is invoked is not included in the resulting table.
+
+The idiom \scheme{(with-profile-tracker #t values)} can be used to obtain
+the current set of profile counts as a source table.
+
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{source-table-dump}{\categoryprocedure}{(source-table-dump \var{source-table})}
+\returns a list of pairs of source objects and their associated values in \var{source-table}
+\listlibraries
+\endentryheader
+
+This procedure can be used to convert a source-table produced by
+\index{\scheme{with-profile-tracker}}\scheme{with-profile-tracker} or some other mechanism into the form returned
+by \index{\scheme{profile-dump}}\scheme{profile-dump} for use as an argument to
+\index{\scheme{profile-dump-html}}\scheme{profile-dump-html},
+\index{\scheme{profile-dump-list}}\scheme{profile-dump-list},
+or
+\index{\scheme{profile-dump-data}}\scheme{profile-dump-data}.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{profile-dump-html}{\categoryprocedure}{(profile-dump-html)}

csug/threads.stex

@@ -460,6 +460,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
@@ -559,6 +567,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}}
 
 %----------------------------------------------------------------------------

csug/use.stex

@@ -1538,9 +1538,8 @@ libraries have been built and Scheme source files have been compiled
 to object code.
 
 Although not strictly necessary, we suggest that you concatenate your
-object files, if you have more than one, into a single object file.
+object files, if you have more than one, into a single object file
-This may be done on Unix systems simply via the \scheme{cat}
+via the \scheme{concatenate-object-files} procedure.
-program or on Windows via \scheme{copy}.
 Placing all of the object code into a single file
 simplifies both building and distribution of applications.
 

makefiles/Makefile-workarea.in

@@ -16,32 +16,48 @@
 MAKEFLAGS += --no-print-directory
 PREFIX=
 
+.PHONY: build
 build:
 	(cd c && $(MAKE))
 	(cd s && $(MAKE) bootstrap)
 
+.PHONY: install
 install: build
 	$(MAKE) -f Mf-install
 
+.PHONY: uninstall
 uninstall:
 	$(MAKE) -f Mf-install uninstall
 
+.PHONY: test
 test: build
 	(cd mats && $(MAKE) allx)
 	@echo "test run complete.  check $(PREFIX)mats/summary for errors."
 
+.PHONY: coverage
+coverage:
+	rm -f s/bootstrap
+	(cd c && $(MAKE))
+	(cd s && $(MAKE) bootstrap p=t c=t)
+	(cd mats && $(MAKE) allx c=t)
+
+.PHONY: bootfiles
 bootfiles: build
 	$(MAKE) -f Mf-boot
 
-create-bintar: build
+.PHONY: bintar
+bintar: build
 	(cd bintar && $(MAKE))
 
-create-rpm: create-bintar
+.PHONY: rpm
+rpm: bintar
 	(cd rpm && $(MAKE))
 
-create-pkg: create-bintar
+.PHONY: pkg
+pkg: bintar
 	(cd pkg && $(MAKE))
 
+.PHONY: clean
 clean:
 	rm -f petite.1 scheme.1
 	(cd s && $(MAKE) clean)

makefiles/Makefile.in

@@ -15,50 +15,68 @@
 
 MAKEFLAGS += --no-print-directory
 
+.PHONY: build
 build:
 	(cd $(workarea) && $(MAKE) build)
 
+.PHONY: run
 run:
 	env SCHEMEHEAPDIRS=$(workarea)/boot/$(m) $(workarea)/bin/$(m)/scheme
 
+.PHONY: install
 install:
 	(cd $(workarea) && $(MAKE) install)
 
+.PHONY: uninstall
 uninstall:
 	(cd $(workarea) && $(MAKE) uninstall)
 
+.PHONY: test
 test:
 	(cd $(workarea) && $(MAKE) test PREFIX=$(workarea)/)
 
+.PHONY: coverage
+coverage:
+	(cd $(workarea) && $(MAKE) coverage)
+
+.PHONY: bootfiles
 bootfiles:
 	(cd $(workarea) && $(MAKE) bootfiles)
 
 # Supply XM=<machine> to build boot files for <machine>
+.PHONY: boot
 boot: build
 	mkdir -p boot/$(XM)
 	(cd $(workarea) && $(MAKE) -f Mf-boot $(XM).boot)
 
 # Supply ORIG=<dir> to build using existing at <dir>
+.PHONY: from-orig
 from-orig:
 	(cd $(m)/s && $(MAKE) -f Mf-cross m=$(m) xm=$(m) base=$(ORIG)/$(m))
 	$(MAKE) build
 
+.PHONY: docs
 docs: build
 	(cd csug && $(MAKE) m=$(m))
 	(cd release_notes && $(MAKE) m=$(m))
 
-create-bintar:
+.PHONY: bintar
-	(cd $(workarea) && $(MAKE) create-bintar)
+bintar:
+	(cd $(workarea) && $(MAKE) bintar)
 
-create-rpm:
+.PHONY: rpm
-	(cd $(workarea) && $(MAKE) create-rpm)
+rpm:
+	(cd $(workarea) && $(MAKE) rpm)
 
-create-pkg:
+.PHONY: pkg
-	(cd $(workarea) && $(MAKE) create-pkg)
+pkg:
+	(cd $(workarea) && $(MAKE) pkg)
 
+.PHONY: clean
 clean:
 	(cd $(workarea) && $(MAKE) clean)
 
+.PHONY: distclean
 distclean:
 	(cd csug && if [ -e Makefile ] ; then $(MAKE) reallyreallyclean ; fi)
 	rm -f csug/Makefile

mats/4.ms

@@ -452,7 +452,7 @@
          ; make sure no collection occurs before profile data is dumped
          (parameterize ([compile-profile #t] [collect-request-handler void])
            (load "testfile.ss" compile)
-           (profile-dump-data "testfile.pd"))
+           (profile-dump-data "testfile.pd" (remp preexisting-profile-dump-entry? (profile-dump))))
          ; make sure collections are restarted
          (collect)))
      "(11 10 1 10 0)\n")
@@ -467,6 +467,17 @@
    (begin
      (profile-clear-database)
      #t)
+   (begin
+     (profile-load-data "testfile.pd" "testfile.pd")
+     #t)
+   (equal?
+     (with-output-to-string
+       (lambda ()
+         (load "testfile.ss" compile)))
+     "(1 11 1 10 0)\n")
+   (begin
+     (profile-clear-database)
+     #t)
  )
 
 (mat case
@@ -560,7 +571,7 @@
         (parameterize ([compile-profile #t]) (load "testfile.ss" compile))))
     "AAAAAAAAAAB")
   (begin
-    (profile-dump-data "testfile.pd")
+    (profile-dump-data "testfile.pd" (remp preexisting-profile-dump-entry? (profile-dump)))
     (profile-load-data "testfile.pd")
     #t)
   (equal?
@@ -4194,8 +4205,53 @@
      (let ([v (make-self #f)])
        (self-v-set! v v)
        (check-self-referencing v self-v)))
-  )
 
+   (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
   (error? ; unrecognized ftype
@@ -4336,6 +4392,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

mats/5_3.ms

@@ -3080,6 +3080,107 @@
    (eqv? (ash #x-8000000000000000 -31) #x-100000000)
    (eqv? (ash #x-8000000000000000 -32) #x-80000000)
    (eqv? (ash #x-8000000000000000 -33) #x-40000000)
+   (begin
+     (define ($test-right-shift srl)
+       (define ($go q x n expected)
+         (let ([got (srl x n)])
+           (unless (eqv? got expected)
+             (syntax-error q (format "expected ~x, got ~x" expected got)))))
+       (define-syntax go
+         (lambda (q)
+           (syntax-case q ()
+             [(_ x n expected) #`($go #'#,q x n expected)])))
+       (let* ([$x (expt 2 1024)]
+              [$-x (- $x)]
+              [$x+1 (+ $x 1)]
+              [$-x-1 (- $x+1)]
+              [$x-1 (- $x 1)]
+              [$-x+1 (- $x-1)]
+              [$x+8 (+ $x 8)]
+              [$-x-8 (- $x+8)]
+              [$x+2^31 (+ $x (expt 2 32))]
+              [$-x-2^31 (- $x+2^31)]
+              [$x+2^32 (+ $x (expt 2 32))]
+              [$-x-2^32 (- $x+2^32)]
+              [$x+2^40 (+ $x (expt 2 40))]
+              [$-x-2^40 (- $x+2^40)]
+              [$x+2^63 (+ $x (expt 2 63))]
+              [$-x-2^63 (- $x+2^63)]
+              [$x+2^65 (+ $x (expt 2 65))]
+              [$-x-2^65 (- $x+2^65)]
+              [$x*3/2 (ash 3 1023)]
+              [$-x*3/2 (- $x*3/2)]
+              ; answers
+              [$2^64 (expt 2 64)]
+              [$-2^64 (- $2^64)]
+              [$-2^64-1 (- -1 $2^64)]
+              [$x>>64 (expt 2 (- 1024 64))]
+              [$-x>>64 (- $x>>64)]
+              [$-x>>64-1 (- -1 $x>>64)]
+              [$x>>64+2 (+ $x>>64 2)]
+              [$-x>>64-2 (- $x>>64+2 )]
+              [$x>>80 (expt 2 (- 1024 80))]
+              [$-x>>80 (- $x>>80)]
+              [$-x>>80-1 (- -1 $x>>80)]
+              )
+         (go $x 1024 1)
+         (go $-x 1024 -1)
+         (go $x 1025 0)
+         (go $-x 1025 -1)
+         (go $x+1 1024 1)
+         (go $-x-1 1024 -2)
+         (go $x+1 1025 0)
+         (go $-x-1 1025 -1)
+         (go $x (- 1024 64) $2^64)
+         (go $-x (- 1024 64) $-2^64)
+         (go $x+1 (- 1024 64) $2^64)
+         (go $-x-1 (- 1024 64) $-2^64-1)
+         (go $x+8 (- 1024 64) $2^64)
+         (go $-x-8 (- 1024 64) $-2^64-1)
+         (go $x+2^32 (- 1024 64) $2^64)
+         (go $-x-2^32 (- 1024 64) $-2^64-1)
+         (go $x+2^65 (- 1024 64) $2^64)
+         (go $-x-2^65 (- 1024 64) $-2^64-1)
+         (go $x 64 $x>>64)
+         (go $-x 64 $-x>>64)
+         (go $x+1 64 $x>>64)
+         (go $-x-1 64 $-x>>64-1)
+         (go $x+8 64 $x>>64)
+         (go $-x-8 64 $-x>>64-1)
+         (go $x+2^31 64 $x>>64)
+         (go $-x-2^31 64 $-x>>64-1)
+         (go $x+2^40 64 $x>>64)
+         (go $-x-2^40 64 $-x>>64-1)
+         (go $x+2^63 64 $x>>64)
+         (go $-x-2^63 64 $-x>>64-1)
+         (go $x+2^65 64 $x>>64+2)
+         (go $-x-2^65 64 $-x>>64-2)
+         (go $x 80 $x>>80)
+         (go $-x 80 $-x>>80)
+         (go $x+1 80 $x>>80)
+         (go $-x-1 80 $-x>>80-1)
+         (go $x+8 80 $x>>80)
+         (go $-x-8 80 $-x>>80-1)
+         (go $x+2^31 80 $x>>80)
+         (go $-x-2^31 80 $-x>>80-1)
+         (go $x+2^32 80 $x>>80)
+         (go $-x-2^32 80 $-x>>80-1)
+         (go $x+2^40 80 $x>>80)
+         (go $-x-2^40 80 $-x>>80-1)
+         (go $x+2^63 80 $x>>80)
+         (go $-x-2^63 80 $-x>>80-1)
+         (go $x+2^65 80 $x>>80)
+         (go $-x-2^65 80 $-x>>80-1)
+         (go $x*3/2 1023 3)
+         (go $-x*3/2 1023 -3)
+         (go $x*3/2 1024 1)
+         (go $-x*3/2 1024 -2)
+         (go $x*3/2 1025 0)
+         (go $-x*3/2 1025 -1)
+         )
+       #t)
+     #t)
+   ($test-right-shift (lambda (x n) (ash x (- n))))
 )
 
 (mat bitwise-arithmetic-shift
@@ -3135,6 +3236,7 @@
    (eqv? (bitwise-arithmetic-shift 0 (- (expt 2 100))) 0)
    (eqv? (bitwise-arithmetic-shift 0 (expt 2 100)) 0)
    (eqv? (bitwise-arithmetic-shift 0 (expt 2 100)) 0)
+   ($test-right-shift (lambda (x n) (bitwise-arithmetic-shift x (- n))))
 )
 
 (mat bitwise-arithmetic-shift-left/right
@@ -3182,6 +3284,7 @@
    (eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 31) #x-100000000)
    (eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 32) #x-80000000)
    (eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 33) #x-40000000)
+   ($test-right-shift (lambda (x n) (bitwise-arithmetic-shift-right x n)))
 )
 
 (mat bitwise-bit-field
@@ -6493,6 +6596,567 @@
       (5 . 2/7) (-5 . -2/7) (-5 . 2/7) (5 . -2/7)))
 )
 
+(mat special-cases ; test special cases added Feb 2020
+  (begin
+    (define $n 40910371311673474504209841881478505181983799806634563)
+    (define $-n (- $n))
+    (define $q 40910371311673474504209841881478505181983799806634563/7312893582423593745243587)
+    (define $-q (- $q))
+    (define $x 1.499423325079378e100)
+    (define $-x (- $x))
+    (define $ez 3+4i)
+    (define $-ez (- $ez))
+    (define $iz 3.0-4.0i)
+    (define $-iz (- $iz))
+    #t)
+  (error? ; not a number
+    (div-and-mod 'bogus 1))
+  (error? ; not a number
+    (div-and-mod 'bogus -1))
+  (error? ; domain error
+    (div-and-mod $n 4+3i))
+  (error? ; domain error
+    (div-and-mod 4+3i $n))
+  (error? ; domain error
+    (div-and-mod 0 0))
+  (error? ; domain error
+    (div-and-mod $n 0))
+  (error? ; domain error
+    (div-and-mod $q 0))
+  (error? ; not a number
+    (div 'bogus 1))
+  (error? ; not a number
+    (div 'bogus -1))
+  (error? ; domain error
+    (div $n 4+3i))
+  (error? ; domain error
+    (div 4+3i $n))
+  (error? ; domain error
+    (div 0 0))
+  (error? ; domain error
+    (div $n 0))
+  (error? ; domain error
+    (div $q 0))
+  (error? ; not a number
+    (mod 'bogus 1))
+  (error? ; not a number
+    (mod 'bogus -1))
+  (error? ; domain error
+    (mod $n 4+3i))
+  (error? ; domain error
+    (mod 4+3i $n))
+  (error? ; domain error
+    (mod 0 0))
+  (error? ; domain error
+    (mod $n 0))
+  (error? ; domain error
+    (mod $q 0))
+  (error? ; not a number
+    (div0-and-mod0 'bogus 1))
+  (error? ; not a number
+    (div0-and-mod0 'bogus -1))
+  (error? ; domain error
+    (div0-and-mod0 $n 4+3i))
+  (error? ; domain error
+    (div0-and-mod0 4+3i $n))
+  (error? ; domain error
+    (div0-and-mod0 0 0))
+  (error? ; domain error
+    (div0-and-mod0 $n 0))
+  (error? ; domain error
+    (div0-and-mod0 $q 0))
+  (error? ; not a number
+    (div0 'bogus 1))
+  (error? ; not a number
+    (div0 'bogus -1))
+  (error? ; domain error
+    (div0 $n 4+3i))
+  (error? ; domain error
+    (div0 4+3i $n))
+  (error? ; domain error
+    (div0 0 0))
+  (error? ; domain error
+    (div0 $n 0))
+  (error? ; domain error
+    (div0 $q 0))
+  (error? ; not a number
+    (mod0 'bogus 1))
+  (error? ; not a number
+    (mod0 'bogus -1))
+  (error? ; domain error
+    (mod0 $n 4+3i))
+  (error? ; domain error
+    (mod0 4+3i $n))
+  (error? ; domain error
+    (mod0 0 0))
+  (error? ; domain error
+    (mod0 $n 0))
+  (error? ; domain error
+    (mod0 $q 0))
+  (error? ; not a number
+    (quotient 'bogus 1))
+  (error? ; not a number
+    (quotient 'bogus -1))
+  (error? ; domain error
+    (quotient $n 4+3i))
+  (error? ; domain error
+    (quotient 4.5 $n))
+  (error? ; domain error
+    (quotient 0 0))
+  (error? ; domain error
+    (quotient $n 0))
+  (error? ; domain error
+    (quotient 4.0 0))
+  (error? ; not a number
+    (remainder 'bogus 1))
+  (error? ; not a number
+    (remainder 'bogus -1))
+  (error? ; domain error
+    (remainder $n 4+3i))
+  (error? ; domain error
+    (remainder 4.5 $n))
+  (error? ; domain error
+    (remainder 0 0))
+  (error? ; domain error
+    (remainder $n 0))
+  (error? ; domain error
+    (remainder 4.0 0))
+  (error? ; not a number
+    (modulo 'bogus 1))
+  (error? ; not a number
+    (modulo 'bogus -1))
+  (error? ; domain error
+    (modulo $n 4+3i))
+  (error? ; domain error
+    (modulo 4.5 $n))
+  (error? ; domain error
+    (modulo 0 0))
+  (error? ; domain error
+    (modulo $n 0))
+  (error? ; domain error
+    (modulo 4.0 0))
+  (error? ; not a number
+    (/ 'bogus 1))
+  (error? ; not a number
+    (/ 'bogus -1))
+  (error? ; domain error
+    (/ 0 0))
+  (error? ; domain error
+    (/ $n 0))
+  (error? ; domain error
+    (/ $q 0))
+  (error? ; domain error
+    (/ $ez 0))
+  (error? ; not a number
+    (* 'bogus 0))
+  (error? ; not a number
+    (* 'bogus 1))
+  (error? ; not a number
+    (* 'bogus -1))
+  (error? ; not a number
+    (* 0 'bogus))
+  (error? ; not a number
+    (* 1 'bogus))
+  (error? ; not a number
+    (* -1 'bogus))
+  (error? ; not a number
+    (+ 'bogus 0))
+  (error? ; not a number
+    (+ 0 'bogus))
+  (error? ; not a number
+    (- 'bogus 0))
+  (error? ; not a number
+    (- 0 'bogus))
+  (equal? (call-with-values (lambda () (div-and-mod $n 1)) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (div-and-mod $n -1)) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (div-and-mod $-n 1)) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (div-and-mod $-n -1)) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (values (div $n 1) (mod $n 1))) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (values (div $n -1) (mod $n -1))) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (values (div $-n 1) (mod $n 1))) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (values (div $-n -1) (mod $n -1))) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (div0-and-mod0 $n 1)) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (div0-and-mod0 $n -1)) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (div0-and-mod0 $-n 1)) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (div0-and-mod0 $-n -1)) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (values (div0 $n 1) (mod0 $n 1))) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (values (div0 $n -1) (mod0 $n -1))) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (values (div0 $-n 1) (mod0 $n 1))) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (values (div0 $-n -1) (mod0 $n -1))) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (values (quotient $n 1) (remainder $n 1))) cons) `(,$n . 0))
+  (equal? (call-with-values (lambda () (values (quotient $n -1) (remainder $n -1))) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (values (quotient $-n 1) (remainder $n 1))) cons) `(,$-n . 0))
+  (equal? (call-with-values (lambda () (values (quotient $-n -1) (remainder $n -1))) cons) `(,$n . 0))
+  (equal? (modulo $n 1) 0)
+  (equal? (modulo $n -1) 0)
+  (equal? (modulo $-n 1) 0)
+  (equal? (modulo $-n -1) 0)
+  (equal? (/ $n 1) $n)
+  (equal? (/ $n -1) $-n)
+  (equal? (/ $-n 1) $-n)
+  (equal? (/ $-n -1) $n)
+  (equal? (/ 0 $n) 0)
+  (equal? (/ 0 $-n) 0)
+  (equal? (/ $q 1) $q)
+  (equal? (/ $q -1) $-q)
+  (equal? (/ $-q 1) $-q)
+  (equal? (/ $-q -1) $q)
+  (equal? (/ $x 1) $x)
+  (equal? (/ $x -1) $-x)
+  (equal? (/ $-x 1) $-x)
+  (equal? (/ $-x -1) $x)
+  (equal? (/ $ez 1) $ez)
+  (equal? (/ $ez -1) $-ez)
+  (equal? (/ $-ez 1) $-ez)
+  (equal? (/ $-ez -1) $ez)
+  (equal? (/ $iz 1) $iz)
+  (equal? (/ $iz -1) $-iz)
+  (equal? (/ $-iz 1) $-iz)
+  (equal? (/ $-iz -1) $iz)
+  (equal? (* $n 1) $n)
+  (equal? (* $n -1) $-n)
+  (equal? (* $-n 1) $-n)
+  (equal? (* $-n -1) $n)
+  (equal? (* $n 0) 0)
+  (equal? (* $-n 0) 0)
+  (equal? (* $q 1) $q)
+  (equal? (* $q -1) $-q)
+  (equal? (* $-q 1) $-q)
+  (equal? (* $-q -1) $q)
+  (equal? (* $q 0) 0)
+  (equal? (* $-q 0) 0)
+  (equal? (* $x 1) $x)
+  (equal? (* $x -1) $-x)
+  (equal? (* $-x 1) $-x)
+  (equal? (* $-x -1) $x)
+  (equal? (* $x 0) 0)
+  (equal? (* $-x 0) 0)
+  (equal? (* $ez 1) $ez)
+  (equal? (* $ez -1) $-ez)
+  (equal? (* $-ez 1) $-ez)
+  (equal? (* $-ez -1) $ez)
+  (equal? (* $ez 0) 0)
+  (equal? (* $-ez 0) 0)
+  (equal? (* $iz 1) $iz)
+  (equal? (* $iz -1) $-iz)
+  (equal? (* $-iz 1) $-iz)
+  (equal? (* $-iz -1) $iz)
+  (equal? (* $iz 0) 0)
+  (equal? (* $-iz 0) 0)
+  (equal? (* 1 $n) $n)
+  (equal? (* -1 $n) $-n)
+  (equal? (* 1 $-n) $-n)
+  (equal? (* -1 $-n) $n)
+  (equal? (* 0 $n) 0)
+  (equal? (* 0 $-n) 0)
+  (equal? (* 1 $q) $q)
+  (equal? (* -1 $q) $-q)
+  (equal? (* 1 $-q) $-q)
+  (equal? (* -1 $-q) $q)
+  (equal? (* 0 $q) 0)
+  (equal? (* 0 $-q) 0)
+  (equal? (* 1 $x) $x)
+  (equal? (* -1 $x) $-x)
+  (equal? (* 1 $-x) $-x)
+  (equal? (* -1 $-x) $x)
+  (equal? (* 0 $x) 0)
+  (equal? (* 0 $-x) 0)
+  (equal? (* 1 $ez) $ez)
+  (equal? (* -1 $ez) $-ez)
+  (equal? (* 1 $-ez) $-ez)
+  (equal? (* -1 $-ez) $ez)
+  (equal? (* 0 $ez) 0)
+  (equal? (* 0 $-ez) 0)
+  (equal? (* 1 $iz) $iz)
+  (equal? (* -1 $iz) $-iz)
+  (equal? (* 1 $-iz) $-iz)
+  (equal? (* -1 $-iz) $iz)
+  (equal? (* 0 $iz) 0)
+  (equal? (* 0 $-iz) 0)
+  (equal? (+ $n 0) $n)
+  (equal? (+ $-n 0) $-n)
+  (equal? (+ 0 $n) $n)
+  (equal? (+ 0 $-n) $-n)
+  (equal? (+ $q 0) $q)
+  (equal? (+ $-q 0) $-q)
+  (equal? (+ 0 $q) $q)
+  (equal? (+ 0 $-q) $-q)
+  (equal? (+ $x 0) $x)
+  (equal? (+ $-x 0) $-x)
+  (equal? (+ 0 $x) $x)
+  (equal? (+ 0 $-x) $-x)
+  (equal? (+ $ez 0) $ez)
+  (equal? (+ $-ez 0) $-ez)
+  (equal? (+ 0 $ez) $ez)
+  (equal? (+ 0 $-ez) $-ez)
+  (equal? (+ $iz 0) $iz)
+  (equal? (+ $-iz 0) $-iz)
+  (equal? (+ 0 $iz) $iz)
+  (equal? (+ 0 $-iz) $-iz)
+  (equal? (- $n 0) $n)
+  (equal? (- $-n 0) $-n)
+  (equal? (- 0 $n) $-n)
+  (equal? (- 0 $-n) $n)
+  (equal? (- $q 0) $q)
+  (equal? (- $-q 0) $-q)
+  (equal? (- 0 $q) $-q)
+  (equal? (- 0 $-q) $q)
+  (equal? (- $x 0) $x)
+  (equal? (- $-x 0) $-x)
+  (equal? (- 0 $x) $-x)
+  (equal? (- 0 $-x) $x)
+  (equal? (- $ez 0) $ez)
+  (equal? (- $-ez 0) $-ez)
+  (equal? (- 0 $ez) $-ez)
+  (equal? (- 0 $-ez) $ez)
+  (equal? (- $iz 0) $iz)
+  (equal? (- $-iz 0) $-iz)
+  (equal? (- 0 $iz) $-iz)
+  (equal? (- 0 $-iz) $iz)
+  (equal? (- 0 (most-negative-fixnum)) (+ (most-positive-fixnum) 1))
+)
+
+(mat benchmarks
+  (let ()
+    ; revert to the original values for benchmarking
+    (define runs 1 #;10)
+    (define iter 1 #;100000)
+    (define min-ns 0 #;#e25e7)
+
+    (define time->ns
+      (lambda (t)
+        (+ (* (time-second t) 1000000000) (time-nanosecond t))))
+
+    (define mean
+      (lambda (ls)
+        (assert (not (null? ls)))
+        (/ (apply + ls) (length ls))))
+
+    (define stddev
+      (lambda (m ls)
+        (define (square x) (* x x))
+        (sqrt (mean (map (lambda (x) (square (- x m))) ls)))))
+
+    (define ($run-one expr th expected)
+      (define (do-big-iter)
+        (collect 0 0)
+        (let ([t0 (current-time 'time-monotonic)])
+          (do ([iter iter (#3%fx- iter 1)] [ans #f (th)])
+            ((#3%fx= iter 0)
+             (let ([t (time-difference t0 (current-time 'time-monotonic))])
+               (unless (equal? ans expected) (errorf #f "oops ~s != ~s for ~s" ans expected expr))
+               t)))))
+      (parameterize ([collect-request-handler void])
+        (collect (collect-maximum-generation))
+        ; warm up and calibrate number of ITERATIONS to at least meet min-ns
+        (let ([ITER (let loop ([ITER 1] [t (make-time 'time-duration 0 0)])
+                      (let ([t (time-difference t (do-big-iter))])
+                        (if (>= (time->ns t) min-ns)
+                            ITER
+                            (loop (fx+ ITER 1) t))))])
+          (do ([run runs (#3%fx- run 1)]
+               [t* '() (cons
+                         (let loop ([ITER ITER] [t (make-time 'time-duration 0 0)])
+                           (do ([ITER ITER (#3%fx- ITER 1)]
+                                [t (make-time 'time-duration 0 0) (time-difference t (do-big-iter))])
+                             ((#3%fx= ITER 0) t)))
+                         t*)])
+            ((#3%fx= run 0)
+             (let ([ns* (map time->ns (reverse t*))])
+               (let ([m (mean ns*)])
+                 (printf "~s\n" (vector expr (/ m ITER) (if (= m 0) 0 (/ (stddev m ns*) m)) ITER))
+                 (flush-output-port))))))))
+
+    (let ()
+      (define (run sra)
+        (define-syntax run-one
+          (lambda (x)
+            (define prettify
+              (lambda (x)
+                (let-values ([(neg? x) (if (< x 0) (values #t (- x)) (values #f x))])
+                  (let ([s (format "~{~a~^+~}"
+                             (let loop ([x x] [k 0] [ls '()])
+                               (let ([b (bitwise-first-bit-set x)])
+                                 (if (= b -1)
+                                     ls
+                                     (let ([k (+ k b)])
+                                       (loop (bitwise-arithmetic-shift-right x (fx+ b 1)) (fx+ k 1)
+                                         (cons (if (= k 0) "1" (format "2^~a" k)) ls)))))))])
+                    (if neg? (format "-(~a)" s) s)))))
+            (syntax-case x ()
+              [(_ sra x k expected)
+               (with-syntax ([n (eval (datum x))])
+                 (with-syntax ([expr (format "(sra ~a ~s)" (prettify (datum n)) (datum k))])
+                   #'($run-one expr (lambda () (sra n k)) expected)))])))
+        (printf "((iter . ~s) (min-ns . ~s))\n" iter min-ns)
+        (printf "(\n")
+        (run-one sra 1 1 0)
+        (run-one sra (ash 1 1024) 1024 1)
+        (run-one sra (ash 1 1024) 512 (ash 1 512))
+        (run-one sra (- (ash 1 1024)) 1024 -1)
+        (run-one sra (- (ash 1 1024)) 512 (- (ash 1 512)))
+        (run-one sra (+ (ash 1 1024) 1) 1024 1)
+        (run-one sra (+ (ash 1 1024) 1) 512 (ash 1 512))
+        (run-one sra (- (+ (ash 1 1024) 1)) 1024 -2)
+        (run-one sra (- (+ (ash 1 1024) 1)) 512 (- -1 (ash 1 512)))
+        (run-one sra (- (ash 1 1024)) 1024 -1)
+        (run-one sra (- (ash 1 1024)) 512 (- (ash 1 512)))
+        (run-one sra (ash 1 1024) 1025 0)
+        (run-one sra (- (ash 1 1024)) 1025 -1)
+        (run-one sra (ash 3 1023) 1024 1)
+        (run-one sra (- (ash 3 1023)) 1024 -2)
+        (run-one sra (ash 3 1023) 1025 0)
+        (run-one sra (- (ash 3 1023)) 1025 -1)
+        (run-one sra (ash 1 1000000) 1000000 1)
+        (run-one sra (- (ash 1 1000000)) 1000000 -1)
+        (run-one sra (ash 1 1000000) 1000001 0)
+        (run-one sra (- (ash 1 1000000)) 1000001 -1)
+        (run-one sra (ash 3 1000000) 1000001 1)
+        (run-one sra (- (ash 3 1000000)) 1000001 -2)
+        (run-one sra (ash 3 1000000) 1000002 0)
+        (run-one sra (- (ash 3 1000000)) 1000002 -1)
+        ; worst-case---only shifted-off one bit is in the middle
+        (run-one sra (- (+ (ash 1 1024) (ash 1 512))) 1024 -2)
+        ; shift by one bit
+        (run-one sra (ash 3 1000000) 1 (ash 3 999999))
+        (run-one sra (- (ash 3 1000000)) 1 (- (ash 3 999999)))
+        (printf ")\n"))
+
+      (run bitwise-arithmetic-shift-right)
+      (run (lambda (x k) (bitwise-arithmetic-shift x (- k))))
+      (run (lambda (x k) (ash x (- k)))))
+
+    (let ()
+      (define (run)
+        (define $x 123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789)
+        (define $y (* (most-positive-fixnum) 2))
+        (define-syntax run-one
+          (syntax-rules ()
+            [(_ expr expected)
+             ($run-one 'expr (lambda () expr) expected)]
+            [(_ expr expected ...)
+             ($run-one 'expr (lambda () (call-with-values (lambda () expr) list)) (list expected ...))]))
+        (define $2x (* 2 $x))
+        (define $x+2 (+ $x 2))
+        (define $-x (- $x))
+        (define $x^4 (* $x $x $x $x))
+        (define $-x^4 (- $x^4))
+        (define $2y (* $y 2))
+        (define $y+2 (+ $y 2))
+        (printf "((iter . ~s) (min-ns . ~s) ($x . ~s) ($y . ~s))\n" iter min-ns $x $y)
+        (printf "(\n")
+        (run-one 0 0)
+        (run-one (* $x 0) 0)
+        (run-one (* $x^4 0) 0)
+        (run-one (* $x 1) $x)
+        (run-one (* $x^4 1) $x^4)
+        (run-one (* $x -1) $-x)
+        (run-one (* $x^4 -1) $-x^4)
+        (run-one (* 1 $x) $x)
+        (run-one (* 1 $x^4) $x^4)
+        (run-one (* -1 $x) $-x)
+        (run-one (* -1 $x^4) $-x^4)
+        (run-one (/ $x 1) $x)
+        (run-one (/ $x^4 1) $x^4)
+        (run-one (/ $x -1) $-x)
+        (run-one (/ $x^4 -1) $-x^4)
+        (run-one (+ $x 0) $x)
+        (run-one (+ $x^4 0) $x^4)
+        (run-one (- $x 0) $x)
+        (run-one (- $x^4 0) $x^4)
+        (run-one (+ 0 $x) $x)
+        (run-one (+ 0 $x^4) $x^4)
+        (run-one (- 0 $x) $-x)
+        (run-one (- 0 $x^4) $-x^4)
+        (run-one (quotient $x 1) $x)
+        (run-one (quotient $x^4 1) $x^4)
+        (run-one (quotient $x -1) $-x)
+        (run-one (remainder $x 1) 0)
+        (run-one (remainder $x^4 1) 0)
+        (run-one (remainder $x -1) 0)
+        (run-one (div-and-mod $x 1) $x 0)
+        (run-one (div-and-mod $x^4 1) $x^4 0)
+        (run-one (div-and-mod $x -1) $-x 0)
+        (run-one (div0-and-mod0 $x 1) $x 0)
+        (run-one (div0-and-mod0 $x^4 1) $x^4 0)
+        (run-one (div0-and-mod0 $x -1) $-x 0)
+        (run-one (div $x 1) $x)
+        (run-one (div $x^4 1) $x^4)
+        (run-one (div $x -1) $-x)
+        (run-one (div0 $x 1) $x)
+        (run-one (div0 $x^4 1) $x^4)
+        (run-one (div0 $x -1) $-x)
+        (run-one (mod $x 1) 0)
+        (run-one (mod $x^4 1) 0)
+        (run-one (mod $x -1) 0)
+        (run-one (mod0 $x 1) 0)
+        (run-one (mod0 $x^4 1) 0)
+        (run-one (mod0 $x -1) 0)
+        ; these should not improve and we hope not slow down measurably
+        (run-one (* $y 2) $2y)
+        (run-one (/ $2y 2) $y)
+        (run-one (+ $y 2) $y+2)
+        (run-one (- $y -2) $y+2)
+        (run-one (quotient $y 2) (ash $y -1))
+        (run-one (remainder $y 2) (logand $y 1))
+        (run-one (div-and-mod $2y 2) $y 0)
+        (run-one (div0-and-mod0 $2y 2) $y 0)
+        (run-one (div $2y 2) $y)
+        (run-one (div0 $2y 2) $y)
+        (run-one (mod $2y 2) 0)
+        (run-one (mod0 $2y 2) 0)
+        (printf ")\n"))
+
+      (run))
+
+    ; use with --program to compare results
+    #;(top-level-program
+      (import (chezscheme))
+
+      (unless (= (length (command-line-arguments)) 3)
+        (fprintf (current-error-port) "usage: ~a: <output-file> <before-input-file> <after-input-file>\n" (car (command-line)))
+        (exit 1))
+
+      (let ([reportfn (car (command-line-arguments))]
+            [beforefn (cadr (command-line-arguments))]
+            [afterfn (caddr (command-line-arguments))])
+        (let-values ([(before-info before) (with-input-from-file beforefn (lambda () (let ([info (read)]) (values info (read)))))]
+                     [(after-info after) (with-input-from-file afterfn (lambda () (let ([info (read)]) (values info (read)))))])
+          (with-output-to-file reportfn
+            (lambda ()
+              (unless (equal? before-info after-info) (errorf #f "before info ~s and after info ~s differ" before-info after-info))
+              (let ([iter (cond [(assq 'iter before-info) => cdr] [else (errorf #f "expected to find binding for iter in info\n")])])
+                (printf "<html><head><title>Results ~a</title></head><body><table cellspacing=\"10em\">\n" (machine-type))
+                (printf "<p>~{~a~^<br>~}</p>" (map (lambda (a) (format "~s = ~s" (car a) (cdr a))) before-info))
+                (printf "<tr><th align=left>expression</th><th align=right>speedup</th><th align=right>before stddev</th><th align=right>after stddev</th><th align=right>before time (x~s)</th><th align=right>after time (x~s)</th><th align=right>before iterations</th><th align=right>after iterations</th></tr>\n" iter iter)
+                (for-each
+                  (lambda (before after)
+                    (define EXPR 0)
+                    (define MEAN-NS 1)
+                    (define STDDEV 2)
+                    (define ITER 3)
+                    (for-each
+                      (lambda (i)
+                        (unless (equal? (vector-ref before i) (vector-ref after i))
+                          (errorf #f "comparing apples to oranges: ~s, ~s" before after)))
+                      (list EXPR))
+                    (printf "<tr><td align=left>~a</td><td align=right>~5,2f%</td><td align=right>~7,4f%</td><td align=right>~7,4f%</td><td align=right>~10,8f</td><td align=right>~10,8f</td><td align=right>~s</td><td align=right>~s</td></tr>\n"
+                      (vector-ref before EXPR)
+                      (* (/ (- (vector-ref before MEAN-NS) (vector-ref after MEAN-NS)) (vector-ref before MEAN-NS)) 100)
+                      (vector-ref before STDDEV)
+                      (vector-ref after STDDEV)
+                      (/ (vector-ref before MEAN-NS) (expt 10 9))
+                      (/ (vector-ref after MEAN-NS) (expt 10 9))
+                      (vector-ref before ITER)
+                      (vector-ref after ITER)
+                      ))
+                  before
+                  after)
+                (printf "</table></body></html>\n")))
+            'replace))))
+    #t)
+)
+
 (mat popcount
   (error? (fxpopcount #f))
   (error? (fxpopcount 1.0))

mats/6.ms

@@ -727,6 +727,11 @@
            (eqv? (read-char x) #\a)
            (char-ready? x)
            (eof-object? (read-char x))))
+   (parameterize ([current-input-port (open-input-string "a")])
+      (and (char-ready?)
+           (eqv? (read-char) #\a)
+           (char-ready?)
+           (eof-object? (read-char))))
  )
 
 (mat clear-input-port ; test interactively
@@ -1654,25 +1659,24 @@
     #t)
   (error?
     (let* ([ip (open-file-input-port "testfile.ss")]
-           [sfd (#%$source-file-descriptor "testfile.ss" ip)]
+           [sfd (make-source-file-descriptor "testfile.ss" ip #t)]
            [ip (transcoded-port ip (native-transcoder))])
       (dynamic-wind
         void
-        (lambda () (read-token ip sfd))
+        (lambda () (read-token ip sfd 0))
         (lambda () (close-input-port ip)))))
   (let ()
     (with-output-to-file "testfile.ss"
       (lambda () (display "\neat\n"))
       'replace)
     #t)
-  ; $transcoded-source-port is no more
+  (equal?
-  #;(equal?
     (let-values ([vals (let* ([ip (open-file-input-port "testfile.ss")]
-                              [sfd (#%$source-file-descriptor "testfile.ss" ip)]
+                              [sfd (make-source-file-descriptor "testfile.ss" ip #t)]
-                              [ip (#%$transcoded-source-port ip (native-transcoder))])
+                              [ip (transcoded-port ip (native-transcoder))])
                          (dynamic-wind
                            void
-                           (lambda () (read-token ip sfd))
+                           (lambda () (read-token ip sfd 0))
                            (lambda () (close-input-port ip))))])
       vals)
     '(atomic eat 1 4))

mats/8.ms

@@ -8487,7 +8487,7 @@
     "inside testfile-a3-9\n")
   (equal?
     (with-output-to-string (lambda () (load "testfile-a3-10.so")))
-    "outside (testfile-a3-8)\ninside testfile-a3-10\n")
+    "inside testfile-a3-10\n")
 )
 
 (mat library4
@@ -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?
@@ -9033,8 +9132,82 @@
      (string-append
       "123\n"
       "123\n"
-      "Exception in visit: library (testfile-lr-l4) is not visible\n"
+      "Exception in environment: attempt to import invisible library (testfile-lr-l4)\n"
-      "Exception in visit: library (testfile-lr-l4) is not visible\n"))))
+      "Exception in environment: attempt to import invisible library (testfile-lr-l4)\n"))))
+
+(mat invoke-library
+  (error? ; invalid library reference
+     (invoke-library '(testfile-il1 (<= 3))))
+  (error? ; invalid library reference
+     (invoke-library '(testfile-il1 (what?))))
+  (error? ; invalid library reference
+     (invoke-library '()))
+  (error? ; invalid library reference
+     (invoke-library 'hello))
+  (error? ; invalid library reference
+     (invoke-library '(3 2 1)))
+  (begin
+    (mkfile "testfile-il1.ss"
+      '(library (testfile-il1 (2)) (export a) (import (chezscheme)) (define a 3) (printf "invoked (testfile-il1)\n")))
+    #t)
+  (equal?
+    (separate-eval
+      '(let () (import (testfile-il1)) a))
+    "invoked (testfile-il1)\n3\n")
+  (equal?
+    (separate-eval
+      '(invoke-library '(testfile-il1)))
+    "invoked (testfile-il1)\n")
+  (equal?
+    (separate-eval
+      '(invoke-library '(testfile-il1))
+      '(printf "hello\n")
+      '(let () (import (testfile-il1)) a))
+    "invoked (testfile-il1)\nhello\n3\n")
+  (equal?
+    (separate-eval
+      '(let () (import (testfile-il1)) a)
+      '(printf "hello\n")
+      '(invoke-library '(testfile-il1)))
+    "invoked (testfile-il1)\n3\nhello\n")
+  (begin
+    (separate-eval '(compile-library "testfile-il1"))
+    #t)
+  (delete-file "testfile-il1.ss")
+  (equal?
+    (separate-eval
+      '(let () (import (testfile-il1)) a))
+    "invoked (testfile-il1)\n3\n")
+  (equal?
+    (separate-eval
+      '(invoke-library '(testfile-il1)))
+    "invoked (testfile-il1)\n")
+  (equal?
+    (separate-eval
+      '(invoke-library '(testfile-il1))
+      '(printf "hello\n")
+      '(let () (import (testfile-il1)) a))
+    "invoked (testfile-il1)\nhello\n3\n")
+  (equal?
+    (separate-eval
+      '(let () (import (testfile-il1)) a)
+      '(printf "hello\n")
+      '(invoke-library '(testfile-il1)))
+    "invoked (testfile-il1)\n3\nhello\n")
+  (error? ; version mismatch
+    (separate-eval '(invoke-library '(testfile-il1 (3)))))
+  (error? ; version mismatch
+    (separate-eval
+      '(invoke-library '(testfile-il1 ((>= 3))))))
+  (equal?
+    (separate-eval
+      '(invoke-library '(testfile-il1 ((>= 2)))))
+    "invoked (testfile-il1)\n")
+  (equal?
+    (separate-eval
+      '(invoke-library '(testfile-il1 (2))))
+    "invoked (testfile-il1)\n")
+)
 
 (mat cross-library-optimization
   (begin
@@ -9568,6 +9741,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 +9790,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 +10572,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\"\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))
 )
 

mats/Mf-base

@@ -106,10 +106,10 @@ cis = $(defaultcis)
 defaultspi = f
 spi = $(defaultspi)
 
-# ehc defines the value to which $enable-check-heap is set:
+# hci defines the value to which heap-check-interval (mat.ss) is set:
-# f for #f, t for #t
+# 0 to disable, > 0 to enable
-defaultehc = f
+defaulthci = 0
-ehc = $(defaultehc)
+hci = $(defaulthci)
 
 # eoc determines whether object counts are enabled
 defaulteoc = t
@@ -123,8 +123,15 @@ cl = $(defaultcl)
 defaultecpf = t
 ecpf = $(defaultecpf)
 
+# c determines whether mat coverage (.covout) files are created
+defaultc = f
+c = $(defaultc)
+
+# set of coverage files to load
+coverage-files = ../boot/$m/petite.covin ../boot/$m/scheme.covin
+
 # set of mats to run
-mats = primvars 3 4 5_1 5_2 5_3 5_4 5_5 bytevector thread\
+mats = primvars 3 4 5_1 5_2 5_3 5_4 5_5 bytevector thread profile\
  misc cp0 cptypes 5_6 5_7 5_8 6 io format 7 record hash enum 8 fx fl cfl foreign\
  ftype unix windows examples ieee date exceptions oop
 
@@ -140,15 +147,15 @@ src = $(mats:%=%.ms)
 
 # prettysrc is src to use for pretty-print test; we leave out mat files
 # with cycles, e.g., primvars.ms, misc.ms, 4.ms, 5_1.ms, hash.ms
-prettysrc = 3.ms 5_3.ms 5_4.ms 5_5.ms bytevector.ms\
+prettysrc = 3.ms 5_3.ms 5_4.ms 5_5.ms bytevector.ms thread.ms profile.ms\
- thread.ms 5_6.ms 5_7.ms 5_8.ms 6.ms io.ms format.ms 7.ms record.ms enum.ms 8.ms\
+ 5_6.ms 5_7.ms 5_8.ms 6.ms io.ms format.ms 7.ms record.ms enum.ms 8.ms\
  fx.ms fl.ms cfl.ms foreign.ms unix.ms windows.ms examples.ms ieee.ms date.ms\
  exceptions.ms
 
 $(objdir)/%.mo : %.ms mat.so
 	echo '(optimize-level $o)'\
              '(#%$$suppress-primitive-inlining #${spi})'\
-             '(#%$$enable-check-heap #${ehc})'\
+             '(heap-check-interval ${hci})'\
              '(#%$$enable-check-prelex-flags #${ecpf})'\
              '(compile-profile #$p)'\
              '(collect-trip-bytes ${ctb})'\
@@ -161,6 +168,7 @@ $(objdir)/%.mo : %.ms mat.so
              '(enable-cp0 #${cp0})'\
              '(set! *scheme* "${Scheme}")'\
              '(current-eval ${eval})'\
+             '(when #$c (coverage-table (load-coverage-files ${coverage-files:%="%"})))'\
              '(time ((mat-file "$(objdir)") "$*"))'\
              '(unless (= (#%$$check-heap-errors) 0)'\
              '  (fprintf (console-error-port) "check heap detected errors---grep standard output for !!!\n")'\
@@ -171,7 +179,7 @@ $(objdir)/%.mo : %.ms mat.so
 %.mo : %.ms mat.so
 	echo '(optimize-level $o)'\
              '(#%$$suppress-primitive-inlining #${spi})'\
-             '(#%$$enable-check-heap #${ehc})'\
+             '(heap-check-interval ${hci})'\
              '(#%$$enable-check-prelex-flags #${ecpf})'\
              '(compile-profile #$p)'\
              '(collect-trip-bytes ${ctb})'\
@@ -184,6 +192,7 @@ $(objdir)/%.mo : %.ms mat.so
              '(enable-cp0 #${cp0})'\
              '(set! *scheme* "${Scheme}")'\
              '(current-eval ${eval})'\
+             '(when #$c (coverage-table (load-coverage-files ${coverage-files:%="%"})))'\
              '(time ((mat-file ".") "$*"))'\
              '(parameterize ([source-directories (quote ("." "../s"))]) (when #${pdhtml} (profile-dump-html)))'\
              '(unless (= (#%$$check-heap-errors) 0)'\
@@ -225,6 +234,21 @@ fastreport:
 	$(MAKE) doerrors
 	$(MAKE) doreport
 
+docoverage: mat.so
+	if [ "$c" = "t" ] ; then\
+          echo '(reset-handler abort) (combine-coverage-files "$(objdir)/all.covout" (quote ($(mats:%="$(objdir)/%.covout"))))' | ${Scheme} -q ${patchfile} mat.so ;\
+          echo '(reset-handler abort) (coverage-percent "$(objdir)/all.covout" ${coverage-files:%="%"})'  | ${Scheme} -q ${patchfile} mat.so ;\
+          echo '(reset-handler abort) (coverage-percent "$(objdir)/run.covout" ${coverage-files:%="%"})'  | ${Scheme} -q ${patchfile} mat.so ;\
+        fi
+
+doallcoverage: mat.so
+	if [ "$c" = "t" ] ; then\
+          echo '(reset-handler abort) (combine-coverage-files "all.covout" (map symbol->string (quote ($(shell echo */all.covout)))))' | ${Scheme} -q ${patchfile} mat.so ;\
+          echo '(reset-handler abort) (coverage-percent "all.covout" ${coverage-files:%="%"})'  | ${Scheme} -q ${patchfile} mat.so ;\
+          echo '(reset-handler abort) (combine-coverage-files "run.covout" (map symbol->string (quote ($(shell echo */run.covout)))))' | ${Scheme} -q ${patchfile} mat.so ;\
+          echo '(reset-handler abort) (coverage-percent "run.covout" ${coverage-files:%="%"})'  | ${Scheme} -q ${patchfile} mat.so ;\
+        fi
+
 partialx:
 	$(MAKE) allxhelp o=0
 	$(MAKE) allxhelp o=3
@@ -242,8 +266,9 @@ allx: prettyclean
 	$(MAKE) allxhelp o=3 eval=interpret cl=6
 	$(MAKE) allxhelp o=0 eval=interpret cp0=t rmg=2
 	$(MAKE) allxhelp o=3 eval=interpret cp0=t rmg=2
-	$(MAKE) allxhelp o=0 eoc=f ehc=t cl=9
+	$(MAKE) allxhelp o=0 eoc=f hci=101 cl=9
-	$(MAKE) allxhelp o=3 eval=interpret ehc=t rmg=2
+	$(MAKE) allxhelp o=3 eval=interpret hci=101 rmg=2
+	$(MAKE) doallcoverage
 
 just-reports:
 	for EVAL in compile interpret ; do\
@@ -264,16 +289,17 @@ bullyx:
 
 bully:
 	-$(MAKE) allxhelpnotall spi=t cp0=f
-	-$(MAKE) allxhelp spi=f cp0=f cl=9 ctb='(/ (collect-trip-bytes) 64)' ehc=t
+	-$(MAKE) allxhelp spi=f cp0=f cl=9 ctb='(/ (collect-trip-bytes) 64)' hci=503
 	-$(MAKE) allxhelp spi=t cp0=f cis=t cmg=1
-	-$(MAKE) allxhelp spi=f cp0=f cis=t cmg=6 ehc=t
+	-$(MAKE) allxhelp spi=f cp0=f cis=t cmg=6 hci=101
 	-$(MAKE) allxhelp spi=t cp0=t ctb='(/ (collect-trip-bytes) 64)' cgr=6
-	-$(MAKE) allxhelp spi=t cp0=f p=t eoc=f ehc=t
+	-$(MAKE) allxhelp spi=t cp0=f p=t eoc=f hci=101
-	-$(MAKE) allxhelp spi=f cp0=t cl=9 p=t ehc=t
+	-$(MAKE) allxhelp spi=f cp0=t cl=9 p=t hci=101
 	-$(MAKE) allxhelp eval=interpret spi=f cp0=f
 	-$(MAKE) allxhelp eval=interpret spi=f cp0=t
-	-$(MAKE) allxhelp eval=interpret spi=t cp0=f ctb='(/ (collect-trip-bytes) 64)' ehc=t
+	-$(MAKE) allxhelp eval=interpret spi=t cp0=f ctb='(/ (collect-trip-bytes) 64)' hci=503
-	-$(MAKE) allxhelp eval=interpret spi=t cp0=t cgr=2 ehc=t p=t
+	-$(MAKE) allxhelp eval=interpret spi=t cp0=t cgr=2 hci=101 p=t
+	$(MAKE) doallcoverage
 
 allxhelp:
 	$(MAKE) doheader
@@ -283,7 +309,7 @@ allxhelp:
 doheader:
 	printf "%s" "-------- o=$o" >> summary
 	if [ "$(spi)" != "$(defaultspi)" ] ; then printf " spi=$(spi)" >> summary ; fi
-	if [ "$(ehc)" != "$(defaultehc)" ] ; then printf " ehc=$(ehc)" >> summary ; fi
+	if [ "$(hci)" != "$(defaulthci)" ] ; then printf " hci=$(hci)" >> summary ; fi
 	if [ "$(ecpf)" != "$(defaultecpf)" ] ; then printf " ecpf(ecpf)" >> summary ; fi
 	if [ "$(cp0)" != "$(defaultcp0)" ] ; then printf " cp0=$(cp0)" >> summary ; fi
 	if [ "$(cis)" != "$(defaultcis)" ] ; then printf " cis=$(cis)" >> summary ; fi
@@ -309,23 +335,25 @@ allxhelpnotall:
 	$(MAKE) doheader hdrmsg="not all"
 	-$(MAKE)
 	$(MAKE) dosummary
+	$(MAKE) docoverage
 
 all0: ; $(MAKE) all o=0
 all1: ; $(MAKE) all o=1
 all2: ; $(MAKE) all o=2
 all3: ; $(MAKE) all o=3
 
-all: makescript$o $(src) oop.ss ht.ss mat.so cat_flush ${fobj} m4test.in m4test.out prettytest.ss ftype.h freq.in freq.out ${patchfile} examples
+all: makescript$o $(src) oop.ss ht.ss mat.so cat_flush ${fobj} m4test.in m4test.out prettytest.ss ftype.h freq.in freq.out ${patchfile} build-examples
 	${Scheme} --verbose -q mat.so ${patchfile} < script.all$o
 	$(MAKE) doerrors
 	$(MAKE) doreport
+	$(MAKE) docoverage
 
 script.all$o: Mf-base
 
 script.all$o makescript$o:
 	echo '(optimize-level $o)'\
              '(#%$$suppress-primitive-inlining #${spi})'\
-             '(#%$$enable-check-heap #${ehc})'\
+             '(heap-check-interval ${hci})'\
              '(#%$$enable-check-prelex-flags #${ecpf})'\
              '(compile-profile #$p)'\
              '(collect-trip-bytes ${ctb})'\
@@ -338,12 +366,15 @@ script.all$o makescript$o:
              '(enable-cp0 #${cp0})'\
              '(set! *scheme* "${Scheme}")'\
              '(current-eval ${eval})'\
-             '(time (for-each (mat-file "$(objdir)")'\
+             '(when #$c (coverage-table (load-coverage-files ${coverage-files:%="%"})))'\
+             '(record-run-coverage "$(objdir)/run.covout"'\
+             '  (lambda ()'\
+             '    (time (for-each (lambda (x) (time ((mat-file "$(objdir)") x)))'\
              '            (quote ($(mats:%="%")))))'\
              '    (parameterize ([source-directories (quote ("." "../s"))]) (when #${pdhtml} (profile-dump-html)))'\
              '    (unless (= (#%$$check-heap-errors) 0)'\
              '      (fprintf (console-error-port) "check heap detected errors---grep standard output for !!!\n")'\
-             '  (abort))'\
+             '      (abort))))'\
           > script.all$o
 
 source:
@@ -373,23 +404,26 @@ bullyprettytest.ss: ${src}
 mat.so: ${patchfile}
 foreign.mo ${objdir}/foreign.mo: ${fobj}
 thread.mo ${objdir}/thread.mo: ${fobj}
-examples.mo ${objdir}/examples.mo: m4test.in m4test.out freq.in freq.out examples
+examples.mo ${objdir}/examples.mo: m4test.in m4test.out freq.in freq.out build-examples
 6.mo ${objdir}/6.mo: prettytest.ss
+bytevector.mo ${objdir}/bytevector.mo: prettytest.ss
 io.mo ${objdir}/io.mo: prettytest.ss
 unix.mo ${objdir}/unix.mo io.mo ${objdir}/io.mo 6.mo ${objdir}/6.mo: cat_flush
 oop.mo ${objdir}/oop.mo: oop.ss
 ftype.mo ${objdir}/ftype.mo: ftype.h
 hash.mo ${objdir}/hash.mo: ht.ss
 
-examples:
+build-examples:
 	( cd ../examples && ${MAKE} Scheme=${Scheme} )
+	touch build-examples
 
 prettyclean:
-	rm -f *.o ${mdclean} *.so *.mo experr* errors* report* summary testfile* testscript\
+	rm -f *.o ${mdclean} *.so *.mo *.covout experr* errors* report* summary testfile* testscript\
  ${fobj} prettytest.ss cat_flush so_locations\
- script.all? *.html experr*.rej experr*.orig
+ build-examples script.all? *.html experr*.rej experr*.orig
 	rm -rf testdir*
 	rm -rf output-*
+	( cd ../examples && ${MAKE} Scheme=${Scheme} clean )
 
 clean: prettyclean
 	rm -f Make.out

mats/bytevector.ms

@@ -11275,9 +11275,8 @@
     (number? (bytevector-ieee-double-native-ref immutable-100-bytevector 0))
 )
 
-
 (mat bytevector-compress
-    (parameters [compress-format 'gzip 'lz4])
+    (parameters [compress-format 'gzip 'lz4] [compress-level 'minimum 'low 'medium 'high 'maximum])
     (error? (bytevector-compress 7))
     (error? (bytevector-compress "hello"))
     (error? (bytevector-uncompress 7))

mats/cp0.ms

@@ -910,7 +910,7 @@
     'a)
  ; verify optimization of or pattern
   (equivalent-expansion?
-    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2] [compile-profile #f])
       (expand/optimize
         '(lambda (x y) (if (not (or (fx< x y) (fx> y x))) x y))))
     '(lambda (x.0 y.1)
@@ -918,7 +918,7 @@
            y.1
            x.0)))
   (equivalent-expansion?
-    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2] [compile-profile #f])
       (expand/optimize
         '(lambda (x y) (if (or (fx< x y) (fx> y x)) x y))))
     '(lambda (x y) (if (if (#2%fx< x y) #t (#3%fx> y x)) x y)))
@@ -2845,7 +2845,7 @@
     ; does push (make-message-condition y) because it is pure, even though one of the vars (z) is assigned
     '(lambda (y) (let ([z #f]) (#3%list (lambda () (set! z 15) z) (#3%make-message-condition y)))))
   (equivalent-expansion?
-    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2] [compile-profile #f])
       (expand/optimize
         '(let ()
            (define-record foo ((immutable boolean x)))
@@ -2858,7 +2858,7 @@
          #t
          e2))
   (equivalent-expansion?
-    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 3])
+    (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 3] [compile-profile #f])
       (expand/optimize
         '(let ()
            (define-record foo ((immutable boolean x)))

mats/foreign.ms

@@ -2970,8 +2970,8 @@
   (check-union [x float 58.0] [y int 0])
   (check-union [x double 68.0] [y int 0])
 
-  ;; Check that `__collect_safe` saves a argument and result floating-point registers
+  ;; Check that `__collect_safe` saves argument and result floating-point registers
-  ;; while activating and deacttiving a thread
+  ;; while activating and deactivating a thread
   (let ()
     (define-ftype T (struct [d double] [i integer-8] [n int]))
     (define sum_pre_double_double_double_double_double_double_double_double

mats/hash.ms

@@ -3942,19 +3942,20 @@
     (with-output-to-file "testfile.ss"
       (lambda ()
         (pretty-print
-          '(begin
+          '(module ($feh-ls $feh-ht)
-             (define-syntax $feh-ls
+             (define-syntax ls
                (let ([ls '(1 2 3)])
                  (lambda (x)
                    #`(quote #,(datum->syntax #'* ls)))))
+             (define $feh-ls ls)
              (define $feh-ht
                (let ()
                  (define-syntax a
                    (let ([ht (make-eq-hashtable)])
                      (eq-hashtable-set! ht 'q 'p)
-                     (eq-hashtable-set! ht $feh-ls (cdr $feh-ls))
+                     (eq-hashtable-set! ht ls (cdr ls))
-                     (eq-hashtable-set! ht (cdr $feh-ls) (cddr $feh-ls))
+                     (eq-hashtable-set! ht (cdr ls) (cddr ls))
-                     (eq-hashtable-set! ht (cddr $feh-ls) $feh-ls)
+                     (eq-hashtable-set! ht (cddr ls) ls)
                      (lambda (x) #`(quote #,(datum->syntax #'* ht)))))
                  a)))))
       'replace)

mats/mat.ss

@@ -40,8 +40,6 @@
 
 (define enable-cp0 (make-parameter #f))
 
-(define mat-run)
-(define mat-file)
 (define-syntax mat/cf
   (syntax-rules (testfile)
     [(_ (testfile ?path) expr ...)
@@ -55,9 +53,9 @@
        #t)]
     [(_ expr ...) (mat/cf (testfile "testfile") expr ...)]))
 
-(let ()
+(define mat-output (make-parameter (current-output-port)))
 
-(define *mat-output* (current-output-port))
+(let ()
 
 (define mat-load
   (lambda (in)
@@ -74,8 +72,8 @@
               (if (warning? c)
                   (raise-continuable c)
                   (begin
-                    (fprintf *mat-output* "Error reading mat input: ")
+                    (fprintf (mat-output) "Error reading mat input: ")
-                    (display-condition c *mat-output*)
+                    (display-condition c (mat-output))
                     (reset))))
             (lambda () (load in))))))))
 
@@ -174,10 +172,10 @@
               (call-with-values
                 (lambda () (#%$locate-source sfd fp #t))
                 (case-lambda
-                  [() (fprintf *mat-output* "~a at char ~a of ~a~%" msg fp (source-file-descriptor-path sfd))]
+                  [() (fprintf (mat-output) "~a at char ~a of ~a~%" msg fp (source-file-descriptor-path sfd))]
-                  [(path line char) (fprintf *mat-output* "~a at line ~a, char ~a of ~a~%" msg line char path)]))))
+                  [(path line char) (fprintf (mat-output) "~a at line ~a, char ~a of ~a~%" msg line char path)]))))
-          (fprintf *mat-output* "~a~%" msg))
+          (fprintf (mat-output) "~a~%" msg))
-      (flush-output-port *mat-output*))))
+      (flush-output-port (mat-output)))))
 
 (define ununicode
  ; sanitizer for expected exception messages to make sure we don't end up
@@ -192,6 +190,38 @@
             [(fx> (char->integer c) 127) (fprintf op "U+~x" (char->integer c)) (f)]
             [else (write-char c op) (f)]))))))
 
+(define store-coverage
+  (lambda (universe-ct ct path)
+    (call-with-port
+      (open-file-output-port path
+        (file-options replace compressed)
+        (buffer-mode block)
+        (current-transcoder))
+      (lambda (op)
+        (put-source-table op
+          (if (eq? universe-ct ct)
+              ct
+              (let ([new-ct (make-source-table)])
+                (for-each
+                  (lambda (p)
+                    (let ([src (car p)] [count (cdr p)])
+                      (when (source-table-contains? universe-ct src)
+                        (source-table-set! new-ct src count))))
+                  (source-table-dump ct))
+                new-ct)))))))
+
+(define load-coverage
+  (lambda (ct)
+    (lambda (path)
+      (call-with-port
+        (open-file-input-port path
+          (file-options compressed)
+          (buffer-mode block)
+          (current-transcoder))
+        (lambda (ip) (get-source-table! ip ct +))))))
+
+(set! coverage-table (make-parameter #f))
+
 (set! mat-file
   (lambda (dir)
     (unless (string? dir)
@@ -199,22 +229,56 @@
     (unless (file-exists? dir) (mkdir dir))
     (lambda (mat)
       (unless (string? mat)
-        (errorf 'mat-file "~s is not a string" fn))
+        (errorf 'mat-file "~s is not a string" mat))
       (let ([ifn (format "~a.ms" mat)] [ofn (format "~a/~a.mo" dir mat)])
         (printf "matting ~a with output to ~a~%" ifn ofn)
         (delete-file ofn #f)
-        (fluid-let ([*mat-output* (open-output-file ofn)])
+        (parameterize ([mat-output (open-output-file ofn)])
           (dynamic-wind
             (lambda () #f)
-            (lambda () (mat-load ifn))
+            (lambda ()
-            (lambda () (close-output-port *mat-output*))))))))
+              (let ([go (lambda () (mat-load ifn))] [universe-ct (coverage-table)])
+                (if universe-ct
+                    (let-values ([(ct . ignore) (with-profile-tracker go)])
+                      (store-coverage universe-ct ct (format "~a/~a.covout" dir mat)))
+                    (go))))
+            (lambda () (close-output-port (mat-output)))))))))
+
+(set! record-run-coverage
+  (lambda (covout th)
+    (let ([universe-ct (coverage-table)])
+      (if universe-ct
+          (let-values ([(ct . ignore) (with-profile-tracker #t th)])
+            (store-coverage universe-ct ct covout))
+          (th)))))
+
+(set! load-coverage-files
+  (lambda path*
+    (let ([ct (make-source-table)])
+      (for-each (load-coverage ct) path*)
+      ct)))
+
+(set! combine-coverage-files
+  (lambda (covout covout*)
+    (let ([ct (make-source-table)])
+      (for-each (load-coverage ct) covout*)
+      (store-coverage ct ct covout))))
+
+(set! coverage-percent
+  (lambda (covout . covin*)
+    (let ([n (source-table-size (load-coverage-files covout))]
+          [d (source-table-size (apply load-coverage-files covin*))])
+      (printf "~a: covered ~s of ~s source expressions (~s%)\n"
+        covout n d (round (/ (* n 100) d))))))
 
 (set! mat-run
   (case-lambda
     [(name)
-       (fprintf *mat-output* "Warning: empty mat for ~s.~%" name)]
+     (fprintf (mat-output) "Warning: empty mat for ~s.~%" name)]
     [(name . clauses)
-       (fprintf *mat-output* "~%Starting mat ~s.~%" name)
+     (fprintf (mat-output) "~%Starting mat ~s.~%" name)
+     ; release counters for reclaimed code objects between mat groups to reduce gc time
+     (when (compile-profile) (profile-release-counters))
      (do ([clauses clauses (cdr clauses)]
           [count 1 (+ count 1)])
        ((null? clauses) 'done)
@@ -224,22 +288,22 @@
              (if (warning? c)
                  (raise-continuable c)
                  (begin
-                       (fprintf *mat-output* "Error printing mat clause: ")
+                   (fprintf (mat-output) "Error printing mat clause: ")
-                       (display-condition c *mat-output*)
+                   (display-condition c (mat-output))
                    (reset))))
            (lambda ()
-                 (pretty-print clause *mat-output*)
+             (pretty-print clause (mat-output))
-                 (flush-output-port *mat-output*)))
+             (flush-output-port (mat-output))))
          (if (and (list? clause)
                   (= (length clause) 2)
                   (memq (car clause) '(sanitized-error? error? warning?)))
              (let ([expect (case (car clause) [(sanitized-error? error?) 'error] [(warning?) 'warning])])
                (if (and (= (optimize-level) 3) (eq? expect 'error))
-                        (fprintf *mat-output* "Ignoring error check at optimization level 3.~%")
+                   (fprintf (mat-output) "Ignoring error check at optimization level 3.~%")
                    (let ([ans (mat-one-exp expect (lambda () (eval (cadr clause))) (eq? (car clause) 'sanitized-error?))])
                      (cond
                        [(and (pair? ans) (eq? (car ans) expect))
-                             (fprintf *mat-output*
+                        (fprintf (mat-output)
                           "Expected ~s in mat ~s: \"~a\".~%"
                           expect name (ununicode (cdr ans)))]
                        [else
@@ -296,8 +360,7 @@
                    (and (fxvector? y)
                         (fx= (fxvector-length x) (fxvector-length y))
                         (let f ([i (fx- (fxvector-length x) 1)])
-                          (if (fx< i 0)
+                          (or (fx< i 0)
-                              k
                               (and (fx= (fxvector-ref x i) (fxvector-ref y i))
                                    (f (fx1- i))))))]
                   [(box? x) (and (box? y) (e? (unbox x) (unbox y)))]
@@ -364,7 +427,7 @@
         (list->string (subst #\\ #\/ (string->list p)))
         p)))
 
-(module (separate-eval run-script separate-compile)
+(module separate-eval-tools (separate-eval run-script separate-compile)
   (define (slurp ip)
     (with-output-to-string
       (lambda ()
@@ -383,7 +446,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)))
@@ -409,6 +476,7 @@
       [(x) (separate-compile 'compile-file x)]
       [(cf x) ($separate-eval 'separate-compile `((,cf ,(if (symbol? x) (format "testfile-~a" x) x))))])))
 
+(import separate-eval-tools)
 
 #;(collect-request-handler
   (begin
@@ -440,12 +508,13 @@
 (define test-cp0-expansion
   (rec test-cp0-expansion
     (case-lambda
-      [(expr result) (test-cp0-expansion equivalent-expansion? expr result)]
+      [(expr expected) (test-cp0-expansion equivalent-expansion? expr expected)]
-      [(equiv? expr result)
+      [(equiv? expr expected)
-       (equiv?
+       (let ([actual (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-         (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+                       (expand/optimize `(let () (import scheme) ,expr)))])
-           (expand/optimize `(let () (import scheme) ,expr)))
+         (unless (equiv? actual expected)
-         result)])))
+           (errorf 'test-cp0-expansion "expected ~s for ~s, got ~s\n" expected expr actual))
+         #t)])))
 
 (define rm-rf
   (lambda (path)
@@ -474,3 +543,21 @@
           (sleep (make-time 'time-duration 1000000 1))
           (loop))))
     #t))
+
+(define preexisting-profile-dump-entry?
+  (let ([ht (make-eq-hashtable)])
+    (for-each (lambda (x) (eq-hashtable-set! ht (car x) #t)) (profile-dump))
+    (lambda (x) (eq-hashtable-contains? ht (car x)))))
+
+(define heap-check-interval (make-parameter 0))
+
+(collect-request-handler
+  (let ([counter 0])
+    (lambda ()
+      (parameterize ([#%$enable-check-heap
+                       (let ([interval (heap-check-interval)])
+                         (and (not (fx= interval 0))
+                              (let ([n (fxmod (fx+ counter 1) interval)])
+                                (set! counter n)
+                                (fx= n 0))))])
+        (collect)))))

mats/misc.ms

@@ -1614,639 +1614,6 @@
        0))
 )
 
-(mat compile-profile
-  (error? ; invalid argument
-    (compile-profile 'src))
-  (eqv?
-    (parameterize ([compile-profile #t])
-      (compile-profile))
-    'source)
-  (eqv?
-    (parameterize ([compile-profile 'source])
-      (compile-profile))
-    'source)
-  (eqv?
-    (parameterize ([compile-profile 'block])
-      (compile-profile))
-    'block)
-  (error? ; incorrect argument count
-    (profile-dump '()))
-  (error? ; incorrect argument count
-    (profile-clear '()))
-  (error? ; incorrect argument count
-    (profile-dump-list #t '() 3))
-  (error? ; invalid dump
-    (profile-dump-list #f 17))
-  (error? ; invalid dump
-    (profile-dump-list #f '(17)))
-  (error? ; invalid dump
-    (profile-dump-list #f '((a . 17))))
-  (error? ; invalid dump
-    (profile-dump-list #f `((,(make-source-object (source-file-descriptor "abc" 34) 0 3) . q))))
-  (error? ; incorrect argument count
-    (profile-dump-html "" '() 3))
-  (error? ; not a string
-    (profile-dump-html '(prefix)))
-  (error? ; invalid dump
-    (profile-dump-html "profile" 17))
-  (error? ; invalid dump
-    (profile-dump-html "profile" '(17)))
-  (error? ; invalid dump
-    (profile-dump-html "profile" '((a . 17))))
-  (error? ; invalid dump
-    (profile-dump-html "profile" `((,(make-source-object (source-file-descriptor "abc" 34) 0 3) . q))))
-  (error? ; incorrect argument count
-    (profile-dump-data))
-  (error? ; incorrect argument count
-    (profile-dump-data "profile.data" '() 'q))
-  (error? ; not a string
-    (profile-dump-data #t))
-  (error? ; invalid dump
-    (profile-dump-data "profile.data" 17))
-  (error? ; invalid dump
-    (profile-dump-data "profile.data" '(17)))
-  (error? ; invalid dump
-    (profile-dump-data "profile.data" '((a . 17))))
-  (error? ; invalid dump
-    (profile-dump-data "profile.data" `((,(make-source-object (source-file-descriptor "abc" 34) 0 3) . q))))
-  (error? ; not a string
-    (profile-load-data 'what?))
-  (eqv? (parameterize ([compile-profile #t])
-          (compile
-            '(let ()
-               (define (f x) (if (= x 0) 1 (* x (f (- x 1)))))
-               (f 3))))
-        6)
-  (eqv? (parameterize ([compile-profile #t])
-          (compile
-            '(let ()
-               (define fat+
-                 (lambda (x y)
-                   (if (zero? y)
-                       x
-                       (fat+ (1+ x) (1- y)))))
-               (define fatfib
-                 (lambda (x)
-                   (if (< x 2)
-                       1
-                       (fat+ (fatfib (1- x)) (fatfib (1- (1- x)))))))
-               (fatfib 20))))
-         10946)
-  (equal?
-    (parameterize ([compile-profile #t])
-      (compile
-        '(let ()
-           (define $values (lambda (n) (lambda () (apply values (make-list n)))))
-           (define foo
-             (lambda (n)
-               (call/cc
-                 (lambda (k)
-                   (with-exception-handler
-                     (lambda (c) (collect) (k 'okay))
-                     (lambda ()
-                       (define f (case-lambda))
-                       (let ([x (random 10)])
-                         (call-with-values ($values n) f))))))))
-           (list (foo 0) (foo 1) (foo 3) (foo 10) (foo 100) (foo 1000)))))
-    '(okay okay okay okay okay okay))
-  ; no longer recording (useless) profiling information when source file & position aren't available
-  #;(let ([ls (profile-dump)])
-    (and (list? ls)
-      (not (null? ls))))
-  (eqv? (profile-clear) (void))
-  (or (eq? (compile-profile) 'source) (andmap zero? (map cdr (profile-dump))))
-  (begin (set! cp-fatfib (void)) #t) ; release fatfib
-
-  (begin (define $old-cp (compile-profile)) #t)
-  ; this collect is here to make it more likely that we won't get a generation 1
-  ; collection cementing in place the code that defines cp-fact
-  (begin (collect 1) #t)
-  (mat/cf (testfile "testfile")
-    (eval-when (compile) (compile-profile 'source))
-    (define (cp-fact x) (if (= x 0) 1 (* x (cp-fact (- x 1))))))
-  (eq? (compile-profile) $old-cp)
-  ; drop code that defines cp-fact so it won't show up in profile-dump-list in
-  ; hopes of resolving potential issue with comparison to pdl further down
-  (begin (collect (collect-maximum-generation)) #t)
-  (= (cp-fact 10) 3628800)
-  (begin
-    (define-values (pdl pdl2)
-      (with-interrupts-disabled
-        (values
-          (profile-dump-list #t (profile-dump))
-          (profile-dump-list))))
-    #t)
-  (equal? pdl pdl2)
-  (not (null? pdl))
-  (begin
-    (rm-rf "testdir")
-    (mkdir "testdir")
-    (parameterize ([gensym-prefix 0]) (profile-dump-html "testdir/" (profile-dump)))
-    #t)
-  (file-exists? "testdir/profile.html")
-  (file-exists? "testdir/testfile.ss.html")
-
-  (begin (define $old-cp (compile-profile)) #t)
-  (mat/cf (testfile "testfile-block")
-    (eval-when (compile) (compile-profile 'block))
-    (define (cp-fact-block x) (if (= x 0) 1 (* x (cp-fact-block (- x 1))))))
-  (eq? (compile-profile) $old-cp)
-  (= (cp-fact-block 10) 3628800)
-  (or (equal? (compile-profile) 'source) (equal? (profile-dump-list) pdl))
-  (begin
-    (profile-dump-html)
-    #t)
-  (file-exists? "profile.html")
-  (file-exists? "testfile.ss.html")
-  (not (file-exists? "testfile2.ss.html"))
-
-  (eqv? (profile-clear) (void))
-
-  (mat/cf (testfile "testfile")
-    (eval-when (compile) (compile-profile #t))
-    (define (cp-fact x) (if (= x 0) 1 (* x (cp-fact (- x 1))))))
-  (= (cp-fact 10) 3628800)
-  (eqv? (profile-dump-data "testfile1.pd") (void))
-  (file-exists? "testfile1.pd")
-  (eqv? (profile-load-data "testfile1.pd") (void))
-  (begin
-    (define $cp-ip (open-file-input-port "testfile.ss"))
-    (define $cp-sfd (make-source-file-descriptor "testfile.ss" $cp-ip))
-    (define $qw (lambda (bfp efp) (profile-query-weight (make-source-object $cp-sfd bfp efp))))
-    #t)
-
-  (eqv? (close-port $cp-ip) (void))
-
-  (eqv? ($qw 0 0) 0.0) ; bfp, efp combination not in database
-  (eqv? ; file not in database
-    (let* ([ip (open-file-input-port "Mf-base")]
-           [sfd (make-source-file-descriptor "Mf-base" ip)])
-      (close-port ip)
-      (profile-query-weight (make-source-object sfd 0 0)))
-    #f)
-  ((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0))) #t)) ($qw 0 42))
-  ((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0))) #t)) ($qw 43 102))
-  (eqv? ($qw 63 101) 1.0)
-  (eqv? ($qw 75 76) (fl/ 1.0 11.0))
-  (eqv? ($qw 77 100) (fl/ 10.0 11.0))
-  ((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0))) #t)) ($qw 103 127))
-  (eqv? ($qw 119 126) 0.0)
-  (eqv? ($qw 120 125) 0.0)
-  (eqv? (profile-clear) (void))
-  (= (cp-fact 5) 120)
-  (eqv? (profile-dump-data "testfile2.pd") (void))
-  (eqv? (profile-load-data "testfile2.pd") (void))
-  ((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0) (fl/ (/ 1.0 11.0) 2.0))) #t)) ($qw 0 42))
-  (eqv? ($qw 21 40) 0.0)
-  ((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0) (fl/ (/ 1.0 11.0) 2.0))) #t)) ($qw 43 102))
-  (eqv? ($qw 63 101) 1.0)
-  (eqv? ($qw 75 76) (fl/ (fl+ (/ 1.0 11.0) (fl/ 1.0 6.0)) 2.0))
-  (eqv? ($qw 77 100) (fl/ (fl+ (fl/ 10.0 11.0) (fl/ 5.0 6.0)) 2.0))
-  ((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0) (fl/ (/ 1.0 11.0) 2.0))) #t)) ($qw 103 127))
-  (eqv? ($qw 119 126) 0.0)
-  (eqv? ($qw 120 125) 0.0)
-  (eqv? (profile-clear) (void))
-
-  ; make sure all is well when compiled with source profile info
-  (mat/cf (testfile "testfile")
-    (eval-when (compile) (compile-profile 'block))
-    (define (cp-fact x) (if (= x 0) 1 (* x (cp-fact (- x 1))))))
-  (eqv? (profile-dump-data "testfile3.pd") (void))
-  (file-exists? "testfile3.pd")
-  (eqv? (profile-load-data "testfile3.pd") (void))
-  ; and again with block profile info
-  (mat/cf (testfile "testfile")
-    (eval-when (compile) (compile-profile #f))
-    (define (cp-fact x) (if (= x 0) 1 (* x (cp-fact (- x 1))))))
-  (= (cp-fact 5) 120)
-
-  (eqv? (profile-clear-database) (void))
-  (eqv? ($qw 0 42) #f)
-  (eqv? ($qw 77 100) #f)
-
-  ; make sure record-ref, record-type, and record-cd are properly handled by
-  ; find-source in pdhtml
-  (mat/cf
-    (eval-when (compile) (compile-profile #t))
-    (library (A) (export make-foo foo? foo-x) (import (chezscheme)) (define-record-type foo (fields x)))
-    (let ()
-      (import (A))
-      (define add-foo-xs
-        (lambda ls
-          (let f ([ls ls] [sum 0])
-            (if (null? ls) sum (f (cdr ls) (+ (foo-x (car ls)) sum))))))
-      ; make sure this is still around when we call profile-dump-list
-      (set! $add-foo-xs add-foo-xs)
-      (pretty-print (add-foo-xs (make-foo 1) (make-foo 2) (make-foo 3)))))
-  (not (null? (profile-dump-list)))
-  (eqv? (profile-clear) (void))
-  (begin (set! $add-foo-xs #f) #t)
-
-  (vector? (profile-palette))
-  (vector?
-    (parameterize ([profile-palette (vector-map
-                                      (lambda (p) (cons "white" (car p)))
-                                      (profile-palette))])
-      (profile-palette)))
-  (parameterize ([profile-palette
-                  '#(("black" . "white")
-                     ("red" . "white")
-                     ("blue" . "black"))])
-    (= (vector-length (profile-palette)) 3))
-  (error? (profile-palette '#()))
-  (error? (profile-palette '#(("black" . "white"))))
-  (error? (profile-palette '#(("black" . "white") ("red" . "white"))))
-  (error?
-    (profile-palette
-      '#(("black" . "white")
-         #("red" "white")
-         ("blue" . "black"))))
-  (error?
-    (profile-palette
-      '#(("black" . "white")
-         ("red" . "white")
-         ("blue" . black))))
-  (error?
-    (profile-palette
-      '#(("black" . "white")
-         ("red" . "white")
-         (#x0000ff . "black"))))
-  ; test for proper counts in the presence of control operators
-  (begin
-    (define $return)
-    (define $retry)
-    (with-output-to-file "testfile-cp1.ss"
-      (lambda ()
-        (display-string "\
-(define $frumble
-  (lambda (ls)
-    (if (null? ls)
-        1
-        (let ([n (car ls)])
-          (if (eqv? n 0)
-              (call/cc (lambda (k) (set! $retry k) ($return 0)))
-              (let ([q ($frumble (cdr ls))])
-                (add1 (* q n))))))))
-"))
-      'replace)
-    (profile-clear)
-    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2] [compile-profile #t])
-      (load "testfile-cp1.ss" compile))
-    #t)
-  (eqv?
-    ($frumble (make-list 100 5))
-    9860761315262647567646607066034827870915080438862787559628486633300781)
-  (equal?
-    (filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list))
-    '((101 "testfile-cp1.ss" 36 258 3 5)
-      (101 "testfile-cp1.ss" 40 50 3 9)
-      (101 "testfile-cp1.ss" 41 46 3 10)
-      (101 "testfile-cp1.ss" 47 49 3 16)
-      (100 "testfile-cp1.ss" 69 257 5 9)
-      (100 "testfile-cp1.ss" 78 86 5 18)
-      (100 "testfile-cp1.ss" 79 82 5 19)
-      (100 "testfile-cp1.ss" 83 85 5 23)
-      (100 "testfile-cp1.ss" 99 256 6 11)
-      (100 "testfile-cp1.ss" 103 113 6 15)
-      (100 "testfile-cp1.ss" 104 108 6 16)
-      (100 "testfile-cp1.ss" 109 110 6 21)
-      (100 "testfile-cp1.ss" 111 112 6 23)
-      (100 "testfile-cp1.ss" 193 255 8 15)
-      (100 "testfile-cp1.ss" 202 221 8 24)
-      (100 "testfile-cp1.ss" 203 211 8 25)
-      (100 "testfile-cp1.ss" 212 220 8 34)
-      (100 "testfile-cp1.ss" 213 216 8 35)
-      (100 "testfile-cp1.ss" 217 219 8 39)
-      (100 "testfile-cp1.ss" 240 254 9 17)
-      (100 "testfile-cp1.ss" 241 245 9 18)
-      (100 "testfile-cp1.ss" 246 253 9 23)
-      (100 "testfile-cp1.ss" 247 248 9 24)
-      (100 "testfile-cp1.ss" 249 250 9 26)
-      (100 "testfile-cp1.ss" 251 252 9 28)
-      (1 "testfile-cp1.ss" 0 260 1 1)
-      (1 "testfile-cp1.ss" 19 259 2 3)
-      (1 "testfile-cp1.ss" 59 60 4 9)
-      (0 "testfile-cp1.ss" 128 178 7 15)
-      (0 "testfile-cp1.ss" 129 136 7 16)
-      (0 "testfile-cp1.ss" 137 177 7 24)
-      (0 "testfile-cp1.ss" 149 164 7 36)
-      (0 "testfile-cp1.ss" 162 163 7 49)
-      (0 "testfile-cp1.ss" 165 176 7 52)
-      (0 "testfile-cp1.ss" 166 173 7 53)
-      (0 "testfile-cp1.ss" 174 175 7 61)))
-  (eqv? 
-    (call/cc
-      (lambda (k)
-        (set! $return k)
-        (let ([ans ($frumble (append (make-list 50 5) (list 0) (make-list 50 7)))])
-          ($return ans))))
-    0)
-  (equal?
-    (filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list))
-    '((152 "testfile-cp1.ss" 36 258 3 5)
-      (152 "testfile-cp1.ss" 40 50 3 9)
-      (152 "testfile-cp1.ss" 41 46 3 10)
-      (152 "testfile-cp1.ss" 47 49 3 16)
-      (151 "testfile-cp1.ss" 69 257 5 9)
-      (151 "testfile-cp1.ss" 78 86 5 18)
-      (151 "testfile-cp1.ss" 79 82 5 19)
-      (151 "testfile-cp1.ss" 83 85 5 23)
-      (151 "testfile-cp1.ss" 99 256 6 11)
-      (151 "testfile-cp1.ss" 103 113 6 15)
-      (151 "testfile-cp1.ss" 104 108 6 16)
-      (151 "testfile-cp1.ss" 109 110 6 21)
-      (151 "testfile-cp1.ss" 111 112 6 23)
-      (150 "testfile-cp1.ss" 193 255 8 15)
-      (150 "testfile-cp1.ss" 202 221 8 24)
-      (150 "testfile-cp1.ss" 203 211 8 25)
-      (150 "testfile-cp1.ss" 212 220 8 34)
-      (150 "testfile-cp1.ss" 213 216 8 35)
-      (150 "testfile-cp1.ss" 217 219 8 39)
-      (100 "testfile-cp1.ss" 240 254 9 17)
-      (100 "testfile-cp1.ss" 241 245 9 18)
-      (100 "testfile-cp1.ss" 246 253 9 23)
-      (100 "testfile-cp1.ss" 247 248 9 24)
-      (100 "testfile-cp1.ss" 249 250 9 26)
-      (100 "testfile-cp1.ss" 251 252 9 28)
-      (1 "testfile-cp1.ss" 0 260 1 1)
-      (1 "testfile-cp1.ss" 19 259 2 3)
-      (1 "testfile-cp1.ss" 59 60 4 9)
-      (1 "testfile-cp1.ss" 128 178 7 15)
-      (1 "testfile-cp1.ss" 129 136 7 16)
-      (1 "testfile-cp1.ss" 137 177 7 24)
-      (1 "testfile-cp1.ss" 149 164 7 36)
-      (1 "testfile-cp1.ss" 162 163 7 49)
-      (1 "testfile-cp1.ss" 165 176 7 52)
-      (1 "testfile-cp1.ss" 166 173 7 53)
-      (1 "testfile-cp1.ss" 174 175 7 61)))
-  (eqv?
-    (call/cc
-      (lambda (k)
-        (set! $return k)
-        ($retry 1)))
-    111022302462515654042363166809082031)
-  (equal?
-    (filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list))
-    '((152 "testfile-cp1.ss" 36 258 3 5)
-      (152 "testfile-cp1.ss" 40 50 3 9)
-      (152 "testfile-cp1.ss" 41 46 3 10)
-      (152 "testfile-cp1.ss" 47 49 3 16)
-      (151 "testfile-cp1.ss" 69 257 5 9)
-      (151 "testfile-cp1.ss" 78 86 5 18)
-      (151 "testfile-cp1.ss" 79 82 5 19)
-      (151 "testfile-cp1.ss" 83 85 5 23)
-      (151 "testfile-cp1.ss" 99 256 6 11)
-      (151 "testfile-cp1.ss" 103 113 6 15)
-      (151 "testfile-cp1.ss" 104 108 6 16)
-      (151 "testfile-cp1.ss" 109 110 6 21)
-      (151 "testfile-cp1.ss" 111 112 6 23)
-      (150 "testfile-cp1.ss" 193 255 8 15)
-      (150 "testfile-cp1.ss" 202 221 8 24)
-      (150 "testfile-cp1.ss" 203 211 8 25)
-      (150 "testfile-cp1.ss" 212 220 8 34)
-      (150 "testfile-cp1.ss" 213 216 8 35)
-      (150 "testfile-cp1.ss" 217 219 8 39)
-      (150 "testfile-cp1.ss" 240 254 9 17)
-      (150 "testfile-cp1.ss" 241 245 9 18)
-      (150 "testfile-cp1.ss" 246 253 9 23)
-      (150 "testfile-cp1.ss" 247 248 9 24)
-      (150 "testfile-cp1.ss" 249 250 9 26)
-      (150 "testfile-cp1.ss" 251 252 9 28)
-      (1 "testfile-cp1.ss" 0 260 1 1)
-      (1 "testfile-cp1.ss" 19 259 2 3)
-      (1 "testfile-cp1.ss" 59 60 4 9)
-      (1 "testfile-cp1.ss" 128 178 7 15)
-      (1 "testfile-cp1.ss" 129 136 7 16)
-      (1 "testfile-cp1.ss" 137 177 7 24)
-      (1 "testfile-cp1.ss" 149 164 7 36)
-      (1 "testfile-cp1.ss" 162 163 7 49)
-      (1 "testfile-cp1.ss" 165 176 7 52)
-      (1 "testfile-cp1.ss" 166 173 7 53)
-      (1 "testfile-cp1.ss" 174 175 7 61)))
-  (begin
-    (collect (collect-maximum-generation)) ; drop code object for the define and lambda
-    (profile-release-counters) ; drop proile information for the dropped code object
-    #t)
-  (equal?
-    (filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list))
-    '((152 "testfile-cp1.ss" 36 258 3 5)
-      (152 "testfile-cp1.ss" 40 50 3 9)
-      (152 "testfile-cp1.ss" 41 46 3 10)
-      (152 "testfile-cp1.ss" 47 49 3 16)
-      (151 "testfile-cp1.ss" 69 257 5 9)
-      (151 "testfile-cp1.ss" 78 86 5 18)
-      (151 "testfile-cp1.ss" 79 82 5 19)
-      (151 "testfile-cp1.ss" 83 85 5 23)
-      (151 "testfile-cp1.ss" 99 256 6 11)
-      (151 "testfile-cp1.ss" 103 113 6 15)
-      (151 "testfile-cp1.ss" 104 108 6 16)
-      (151 "testfile-cp1.ss" 109 110 6 21)
-      (151 "testfile-cp1.ss" 111 112 6 23)
-      (150 "testfile-cp1.ss" 193 255 8 15)
-      (150 "testfile-cp1.ss" 202 221 8 24)
-      (150 "testfile-cp1.ss" 203 211 8 25)
-      (150 "testfile-cp1.ss" 212 220 8 34)
-      (150 "testfile-cp1.ss" 213 216 8 35)
-      (150 "testfile-cp1.ss" 217 219 8 39)
-      (150 "testfile-cp1.ss" 240 254 9 17)
-      (150 "testfile-cp1.ss" 241 245 9 18)
-      (150 "testfile-cp1.ss" 246 253 9 23)
-      (150 "testfile-cp1.ss" 247 248 9 24)
-      (150 "testfile-cp1.ss" 249 250 9 26)
-      (150 "testfile-cp1.ss" 251 252 9 28)
-      (1 "testfile-cp1.ss" 59 60 4 9)
-      (1 "testfile-cp1.ss" 128 178 7 15)
-      (1 "testfile-cp1.ss" 129 136 7 16)
-      (1 "testfile-cp1.ss" 137 177 7 24)
-      (1 "testfile-cp1.ss" 149 164 7 36)
-      (1 "testfile-cp1.ss" 162 163 7 49)
-      (1 "testfile-cp1.ss" 165 176 7 52)
-      (1 "testfile-cp1.ss" 166 173 7 53)
-      (1 "testfile-cp1.ss" 174 175 7 61)))
-  ; test profiling with compiled files
-  (begin
-    (with-output-to-file "testfile-cp2.ss"
-      (lambda ()
-        (display-string "\
-(define cp2-fib
-  (rec fib
-    (lambda (n)
-      (cond
-        [(fx= n 0) 1]
-        [(fx= n 1) 1]
-        [else (+ (fib (- n 1)) (fib (- n 2)))]))))
-"))
-      'replace)
-    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2] [compile-profile #t])
-      (compile-file "testfile-cp2"))
-    (profile-clear)
-    (load "testfile-cp2.so")
-    #t)
-  (eqv? (cp2-fib 10) 89)
-  (equal?
-    (filter (lambda (x) (equal? (cadr x) "testfile-cp2.ss")) (profile-dump-list))
-    '((177 "testfile-cp2.ss" 49 146 4 7)
-      (177 "testfile-cp2.ss" 64 73 5 10)
-      (177 "testfile-cp2.ss" 65 68 5 11)
-      (177 "testfile-cp2.ss" 69 70 5 15)
-      (177 "testfile-cp2.ss" 71 72 5 17)
-      (143 "testfile-cp2.ss" 86 95 6 10)
-      (143 "testfile-cp2.ss" 87 90 6 11)
-      (143 "testfile-cp2.ss" 91 92 6 15)
-      (143 "testfile-cp2.ss" 93 94 6 17)
-      (88 "testfile-cp2.ss" 113 144 7 15)
-      (88 "testfile-cp2.ss" 114 115 7 16)
-      (88 "testfile-cp2.ss" 116 129 7 18)
-      (88 "testfile-cp2.ss" 117 120 7 19)
-      (88 "testfile-cp2.ss" 121 128 7 23)
-      (88 "testfile-cp2.ss" 122 123 7 24)
-      (88 "testfile-cp2.ss" 124 125 7 26)
-      (88 "testfile-cp2.ss" 126 127 7 28)
-      (88 "testfile-cp2.ss" 130 143 7 32)
-      (88 "testfile-cp2.ss" 131 134 7 33)
-      (88 "testfile-cp2.ss" 135 142 7 37)
-      (88 "testfile-cp2.ss" 136 137 7 38)
-      (88 "testfile-cp2.ss" 138 139 7 40)
-      (88 "testfile-cp2.ss" 140 141 7 42)
-      (55 "testfile-cp2.ss" 96 97 6 20)
-      (34 "testfile-cp2.ss" 74 75 5 20)
-      (1 "testfile-cp2.ss" 0 149 1 1)
-      (1 "testfile-cp2.ss" 18 148 2 3)
-      (1 "testfile-cp2.ss" 23 26 2 8)
-      (1 "testfile-cp2.ss" 31 147 3 5)))
-  (begin
-    (collect (collect-maximum-generation)) ; drop code object for the define and lambda
-    (profile-release-counters) ; drop proile information for the dropped code object
-    #t)
-  (equal?
-    (filter (lambda (x) (equal? (cadr x) "testfile-cp2.ss")) (profile-dump-list))
-    '((177 "testfile-cp2.ss" 49 146 4 7)
-      (177 "testfile-cp2.ss" 64 73 5 10)
-      (177 "testfile-cp2.ss" 65 68 5 11)
-      (177 "testfile-cp2.ss" 69 70 5 15)
-      (177 "testfile-cp2.ss" 71 72 5 17)
-      (143 "testfile-cp2.ss" 86 95 6 10)
-      (143 "testfile-cp2.ss" 87 90 6 11)
-      (143 "testfile-cp2.ss" 91 92 6 15)
-      (143 "testfile-cp2.ss" 93 94 6 17)
-      (88 "testfile-cp2.ss" 113 144 7 15)
-      (88 "testfile-cp2.ss" 114 115 7 16)
-      (88 "testfile-cp2.ss" 116 129 7 18)
-      (88 "testfile-cp2.ss" 117 120 7 19)
-      (88 "testfile-cp2.ss" 121 128 7 23)
-      (88 "testfile-cp2.ss" 122 123 7 24)
-      (88 "testfile-cp2.ss" 124 125 7 26)
-      (88 "testfile-cp2.ss" 126 127 7 28)
-      (88 "testfile-cp2.ss" 130 143 7 32)
-      (88 "testfile-cp2.ss" 131 134 7 33)
-      (88 "testfile-cp2.ss" 135 142 7 37)
-      (88 "testfile-cp2.ss" 136 137 7 38)
-      (88 "testfile-cp2.ss" 138 139 7 40)
-      (88 "testfile-cp2.ss" 140 141 7 42)
-      (55 "testfile-cp2.ss" 96 97 6 20)
-      (34 "testfile-cp2.ss" 74 75 5 20)))
-  (eqv? (profile-clear) (void))
-  (begin
-    (with-output-to-file "testfile.ss"
-      (lambda ()
-        (pretty-print
-          '(define f (lambda () 0))))
-      'replace)
-    (parameterize ([compile-profile #t]) (load "testfile.ss" compile))
-    #t)
-  (begin
-    (with-output-to-file "testfile.ss"
-      (lambda ()
-        (pretty-print
-          '(define f (lambda () 1))))
-      'replace)
-    #t)
-  (eqv? (f) 0)
-  (warning? ; unmodified source file not found
-    (profile-dump-list))
-  (warning? ; unmodified source file not found
-    (profile-dump-list #t))
-  (warning? ; unmodified source file not found
-    (profile-dump-list #t (profile-dump)))
-  (warning? ; unmodified source file not found
-    (profile-dump-list #t (profile-dump)))
-  (guard (c [else #f])
-    (profile-dump-list #f)
-    #t)
-  (guard (c [else #f])
-    (profile-dump-list #f (profile-dump))
-    #t)
-  (eqv? (profile-clear) (void))
-)
-
-(mat profile-form
-  (error? ; invalid syntax
-    (profile))
-  (error? ; invalid syntax
-    (profile 1 2 3))
-  (error? ; not a source object
-    (profile 3))
-  (begin
-    (define str "(ugh (if \x3b2;))")
-    (define bv (string->utf8 str))
-    (define ip (open-bytevector-input-port bv))
-    (define sfd (make-source-file-descriptor "foo" ip #t))
-    #t)
-  (eq? (eval `(profile ,(make-source-object sfd 2 3))) (void))
-  (begin
-    (define compile-triv-file
-      (lambda (ifn ofn)
-        (define insert-profile-forms
-          (lambda (x)
-            (unless (annotation? x) (errorf 'compile-triv-file "expected an annotation, got ~s" x))
-            (let ([src (annotation-source x)] [exp (annotation-expression x)])
-              `(begin (profile ,src)
-                 ,(syntax-case exp ()
-                    [(?do-times n e)
-                      (eq? (annotation-expression #'?do-times) 'do-times)
-                      (let ([n (annotation-expression #'n)])
-                        `(do ([i ,n (fx- i 1)]) ((fx= i 0)) ,(insert-profile-forms #'e)))]
-                    [(?print string)
-                      (eq? (annotation-expression #'?print) 'print)
-                      `(printf "~a\n" ,(annotation-expression #'string))]
-                    [else (syntax-error exp)])))))
-        (define parse
-          (lambda (ifn)
-            (let ([ip (open-file-input-port ifn)])
-              (let ([sfd (make-source-file-descriptor ifn ip #t)])
-                (let ([ip (transcoded-port ip (native-transcoder))])
-                  (let f ([bfp 0])
-                    (let-values ([(x bfp) (get-datum/annotations ip sfd bfp)])
-                      (if (eof-object? x)
-                          (begin (close-port ip) '())
-                          (cons x (f bfp))))))))))
-        (parameterize ([compile-profile 'source] [generate-profile-forms #f])
-          (compile-to-file (list `(define (triv) ,@(map insert-profile-forms (parse ifn)))) ofn))))
-    #t)
-  (begin
-    (with-output-to-file "testfile-triv.ss"
-      (lambda ()
-        (pretty-print '(do-times 10 (print "hello")))
-        (pretty-print '(do-times 5 (print "goodbye"))))
-      'replace)
-    (compile-triv-file "testfile-triv.ss" "testfile-triv.so")
-    (load "testfile-triv.so")
-    #t)
-  (equal?
-    (with-output-to-string triv)
-    "hello\nhello\nhello\nhello\nhello\nhello\nhello\nhello\nhello\nhello\ngoodbye\ngoodbye\ngoodbye\ngoodbye\ngoodbye\n")
-  (equal?
-    (sort
-      ; sort by bfp
-      (lambda (x y) (< (list-ref x 2) (list-ref y 2)))
-      (filter (lambda (x) (equal? (list-ref x 1) "testfile-triv.ss")) (profile-dump-list)))
-    '((1 "testfile-triv.ss" 0 29 1 1)
-      (10 "testfile-triv.ss" 13 28 1 14)
-      (1 "testfile-triv.ss" 30 60 2 1)
-      (5 "testfile-triv.ss" 42 59 2 13)))
-  (eqv? (profile-clear) (void))
-)
-
 (mat generate-procedure-source-information
   (begin
     (define the-source
@@ -2316,11 +1683,12 @@
       'replace)
     (with-output-to-file "testfile-sff-1c.ss"
       (lambda ()
+        (pretty-print '(define preexisting-entries (length (profile-dump))))
         (pretty-print '(eval-when (compile) (import (add-prefix (testfile-sff-1a) sff-1a-))))
         (pretty-print '(eval-when (compile) (import (add-prefix (testfile-sff-1b) sff-1b-))))
         (pretty-print '(pretty-print (list (sff-1a-x 3) sff-1b-y)))
         (pretty-print '(pretty-print (not (((inspect/object sff-1a-x) 'code) 'source))))
-        (pretty-print '(pretty-print (null? (profile-dump-list)))))
+        (pretty-print '(pretty-print (= (length (profile-dump)) preexisting-entries))))
       'replace)
     (separate-compile
       '(lambda (x)
@@ -2330,8 +1698,13 @@
            (compile-file x)))
       'sff-1c)
     #t)
-  (equal?
+  (begin
+    (define (go)
       (separate-eval
+        '(define preexisting-entries
+           (with-exception-handler
+             (lambda (c) (unless (warning? c) (raise-continuable c)))
+             (lambda () (length (profile-dump-list)))))
         '(import (testfile-sff-1a))
         '(import (testfile-sff-1b))
         '(define-syntax so?
@@ -2340,55 +1713,35 @@
                [(_ q) (and (syntax->annotation #'q) #t)])))
         '(list a (b so?) (x 3) y)
         '(not (((inspect/object x) 'code) 'source))
-      '(null? (profile-dump-list)))
+        '(define all-entries
+           (with-exception-handler
+             (lambda (c) (unless (warning? c) (raise-continuable c)))
+             (lambda () (length (profile-dump-list)))))
+        '(= all-entries preexisting-entries)))
+    #t)
+  (equal?
+    (go)
     "(120 #t 6 24)\n#f\n#f\n")
   (strip-and-check "testfile-sff-1a.so" "testfile-sff-1a.so"
     (fasl-strip-options inspector-source))
   (strip-and-check "testfile-sff-1b.so" "testfile-sff-1b.so"
     (fasl-strip-options inspector-source))
   (equal?
-    (separate-eval
+    (go)
-      '(import (testfile-sff-1a))
-      '(import (testfile-sff-1b))
-      '(define-syntax so?
-         (lambda (x)
-           (syntax-case x ()
-             [(_ q) (and (syntax->annotation #'q) #t)])))
-      '(list a (b so?) (x 3) y)
-      '(not (((inspect/object x) 'code) 'source))
-      '(null? (profile-dump-list)))
     "(120 #t 6 24)\n#t\n#f\n")
   (strip-and-check "testfile-sff-1a.so" "testfile-sff-1a.so"
     (fasl-strip-options profile-source))
   (strip-and-check "testfile-sff-1b.so" "testfile-sff-1b.so"
     (fasl-strip-options profile-source))
   (equal?
-    (separate-eval
+    (go)
-      '(import (testfile-sff-1b))
-      '(import (testfile-sff-1a))
-      '(define-syntax so?
-         (lambda (x)
-           (syntax-case x ()
-             [(_ q) (and (syntax->annotation #'q) #t)])))
-      '(list a (b so?) (x 3) y)
-      '(not (((inspect/object x) 'code) 'source))
-      '(null? (profile-dump-list)))
     "(120 #t 6 24)\n#t\n#t\n")
   (strip-and-check "testfile-sff-1a.so" "testfile-sff-1a.so"
     (fasl-strip-options source-annotations))
   (strip-and-check "testfile-sff-1b.so" "testfile-sff-1b.so"
     (fasl-strip-options source-annotations))
   (equal?
-    (separate-eval
+    (go)
-      '(import (testfile-sff-1b))
-      '(import (testfile-sff-1a))
-      '(define-syntax so?
-         (lambda (x)
-           (syntax-case x ()
-             [(_ q) (and (syntax->annotation #'q) #t)])))
-      '(list a (b so?) (x 3) y)
-      '(not (((inspect/object x) 'code) 'source))
-      '(null? (profile-dump-list)))
     "(120 #f 6 24)\n#t\n#t\n")
   (strip-and-check "testfile-sff-1a.so" "testfile-sff-1a.so"
     (fasl-strip-options compile-time-information))
@@ -2404,8 +1757,8 @@
       '(expand 'b)
       '(load "testfile-sff-1c.so")
       '(guard (c [else (display-condition c) (newline) #t]) (eval '(import (testfile-sff-1b)))))
-    "Exception: loading testfile-sff-1b.so did not define compile-time information for library (testfile-sff-1b)\n#t\n\
+    "Exception: loading testfile-sff-1b.so did not define library (testfile-sff-1b)\n#t\n\
-     Exception: loading testfile-sff-1a.so did not define compile-time information for library (testfile-sff-1a)\n#t\n\
+     Exception: loading testfile-sff-1a.so did not define library (testfile-sff-1a)\n#t\n\
      a\nb\n\
      (6 24)\n#t\n#t\n\
      Exception: loading testfile-sff-1b.so did not define compile-time information for library (testfile-sff-1b)\n#t\n\
@@ -2470,6 +1823,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?
@@ -5458,6 +4858,12 @@
   
  )
 
+(mat show-allocation
+  (begin
+    (#%$show-allocation #t)
+    #t)
+)
+
 (mat current-generate-id
   (begin
     (define (make-x-generator)
@@ -5658,5 +5064,4 @@
     (< (* 0.75 $pre-allocated)
        (bytes-allocated)
        (* 1.25 $pre-allocated)))
-
 )

mats/patch-compile-0-f-t-f

@@ -1,7 +1,7 @@
-*** errors-compile-0-f-f-f	2019-07-26 13:30:16.000000000 -0400
+*** errors-compile-0-f-f-f	2020-02-22 12:22:03.000000000 -0700
---- errors-compile-0-f-t-f	2019-07-26 13:41:01.000000000 -0400
+--- errors-compile-0-f-t-f	2020-02-22 12:57:01.000000000 -0700
 ***************
-*** 125,131 ****
+*** 254,260 ****
   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".
---- 125,131 ----
+--- 254,260 ----
   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".
 ***************
-*** 144,150 ****
+*** 273,279 ****
   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".
---- 144,150 ----
+--- 273,279 ----
   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".
 ***************
-*** 191,200 ****
+*** 320,329 ****
   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".
---- 191,200 ----
+--- 320,329 ----
   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".
 ***************
-*** 3741,3747 ****
+*** 4080,4086 ****
   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".
---- 3741,3747 ----
+--- 4080,4086 ----
   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".
 ***************
-*** 7259,7266 ****
+*** 7645,7652 ****
   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)".
---- 7259,7266 ----
+--- 7645,7652 ----
   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)".
 ***************
-*** 7268,7282 ****
+*** 7654,7668 ****
   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".
---- 7268,7282 ----
+--- 7654,7668 ----
   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".
 ***************
-*** 7289,7314 ****
+*** 7675,7700 ****
   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".
---- 7289,7314 ----
+--- 7675,7700 ----
   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".
 ***************
-*** 7439,7477 ****
+*** 7825,7863 ****
   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".
---- 7439,7477 ----
+--- 7825,7863 ----
   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".
 ***************
-*** 7486,7542 ****
+*** 7872,7928 ****
   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".
---- 7486,7542 ----
+--- 7872,7928 ----
   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".

mats/patch-interpret-0-f-f-f

@@ -1,7 +1,26 @@
-*** errors-compile-0-f-f-f	2019-07-26 13:30:16.000000000 -0400
+*** errors-compile-0-f-f-f	2020-02-22 12:22:03.000000000 -0700
---- errors-interpret-0-f-f-f	2019-07-26 14:04:09.000000000 -0400
+--- errors-interpret-0-f-f-f	2020-02-22 12:57:46.000000000 -0700
 ***************
-*** 1,7 ****
+*** 18,25 ****
+  primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
+  primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure
+  primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure
+! primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in compile: ((a . b)) is not an environment
+! primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in compile: #f is not an environment
+  primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment
+  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
+--- 18,25 ----
+  primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
+  primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure
+  primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure
+! primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in interpret: ((a . b)) is not an environment
+! primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in interpret: #f is not an environment
+  primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment
+  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
+***************
+*** 130,136 ****
   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 1 to #<procedure>".
@@ -9,13 +28,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".
---- 1,13 ----
+--- 130,136 ----
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1045, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1047, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1054, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1056, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1063, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1065, char 4 of 6.ms
   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 1 to #<procedure>".
@@ -24,7 +37,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".
 ***************
-*** 28,98 ****
+*** 157,227 ****
   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".
@@ -96,7 +109,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".
---- 34,104 ----
+--- 157,227 ----
   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".
@@ -169,7 +182,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".
 ***************
-*** 191,202 ****
+*** 320,331 ****
   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".
@@ -182,7 +195,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".
---- 197,208 ----
+--- 320,331 ----
   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".
@@ -196,7 +209,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".
 ***************
-*** 4147,4162 ****
+*** 4483,4498 ****
   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)".
@@ -213,9 +226,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)".
---- 4153,4162 ----
+--- 4483,4492 ----
 ***************
-*** 7121,7127 ****
+*** 7457,7463 ****
   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
@@ -223,7 +236,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".
---- 7121,7127 ----
+--- 7451,7457 ----
   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
@@ -232,7 +245,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".
 ***************
-*** 7450,7456 ****
+*** 7836,7842 ****
   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".
@@ -240,7 +253,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".
---- 7450,7456 ----
+--- 7830,7836 ----
   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".
@@ -249,7 +262,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".
 ***************
-*** 7492,7498 ****
+*** 7878,7884 ****
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
@@ -257,7 +270,7 @@
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 4 to #<procedure constructor>".
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor #<record constructor descriptor> is not for parent of record type #<record type grand-child>".
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar>".
---- 7492,7498 ----
+--- 7872,7878 ----
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
@@ -266,7 +279,7 @@
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor #<record constructor descriptor> is not for parent of record type #<record type grand-child>".
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar>".
 ***************
-*** 8715,8727 ****
+*** 9122,9134 ****
   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".
@@ -280,7 +293,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".
---- 8715,8727 ----
+--- 9116,9128 ----
   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".
@@ -295,7 +308,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".
 ***************
-*** 9482,9506 ****
+*** 9889,9913 ****
   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".
@@ -321,7 +334,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".
---- 9482,9506 ----
+--- 9883,9907 ----
   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".
@@ -348,7 +361,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".
 ***************
-*** 9513,9544 ****
+*** 9920,9951 ****
   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".
@@ -381,7 +394,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>".
---- 9513,9544 ----
+--- 9914,9945 ----
   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".
@@ -415,7 +428,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>".
 ***************
-*** 9546,9571 ****
+*** 9953,9978 ****
   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>".
@@ -442,7 +455,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>".
---- 9546,9571 ----
+--- 9947,9972 ----
   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>".
@@ -470,7 +483,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>".
 ***************
-*** 9576,9610 ****
+*** 9983,10017 ****
   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>".
@@ -506,7 +519,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>".
---- 9576,9610 ----
+--- 9977,10011 ----
   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>".
@@ -543,7 +556,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>".
 ***************
-*** 10211,10220 ****
+*** 10618,10627 ****
   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 ...)))".
@@ -554,7 +567,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".
---- 10211,10220 ----
+--- 10612,10621 ----
   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 ...)))".

mats/patch-interpret-0-f-t-f

@@ -1,7 +1,26 @@
-*** errors-compile-0-f-t-f	2019-07-26 13:41:01.000000000 -0400
+*** errors-compile-0-f-t-f	2020-02-22 12:57:01.000000000 -0700
---- errors-interpret-0-f-t-f	2019-07-26 14:16:35.000000000 -0400
+--- errors-interpret-0-f-t-f	2020-02-22 12:56:12.000000000 -0700
 ***************
-*** 1,7 ****
+*** 18,25 ****
+  primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
+  primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure
+  primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure
+! primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in compile: ((a . b)) is not an environment
+! primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in compile: #f is not an environment
+  primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment
+  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
+--- 18,25 ----
+  primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
+  primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure
+  primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure
+! primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in interpret: ((a . b)) is not an environment
+! primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in interpret: #f is not an environment
+  primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment
+  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
+***************
+*** 130,136 ****
   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 1 to #<procedure>".
@@ -9,13 +28,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".
---- 1,13 ----
+--- 130,136 ----
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1045, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1047, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1054, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1056, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1063, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1065, char 4 of 6.ms
   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 1 to #<procedure>".
@@ -24,7 +37,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".
 ***************
-*** 28,98 ****
+*** 157,227 ****
   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".
@@ -96,7 +109,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".
---- 34,104 ----
+--- 157,227 ----
   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".
@@ -169,7 +182,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".
 ***************
-*** 4147,4162 ****
+*** 4483,4498 ****
   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)".
@@ -186,9 +199,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)".
---- 4153,4162 ----
+--- 4483,4492 ----
 ***************
-*** 7121,7127 ****
+*** 7457,7463 ****
   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
@@ -196,7 +209,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".
---- 7121,7127 ----
+--- 7451,7457 ----
   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
@@ -205,7 +218,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".
 ***************
-*** 7259,7266 ****
+*** 7645,7652 ****
   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".
@@ -214,7 +227,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)".
---- 7259,7266 ----
+--- 7639,7646 ----
   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".
@@ -224,7 +237,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)".
 ***************
-*** 7268,7282 ****
+*** 7654,7668 ****
   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".
@@ -240,7 +253,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".
---- 7268,7282 ----
+--- 7648,7662 ----
   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".
@@ -257,7 +270,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".
 ***************
-*** 7289,7314 ****
+*** 7675,7700 ****
   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>".
@@ -284,7 +297,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".
---- 7289,7314 ----
+--- 7669,7694 ----
   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>".
@@ -312,7 +325,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".
 ***************
-*** 7439,7477 ****
+*** 7825,7863 ****
   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>".
@@ -352,7 +365,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".
---- 7439,7477 ----
+--- 7819,7857 ----
   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>".
@@ -393,7 +406,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".
 ***************
-*** 7486,7542 ****
+*** 7872,7928 ****
   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".
@@ -451,7 +464,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".
---- 7486,7542 ----
+--- 7866,7922 ----
   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".
@@ -510,7 +523,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".
 ***************
-*** 8715,8727 ****
+*** 9122,9134 ****
   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".
@@ -524,7 +537,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".
---- 8715,8727 ----
+--- 9116,9128 ----
   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".
@@ -539,7 +552,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".
 ***************
-*** 10211,10220 ****
+*** 10618,10627 ****
   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 ...)))".
@@ -550,7 +563,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".
---- 10211,10220 ----
+--- 10612,10621 ----
   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 ...)))".

mats/patch-interpret-3-f-f-f

@@ -1,17 +1,5 @@
-*** errors-compile-3-f-f-f	2019-07-26 13:35:23.000000000 -0400
+*** errors-compile-3-f-f-f	2020-02-22 11:39:11.000000000 -0700
---- errors-interpret-3-f-f-f	2019-07-26 14:10:17.000000000 -0400
+--- errors-interpret-3-f-f-f	2020-02-22 12:56:30.000000000 -0700
-***************
-*** 1,3 ****
---- 1,9 ----
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1045, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1047, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1054, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1056, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1063, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1065, char 4 of 6.ms
-  3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x".
-  3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x at line 1, char 19 of testfile.ss".
-  misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
 ***************
 *** 12,26 ****
   misc.mo:Expected warning in mat (argcnt compile-warning): "compile: possible incorrect argument count in call (car (quote (a b)) (quote (c d))) at line 3, char 38 of testfile.ss".
@@ -29,4 +17,4 @@
 - 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".
   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".
---- 18,26 ----
+--- 12,20 ----

mats/patch-interpret-3-f-t-f

@@ -1,17 +1,5 @@
-*** errors-compile-3-f-t-f	2019-07-26 13:46:04.000000000 -0400
+*** errors-compile-3-f-t-f	2020-02-22 12:57:08.000000000 -0700
---- errors-interpret-3-f-t-f	2019-07-26 14:22:41.000000000 -0400
+--- errors-interpret-3-f-t-f	2020-02-22 12:56:23.000000000 -0700
-***************
-*** 1,3 ****
---- 1,9 ----
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1045, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1047, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1054, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1056, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1063, char 4 of 6.ms
-+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1065, char 4 of 6.ms
-  3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x".
-  3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x at line 1, char 19 of testfile.ss".
-  misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
 ***************
 *** 12,26 ****
   misc.mo:Expected warning in mat (argcnt compile-warning): "compile: possible incorrect argument count in call (car (quote (a b)) (quote (c d))) at line 3, char 38 of testfile.ss".
@@ -29,4 +17,4 @@
 - 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".
   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".
---- 18,26 ----
+--- 12,20 ----

mats/primvars.ms

@@ -14,19 +14,66 @@
 ;;; limitations under the License.
 
 (mat primvars
-  (let loop ([ls (oblist)] [bad '()])
+  (let ([ls (oblist)])
+    (define (mat-id? x)
+      (memq x
+        '(equivalent-expansion? mat-run mat mat/cf
+           mat-file mat-output enable-cp0 windows? embedded?
+           *examples-directory* *scheme*
+           *fuzz* ~= fl~= cfl~= == nan pi +pi +pi/2 +pi/4 -pi -pi/2 -pi/4 +e -e
+           separate-eval-tools separate-compile separate-eval run-script patch-exec-path $record->vector
+           $cat_flush
+           test-cp0-expansion
+           mkfile rm-rf touch
+           heap-check-interval
+           preexisting-profile-dump-entry?
+           coverage-table record-run-coverage load-coverage-files combine-coverage-files coverage-percent
+           parameters)))
+    (define (canonical-label x)
+      (let ([s (symbol->string x)])
+        (#%$intern3 (format "~a*top*:~a" s s) (string-length s) (+ 6 (* 2 (string-length s))))))
+    (unless (find (lambda (x) (#%$sgetprop x '*top* #f)) ls)
+      (errorf #f "no symbols found with property ~s" '*top*))
+    (let loop ([ls ls] [bad '()])
       (if (null? ls)
           (or (null? bad)
               (begin
                 (pretty-print bad)
-              (errorf #f "incorrect library-entry bindings for symbols ~s" bad)))
+                (errorf #f "incorrect top-level bindings for symbols ~s" bad)))
+          (loop (cdr ls)
             (let ([x (car ls)])
-          (if (let ([i (#%$sgetprop x '*library-entry* #f)])
+              (if (gensym? x)
-                (or (not i) (#%$lookup-library-entry i)))
+                  (let ([name (#%$symbol-name x)])
-              (loop (cdr ls) bad)
+                    (if name
-              (loop (cdr ls) (cons x bad))))))
+                        (let ([pname (cdr name)] [uname (car name)])
+                          (if (and pname uname (string=? uname (format "*top*:~a" pname)))
+                              (if (mat-id? (string->symbol pname)) bad (cons x bad))
+                              bad))
+                        bad))
+                  (if (let ([loc (#%$sgetprop x '*top* #f)])
+                        (case (#%$symbol-type x)
+                          [(keyword library-uid) (eq? loc x)]
+                          [(primitive)
+                           (and
+                             (top-level-bound? x)
+                             (eq? (top-level-value x) (top-level-value x (scheme-environment)))
+                             (eq? loc x))]
+                          [else
+                            (if (mat-id? x)
+                                (or loc (guard (c [else #f]) (#2%$top-level-value (canonical-label x)) #t))
+                                (and
+                                  (not loc)
+                                  (not (top-level-bound? x))
+                                  (guard (c [else #t])
+                                    (#2%top-level-value x)
+                                    #f)
+                                  (guard (c [else #t])
+                                    (#2%$top-level-value (canonical-label x))
+                                    #f)))]))
+                      bad
+                      (cons x bad))))))))
 
-  (let ()
+  (let ([ls (remp gensym? (oblist))])
     (define (get-cte x) (#%$sgetprop x '*cte* #f))
     (define (keyword? x)
       (cond
@@ -37,7 +84,11 @@
         [(get-cte x) => (lambda (b) (eq? (car b) 'primitive))]
         [else #t]))
     (define (scheme? x) (eq? (#%$sgetprop x '*scheme* #f) x))
-    (let loop ([ls (remp gensym? (oblist))] [bad '()])
+    (unless (find (lambda (x) (#%$sgetprop x '*cte* #f)) ls)
+      (errorf #f "no symbols found with property ~s" '*cte*))
+    (unless (find (lambda (x) (#%$sgetprop x '*scheme* #f)) ls)
+      (errorf #f "no symbols found with property ~s" '*scheme*))
+    (let loop ([ls ls] [bad '()])
       (if (null? ls)
           (or (null? bad)
               (begin
@@ -96,57 +147,39 @@
                 (loop (cdr ls) bad)
                 (loop (cdr ls) (cons x bad))))))
      #t)
-
-  (let ()
-    (define (get-cte x) (#%$sgetprop x '*cte* #f))
-    (define (scheme? x) (eq? (#%$sgetprop x '*scheme* #f) x))
-    (define (mat-id? x)
-      (memq x
-        '(equivalent-expansion? pretty-equal? mat-run
-           show-mat-source-info mat-file enable-cp0 windows? embedded?
-           *examples-directory* *scheme*
-           *fuzz* ~= fl~= cfl~= == nan pi +pi +pi/2 +pi/4 -pi -pi/2 -pi/4 +e -e
-           separate-compile separate-eval run-script patch-exec-path $record->vector
-           $cat_flush
-           test-cp0-expansion
-           mkfile rm-rf touch)))
-    (let loop ([ls (remp gensym? (oblist))] [bad '()])
-      (if (null? ls)
-          (or (null? bad)
-              (begin
-                (pretty-print bad)
-                (errorf #f "incorrect top-level bindings for symbols ~s" bad)))
-          (loop (cdr ls)
-            (let ([x (car ls)])
-              (if (let ([loc (#%$sgetprop x '*top* #f)])
-                    (case (#%$symbol-type x)
-                      [(keyword) (eq? loc x)]
-                      [(primitive)
-                       (and
-                         (top-level-bound? x)
-                         (eq? (top-level-value x) (top-level-value x (scheme-environment)))
-                         (eq? loc x))]
-                      [else
-                        (or (mat-id? x)
-                            (not loc)
-                            (not (top-level-bound? x))
-                            (guard (c [else #t])
-                              (#2%top-level-value x)
-                              #f))]))
-                  bad
-                  (cons x bad)))))))
  )
 
 (mat arity
   (or (= (optimize-level) 3)
-      (let ()
+      (let ([ls (oblist)])
         (define oops #f)
+        (define (arity->mask a*)
+          (fold-left (lambda (mask a)
+                       (logor mask
+                         (if (< a 0)
+                             (ash -1 (- -1 a))
+                             (ash 1 a))))
+            0 a*))
+        (define prim-arity
+          (lambda (x)
+            (module (primref-arity) (include "../s/primref.ss"))
+            (let ([primref2 (#%$sgetprop x '*prim2* #f)] [primref3 (#%$sgetprop x '*prim3* #f)])
+              (if primref2
+                  (if primref3
+                      (let ([arity2 (primref-arity primref2)]
+                            [arity3 (primref-arity primref3)])
+                        (unless (equal? arity2 arity3)
+                          (errorf #f "unequal *prim2* and *prim3* arity for ~s" x))
+                        (and arity2 (arity->mask arity2)))
+                      (errorf #f "found *prim2* but not *prim3* for ~s" x))
+                  (if primref3
+                      (errorf #f "found *prim2* but not *prim3* for ~s" x)
+                      #f)))))
         (define (prefix=? prefix str)
           (let ([n (string-length prefix)])
             (and (>= (string-length str) n)
                  (string=? (substring str 0 n) prefix))))
-        (define (check prim n)
+        (define (okay-condition? prim c)
-          (define (okay-condition? c)
           (and (violation? c)
                (message-condition? c)
                (irritants-condition? c)
@@ -162,71 +195,45 @@
                           (and (list? args) (= (length args) 1) (string? (car args)))
                           (let ([unprefixed (#%$sgetprop prim '*unprefixed* prim)])
                             (prefix=? (format "(~s" unprefixed) (car args))))))))
-          (let ([call `(,prim ,@(make-list n `',(void)))])
+        (define (check prim n)
-            (unless (guard (c [else (okay-condition? c)])
+        (void)
+          (let ([call `(($primitive ,prim) ,@(make-list n `',(void)))])
+            (unless (guard (c [else (okay-condition? prim c)])
                       (eval `(begin ,call #f)))
               (set! oops #t)
-              (printf "no argcount error for ~s\n" call))))
+              (printf "no argcount error for ~s\n" call)))
-        (for-each
+          (let ([call `(($primitive ,prim) ,@(make-list n '(void)))])
-          (lambda (prim)
-            (let ([a* (#%$sgetprop prim '*arity* #f)])
-              (when a*
-                (let loop ([n 0] [a* a*])
-                  (cond
-                    [(null? a*) (check prim n)]
-                    [(= (- -1 (car a*)) n) (void)]
-                    [(= (car a*) n) (loop (+ n 1) (cdr a*))]
-                    [else (check prim n) (loop (+ n 1) a*)])))))
-          (oblist))
-        (not oops)))
-  (or (= (optimize-level) 3)
-      (let ()
-        (define oops #f)
-        (define (prefix=? prefix str)
-          (let ([n (string-length prefix)])
-            (and (>= (string-length str) n)
-                 (string=? (substring str 0 n) prefix))))
             (define (write-and-load x)
               (with-output-to-file "testfile.ss"
                 (lambda () (pretty-print x))
                 'replace)
               (load "testfile.ss"))
-        (define (check prim n)
-          (define (okay-condition? c)
-            (and (violation? c)
-                 (message-condition? c)
-                 (irritants-condition? c)
-                 (let ([msg (condition-message c)] [args (condition-irritants c)])
-                   (or (and (prefix=? "incorrect number of arguments" msg)
-                            (and (list? args) (= (length args) 1))
-                            (let ([unprefixed (#%$sgetprop prim '*unprefixed* prim)])
-                              (or (and (procedure? (car args))
-                                       (let ([name (#%$procedure-name (car args))])
-                                         (or (not name) (equal? name (symbol->string unprefixed)))))
-                                  (and (pair? (car args)) (eq? (caar args) unprefixed)))))
-                       (and (prefix=? "incorrect argument count" msg)
-                            (and (list? args) (= (length args) 1) (string? (car args)))
-                            (let ([unprefixed (#%$sgetprop prim '*unprefixed* prim)])
-                              (prefix=? (format "(~s" unprefixed) (car args))))))))
-          (let ([call `(,prim ,@(make-list n '(void)))])
             (let ([warn? #f] [error? #f])
-              (guard (c [(okay-condition? c) (set! error? #t)])
+              (guard (c [(okay-condition? prim c) (set! error? #t)])
                 (with-exception-handler
                   (lambda (x) (if (warning? x) (begin (set! warn? #t) (values)) (raise-continuable x)))
                   (lambda () (write-and-load `(begin ,call #f)) #f)))
-              (unless warn? (printf "no argcount warning for ~s\n" call) (set! oops #t))
+              (unless (or warn? (#%$suppress-primitive-inlining)) (printf "no argcount warning for ~s\n" call) (set! oops #t))
               (unless error? (printf "no argcount error for ~s\n" call) (set! oops #t)))))
+        (unless (find (lambda (x) (#%$sgetprop x '*prim3* #f)) ls)
+          (printf "no symbols found with property ~s" '*prim3*))
         (for-each
           (lambda (prim)
-            (let ([a* (#%$sgetprop prim '*arity* #f)])
+            (let ([mask (prim-arity prim)])
-              (when a*
+              (when mask
-                (let loop ([n 0] [a* a*])
+                (let ([pam (procedure-arity-mask (eval `($primitive ,prim)))])
+                  (unless (= mask pam)
+                    (printf "primref arity mask ~s differs from procedure-arity-mask return value ~s for ~s\n"
+                      mask pam prim)
+                    (set! oops #t)))
+                (let loop ([n 0] [mask mask])
                   (cond
-                    [(null? a*) (check prim n)]
+                    [(eqv? mask 0) (check prim n)]
-                    [(= (- -1 (car a*)) n) (void)]
+                    [(eqv? mask -1) (void)]
-                    [(= (car a*) n) (loop (+ n 1) (cdr a*))]
+                    [else
-                    [else (check prim n) (loop (+ n 1) a*)])))))
+                      (unless (bitwise-bit-set? mask 0) (check prim n))
-          (oblist))
+                      (loop (fx+ n 1) (ash mask -1))])))))
+          ls)
         (not oops)))
 )
 
@@ -310,14 +317,19 @@
                    [binary-input-port (open-bytevector-input-port bv)]
                    [sfd (make-source-file-descriptor "foo" binary-input-port #t)]
                    [source-object (make-source-object sfd 2 3)]
-                   [annotation (make-annotation '(if #f #f) source-object '(source expr))])
+                   [annotation (make-annotation '(if #f #f) source-object '(source expr))]
+                   [textual-input-port (transcoded-port binary-input-port (native-transcoder))])
               (def *binary-input-port binary-input-port)
               (def *sfd sfd)
               (def *source-object source-object)
-              (def *annotation annotation))
+              (def *annotation annotation)
-            (let-values ([(binary-output-port getter) (open-bytevector-output-port)])
+              (def *textual-input-port textual-input-port))
+            (let*-values ([(binary-output-port getter) (open-bytevector-output-port)]
+                          [(textual-output-port) (transcoded-port binary-output-port (native-transcoder))])
               (def *binary-output-port binary-output-port)
-              (def *binary-port binary-output-port))
+              (def *binary-port binary-output-port)
+              (def *textual-output-port textual-output-port)
+              (def *textual-port textual-output-port))
             (def *cost-center (make-cost-center))
             (def *date (current-date))
             (def *phantom-bytevector (make-phantom-bytevector 10))
@@ -334,6 +346,7 @@
               (def *record ((record-constructor rcd) 3)))
             (def *sstats (statistics))
             (def *time (make-time 'time-duration 0 5))
+            (def *time-utc (make-time 'time-utc 0 5))
             (cond
               [(fx< (fixnum-width) 32)
                (def *max-iptr (- (expt 2 31) 1))
@@ -369,31 +382,34 @@
               [(bytevector) '#vu8(0) "a" #f]
               [(cflonum) 0.0+1.0i 0 'a #f]
               [(char) #\a 0 #f]
-              [(codec) latin-1-codec 0 #f]
+              [(codec) (latin-1-codec) 0 #f]
               [(code) (closure-code 'values) 0 #f]
-              [(compile-time-value) (make-compile-time-value 17)]
+              [(compile-time-value) (make-compile-time-value 17) #f]
-              [(condition) (make-who-condition 'me) 'the-who]
+              [(condition) (make-who-condition 'me) 'the-who #f]
               [(continuation-condition) (call/cc make-continuation-condition) (make-who-condition 'who) #f]
               [(cost-center) *cost-center '(a) #f]
+              [(source-table) (make-source-table) *time #f]
               [(date) *date *time #f]
+              [(endianness) 'big 'giant #f]
               [(enum-set) (file-options compressed) 0 #f]
               [(environment) *env '((a . b)) #f]
               [(eq-hashtable) *eq-hashtable *symbol-hashtable #f]
-              [(exact-integer) (- (most-negative-fixnum) 1) 1/2 #f]
+              [(exact-integer) (- (most-negative-fixnum) 1) 2.0 1/2 #f]
               [(exception-state) (current-exception-state) 0 #f]
               [(eof/char) #\a 0 #f]
               [(eof/u8) 0 -1 (expt 2 8) "a" #f]
               [(fasl-strip-options) (fasl-strip-options inspector-source) (file-options compressed) #f]
               [(file-options) (file-options compressed) 1/2 #f]
-              [(fixnum) -1 'q (+ (most-positive-fixnum) 1) (- (most-negative-fixnum) 1)]
+              [(fixnum) -1 'q (+ (most-positive-fixnum) 1) (- (most-negative-fixnum) 1) #f]
               [(flonum) 0.0 0 0.0+1.0i 'a #f]
               [(ftype-pointer) *ftype-pointer 0 *time #f]
               [(fxvector) '#vfx(0) "a" #f]
-              [(gensym) *genny sym #f]
+              [(gensym) *genny 'sym #f]
+              [(guardian) (make-guardian) values "oops" #f]
               [(hashtable) *eq-hashtable '((a . b)) #f]
-              [(identifier) #'x x 17 #f]
+              [(identifier) #'x 'x 17 #f]
-              [(import-spec) (chezscheme) 0 '(a . b) #f]
+              [(import-spec) '(chezscheme) 0 '(a . b) #f]
-              [(input-port) (current-input-port) 0 *binary-output-port (transcoded-port *binary-output-port (native-transcoder)) #f]
+              [(input-port) (current-input-port) 0 *binary-output-port *textual-output-port #f]
               [(integer) 0.0 1/2 1.0+0.0i 'a #f]
               [(i/o-encoding-error) (make-i/o-encoding-error 17 23) (make-who-condition 'who) 1/2 #f]
               [(i/o-filename-error) (make-i/o-filename-error 17) (make-who-condition 'who) 3 #f]
@@ -401,25 +417,31 @@
               [(i/o-port-error) (make-i/o-port-error 17) (make-who-condition 'who) '(a) #f]
               [(irritants-condition) (make-irritants-condition 17) (make-who-condition 'who) 'a #f]
               [(length) 0 -1 (+ (most-positive-fixnum) 1) 'a #f]
+              [(library-path) '(a) "hereiam" #f]
               [(library-requirements-options) (library-requirements-options import invoke) 1/2 #f]
               [(list) '(a) '#1=(a . #1#) 17 '#() #f]
+              [(list-of-string-pairs) '(("a" . "b")) '("a") #f]
+              [(list-of-symbols) '(a b c) '("a") #f]
               [(maybe-binary-output-port) *binary-output-port *binary-input-port (current-output-port)]
               [(maybe-char) #\a 0]
               [(maybe-pathname) "a" 'a]
               [(maybe-procedure) values 0]
               [(maybe-rtd) *rtd *record ""]
               [(maybe-sfd) *sfd '(q)]
+              [(maybe-source-table) (make-source-table) *time]
               [(maybe-string) "a" 'a]
               [(maybe-symbol) 'a 0 "a"]
-              [(maybe-textual-output-port) (current-output-port) 0 *binary-output-port (transcoded-port *binary-input-port (native-transcoder))]
+              [(maybe-textual-output-port) (current-output-port) 0 *binary-output-port *textual-input-port]
               [(maybe-transcoder) (native-transcoder) 0]
               [(maybe-ufixnum) 0 -1 (+ (most-positive-fixnum) 1) 'a]
               [(maybe-uint) 0 -1 'a]
               [(maybe-who) 'who 17]
+              [(maybe-timeout) *time 371]
               [(message-condition) (make-message-condition 17) (make-who-condition 'who) 'q #f]
               [(number) 1+2i 'oops #f]
+              [(nzuint) 1 0 'a #f]
               [(old-hash-table) *old-hash-table '((a . b)) #f]
-              [(output-port) (current-output-port) 0 *binary-input-port (transcoded-port *binary-input-port (native-transcoder)) #f]
+              [(output-port) (current-output-port) 0 *binary-input-port *textual-input-port #f]
               [(pair) '(a . b) 'a #f]
               [(pathname) "a" 'a #f]
               [(pfixnum) 1 0 #f]
@@ -441,22 +463,24 @@
               [(s56) -1 'q (expt 2 55) (- -1 (expt 2 55)) #f]
               [(s64) -1 'q (expt 2 63) (- -1 (expt 2 63)) #f]
               [(s8) -1 'q (expt 2 7) (- -1 (expt 2 7)) #f]
-              [(sfd) *sfd '(q)]
+              [(sfd) *sfd '(q) #f]
-              [(sint) -1 'q]
+              [(sint) -1 'q #f]
               [(source-condition) (make-source-condition 17) (make-who-condition 'who) #f]
               [(source-object) *source-object '#&a #f]
               [(sstats) *sstats '#(0 2 7 3) #f]
               [(string) "a" 'a #f]
               [(string/bytevector) no-good]
               [(sub-ptr) no-good]
-              [(sub-uint sub-ufixnum sub-index sub-length sub-list sub-fixnum sub-flonum sub-integer sub-number sub-port sub-rtd sub-sint sub-string sub-symbol sub-textual-output-port sub-vector maybe-sub-rcd maybe-sub-symbol) no-good #!eof]
+              [(sub-uint sub-ufixnum sub-index sub-length sub-list sub-fixnum sub-flonum sub-integer sub-number sub-port sub-rtd sub-sint sub-string sub-symbol sub-textual-output-port sub-vector) no-good #!eof #f]
+              [(maybe-sub-rcd maybe-sub-symbol) no-good #!eof]
               [(symbol) 'a 0 "a" #f]
               [(symbol-hashtable) *symbol-hashtable *eq-hashtable '() #f]
               [(syntax-violation) (make-syntax-violation '(if) #f) 'oops #f]
-              [(textual-input-port) (current-input-port) 0 *binary-input-port (transcoded-port *binary-output-port (native-transcoder)) #f]
+              [(textual-input-port) (current-input-port) 0 *binary-input-port *textual-output-port #f]
-              [(textual-output-port) (current-output-port) 0 *binary-output-port (transcoded-port *binary-input-port (native-transcoder)) #f]
+              [(textual-output-port) (current-output-port) 0 *binary-output-port *textual-input-port #f]
               [(time) *time "no-time" #f]
-              [(timeout) *time "no-time"]
+              [(time-utc) *time-utc "no-time" #f]
+              [(timeout) *time "no-time" #f]
               [(transcoder) (native-transcoder) 0 #f]
               [(u16) 0 -1 (expt 2 16) "a" #f]
               [(u24) 0 -1 (expt 2 24) "a" #f]
@@ -474,7 +498,8 @@
               [(uptr/iptr) -1 'q (+ *max-uptr 1) (- *min-iptr 1) #f]
               [(vector) '#(a) "a" #f]
               [(stencil-vector) (stencil-vector 7 1 2 3) "a" #f]
-              [(who-condition) (make-who-condition 'me) (make-message-condition "hello") 'the-who])
+              [(who-condition) (make-who-condition 'me) (make-message-condition "hello") 'the-who #f]
+              [(who) 'who 17])
             (meta-cond
               [(memq 'pthreads feature*)
                (declare-types
@@ -482,6 +507,13 @@
                  [(mutex) (make-mutex) "not a mutex" #f])])
             ht))
         (define (fuzz-prim-args name unprefixed-name lib* flag* in*/out**)
+          (define (prefix=? prefix str)
+            (let ([n (string-length prefix)])
+              (and (>= (string-length str) n)
+                   (string=? (substring str 0 n) prefix))))
+          (define (who=? x y)
+            (define ->string (lambda (x) (if (symbol? x) (symbol->string x) x)))
+            (equal? (->string x) (->string y)))
           (define-syntax flags-set?  (syntax-rules () [(_ x ...) (and (memq 'x flag*) ...)]))
           (define good/bad
             (lambda (in* k)
@@ -522,8 +554,9 @@
                         (unless (or (memq 'no-good rgood*) (memq 'no-good (cdr good*)))
                           (for-each
                             (lambda (bad)
-                              (let ([call `(,name ,@(reverse rgood*) ,bad ,@(cdr good*))])
+                              (let ([bad (eval bad env)])
-                                (printf "testing ~s..." call)
+                                (let ([call `(,name ,@(reverse rgood*) ',bad ,@(cdr good*))])
+                                  (printf "testing ~s\n" call)
                                   (flush-output-port)
                                   (let ([c (call/cc
                                              (lambda (k)
@@ -539,11 +572,89 @@
                                                            ; split up so we can grep for "invalid memory reference" in mat output and not see this
                                                            (member (string-append "invalid" " " "memory reference") (condition-irritants c)))))
                                             (begin
-                                            (display-condition c)
+                                              ; try to weed out common error messages
-                                            (newline))
+                                              (if (or (and (message-condition? c)
+                                                           (format-condition? c)
+                                                           (irritants-condition? c)
+                                                           (string=? (condition-message c) "attempt to apply non-procedure ~s")
+                                                           (equal? (condition-irritants c) (list bad)))
+                                                      (and (who-condition? c)
+                                                           (message-condition? c)
+                                                           (format-condition? c)
+                                                           (irritants-condition? c)
+                                                           (or (who=? (condition-who c) name)
+                                                               (who=? (condition-who c) (#%$sgetprop name '*unprefixed* #f)))
+                                                           (or (and (or (prefix=? "~s is not a" (condition-message c))
+                                                                        (prefix=? "~s is not #f or a" (condition-message c))
+                                                                        (prefix=? "index ~s is not a" (condition-message c))
+                                                                        (member (condition-message c)
+                                                                          '("~s is circular"
+                                                                             "incorrect list structure ~s"
+                                                                             "improper list structure ~s"
+                                                                             "attempt to apply non-procedure ~s"
+                                                                             "undefined for ~s"
+                                                                             "invalid endianness ~s"
+                                                                             "invalid start value ~s"
+                                                                             "invalid count value ~s"
+                                                                             "invalid count ~s"
+                                                                             "invalid size ~s"
+                                                                             "invalid index ~s"
+                                                                             "invalid report specifier ~s"
+                                                                             "invalid record name ~s"
+                                                                             "invalid parent ~s"
+                                                                             "invalid uid ~s"
+                                                                             "invalid field vector ~s"
+                                                                             "invalid field specifier ~s"
+                                                                             "invalid record constructor descriptor ~s"
+                                                                             "invalid size argument ~s"
+                                                                             "invalid count argument ~s"
+                                                                             "cyclic list structure ~s"
+                                                                             "invalid time-zone offset ~s"
+                                                                             "unrecognized time type ~s"
+                                                                             "invalid number of seconds ~s"
+                                                                             "invalid nanosecond ~s"
+                                                                             "invalid generation ~s"
+                                                                             "invalid limit ~s"
+                                                                             "invalid level ~s"
+                                                                             "invalid buffer argument ~s"
+                                                                             "invalid space ~s"
+                                                                             "invalid value ~s"
+                                                                             "invalid library name ~s"
+                                                                             "invalid extension list ~s"
+                                                                             "invalid eval-when list ~s"
+                                                                             "invalid dump ~s"
+                                                                             "invalid argument ~s"
+                                                                             "invalid bit index ~s"
+                                                                             "invalid situation ~s"
+                                                                             "invalid foreign address ~s"
+                                                                             "invalid foreign type specifier ~s"
+                                                                             "invalid foreign address ~s"
+                                                                             "invalid path ~s"
+                                                                             "invalid path list ~s"
+                                                                             "~s is not between 2 and 36"
+                                                                             "invalid palette ~s"
+                                                                             "bit argument ~s is not 0 or 1"
+                                                                             "unrecognized type ~s"
+                                                                             "invalid code page ~s")))
+                                                                    (equal? (condition-irritants c) (list bad)))
+                                                               (and (or (member (condition-message c)
+                                                                          '("~s is not a valid index for ~s"
+                                                                             "~s is not a valid size for ~s"
+                                                                             "invalid index ~s for bytevector ~s"
+                                                                             "invalid new length ~s for ~s"))
+                                                                        (prefix=? "invalid message argument ~s" (condition-message c))
+                                                                        (prefix=? "invalid who argument ~s" (condition-message c)))
+                                                                    (let ([ls (condition-irritants c)])
+                                                                      (and (not (null? ls)) (equal? (car ls) bad)))))))
+                                                  ; if it looks good, print to stdout
+                                                  (fprintf (mat-output) "seemingly appropriate argument-type error testing ~s: " call)
+                                                  ; otherwise, mark it as an expected error for user audit
+                                                  (fprintf (mat-output) "Expected error testing ~s: " call))
+                                              (display-condition c (mat-output))
+                                              (newline (mat-output)))
                                             (errorf 'fuzz-prim-args "unexpected exception occurred evaluating ~s: ~a" call
                                               (with-output-to-string (lambda () (display-condition c)))))
-                                      (errorf 'fuzz-prim-args "no exception occurred evaluating ~s" call)))))
+                                        (errorf 'fuzz-prim-args "no exception occurred evaluating ~s" call))))))
                             (car bad**)))
                         (loop (cdr good*) (cdr bad**) (cons (car good*) rgood*)))))))
               (map car in*/out**))))

mats/profile.ms

@@ -0,0 +1,999 @@
+(mat compile-profile
+  (error? ; invalid argument
+    (compile-profile 'src))
+  (eqv?
+    (parameterize ([compile-profile #t])
+      (compile-profile))
+    'source)
+  (eqv?
+    (parameterize ([compile-profile 'source])
+      (compile-profile))
+    'source)
+  (eqv?
+    (parameterize ([compile-profile 'block])
+      (compile-profile))
+    'block)
+  (error? ; incorrect argument count
+    (profile-dump '()))
+  (error? ; incorrect argument count
+    (profile-clear '()))
+  (error? ; incorrect argument count
+    (profile-dump-list #t '() 3))
+  (error? ; invalid dump
+    (profile-dump-list #f 17))
+  (error? ; invalid dump
+    (profile-dump-list #f '(17)))
+  (error? ; invalid dump
+    (profile-dump-list #f '((a . 17))))
+  (error? ; invalid dump
+    (profile-dump-list #f `((,(make-source-object (source-file-descriptor "abc" 34) 0 3) . q))))
+  (error? ; incorrect argument count
+    (profile-dump-html "" '() 3))
+  (error? ; not a string
+    (profile-dump-html '(prefix)))
+  (error? ; invalid dump
+    (profile-dump-html "profile" 17))
+  (error? ; invalid dump
+    (profile-dump-html "profile" '(17)))
+  (error? ; invalid dump
+    (profile-dump-html "profile" '((a . 17))))
+  (error? ; invalid dump
+    (profile-dump-html "profile" `((,(make-source-object (source-file-descriptor "abc" 34) 0 3) . q))))
+  (error? ; incorrect argument count
+    (profile-dump-data))
+  (error? ; incorrect argument count
+    (profile-dump-data "profile.data" '() 'q))
+  (error? ; not a string
+    (profile-dump-data #t))
+  (error? ; invalid dump
+    (profile-dump-data "profile.data" 17))
+  (error? ; invalid dump
+    (profile-dump-data "profile.data" '(17)))
+  (error? ; invalid dump
+    (profile-dump-data "profile.data" '((a . 17))))
+  (error? ; invalid dump
+    (profile-dump-data "profile.data" `((,(make-source-object (source-file-descriptor "abc" 34) 0 3) . q))))
+  (error? ; not a string
+    (profile-load-data 'what?))
+  (eqv? (parameterize ([compile-profile #t])
+          (compile
+            '(let ()
+               (define (f x) (if (= x 0) 1 (* x (f (- x 1)))))
+               (f 3))))
+        6)
+  (eqv? (parameterize ([compile-profile #t])
+          (compile
+            '(let ()
+               (define fat+
+                 (lambda (x y)
+                   (if (zero? y)
+                       x
+                       (fat+ (1+ x) (1- y)))))
+               (define fatfib
+                 (lambda (x)
+                   (if (< x 2)
+                       1
+                       (fat+ (fatfib (1- x)) (fatfib (1- (1- x)))))))
+               (fatfib 20))))
+         10946)
+  (equal?
+    (parameterize ([compile-profile #t])
+      (compile
+        '(let ()
+           (define $values (lambda (n) (lambda () (apply values (make-list n)))))
+           (define foo
+             (lambda (n)
+               (call/cc
+                 (lambda (k)
+                   (with-exception-handler
+                     (lambda (c) (collect) (k 'okay))
+                     (lambda ()
+                       (define f (case-lambda))
+                       (let ([x (random 10)])
+                         (call-with-values ($values n) f))))))))
+           (list (foo 0) (foo 1) (foo 3) (foo 10) (foo 100) (foo 1000)))))
+    '(okay okay okay okay okay okay))
+  ; no longer recording (useless) profiling information when source file & position aren't available
+  #;(let ([ls (profile-dump)])
+    (and (list? ls)
+      (not (null? ls))))
+  (eqv? (profile-clear) (void))
+  (or (eq? (compile-profile) 'source) (andmap zero? (map cdr (remp preexisting-profile-dump-entry? (profile-dump)))))
+  (begin (set! cp-fatfib (void)) #t) ; release fatfib
+
+  (begin (define $old-cp (compile-profile)) #t)
+  ; this collect is here to make it more likely that we won't get a generation 1
+  ; collection cementing in place the code that defines cp-fact
+  (begin (collect 1) #t)
+  (mat/cf (testfile "testfile")
+    (eval-when (compile) (compile-profile 'source))
+    (define (cp-fact x) (if (= x 0) 1 (* x (cp-fact (- x 1))))))
+  (eq? (compile-profile) $old-cp)
+  ; drop code that defines cp-fact so it won't show up in profile-dump-list in
+  ; hopes of resolving potential issue with comparison to pdl further down
+  (begin (collect (collect-maximum-generation)) #t)
+  (= (cp-fact 10) 3628800)
+  (begin
+    (define (prefix=? prefix s)
+      (let ([n (string-length prefix)])
+        (and (>= (string-length s) n) (string=? (substring s 0 n) prefix))))
+    (define (sdir? x) (or (prefix=? "../s" (cadr x)) (prefix=? "../unicode" (cadr x))))
+    (define-values (pdl pdl2)
+      (with-interrupts-disabled
+        (parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
+          (values
+            (remp sdir? (profile-dump-list #t (profile-dump)))
+            (remp sdir? (profile-dump-list))))))
+    #t)
+  (equal? pdl pdl2)
+  (not (null? pdl))
+  (begin
+    (rm-rf "testdir")
+    (mkdir "testdir")
+    (parameterize ([gensym-prefix 0]) (profile-dump-html "testdir/" (profile-dump)))
+    #t)
+  (file-exists? "testdir/profile.html")
+  (file-exists? "testdir/testfile.ss.html")
+
+  (begin (define $old-cp (compile-profile)) #t)
+  (mat/cf (testfile "testfile-block")
+    (eval-when (compile) (compile-profile 'block))
+    (define (cp-fact-block x) (if (= x 0) 1 (* x (cp-fact-block (- x 1))))))
+  (eq? (compile-profile) $old-cp)
+  (= (cp-fact-block 10) 3628800)
+  (or (equal? (compile-profile) 'source)
+      (equal?
+        (parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
+          (remp sdir? (profile-dump-list)))
+        pdl))
+  (begin
+    (parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
+      (profile-dump-html))
+    #t)
+  (file-exists? "profile.html")
+  (file-exists? "testfile.ss.html")
+  (not (file-exists? "testfile2.ss.html"))
+
+  (eqv? (profile-clear) (void))
+
+  (mat/cf (testfile "testfile")
+    (eval-when (compile) (compile-profile #t))
+    (define (cp-fact x) (if (= x 0) 1 (* x (cp-fact (- x 1))))))
+  (= (cp-fact 10) 3628800)
+  (eqv? (profile-dump-data "testfile1.pd" (remp preexisting-profile-dump-entry? (profile-dump))) (void))
+  (file-exists? "testfile1.pd")
+  (eqv? (profile-load-data) (void))
+  (eqv? (profile-load-data "testfile1.pd") (void))
+  (begin
+    (define $cp-ip (open-file-input-port "testfile.ss"))
+    (define $cp-sfd (make-source-file-descriptor "testfile.ss" $cp-ip))
+    (define $qw (lambda (bfp efp) (profile-query-weight (make-source-object $cp-sfd bfp efp))))
+    #t)
+
+  (eqv? (close-port $cp-ip) (void))
+
+  (eqv? ($qw 0 0) 0.0) ; bfp, efp combination not in database
+  (eqv? ; file not in database
+    (let* ([ip (open-file-input-port "Mf-base")]
+           [sfd (make-source-file-descriptor "Mf-base" ip)])
+      (close-port ip)
+      (profile-query-weight (make-source-object sfd 0 0)))
+    #f)
+  ((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0))) #t)) ($qw 0 42))
+  ((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0))) #t)) ($qw 43 102))
+  (eqv? ($qw 63 101) 1.0)
+  (eqv? ($qw 75 76) (fl/ 1.0 11.0))
+  (eqv? ($qw 77 100) (fl/ 10.0 11.0))
+  ((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0))) #t)) ($qw 103 127))
+  (eqv? ($qw 119 126) 0.0)
+  (eqv? ($qw 120 125) 0.0)
+  (eqv? (profile-clear) (void))
+  (= (cp-fact 5) 120)
+  (eqv? (profile-dump-data "testfile2.pd" (remp preexisting-profile-dump-entry? (profile-dump))) (void))
+  (eqv? (profile-load-data "testfile2.pd") (void))
+  ((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0) (fl/ (/ 1.0 11.0) 2.0))) #t)) ($qw 0 42))
+  (eqv? ($qw 21 40) 0.0)
+  ((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0) (fl/ (/ 1.0 11.0) 2.0))) #t)) ($qw 43 102))
+  (eqv? ($qw 63 101) 1.0)
+  (eqv? ($qw 75 76) (fl/ (fl+ (/ 1.0 11.0) (fl/ 1.0 6.0)) 2.0))
+  (eqv? ($qw 77 100) (fl/ (fl+ (fl/ 10.0 11.0) (fl/ 5.0 6.0)) 2.0))
+  ((lambda (x) (and (memv x (list 0.0 (/ 1.0 11.0) (fl/ (/ 1.0 11.0) 2.0))) #t)) ($qw 103 127))
+  (eqv? ($qw 119 126) 0.0)
+  (eqv? ($qw 120 125) 0.0)
+  (eqv? (profile-clear) (void))
+
+  ; make sure all is well when compiled with source profile info
+  (mat/cf (testfile "testfile")
+    (eval-when (compile) (compile-profile 'block))
+    (define (cp-fact x) (if (= x 0) 1 (* x (cp-fact (- x 1))))))
+  (eqv? (profile-dump-data "testfile3.pd" (remp preexisting-profile-dump-entry? (profile-dump))) (void))
+  (file-exists? "testfile3.pd")
+  (eqv? (profile-load-data "testfile3.pd") (void))
+  ; and again with block profile info
+  (mat/cf (testfile "testfile")
+    (eval-when (compile) (compile-profile #f))
+    (define (cp-fact x) (if (= x 0) 1 (* x (cp-fact (- x 1))))))
+  (= (cp-fact 5) 120)
+
+  (eqv? (profile-clear-database) (void))
+  (eqv? ($qw 0 42) #f)
+  (eqv? ($qw 77 100) #f)
+
+  ; make sure record-ref, record-type, and record-cd are properly handled by
+  ; find-source in pdhtml
+  (mat/cf
+    (eval-when (compile) (compile-profile #t))
+    (library (A) (export make-foo foo? foo-x) (import (chezscheme)) (define-record-type foo (fields x)))
+    (let ()
+      (import (A))
+      (define add-foo-xs
+        (lambda ls
+          (let f ([ls ls] [sum 0])
+            (if (null? ls) sum (f (cdr ls) (+ (foo-x (car ls)) sum))))))
+      ; make sure this is still around when we call profile-dump-list
+      (set! $add-foo-xs add-foo-xs)
+      (pretty-print (add-foo-xs (make-foo 1) (make-foo 2) (make-foo 3)))))
+  (not (null? (profile-dump-list)))
+  (eqv? (profile-clear) (void))
+  (begin (set! $add-foo-xs #f) #t)
+
+  (vector? (profile-palette))
+  (vector?
+    (parameterize ([profile-palette (vector-map
+                                      (lambda (p) (cons "white" (car p)))
+                                      (profile-palette))])
+      (profile-palette)))
+  (parameterize ([profile-palette
+                  '#(("black" . "white")
+                     ("red" . "white")
+                     ("blue" . "black"))])
+    (= (vector-length (profile-palette)) 3))
+  (error? (profile-palette '#()))
+  (error? (profile-palette '#(("black" . "white"))))
+  (error? (profile-palette '#(("black" . "white") ("red" . "white"))))
+  (error?
+    (profile-palette
+      '#(("black" . "white")
+         #("red" "white")
+         ("blue" . "black"))))
+  (error?
+    (profile-palette
+      '#(("black" . "white")
+         ("red" . "white")
+         ("blue" . black))))
+  (error?
+    (profile-palette
+      '#(("black" . "white")
+         ("red" . "white")
+         (#x0000ff . "black"))))
+  ; test for proper counts in the presence of control operators
+  (begin
+    (define $return)
+    (define $retry)
+    (with-output-to-file "testfile-cp1.ss"
+      (lambda ()
+        (display-string "\
+(define $frumble
+  (lambda (ls)
+    (if (null? ls)
+        1
+        (let ([n (car ls)])
+          (if (eqv? n 0)
+              (call/cc (lambda (k) (set! $retry k) ($return 0)))
+              (let ([q ($frumble (cdr ls))])
+                (add1 (* q n))))))))
+"))
+      'replace)
+    (profile-clear)
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2] [compile-profile #t])
+      (load "testfile-cp1.ss" compile))
+    #t)
+  (eqv?
+    ($frumble (make-list 100 5))
+    9860761315262647567646607066034827870915080438862787559628486633300781)
+  (equal?
+    (filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list))
+    '((101 "testfile-cp1.ss" 36 258 3 5)
+      (101 "testfile-cp1.ss" 40 50 3 9)
+      (101 "testfile-cp1.ss" 41 46 3 10)
+      (101 "testfile-cp1.ss" 47 49 3 16)
+      (100 "testfile-cp1.ss" 69 257 5 9)
+      (100 "testfile-cp1.ss" 78 86 5 18)
+      (100 "testfile-cp1.ss" 79 82 5 19)
+      (100 "testfile-cp1.ss" 83 85 5 23)
+      (100 "testfile-cp1.ss" 99 256 6 11)
+      (100 "testfile-cp1.ss" 103 113 6 15)
+      (100 "testfile-cp1.ss" 104 108 6 16)
+      (100 "testfile-cp1.ss" 109 110 6 21)
+      (100 "testfile-cp1.ss" 111 112 6 23)
+      (100 "testfile-cp1.ss" 193 255 8 15)
+      (100 "testfile-cp1.ss" 202 221 8 24)
+      (100 "testfile-cp1.ss" 203 211 8 25)
+      (100 "testfile-cp1.ss" 212 220 8 34)
+      (100 "testfile-cp1.ss" 213 216 8 35)
+      (100 "testfile-cp1.ss" 217 219 8 39)
+      (100 "testfile-cp1.ss" 240 254 9 17)
+      (100 "testfile-cp1.ss" 241 245 9 18)
+      (100 "testfile-cp1.ss" 246 253 9 23)
+      (100 "testfile-cp1.ss" 247 248 9 24)
+      (100 "testfile-cp1.ss" 249 250 9 26)
+      (100 "testfile-cp1.ss" 251 252 9 28)
+      (1 "testfile-cp1.ss" 0 260 1 1)
+      (1 "testfile-cp1.ss" 19 259 2 3)
+      (1 "testfile-cp1.ss" 59 60 4 9)
+      (0 "testfile-cp1.ss" 128 178 7 15)
+      (0 "testfile-cp1.ss" 129 136 7 16)
+      (0 "testfile-cp1.ss" 137 177 7 24)
+      (0 "testfile-cp1.ss" 149 164 7 36)
+      (0 "testfile-cp1.ss" 162 163 7 49)
+      (0 "testfile-cp1.ss" 165 176 7 52)
+      (0 "testfile-cp1.ss" 166 173 7 53)
+      (0 "testfile-cp1.ss" 174 175 7 61)))
+  (eqv? 
+    (call/cc
+      (lambda (k)
+        (set! $return k)
+        (let ([ans ($frumble (append (make-list 50 5) (list 0) (make-list 50 7)))])
+          ($return ans))))
+    0)
+  (equal?
+    (filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list))
+    '((152 "testfile-cp1.ss" 36 258 3 5)
+      (152 "testfile-cp1.ss" 40 50 3 9)
+      (152 "testfile-cp1.ss" 41 46 3 10)
+      (152 "testfile-cp1.ss" 47 49 3 16)
+      (151 "testfile-cp1.ss" 69 257 5 9)
+      (151 "testfile-cp1.ss" 78 86 5 18)
+      (151 "testfile-cp1.ss" 79 82 5 19)
+      (151 "testfile-cp1.ss" 83 85 5 23)
+      (151 "testfile-cp1.ss" 99 256 6 11)
+      (151 "testfile-cp1.ss" 103 113 6 15)
+      (151 "testfile-cp1.ss" 104 108 6 16)
+      (151 "testfile-cp1.ss" 109 110 6 21)
+      (151 "testfile-cp1.ss" 111 112 6 23)
+      (150 "testfile-cp1.ss" 193 255 8 15)
+      (150 "testfile-cp1.ss" 202 221 8 24)
+      (150 "testfile-cp1.ss" 203 211 8 25)
+      (150 "testfile-cp1.ss" 212 220 8 34)
+      (150 "testfile-cp1.ss" 213 216 8 35)
+      (150 "testfile-cp1.ss" 217 219 8 39)
+      (100 "testfile-cp1.ss" 240 254 9 17)
+      (100 "testfile-cp1.ss" 241 245 9 18)
+      (100 "testfile-cp1.ss" 246 253 9 23)
+      (100 "testfile-cp1.ss" 247 248 9 24)
+      (100 "testfile-cp1.ss" 249 250 9 26)
+      (100 "testfile-cp1.ss" 251 252 9 28)
+      (1 "testfile-cp1.ss" 0 260 1 1)
+      (1 "testfile-cp1.ss" 19 259 2 3)
+      (1 "testfile-cp1.ss" 59 60 4 9)
+      (1 "testfile-cp1.ss" 128 178 7 15)
+      (1 "testfile-cp1.ss" 129 136 7 16)
+      (1 "testfile-cp1.ss" 137 177 7 24)
+      (1 "testfile-cp1.ss" 149 164 7 36)
+      (1 "testfile-cp1.ss" 162 163 7 49)
+      (1 "testfile-cp1.ss" 165 176 7 52)
+      (1 "testfile-cp1.ss" 166 173 7 53)
+      (1 "testfile-cp1.ss" 174 175 7 61)))
+  (eqv?
+    (call/cc
+      (lambda (k)
+        (set! $return k)
+        ($retry 1)))
+    111022302462515654042363166809082031)
+  (equal?
+    (filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list))
+    '((152 "testfile-cp1.ss" 36 258 3 5)
+      (152 "testfile-cp1.ss" 40 50 3 9)
+      (152 "testfile-cp1.ss" 41 46 3 10)
+      (152 "testfile-cp1.ss" 47 49 3 16)
+      (151 "testfile-cp1.ss" 69 257 5 9)
+      (151 "testfile-cp1.ss" 78 86 5 18)
+      (151 "testfile-cp1.ss" 79 82 5 19)
+      (151 "testfile-cp1.ss" 83 85 5 23)
+      (151 "testfile-cp1.ss" 99 256 6 11)
+      (151 "testfile-cp1.ss" 103 113 6 15)
+      (151 "testfile-cp1.ss" 104 108 6 16)
+      (151 "testfile-cp1.ss" 109 110 6 21)
+      (151 "testfile-cp1.ss" 111 112 6 23)
+      (150 "testfile-cp1.ss" 193 255 8 15)
+      (150 "testfile-cp1.ss" 202 221 8 24)
+      (150 "testfile-cp1.ss" 203 211 8 25)
+      (150 "testfile-cp1.ss" 212 220 8 34)
+      (150 "testfile-cp1.ss" 213 216 8 35)
+      (150 "testfile-cp1.ss" 217 219 8 39)
+      (150 "testfile-cp1.ss" 240 254 9 17)
+      (150 "testfile-cp1.ss" 241 245 9 18)
+      (150 "testfile-cp1.ss" 246 253 9 23)
+      (150 "testfile-cp1.ss" 247 248 9 24)
+      (150 "testfile-cp1.ss" 249 250 9 26)
+      (150 "testfile-cp1.ss" 251 252 9 28)
+      (1 "testfile-cp1.ss" 0 260 1 1)
+      (1 "testfile-cp1.ss" 19 259 2 3)
+      (1 "testfile-cp1.ss" 59 60 4 9)
+      (1 "testfile-cp1.ss" 128 178 7 15)
+      (1 "testfile-cp1.ss" 129 136 7 16)
+      (1 "testfile-cp1.ss" 137 177 7 24)
+      (1 "testfile-cp1.ss" 149 164 7 36)
+      (1 "testfile-cp1.ss" 162 163 7 49)
+      (1 "testfile-cp1.ss" 165 176 7 52)
+      (1 "testfile-cp1.ss" 166 173 7 53)
+      (1 "testfile-cp1.ss" 174 175 7 61)))
+  (begin
+    (collect (collect-maximum-generation)) ; drop code object for the define and lambda
+    (profile-release-counters) ; drop proile information for the dropped code object
+    #t)
+  (equal?
+    (filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list))
+    '((152 "testfile-cp1.ss" 36 258 3 5)
+      (152 "testfile-cp1.ss" 40 50 3 9)
+      (152 "testfile-cp1.ss" 41 46 3 10)
+      (152 "testfile-cp1.ss" 47 49 3 16)
+      (151 "testfile-cp1.ss" 69 257 5 9)
+      (151 "testfile-cp1.ss" 78 86 5 18)
+      (151 "testfile-cp1.ss" 79 82 5 19)
+      (151 "testfile-cp1.ss" 83 85 5 23)
+      (151 "testfile-cp1.ss" 99 256 6 11)
+      (151 "testfile-cp1.ss" 103 113 6 15)
+      (151 "testfile-cp1.ss" 104 108 6 16)
+      (151 "testfile-cp1.ss" 109 110 6 21)
+      (151 "testfile-cp1.ss" 111 112 6 23)
+      (150 "testfile-cp1.ss" 193 255 8 15)
+      (150 "testfile-cp1.ss" 202 221 8 24)
+      (150 "testfile-cp1.ss" 203 211 8 25)
+      (150 "testfile-cp1.ss" 212 220 8 34)
+      (150 "testfile-cp1.ss" 213 216 8 35)
+      (150 "testfile-cp1.ss" 217 219 8 39)
+      (150 "testfile-cp1.ss" 240 254 9 17)
+      (150 "testfile-cp1.ss" 241 245 9 18)
+      (150 "testfile-cp1.ss" 246 253 9 23)
+      (150 "testfile-cp1.ss" 247 248 9 24)
+      (150 "testfile-cp1.ss" 249 250 9 26)
+      (150 "testfile-cp1.ss" 251 252 9 28)
+      (1 "testfile-cp1.ss" 59 60 4 9)
+      (1 "testfile-cp1.ss" 128 178 7 15)
+      (1 "testfile-cp1.ss" 129 136 7 16)
+      (1 "testfile-cp1.ss" 137 177 7 24)
+      (1 "testfile-cp1.ss" 149 164 7 36)
+      (1 "testfile-cp1.ss" 162 163 7 49)
+      (1 "testfile-cp1.ss" 165 176 7 52)
+      (1 "testfile-cp1.ss" 166 173 7 53)
+      (1 "testfile-cp1.ss" 174 175 7 61)))
+  ; test profiling with compiled files
+  (begin
+    (with-output-to-file "testfile-cp2.ss"
+      (lambda ()
+        (display-string "\
+(define cp2-fib
+  (rec fib
+    (lambda (n)
+      (cond
+        [(fx= n 0) 1]
+        [(fx= n 1) 1]
+        [else (+ (fib (- n 1)) (fib (- n 2)))]))))
+"))
+      'replace)
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2] [compile-profile #t])
+      (compile-file "testfile-cp2"))
+    (profile-clear)
+    (load "testfile-cp2.so")
+    #t)
+  (eqv? (cp2-fib 10) 89)
+  (equal?
+    (filter (lambda (x) (equal? (cadr x) "testfile-cp2.ss")) (profile-dump-list))
+    '((177 "testfile-cp2.ss" 49 146 4 7)
+      (177 "testfile-cp2.ss" 64 73 5 10)
+      (177 "testfile-cp2.ss" 65 68 5 11)
+      (177 "testfile-cp2.ss" 69 70 5 15)
+      (177 "testfile-cp2.ss" 71 72 5 17)
+      (143 "testfile-cp2.ss" 86 95 6 10)
+      (143 "testfile-cp2.ss" 87 90 6 11)
+      (143 "testfile-cp2.ss" 91 92 6 15)
+      (143 "testfile-cp2.ss" 93 94 6 17)
+      (88 "testfile-cp2.ss" 113 144 7 15)
+      (88 "testfile-cp2.ss" 114 115 7 16)
+      (88 "testfile-cp2.ss" 116 129 7 18)
+      (88 "testfile-cp2.ss" 117 120 7 19)
+      (88 "testfile-cp2.ss" 121 128 7 23)
+      (88 "testfile-cp2.ss" 122 123 7 24)
+      (88 "testfile-cp2.ss" 124 125 7 26)
+      (88 "testfile-cp2.ss" 126 127 7 28)
+      (88 "testfile-cp2.ss" 130 143 7 32)
+      (88 "testfile-cp2.ss" 131 134 7 33)
+      (88 "testfile-cp2.ss" 135 142 7 37)
+      (88 "testfile-cp2.ss" 136 137 7 38)
+      (88 "testfile-cp2.ss" 138 139 7 40)
+      (88 "testfile-cp2.ss" 140 141 7 42)
+      (55 "testfile-cp2.ss" 96 97 6 20)
+      (34 "testfile-cp2.ss" 74 75 5 20)
+      (1 "testfile-cp2.ss" 0 149 1 1)
+      (1 "testfile-cp2.ss" 18 148 2 3)
+      (1 "testfile-cp2.ss" 23 26 2 8)
+      (1 "testfile-cp2.ss" 31 147 3 5)))
+  (begin
+    (collect (collect-maximum-generation)) ; drop code object for the define and lambda
+    (profile-release-counters) ; drop proile information for the dropped code object
+    #t)
+  (equal?
+    (filter (lambda (x) (equal? (cadr x) "testfile-cp2.ss")) (profile-dump-list))
+    '((177 "testfile-cp2.ss" 49 146 4 7)
+      (177 "testfile-cp2.ss" 64 73 5 10)
+      (177 "testfile-cp2.ss" 65 68 5 11)
+      (177 "testfile-cp2.ss" 69 70 5 15)
+      (177 "testfile-cp2.ss" 71 72 5 17)
+      (143 "testfile-cp2.ss" 86 95 6 10)
+      (143 "testfile-cp2.ss" 87 90 6 11)
+      (143 "testfile-cp2.ss" 91 92 6 15)
+      (143 "testfile-cp2.ss" 93 94 6 17)
+      (88 "testfile-cp2.ss" 113 144 7 15)
+      (88 "testfile-cp2.ss" 114 115 7 16)
+      (88 "testfile-cp2.ss" 116 129 7 18)
+      (88 "testfile-cp2.ss" 117 120 7 19)
+      (88 "testfile-cp2.ss" 121 128 7 23)
+      (88 "testfile-cp2.ss" 122 123 7 24)
+      (88 "testfile-cp2.ss" 124 125 7 26)
+      (88 "testfile-cp2.ss" 126 127 7 28)
+      (88 "testfile-cp2.ss" 130 143 7 32)
+      (88 "testfile-cp2.ss" 131 134 7 33)
+      (88 "testfile-cp2.ss" 135 142 7 37)
+      (88 "testfile-cp2.ss" 136 137 7 38)
+      (88 "testfile-cp2.ss" 138 139 7 40)
+      (88 "testfile-cp2.ss" 140 141 7 42)
+      (55 "testfile-cp2.ss" 96 97 6 20)
+      (34 "testfile-cp2.ss" 74 75 5 20)))
+  (eqv? (profile-clear) (void))
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print
+          '(define f (lambda () 0))))
+      'replace)
+    (parameterize ([compile-profile #t]) (load "testfile.ss" compile))
+    #t)
+  (begin
+    (with-output-to-file "testfile.ss"
+      (lambda ()
+        (pretty-print
+          '(define f (lambda () 1))))
+      'replace)
+    #t)
+  (eqv? (f) 0)
+  (warning? ; unmodified source file not found
+    (parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
+      (profile-dump-list)))
+  (warning? ; unmodified source file not found
+    (parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
+      (profile-dump-list #t)))
+  (warning? ; unmodified source file not found
+    (parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
+      (profile-dump-list #t (profile-dump))))
+  (warning? ; unmodified source file not found
+    (parameterize ([source-directories (cons* "../s" "../unicode" (source-directories))])
+      (profile-dump-list #t (profile-dump))))
+  (guard (c [else #f])
+    (profile-dump-list #f)
+    #t)
+  (guard (c [else #f])
+    (profile-dump-list #f (profile-dump))
+    #t)
+  (eqv? (profile-clear) (void))
+
+  ; verify that annotations are preserved within syntax objects when
+  ; profiling is enabled even when generation of inspector information
+  ; is disabled.
+  (begin
+    (mkfile "testfile-ca3.ss"
+      '(library (testfile-ca3) (export a) (import (chezscheme))
+         (define-syntax a (lambda (x) #'(cons 0 1)))))
+    (mkfile "testfile-cp3.ss"
+      '(import (chezscheme) (testfile-ca3))
+      '(do ([i 123 (fx- i 1)] [q #f a]) ((fx= i 0) (pretty-print q)))
+      '(profile-dump-html))
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([generate-inspector-information #f]
+                        [compile-profile #t])
+           (compile-library x)))
+      'ca3)
+    (separate-compile
+      '(lambda (x)
+         (parameterize ([compile-profile #t])
+           (compile-program x)))
+      'cp3)
+    #t)
+  (equal?
+    (separate-eval
+      '(load-program "testfile-cp3.so")
+      '(cdr (find (lambda (x) (equal? (source-file-descriptor-path (source-object-sfd (car x))) "testfile-ca3.ss")) (profile-dump))))
+    "(0 . 1)\n123\n")
+
+  ; verify that we get profiling information for local macro transformers
+  (begin
+    (call-with-port (open-output-file "testfile-cp4.ss" 'replace)
+      (lambda (op)
+        (put-string op "\
+(let ()
+  (define-syntax a
+    (lambda (q)
+      (define square
+        (lambda (n)
+          (* n n)))
+      (syntax-case q ()
+        [(_ x (d ...) e)
+         #`(let ([x (quote #,(map square (datum (d ...))))])
+             e)])))
+  (pretty-print (list (a b (8 6 7) b) (a b (5 3 0 9) (list b)))))")))
+    (delete-file "testfile-cp4.so")
+    (parameterize ([print-gensym #f] [current-eval compile] [compile-profile #t])
+      (compile-file "testfile-cp4"))
+    #t)
+  (equal?
+    (sort (lambda (x y) (< (list-ref x 2) (list-ref y 2)))
+      (filter (lambda (x) (equal? (list-ref x 1) "testfile-cp4.ss"))
+        (profile-dump-list)))
+    '((1 "testfile-cp4.ss" 31 232 3 5)     ; first transformer count ...
+      (2 "testfile-cp4.ss" 72 102 5 9)
+      (7 "testfile-cp4.ss" 94 101 6 11)
+      (7 "testfile-cp4.ss" 95 96 6 12)
+      (7 "testfile-cp4.ss" 97 98 6 14)
+      (7 "testfile-cp4.ss" 99 100 6 16)
+      (2 "testfile-cp4.ss" 110 231 7 7)
+      (2 "testfile-cp4.ss" 123 124 7 20)
+      (2 "testfile-cp4.ss" 162 229 9 10)
+      (2 "testfile-cp4.ss" 182 210 9 30)
+      (2 "testfile-cp4.ss" 183 186 9 31)
+      (2 "testfile-cp4.ss" 187 193 9 35)
+      (2 "testfile-cp4.ss" 194 209 9 42)   ; ... last transformer count
+      ))
+  (begin
+    (collect (collect-maximum-generation))
+    (profile-release-counters)
+    #t)
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (revisit "testfile-cp4.so")))
+    "((64 36 49) ((25 9 0 81)))\n")
+  (equal?
+    (sort (lambda (x y) (< (list-ref x 2) (list-ref y 2)))
+      (filter (lambda (x) (equal? (list-ref x 1) "testfile-cp4.ss"))
+        (profile-dump-list)))
+    '((1 "testfile-cp4.ss" 0 299 1 1)      ; top-level let
+      (1 "testfile-cp4.ss" 236 298 11 3)   ; pretty-print call ...
+      (1 "testfile-cp4.ss" 237 249 11 4)   ; ... and subforms
+      (1 "testfile-cp4.ss" 250 297 11 17)
+      (1 "testfile-cp4.ss" 251 255 11 18)
+      (1 "testfile-cp4.ss" 256 271 11 23)
+      (1 "testfile-cp4.ss" 269 270 11 36)
+      (1 "testfile-cp4.ss" 272 296 11 39)
+      (1 "testfile-cp4.ss" 287 295 11 54)
+      (1 "testfile-cp4.ss" 288 292 11 55)
+      (1 "testfile-cp4.ss" 293 294 11 60)
+      ))
+)
+
+(mat profile-form
+  (error? ; invalid syntax
+    (profile))
+  (error? ; invalid syntax
+    (profile 1 2 3))
+  (error? ; not a source object
+    (profile 3))
+  (begin
+    (define str "(ugh (if \x3b2;))")
+    (define bv (string->utf8 str))
+    (define ip (open-bytevector-input-port bv))
+    (define sfd (make-source-file-descriptor "foo" ip #t))
+    #t)
+  (eq? (eval `(profile ,(make-source-object sfd 2 3))) (void))
+  (begin
+    (define compile-triv-file
+      (lambda (ifn ofn)
+        (define insert-profile-forms
+          (lambda (x)
+            (unless (annotation? x) (errorf 'compile-triv-file "expected an annotation, got ~s" x))
+            (let ([src (annotation-source x)] [exp (annotation-expression x)])
+              `(begin (profile ,src)
+                 ,(syntax-case exp ()
+                    [(?do-times n e)
+                      (eq? (annotation-expression #'?do-times) 'do-times)
+                      (let ([n (annotation-expression #'n)])
+                        `(do ([i ,n (fx- i 1)]) ((fx= i 0)) ,(insert-profile-forms #'e)))]
+                    [(?print string)
+                      (eq? (annotation-expression #'?print) 'print)
+                      `(printf "~a\n" ,(annotation-expression #'string))]
+                    [else (syntax-error exp)])))))
+        (define parse
+          (lambda (ifn)
+            (let ([ip (open-file-input-port ifn)])
+              (let ([sfd (make-source-file-descriptor ifn ip #t)])
+                (let ([ip (transcoded-port ip (native-transcoder))])
+                  (let f ([bfp 0])
+                    (let-values ([(x bfp) (get-datum/annotations ip sfd bfp)])
+                      (if (eof-object? x)
+                          (begin (close-port ip) '())
+                          (cons x (f bfp))))))))))
+        (parameterize ([compile-profile 'source] [generate-profile-forms #f])
+          (compile-to-file (list `(define (triv) ,@(map insert-profile-forms (parse ifn)))) ofn))))
+    #t)
+  (begin
+    (with-output-to-file "testfile-triv.ss"
+      (lambda ()
+        (pretty-print '(do-times 10 (print "hello")))
+        (pretty-print '(do-times 5 (print "goodbye"))))
+      'replace)
+    (compile-triv-file "testfile-triv.ss" "testfile-triv.so")
+    (load "testfile-triv.so")
+    #t)
+  (equal?
+    (with-output-to-string triv)
+    "hello\nhello\nhello\nhello\nhello\nhello\nhello\nhello\nhello\nhello\ngoodbye\ngoodbye\ngoodbye\ngoodbye\ngoodbye\n")
+  (equal?
+    (sort
+      ; sort by bfp
+      (lambda (x y) (< (list-ref x 2) (list-ref y 2)))
+      (filter (lambda (x) (equal? (list-ref x 1) "testfile-triv.ss")) (profile-dump-list)))
+    '((1 "testfile-triv.ss" 0 29 1 1)
+      (10 "testfile-triv.ss" 13 28 1 14)
+      (1 "testfile-triv.ss" 30 60 2 1)
+      (5 "testfile-triv.ss" 42 59 2 13)))
+  (eqv? (profile-clear) (void))
+)
+
+(mat coverage
+  (begin
+    (mkfile "testfile.ss" '(printf "hello\n"))
+    (define $ct0 (make-source-table))
+    (define $ct0-src1
+      (make-source-object
+        (call-with-port (open-file-input-port "testfile.ss")
+          (lambda (ip)
+            (make-source-file-descriptor "testfile.ss" ip #t)))
+        3 7))
+    (define $ct0-src2
+      (make-source-object
+        (call-with-port (open-file-input-port "testfile.ss")
+          (lambda (ip)
+            (make-source-file-descriptor "testfile.ss" ip #t)))
+        5 11))
+    (define $ct0-src3
+      (make-source-object
+        (call-with-port (open-file-input-port "testfile.ss")
+          (lambda (ip)
+            (make-source-file-descriptor "not-testfile.ss" ip #t)))
+        17 19))
+    #t)
+  (source-table? $ct0)
+  (= (source-table-size $ct0) 0)
+  (not (source-table-contains? $ct0 $ct0-src1))
+  (eq? (source-table-ref $ct0 $ct0-src2 'q) 'q)
+  (begin
+    (source-table-set! $ct0 $ct0-src1 17)
+    #t)
+  (= (source-table-size $ct0) 1)
+  (source-table-contains? $ct0 $ct0-src1)
+  (not (source-table-contains? $ct0 $ct0-src2))
+  (eq? (source-table-ref $ct0 $ct0-src3 'q) 'q)
+  (begin
+    (source-table-set! $ct0 $ct0-src2 37)
+    (source-table-set! $ct0 $ct0-src3 43)
+    #t)
+  (= (source-table-size $ct0) 3)
+  (source-table-contains? $ct0 $ct0-src1)
+  (source-table-contains? $ct0 $ct0-src2)
+  (source-table-contains? $ct0 $ct0-src3)
+  (eqv? (source-table-ref $ct0 $ct0-src1 'q) 17)
+  (eqv? (source-table-ref $ct0 $ct0-src2 'q) 37)
+  (eqv? (source-table-ref $ct0 $ct0-src3 'q) 43)
+  (let ([a (source-table-cell $ct0 $ct0-src1 #f)])
+    (and (eqv? (cdr a) 17)
+         (begin
+           (set-cdr! a 23)
+           #t)))
+  (= (source-table-size $ct0) 3)
+  (source-table-contains? $ct0 $ct0-src1)
+  (source-table-contains? $ct0 $ct0-src2)
+  (source-table-contains? $ct0 $ct0-src3)
+  (eqv? (source-table-ref $ct0 $ct0-src1 'q) 23)
+  (eqv? (source-table-ref $ct0 $ct0-src2 'q) 37)
+  (eqv? (source-table-ref $ct0 $ct0-src3 'q) 43)
+  (eqv? (source-table-delete! $ct0 $ct0-src1) (void))
+  (= (source-table-size $ct0) 2)
+  (not (source-table-contains? $ct0 $ct0-src1))
+  (source-table-contains? $ct0 $ct0-src2)
+  (source-table-contains? $ct0 $ct0-src3)
+  (eqv? (source-table-delete! $ct0 $ct0-src3) (void))
+  (= (source-table-size $ct0) 1)
+  (not (source-table-contains? $ct0 $ct0-src1))
+  (source-table-contains? $ct0 $ct0-src2)
+  (not (source-table-contains? $ct0 $ct0-src3))
+  (eqv? (source-table-delete! $ct0 $ct0-src2) (void))
+  (= (source-table-size $ct0) 0)
+  (not (source-table-contains? $ct0 $ct0-src1))
+  (not (source-table-contains? $ct0 $ct0-src2))
+  (not (source-table-contains? $ct0 $ct0-src3))
+  (begin
+    (define $source-table-filter
+      (lambda (universe-ct ct)
+        (let ([new-ct (make-source-table)])
+          (for-each
+            (lambda (p)
+              (let ([src (car p)] [count (cdr p)])
+                (when (source-table-contains? universe-ct src)
+                  (source-table-set! new-ct src count))))
+            (source-table-dump ct))
+          new-ct)))
+    (begin
+      (mkfile "testfile-coverage1a.ss"
+        '(library (testfile-coverage1a) (export a f) (import (chezscheme))
+           (define-syntax a (lambda (x) #'(cons 0 1)))
+           (define f (lambda (x) (if (= x 0) 1 (* x (f (- x 1))))))))
+      (parameterize ([generate-covin-files #t] [compile-profile #t])
+        (compile-library "testfile-coverage1a")))
+    (begin
+      (mkfile "testfile-coverage1b.ss"
+        `(top-level-program
+           (import (chezscheme) (testfile-coverage1a))
+           (do ([i 3 (fx- i 1)])
+               ((fx= i 0) (printf "~s\n" (f 3)))
+             (printf "a = ~s\n" a))))
+      (call-with-port (open-file-input-port "testfile-coverage1b.ss")
+        (lambda (ip)
+          (let ([sfd (make-source-file-descriptor "testfile-coverage1b.ss" ip #t)])
+            (call-with-port (transcoded-port ip (native-transcoder))
+              (lambda (ip)
+                (call-with-port (open-file-output-port "testfile-coverage1b.so" (file-options replace))
+                  (lambda (op)
+                    (call-with-port (open-output-file "testfile-coverage1b.covin" 'replace)
+                      (lambda (covop)
+                        (parameterize ([compile-profile #t])
+                          (compile-port ip op sfd #f covop))))))))))))
+    (begin
+      (mkfile "testfile-coverage1c.ss"
+        '(top-level-program
+           (import (chezscheme) (testfile-coverage1a))
+           (do ([i 4 (fx- i 1)])
+               ((fx= i 0) (printf "~s\n" (f 4)))
+             (printf "a = ~s\n" a))))
+      (call-with-port (open-file-input-port "testfile-coverage1c.ss")
+        (lambda (ip)
+          (let ([sfd (make-source-file-descriptor "testfile-coverage1c.ss" ip #t)])
+            (call-with-port (transcoded-port ip (native-transcoder))
+              (lambda (ip)
+                (call-with-port (open-file-output-port "testfile-coverage1c.so" (file-options replace))
+                  (lambda (op)
+                    (call-with-port (open-output-file "testfile-coverage1c.covin" 'replace)
+                      (lambda (covop)
+                        (parameterize ([compile-profile #t])
+                          (let-values ([(x fp) (get-datum/annotations ip sfd 0)])
+                            (compile-to-port (list x) op sfd #f covop)))))))))))))
+    (begin
+      (mkfile "testfile-coverage1d.ss"
+        '(import (chezscheme) (testfile-coverage1a))
+        '(do ([i 3 (fx- i 1)])
+             ((fx= i 0) (printf "~s\n" (f 5)))
+           (printf "a = ~s\n" a)))
+      (parameterize ([generate-covin-files #t] [compile-profile #t])
+        (compile-program "testfile-coverage1d")))
+    (define $ct0
+      (let ()
+        (define (with-source-input-port path p)
+          (call-with-port
+            (open-file-input-port path
+              (file-options compressed)
+              (buffer-mode block)
+              (current-transcoder))
+            p))
+        (let ([ct (make-source-table)])
+          (with-source-input-port "testfile-coverage1b.covin" (lambda (ip) (get-source-table! ip ct)))
+          (with-source-input-port "testfile-coverage1c.covin" (lambda (ip) (get-source-table! ip ct (lambda (x y) (assert (= x y 0)) x))))
+          ct)))
+    #t)
+  (source-table? $ct0)
+  (andmap zero? (map cdr (source-table-dump $ct0)))
+  (call-with-values
+    (lambda ()
+      (with-profile-tracker
+        (lambda ()
+          (call/cc
+            (lambda (k)
+              (values k
+                (with-output-to-string
+                  (lambda ()
+                    (load-program "testfile-coverage1b.so")
+                    (load-program "testfile-coverage1c.so")
+                    (load-program "testfile-coverage1d.so")))))))))
+    (lambda (ct k s)
+      (let* ([ct ($source-table-filter $ct0 ct)])
+        (if k
+            (and (string=? s "a = (0 . 1)\na = (0 . 1)\na = (0 . 1)\n6\na = (0 . 1)\na = (0 . 1)\na = (0 . 1)\na = (0 . 1)\n24\na = (0 . 1)\na = (0 . 1)\na = (0 . 1)\n120\n")
+                 (procedure? k)
+                 (begin
+                   (set! $ct1 ct)
+                   (k #f "yup.")))
+            (and (string=? s "yup.")
+                 (begin
+                   (set! $ct2 ct)
+                   #t))))))
+  (source-table? $ct1)
+  (source-table? $ct2)
+  (and
+    (andmap
+      (lambda (dumpit)
+        (and (source-table-contains? $ct2 (car dumpit))
+             (>= (source-table-ref $ct2 (car dumpit) #f) (cdr dumpit))))
+      (source-table-dump $ct1))
+    (andmap
+      (lambda (dumpit)
+        (and (source-table-contains? $ct1 (car dumpit))
+             (<= (source-table-ref $ct1 (car dumpit) #f) (cdr dumpit))))
+      (source-table-dump $ct2)))
+  (not (ormap zero? (map cdr (source-table-dump $ct1))))
+  (let ([dump (source-table-dump $ct1)])
+    (define (file-found? path)
+      (ormap
+        (lambda (dumpit)
+          (string=? (source-file-descriptor-path (source-object-sfd (car dumpit))) path))
+        dump))
+    (and (file-found? "testfile-coverage1a.ss")
+         (file-found? "testfile-coverage1b.ss")
+         (file-found? "testfile-coverage1c.ss")
+         (not (file-found? "testfile-coverage1d.ss"))))
+    (string=?
+      (with-output-to-string
+        (lambda ()
+          ; shouldn't matter whether this is before or after the with-profile-tracker call
+          (load-program "testfile-coverage1b.so")
+          (let-values ([(ct . ignore) (with-profile-tracker #t
+                                        (lambda ()
+                                          (load-program "testfile-coverage1c.so")
+                                          (load-program "testfile-coverage1d.so")))])
+            (let ([ct ($source-table-filter $ct0 ct)])
+              (set! $ct3 ct)))))
+      "a = (0 . 1)\na = (0 . 1)\na = (0 . 1)\n6\na = (0 . 1)\na = (0 . 1)\na = (0 . 1)\na = (0 . 1)\n24\na = (0 . 1)\na = (0 . 1)\na = (0 . 1)\n120\n")
+  (source-table? $ct3)
+  (let ([dump (source-table-dump $ct3)])
+    (define (file-found? path)
+      (ormap
+        (lambda (dumpit)
+          (string=? (source-file-descriptor-path (source-object-sfd (car dumpit))) path))
+        dump))
+    (and (file-found? "testfile-coverage1a.ss")
+         (file-found? "testfile-coverage1b.ss")
+         (file-found? "testfile-coverage1c.ss")
+         (not (file-found? "testfile-coverage1d.ss"))))
+  ; the coverage table retreived should include counts for both sets of load-program calls
+  (and
+    (andmap
+      (lambda (dumpit)
+        (>= (source-table-ref $ct3 (car dumpit) #f) (* 2 (cdr dumpit))))
+      (source-table-dump $ct1))
+    (andmap
+      (lambda (dumpit)
+        (<= (* 2 (source-table-ref $ct1 (car dumpit) #f)) (cdr dumpit)))
+      (source-table-dump $ct3)))
+  (begin
+    (call-with-output-file "testfile.covout"
+      (lambda (op)
+        (put-source-table op $ct3))
+      'replace)
+    (define $ct5
+      (let ([ct (make-source-table)])
+        (call-with-input-file "testfile.covout" (lambda (ip) (get-source-table! ip ct)))
+        ct))
+    #t)
+  (andmap
+    (lambda (dumpit)
+      (= (source-table-ref $ct5 (car dumpit) #f) (cdr dumpit)))
+    (source-table-dump $ct3))
+  (andmap
+    (lambda (dumpit)
+      (= (source-table-ref $ct3 (car dumpit) #f) (cdr dumpit)))
+    (source-table-dump $ct5))
+  (begin
+    (call-with-input-file "testfile.covout" (lambda (ip) (get-source-table! ip $ct5 (lambda (x y) (- (* x y))))))
+    #t)
+  (andmap
+    (lambda (dumpit)
+      (= (source-table-ref $ct5 (car dumpit) #f) (- (expt (cdr dumpit) 2))))
+    (source-table-dump $ct3))
+)

mats/record.ms

@@ -8325,7 +8325,7 @@
       (record? (make-xftr) (record-type-descriptor prnt)))
     #f)
   (equivalent-expansion?
-    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [compile-profile #f])
       (expand/optimize
         '(lambda (x)
            (define-record-type bar)
@@ -8334,7 +8334,7 @@
        (#3%record? x (#2%$make-record-type-descriptor #!base-rtd 'bar #f #f #f #f '#() 'define-record-type))))
 
   (equivalent-expansion?
-    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [compile-profile #f])
       (expand/optimize
         '(lambda (x)
            (define-record-type bar (sealed #t))
@@ -8775,7 +8775,7 @@
     '(lambda (a) (#3%list (#3%cons a a) a)))
   ; oscar's example
   (equivalent-expansion?
-    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [compile-profile #f])
       (expand/optimize
         '(let ()
            (import scheme)
@@ -8788,7 +8788,7 @@
                r)))))
     `(lambda (x) (#3%$record ',record-type-descriptor? 37 (#3%+ 1 (#2%+ 1 x)))))
   (equivalent-expansion?
-    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [compile-profile #f])
       (expand/optimize
         '(let ()
            (import scheme)

mats/root-experr-compile-0-f-f-f

@@ -1,3 +1,132 @@
+primvars.mo:Expected error testing (environment (quote 0)): Exception in environment: invalid library reference 0
+primvars.mo:Expected error testing (environment (quote (a . b))): Exception in environment: invalid library reference (a . b)
+primvars.mo:Expected error testing (environment (quote #f)): Exception in environment: invalid library reference #f
+primvars.mo:Expected error testing (environment (quote 0) (quote (chezscheme))): Exception in environment: invalid library reference 0
+primvars.mo:Expected error testing (environment (quote (a . b)) (quote (chezscheme))): Exception in environment: invalid library reference (a . b)
+primvars.mo:Expected error testing (environment (quote #f) (quote (chezscheme))): Exception in environment: invalid library reference #f
+primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote 0)): Exception in environment: invalid library reference 0
+primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (a . b))): Exception in environment: invalid library reference (a . b)
+primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
+primvars.mo:Expected error testing (environment (quote 0) (quote (chezscheme)) (quote (chezscheme))): Exception in environment: invalid library reference 0
+primvars.mo:Expected error testing (environment (quote (a . b)) (quote (chezscheme)) (quote (chezscheme))): Exception in environment: invalid library reference (a . b)
+primvars.mo:Expected error testing (environment (quote #f) (quote (chezscheme)) (quote (chezscheme))): Exception in environment: invalid library reference #f
+primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote 0) (quote (chezscheme))): Exception in environment: invalid library reference 0
+primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (a . b)) (quote (chezscheme))): Exception in environment: invalid library reference (a . b)
+primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote #f) (quote (chezscheme))): Exception in environment: invalid library reference #f
+primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote 0)): Exception in environment: invalid library reference 0
+primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote (a . b))): Exception in environment: invalid library reference (a . b)
+primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
+primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure
+primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure
+primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in compile: ((a . b)) is not an environment
+primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in compile: #f is not an environment
+primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment
+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
+primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f) 1.0+2.0i): 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 1.0+2.0i): Exception in sc-expand: ((a . b)) is not an environment
+primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f) 1.0+2.0i 1.0+2.0i): 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 1.0+2.0i "a"): Exception in sc-expand: ((a . b)) is not an environment
+primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f) 1.0+2.0i 1.0+2.0i "a"): Exception in sc-expand: #f is not an environment
+primvars.mo:Expected error testing (expand 1.0+2.0i *env 1.0+2.0i 1.0+2.0i (quote a)): Exception in sc-expand: a is not a string or #f
+primvars.mo:Expected error testing (fxpopcount (quote #!eof)): Exception in fxpopcount32: #!eof is not a non-negative fixnum
+primvars.mo:Expected error testing (fxpopcount (quote #f)): Exception in fxpopcount32: #f is not a non-negative fixnum
+primvars.mo:Expected error testing (hashtable-cells (quote ((a . b)))): Exception in hashtable-size: ((a . b)) is not a hashtable
+primvars.mo:Expected error testing (hashtable-cells (quote #f)): Exception in hashtable-size: #f is not a hashtable
+primvars.mo:Expected error testing (make-input-port (quote 0) "a"): Exception in make-input-port: fixnum handler no longer supported; use open-fd-input-port
+primvars.mo:Expected error testing (make-input/output-port (quote 0) "a" "a"): Exception in make-input/output-port: fixnum handler no longer supported; use open-fd-input-port
+primvars.mo:Expected error testing (make-output-port (quote 0) "a"): Exception in make-output-port: fixnum handler no longer supported; use open-fd-input-port
+primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i (quote q) (- (most-negative-fixnum) 1)): Exception in make-record-type-descriptor*: invalid field count q
+primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i (quote 1152921504606846976) (- (most-negative-fixnum) 1)): Exception in make-record-type-descriptor*: invalid field count 1152921504606846976
+primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i (quote -1152921504606846977) (- (most-negative-fixnum) 1)): Exception in make-record-type-descriptor*: invalid field count -1152921504606846977
+primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i (quote #f) (- (most-negative-fixnum) 1)): Exception in make-record-type-descriptor*: invalid field count #f
+primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i -1 (quote 2.0)): Exception in make-record-type-descriptor*: invalid field count -1
+primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i -1 (quote 1/2)): Exception in make-record-type-descriptor*: invalid field count -1
+primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i -1 (quote #f)): Exception in make-record-type-descriptor*: invalid field count -1
+primvars.mo:Expected error testing (make-sstats (quote "no-time") *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: cpu value "no-time" is not a time record
+primvars.mo:Expected error testing (make-sstats (quote #f) *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: cpu value #f is not a time record
+primvars.mo:Expected error testing (make-sstats *time (quote "no-time") (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: real value "no-time" is not a time record
+primvars.mo:Expected error testing (make-sstats *time (quote #f) (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: real value #f is not a time record
+primvars.mo:Expected error testing (make-sstats *time *time (quote 2.0) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: bytes value 2.0 is not an exact integer
+primvars.mo:Expected error testing (make-sstats *time *time (quote 1/2) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: bytes value 1/2 is not an exact integer
+primvars.mo:Expected error testing (make-sstats *time *time (quote #f) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: bytes value #f is not an exact integer
+primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (quote 2.0) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-count value 2.0 is not an exact integer
+primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (quote 1/2) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-count value 1/2 is not an exact integer
+primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (quote #f) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-count value #f is not an exact integer
+primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) (quote "no-time") *time (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-cpu value "no-time" is not a time record
+primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) (quote #f) *time (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-cpu value #f is not a time record
+primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time (quote "no-time") (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-real value "no-time" is not a time record
+primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time (quote #f) (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-real value #f is not a time record
+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 (pseudo-random-generator->vector (quote #f)): Exception in pseudo-random-generator->vector: not a pseudo-random generator #f
+primvars.mo:Expected error testing (pseudo-random-generator-seed! *pseudo-random-generator (quote #!eof)): Exception: variable *pseudo-random-generator is not bound
+primvars.mo:Expected error testing (pseudo-random-generator-seed! *pseudo-random-generator (quote #f)): Exception: variable *pseudo-random-generator is not bound
+primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #f)): Exception in pseudo-random-generator-next!: not a pseudo-random generator #f
+primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #!eof) *pseudo-random-generator): Exception: variable *pseudo-random-generator is not bound
+primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #f) *pseudo-random-generator): Exception: variable *pseudo-random-generator is not bound
+primvars.mo:Expected error testing (set-wrapper-procedure! 1.0+2.0i (quote 0)): Exception in set-wrapper-procedure!: 1.0+2.0i is not a wrapper procedure
+primvars.mo:Expected error testing (set-wrapper-procedure! 1.0+2.0i (quote #f)): Exception in set-wrapper-procedure!: 1.0+2.0i is not a wrapper procedure
+primvars.mo:Expected error testing (stencil-vector (quote -1)): Exception in stencil-vector: invalid mask -1
+primvars.mo:Expected error testing (stencil-vector (quote a)): Exception in stencil-vector: invalid mask a
+primvars.mo:Expected error testing (stencil-vector (quote 18446744073709551616)): Exception in stencil-vector: invalid mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector (quote #f)): Exception in stencil-vector: invalid mask #f
+primvars.mo:Expected error testing (stencil-vector (quote -1) 1.0+2.0i): Exception in stencil-vector: invalid mask -1
+primvars.mo:Expected error testing (stencil-vector (quote a) 1.0+2.0i): Exception in stencil-vector: invalid mask a
+primvars.mo:Expected error testing (stencil-vector (quote 18446744073709551616) 1.0+2.0i): Exception in stencil-vector: invalid mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector (quote #f) 1.0+2.0i): Exception in stencil-vector: invalid mask #f
+primvars.mo:Expected error testing (stencil-vector (quote -1) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask -1
+primvars.mo:Expected error testing (stencil-vector (quote a) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask a
+primvars.mo:Expected error testing (stencil-vector (quote 18446744073709551616) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector (quote #f) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask #f
+primvars.mo:Expected error testing (stencil-vector (quote -1) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask -1
+primvars.mo:Expected error testing (stencil-vector (quote a) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask a
+primvars.mo:Expected error testing (stencil-vector (quote 18446744073709551616) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector (quote #f) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask #f
+primvars.mo:Expected error testing (stencil-vector-truncate! (stencil-vector 7 1 2 3) (quote -1)): Exception in stencil-vector-truncate!: invalid mask -1
+primvars.mo:Expected error testing (stencil-vector-truncate! (stencil-vector 7 1 2 3) (quote a)): Exception in stencil-vector-truncate!: invalid mask a
+primvars.mo:Expected error testing (stencil-vector-truncate! (stencil-vector 7 1 2 3) (quote 18446744073709551616)): Exception in stencil-vector-truncate!: invalid mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector-truncate! (stencil-vector 7 1 2 3) (quote #f)): Exception in stencil-vector-truncate!: invalid mask #f
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote -1) 0): Exception in stencil-vector-update: invalid removal mask -1
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote a) 0): Exception in stencil-vector-update: invalid removal mask a
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote 18446744073709551616) 0): Exception in stencil-vector-update: invalid removal mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote #f) 0): Exception in stencil-vector-update: invalid removal mask #f
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote -1)): Exception in stencil-vector-update: invalid addition mask -1
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote a)): Exception in stencil-vector-update: invalid addition mask a
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote 18446744073709551616)): Exception in stencil-vector-update: invalid addition mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote #f)): Exception in stencil-vector-update: invalid addition mask #f
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote -1) 0 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask -1
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote a) 0 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask a
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote 18446744073709551616) 0 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote #f) 0 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask #f
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote -1) 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask -1
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote a) 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask a
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote 18446744073709551616) 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote #f) 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask #f
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote -1) 0 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask -1
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote a) 0 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask a
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote 18446744073709551616) 0 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote #f) 0 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask #f
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote -1) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask -1
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote a) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask a
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote 18446744073709551616) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote #f) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask #f
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote -1) 0 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask -1
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote a) 0 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask a
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote 18446744073709551616) 0 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote #f) 0 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask #f
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote -1) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask -1
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote a) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask a
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote 18446744073709551616) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask 18446744073709551616
+primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote #f) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask #f
+primvars.mo:Expected error testing (vector->pseudo-random-generator (quote "a")): Exception in vector->pseudo-random-generator: not a valid pseudo-random generator state vector "a"
+primvars.mo:Expected error testing (vector->pseudo-random-generator (quote #f)): Exception in vector->pseudo-random-generator: not a valid pseudo-random generator state vector #f
+primvars.mo:Expected error testing (vector->pseudo-random-generator! (quote #f) (quote #(a))): Exception in vector->pseudo-random-generator!: not a pseudo-random generator #f
+primvars.mo:Expected error testing (vector->pseudo-random-generator! *pseudo-random-generator (quote "a")): Exception: variable *pseudo-random-generator is not bound
+primvars.mo:Expected error testing (vector->pseudo-random-generator! *pseudo-random-generator (quote #f)): Exception: variable *pseudo-random-generator is not bound
+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 1 to #<procedure>".
@@ -14,7 +143,7 @@ primvars.mo:Expected error in mat current-output-port: "current-output-port: #<i
 primvars.mo:Expected error in mat eval-syntax-expanders-when: "eval-syntax-expanders-when: invalid eval-when list (compiling)".
 primvars.mo:Expected error in mat gensym-count: "gensym-count: "g" is not a nonnegative integer".
 primvars.mo:Expected error in mat keyboard-interrupt-handler: "keyboard-interrupt-handler: 0 is not a procedure".
-primvars.mo:Expected error in mat optimize-level: "optimize-level: 4 is not valid optimize level".
+primvars.mo:Expected error in mat optimize-level: "optimize-level: 4 is not a valid optimize level".
 primvars.mo:Expected error in mat pretty-line-length: "pretty-line-length: -1 is not a positive fixnum".
 primvars.mo:Expected error in mat pretty-line-length: "pretty-line-length: <int> is not a positive fixnum".
 primvars.mo:Expected error in mat pretty-one-line-limit: "pretty-one-line-limit: 0 is not a positive fixnum".
@@ -330,12 +459,12 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular".
 4.mo:Expected error in mat fold-right: "fold-right: lists (a b) and (p q r) differ in length".
 4.mo:Expected error in mat fold-right: "fold-right: lists (1 2) and (p q r) differ in length".
-4.mo:Expected error in mat fold-right: "map: a is not a proper list".
+4.mo:Expected error in mat fold-right: "fold-right: a is not a proper list".
-4.mo:Expected error in mat fold-right: "map: a is not a proper list".
+4.mo:Expected error in mat fold-right: "fold-right: a is not a proper list".
-4.mo:Expected error in mat fold-right: "map: (a . b) is not a proper list".
+4.mo:Expected error in mat fold-right: "fold-right: (a . b) is not a proper list".
-4.mo:Expected error in mat fold-right: "map: (a . b) is not a proper list".
+4.mo:Expected error in mat fold-right: "fold-right: (a . b) is not a proper list".
-4.mo:Expected error in mat fold-right: "map: (a a a a a a ...) is circular".
+4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular".
-4.mo:Expected error in mat fold-right: "map: (a a a a a a ...) is circular".
+4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular".
 4.mo:Expected error in mat fold-right: "fold-right: a is not a proper list".
 4.mo:Expected error in mat fold-right: "fold-right: a is not a proper list".
 4.mo:Expected error in mat fold-right: "fold-right: a is not a proper list".
@@ -1725,6 +1854,85 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
 5_3.mo:Expected error in mat div0-and-mod0: "mod0: undefined for 0".
 5_3.mo:Expected error in mat div0-and-mod0: "mod0: undefined for a".
 5_3.mo:Expected error in mat div0-and-mod0: "mod0: undefined for (a)".
+5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for bogus".
+5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for bogus".
+5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 4+3i".
+5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 4+3i".
+5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "div: undefined for bogus".
+5_3.mo:Expected error in mat special-cases: "div: undefined for bogus".
+5_3.mo:Expected error in mat special-cases: "div: undefined for 4+3i".
+5_3.mo:Expected error in mat special-cases: "div: undefined for 4+3i".
+5_3.mo:Expected error in mat special-cases: "div: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "div: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "div: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "mod: undefined for bogus".
+5_3.mo:Expected error in mat special-cases: "mod: undefined for bogus".
+5_3.mo:Expected error in mat special-cases: "mod: undefined for 4+3i".
+5_3.mo:Expected error in mat special-cases: "mod: undefined for 4+3i".
+5_3.mo:Expected error in mat special-cases: "mod: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "mod: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "mod: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for bogus".
+5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for bogus".
+5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 4+3i".
+5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 4+3i".
+5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "div0: undefined for bogus".
+5_3.mo:Expected error in mat special-cases: "div0: undefined for bogus".
+5_3.mo:Expected error in mat special-cases: "div0: undefined for 4+3i".
+5_3.mo:Expected error in mat special-cases: "div0: undefined for 4+3i".
+5_3.mo:Expected error in mat special-cases: "div0: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "div0: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "div0: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "mod0: undefined for bogus".
+5_3.mo:Expected error in mat special-cases: "mod0: undefined for bogus".
+5_3.mo:Expected error in mat special-cases: "mod0: undefined for 4+3i".
+5_3.mo:Expected error in mat special-cases: "mod0: undefined for 4+3i".
+5_3.mo:Expected error in mat special-cases: "mod0: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "mod0: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "mod0: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "quotient: bogus is not an integer".
+5_3.mo:Expected error in mat special-cases: "quotient: bogus is not an integer".
+5_3.mo:Expected error in mat special-cases: "quotient: 4+3i is not an integer".
+5_3.mo:Expected error in mat special-cases: "quotient: 4.5 is not an integer".
+5_3.mo:Expected error in mat special-cases: "quotient: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "quotient: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "quotient: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "remainder: bogus is not an integer".
+5_3.mo:Expected error in mat special-cases: "remainder: bogus is not an integer".
+5_3.mo:Expected error in mat special-cases: "remainder: 4+3i is not an integer".
+5_3.mo:Expected error in mat special-cases: "remainder: 4.5 is not an integer".
+5_3.mo:Expected error in mat special-cases: "remainder: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "remainder: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "remainder: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "modulo: bogus is not an integer".
+5_3.mo:Expected error in mat special-cases: "modulo: bogus is not an integer".
+5_3.mo:Expected error in mat special-cases: "modulo: 4+3i is not an integer".
+5_3.mo:Expected error in mat special-cases: "modulo: 4.5 is not an integer".
+5_3.mo:Expected error in mat special-cases: "modulo: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "modulo: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "modulo: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "/: bogus is not a number".
+5_3.mo:Expected error in mat special-cases: "/: bogus is not a number".
+5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
+5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
+5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
+5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
+5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
+5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
+5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
+5_3.mo:Expected error in mat special-cases: "+: bogus is not a number".
+5_3.mo:Expected error in mat special-cases: "+: bogus is not a number".
+5_3.mo:Expected error in mat special-cases: "-: bogus is not a number".
+5_3.mo:Expected error in mat special-cases: "-: bogus is not a number".
 5_3.mo:Expected error in mat popcount: "fxpopcount32: #f is not a non-negative fixnum".
 5_3.mo:Expected error in mat popcount: "fxpopcount32: 1.0 is not a non-negative fixnum".
 5_3.mo:Expected error in mat popcount: "fxpopcount32: 1267650600228229401496703205376 is not a non-negative fixnum".
@@ -3704,6 +3912,97 @@ bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress:
 bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
 bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
 bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
+bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
+profile.mo:Expected error in mat compile-profile: "compile-profile: invalid mode src [must be #f, #t, source, or block]".
+profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump (quote ()))".
+profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-clear (quote ()))".
+profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-list #t (quote ()) 3)".
+profile.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump 17".
+profile.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump (17)".
+profile.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump ((a . 17))".
+profile.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump ((#<source abc[0:3]> . q))".
+profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-html "" (quote ()) 3)".
+profile.mo:Expected error in mat compile-profile: "profile-dump-html: (prefix) is not a string".
+profile.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump 17".
+profile.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump (17)".
+profile.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump ((a . 17))".
+profile.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump ((#<source abc[0:3]> . q))".
+profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-data)".
+profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-data "profile.data" (quote ()) (quote q))".
+profile.mo:Expected error in mat compile-profile: "profile-dump-data: #t is not a string".
+profile.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump 17".
+profile.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump (17)".
+profile.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump ((a . 17))".
+profile.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump ((#<source abc[0:3]> . q))".
+profile.mo:Expected error in mat compile-profile: "profile-load-data: what? is not a string".
+profile.mo:Expected error in mat compile-profile: "profile-palette: palette #() has too few entries".
+profile.mo:Expected error in mat compile-profile: "profile-palette: palette #(("black" . "white")) has too few entries".
+profile.mo:Expected error in mat compile-profile: "profile-palette: palette #(("black" . "white") ("red" . "white")) has too few entries".
+profile.mo:Expected error in mat compile-profile: "profile-palette: invalid palette #(("black" . "white") #("red" "white") ("blue" . "black"))".
+profile.mo:Expected error in mat compile-profile: "profile-palette: invalid palette #(("black" . "white") ("red" . "white") ("blue" . black))".
+profile.mo:Expected error in mat compile-profile: "profile-palette: invalid palette #(("black" . "white") ("red" . "white") (255 . "black"))".
+profile.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
+profile.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
+profile.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
+profile.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
+profile.mo:Expected error in mat profile-form: "invalid syntax (profile)".
+profile.mo:Expected error in mat profile-form: "invalid syntax (profile 1 2 3)".
+profile.mo:Expected error in mat profile-form: "profile subform is not a source object 3".
 misc.mo:Expected error in mat compiler1: "variable i-am-not-bound is not bound".
 misc.mo:Expected error in mat compiler1: "attempt to apply non-procedure oops".
 misc.mo:Expected error in mat compiler1: "incorrect argument count in call (g (list))".
@@ -3743,10 +4042,10 @@ misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid g
 misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen".
 misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1".
 misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments 1 to #<procedure find-next>".
-misc.mo:Expected error in mat subset: "subset-mode: ieee is not valid subset mode".
+misc.mo:Expected error in mat subset: "subset-mode: ieee is not a valid subset mode".
-misc.mo:Expected error in mat subset: "subset-mode: r4rs is not valid subset mode".
+misc.mo:Expected error in mat subset: "subset-mode: r4rs is not a valid subset mode".
-misc.mo:Expected error in mat subset: "subset-mode: r5rs is not valid subset mode".
+misc.mo:Expected error in mat subset: "subset-mode: r5rs is not a valid subset mode".
-misc.mo:Expected error in mat subset: "subset-mode: #t is not valid subset mode".
+misc.mo:Expected error in mat subset: "subset-mode: #t is not a valid subset mode".
 misc.mo:Expected error in mat eval: "attempt to reference unbound identifier force".
 misc.mo:Expected error in mat eval: "attempt to reference unbound identifier force".
 misc.mo:Expected error in mat eval: "attempt to reference unbound identifier cons".
@@ -3787,45 +4086,14 @@ misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable
 misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
 misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
 misc.mo:Expected error in mat cpletrec: "attempt to assign undefined variable b".
-misc.mo:Expected error in mat compile-profile: "compile-profile: invalid mode src [must be #f, #t, source, or block]".
-misc.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump (quote ()))".
-misc.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-clear (quote ()))".
-misc.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-list #t (quote ()) 3)".
-misc.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump 17".
-misc.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump (17)".
-misc.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump ((a . 17))".
-misc.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump ((#<source abc[0:3]> . q))".
-misc.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-html "" (quote ()) 3)".
-misc.mo:Expected error in mat compile-profile: "profile-dump-html: (prefix) is not a string".
-misc.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump 17".
-misc.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump (17)".
-misc.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump ((a . 17))".
-misc.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump ((#<source abc[0:3]> . q))".
-misc.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-data)".
-misc.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-data "profile.data" (quote ()) (quote q))".
-misc.mo:Expected error in mat compile-profile: "profile-dump-data: #t is not a string".
-misc.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump 17".
-misc.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump (17)".
-misc.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump ((a . 17))".
-misc.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump ((#<source abc[0:3]> . q))".
-misc.mo:Expected error in mat compile-profile: "profile-load-data: what? is not a string".
-misc.mo:Expected error in mat compile-profile: "profile-palette: palette #() has too few entries".
-misc.mo:Expected error in mat compile-profile: "profile-palette: palette #(("black" . "white")) has too few entries".
-misc.mo:Expected error in mat compile-profile: "profile-palette: palette #(("black" . "white") ("red" . "white")) has too few entries".
-misc.mo:Expected error in mat compile-profile: "profile-palette: invalid palette #(("black" . "white") #("red" "white") ("blue" . "black"))".
-misc.mo:Expected error in mat compile-profile: "profile-palette: invalid palette #(("black" . "white") ("red" . "white") ("blue" . black))".
-misc.mo:Expected error in mat compile-profile: "profile-palette: invalid palette #(("black" . "white") ("red" . "white") (255 . "black"))".
-misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
-misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
-misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
-misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
-misc.mo:Expected error in mat profile-form: "invalid syntax (profile)".
-misc.mo:Expected error in mat profile-form: "invalid syntax (profile 1 2 3)".
-misc.mo:Expected error in mat profile-form: "profile subform is not a source object 3".
 misc.mo:Expected error in mat strip-fasl-file: "invalid fasl strip option ratfink".
 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".
@@ -3834,7 +4102,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 2".
+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".
@@ -4183,8 +4451,8 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
 6.mo:Expected error in mat port-operations: "with-output-to-string: (this too?) is not a procedure".
 6.mo:Expected error in mat port-operations: "incorrect argument count in call (eof-object #!eof)".
 6.mo:Expected error in mat port-operations: "read: unexpected end-of-file reading quote at char 0 of #<input port string>".
-6.mo:Expected error in mat port-operations: "read: more than one item found after dot (.) on #<input port testfile.ss>".
+6.mo:Expected error in mat port-operations: "read: more than one item found after dot (.) before file-position 15 of #<input port testfile.ss>; the character position might differ".
-6.mo:Expected error in mat port-operations: "read: parenthesized list terminated by bracket on #<input port testfile.ss>".
+6.mo:Expected error in mat port-operations: "read: parenthesized list terminated by bracket before file-position 11 of #<input port testfile.ss>; the character position might differ".
 6.mo:Expected error in mat port-operations1: "incorrect argument count in call (open-input-output-file)".
 6.mo:Expected error in mat port-operations1: "open-input-output-file: furball is not a string".
 6.mo:Expected error in mat port-operations1: "open-input-output-file: failed for /probably/not/a/good/path: no such file or directory".
@@ -4249,7 +4517,7 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
 6.mo:Expected error in mat string-escapes: "read: invalid character " in string hex escape at char 3 of #<input port string>".
 6.mo:Expected error in mat string-escapes: "read: invalid character * in string hex escape at char 3 of #<input port string>".
 6.mo:Expected error in mat string-escapes: "read: invalid character g in string hex escape at char 3 of #<input port string>".
-6.mo:Expected error in mat read-token: "read-token: invalid number syntax #eat on #<input port testfile.ss>".
+6.mo:Expected error in mat read-token: "read-token: invalid number syntax #eat at line 2, char 1 of testfile.ss".
 6.mo:Expected error in mat read-test: "read: unsupported old fasl format detected---use new format with binary i/o at line 4, char 1 of testfile.ss".
 6.mo:Expected error in mat load-test: "read: unsupported old fasl format detected---use new format with binary i/o at line 4, char 1 of testfile.ss".
 6.mo:Expected error in mat compile-test: "read: unsupported old fasl format detected---use new format with binary i/o at line 4, char 1 of testfile.ss".
@@ -7210,20 +7478,70 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
 7.mo:Expected error in mat eval-when: "invalid syntax revisit-x".
 7.mo:Expected error in mat compile-whole-program: "compile-whole-program: failed for nosuchfile.wpo: no such file or directory".
 7.mo:Expected error in mat compile-whole-program: "incorrect argument count in call (compile-whole-program "testfile-wpo-ab.wpo")".
-7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in visit: library (testfile-wpo-lib) is not visible
+7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in environment: attempt to import invisible library (testfile-wpo-lib)
 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-c5)
+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: cyclic dependency involving invocation of library (testfile-wpo-a9)
+7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke invisible library (testfile-wpo-c10)
+7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to import invisible library (testfile-wpo-c10)
+7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in verify-loadability: attempting to invoke invisible library (testfile-wpo-c10)
+7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in verify-loadability: attempting to invoke invisible library (testfile-wpo-c10)
+7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c12)
+7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c12)
+7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c12)
 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 run-time part of library (testfile-cwl-a5)
+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: attempting to re-install run-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)
-7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: attempting to re-install run-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)
-7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: attempting to re-install run-time part of library (testfile-cwl-a5)
+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: attempting to re-install run-time part of library (testfile-cwl-a5)
+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: library (testfile-cwl-a6) not found
 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 concatenate-object-files: "separate-eval: Exception: library (testfile-catlibA) not found
+7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception: library (testfile-catlibA) not found
+7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1A)
+7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1B)
 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".
@@ -8517,7 +8835,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)".
@@ -8552,15 +8870,36 @@ 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 invoke-library: "invoke-library: invalid library reference (testfile-il1 (<= 3))".
+8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference (testfile-il1 (what?))".
+8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference ()".
+8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference hello".
+8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference (3 2 1)".
+8.mo:Expected error in mat invoke-library: "separate-eval: Exception in invoke-library: library (testfile-il1) version mismatch: want (3) but found (2) at testfile-il1.so
+8.mo:Expected error in mat invoke-library: "separate-eval: Exception in invoke-library: library (testfile-il1) version mismatch: want ((>= 3)) but found (2) at testfile-il1.so
 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)".
 8.mo:Expected error in mat eval-when-library: "loading testfile-ewl5.ss did not define library (testfile-ewl5)".
 8.mo:Expected error in mat eval-when-library: "loading testfile-ewl6.ss did not define library (testfile-ewl6)".
-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-ewl1.so did not define library (testfile-ewl1)".
-8.mo:Expected error in mat eval-when-library: "loading testfile-ewl2.ss did not define library (testfile-ewl2)".
+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.ss did not define library (testfile-ewl6)".
+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"))".
@@ -8569,7 +8908,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".
@@ -8736,9 +9075,9 @@ fx.mo:Expected error in mat fx=?: "fx=?: (a) is not a fixnum".
 fx.mo:Expected error in mat fx=?: "fx=?: <int> is not a fixnum".
 fx.mo:Expected error in mat fx=?: "fx=?: <-int> is not a fixnum".
 fx.mo:Expected error in mat fx=?: "incorrect argument count in call (fx=? 1)".
-fx.mo:Expected error in mat fx<?: "fx<: a is not a fixnum".
+fx.mo:Expected error in mat fx<?: "fx<?: a is not a fixnum".
-fx.mo:Expected error in mat fx<?: "fx<: <int> is not a fixnum".
+fx.mo:Expected error in mat fx<?: "fx<?: <int> is not a fixnum".
-fx.mo:Expected error in mat fx<?: "fx<: <-int> is not a fixnum".
+fx.mo:Expected error in mat fx<?: "fx<?: <-int> is not a fixnum".
 fx.mo:Expected error in mat fx<?: "incorrect argument count in call (fx<? 1)".
 fx.mo:Expected error in mat fx>?: "fx>?: "hi" is not a fixnum".
 fx.mo:Expected error in mat fx>?: "fx>?: <int> is not a fixnum".

mats/root-experr-compile-3-f-f-f

@@ -1,9 +1,9 @@
 3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x".
 3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x at line 1, char 19 of testfile.ss".
-misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
+profile.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
-misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
+profile.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
-misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
+profile.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
-misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
+profile.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
 misc.mo:Expected warning in mat (argcnt load-warning): "compile: possible incorrect argument count in call (car) at line 3, char 38 of testfile.ss".
 misc.mo:Expected warning in mat (argcnt load-warning): "compile: possible incorrect argument count in call (car (quote (a b)) (quote (c d))) at line 3, char 38 of testfile.ss".
 misc.mo:Expected warning in mat (argcnt load-warning): "compile: possible incorrect argument count in call (g 7) at line 3, char 47 of testfile.ss".

mats/unix.ms

@@ -160,15 +160,18 @@
       (error? (register-signal-handler list 14))
       (error? (register-signal-handler 14 14))
       (error? (register-signal-handler list list))
-      (let ((x #f))
+      (let ((x '()))
-        (register-signal-handler 14 (lambda (sig) (set! x sig)))
+        (register-signal-handler 14 (lambda (sig) (set! x (cons sig x))))
         ; guard the call to system, since openbsd gets an EINTR error,
         ; probably in system's call to waitpid, causing s_system to
         ; raise an exception
         (guard (c [#t (display-condition c) (printf "\nexception ignored\n")])
+          (system "exec kill -14 $PPID")
+          (system "exec kill -14 $PPID")
+          (system "exec kill -14 $PPID")
           (system "exec kill -14 $PPID"))
         (let f ((n 1000000))
-          (or (eqv? x 14)
+          (or (equal? x '(14 14 14 14))
               (and (not (= n 0))
                    (f (- n 1))))))
     )

release_notes/release_notes.stex

@@ -2,8 +2,8 @@
 
 \thisversion{Version 9.5.3}
 \thatversion{Version 8.4}
-\pubmonth{March}
+\pubmonth{February}
-\pubyear{2019}
+\pubyear{2020}
 
 \begin{document}
 
@@ -112,6 +112,148 @@ unordered by default. An ordered guardian's objects are classified as
 inaccessible only when they are not reachable from the represetative
 of any inaccessible object in any other guardian.
 
+\subsection{Bytevector compression and compression level (9.5.3)}
+
+The procedure \scheme{bytevector-compress} now selects the level of
+compression based on the \scheme{compress-level} parameter.
+Prior to this it always used a default setting for compression.
+
+The \scheme{compress-level} parameter can now take on the new value
+\scheme{minimum} in addition to \scheme{low}, \scheme{medium},
+\scheme{high}, and \scheme{maximum}.
+
+\subsection{Combining object files (9.5.3)}
+
+In previous versions of Chez Scheme, multiple object files could
+be combined by concatinating them into a single file.  To support faster
+object file loading and loadability verification (described later in this
+document), recompile information and information about libraries and
+top-level programs within an object file is now placed at the top of the
+file.  The new \scheme{concatenate-object-files} procedure can be used to
+combine multiple object files while moving this information to the
+top of the combined file.
+
+\subsection{Explicitly invoking libraries (9.5.3)}
+
+The new procedure \scheme{invoke-library} can be used to force
+the evaluation of a library's body expressions (variable definition
+right-hand sides and initialization expresisons) before they might
+otherwise be needed.
+It is generally useful only for libraries whose body expressions
+have side effects.
+
+\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}
+rather than the default \scheme{#f}, file compilation routines such as
+\scheme{compile-file} and \scheme{compile-library} produce coverage
+information (\scheme{.covin}) files that can be used in conjunction with
+profile information to measure coverage of a source-code base.
+Coverage information is also written out when the optional \var{covop}
+argument is supplied to \scheme{compile-port} and \scheme{compile-to-port}.
+
+A covin file contains a printed representation of a \emph{source
+table} mapping each profiled source object in the code base to a
+count of zero.
+Source tables generally associate source objects with arbitrary values
+and are allocated and manipulated with hashtable-like operations specific
+to source tables.
+
+Profile information can be tracked even through releasing and clearing
+of profile counters via the new procedure \scheme{with-profile-tracker},
+which produces a source table.
+
+Coverage of a source-code base can thus be achieved by comparing
+the set of source objects in the covin-file source tables for one
+or more source files with the set of source objects in the source
+tables produced by one or more runs of tests run with profile
+information tracked by \scheme{with-profile-tracker}.
+
+\subsection{Importing a library from an object file now visits the file (9.5.3)}
+
+As described in Section~\ref{sec:faster-object-file-loading},
+importing a library from an object file now causes the object file
+to be visited rather than fully loaded.
+If the run-time information is needed, i.e., if the library is
+invoked, the file will be revisited.
+This is typically transparent to the program, but problems can arise
+if the program changes its current directory (via
+\scheme{current-directory}) prior to invoking a library, and the
+object file cannot be found.
+
+\subsection{Recompile information (9.5.3)}
+
+As described in Section~\ref{sec:faster-object-file-loading}, all
+recompile information is now placed at the front of each object
+file where it can be read without the need to scan through the
+remainder of the file.
+Because the library manager expects to find recompile information
+at the front of an object file, it will not find all recompile
+information if object files are concatenated together via some
+mechanism other than then new \scheme{concatenate-object-files}
+procedure.
+
+Also, the compiler has to hold in memory the object code for all
+expressions in a file so that it can emit the unified recompile
+information, rather than writing to the object file incrementally,
+which can significantly increase the memory required to compile a
+large file full of individual top-level forms.
+This does not affect top-level programs, which were already handled
+as a whole, or a typical library file that contains just a single
+library form.
+
+\subsection{Optional new \protect\scheme{fasl-read} situation argument (9.5.3)}
+
+It is now possible to direct \scheme{fasl-read} to read only visit
+(compile-time) or revisit (run-time) objects via the optional new
+situation argument.
+Situation \scheme{visit} causes the fasl reader to skip over
+revisit (run-time-only) objects, while
+\scheme{revisit} causes the fasl reader to skip over
+visit (compile-time-only) objects.
+Situation \scheme{load} doesn't skip over any objects.
+
+\subsection{Optional \protect\scheme{read-token} \protect\var{sfd} and \protect\var{bfp} arguments (9.5.3)}
+
+In addition to the optional input-port argument, \scheme{read-token} now takes
+optional \var{sfd} (source-file-descriptor) and \var{bfp} (beginning-file-position)
+arguments.
+If either is provided, both must be provided.
+Specifying \var{sfd} and \var{bfp} improves the quality of error messages,
+guarantees the \scheme{read-token} \var{start} and \var{end} return values can be determined,
+and eliminates the overhead of asking for a file position on each call
+to \scheme{read-token}.
+\var{bfp} is normally 0 for the first call
+to \scheme{read-token} at the start of a file,
+and the \var{end} return value of the preceding
+call for each subsequent call.
+
 \subsection{Compression format and level (9.5.3)}
 
 Support for LZ4 compression has been added.
@@ -1749,7 +1891,37 @@ in fasl files does not generally make sense.
 %-----------------------------------------------------------------------------
 \section{Bug Fixes}\label{section:bugfixes}
 
-\subsection{\protect\code{putenv} memory leak (9.5.3)}
+\subsection{Buffering signals (9.5.3)}
+
+Prior to this release, only one unhandled signal was buffered for
+any signal for which a handler has been registered via
+\scheme{register-signal-handler}, so two signals delivered in
+quick succession could be see as only one.
+The system now buffers a much larger number (63 in this release) of
+signals, and the fact that signals can be dropped has now been
+documented.
+
+\subsection{Clear-output bug (9.5.3)}
+
+A bug has been fixed in which a call to \scheme{clear-output-port}
+on a port could lead to unexpected behavior involving the port,
+including loss of buffering or suppression of future output to the
+port.
+
+\subsection{Various argument type-error issues (9.5.3)}
+
+A variety of primitive argument type-checking issues have been
+fixed, including missing checks, misleading error messages,
+and checks made later than appropriate, i.e., after the primitive
+has already had side effects.
+
+\subsection{\protect\scheme{__collect_safe}, x86\_64, and floating-point arguments or results (9.5.3)}
+
+The \scheme{__collect_safe} mode for a foreign call or callable now
+correctly preserves floating-point registers used for arguments or
+results while activating or deactivating a thread on x86\_64.
+
+\subsection{\protect\scheme{putenv} memory leak (9.5.3)}
 
 \scheme{putenv} now calls the host system's \scheme{setenv} instead of
 \scheme{putenv} on non-Windows hosts and avoids allocating memory that
@@ -2152,6 +2324,62 @@ x86\_64 has been fixed.
 %-----------------------------------------------------------------------------
 \section{Performance Enhancements}\label{section:performance}
 
+\subsection{Special-cased basic arithmetic operations (9.5.3)}
+
+The basic arithmetic operations (addition, subtraction, multiplication,
+division) are now much faster when presented with certain special
+cases, e.g., multiplication of a large integer by 1 or -1 or addition
+of large integer and 0.
+
+\subsection{Faster right-shift of large integers (9.5.3)}
+
+Right shifting a large integer is now much faster in most cases
+where the shift count is a significant fraction of the number of
+bits in the large integer.
+
+\subsection{Faster object-file loading (9.5.3)}\label{sec:faster-object-file-loading}
+
+Visiting an object file (to obtain only compile-time information and
+code) and revisiting an object file (to obtain only run-time information
+and code) is now faster, because revisions to the fasl format, fasl
+writer, and fasl reader allow run-time code to be seeked past when
+visiting and compile-time code to be seeked past when revisiting.
+For compressed object files (the default), seeking still requires
+reading all of the data, but the cost of parsing the fasl format and
+building objects in the skipped portions is avoided, as are certain
+side effects, such as associating record type descriptors with their
+uids.
+
+Similarly, recompile information is now placed at the front of each
+object file where it can be loaded separately from
+the remainder of an object file without even seeking past the other
+portions of the file.
+Recompile information is used by \scheme{import} (when
+\scheme{compile-imported-libraries} is \scheme{#t}) and by maybe-compile
+routines such as \scheme{maybe-compile-program} to help determine
+whether recompilation is necessary.
+
+Importing a library from an object file now causes the object file
+to be visited rather than fully loaded.  (Libraries were already
+just revisited when required for their run-time code, e.g., when
+used from a top-level program.)
+
+Together these changes can significantly reduce compile-time and
+run-time overhead, particularly in applications that make use of
+a large number of libraries.
+
+\subsection{Faster \protect\scheme{profile-release-counters} (9.5.3)}
+
+\scheme{profile-release-counters} is now generation-friendly, meaning
+it does not incur any overhead for code objects in generations that
+have not been collected since the last call to\scheme{profile-release-counters}. 
+Also, it no longer allocates memory when counters are released.
+
+\subsection{Reduced cost for obtaining profile counts (9.5.3)}
+
+The cost of obtaining profile counts via \scheme{profile-dump} and
+other mechanisms has been reduced significantly.
+
 \subsection{Better code for \protect\scheme{bytevector} (9.5.1)}
 
 The compiler now generates better inline code for the \scheme{bytevector}

s/4.ss

@@ -14,7 +14,7 @@
 ;;; See the License for the specific language governing permissions and
 ;;; limitations under the License.
 
-(define apply
+(define-who apply
   (let ()
     (define-syntax build-apply
       (lambda (x)
@@ -24,7 +24,7 @@
                [(p r)
                 (unless (procedure? p)
                   ($oops #f "attempt to apply non-procedure ~s" p))
-                (let ([n ($list-length r 'apply)])
+                (let ([n ($list-length r who)])
                   (case n
                     [(0) (p)]
                     [(1) (p (car r))]
@@ -35,8 +35,8 @@
                [(p x . r)
                 (unless (procedure? p)
                    ($oops #f "attempt to apply non-procedure ~s" p))
-                (let ([r (cons x ($apply list* ($list-length r 'apply) r))])
+                (let ([r (cons x ($apply list* ($list-length r who) r))])
-                   ($apply p ($list-length r 'apply) r))])]
+                   ($apply p ($list-length r who) r))])]
           [(_ (s1 s2 ...) cl ...)
            (with-syntax ((m (length #'(s1 s2 ...))))
              #'(build-apply
@@ -44,7 +44,7 @@
                  [(p s1 s2 ... r)
                   (unless (procedure? p)
                     ($oops #f "attempt to apply non-procedure ~s" p))
-                  (let ([n ($list-length r 'apply)])
+                  (let ([n ($list-length r who)])
                     (case n
                       [(0) (p s1 s2 ...)]
                       [(1) (p s1 s2 ... (car r))]
@@ -153,22 +153,22 @@
     (set-who! andmap (do-andmap who))
     (set-who! for-all (do-andmap who)))
 
-  (set! map
+  (set-who! map
     (case-lambda
       [(f ls)
-       (unless (procedure? f) (nonprocedure-error 'map f))
+       (unless (procedure? f) (nonprocedure-error who f))
-       ($list-length ls 'map)
+       ($list-length ls who)
       ; library map cdrs first to avoid getting sick if f mutates input
        (#3%map f ls)]
       [(f ls1 ls2)
-       (unless (procedure? f) (nonprocedure-error 'map f))
+       (unless (procedure? f) (nonprocedure-error who f))
-       (unless (fx= ($list-length ls1 'map) ($list-length ls2 'map))
+       (unless (fx= ($list-length ls1 who) ($list-length ls2 who))
-         (length-error 'map ls1 ls2))
+         (length-error who ls1 ls2))
       ; library map cdrs first to avoid getting sick if f mutates input
        (#3%map f ls1 ls2)]
       [(f ls . more)
-       (unless (procedure? f) (nonprocedure-error 'map f))
+       (unless (procedure? f) (nonprocedure-error who f))
-       (length-check 'map ls more)
+       (length-check who ls more)
        (let map ([f f] [ls ls] [more more])
          (if (null? ls)
              '()
@@ -200,22 +200,22 @@
              (let ([tail (map f (cdr ls) (#3%map cdr more))])
                (cons (apply f (car ls) (#3%map car more)) tail))))]))
 
-  (set! for-each
+  (set-who! for-each
     (case-lambda
       [(f ls)
-       (unless (procedure? f) (nonprocedure-error 'for-each f))
+       (unless (procedure? f) (nonprocedure-error who f))
        (unless (null? ls)
-         (let for-each ([n ($list-length ls 'for-each)] [ls ls])
+         (let for-each ([n ($list-length ls who)] [ls ls])
            (if (fx= n 1)
                (f (car ls))
                (begin
                  (f (car ls))
                  (let ([ls (cdr ls)])
-                   (unless (pair? ls) (mutation-error 'for-each))
+                   (unless (pair? ls) (mutation-error who))
                    (for-each (fx- n 1) ls))))))]
       [(f ls . more)
-       (unless (procedure? f) (nonprocedure-error 'for-each f))
+       (unless (procedure? f) (nonprocedure-error who f))
-       (let ([n (length-check 'for-each ls more)])
+       (let ([n (length-check who ls more)])
          (unless (fx= n 0)
            (let for-each ([n n] [ls ls] [more more] [cars (map car more)])
              (if (fx= n 1)
@@ -223,28 +223,28 @@
                  (begin
                    (apply f (car ls) cars)
                    (let ([ls (cdr ls)])
-                     (unless (pair? ls) (mutation-error 'for-each))
+                     (unless (pair? ls) (mutation-error who))
-                     (let-values ([(cdrs cars) (getcxrs more 'for-each)])
+                     (let-values ([(cdrs cars) (getcxrs more who)])
                        (for-each (fx- n 1) ls cdrs cars))))))))]))
 
-  (set! fold-left 
+  (set-who! fold-left 
     (case-lambda
       [(combine nil ls)
-       (unless (procedure? combine) (nonprocedure-error 'fold-left combine))
+       (unless (procedure? combine) (nonprocedure-error who combine))
        (cond
          [(null? ls) nil]
          [else
-          ($list-length ls 'fold-left)
+          ($list-length ls who)
           (let fold-left ([ls ls] [acc nil])
             (let ([cdrls (cdr ls)])
               (if (pair? cdrls)
                   (fold-left cdrls (combine acc (car ls)))
                   (if (null? cdrls)
                       (combine acc (car ls))
-                      (mutation-error 'fold-left)))))])]
+                      (mutation-error who)))))])]
       [(combine nil ls . more)
-       (unless (procedure? combine) (nonprocedure-error 'fold-left combine))
+       (unless (procedure? combine) (nonprocedure-error who combine))
-       (length-check 'fold-left ls more)
+       (length-check who ls more)
        (if (null? ls)
            nil
            (let fold-left ([ls ls] [more more] [cars (map car more)] [acc nil])
@@ -252,26 +252,26 @@
                (if (null? cdrls)
                    (apply combine acc (car ls) cars)
                    (let ([acc (apply combine acc (car ls) cars)])
-                     (unless (pair? cdrls) (mutation-error 'fold-left))
+                     (unless (pair? cdrls) (mutation-error who))
-                     (let-values ([(cdrs cars) (getcxrs more 'fold-left)])
+                     (let-values ([(cdrs cars) (getcxrs more who)])
                        (fold-left cdrls cdrs cars acc)))))))]))
 
-  (set! fold-right 
+  (set-who! fold-right 
     (case-lambda
       [(combine nil ls)
-       (unless (procedure? combine) (nonprocedure-error 'fold-right combine))
+       (unless (procedure? combine) (nonprocedure-error who combine))
-       ($list-length ls 'fold-right)
+       ($list-length ls who)
       ; #3%fold-right naturally does cdrs first to avoid mutation sickness
        (#3%fold-right combine nil ls)]
       [(combine nil ls1 ls2)
-       (unless (procedure? combine) (nonprocedure-error 'fold-right combine))
+       (unless (procedure? combine) (nonprocedure-error who combine))
-       (unless (fx= ($list-length ls1 'map) ($list-length ls2 'map))
+       (unless (fx= ($list-length ls1 who) ($list-length ls2 who))
-         (length-error 'fold-right ls1 ls2))
+         (length-error who ls1 ls2))
       ; #3%fold-right naturally does cdrs first to avoid mutation sickness
        (#3%fold-right combine nil ls1 ls2)]
       [(combine nil ls . more)
-       (unless (procedure? combine) (nonprocedure-error 'fold-right combine))
+       (unless (procedure? combine) (nonprocedure-error who combine))
-       (length-check 'fold-right ls more)
+       (length-check who ls more)
        (let fold-right ([combine combine] [nil nil] [ls ls] [more more])
          (if (null? ls)
              nil
@@ -407,10 +407,10 @@
 
 ;;; make-promise and force
 
-(define $make-promise
+(define-who $make-promise
   (lambda (thunk)
     (unless (procedure? thunk)
-      ($oops '$make-promise "~s is not a procedure" thunk))
+      ($oops who "~s is not a procedure" thunk))
     (let ([value (void)] [set? #f])
       (lambda ()
         (case set?
@@ -435,8 +435,8 @@
                         (set! set? 'multiple)
                         (apply values x)])]))])))))
 
-(define force
+(define-who force
    (lambda (promise)
       (unless (procedure? promise)
-         ($oops 'force "~s is not a procedure" promise))
+         ($oops who "~s is not a procedure" promise))
       (promise)))

s/5_2.ss

@@ -266,20 +266,26 @@
          (if (null? xr) x1 (append x1 (f (car xr) (cdr xr)))))])))
 
 (define-who append!
-  (rec append!
+  (let ()
-    (case-lambda
+    (define (do-append! x1 x2)
-      [() '()]
-      [(x1 x2)
-       ($list-length x1 who)
       (if (null? x1)
           x2
           (let f ([ls x1])
             (if (null? (cdr ls))
                 (begin (set-cdr! ls x2) x1)
-                 (f (cdr ls)))))]
+                (f (cdr ls))))))
+    (case-lambda
+      [() '()]
+      [(x1 x2)
+       ($list-length x1 who)
+       (do-append! x1 x2)]
       [(x1 . xr)
        (let f ([x1 x1] [xr xr])
-         (if (null? xr) x1 (append! x1 (f (car xr) (cdr xr)))))])))
+         (if (null? xr)
+             x1
+             (begin
+               ($list-length x1 who) ; make sure all checks occur before first set-cdr!
+               (do-append! x1 (f (car xr) (cdr xr))))))])))
 
 (define-who reverse
   (lambda (ls)

s/5_3.ss

@@ -77,6 +77,7 @@
 (define big<
   (foreign-procedure "(cs)s_big_lt" (scheme-object scheme-object)
     boolean))
+(define big-negate (schemeop1 "(cs)s_big_negate"))
 (define integer-ash (schemeop2 "(cs)s_ash"))
 (define integer+ (schemeop2 "(cs)add"))
 (define integer* (schemeop2 "(cs)mul"))
@@ -900,6 +901,19 @@
          [else (nonexact-integer-error who x)])]
       [else (nonexact-integer-error who n)])))
 
+(define $negate
+  (lambda (who x)
+    (type-case x
+      [(fixnum?)
+       (if (fx= x (most-negative-fixnum))
+           (let-syntax ([a (lambda (x) (- (constant most-negative-fixnum)))]) a)
+           (fx- x))]
+      [(bignum?) (big-negate x)]
+      [(flonum?) (fl- x)]
+      [(ratnum?) (integer/ (- ($ratio-numerator x)) ($ratio-denominator x))]
+      [($exactnum? $inexactnum?) (make-rectangular (- (real-part x)) (- (imag-part x)))]
+      [else (nonnumber-error who x)])))
+
 (set! integer?
   (lambda (x)
     (type-case x
@@ -1606,30 +1620,34 @@
        [(ratnum?) (quotient ($ratio-numerator x) ($ratio-denominator x))]
        [else (nonreal-error who x)])))
 
-(set! quotient
+(set-who! quotient
   (let ([f (lambda (x y) (truncate (/ x y)))])
     (lambda (x y)
       (type-case y
         [(fixnum?)
-             (when (fx= y 0) (domain-error 'quotient y))
+         (when (fx= y 0) (domain-error who y))
+         (cond
+           [(fx= y 1) (unless (integer? x) (noninteger-error who x)) x]
+           [(fx= y -1) (unless (integer? x) (noninteger-error who x)) ($negate who x)]
+           [else
              (type-case x
                [(fixnum?) (if (and (fx= y -1) (fx= x (most-negative-fixnum)))
                               (- (most-negative-fixnum))
                               (fxquotient x y))]
                [(bignum?) (intquotient x y)]
                [else
-                 (unless (integer? x) (noninteger-error 'quotient x))
+                 (unless (integer? x) (noninteger-error who x))
-                 (f x y)])]
+                 (f x y)])])]
         [(bignum?)
          (type-case x
            [(fixnum? bignum?) (intquotient x y)]
            [else
-                 (unless (integer? x) (noninteger-error 'quotient x))
+             (unless (integer? x) (noninteger-error who x))
              (f x y)])]
         [else
-             (unless (integer? y) (noninteger-error 'quotient y))
+          (unless (integer? y) (noninteger-error who y))
-             (unless (integer? x) (noninteger-error 'quotient x))
+          (unless (integer? x) (noninteger-error who x))
-             (when (= y 0) (domain-error 'quotient y))
+          (when (= y 0) (domain-error who y))
           (f x y)]))))
 
 (set-who! div-and-mod
@@ -1642,6 +1660,10 @@
           ($fxdiv-and-mod x y #f)]
          [(flonum?) ($fldiv-and-mod x (fixnum->flonum y))]
          [(bignum?)
+          (cond
+            [(fx= y 1) (values x 0)]
+            [(fx= y -1) (values (big-negate x) 0)]
+            [else
               (when (fx= y 0) (domain-error who y))
               (let ([q.r (intquotient-remainder x y)])
                 (if ($bigpositive? x)
@@ -1650,7 +1672,7 @@
                         (values (car q.r) 0)
                         (if (fx< y 0)
                             (values (+ (car q.r) 1) (fx- (cdr q.r) y))
-                        (values (- (car q.r) 1) (fx+ (cdr q.r) y))))))]
+                            (values (- (car q.r) 1) (fx+ (cdr q.r) y))))))])]
          [(ratnum?)
           (when (fx= y 0) (domain-error who y))
           ($exdiv-and-mod x y)]
@@ -1697,6 +1719,10 @@
          [(flonum?) ($fldiv x (fixnum->flonum y))]
          [(bignum?)
           (when (fx= y 0) (domain-error who y))
+          (cond
+            [(fx= y 1) x]
+            [(fx= y -1) (big-negate x)]
+            [else
              (if ($bigpositive? x)
                  (intquotient x y)
                  (let ([q.r (intquotient-remainder x y)])
@@ -1704,7 +1730,7 @@
                        (car q.r)
                        (if (fx< y 0)
                            (+ (car q.r) 1)
-                        (- (car q.r) 1)))))]
+                           (- (car q.r) 1)))))])]
          [(ratnum?)
           (when (fx= y 0) (domain-error who y))
           ($exdiv x y)]
@@ -1749,6 +1775,9 @@
          [(flonum?) ($flmod x (fixnum->flonum y))]
          [(bignum?)
           (when (fx= y 0) (domain-error who y))
+          (cond
+            [(or (fx= y 1) (fx= y -1)) 0]
+            [else
              (if ($bigpositive? x)
                  (intremainder x y)
                  (let ([q.r (intquotient-remainder x y)])
@@ -1756,7 +1785,7 @@
                        0
                        (if (fx< y 0)
                            (fx- (cdr q.r) y)
-                        (fx+ (cdr q.r) y)))))]
+                           (fx+ (cdr q.r) y)))))])]
          [(ratnum?)
           (when (fx= y 0) (domain-error who y))
           ($exmod x y)]
@@ -1799,7 +1828,14 @@
           (when (fx= y 0) (domain-error who y))
           ($fxdiv0-and-mod0 x y #f)]
          [(flonum?) ($fldiv0-and-mod0 x (fixnum->flonum y))]
-         [(bignum? ratnum?)
+         [(bignum?)
+          (cond
+            [(fx= y 1) (values x 0)]
+            [(fx= y -1) (values (big-negate x) 0)]
+            [else
+             (when (fx= y 0) (domain-error who y))
+             ($exdiv0-and-mod0 x y)])]
+         [(ratnum?)
           (when (fx= y 0) (domain-error who y))
           ($exdiv0-and-mod0 x y)]
          [else (domain-error who x)])]
@@ -1835,7 +1871,14 @@
           (when (fx= y 0) (domain-error who y))
           ($fxdiv0 x y #f)]
          [(flonum?) ($fldiv0 x (fixnum->flonum y))]
-         [(bignum? ratnum?)
+         [(bignum?)
+          (cond
+            [(fx= y 1) x]
+            [(fx= y -1) (big-negate x)]
+            [else
+             (when (fx= y 0) (domain-error who y))
+             (exdiv0 x y)])]
+         [(ratnum?)
           (when (fx= y 0) (domain-error who y))
           (exdiv0 x y)]
          [else (domain-error who x)])]
@@ -1871,7 +1914,13 @@
           (when (fx= y 0) (domain-error who y))
           ($fxmod0 x y)]
          [(flonum?) ($flmod0 x (fixnum->flonum y))]
-         [(bignum? ratnum?)
+         [(bignum?)
+          (cond
+            [(or (fx= y 1) (fx= y -1)) 0]
+            [else
+             (when (fx= y 0) (domain-error who y))
+             (exmod0 x y)])]
+         [(ratnum?)
           (when (fx= y 0) (domain-error who y))
           (exmod0 x y)]
          [else (domain-error who x)])]
@@ -1893,7 +1942,7 @@
          [else (domain-error who x)])]
       [else (domain-error who y)])))
 
-(set! remainder
+(set-who! remainder
   (let ([f (lambda (x y)
              (let ([r (- x (* (quotient x y) y))])
                ;;; filter out outrageous results
@@ -1904,23 +1953,26 @@
     (lambda (x y)
       (type-case y
         [(fixnum?)
-             (when (fx= y 0) (domain-error 'remainder y))
+         (when (fx= y 0) (domain-error who y))
+         (cond
+           [(or (fx= y 1) (fx= y -1)) (unless (integer? x) (noninteger-error who x)) 0]
+           [else
              (type-case x
                [(fixnum?) (fxremainder x y)]
                [(bignum?) (intremainder x y)]
                [else
-                 (unless (integer? x) (noninteger-error 'remainder x))
+                 (unless (integer? x) (noninteger-error who x))
-                 (f x y)])]
+                 (f x y)])])]
         [(bignum?)
          (type-case x
            [(fixnum? bignum?) (intremainder x y)]
            [else
-                 (unless (integer? x) (noninteger-error 'remainder x))
+             (unless (integer? x) (noninteger-error who x))
              (f x y)])]
         [else
-             (unless (integer? y) (noninteger-error 'remainder y))
+          (unless (integer? y) (noninteger-error who y))
-             (unless (integer? x) (noninteger-error 'remainder x))
+          (unless (integer? x) (noninteger-error who x))
-             (when (= y 0) (domain-error 'remainder y))
+          (when (= y 0) (domain-error who y))
           (f x y)]))))
 
 (set-who! even?
@@ -2082,26 +2134,34 @@
 
 (set! $+
   (lambda (who x y)
-      (type-case x
+    (define (exint-unknown+ who x y)
-         [(fixnum? bignum?)
       (type-case y
         [(fixnum? bignum?) (integer+ x y)]
         [(ratnum?)
          (let ([d ($ratio-denominator y)])
-                 (/ (+ (* x d) ($ratio-numerator y)) d))]
+           (integer/ (+ (* x d) ($ratio-numerator y)) d))]
         [(flonum?) (exact-inexact+ x y)]
         [($exactnum? $inexactnum?)
          (make-rectangular (+ x (real-part y)) (imag-part y))]
-             [else (nonnumber-error who y)])]
+        [else (nonnumber-error who y)]))
+    (cond
+      [(eqv? y 0) (unless (number? x) (nonnumber-error who x)) x]
+      [else
+        (type-case x
+          [(fixnum?)
+           (cond
+             [(fx= x 0) (unless (number? y) (nonnumber-error who y)) y]
+             [else (exint-unknown+ who x y)])]
+          [(bignum?) (exint-unknown+ who x y)]
           [(ratnum?)
            (type-case y
              [(fixnum? bignum?)
               (let ([d ($ratio-denominator x)])
-                 (/ (+ (* y d) ($ratio-numerator x)) d))]
+                (integer/ (+ (* y d) ($ratio-numerator x)) d))]
              [(ratnum?)
               (let ([xd ($ratio-denominator x)] [yd ($ratio-denominator y)])
-                 (/ (+ (* ($ratio-numerator x) yd)
+                (integer/
-                       (* ($ratio-numerator y) xd))
+                  (+ (* ($ratio-numerator x) yd) (* ($ratio-numerator y) xd))
                   (* xd yd)))]
              [($exactnum? $inexactnum?)
               (make-rectangular (+ x (real-part y)) (imag-part y))]
@@ -2122,16 +2182,29 @@
               (make-rectangular (+ (real-part x) (real-part y))
                 (+ (imag-part x) (imag-part y)))]
              [else (nonnumber-error who y)])]
-         [else (nonnumber-error who x)])))
+          [else (nonnumber-error who x)])])))
 
 (set! $*
    (lambda (who x y)
+    (cond
+      [(and (fixnum? y) ($fxu< (#3%fx+ y 1) 3))
+       (cond
+         [(fx= y 0) (unless (number? x) (nonnumber-error who x)) 0]
+         [(fx= y 1) (unless (number? x) (nonnumber-error who x)) x]
+         [else ($negate who x)])]
+      [else
        (type-case x
          [(fixnum? bignum?)
           (type-case y
              [(fixnum?) (integer* x y)]
             [(bignum?) (if (fixnum? x)
-                            (integer* x y)
+                           (cond
+                            [($fxu< (#3%fx+ x 1) 3)
+                             (cond
+                              [(fx= x 0) (unless (number? y) (nonnumber-error who y)) 0]
+                              [(fx= x 1) (unless (number? y) (nonnumber-error who y)) y]
+                              [else ($negate who y)])]
+                            [else (integer* x y)])
                             (let ()
                               ;; _Modern Computer Arithmetic_, Brent and Zimmermann
                               (define (karatsuba x y)
@@ -2171,9 +2244,10 @@
          [(ratnum?)
           (type-case y
              [(fixnum? bignum?)
-              (/ (* y ($ratio-numerator x)) ($ratio-denominator x))]
+              (integer/ (* y ($ratio-numerator x)) ($ratio-denominator x))]
              [(ratnum?)
-              (/ (* ($ratio-numerator x) ($ratio-numerator y))
+              (integer/
+                (* ($ratio-numerator x) ($ratio-numerator y))
                 (* ($ratio-denominator x) ($ratio-denominator y)))]
              [($exactnum? $inexactnum?)
               (make-rectangular (* x (real-part y)) (* x (imag-part y)))]
@@ -2195,30 +2269,38 @@
                     [c (real-part y)] [d (imag-part y)])
                 (make-rectangular (- (* a c) (* b d)) (+ (* a d) (* b c))))]
              [else (nonnumber-error who y)])]
-         [else (nonnumber-error who x)])))
+          [else (nonnumber-error who x)])])))
 
 (set! $-
   (lambda (who x y)
-      (type-case x
+    (define (exint-unknown- who x y)
-         [(fixnum? bignum?)
       (type-case y
         [(fixnum? bignum?) (integer- x y)]
         [(ratnum?)
          (let ([d ($ratio-denominator y)])
-                 (/ (- (* x d) ($ratio-numerator y)) d))]
+           (integer/ (- (* x d) ($ratio-numerator y)) d))]
         [($exactnum? $inexactnum?)
          (make-rectangular (- x (real-part y)) (- (imag-part y)))]
         [(flonum?) (exact-inexact- x y)]
-             [else (nonnumber-error who y)])]
+        [else (nonnumber-error who y)]))
+    (cond
+      [(eqv? y 0) (unless (number? x) (nonnumber-error who x)) x]
+      [else
+        (type-case x
+          [(fixnum?)
+           (cond
+             [(eqv? x 0) ($negate who y)]
+             [else (exint-unknown- who x y)])]
+          [(bignum?) (exint-unknown- who x y)]
           [(ratnum?)
            (type-case y
              [(fixnum? bignum?)
               (let ([d ($ratio-denominator x)])
-                 (/ (- ($ratio-numerator x) (* y d)) d))]
+                (integer/ (- ($ratio-numerator x) (* y d)) d))]
              [(ratnum?)
               (let ([xd ($ratio-denominator x)] [yd ($ratio-denominator y)])
-                 (/ (- (* ($ratio-numerator x) yd)
+                (integer/
-                       (* ($ratio-numerator y) xd))
+                  (- (* ($ratio-numerator x) yd) (* ($ratio-numerator y) xd))
                   (* xd yd)))]
              [($exactnum? $inexactnum?)
               (make-rectangular (- x (real-part y)) (- (imag-part y)))]
@@ -2239,24 +2321,26 @@
               (make-rectangular (- (real-part x) (real-part y))
                 (- (imag-part x) (imag-part y)))]
              [else (nonnumber-error who y)])]
-         [else (nonnumber-error who x)])))
+          [else (nonnumber-error who x)])])))
 
 (set! $/
    (lambda (who x y)
       (type-case y
          [(fixnum?)
+          (cond
+           [(fx= y 1) (unless (number? x) (nonnumber-error who x)) x]
+           [(fx= y -1) (unless (number? x) (nonnumber-error who x)) ($negate who x)]
+           [else
             (type-case x
              [(fixnum?)
               ;; Trying `fxquotient` followed by a `fx*` check
               ;; is so much faster (in the case that it works)
               ;; that it's worth a try
               (when (eq? y 0) (domain-error who y))
-              (if (fx= x (constant most-negative-fixnum))
-                  (integer/ x y) ; in case `y` is -1
               (let ([q (fxquotient x y)])
                 (if (fx= x (fx* y q))
                     q
-                        (integer/ x y))))]
+                    (integer/ x y)))]
              [(bignum?)
               (when (eq? y 0) (domain-error who y))
               (integer/ x y)]
@@ -2269,7 +2353,7 @@
              [($inexactnum?)
               (make-rectangular (/ (real-part x) y) (/ (imag-part x) y))]
              [(flonum?) (inexact-exact/ x y)]
-             [else (nonnumber-error who x)])]
+             [else (nonnumber-error who x)])])]
          [(bignum?)
           (type-case x
              [(fixnum? bignum?)
@@ -2635,15 +2719,15 @@
       [(and (bignum? n) (#%$bigpositive? n)) (big-integer-sqrt n)]
       [else ($oops who "~s is not a nonnegative exact integer" n)])))
 
-(set! $quotient-remainder
+(set-who! $quotient-remainder
   (lambda (x y)
     (type-case y
-         [(bignum? fixnum?)
+      [(fixnum? bignum?)
-          (when (eq? y 0) (domain-error '$quotient-remainder y))
+       (when (eq? y 0) (domain-error who y))
        (type-case x
          [(fixnum? bignum?) (intquotient-remainder x y)]
-             [else (nonexact-integer-error '$quotient-remainder x)])]
+         [else (nonexact-integer-error who x)])]
-         [else (nonexact-integer-error '$quotient-remainder y)])))
+      [else (nonexact-integer-error who y)])))
 
 (let ()
   (define-record pseudo-random-generator

s/7.ss

@@ -96,8 +96,8 @@
 (define-who with-source-path
   (lambda (whoarg fn p)
     (unless (or (eq? whoarg #f) (string? whoarg) (symbol? whoarg)) ($oops who "invalid who argument ~s" whoarg))
+    (unless (string? fn) ($oops who "~s is not a string" fn))
     (unless (procedure? p) ($oops who "~s is not a procedure" p))
-    (unless (string? fn) ($oops whoarg "~s is not a string" fn))
     (let ([dirs (source-directories)])
       (if (or (equal? dirs '("")) (equal? dirs '(".")) ($fixed-path? fn))
           (p fn)
@@ -118,9 +118,9 @@
                       (p path)
                       (loop (cdr ls))))))))))
 
-(set! fasl-read
+(set-who! fasl-read
   (let ()
-    (define $fasl-read (foreign-procedure "(cs)fasl_read" (ptr boolean ptr) ptr))
+    (define $fasl-read (foreign-procedure "(cs)fasl_read" (ptr boolean fixnum ptr) ptr))
     (define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr int uptr uptr ptr) ptr))
     (define (get-uptr p)
       (let ([k (get-u8 p)])
@@ -129,7 +129,7 @@
               (let ([k (get-u8 p)])
                 (f k (logor (ash n 7) (fxand k #x7F))))
               n))))
-    (define (malformed p) ($oops 'fasl-read "malformed fasl-object header found in ~s" p))
+    (define (malformed p) ($oops who "malformed fasl-object header found in ~s" p))
     (define (check-header p)
       (let ([bv (make-bytevector 8 (constant fasl-type-header))])
         (unless (and (eqv? (get-bytevector-n! p bv 1 7) 7)
@@ -137,14 +137,14 @@
           (malformed p)))
       (let ([n (get-uptr p)])
         (unless (= n (constant scheme-version))
-          ($oops 'fasl-read "incompatible fasl-object version ~a found in ~s"
+          ($oops who "incompatible fasl-object version ~a found in ~s"
             ($format-scheme-version n) p)))
       (let ([n (get-uptr p)])
         (unless (or (= n (constant machine-type-any)) (= n (constant machine-type)))
           (cond
             [(assv n (constant machine-type-alist)) =>
              (lambda (a)
-               ($oops 'fasl-read "incompatible fasl-object machine-type ~s found in ~s"
+               ($oops who "incompatible fasl-object machine-type ~s found in ~s"
                  (cdr a) p))]
             [else (malformed p)])))
       (unless (and (eqv? (get-u8 p) (char->integer #\()) ;)
@@ -153,13 +153,13 @@
                        (and (not (eof-object? n)) ;(
                             (or (eqv? n (char->integer #\))) (f))))))
         (malformed p)))
-    (lambda (p)
+    (define (go p situation)
-      (unless (and (input-port? p) (binary-port? p))
+      (define (go1)
-        ($oops 'fasl-read "~s is not a binary input port" p))
         (if (and ($port-flags-set? p (constant port-flag-file))
                  (eqv? (binary-port-input-count p) 0))
             ($fasl-read ($port-info p)
               ($port-flags-set? p (constant port-flag-compressed))
+              situation
               (port-name p))
             (let fasl-entry ()
               (let ([ty (get-u8 p)])
@@ -168,10 +168,26 @@
                   [(eqv? ty (constant fasl-type-header))
                    (check-header p)
                    (fasl-entry)]
+                  [(eqv? ty (constant fasl-type-visit))
+                   (go2 (eqv? situation (constant fasl-type-revisit)))]
+                  [(eqv? ty (constant fasl-type-revisit))
+                   (go2 (eqv? situation (constant fasl-type-visit)))]
+                  [(eqv? ty (constant fasl-type-visit-revisit))
+                   (go2 #f)]
+                  [else (malformed p)])))))
+      (define (go2 skip?)
+        (let ([ty (get-u8 p)])
+          (cond
             [(or (eqv? ty (constant fasl-type-fasl-size))
                  (eqv? ty (constant fasl-type-vfasl-size)))
-                 (let ([len (get-uptr p)]
+             (let ([len (get-uptr p)])
-                       [name (port-name p)])
+               (if skip?
+                   (begin
+                     (if (and (port-has-port-position? p) (port-has-set-port-position!? p))
+                         (set-port-position! p (+ (port-position p) len))
+                         (get-bytevector-n p len))
+                     (go1))
+                   (let ([name (port-name p)])
                      ;; fasl-read directly from the port buffer if it has `len`
                      ;; bytes ready, which works for a bytevector port; disable
                      ;; interrupt to make sure the bytes stay available (and
@@ -187,8 +203,20 @@
                           [else
                            ;; Call `get-bytevector-n`, etc. with interrupts reenabled
                            (lambda ()
-                           ($bv-fasl-read (get-bytevector-n p len) ty 0 len name))])))))]
+                             ($bv-fasl-read (get-bytevector-n p len) ty 0 len name))])))))))]
-                [else (malformed p)])))))))
+            [else (malformed p)])))
+      (unless (and (input-port? p) (binary-port? p))
+        ($oops who "~s is not a binary input port" p))
+      (go1))
+    (case-lambda
+      [(p) (go p (constant fasl-type-visit-revisit))]
+      [(p situation)
+       (go p
+         (case situation
+           [(visit) (constant fasl-type-visit)]
+           [(revisit) (constant fasl-type-revisit)]
+           [(load) (constant fasl-type-visit-revisit)]
+           [else ($oops who "invalid situation ~s" situation)]))])))
 
 (define ($compiled-file-header? ip)
   (let ([pos (port-position ip)])
@@ -202,40 +230,21 @@
 
 (let ()
   (define do-load-binary
-    (lambda (who fn ip situation for-import? results?)
+    (lambda (who fn ip situation for-import? importer)
-      (let ([load-binary (make-load-binary who fn situation for-import?)])
+      (let ([load-binary (make-load-binary who fn situation for-import? importer)])
-        (let loop ([lookahead-x #f])
+        (let ([x (fasl-read ip situation)])
-          (let* ([x (or lookahead-x (fasl-read ip))]
+          (unless (eof-object? x)
-                 [next-x (and results? (not (eof-object? x)) (fasl-read ip))])
+            (let loop ([x x])
-            (cond
+              (let ([next-x (fasl-read ip situation)])
-             [(eof-object? x) (close-port ip)]
+                (if (eof-object? next-x)
-             [(and results? (eof-object? next-x)) (load-binary x)]
+                    (load-binary x)
-             [else (load-binary x) (loop next-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? visit-stuff? visit-stuff-inner revisit-stuff? revisit-stuff-inner
+    (module (Lexpand? recompile-info? library/ct-info? library/rt-info? program-info?)
-              recompile-info? library/ct-info? library/rt-info? program-info?)
       (import (nanopass))
       (include "base-lang.ss")
       (include "expand-lang.ss"))
-    (define unexpected-value!
-      (lambda (x)
-        ($oops who "unexpected value ~s read from ~a" x fn)))
-    (define run-inner
-      (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)]
-         [(program-info? x) ($install-program-desc x)]
-         [else (unexpected-value! x)])))
-    (define run-outer
-      (lambda (x)
-        (cond
-         [(recompile-info? x) (void)]
-         [(revisit-stuff? x) (when (memq situation '(load revisit)) (run-inner (revisit-stuff-inner x)))]
-         [(visit-stuff? x) (when (memq situation '(load visit)) (run-inner (visit-stuff-inner x)))]
-         [else (run-inner x)])))
     (define run-vector
       (lambda (v)
         (let ([n (vector-length v)])
@@ -245,13 +254,23 @@
                 (if (fx= i n)
                     (run-outer x) ; return value(s) of last form for load-compiled-from-port
                     (begin (run-outer x) (loop i)))))))))
+    (define run-outer
       (lambda (x)
         (cond
+         [(procedure? x) (x)]
+         [(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? importer fn)]
+                                        ; NB: this is here to support the #t inserted by compile-file-help2 after header information
+         [(eq? x #t) (void)]
+         ;; for vfasl combinations:
          [(vector? x) (run-vector x)]
-       [(Lexpand? x) ($interpret-backend x situation for-import? fn)]
+         [else ($oops who "unexpected value ~s read from ~a" x fn)])))
-       [else (run-outer x)])))
+    (lambda (x) (run-outer x)))
 
-  (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)])
@@ -269,11 +288,16 @@
                         (begin (set-port-position! ip start-pos) 0)))])
           (port-file-compressed! ip)
           (if ($compiled-file-header? ip)
-              (do-load-binary who fn ip situation for-import? #f)
+              (begin
+                (do-load-binary who fn ip situation for-import? importer)
+                (close-port ip))
               (begin
                 (when ($port-flags-set? ip (constant port-flag-compressed))
+                  (close-port ip)
                   ($oops who "missing header for compiled file ~s" fn))
-                (unless ksrc ($oops who "~a is not a compiled file" fn))
+                (unless ksrc
+                  (close-port ip)
+                  ($oops who "~a is not a compiled file" fn))
                 (unless (eqv? fp 0) (set-port-position! ip 0))
                 (let ([sfd ($source-file-descriptor fn ip (eqv? fp 0))])
                   (unless (eqv? fp 0) (set-port-position! ip fp))
@@ -282,24 +306,37 @@
                   (ksrc ip sfd ($make-read ip sfd fp)))))))))
 
   (set! $make-load-binary
-    (lambda (fn situation for-import?)
+    (lambda (fn)
-      (make-load-binary '$make-load-binary fn situation for-import?)))
+      (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 #t)))
+      (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 #f)))
+
+  (set-who! revisit-compiled-from-port
+    (lambda (ip)
+      (unless (and (input-port? ip) (binary-port? ip))
+        ($oops who "~s is not a binary input port" ip))
+      (do-load-binary who (port-name ip) ip 'revisit #f #f)))
 
   (set-who! load-program
     (rec load-program
       (case-lambda
         [(fn) (load-program fn eval)]
         [(fn ev)
+         (unless (string? fn) ($oops who "~s is not a string" fn))
          (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* '()])
@@ -316,10 +353,11 @@
       (case-lambda
         [(fn) (load-library fn eval)]
         [(fn ev)
+         (unless (string? fn) ($oops who "~s is not a string" fn))
          (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 ()
@@ -333,11 +371,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))])
@@ -353,10 +391,11 @@
       (case-lambda
         [(fn) (load fn eval)]
         [(fn ev)
+         (unless (string? fn) ($oops who "~s is not a string" fn))
          (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)])
@@ -366,20 +405,20 @@
                  (close-port ip)))))])))
 
   (set! $visit
-    (lambda (who fn)
+    (lambda (who fn importer)
-      (do-load who fn 'visit #t #f)))
+      (do-load who fn 'visit #t importer #f)))
 
   (set! $revisit
-    (lambda (who fn)
+    (lambda (who fn importer)
-      (do-load who fn 'revisit #t #f)))
+      (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

s/Mf-base

@@ -50,6 +50,9 @@ xp = f
 bp = f
 xbp = f
 
+# c determines whether covin files are generated: f for false, t for true.
+c = f
+
 # loadspd determines whether source-profile data is loaded: f for false, t for true
 loadspd = f
 
@@ -232,12 +235,14 @@ clean: profileclean
              '(generate-inspector-information #$i)'\
              '(generate-allocation-counts #${gac})'\
              '(generate-instruction-counts #${gic})'\
+             '(generate-covin-files #$c)'\
              '(run-cp0 (lambda (cp0 x)'\
              '           (do ([i ${cp0} (fx- i 1)] [x x (cp0 x)])'\
              '               ((fx= i 0) x))))'\
              '(collect-trip-bytes (expt 2 24))'\
              '(collect-request-handler (lambda () (collect 0 1)))'\
              '(collect 1 2)'\
+             '(delete-file "$*.covin")'\
              '(time (${compile} "$*.ss" "$*.$m" (quote $m)))'\
              '(when #${pdhtml} (profile-dump-html))'\
              '(when #${dumpspd} (profile-dump-data "${ProfileDumpSource}"))'\
@@ -259,6 +264,7 @@ clean: profileclean
              '(generate-inspector-information #$i)'\
              '(generate-allocation-counts #${gac})'\
              '(generate-instruction-counts #${gic})'\
+             '(generate-covin-files #$c)'\
              '(run-cp0 (lambda (cp0 x)'\
              '           (do ([i ${cp0} (fx- i 1)] [x x (cp0 x)])'\
              '               ((fx= i 0) x))))'\
@@ -266,6 +272,7 @@ clean: profileclean
              '(collect-request-handler (lambda () (collect 0 1)))'\
              '(collect 1 2)'\
              '(print-gensym (quote pretty/suffix))'\
+             '(delete-file "$*.covin")'\
              '(compile-with-asm "$*.ss" "$*.$m" (quote $m))'\
              '(when #${pdhtml} (profile-dump-html))'\
              '(when #${dumpspd} (profile-dump-data "${ProfileDumpSource}"))'\
@@ -347,12 +354,16 @@ resetbootlinks:
 
 ${PetiteBoot}: ${macroobj} ${patchfile} ${baseobj}
 	echo '(reset-handler abort)'\
+             '(generate-covin-files #$c)'\
+             '(delete-file (string-append (path-root "${PetiteBoot}") ".covin"))'\
              '(apply #%$$make-boot-file "${PetiteBoot}" (quote $m) (quote ())'\
              '  (map symbol->string (quote (${baseobj}))))'\
              | ${Scheme} -q ${macroobj} ${patchfile}
 
 ${SchemeBoot}: ${macroobj} ${patchfile} ${compilerobj}
 	echo '(reset-handler abort)'\
+             '(generate-covin-files #$c)'\
+             '(delete-file (string-append (path-root "${SchemeBoot}") ".covin"))'\
              '(apply #%$$make-boot-file "${SchemeBoot}" (quote $m) (quote ("petite"))'\
              '  (map symbol->string (quote (${compilerobj}))))'\
              | ${Scheme} -q ${macroobj} ${patchfile}
@@ -447,11 +458,13 @@ script.all makescript:
              '(generate-allocation-counts #${gac})'\
              '(generate-instruction-counts #${gic})'\
              '(#%$$enable-pass-timing #${pps})'\
+             '(generate-covin-files #$c)'\
              '(run-cp0 (lambda (cp0 x)'\
              '           (do ([i ${cp0} (fx- i 1)] [x x (cp0 x)])'\
              '               ((fx= i 0) x))))'\
              '(collect-trip-bytes (expt 2 24))'\
              '(collect-request-handler (lambda () (collect 0 1)))'\
+             '(for-each (lambda (x) (delete-file (string-append (path-root (symbol->string x)) ".covin"))) (quote (${obj})))'\
              '(time (for-each (lambda (x y)'\
              '                   (collect 1 2)'\
              '                   (${compile} (symbol->string x)'\
@@ -460,8 +473,10 @@ script.all makescript:
              '                (quote (${src}))'\
              '                (quote (${obj}))))'\
              '(when #${pps} (#%$$print-pass-stats))'\
+             '(delete-file (string-append (path-root "${PetiteBoot}") ".covin"))'\
              '(apply #%$$make-boot-file "${PetiteBoot}" (quote $m) (quote ())'\
              '  (map symbol->string (quote (${baseobj}))))'\
+             '(delete-file (string-append (path-root "${SchemeBoot}") ".covin"))'\
              '(apply #%$$make-boot-file "${SchemeBoot}" (quote $m) (quote ("petite"))'\
              '  (map symbol->string (quote (${compilerobj}))))'\
              '(when #${pdhtml} (profile-dump-html))'\
@@ -483,12 +498,16 @@ script-static.all:
              '(generate-inspector-information #$i)'\
              '(generate-allocation-counts #${gac})'\
              '(generate-instruction-counts #${gic})'\
+             '(generate-covin-files #$c)'\
              '(run-cp0 (lambda (cp0 x)'\
              '           (do ([i ${cp0} (fx- i 1)] [x x (cp0 x)])'\
              '               ((fx= i 0) x))))'\
+             '(for-each (lambda (x) (delete-file (string-append (path-root (symbol->string x)) ".covin"))) (quote (${obj})))'\
              '(compile-with-setup-closure-counts (quote (${closure-opt})) (quote (${src})) (quote (${obj})) (quote $m) #$r)'\
+             '(delete-file (string-append (path-root "${PetiteBoot}") ".covin"))'\
              '(apply #%$$make-boot-file "${PetiteBoot}" (quote $m) (quote ())'\
              '  (map symbol->string (quote (${baseobj}))))'\
+             '(delete-file (string-append (path-root "${SchemeBoot}") ".covin"))'\
              '(apply #%$$make-boot-file "${SchemeBoot}" (quote $m) (quote ("petite"))'\
              '  (map symbol->string (quote (${compilerobj}))))'\
              '(when #${pdhtml} (profile-dump-html))'\
@@ -508,12 +527,16 @@ script-dynamic.all:
              '(generate-inspector-information #$i)'\
              '(generate-allocation-counts #${gac})'\
              '(generate-instruction-counts #${gic})'\
+             '(generate-covin-files #$c)'\
              '(run-cp0 (lambda (cp0 x)'\
              '           (do ([i ${cp0} (fx- i 1)] [x x (cp0 x)])'\
              '               ((fx= i 0) x))))'\
+             '(for-each (lambda (x) (delete-file (string-append (path-root (symbol->string x)) ".covin"))) (quote (${obj})))'\
              '(compile-with-closure-counts (quote (${closure-opt})) (quote (${src})) (quote (${obj})) (quote $m) #$r)'\
+             '(delete-file (string-append (path-root "${PetiteBoot}") ".covin"))'\
              '(apply #%$$make-boot-file "${PetiteBoot}" (quote $m) (quote ())'\
              '  (map symbol->string (quote (${baseobj}))))'\
+             '(delete-file (string-append (path-root "${SchemeBoot}") ".covin"))'\
              '(apply #%$$make-boot-file "${SchemeBoot}" (quote $m) (quote ("petite"))'\
              '  (map symbol->string (quote (${compilerobj}))))'\
              '(when #${pdhtml} (profile-dump-html))'\
@@ -567,7 +590,7 @@ examples:
 	( cd ../examples && ${MAKE} all Scheme="${Scheme} ../s/${patchfile}" )
 
 prettyclean:
-	rm -f *.$m xpatch ${patch} *.patch *.so *.asm script.all header.tmp *.html
+	rm -f *.$m xpatch ${patch} *.patch *.so *.covin *.asm script.all header.tmp *.html
 	rm -rf nanopass
 
 profileclean: prettyclean

s/back.ss

@@ -126,6 +126,11 @@
     (lambda (x)
       (and x #t))))
 
+(define-who generate-covin-files
+  ($make-thread-parameter #f
+    (lambda (x)
+      (and x #t))))
+
 (define $enable-check-prelex-flags
   ($make-thread-parameter #f
     (lambda (x)
@@ -182,6 +187,7 @@
     [()
      (let ([x ($tc-field 'compress-level ($tc))])
        (cond
+         [(eqv? x (constant COMPRESS-MIN)) 'minimum]
          [(eqv? x (constant COMPRESS-LOW)) 'low]
          [(eqv? x (constant COMPRESS-MEDIUM)) 'medium]
          [(eqv? x (constant COMPRESS-HIGH)) 'high]
@@ -190,6 +196,7 @@
     [(x)
      ($tc-field 'compress-level ($tc)
        (case x
+         [(minimum) (constant COMPRESS-MIN)]
          [(low) (constant COMPRESS-LOW)]
          [(medium) (constant COMPRESS-MEDIUM)]
          [(high) (constant COMPRESS-HIGH)]

s/cmacros.ss

@@ -328,7 +328,7 @@
                  [(_ foo e1 e2) e1] ...
                  [(_ bar e1 e2) e2]))))])))
 
-(define-constant scheme-version #x09050314)
+(define-constant scheme-version #x09050315)
 
 (define-syntax define-machine-types
   (lambda (x)
@@ -445,21 +445,22 @@
 (define-constant fasl-type-weak-pair 30)
 (define-constant fasl-type-eq-hashtable 31)
 (define-constant fasl-type-symbol-hashtable 32)
-(define-constant fasl-type-group 33)
+; 33
 (define-constant fasl-type-visit 34)
 (define-constant fasl-type-revisit 35)
+(define-constant fasl-type-visit-revisit 36)
 
-(define-constant fasl-type-immutable-vector 36)
+(define-constant fasl-type-immutable-vector 37)
-(define-constant fasl-type-immutable-string 37)
+(define-constant fasl-type-immutable-string 38)
-(define-constant fasl-type-immutable-fxvector 38)
+(define-constant fasl-type-immutable-fxvector 39)
-(define-constant fasl-type-immutable-bytevector 39)
+(define-constant fasl-type-immutable-bytevector 40)
-(define-constant fasl-type-immutable-box 40)
+(define-constant fasl-type-immutable-box 41)
 
-(define-constant fasl-type-stencil-vector 41)
+(define-constant fasl-type-stencil-vector 42)
 
-(define-constant fasl-type-begin 42)
+(define-constant fasl-type-begin 43)
-(define-constant fasl-type-phantom 43)
+(define-constant fasl-type-phantom 44)
-(define-constant fasl-type-uninterned-symbol 44)
+(define-constant fasl-type-uninterned-symbol 45)
 
 (define-constant fasl-fld-ptr 0)
 (define-constant fasl-fld-u8 1)
@@ -541,10 +542,11 @@
 (define-constant COMPRESS-LZ4 1)
 (define-constant COMPRESS-FORMAT-BITS 3)
 
-(define-constant COMPRESS-LOW 0)
+(define-constant COMPRESS-MIN 0)
-(define-constant COMPRESS-MEDIUM 1)
+(define-constant COMPRESS-LOW 1)
-(define-constant COMPRESS-HIGH 2)
+(define-constant COMPRESS-MEDIUM 2)
-(define-constant COMPRESS-MAX 3)
+(define-constant COMPRESS-HIGH 3)
+(define-constant COMPRESS-MAX 4)
 
 (define-constant SICONV-DUNNO 0)
 (define-constant SICONV-INVALID 1)
@@ -601,10 +603,6 @@
 (define-constant ERROR_VALUES 7)
 (define-constant ERROR_MVLET 8)
 
-;;; object-file tags
-(define-constant visit-tag 0)
-(define-constant revisit-tag 1)
-
 ;;; allocation spaces
 (define-constant space-locked #x20)         ; lock flag
 (define-constant space-old #x40)            ; oldspace flag
@@ -767,12 +765,13 @@
 (define-constant type-phantom          #b01111110)
 (define-constant type-record                #b111)
 
-(define-constant code-flag-system           #b000001)
+(define-constant code-flag-system           #b0000001)
-(define-constant code-flag-continuation     #b000010)
+(define-constant code-flag-continuation     #b0000010)
-(define-constant code-flag-template         #b000100)
+(define-constant code-flag-template         #b0000100)
-(define-constant code-flag-mutable-closure  #b001000)
+(define-constant code-flag-guardian         #b0001000)
-(define-constant code-flag-arity-in-closure #b010000)
+(define-constant code-flag-mutable-closure  #b0010000)
-(define-constant code-flag-single-valued    #b100000)
+(define-constant code-flag-arity-in-closure #b0100000)
+(define-constant code-flag-single-valued    #b1000000)
 
 (define-constant fixnum-bits
   (case (constant ptr-bits)
@@ -859,6 +858,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))))
 (define-constant type-code-mutable-closure
   (fxlogor (constant type-code)
            (fxsll (constant code-flag-mutable-closure)
@@ -947,6 +950,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-code-mutable-closure
   (fxlogor (fxsll (constant code-flag-mutable-closure) (constant code-flags-offset))
            (fx- (fxsll 1 (constant code-flags-offset)) 1)))
@@ -1402,6 +1408,7 @@
    [ptr timer-ticks]
    [ptr disable-count]
    [ptr signal-interrupt-pending]
+   [ptr signal-interrupt-queue]
    [ptr keyboard-interrupt-pending]
    [ptr threadno]
    [ptr current-input]
@@ -1571,8 +1578,9 @@
     (with-syntax ([type (datum->syntax #'* (filter-scheme-type 'string-char))])
       #''type)))
 
-(define-constant annotation-debug 1)
+(define-constant annotation-debug   #b0001)
-(define-constant annotation-profile 2)
+(define-constant annotation-profile #b0010)
+(define-constant annotation-all     #b0011)
 
 (eval-when (compile load eval)
 (define flag->mask

s/cp0.ss

@@ -2866,7 +2866,8 @@
             (and (okay-to-handle?)
                  (visit-and-maybe-extract* bytevector? ([dx x])
                    (visit-and-maybe-extract* (lambda (y)
-                                               (and (exact? y)
+                                               (and (integer? y)
+                                                    (exact? y)
                                                     (nonnegative? y)
                                                     (= (modulo y align) 0)))
                      ([dy y])
@@ -4838,13 +4839,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) (app-name ctxt))
+                         (build-case-lambda (let ([preinfo (preinfo-call->preinfo-lambda (app-preinfo ctxt) (app-name 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)])

s/cpnanopass.ss

@@ -5524,8 +5524,17 @@
           (def-len string-length mask-string type-string string-type-disp string-length-offset)
           (def-len bytevector-length mask-bytevector type-bytevector bytevector-type-disp bytevector-length-offset)
           (def-len stencil-vector-mask mask-stencil-vector type-stencil-vector stencil-vector-type-disp stencil-vector-mask-offset))
-        ; TODO: consider adding integer?, integer-valued?, rational?, rational-valued?,
+        ; TODO: consider adding integer-valued?, rational?, rational-valued?,
         ; real?, and real-valued?
+        (define-inline 2 integer?
+          [(e) (bind #t (e)
+                 (build-simple-or
+                   (%type-check mask-fixnum type-fixnum ,e)
+                   (build-simple-or
+                     (%typed-object-check mask-bignum type-bignum ,e)
+                     (build-and
+                       (%type-check mask-flonum type-flonum ,e)
+                       `(call ,(make-info-call src sexpr #f #f #f) #f ,(lookup-primref 3 'flinteger?) ,e)))))])
         (let ()
           (define build-number?
             (lambda (e)
@@ -5900,6 +5909,18 @@
                  (set! ,(%mref ,t ,(constant guardian-entry-pending-disp)) ,(%constant snil))
                  (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 3 $make-phantom-bytevector
           [()
            (bind #f ()
@@ -5910,6 +5931,7 @@
                     (set! ,(%mref ,t ,(constant phantom-length-disp))
                           (immediate 0))
                     ,t)))])
+
         (define-inline 3 phantom-bytevector-length
           [(e-ph)
            (bind #f (e-ph)

s/cprep.ss

@@ -17,6 +17,7 @@
 
 (let ()
   (import (nanopass))
+  (include "types.ss")
   (include "base-lang.ss")
   (include "expand-lang.ss")
 
@@ -30,11 +31,12 @@
            (go ($build-install-library/ct-code uid export-id* import-code visit-code))]
           [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
            (go ($build-install-library/rt-code uid dl* db* dv* de* body))]
-          [,linfo/ct `(library/ct-info ,(library-info-uid linfo/ct) ,(library/ct-info-import-req* linfo/ct)
+          [(library/ct-info ,linfo/ct)
-                            ,(library/ct-info-include-req* linfo/ct) ,(library/ct-info-visit-visit-req* linfo/ct)
+           `(library/ct-info ,(library-info-uid linfo/ct) ,(library/ct-info-import-req* linfo/ct)
+              ,(library/ct-info-visit-visit-req* linfo/ct)
               ,(library/ct-info-visit-req* linfo/ct))]
-          [,linfo/rt `(library/rt-info ,(library-info-uid linfo/rt) ,(library/rt-info-invoke-req* linfo/rt))]
+          [(library/rt-info ,linfo/rt) `(library/rt-info ,(library-info-uid linfo/rt) ,(library/rt-info-invoke-req* linfo/rt))]
-          [,pinfo `(program-info ,(program-info-invoke-req* pinfo))])
+          [(program-info ,pinfo) `(program-info ,(program-info-invoke-req* pinfo))])
         (Inner ir))
       (let ([x* (let f ([x x] [x* '()])
                   (nanopass-case (Lexpand Outer) x
@@ -42,7 +44,7 @@
                     [(visit-only ,inner) (cons `(eval-when (visit) ,(go-Inner inner)) x*)]
                     [(revisit-only ,inner) (cons `(eval-when (revisit) ,(go-Inner inner)) x*)]
                     [,inner (cons (go-Inner inner) x*)]
-                    [,rcinfo (cons `(recompile-requirements ,(recompile-info-import-req* x) ,(recompile-info-include-req* x)) x*)]
+                    [(recompile-info ,rcinfo) (cons `(recompile-requirements ,(recompile-info-import-req* rcinfo) ,(recompile-info-include-req* rcinfo)) x*)]
                     [else (sorry! who "unexpected language form ~s" x)]))])
         (safe-assert (not (null? x*)))
         (cond
@@ -310,4 +312,13 @@
           [(clause (,x* ...) ,interface ,body)
            (for-each initialize-id! x*)
            `(clause (,x* ...) ,interface ,(Expr body))]))
-      (Lexpand-to-go x cpcheck-prelex-flags))))
+      (Lexpand-to-go x cpcheck-prelex-flags)))
+
+  (set-who! $insert-profile-src! ; called from compiler only
+    (lambda (st x)
+      ; NB: the output should be *, but nanopass won't autogenerate the pass
+      (define-pass record-coverage-info! : Lsrc (ir) -> Lsrc ()
+        (Expr : Expr (ir) -> Expr ()
+          [(profile ,src) (source-table-set! st src 0) `(profile ,src)]))
+      (Lexpand-to-go x record-coverage-info!)))
+  )

s/date.ss

@@ -211,87 +211,87 @@
       (fprintf p "#<date~@[ ~a~]>"
         ($asctime (dt-vec x)))))
 
-  (set! make-time
+  (set-who! make-time
     (lambda (type nsec sec)
-      (let ([typeno (ts-type->typeno 'make-time type)])
+      (let ([typeno (ts-type->typeno who type)])
-        (check-nsec 'make-time nsec)
+        (check-nsec who nsec)
-        (check-ts-sec 'make-time sec)
+        (check-ts-sec who sec)
         (make-ts typeno (cons sec nsec)))))
 
   (set! time? (lambda (x) (ts? x)))
 
-  (set! time-type
+  (set-who! time-type
     (lambda (ts)
-      (check-ts 'time-type ts)
+      (check-ts who ts)
       (ts-typeno->type (ts-typeno ts))))
 
-  (set! time-second
+  (set-who! time-second
     (lambda (ts)
-      (check-ts 'time-second ts)
+      (check-ts who ts)
       (ts-sec ts)))
 
-  (set! time-nanosecond
+  (set-who! time-nanosecond
     (lambda (ts)
-      (check-ts 'time-nanosecond ts)
+      (check-ts who ts)
       (ts-nsec ts)))
 
-  (set! set-time-type!
+  (set-who! set-time-type!
     (lambda (ts type)
-      (check-ts 'set-time-type! ts)
+      (check-ts who ts)
-      (ts-typeno-set! ts (ts-type->typeno 'set-time-type! type))))
+      (ts-typeno-set! ts (ts-type->typeno who type))))
 
-  (set! set-time-second!
+  (set-who! set-time-second!
     (lambda (ts sec)
-      (check-ts 'set-time-second! ts)
+      (check-ts who ts)
-      (check-ts-sec 'set-time-second! sec)
+      (check-ts-sec who sec)
       (set-ts-sec! ts sec)))
 
-  (set! set-time-nanosecond!
+  (set-who! set-time-nanosecond!
     (lambda (ts nsec)
-      (check-ts 'set-time-nanosecond! ts)
+      (check-ts who ts)
-      (check-nsec 'set-time-nanosecond! nsec)
+      (check-nsec who nsec)
       (set-ts-nsec! ts nsec)))
 
-  (set! time=?
+  (set-who! time=?
     (lambda (t1 t2)
-      (check-ts 'time=? t1)
+      (check-ts who t1)
-      (check-ts 'time=? t2)
+      (check-ts who t2)
-      (check-same-type 'time=? t1 t2)
+      (check-same-type who t1 t2)
       (and (= (ts-sec t1) (ts-sec t2))
            (= (ts-nsec t1) (ts-nsec t2)))))
 
-  (set! time<?
+  (set-who! time<?
     (lambda (t1 t2)
-      (check-ts 'time<? t1)
+      (check-ts who t1)
-      (check-ts 'time<? t2)
+      (check-ts who t2)
-      (check-same-type 'time<? t1 t2)
+      (check-same-type who t1 t2)
       (or (< (ts-sec t1) (ts-sec t2))
           (and (= (ts-sec t1) (ts-sec t2))
                (< (ts-nsec t1) (ts-nsec t2))))))
 
-  (set! time<=?
+  (set-who! time<=?
     (lambda (t1 t2)
-      (check-ts 'time<=? t1)
+      (check-ts who t1)
-      (check-ts 'time<=? t2)
+      (check-ts who t2)
-      (check-same-type 'time<=? t1 t2)
+      (check-same-type who t1 t2)
       (or (< (ts-sec t1) (ts-sec t2))
           (and (= (ts-sec t1) (ts-sec t2))
                (<= (ts-nsec t1) (ts-nsec t2))))))
 
-  (set! time>=?
+  (set-who! time>=?
     (lambda (t1 t2)
-      (check-ts 'time>=? t1)
+      (check-ts who t1)
-      (check-ts 'time>=? t2)
+      (check-ts who t2)
-      (check-same-type 'time>=? t1 t2)
+      (check-same-type who t1 t2)
       (or (> (ts-sec t1) (ts-sec t2))
           (and (= (ts-sec t1) (ts-sec t2))
                (>= (ts-nsec t1) (ts-nsec t2))))))
 
-  (set! time>?
+  (set-who! time>?
     (lambda (t1 t2)
-      (check-ts 'time>? t1)
+      (check-ts who t1)
-      (check-ts 'time>? t2)
+      (check-ts who t2)
-      (check-same-type 'time>? t1 t2)
+      (check-same-type who t1 t2)
       (or (> (ts-sec t1) (ts-sec t2))
           (and (= (ts-sec t1) (ts-sec t2))
                (> (ts-nsec t1) (ts-nsec t2))))))
@@ -348,45 +348,45 @@
          [else (let ([typeno (ts-type->typeno who type)])
                  (make-ts typeno ($clock-gettime typeno)))])]))
 
-  (set! current-date
+  (set-who! current-date
     (case-lambda
       [()
        (let ([dtvec ($gmtime #f #f)])
-         (unless dtvec ($oops 'current-date "failed"))
+         (unless dtvec ($oops who "failed"))
          (make-dt dtvec))]
       [(tz)
-       (check-tz 'current-date tz)
+       (check-tz who tz)
        (let ([dtvec ($gmtime tz #f)])
-         (unless dtvec ($oops 'current-date "failed"))
+         (unless dtvec ($oops who "failed"))
          (make-dt dtvec))]))
 
-  (set! date-and-time ; ptime|#f -> string
+  (set-who! date-and-time ; ptime|#f -> string
     (case-lambda
-      [() (or ($asctime #f) ($oops 'date-and-time "failed"))]
+      [() (or ($asctime #f) ($oops who "failed"))]
       [(dt)
-       (check-dt 'date-and-time dt)
+       (check-dt who dt)
        (or ($asctime (dt-vec dt))
-           ($oops 'date-and-time "failed for date record ~s" dt))]))
+           ($oops who "failed for date record ~s" dt))]))
 
-  (set! make-date
+  (set-who! make-date
     (let ([do-make-date
            (lambda (nsec sec min hour day mon year tz tz-provided?)
-             (check-nsec 'make-date nsec)
+             (check-nsec who nsec)
-             (check-sec 'make-date sec)
+             (check-sec who sec)
-             (check-min 'make-date min)
+             (check-min who min)
-             (check-hour 'make-date hour)
+             (check-hour who hour)
             ; need more accurate check for day based on year and month
-             (check-day 'make-date day)
+             (check-day who day)
-             (check-mon 'make-date mon)
+             (check-mon who mon)
-             (check-year 'make-date year)
+             (check-year who year)
              (when tz-provided?
-               (check-tz 'make-date tz))
+               (check-tz who tz))
             ; keep in sync with cmacros.ss declarations of dtvec-nsec, etc.
              (let ([dtvec (vector nsec sec min hour day mon (- year 1900) 0 #f 0 tz #f)])
                (unless ($mktime dtvec) ; for effect on dtvec
-                 ($oops 'make-date "invalid combination of arguments"))
+                 ($oops who "invalid combination of arguments"))
                (unless (fx= (vector-ref dtvec (constant dtvec-mday)) day)
-                 ($oops 'make-date "invalid day ~s for month ~s and year ~s" day mon year))
+                 ($oops who "invalid day ~s for month ~s and year ~s" day mon year))
                (make-dt dtvec)))])
       (case-lambda
         [(nsec sec min hour day mon year tz)
@@ -418,15 +418,15 @@
     (date-getter date-zone-offset (constant dtvec-tzoff))
     (date-getter date-zone-name (constant dtvec-tzname)))
 
-  (set! date-year
+  (set-who! date-year
     (lambda (dt)
-      (check-dt 'date-year dt)
+      (check-dt who dt)
       (+ (vector-ref (dt-vec dt) (constant dtvec-year)) 1900)))
 
-  #;(set! date-week-number
+  #;(set-who! date-week-number
     (lambda (dt dowsw)
       (unless (or (eq? dossw 0) (eq? dossw 1)) 
-        ($oops 'date-week-number "invalid week starting day" dossw))
+        ($oops who "invalid week starting day" dossw))
       ???))
 
   (set-who! time-utc->date
@@ -440,7 +440,7 @@
       [(t tz)
        (unless (and (ts? t) (eq? (ts-typeno t) (constant time-utc)))
          ($oops who "~s is not a utc time record" t))
-       (check-tz 'current-date tz)
+       (check-tz who tz)
        (let ([dtvec ($gmtime tz (ts-pair t))])
          (unless dtvec ($oops who "failed"))
          (make-dt dtvec))]))

s/expand-lang.ss

@@ -29,29 +29,27 @@
   (sealed #t))
 
 (define-record-type library-info
-  (nongenerative #{library-info e10vy7tci6bqz6pmnxgvlq-2})
+  (nongenerative #{library-info e10vy7tci6bqz6pmnxgvlq-3})
   (fields
     (immutable path)
     (immutable version)
-    (immutable uid)))
+    (immutable uid)
+    (immutable visible?)))
 
 (define-record-type library/ct-info
   (parent library-info)
   (fields
-    ; NB: include-req* should go away with new recompile support that uses recompile-info
-    (immutable include-req*)
     (immutable import-req*)
     (immutable visit-visit-req*)
-    (immutable visit-req*)
+    (immutable visit-req*))
-    (immutable clo*))
+  (nongenerative #{library/ct-info fgf0koeh2zn6ajlujfyoyf-4})
-  (nongenerative #{library/ct-info fgf0koeh2zn6ajlujfyoyf-3})
   (sealed #t))
 
 (define-record-type library/rt-info
   (parent library-info)
   (fields
     (immutable invoke-req*))
-  (nongenerative #{library/rt-info ff86rtm7efmvxcvrmh7t0b-2})
+  (nongenerative #{library/rt-info ff86rtm7efmvxcvrmh7t0b-3})
   (sealed #t))
 
 (define-record-type program-info
@@ -59,12 +57,6 @@
   (nongenerative #{program-info fgc8ptwnu9i5gfqz3s85mr-0})
   (sealed #t))
 
-(define (revisit-stuff? x) (and (pair? x) (eqv? (car x) (constant revisit-tag))))
-(define (revisit-stuff-inner x) (cdr x))
-
-(define (visit-stuff? x) (and (pair? x) (eqv? (car x) (constant visit-tag))))
-(define (visit-stuff-inner x) (cdr x))
-
 (module (Lexpand Lexpand?)
   (define library-path?
     (lambda (x)
@@ -80,7 +72,7 @@
   (define maybe-label? (lambda (x) (or (not x) (gensym? x))))
 
   (define-language Lexpand
-    (nongenerative-id #{Lexpand fgy7v2wrvj0so4ro8kvhqo-2})
+    (nongenerative-id #{Lexpand fgy7v2wrvj0so4ro8kvhqo-3})
     (terminals
       (maybe-label (dl))
       (gensym (uid export-id))
@@ -96,17 +88,17 @@
       (library/rt-info (linfo/rt))
       (program-info (pinfo)))
     (Outer (outer)
-      rcinfo
+      (recompile-info rcinfo)
       (group outer1 outer2)
       (visit-only inner)
       (revisit-only inner)
       inner)
     (Inner (inner)
-      linfo/ct
+      (library/ct-info linfo/ct)
       ctlib
-      linfo/rt
+      (library/rt-info linfo/rt)
       rtlib
-      pinfo
+      (program-info pinfo)
       prog
       lsrc)
     (ctLibrary (ctlib)

s/fasl.ss

@@ -179,9 +179,12 @@
         [(vector? x) (bld-graph x t a? d #t bld-vector)]
         [(stencil-vector? x) (bld-graph x t a? d #t bld-stencil-vector)]
         [(or (symbol? x) (string? x)) (bld-graph x t a? d #t bld-simple)]
+        ; this check must go before $record? check
         [(and (annotation? x) (not a?))
          (bld (annotation-stripped x) t a? d)]
+        ; this check must go before $record? check
         [(eq-hashtable? x) (bld-graph x t a? d #t bld-ht)]
+        ; this check must go before $record? check
         [(symbol-hashtable? x) (bld-graph x t a? d #t bld-ht)]
         [($record? x) (bld-graph x t a? d #t bld-record)]
         [(box? x) (bld-graph x t a? d #t bld-box)]
@@ -335,7 +338,7 @@
                (wrf-stencil-vector-loop (fx+ i 1)))))))
 
 ; Written as: fasl-tag rtd field ...
-(module (wrf-record really-wrf-record)
+(module (wrf-record really-wrf-record wrf-annotation)
   (define maybe-remake-rtd
     (lambda (rtd)
       (if (eq? (machine-type) ($target-machine))
@@ -472,7 +475,18 @@
          (wrf-fields (maybe-remake-rtd x) p t a?)]
         [else
          (put-u8 p (constant fasl-type-record))
-         (wrf-fields x p t a?)]))))
+         (wrf-fields x p t a?)])))
+
+  (define wrf-annotation
+    (lambda (x p t a?)
+      (define maybe-remake-annotation
+        (lambda (x a?)
+          (if (fx= (annotation-flags x) a?)
+              x
+              (make-annotation (annotation-expression x) (annotation-source x) (annotation-stripped x) a?))))
+      (put-u8 p (constant fasl-type-record))
+      (wrf-fields (maybe-remake-annotation x a?) p t a?)))
+)
 
 (define wrf-eqht
   (lambda (x p t a?)
@@ -594,11 +608,16 @@
          [(string? x) (wrf-graph x p t a? wrf-string)]
          [(fxvector? x) (wrf-graph x p t a? wrf-fxvector)]
          [(bytevector? x) (wrf-graph x p t a? wrf-bytevector)]
-         [(and (annotation? x) (not a?))
+         ; this check must go before $record? check
-          (wrf (annotation-stripped x) p t a?)]
+         [(annotation? x)
+          (if a?
+              (wrf-graph x p t a? wrf-annotation)
+              (wrf (annotation-stripped x) p t a?))]
          ; this check must go before $record? check
          [(eq-hashtable? x) (wrf-graph x p t a? wrf-eqht)]
+         ; this check must go before $record? check
          [(symbol-hashtable? x) (wrf-graph x p t a? wrf-symht)]
+         ; this check must go before $record? check
          [(hashtable? x) ($oops 'fasl-write "invalid fasl object ~s" x)]
          [($record? x) (wrf-graph x p t a? wrf-record)]
          [(vector? x) (wrf-graph x p t a? wrf-vector)]
@@ -621,7 +640,7 @@
 
 (module (start)
   (define start
-    (lambda (x p t proc)
+    (lambda (p t situation proc)
       (dump-graph)
       (let-values ([(bv* size)
                     (let-values ([(p extractor) ($open-bytevector-list-output-port)])
@@ -638,8 +657,9 @@
                                           (proc x p)
                                           (wrf x p t #t)))
                                     begins)))
-                      (proc x p)
+                      (proc p)
                       (extractor))])
+        (put-u8 p situation)
         (put-u8 p (constant fasl-type-fasl-size))
         (put-uptr p size)
         (for-each (lambda (bv) (put-bytevector p bv)) bv*))))
@@ -668,13 +688,13 @@
                  [else (loop (fx+ i 1) begins)]))])))))))
 
 (module (fasl-write fasl-file)
-  ; when called from fasl-write or fasl-file, pass #t for a? to preserve annotations;
+  ; when called from fasl-write or fasl-file, always preserve annotations;
   ; otherwise use value passed in by the compiler
   (define fasl-one
     (lambda (x p)
       (let ([t (make-table)])
-         (bld x t #t 0)
+         (bld x t (constant annotation-all) 0)
-         (start x p t (lambda (x p) (wrf x p t #t))))))
+         (start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf x p t (constant annotation-all)))))))
 
   (define-who fasl-write
     (lambda (x p)
@@ -710,7 +730,7 @@
     (emit-header p (constant machine-type-any))
     (let ([t (make-table)])
       (bld-graph x t #f 0 #t really-bld-record)
-      (start x p t (lambda (x p) (wrf-graph x p t #f really-wrf-record))))))
+      (start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf-graph x p t #f really-wrf-record))))))
 
 ($fasl-target (make-target bld-graph bld wrf start make-table wrf-graph fasl-base-rtd fasl-write fasl-file))
 )
@@ -724,7 +744,7 @@
   (set! $fasl-bld-graph (lambda (x t a? d inner? handler) ((target-fasl-bld-graph (fasl-target)) x t a? d inner? handler)))
   (set! $fasl-enter (lambda (x t a? d) ((target-fasl-enter (fasl-target)) x t a? d)))
   (set! $fasl-out (lambda (x p t a?) ((target-fasl-out (fasl-target)) x p t a?)))
-  (set! $fasl-start (lambda (x p t proc) ((target-fasl-start (fasl-target)) x p t proc)))
+  (set! $fasl-start (lambda (p t situation proc) ((target-fasl-start (fasl-target)) p t situation proc)))
   (set! $fasl-table (lambda () ((target-fasl-table (fasl-target)))))
   (set! $fasl-wrf-graph (lambda (x p t a? handler) ((target-fasl-wrf-graph (fasl-target)) x p t a? handler)))
   (set! $fasl-base-rtd (lambda (x p) ((target-fasl-base-rtd (fasl-target)) x p)))

s/interpret.ss

@@ -666,7 +666,7 @@
       ($cptypes x))
       x)
 
-(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])
@@ -694,16 +694,16 @@
      (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))]
-    [,linfo/rt ($install-library/rt-desc linfo/rt for-import? ofn)]
+    [(library/rt-info ,linfo/rt) ($install-library/rt-desc linfo/rt for-import? importer ofn)]
-    [,linfo/ct ($install-library/ct-desc linfo/ct for-import? ofn)]
+    [(library/ct-info ,linfo/ct) ($install-library/ct-desc linfo/ct for-import? importer ofn)]
-    [,pinfo ($install-program-desc pinfo)]
+    [(program-info ,pinfo) ($install-program-desc pinfo)]
     [else (sorry! who "unexpected language form ~s" ir)])
   (Outer : Outer (ir) -> * (val)
     ; can't use cata since (Outer outer1) might return 0 or more than one value
     [(group ,outer1 ,outer2) (Outer outer1) (Outer outer2)]
     [(visit-only ,inner) (unless (eq? situation 'revisit) (Inner inner))]
     [(revisit-only ,inner) (unless (eq? situation 'visit) (Inner inner))]
-    [,rcinfo (void)]
+    [(recompile-info ,rcinfo) (void)]
     [,inner (Inner inner)]
     [else (sorry! who "unexpected language form ~s" ir)])
   (Outer ir))
@@ -725,11 +725,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)
+  (lambda (x situation for-import? importer ofn)
-    (interpret-Lexpand x situation for-import? ofn (expand/optimize-output))))
+    (interpret-Lexpand x situation for-import? importer ofn (expand/optimize-output))))
 )
 
 (current-eval interpret)

s/io.ss

@@ -641,7 +641,7 @@ implementation notes:
 
   (define binary-file-port-clear-output
     (lambda (who p)
-      (set-binary-port-output-size! p 0)))
+      (set-binary-port-output-index! p 0)))
 
   (define binary-file-port-close-port
     (lambda (who p)
@@ -4061,7 +4061,7 @@ implementation notes:
   (set-who! output-port-buffer-mode
     (lambda (output-port)
       (unless (output-port? output-port)
-        ($oops who "~s is not an output-port" output-port))
+        ($oops who "~s is not an output port" output-port))
       (cond
         [($port-flags-set? output-port (constant port-flag-block-buffered))
          (buffer-mode block)]
@@ -4329,9 +4329,7 @@ implementation notes:
              [new-buffer (make-bytevector new-length)])
           (bytevector-copy! old-buffer 0 new-buffer 0
                             (fxmin (bytevector-length old-buffer) old-size))
-          (set-binary-port-output-buffer! p new-buffer)
+          (set-binary-port-output-buffer! p new-buffer))))
-          ;; set size to one less than real size so 'put' always has room
-          (set-binary-port-output-size! p (fx1- new-length)))))
 
     (define port-length
       (lambda (who p)
@@ -4444,7 +4442,6 @@ implementation notes:
                  (binary-port-output-buffer p)
                  (port-length #f p))])
           (set-binary-port-output-buffer! p #vu8())
-          (set-binary-port-output-size! p 0)
           (let ([info ($port-info p)])
             (bytevector-output-port-info-index-set! info 0)
             (bytevector-output-port-info-length-set! info 0))
@@ -4645,9 +4642,7 @@ implementation notes:
              [new-buffer (make-string new-length)])
           (string-copy! old-buffer 0 new-buffer 0
                         (fxmin (string-length old-buffer) old-size))
-          (set-textual-port-output-buffer! p new-buffer)
+          (set-textual-port-output-buffer! p new-buffer))))
-          ;; set size to one less than real size so 'put' always has room
-          (set-textual-port-output-size! p (fx1- new-length)))))
 
     (define port-length
        (lambda (who p)
@@ -4769,7 +4764,6 @@ implementation notes:
                (textual-port-output-buffer p)
                (port-length #f p))])
         (set-textual-port-output-buffer! p "")
-        (set-textual-port-output-size! p 0)
         (let ([info ($port-info p)])
           (string-output-port-info-index-set! info 0)
           (string-output-port-info-length-set! info 0))
@@ -5560,13 +5554,18 @@ implementation notes:
            ($oops who "invalid count argument ~s" n))
          ($block-write who p s n)])))
 
-  (set-who! char-ready?
+  (let ()
-    (lambda (input-port)
+    (define ($char-ready? input-port who)
-      (unless (and (input-port? input-port) (textual-port? input-port))
-        ($oops who "~s is not a textual input port" input-port))
       (or (not (port-input-empty? input-port))
           (port-flag-eof-set? input-port)
-          (call-port-handler ready? who input-port))))
+          (call-port-handler ready? who input-port)))
+    (set-who! char-ready?
+      (case-lambda
+        [() ($char-ready? (current-input-port) who)]
+        [(input-port)
+         (unless (and (input-port? input-port) (textual-port? input-port))
+           ($oops who "~s is not a textual input port" input-port))
+         ($char-ready? input-port who)])))
 
   (set-who! clear-input-port
     (rec clear-input-port

s/library.ss

@@ -503,7 +503,7 @@
 (define-library-entry (fx<= x y) (fxnonfixnum2 'fx<= x y))
 (define-library-entry (fx>= x y) (fxnonfixnum2 'fx>= x y))
 (define-library-entry (fx=? x y) (fxnonfixnum2 'fx=? x y))
-(define-library-entry (fx<? x y) (fxnonfixnum2 'fx< x y))
+(define-library-entry (fx<? x y) (fxnonfixnum2 'fx<? x y))
 (define-library-entry (fx>? x y) (fxnonfixnum2 'fx>? x y))
 (define-library-entry (fx<=? x y) (fxnonfixnum2 'fx<=? x y))
 (define-library-entry (fx>=? x y) (fxnonfixnum2 'fx>=? x y))
@@ -1127,7 +1127,7 @@
           (let ([handler $signal-interrupt-handler])
             ($tc-field 'signal-interrupt-pending ($tc) #f)
             (keyboard)
-            (handler x))
+            (for-each handler ($dequeue-scheme-signals ($tc))))
           (keyboard))))
   (define (keyboard)
     (if ($tc-field 'keyboard-interrupt-pending ($tc))

s/pdhtml.ss

@@ -58,16 +58,168 @@
 
 (let ()
   (include "types.ss")
+  (module (make-tracker tracker-profile-ct)
+    (define-record-type tracker
+      (nongenerative)
+      (fields profile-ct)))
+  (define-record-type cc
+    (nongenerative)
+    (fields (mutable cookie) (mutable total) (mutable current) (mutable preceding)))
+  (define-record-type (source-table $make-source-table $source-table?)
+    (nongenerative)
+    (sealed #t)
+    (opaque #t)
+    (fields ht)
+    (protocol
+      (lambda (new)
+        (lambda ()
+          (define sfd-hash
+            (lambda (sfd)
+              (source-file-descriptor-crc sfd)))
+          (define sfd=?
+            (lambda (sfd1 sfd2)
+              (and (fx= (source-file-descriptor-crc sfd1) (source-file-descriptor-crc sfd2))
+                   (= (source-file-descriptor-length sfd1) (source-file-descriptor-length sfd2))
+                   (string=? (source-file-descriptor-name sfd1) (source-file-descriptor-name sfd2)))))
+          (new (make-hashtable sfd-hash sfd=?))))))
+  (define *local-profile-trackers* '())
   (define op+ car)
   (define op- cdr)
+  (define count+ (constant-case ptr-bits [(32) +] [(64) fx+]))
+  (define count- (constant-case ptr-bits [(32) -] [(64) fx-]))
+  (define count< (constant-case ptr-bits [(32) <] [(64) fx<]))
   (define get-counter-list (foreign-procedure "(cs)s_profile_counters" () ptr))
-  (define set-counter-list! (foreign-procedure "(cs)s_set_profile_counters" (ptr) void))
+  (define release-counters (foreign-procedure "(cs)s_profile_release_counters" () ptr))
-  (set-who! profile-release-counters
+
-    (lambda ()
+  (define rblock-count
-      (set-counter-list!
+    (lambda (rblock)
-        (remp
+      (let sum ((op (rblock-op rblock)))
-          (lambda (x) (bwp-object? (car x)))
+        (if (profile-counter? op)
-          (get-counter-list)))))
+            (profile-counter-count op)
+            ; using #3%fold-left in case the #2% versions are profiled
+            (#3%fold-left
+              (lambda (a op) (count- a (sum op)))
+              (#3%fold-left (lambda (a op) (count+ a (sum op))) 0 (op+ op))
+              (op- op))))))
+
+  (define profile-counts
+    ; like profile-dump but returns ((count . (src ...)) ...)
+    (case-lambda
+      [() (profile-counts (get-counter-list))]
+      [(counter*)
+       ; disabiling interrupts so we don't sum part of the counters for a block before
+       ; an interrupt and the remaining counters after the interrupt, which can lead
+       ; to inaccurate (and possibly negative) counts.  we could disable interrupts just
+       ; around the body of rblock-count to shorten the windows during which interrupts
+       ; are disabled, but doing it here incurs less overhead
+       (with-interrupts-disabled
+         (fold-left
+           (lambda (r x)
+             (fold-left
+               (lambda (r rblock)
+                 (cons (cons (rblock-count rblock) (rblock-srecs rblock)) r))
+               r (cdr x)))
+           '() counter*))]))
+
+  (define (snapshot who uncleared-count* cleared-count*)
+    (lambda (tracker)
+      (define cookie (cons 'vanilla 'wafer))
+      ; set current corresponding to each src to a total of its counts
+      (let ([incr-current
+              (lambda (count.src*)
+                (let ([count (car count.src*)])
+                  (for-each
+                    (lambda (src)
+                      (let ([a ($source-table-cell (tracker-profile-ct tracker) src #f)])
+                        (when (count< count 0) (errorf who "negative profile count ~s for ~s" count src))
+                        (let ([cc (cdr a)])
+                          (if cc
+                              (if (eq? (cc-cookie cc) cookie)
+                                  (cc-current-set! cc (count+ (cc-current cc) count))
+                                  (begin
+                                    (cc-cookie-set! cc cookie)
+                                    (cc-current-set! cc count)))
+                              (set-cdr! a (make-cc cookie 0 count 0))))))
+                    (cdr count.src*))))])
+        (for-each incr-current uncleared-count*)
+        (for-each incr-current cleared-count*))
+      ; then increment total of each affected cc by the delta between current and preceding
+      (source-table-for-each
+        (lambda (src cc)
+          (when (eq? (cc-cookie cc) cookie)
+            (let ([current (cc-current cc)])
+              (let ([delta (count- current (cc-preceding cc))])
+                (unless (eqv? delta 0)
+                  (when (count< delta 0) (errorf who "total profile count for ~s dropped from ~s to ~s" src (cc-preceding cc) current))
+                  (cc-total-set! cc (count+ (cc-total cc) delta))
+                  (cc-preceding-set! cc current))))))
+        (tracker-profile-ct tracker))
+      ; then reduce preceding by cleared counts
+      (for-each
+        (lambda (count.src*)
+          (let ([count (car count.src*)])
+            (for-each
+              (lambda (src)
+                (let ([a ($source-table-cell (tracker-profile-ct tracker) src #f)])
+                  (let ([cc (cdr a)])
+                    (if cc
+                        (cc-preceding-set! cc (count- (cc-preceding cc) count))
+                        (set-cdr! a (make-cc cookie 0 0 0))))))
+              (cdr count.src*))))
+        cleared-count*)))
+
+  (define adjust-trackers!
+    (lambda (who uncleared-counter* cleared-counter*)
+      (let ([local-tracker* *local-profile-trackers*])
+        (unless (null? local-tracker*)
+          (let ([uncleared-count* (profile-counts uncleared-counter*)]
+                [cleared-count* (profile-counts cleared-counter*)])
+            (let ([snapshot (snapshot who uncleared-count* cleared-count*)])
+              (for-each snapshot local-tracker*)))))))
+
+  (define $source-table-contains?
+    (lambda (st src)
+      (let ([src-ht (hashtable-ref (source-table-ht st) (source-sfd src) #f)])
+        (and src-ht (hashtable-contains? src-ht src)))))
+
+  (define $source-table-ref
+    (lambda (st src default)
+      (let ([src-ht (hashtable-ref (source-table-ht st) (source-sfd src) #f)])
+        (if src-ht (hashtable-ref src-ht src default) default))))
+
+  (define $source-table-cell
+    (lambda (st src default)
+      (define same-sfd-src-hash
+        (lambda (src)
+          (source-bfp src)))
+      (define same-sfd-src=?
+        (lambda (src1 src2)
+          (and (= (source-bfp src1) (source-bfp src2))
+               (= (source-efp src1) (source-efp src2)))))
+      (let ([src-ht (let ([a (hashtable-cell (source-table-ht st) (source-sfd src) #f)])
+                      (or (cdr a)
+                          (let ([src-ht (make-hashtable same-sfd-src-hash same-sfd-src=?)])
+                            (set-cdr! a src-ht)
+                            src-ht)))])
+        (hashtable-cell src-ht src default))))
+
+  (define $source-table-delete!
+    (lambda (st src)
+      (let ([ht (source-table-ht st)] [sfd (source-sfd src)])
+        (let ([src-ht (hashtable-ref ht sfd #f)])
+          (when src-ht
+            (hashtable-delete! src-ht src)
+            (when (fx= (hashtable-size src-ht) 0)
+              (hashtable-delete! ht sfd)))))))
+
+  (define source-table-for-each
+    (lambda (p st)
+      (vector-for-each
+        (lambda (src-ht)
+          (let-values ([(vsrc vcount) (hashtable-entries src-ht)])
+            (vector-for-each p vsrc vcount)))
+        (hashtable-values (source-table-ht st)))))
+
   (set-who! profile-clear
     (lambda ()
       (define clear-links
@@ -77,34 +229,210 @@
               (begin
                 (for-each clear-links (op+ op))
                 (for-each clear-links (op- op))))))
+      (let ([counter* (get-counter-list)])
+        (adjust-trackers! who '() counter*)
         (for-each
           (lambda (x)
-          (for-each (lambda (node) (clear-links (rblock-op node)))
+            (for-each
+              (lambda (node) (clear-links (rblock-op node)))
               (cdr x)))
-        (get-counter-list))))
+          counter*))))
-  (set-who! profile-dump
+
+  (set-who! profile-release-counters
     (lambda ()
-      (define rblock-count
+      ; release-counters prunes out (and hands back) the released counters
-        (lambda (rblock)
+      (let* ([dropped-counter* (release-counters)]
-          (let sum ((op (rblock-op rblock)))
+             [kept-counter* (get-counter-list)])
-            ; using #3%apply and #3%map in case the #2% versions are profiled,
+        (adjust-trackers! who kept-counter* dropped-counter*))))
-            ; to avoid possible negative counts
+
-            (if (profile-counter? op)
+  (set-who! profile-dump
-                (profile-counter-count op)
+    ; like profile-counts but returns ((src . count) ...), which requires more allocation
-                (- (#3%apply + (#3%map sum (op+ op)))
+    ; profile-dump could use profile-counts but that would require even more allocation
-                   (#3%apply + (#3%map sum (op- op))))))))
+    (lambda ()
+      ; could disable interrupts just around each call to rblock-count, but doing it here incurs less overhead
+      (with-interrupts-disabled
         (fold-left
           (lambda (r x)
             (fold-left
               (lambda (r rblock)
-              (fold-left
                 (let ([count (rblock-count rblock)])
-                  (lambda (r inst)
+                  (fold-left
-                    (cons (cons inst count) r)))
+                    (lambda (r src)
-                r (rblock-srecs rblock)))
+                      (cons (cons src count) r))
+                    r (rblock-srecs rblock))))
               r (cdr x)))
           '() (get-counter-list)))))
 
+  (set-who! make-source-table
+    (lambda ()
+      ($make-source-table)))
+
+  (set-who! source-table?
+    (lambda (x)
+      ($source-table? x)))
+
+  (set-who! source-table-size
+    (lambda (st)
+      (unless ($source-table? st) ($oops who "~s is not a source table" st))
+      (let ([vsrc-ht (hashtable-values (source-table-ht st))])
+        (let ([n (vector-length vsrc-ht)])
+          (do ([i 0 (fx+ i 1)] [size 0 (fx+ size (hashtable-size (vector-ref vsrc-ht i)))])
+            ((fx= i n) size))))))
+
+  (set-who! source-table-contains?
+    (lambda (st src)
+      (unless ($source-table? st) ($oops who "~s is not a source table" st))
+      (unless (source? src) ($oops who "~s is not a source object" src))
+      ($source-table-contains? st src)))
+
+  (set-who! source-table-ref
+    (lambda (st src default)
+      (unless ($source-table? st) ($oops who "~s is not a source table" st))
+      (unless (source? src) ($oops who "~s is not a source object" src))
+      ($source-table-ref st src default)))
+
+  (set-who! source-table-set!
+    (lambda (st src val)
+      (unless ($source-table? st) ($oops who "~s is not a source table" st))
+      (unless (source? src) ($oops who "~s is not a source object" src))
+      (set-cdr! ($source-table-cell st src #f) val)))
+
+  (set-who! source-table-delete!
+    (lambda (st src)
+      (unless ($source-table? st) ($oops who "~s is not a source table" st))
+      (unless (source? src) ($oops who "~s is not a source object" src))
+      ($source-table-delete! st src)))
+
+  (set-who! source-table-cell
+    (lambda (st src default)
+      (unless ($source-table? st) ($oops who "~s is not a source table" st))
+      (unless (source? src) ($oops who "~s is not a source object" src))
+      ($source-table-cell st src default)))
+
+  (set-who! source-table-dump
+    (lambda (st)
+      (unless ($source-table? st) ($oops who "~s is not a source table" st))
+      (let* ([vsrc-ht (hashtable-values (source-table-ht st))]
+             [n (vector-length vsrc-ht)])
+        (do ([i 0 (fx+ i 1)]
+             [dumpit* '()
+               (let-values ([(vsrc vcount) (hashtable-entries (vector-ref vsrc-ht i))])
+                 (let ([n (vector-length vsrc)])
+                   (do ([i 0 (fx+ i 1)]
+                        [dumpit* dumpit*
+                          (cons (cons (vector-ref vsrc i) (vector-ref vcount i)) dumpit*)])
+                     ((fx= i n) dumpit*))))])
+          ((fx= i n) dumpit*)))))
+
+  (set-who! put-source-table
+    (lambda (op st)
+      (unless (and (output-port? op) (textual-port? op)) ($oops who "~s is not a textual output port" op))
+      (unless ($source-table? st) ($oops who "~s is not a source table" st))
+      (fprintf op "(source-table")
+      (let-values ([(vsfd vsrc-ht) (hashtable-entries (source-table-ht st))])
+        (vector-for-each
+          (lambda (sfd src-ht)
+            (let-values ([(vsrc vval) (hashtable-entries src-ht)])
+              (let ([n (vector-length vsrc)])
+                (unless (fx= n 0)
+                  (fprintf op "\n (file ~s ~s"
+                    (source-file-descriptor-name sfd)
+                    (source-file-descriptor-checksum sfd))
+                  (let ([v (vector-sort (lambda (x1 x2) (< (vector-ref x1 0) (vector-ref x2 0)))
+                              (vector-map (lambda (src val) (vector (source-bfp src) (source-efp src) val)) vsrc vval))])
+                    (let loop ([i 0] [last-bfp 0])
+                      (unless (fx= i n)
+                        (let ([x (vector-ref v i)])
+                          (let ([bfp (vector-ref x 0)] [efp (vector-ref x 1)] [val (vector-ref x 2)])
+                            (let ([offset (- bfp last-bfp)] [len (- efp bfp)])
+                              (fprintf op " (~s ~s ~s)" offset len val))
+                            (loop (fx+ i 1) bfp))))))
+                  (fprintf op ")")))))
+          vsfd vsrc-ht))
+      (fprintf op ")\n")))
+
+  (set-who! get-source-table!
+    (rec get-source-table!
+      (case-lambda
+        [(ip st) (get-source-table! ip st #f)]
+        [(ip st combine)
+         (define (nnint? x) (and (integer? x) (exact? x) (nonnegative? x)))
+         (define (token-oops what bfp)
+           (if bfp
+               ($oops who "expected ~a at file position ~s of ~s" what bfp ip)
+               ($oops who "malformed source table reading from ~a" ip)))
+         (define (next-token expected-type expected-value? what)
+           (let-values ([(type val bfp efp) (read-token ip)])
+             (unless (and (eq? type expected-type) (expected-value? val)) (token-oops what bfp))
+             val))
+         (unless (and (input-port? ip) (textual-port? ip)) ($oops who "~s is not a textual input port" ip))
+         (unless ($source-table? st) ($oops who "~s is not a source table" st))
+         (unless (or (not combine) (procedure? combine)) ($oops who "~s is not a procedure" combine))
+         (next-token 'lparen not "open parenthesis")
+         (next-token 'atomic (lambda (x) (eq? x 'source-table)) "identifier 'source-table'")
+         (let file-loop ()
+           (let-values ([(type val bfp efp) (read-token ip)])
+             (unless (eq? type 'rparen)
+               (unless (eq? type 'lparen) (token-oops "open parenthesis" bfp))
+               (next-token 'atomic (lambda (x) (eq? x 'file)) "identifier 'file'")
+               (let* ([path (next-token 'atomic string? "string")]
+                      [checksum (next-token 'atomic nnint? "checksum")])
+                 (let ([sfd (#%source-file-descriptor path checksum)])
+                   (let entry-loop ([last-bfp 0])
+                     (let-values ([(type val bfp efp) (read-token ip)])
+                       (unless (eq? type 'rparen)
+                         (unless (eq? type 'lparen) (token-oops "open parenthesis" bfp))
+                         (let* ([bfp (+ last-bfp (next-token 'atomic nnint? "file position"))]
+                                [efp (+ bfp (next-token 'atomic nnint? "file position"))]
+                                [val (get-datum ip)])
+                           (next-token 'rparen not "close parenthesis")
+                           (let ([a ($source-table-cell st (make-source-object sfd bfp efp) #f)])
+                             (set-cdr! a
+                               (if (and (cdr a) combine)
+                                   (combine (cdr a) val)
+                                   val)))
+                           (entry-loop bfp)))))))
+               (file-loop))))])))
+
+  (set-who! with-profile-tracker
+    (rec with-profile-tracker
+      (case-lambda
+        [(thunk) (with-profile-tracker #f thunk)]
+        [(include-existing-counts? thunk)
+         (define extract-covered-entries
+           (lambda (profile-ct) 
+             (let ([covered-ct ($make-source-table)])
+               (source-table-for-each
+                 (lambda (src cc)
+                   (let ([count (cc-total cc)])
+                     (unless (eqv? count 0)
+                       ($source-table-cell covered-ct src count))))
+                 profile-ct)
+               covered-ct)))
+         (unless (procedure? thunk) ($oops who "~s is not a procedure" thunk))
+         (let* ([profile-ct ($make-source-table)]
+                [tracker (make-tracker profile-ct)])
+           (unless include-existing-counts?
+             ; set preceding corresponding to each src to a total of its dumpit counts
+             ; set total to zero, since we don't want to count anything from before
+             (for-each
+               (lambda (count.src*)
+                 (let ([count (car count.src*)])
+                   (for-each
+                     (lambda (src)
+                       (let ([a ($source-table-cell profile-ct src #f)])
+                         (let ([cc (cdr a)])
+                           (if cc
+                               (cc-preceding-set! cc (count+ (cc-preceding cc) count))
+                               (set-cdr! a (make-cc #f 0 0 count))))))
+                     (cdr count.src*))))
+               (profile-counts)))
+           ; register for possible adjustment by profile-clear and profile-release-counters
+           (let-values ([v* (fluid-let ([*local-profile-trackers* (cons tracker *local-profile-trackers*)]) (thunk))])
+             ; increment the recorded counts by the now current counts.
+             ((snapshot who (profile-counts) '()) tracker)
+             (apply values (extract-covered-entries profile-ct) v*)))]))))
+
 (let ()
   (include "types.ss")
 
@@ -371,6 +699,10 @@
                     (with-tc-mutex (populate! x))
                     (f)))))
             (close-port ip)))
+        (for-each
+          (lambda (ifn)
+            (unless (string? ifn) ($oops who "~s is not a string" ifn)))
+          ifn*)
         (for-each load-file ifn*)))
     (set! $profile-show-database
       (lambda ()

s/primdata.ss

@@ -216,21 +216,21 @@
   (- [sig [(number number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
   (/ [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
   (abs [sig [(real) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
-  (div-and-mod [sig [(number number) -> (number number)]] [flags discard])
+  (div-and-mod [sig [(real real) -> (real real)]] [flags discard])
-  (div [sig [(number number) -> (number)]] [flags arith-op mifoldable discard])
+  (div [sig [(real real) -> (real)]] [flags arith-op mifoldable discard])
-  (mod [sig [(number number) -> (number)]] [flags arith-op mifoldable discard])
+  (mod [sig [(real real) -> (real)]] [flags arith-op mifoldable discard])
-  (div0-and-mod0 [sig [(number number) -> (number number)]] [flags discard])
+  (div0-and-mod0 [sig [(real real) -> (real real)]] [flags discard])
-  (div0 [sig [(number number) -> (number)]] [flags arith-op mifoldable discard])
+  (div0 [sig [(real real) -> (real)]] [flags arith-op mifoldable discard])
-  (mod0 [sig [(number number) -> (number)]] [flags arith-op mifoldable discard])
+  (mod0 [sig [(real real) -> (real)]] [flags arith-op mifoldable discard])
-  (gcd [sig [(number ...) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
+  (gcd [sig [(integer ...) -> (integer)]] [flags arith-op mifoldable discard ieee r5rs])
-  (lcm [sig [(number ...) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
+  (lcm [sig [(integer ...) -> (integer)]] [flags arith-op mifoldable discard ieee r5rs])
   (numerator [sig [(rational) -> (integer)]] [flags arith-op mifoldable discard ieee r5rs])
   (denominator [sig [(rational) -> (integer)]] [flags arith-op mifoldable discard ieee r5rs])
   (floor [sig [(real) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
   (ceiling [sig [(real) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
   (truncate [sig [(real) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
   (round [sig [(real) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
-  (rationalize [sig [(number number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (rationalize [sig [(real real) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
   (exp [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
   (log [sig [(number) (number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
   (sin [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
@@ -238,9 +238,9 @@
   (tan [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
   (asin [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
   (acos [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (atan [sig [(number) (number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
+  (atan [sig [(number) (real real) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
   (sqrt [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (exact-integer-sqrt [sig [(integer) -> (integer integer)]] [flags discard discard]) ; could be mifoldable if multiple values were handled
+  (exact-integer-sqrt [sig [(exact-integer) -> (exact-integer exact-integer)]] [flags discard discard]) ; could be mifoldable if multiple values were handled
   (expt [sig [(number number) -> (number)]] [flags pure discard true cp02 ieee r5rs]) ; can take too long to fold
   (make-rectangular [sig [(real real) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
   (make-polar [sig [(real real) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
@@ -364,52 +364,52 @@
   (bytevector-s8-set! [sig [(bytevector sub-index s8) -> (void)]] [flags true])
   (bytevector->u8-list [sig [(bytevector) -> (list)]] [flags alloc safeongoodargs])
   (u8-list->bytevector [sig [(sub-list) -> (bytevector)]] [flags alloc])
-  (bytevector-uint-ref [sig [(bytevector sub-index symbol sub-length) -> (uint)]] [flags true mifoldable discard])
+  (bytevector-uint-ref [sig [(bytevector sub-index endianness sub-length) -> (uint)]] [flags true mifoldable discard])
-  (bytevector-sint-ref [sig [(bytevector sub-index symbol sub-length) -> (sint)]] [flags true mifoldable discard])
+  (bytevector-sint-ref [sig [(bytevector sub-index endianness sub-length) -> (sint)]] [flags true mifoldable discard])
-  (bytevector-uint-set! [sig [(bytevector sub-index sub-uint symbol sub-length) -> (void)]] [flags true])
+  (bytevector-uint-set! [sig [(bytevector sub-index sub-uint endianness sub-length) -> (void)]] [flags true])
-  (bytevector-sint-set! [sig [(bytevector sub-index sub-sint symbol sub-length) -> (void)]] [flags true])
+  (bytevector-sint-set! [sig [(bytevector sub-index sub-sint endianness sub-length) -> (void)]] [flags true])
-  (bytevector->uint-list [sig [(bytevector symbol sub-index) -> (list)]] [flags alloc])
+  (bytevector->uint-list [sig [(bytevector endianness sub-index) -> (list)]] [flags alloc])
-  (bytevector->sint-list [sig [(bytevector symbol sub-index) -> (list)]] [flags alloc])
+  (bytevector->sint-list [sig [(bytevector endianness sub-index) -> (list)]] [flags alloc])
-  (uint-list->bytevector [sig [(sub-list symbol sub-index) -> (bytevector)]] [flags alloc])
+  (uint-list->bytevector [sig [(sub-list endianness sub-index) -> (bytevector)]] [flags alloc])
-  (sint-list->bytevector [sig [(sub-list symbol sub-index) -> (bytevector)]] [flags alloc])
+  (sint-list->bytevector [sig [(sub-list endianness sub-index) -> (bytevector)]] [flags alloc])
-  (bytevector-u16-ref [sig [(bytevector sub-index symbol) -> (u16)]] [flags true mifoldable discard])
+  (bytevector-u16-ref [sig [(bytevector sub-index endianness) -> (u16)]] [flags true mifoldable discard])
-  (bytevector-s16-ref [sig [(bytevector sub-index symbol) -> (s16)]] [flags true mifoldable discard])
+  (bytevector-s16-ref [sig [(bytevector sub-index endianness) -> (s16)]] [flags true mifoldable discard])
   (bytevector-u16-native-ref [sig [(bytevector sub-index) -> (u16)]] [flags true cp02])
   (bytevector-s16-native-ref [sig [(bytevector sub-index) -> (s16)]] [flags true cp02])
-  (bytevector-u16-set! [sig [(bytevector sub-index u16 symbol) -> (void)]] [flags true])
+  (bytevector-u16-set! [sig [(bytevector sub-index u16 endianness) -> (void)]] [flags true])
-  (bytevector-s16-set! [sig [(bytevector sub-index s16 symbol) -> (void)]] [flags true])
+  (bytevector-s16-set! [sig [(bytevector sub-index s16 endianness) -> (void)]] [flags true])
   (bytevector-u16-native-set! [sig [(bytevector sub-index u16) -> (void)]] [flags true])
   (bytevector-s16-native-set! [sig [(bytevector sub-index s16) -> (void)]] [flags true])
-  (bytevector-u32-ref [sig [(bytevector sub-index symbol) -> (u32)]] [flags true mifoldable discard])
+  (bytevector-u32-ref [sig [(bytevector sub-index endianness) -> (u32)]] [flags true mifoldable discard])
-  (bytevector-s32-ref [sig [(bytevector sub-index symbol) -> (s32)]] [flags true mifoldable discard])
+  (bytevector-s32-ref [sig [(bytevector sub-index endianness) -> (s32)]] [flags true mifoldable discard])
   (bytevector-u32-native-ref [sig [(bytevector sub-index) -> (u32)]] [flags true cp02])
   (bytevector-s32-native-ref [sig [(bytevector sub-index) -> (s32)]] [flags true cp02])
-  (bytevector-u32-set! [sig [(bytevector sub-index u32 symbol) -> (void)]] [flags true])
+  (bytevector-u32-set! [sig [(bytevector sub-index u32 endianness) -> (void)]] [flags true])
-  (bytevector-s32-set! [sig [(bytevector sub-index s32 symbol) -> (void)]] [flags true])
+  (bytevector-s32-set! [sig [(bytevector sub-index s32 endianness) -> (void)]] [flags true])
   (bytevector-u32-native-set! [sig [(bytevector sub-index u32) -> (void)]] [flags true])
   (bytevector-s32-native-set! [sig [(bytevector sub-index s32) -> (void)]] [flags true])
-  (bytevector-u64-ref [sig [(bytevector sub-index symbol) -> (u64)]] [flags true mifoldable discard])
+  (bytevector-u64-ref [sig [(bytevector sub-index endianness) -> (u64)]] [flags true mifoldable discard])
-  (bytevector-s64-ref [sig [(bytevector sub-index symbol) -> (s64)]] [flags true mifoldable discard])
+  (bytevector-s64-ref [sig [(bytevector sub-index endianness) -> (s64)]] [flags true mifoldable discard])
   (bytevector-u64-native-ref [sig [(bytevector sub-index) -> (u64)]] [flags true cp02])
   (bytevector-s64-native-ref [sig [(bytevector sub-index) -> (s64)]] [flags true cp02])
-  (bytevector-u64-set! [sig [(bytevector sub-index u64 symbol) -> (void)]] [flags true])
+  (bytevector-u64-set! [sig [(bytevector sub-index u64 endianness) -> (void)]] [flags true])
-  (bytevector-s64-set! [sig [(bytevector sub-index s64 symbol) -> (void)]] [flags true])
+  (bytevector-s64-set! [sig [(bytevector sub-index s64 endianness) -> (void)]] [flags true])
   (bytevector-u64-native-set! [sig [(bytevector sub-index u64) -> (void)]] [flags true])
   (bytevector-s64-native-set! [sig [(bytevector sub-index s64) -> (void)]] [flags true])
-  (bytevector-ieee-single-ref [sig [(bytevector sub-index symbol) -> (flonum)]] [flags true mifoldable discard])
+  (bytevector-ieee-single-ref [sig [(bytevector sub-index endianness) -> (flonum)]] [flags true mifoldable discard])
   (bytevector-ieee-single-native-ref [sig [(bytevector sub-index) -> (flonum)]] [flags true mifoldable discard])
-  (bytevector-ieee-double-ref [sig [(bytevector sub-index symbol) -> (flonum)]] [flags true mifoldable discard])
+  (bytevector-ieee-double-ref [sig [(bytevector sub-index endianness) -> (flonum)]] [flags true mifoldable discard])
   (bytevector-ieee-double-native-ref [sig [(bytevector sub-index) -> (flonum)]] [flags true mifoldable discard])
-  (bytevector-ieee-single-set! [sig [(bytevector sub-index real symbol) -> (void)]] [flags true])
+  (bytevector-ieee-single-set! [sig [(bytevector sub-index real endianness) -> (void)]] [flags true])
   (bytevector-ieee-single-native-set! [sig [(bytevector sub-index real) -> (void)]] [flags true])
-  (bytevector-ieee-double-set! [sig [(bytevector sub-index real symbol) -> (void)]] [flags true])
+  (bytevector-ieee-double-set! [sig [(bytevector sub-index real endianness) -> (void)]] [flags true])
   (bytevector-ieee-double-native-set! [sig [(bytevector sub-index real) -> (void)]] [flags true])
   (string->utf8 [sig [(string) -> (bytevector)]] [flags alloc])
-  (string->utf16 [sig [(string) (string symbol) -> (bytevector)]] [flags alloc])
+  (string->utf16 [sig [(string) (string endianness) -> (bytevector)]] [flags alloc])
-  (string->utf32 [sig [(string) (string symbol) -> (bytevector)]] [flags alloc])
+  (string->utf32 [sig [(string) (string endianness) -> (bytevector)]] [flags alloc])
   (utf8->string [sig [(bytevector) -> (string)]] [flags alloc])
-  (utf16->string [sig [(bytevector sub-symbol) (bytevector sub-symbol ptr) -> (string)]] [flags alloc])
+  (utf16->string [sig [(bytevector endianness) (bytevector endianness ptr) -> (string)]] [flags alloc])
-  (utf32->string [sig [(bytevector sub-symbol) (bytevector sub-symbol ptr) -> (string)]] [flags alloc])
+  (utf32->string [sig [(bytevector endianness) (bytevector endianness ptr) -> (string)]] [flags alloc])
 )
 
 (define-symbol-flags* ([libraries (rnrs) (rnrs control)] [flags keyword])
@@ -521,7 +521,7 @@
   (make-eqv-hashtable [sig [() (uint) -> (hashtable)]] [flags alloc])
   (make-hashtable [sig [(procedure procedure) (procedure procedure uint) -> (hashtable)]] [flags alloc])
   (hashtable? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
-  (hashtable-size [sig [(hashtable) -> (length)]] [flags true])
+  (hashtable-size [sig [(hashtable) -> (length)]] [flags discard true])
   (hashtable-ref [sig [(hashtable ptr ptr) -> (ptr)]] [flags discard])
   (hashtable-set! [sig [(hashtable ptr ptr) -> (void)]] [flags true])
   (hashtable-delete! [sig [(hashtable ptr) -> (void)]] [flags true])
@@ -731,9 +731,9 @@
 (define-symbol-flags* ([libraries (rnrs r5rs)] [flags primitive proc])
   (exact->inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
   (inexact->exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard ieee r5rs]) ; no safeongoodargs because it fails with +inf.0
-  (quotient [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
+  (quotient [sig [(integer integer) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (remainder [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
+  (remainder [sig [(integer integer) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (modulo [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
+  (modulo [sig [(integer integer) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
   (force [sig [(procedure) -> (ptr)]] [flags r5rs])
   (null-environment [sig [(sub-fixnum) -> (environment)]] [flags alloc ieee r5rs])
   (scheme-report-environment [sig [(sub-fixnum) -> (environment)]] [flags alloc ieee r5rs])
@@ -868,7 +868,7 @@
   (date-year [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true])
   (date-zone-offset [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true])
   (date-zone-name [sig [(date) -> (ptr)]] [flags pure mifoldable discard])
-  (date->time-utc [sig [(date) -> (time)]] [flags alloc])
+  (date->time-utc [sig [(date) -> (time-utc)]] [flags alloc])
   (make-date [sig [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-fixnum) -> (date)]
                   [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum) -> (date)]]
              [flags alloc])
@@ -889,7 +889,7 @@
   (time-nanosecond [sig [(time) -> (uint)]] [flags mifoldable discard true])
   (time-second [sig [(time) -> (exact-integer)]] [flags mifoldable discard true])
   (time-type [sig [(time) -> (symbol)]] [flags mifoldable discard true])
-  (time-utc->date [sig [(time) (time sub-fixnum) -> (date)]] [flags alloc])
+  (time-utc->date [sig [(time-utc) (time-utc sub-fixnum) -> (date)]] [flags alloc])
 )
 
 (define-symbol-flags* ([libraries] [flags primitive proc]) ; constant parameters
@@ -950,7 +950,7 @@
   (custom-port-buffer-size [sig [() -> (ufixnum)] [(sub-fixnum) -> (void)]] [flags])
   (debug-level [sig [() -> (ufixnum)] [(sub-ufixnum) -> (void)]] [flags])
   (debug-on-exception [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
-  (default-library-search-handler [sig [(symbol list list list) -> (maybe-string maybe-string boolean)]] [flags])
+  (default-library-search-handler [sig [(symbol library-path list-of-string-pairs list-of-string-pairs) -> (maybe-string maybe-string boolean)]] [flags])
   (default-record-equal-procedure [sig [() -> (maybe-procedure)] [(maybe-procedure) -> (void)]] [flags])
   (default-record-hash-procedure [sig [() -> (maybe-procedure)] [(maybe-procedure) -> (void)]] [flags])
   (enable-arithmetic-left-associative [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
@@ -968,6 +968,7 @@
   (exit-handler [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
   (file-buffer-size [sig [() -> (ufixnum)] [(sub-fixnum) -> (void)]] [flags])
   (generate-allocation-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
+  (generate-covin-files [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (generate-inspector-information [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (generate-instruction-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (generate-interrupt-trap [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
@@ -980,6 +981,7 @@
   (import-notify [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (interaction-environment [sig [() -> (environment)] [(environment) -> (void)]] [flags ieee r5rs])
   (internal-defines-as-letrec* [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
+  (invoke-library [sig [(ptr) -> (void)]] [flags true])
   (keyboard-interrupt-handler [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
   (library-directories [sig [() -> (list)] [(sub-ptr) -> (void)]] [flags])
   (library-exports [sig [(sub-list) -> (list)]] [flags])
@@ -1223,27 +1225,28 @@
   (compile [sig [(sub-ptr) (sub-ptr environment) -> (ptr ...)]] [flags])
   (compile-file [sig [(pathname) (pathname pathname) (pathname pathname sub-symbol) -> (void)]] [flags true])
   (compile-library [sig [(pathname) (pathname pathname) (pathname pathname sub-symbol) -> (void)]] [flags true])
-  (compile-port [sig [(textual-input-port binary-output-port) (textual-input-port binary-output-port maybe-sfd) (textual-input-port binary-output-port maybe-sfd maybe-binary-output-port) (textual-input-port binary-output-port maybe-sfd maybe-binary-output-port sub-symbol) (textual-input-port binary-output-port maybe-sfd maybe-binary-output-port sub-symbol maybe-binary-output-port) -> (void)]] [flags true])
+  (compile-port [sig [(textual-input-port binary-output-port) (textual-input-port binary-output-port maybe-sfd) (textual-input-port binary-output-port maybe-sfd maybe-binary-output-port) (textual-input-port binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port) (textual-input-port binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol) (textual-input-port binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port) -> (void)]] [flags true])
   (compile-program [sig [(pathname) (pathname pathname) (pathname pathname sub-symbol) -> (list)]] [flags true])
   (compile-script [sig [(pathname) (pathname pathname) (pathname pathname sub-symbol) -> (void)]] [flags true])
   (compile-time-value? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (compile-time-value-value [sig [(compile-time-value) -> (ptr)]] [flags pure mifoldable discard])
   (compile-to-file [sig [(list pathname) (list pathname maybe-sfd) -> (void/list)]] [flags true])
-  (compile-to-port [sig [(list binary-output-port) (list binary-output-port maybe-sfd) (list binary-output-port maybe-sfd maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port sub-symbol)  (list binary-output-port maybe-sfd maybe-binary-output-port sub-symbol maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port sub-symbol maybe-binary-output-port maybe-pathname) -> (void/list)]] [flags true])
+  (compile-to-port [sig [(list binary-output-port) (list binary-output-port maybe-sfd) (list binary-output-port maybe-sfd maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port) -> (ptr)]] [flags true])
   (compile-whole-program [sig [(string string) (string string ptr) -> (void)]] [flags])
   (compile-whole-library [sig [(string string) -> (void)]] [flags])
   (compute-composition [sig [(ptr) -> (list)] [(ptr sub-ufixnum) -> (list)]] [flags alloc])
   (compute-size [sig [(ptr) -> (uint)] [(ptr sub-ufixnum) -> (uint)]] [flags alloc])
   (compute-size-increments [sig [(list) -> (list)] [(list sub-ufixnum) -> (list)]] [flags alloc])
+  (concatenate-object-files [sig [(pathname pathname pathname ...) -> (void)]] [flags true])
   (condition-broadcast [feature pthreads] [sig [(condition-object) -> (void)]] [flags true])
   (condition-continuation [sig [(continuation-condition) -> (ptr)]] [flags pure mifoldable discard])
   (condition-name [feature pthreads] [sig [(condition-object) -> (maybe-symbol)]] [flags pure])
   (condition-signal [feature pthreads] [sig [(condition-object) -> (void)]] [flags true])
-  (condition-wait [feature pthreads] [sig [(condition-object mutex) (condition-object mutex timeout) -> (boolean)]] [flags])
+  (condition-wait [feature pthreads] [sig [(condition-object mutex) (condition-object mutex maybe-timeout) -> (boolean)]] [flags])
   (conjugate [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
   (continuation-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (continuation-next-attachments [sig [(ptr) -> (list)]] [flags])
-  (copy-environment [sig [(environment) (environment ptr) (environment ptr sub-list) -> (environment)]] [flags alloc])
+  (copy-environment [sig [(environment) (environment ptr) (environment ptr list-of-symbols) -> (environment)]] [flags alloc])
   (copy-time [sig [(time) -> (time)]] [flags alloc])
   (cosh [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
   (cost-center? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
@@ -1300,7 +1303,7 @@
   (expand/optimize [sig [(ptr) (ptr environment) -> (ptr)]] [flags])
   (expt-mod [sig [(integer integer integer) -> (integer)]] [flags arith-op mifoldable discard])
   (fasl-file [sig [(pathname pathname) -> (void)]] [flags true])
-  (fasl-read [sig [(binary-input-port) -> (ptr)]] [flags])
+  (fasl-read [sig [(binary-input-port) (binary-input-port sub-symbol) -> (ptr)]] [flags true])
   (fasl-write [sig [(sub-ptr binary-output-port) -> (void)]] [flags true])
   (vfasl-convert-file [sig [(ptr ptr ptr) -> (void)]] [flags])
   (file-access-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard])
@@ -1395,10 +1398,12 @@
   (get-mode [sig [(pathname) (pathname ptr) -> (fixnum)]] [flags])
   (get-output-string [sig [(sub-textual-output-port) -> (string)]] [flags true])
   (get-registry [feature windows] [sig [(string) -> (maybe-string)]] [flags  discard])
+  (get-source-table! [sig [(textual-input-port source-table) (textual-input-port source-table maybe-procedure) -> (void)]] [flags true])
   (get-string-some [sig [(textual-input-port) -> (eof/string)]] [flags true])
   (get-string-some! [sig [(textual-input-port string length length) -> (eof/length)]] [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])
@@ -1435,7 +1440,6 @@
   (load [sig [(pathname) (pathname procedure) -> (void)]] [flags true ieee r5rs])
   (load-compiled-from-port [sig [(ptr) -> (ptr ...)]] [flags])
   (load-library [sig [(pathname) (pathname procedure) -> (void)]] [flags true])
-  (profile-load-data [sig [(pathname) -> (void)]] [flags true])
   (load-program [sig [(pathname) (pathname procedure) -> (void)]] [flags true])
   (load-shared-object [sig [(maybe-pathname) -> (void)]] [flags true])
   (locate-source [sig [(sfd uint) (sfd uint ptr) -> ()] [(sfd uint) (sfd uint ptr) -> (string uint uint)]] [flags])
@@ -1460,6 +1464,7 @@
   (make-condition [feature pthreads] [sig [() (maybe-symbol) -> (condition-object)]] [flags pure unrestricted alloc])
   (make-continuation-condition [sig [(ptr) -> (condition)]] [flags pure unrestricted mifoldable discard])
   (make-cost-center [sig [() -> (cost-center)]] [flags unrestricted alloc])
+  (make-source-table [sig [() -> (source-table)]] [flags unrestricted alloc])
   (make-ephemeron-eq-hashtable [sig [() (uint) -> (eq-hashtable)]] [flags alloc])
   (make-ephemeron-eqv-hashtable [sig [() (uint) -> (hashtable)]] [flags alloc])
   (make-engine [sig [(procedure) -> (engine)]] [flags pure alloc])
@@ -1479,8 +1484,8 @@
   (make-record-type [sig [(sub-ptr sub-list) (maybe-rtd sub-ptr sub-list) -> (rtd)]] [flags pure alloc cp02])
   (make-record-type-descriptor* [sig [(symbol maybe-rtd maybe-symbol ptr ptr fixnum exact-integer) -> (rtd)]] [flags pure alloc cp02])
   (make-source-condition [sig [(ptr) -> (condition)]] [flags pure unrestricted mifoldable discard])
-  (make-source-file-descriptor [sig [(string binary-input-port) (string binary-input-port ptr) (string binary-input-port ptr ptr) -> (sfd)]] [flags true])
+  (make-source-file-descriptor [sig [(string binary-input-port) (string binary-input-port ptr) -> (sfd)]] [flags true])
-  (make-source-object [sig [(sfd uint uint) (sfd uint uint uint uint) -> (source-object)]] [flags pure true mifoldable discard])
+  (make-source-object [sig [(sfd uint uint) (sfd uint uint nzuint nzuint) -> (source-object)]] [flags pure true mifoldable discard])
   (make-sstats [sig [(time time exact-integer exact-integer time time exact-integer) -> (sstats)]] [flags alloc])
   (make-thread-parameter [feature pthreads] [sig [(ptr) (ptr procedure) -> (thread-parameter)]] [flags true cp02 cp03])
   (make-weak-eq-hashtable [sig [() (uint) -> (eq-hashtable)]] [flags alloc])
@@ -1559,16 +1564,18 @@
   (procedure-arity-mask [sig [(procedure) -> (sint)]] [flags mifoldable discard safeongoodargs true])
   (procedure-known-single-valued? [sig [(procedure) -> (boolean)]] [flags mifoldable discard safeongoodargs])
   (process [sig [(string) -> (list)]] [flags])
-  (profile-clear-database [sig [() -> (void)]] [flags true])
   (profile-clear [sig [() -> (void)]] [flags true])
+  (profile-clear-database [sig [() -> (void)]] [flags true])
   (profile-dump [sig [() -> (list)]] [flags discard true])
   (profile-dump-data [sig [(pathname) (pathname sub-list) -> (void)]] [flags true])
-  (profile-dump-list [sig [() (ptr) (ptr sub-list) -> (list)]] [flags discard true])
   (profile-dump-html [sig [() (pathname) (pathname sub-list) -> (void)]] [flags true])
+  (profile-dump-list [sig [() (ptr) (ptr sub-list) -> (list)]] [flags discard true])
+  (profile-load-data [sig [(pathname ...) -> (void)]] [flags true])
   (profile-release-counters [sig [() -> (void)]] [flags true])
   (property-list [sig [(symbol) -> (list)]] [flags discard true safeongoodargs])
   (put-bytevector-some [sig [(binary-output-port bytevector) (binary-output-port bytevector length) (binary-output-port bytevector length length) -> (uint)]] [flags true])
   (put-hash-table! [sig [(old-hash-table ptr ptr) -> (void)]] [flags true])
+  (put-source-table [sig [(textual-output-port source-table) -> (void)]] [flags true])
   (put-registry! [feature windows] [sig [(string string) -> (void)]] [flags true])
   (put-string-some [sig [(textual-output-port string) (textual-output-port string length) (textual-output-port string length length) -> (uint)]] [flags true])
   (putprop [sig [(symbol ptr ptr) -> (void)]] [flags true safeongoodargs])
@@ -1580,7 +1587,7 @@
   (pseudo-random-generator? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (random [sig [(sub-number) -> (number)]] [flags alloc])
   (ratnum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
-  (read-token [sig [() (textual-input-port) (textual-input-port sfd) -> (symbol ptr maybe-uint maybe-uint)]] [flags])
+  (read-token [sig [() (textual-input-port) (textual-input-port sfd uint) -> (symbol ptr maybe-uint maybe-uint)]] [flags])
   (real-time [sig [() -> (uint)]] [flags unrestricted alloc])
   (record? [sig [(ptr) (ptr rtd) -> (boolean)]] [flags pure mifoldable discard cp02 cptypes2])
   (record-constructor [sig [(sub-ptr) -> (procedure)]] [flags cp02]) ; accepts rtd or rcd
@@ -1607,6 +1614,7 @@
   (reset-maximum-memory-bytes! [sig [() -> (void)]] [flags true])
   (reverse! [sig [(list) -> (list)]] [flags true])
   (revisit [sig [(pathname) -> (void)]] [flags true])
+  (revisit-compiled-from-port [sig [(ptr) -> (ptr ...)]] [flags])
   (s8-list->bytevector [sig [(sub-list) -> (bytevector)]] [flags alloc])
   (sc-expand [sig [(ptr) (ptr environment) (ptr environment ptr) (ptr environment ptr ptr) (ptr environment ptr ptr maybe-string) -> (ptr)]] [flags])
   (scheme-environment [sig [() -> (environment)]] [flags unrestricted alloc])
@@ -1653,7 +1661,7 @@
   (sort! [sig [(procedure list) -> (list)]] [flags true])
   (source-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (source-condition-form [sig [(source-condition) -> (ptr)]] [flags pure mifoldable discard])
-  (source-file-descriptor [sig [(sfd uint) -> (sfd)]] [flags alloc])
+  (source-file-descriptor [sig [(string uint) -> (sfd)]] [flags alloc])
   (source-file-descriptor? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (source-file-descriptor-checksum [sig [(sfd) -> (sint)]] [flags pure mifoldable discard true])
   (source-file-descriptor-path [sig [(sfd) -> (string)]] [flags pure mifoldable discard true])
@@ -1663,6 +1671,14 @@
   (source-object-efp [sig [(source-object) -> (uint)]] [flags pure mifoldable discard])
   (source-object-line [sig [(source-object) -> (maybe-uint)]] [flags pure mifoldable discard])
   (source-object-sfd [sig [(source-object) -> (sfd)]] [flags pure mifoldable discard])
+  (source-table? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
+  (source-table-contains? [sig [(source-table source-object) -> (boolean)]] [flags discard])
+  (source-table-cell [sig [(source-table source-object ptr) -> ((ptr . ptr))]] [flags true])
+  (source-table-delete! [sig [(source-table source-object) -> (void)]] [flags true])
+  (source-table-dump [sig [(source-table) -> (list)]] [flags alloc])
+  (source-table-ref [sig [(source-table source-object ptr) -> (ptr)]] [flags discard])
+  (source-table-set! [sig [(source-table source-object ptr) -> (void)]] [flags true])
+  (source-table-size [sig [(source-table) -> (length)]] [flags discard true])
   (sstats-bytes [sig [(sstats) -> (exact-integer)]] [flags mifoldable discard])
   (sstats-cpu [sig [(sstats) -> (time)]] [flags mifoldable discard])
   (sstats-difference [sig [(sstats sstats) -> (sstats)]] [flags mifoldable discard true])
@@ -1754,6 +1770,7 @@
   (uninterned-symbol? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (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])
@@ -1763,9 +1780,11 @@
   (vector->pseudo-random-generator [sig [(vector) -> (pseudo-random-generator)]] [flags])
   (vector->pseudo-random-generator! [sig [(pseudo-random-generator vector) -> (void)]] [flags])
   (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])
+  (visit-compiled-from-port [sig [(ptr) -> (ptr ...)]] [flags])
   (void [sig [() -> (void)]] [flags pure unrestricted mifoldable discard true])
   (warning [sig [(maybe-who string sub-ptr ...) -> (ptr ...)]] [flags])
   (warningf [sig [(maybe-who string sub-ptr ...) -> (ptr ...)]] [flags])
@@ -1776,6 +1795,7 @@
   (with-input-from-string [sig [(string procedure) -> (ptr ...)]] [flags])
   (with-output-to-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags])    ; has options argument
   (with-output-to-string [sig [(procedure) -> (string)]] [flags])
+  (with-profile-tracker [sig [(procedure) (ptr procedure) -> (ptr ptr ...)]] [flags])
   (with-source-path [sig [(maybe-who pathname procedure) -> (ptr ...)]] [flags])
   (wrapper-procedure? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (wrapper-procedure-data [sig [(ptr) -> (ptr)]] [flags discard])
@@ -1862,6 +1882,7 @@
   ($current-attachments [flags single-valued])
   ($current-stack-link [flags single-valued])
   ($current-winders [flags single-valued])
+  ($dequeue-scheme-signals [flags])
   ($distinct-bound-ids? [sig [(list) -> (boolean)]] [flags discard])
   ($dofmt [flags single-valued])
   ($do-wind [flags single-valued])
@@ -2100,6 +2121,7 @@
   ($inexactnum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
   ($inexactnum-imag-part [flags single-valued])
   ($inexactnum-real-part [flags single-valued])
+  ($insert-profile-src! [flags])
   ($install-ftype-guardian [flags single-valued])
   ($install-guardian [flags single-valued])
   ($install-library-clo-info [flags single-valued])
@@ -2190,6 +2212,7 @@
   ($map [flags single-valued])
   ($mark-invoked! [flags single-valued])
   ($maybe-compile-file [flags single-valued])
+  ($mark-pending! [flags])
   ($maybe-seginfo [flags single-valued])
   ($noexpand?  [sig [(ptr) -> (boolean)]] [flags discard])
   ($np-boot-code [flags single-valued])

s/prims.ss

@@ -84,6 +84,11 @@
     ()
     scheme-object))
 
+(define $dequeue-scheme-signals
+  (foreign-procedure "(cs)dequeue_scheme_signals"
+    (ptr)
+    ptr))
+
 (define-who $show-allocation
   (let ([fp (foreign-procedure "(cs)s_showalloc" (boolean string) void)])
     (case-lambda
@@ -1544,6 +1549,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)))
@@ -1870,9 +1897,9 @@
   (define-tc-parameter $sfd (lambda (x) (or (eq? x #f) (source-file-descriptor? x))) "a source-file descriptor or #f" #f)
   (define-tc-parameter $current-mso (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f)
   (define-tc-parameter $target-machine symbol? "a symbol")
-  (define-tc-parameter optimize-level (lambda (x) (and (fixnum? x) (fx<= 0 x 3))) "valid optimize level" 0)
+  (define-tc-parameter optimize-level (lambda (x) (and (fixnum? x) (fx<= 0 x 3))) "a valid optimize level" 0)
-  (define-tc-parameter $compile-profile (lambda (x) (memq x '(#f source block))) "valid compile-profile flag" #f)
+  (define-tc-parameter $compile-profile (lambda (x) (memq x '(#f source block))) "a valid compile-profile flag" #f)
-  (define-tc-parameter subset-mode (lambda (mode) (memq mode '(#f system))) "valid subset mode" #f)
+  (define-tc-parameter subset-mode (lambda (mode) (memq mode '(#f system))) "a valid subset mode" #f)
   (define-tc-parameter default-record-equal-procedure (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f)
   (define-tc-parameter default-record-hash-procedure (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f)
 )

s/read.ss

@@ -279,7 +279,11 @@
   (let ([ip (rcb-ip rcb)])
     (cond
       [(eq? ip (console-input-port)) ($lexical-error (rcb-who rcb) msg args ip ir?)]
-      [(not fp) ($lexical-error (rcb-who rcb) "~? on ~s" (list msg args ip) ip ir?)]
+      [(not fp)
+       (let ([pos (and (port-has-port-position? ip) (port-position ip))])
+         (if pos
+             ($lexical-error (rcb-who rcb) "~? before file-position ~s of ~s; the character position might differ" (list msg args pos ip) ip ir?)
+             ($lexical-error (rcb-who rcb) "~? on ~s" (list msg args ip) ip ir?)))]
       [(rcb-sfd rcb) ($lexical-error (rcb-who rcb) msg args ip ($make-source-object (rcb-sfd rcb) bfp fp) start? ir?)]
       [else ($lexical-error (rcb-who rcb) "~? at char ~a of ~s" (list msg args (if start? bfp fp) ip) ip ir?)])))
 
@@ -1526,30 +1530,33 @@
          (xmvlet ((x stripped-x) (xcall rd type value))
            (xvalues))]))))
 
-(set! read-token
+(set-who! read-token
-  (let ([who 'read-token])
+  (let ()
     (define read-token
-      (lambda (ip sfd)
+      (lambda (ip sfd fp)
         (when (port-closed? ip)
           ($oops who "not permitted on closed port ~s" ip))
-        (let ([fp (and (port-has-port-position? ip)
+        (let ([fp (or fp
-                       ($port-flags-set? ip (constant port-flag-char-positions))
+                      (and ($port-flags-set? ip (constant port-flag-char-positions))
-                       (port-position ip))])
+                           (port-has-port-position? ip)
+                           (port-position ip)))])
           (let ([rcb (make-rcb ip sfd #f who)] [tb ""] [bfp fp] [it #f])
             (with-token (type value)
               (values type value bfp fp))))))
     (case-lambda
-      [() (read-token (current-input-port) #f)]
+      [() (read-token (current-input-port) #f #f)]
       [(ip)
        (unless (and (input-port? ip) (textual-port? ip))
          ($oops who "~s is not a textual input port" ip))
-       (read-token ip #f)]
+       (read-token ip #f #f)]
-      [(ip sfd)
+      [(ip sfd fp)
        (unless (and (input-port? ip) (textual-port? ip))
          ($oops who "~s is not a textual input port" ip))
-       (unless (or (not sfd) (source-file-descriptor? sfd))
+       (unless (source-file-descriptor? sfd)
          ($oops who "~s is not a source-file descriptor" sfd))
-       (read-token ip sfd)])))
+       (unless (and (integer? fp) (exact? fp) (>= fp 0))
+         ($oops who "~s is not a valid file position" fp))
+       (read-token ip sfd fp)])))
 
 (let ()
   (define do-read
@@ -1557,8 +1564,8 @@
       (when (port-closed? ip)
         ($oops who "not permitted on closed port ~s" ip))
       (let ([fp (or fp
-                    (and (port-has-port-position? ip)
+                    (and ($port-flags-set? ip (constant port-flag-char-positions))
-                         ($port-flags-set? ip (constant port-flag-char-positions))
+                         (port-has-port-position? ip)
                          (port-position ip)))])
         (let ([rcb (make-rcb ip sfd (and a? sfd fp #t) who)] [tb ""] [bfp fp] [it #f])
           (call-with-token rd-top-level)))))
@@ -1578,7 +1585,7 @@
     (lambda (ip sfd fp)
       (unless (and (input-port? ip) (textual-port? ip))
         ($oops who "~s is not a textual input port" ip))
-      (unless (or (not sfd) (source-file-descriptor? sfd))
+      (unless (source-file-descriptor? sfd)
         ($oops who "~s is not a source-file descriptor" sfd))
       (unless (and (integer? fp) (exact? fp) (>= fp 0))
         ($oops who "~s is not a valid file position" fp))

s/strip.ss

@@ -19,7 +19,7 @@
   (define-threaded fasl-count)
 
   (define-datatype fasl
-    (entry fasl)
+    (entry situation fasl)
     (header version machine dependencies)
     (pair vfasl)
     (tuple ty vfasl)
@@ -38,10 +38,7 @@
     (code flags free name arity-mask info pinfo* bytes m vreloc)
     (atom ty uptr)
     (reloc type-etc code-offset item-offset fasl)
-    (indirect g i)
+    (indirect g i))
-    (group vfasl)
-    (visit fasl)
-    (revisit fasl))
 
   (define-datatype field
     (ptr fasl)
@@ -118,10 +115,15 @@
             ty
             (fasl-type-case ty
               [(fasl-type-header) (read-header p)]
+              [(fasl-type-visit fasl-type-revisit fasl-type-visit-revisit)
+               (let ([situation ty])
+                 (let ([ty (read-byte p)])
+                   (fasl-type-case ty
                      [(fasl-type-fasl-size)
                       (let ([size (read-uptr p)])
-                 (fasl-entry (read-fasl p #f)))]
+                        (fasl-entry situation (read-fasl p #f)))]
-              [else (bogus "expected header or entry in ~a" (port-name p))]))))
+                     [else (bogus "expected fasl-size in ~a" (port-name p))])))]
+              [else (bogus "expected header or situation in ~a" (port-name p))]))))
     (define (read-header p)
       (let* ([bv (constant fasl-header)] [n (bytevector-length bv)])
         (do ([i 1 (fx+ i 1)])
@@ -279,9 +281,6 @@
            (let ([n (read-uptr p)])
              (or (vector-ref g n)
                  (fasl-indirect g n)))]
-          [(fasl-type-group) (fasl-group (read-vfasl p g (read-uptr p)))]
-          [(fasl-type-visit) (fasl-visit (read-fasl p g))]
-          [(fasl-type-revisit) (fasl-revisit (read-fasl p g))]
           [else (bogus "unexpected fasl code ~s in ~a" ty (port-name p))]))))
 
   (define read-script-header
@@ -394,7 +393,7 @@
             (lambda ()
               (vector-for-each (lambda (fasl) (build! fasl t)) vfasl))))
         (fasl-case x
-          [entry (fasl) (sorry! "unexpected fasl-record-type entry")]
+          [entry (situation fasl) (sorry! "unexpected fasl-record-type entry")]
           [header (version machine dependencies) (sorry! "unexpected fasl-record-type header")]
           [pair (vfasl) (build-graph! x t (build-vfasl! vfasl))]
           [tuple (ty vfasl) (build-graph! x t (build-vfasl! vfasl))]
@@ -445,17 +444,14 @@
                (vector-for-each (lambda (reloc) (build! reloc t)) vreloc)))]
           [atom (ty uptr) (void)]
           [reloc (type-etc code-offset item-offset fasl) (build! fasl t)]
-          [indirect (g i) (build! (vector-ref g i) t)]
+          [indirect (g i) (build! (vector-ref g i) t)])))
-          [group (vfasl) ((build-vfasl! vfasl))]
-          [visit (fasl) (build! fasl t)]
-          [revisit (fasl) (build! fasl t)])))
 
     (define write-entry
       (lambda (p x)
         (fasl-case x
           [header (version machine dependencies)
            (write-header p version machine dependencies)]
-          [entry (fasl)
+          [entry (situation fasl)
            (let ([t (make-table)])
              (build! fasl t)
              (let ([bv (call-with-bytevector-output-port
@@ -465,6 +461,7 @@
                                (write-byte p (constant fasl-type-graph))
                                (write-uptr p n)))
                            (write-fasl p t fasl)))])
+               (write-byte p situation)
                (write-byte p (constant fasl-type-fasl-size))
                (write-uptr p (bytevector-length bv))
                (put-bytevector p bv)))]
@@ -499,7 +496,7 @@
     (define write-fasl
       (lambda (p t x)
         (fasl-case x
-          [entry (fasl) (sorry! "unexpected fasl-record-type entry")]
+          [entry (situation fasl) (sorry! "unexpected fasl-record-type entry")]
           [header (version machine dependencies) (sorry! "unexpected fasl-record-type header")]
           [pair (vfasl)
            (write-graph p t x
@@ -641,17 +638,7 @@
            (write-uptr p code-offset)
            (when (fxlogtest type-etc 2) (write-uptr p item-offset))
            (write-fasl p t fasl)]
-          [indirect (g i) (write-fasl p t (vector-ref g i))]
+          [indirect (g i) (write-fasl p t (vector-ref g i))])))
-          [group (vfasl)
-           (write-byte p (constant fasl-type-group))
-           (write-uptr p (vector-length vfasl))
-           (vector-for-each (lambda (fasl) (write-fasl p t fasl)) vfasl)]
-          [visit (fasl)
-           (write-byte p (constant fasl-type-visit))
-           (write-fasl p t fasl)]
-          [revisit (fasl)
-           (write-byte p (constant fasl-type-revisit))
-           (write-fasl p t fasl)])))
 
     (define write-byte
       (lambda (p x)
@@ -685,39 +672,21 @@
             ((fx= i n))
             (write-uptr p (char->integer (string-ref x i)))))))
 
-    (module (fasl-program-info? fasl-library/rt-info?)
+    (module (fasl-program-info? fasl-library/rt-info? fasl-recompile-info?)
       (import (nanopass))
       (include "base-lang.ss")
       (include "expand-lang.ss")
       (define fasl-program-info? (fasl-record-predicate (record-type-descriptor program-info)))
-      (define fasl-library/rt-info? (fasl-record-predicate (record-type-descriptor library/rt-info))))
+      (define fasl-library/rt-info? (fasl-record-predicate (record-type-descriptor library/rt-info)))
+      (define fasl-recompile-info? (fasl-record-predicate (record-type-descriptor recompile-info))))
 
     (define keep-revisit-info
-      (lambda (x)
-        (define revisit-record?
-          (lambda (x)
-            (or (fasl-program-info? x) (fasl-library/rt-info? x))))
-        (define revisit-stuff?
       (lambda (x)
         (fasl-case x
-              [closure (offset c) #t]
+          [entry (situation fasl)
-              [revisit (fasl) #t]
+           (and (or (eqv? situation (constant fasl-type-revisit))
-              [record (maybe-uid size nflds rtd pad-ty* fld*) (revisit-record? x)]
+                    (eqv? situation (constant fasl-type-visit-revisit)))
-              [else #f])))
+                x)]
-        (fasl-case x
-          [entry (fasl)
-            (fasl-case fasl
-              [closure (offset c) x]
-              [revisit (fasl) x]
-              [record (maybe-uid size nflds rtd pad-ty* fld*) (and (revisit-record? fasl) x)]
-              [group (vfasl)
-               (let ([fasl* (filter revisit-stuff? (vector->list vfasl))])
-                 (and (not (null? fasl*))
-                      (fasl-entry
-                        (if (null? (cdr fasl*))
-                            (car fasl*)
-                            (fasl-vector (constant fasl-type-vector) (list->vector fasl*))))))]
-              [else #f])]
           [header (version machine dependencies) x]
           [else (sorry! "expected entry or header, got ~s" x)])))
 
@@ -821,7 +790,7 @@
                    (begin
                      (set-cdr! a entry2)
                      (cmp-case fasl-case entry1 entry2
-                       [entry (fasl) (fasl=? fasl1 fasl2)]
+                       [entry (situation fasl) (and (= situation1 situation2) (fasl=? fasl1 fasl2))]
                        [header (version machine dependencies)
                         (and (equal? version1 version2)
                              (equal? machine1 machine2)
@@ -907,10 +876,7 @@
                              (eqv? code-offset1 code-offset2)
                              (eqv? item-offset1 item-offset2)
                              (fasl=? fasl1 fasl2))]
-                       [indirect (g i) (sorry! "unexpected indirect")]
+                       [indirect (g i) (sorry! "unexpected indirect")])))))))
-                       [group (vfasl) (vandmap fasl=? vfasl1 vfasl2)]
-                       [visit (fasl) (fasl=? fasl1 fasl2)]
-                       [revisit (fasl) (fasl=? fasl1 fasl2)])))))))
 
     (set-who! $fasl-file-equal?
       (rec fasl-file-equal?

scheme.1.in

@@ -3,7 +3,7 @@
 .if t .ds c caf\o'\'e'
 .if n .ds c cafe
 .ds ]W 
-.TH SCHEME 1 "Chez Scheme Version 9.5.3 March 2019"
+.TH SCHEME 1 "Chez Scheme Version 9.5.3 September 2019"
 .SH NAME
 \fIChez Scheme\fP
 .br
@@ -72,9 +72,12 @@ Disables the expression editor.
 .B --eehistory off | \fIfile\fP
 Set expression-editor history file or disable restore and save of history.
 .TP
-.B ---enable-object-counts
+.B --enable-object-counts
 Have collector maintain object counts.
 .TP
+.B --retain-static-relocation
+Keep reloc information for compute-size, etc.
+.TP
 .B -b \fIfile\fP, --boot \fIfile\fP
 Load boot code from \fIfile\fP.
 .TP