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

Various enhancements and fixes highlighted by profiling performance

Browse Source 
and functionality improvements (including support for measuring
coverage), primitive argument-checking fixes, and object-file changes
resulting in reduced load times (and some backward incompatibility):
- 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 tests.  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-encrypted 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.ss

original commit: 88501743001393fa82e89c90da9185fc0086fbcb
This commit is contained in:
dybvig 2019-09-21 15:37:29 -07:00
parent ef89a1fa7b
commit 7d145e37a8
67 changed files with 5203 additions and 3086 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

355
LOG
View File

@ -1397,3 +1397,358 @@
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 tests. 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-encrypted 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

58
c/alloc.c
View File

@ -656,64 +656,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 */

2
c/compress-io.c
View File

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

8
c/externs.h
View File

@ -89,12 +89,6 @@ 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_code PROTO((ptr tc, iptr type, iptr n));
@ -103,7 +97,7 @@ extern ptr S_weak_cons PROTO((ptr car, ptr cdr));
/* 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, 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));

142
c/fasl.c
View File

@ -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>
* <fasl>
* <bootfile-name> -> <octet char>*
*
* <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>
*
@ -211,7 +214,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, unbufFaslFile uf));
static void fillFaslFile PROTO((faslFile f));
static void bytesin PROTO((octet *s, iptr n, faslFile f));
@ -286,7 +289,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;
@ -300,7 +303,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;
}
@ -325,7 +328,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
@ -377,6 +380,21 @@ static INT uf_read(unbufFaslFile uf, octet *s, iptr n) {
return 0;
}
static void uf_skipbytes(unbufFaslFile uf, iptr n) {
switch (uf->type) {
case UFFO_TYPE_GZ:
if (S_glzseek(uf->file, 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)
@ -418,55 +436,71 @@ 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;
struct faslFileObj ffo; octet buf[SBUFSIZ];
octet tybuf[1]; IFASLCODE ty; iptr size;
if (uf_read(uf, tybuf, 1) < 0) return Seof_object;
ty = tybuf[0];
for (;;) {
if (uf_read(uf, tybuf, 1) < 0) return Seof_object;
ty = tybuf[0];
while (ty == fasl_type_header) {
uptr n; ICHAR c;
while (ty == fasl_type_header) {
uptr n; ICHAR c;
/* check for remainder of magic number */
if (uf_bytein(uf) != 0 ||
uf_bytein(uf) != 0 ||
uf_bytein(uf) != 0 ||
uf_bytein(uf) != 'c' ||
uf_bytein(uf) != 'h' ||
uf_bytein(uf) != 'e' ||
uf_bytein(uf) != 'z')
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);
if ((n = uf_uptrin(uf)) != machine_type_any && n != machine_type)
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 (missing open paren) found in ~a", uf->path);
while ((c = uf_bytein(uf)) != ')')
if (c < 0) S_error1("", "malformed fasl-object header (missing close paren) found in ~a", uf->path);
/* check for remainder of magic number */
if (uf_bytein(uf) != 0 ||
uf_bytein(uf) != 0 ||
uf_bytein(uf) != 0 ||
uf_bytein(uf) != 'c' ||
uf_bytein(uf) != 'h' ||
uf_bytein(uf) != 'e' ||
uf_bytein(uf) != 'z')
S_error1("", "malformed fasl-object header found in ~a", uf->path);
ty = uf_bytein(uf);
}
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);
switch (ty) {
case fasl_type_visit:
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;
}
if ((n = uf_uptrin(uf)) != machine_type_any && n != machine_type)
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) != fasl_type_fasl_size)
S_error1("", "malformed fasl-object header (missing fasl-size) found in ~a", uf->path);
if (uf_bytein(uf) != '(')
S_error1("", "malformed fasl-object header found in ~a", uf->path);
size = uf_uptrin(uf);
while ((c = uf_bytein(uf)) != ')')
if (c < 0) S_error1("", "malformed fasl-object header found in ~a", uf->path);
if (ty == situation || situation == fasl_type_visit_revisit || ty == fasl_type_visit_revisit) {
struct faslFileObj ffo; octet buf[SBUFSIZ];
ty = uf_bytein(uf);
ffo.size = size;
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);
}
}
if (ty != fasl_type_fasl_size)
S_error1("", "malformed fasl-object header found in ~a", uf->path);
ffo.size = uf_uptrin(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;
}
static ptr bv_fasl_entry(ptr tc, ptr bv, unbufFaslFile uf) {
@ -479,7 +513,6 @@ static ptr bv_fasl_entry(ptr tc, ptr bv, unbufFaslFile uf) {
ffo.uf = uf;
faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
S_flush_instruction_cache(tc);
return x;
}
@ -640,7 +673,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;
@ -957,18 +989,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;
}
default:
S_error2("", "invalid object type ~d in fasl file ~a", FIX(ty), f->uf->path);
}

3
c/gc.c
View File

@ -1244,6 +1244,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)\

4
c/gcwrapper.c
View File

@ -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");
@ -801,6 +802,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;

1
c/globals.h
View File

@ -127,6 +127,7 @@ EXTERN struct S_G_struct {
uptr countof_size[countof_types];
ptr static_id;
ptr countof_names;
IGEN prcgeneration;
/* intern.c */
iptr *oblist_length_pointer;

25
c/prim5.c
View File

@ -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)
@ -1446,8 +1446,25 @@ static ptr s_profile_counters(void) {
return S_G.profile_counters;
}
static void s_set_profile_counters(ptr counters) {
S_G.profile_counters = counters;
/* s_profile_release_counters assumes and maintains the property that each pair's
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) {
@ -1670,7 +1687,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) ptr co; {

18
c/scheme.c
View File

@ -846,20 +846,8 @@ 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);
@ -912,12 +900,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);

4
configure vendored
View File

@ -48,10 +48,6 @@ disablecurses=no
: ${ARFLAGS:="rc"}
: ${RANLIB:="ranlib"}
: ${WINDRES:="windres"}
: ${AR:="ar"}
: ${ARFLAGS:="ruv"}
: ${RANLIB:="ranlib"}
: ${WINDRES:="windres"}
zlibInc=-I../zlib
LZ4Inc=-I../lz4/lib
zlibDep=../zlib/libz.a

64
csug/io.stex
View File

@ -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
the token, i.e., \var{end} characters from the starting position.
Specifying \var{sfd} and \var{bfp} improves the quality of error messages,
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"))

166
csug/syntax.stex
View File

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

168
csug/system.stex
View File

@ -996,6 +996,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 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 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 left at end-of-file but is not closed.
%----------------------------------------------------------------------------
@ -1128,6 +1167,7 @@ cp0-outer-unroll-limit
generate-inspector-information
generate-procedure-source-information
compile-profile
generate-covin-files
generate-interrupt-trap
enable-cross-library-optimization
\endschemedisplay
@ -1379,30 +1419,35 @@ as an object file for the resulting combination of libraries.
\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.
If present, \var{sfd} must be a source-file descriptor.
\var{output-port} and, if present and non-false, \var{wpo-port} must be binary output ports.
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
to \var{wpo-port} for use by \scheme{compile-whole-program}.
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}, 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
that the program that opens the ports and invokes \scheme{compile-port}
The ports are closed automatically after compilation under the assumption
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
to do compression, e.g., if it was opened with the \scheme{compressed}
Output will be compressed only if an output port is already set up to be
compressed, e.g., if it was opened with the \scheme{compressed}
file option.
%----------------------------------------------------------------------------
@ -1410,6 +1455,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
@ -1429,15 +1475,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
to \var{wpo-port} for use by \scheme{compile-whole-program}.
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}, 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
that the program that opens the port and invokes \scheme{compile-to-port}
The ports are not closed automatically after compilation under the assumption
the program that opens the port and invokes \scheme{compile-to-port}
will take care of closing the port.
The output will be compressed only if \var{binary-output-port} is set up
to do compression, e.g., if it was opened with the \scheme{compressed}
Output will be compressed only if an output port is already set up to be
compressed, e.g., if it was opened with the \scheme{compressed}
file option.
When \var{obj-list} contains a single list-structured element whose
@ -2774,12 +2822,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
arbitrary user-defined processing.
displayed in HTML format, or it can be packaged in a list or
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
@ -3045,6 +3098,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
@ -3124,6 +3200,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)}

22
makefiles/Makefile-workarea.in
View File

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

30
makefiles/Makefile.in
View File

@ -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:
(cd $(workarea) && $(MAKE) create-bintar)
.PHONY: bintar
bintar:
(cd $(workarea) && $(MAKE) bintar)
create-rpm:
(cd $(workarea) && $(MAKE) create-rpm)
.PHONY: rpm
rpm:
(cd $(workarea) && $(MAKE) rpm)
create-pkg:
(cd $(workarea) && $(MAKE) create-pkg)
.PHONY: 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

15
mats/4.ms
View File

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

18
mats/6.ms
View File

@ -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
@ -1614,25 +1619,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)]
[ip (#%$transcoded-source-port ip (native-transcoder))])
[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))))])
vals)
'(atomic eat 1 4))

37
mats/7.ms
View File

@ -117,7 +117,27 @@
(define-values (o get) (open-bytevector-output-port))
(compile-to-port '((define lcfp1 'worked) 'loaded) o)
(eq? 'loaded (load-compiled-from-port (open-bytevector-input-port (get)))))
(eq? 'worked lcfp1)
(begin
(define lcfp-bv
(let-values ([(o get) (open-bytevector-output-port)])
(compile-to-port
'((printf "revisit\n")
(define-syntax $lcfp-a (begin (printf "visit\n") (lambda (x) 0)))
(eval-when (visit revisit) (printf "visit-revisit\n"))
(eval-when (visit) 'visit-return)
'revisit-return)
o)
(get)))
#t)
(equal?
(with-output-to-string (lambda () (printf "result = ~s\n" (load-compiled-from-port (open-bytevector-input-port lcfp-bv)))))
"revisit\nvisit\nvisit-revisit\nresult = revisit-return\n")
(equal?
(with-output-to-string (lambda () (printf "result = ~s\n" (visit-compiled-from-port (open-bytevector-input-port lcfp-bv)))))
"visit\nvisit-revisit\nresult = visit-return\n")
(equal?
(with-output-to-string (lambda () (printf "result = ~s\n" (revisit-compiled-from-port (open-bytevector-input-port lcfp-bv)))))
"revisit\nvisit-revisit\nresult = revisit-return\n")
)
(mat compile-to-file
@ -1168,7 +1188,7 @@
(define b1 "23.5")
(define-syntax b2 (identifier-syntax (cons b1 b1))))
(define c (lambda (x) (import b) (vector b2 x)))))
op #f #f ',(machine-type) hostop))))))
op #f #f #f ',(machine-type) hostop))))))
"testfile-hop1")
(with-output-to-file "testfile-hop2.ss"
(lambda ()
@ -2710,14 +2730,14 @@ evaluating module init
"testfile-cwl-b5")
"()\n")
(error? ; attempting to re-install run-time part of library (testfile-cwl-a5)
(error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
(separate-eval
'(let ()
(import (testfile-cwl-c5))
(import (testfile-cwl-b5))
(list (fib+fact 10) (ack+fact 3 4)))))
(error? ; attempting to re-install run-time part of library (testfile-cwl-a5)
(error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
(separate-eval
'(eval '(list (fib+fact 10) (ack+fact 3 4))
(environment '(chezscheme) '(testfile-cwl-c5) '(testfile-cwl-b5)))))
@ -2738,7 +2758,7 @@ evaluating module init
(separate-compile 'cwl-d5)
#t)
(error? ; attempting to re-install run-time part of library (testfile-cwl-a5) with uid #{testfile-cwl-a5 ???}
(error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
(separate-eval '(load "testfile-cwl-d5.so")))
(begin
@ -2763,14 +2783,14 @@ evaluating module init
(delete-file "testfile-cwl-a5.so")
(delete-file "testfile-cwl-a5.wpo")
(error? ; attempting to re-install run-time part of library (testfile-cwl-a5) with uid #{testfile-cwl-a5 ???}
(error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
(separate-eval
'(let ()
(import (testfile-cwl-c5))
(import (testfile-cwl-b5))
(list (fib+fact 10) (ack+fact 3 4)))))
(error? ; attempting to re-install run-time part of library (testfile-cwl-a5) with uid #{testfile-cwl-a5 ???}
(error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
(separate-eval
'(let ()
(import (testfile-cwl-b5))
@ -4165,6 +4185,7 @@ evaluating module init
"import: found corresponding object file \"testfile-lm-a.so\"\n"
"import: object file is not older\n"
"import: loading object file \"testfile-lm-a.so\"\n"
"attempting to 'revisit' previously 'visited' \"testfile-lm-a.so\" for library (testfile-lm-a) run-time info\n"
"rt-a rhs\n"
"c = 456\n"))
(equal?
@ -4180,6 +4201,7 @@ evaluating module init
"import: found corresponding object file \"testfile-lm-c.so\"\n"
"import: object file is not older\n"
"import: loading object file \"testfile-lm-c.so\"\n"
"import: attempting to 'revisit' previously 'visited' \"testfile-lm-c.so\" for library (testfile-lm-c) run-time info\n"
"import: attempting to 'revisit' previously 'visited' \"testfile-lm-a.so\" for library (testfile-lm-a) run-time info\n"
"rt-a rhs\n"
"456\n"))
@ -4197,6 +4219,7 @@ evaluating module init
"import: object file is not older\n"
"import: loading object file \"testfile-lm-b.so\"\n"
"import: attempting to 'visit' previously 'revisited' \"testfile-lm-a.so\" for library (testfile-lm-a) compile-time info\n"
"import: attempting to 'revisit' previously 'visited' \"testfile-lm-b.so\" for library (testfile-lm-b) run-time info\n"
"\"odd\"\n"))
(equal?
(separate-eval

4
mats/8.ms
View File

@ -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
@ -10381,7 +10381,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: loading 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))
)

93
mats/Mf-base
View File

@ -106,10 +106,10 @@ cis = $(defaultcis)
defaultspi = f
spi = $(defaultspi)
# ehc defines the value to which $enable-check-heap is set:
# f for #f, t for #t
defaultehc = f
ehc = $(defaultehc)
# hci defines the value to which heap-check-interval (mat.ss) is set:
# 0 to disable, > 0 to enable
defaulthci = 0
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 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\
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\
prettysrc = 3.ms 5_3.ms 5_4.ms 5_5.ms bytevector.ms thread.ms profile.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=3 eval=interpret ehc=t rmg=2
$(MAKE) allxhelp o=0 eoc=f hci=101 cl=9
$(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=f cp0=t cl=9 p=t ehc=t
-$(MAKE) allxhelp spi=t cp0=f p=t eoc=f hci=101
-$(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=t cgr=2 ehc=t p=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 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)")'\
' (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))'\
'(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))))'\
> script.all$o
source:
@ -373,7 +404,7 @@ 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
io.mo ${objdir}/io.mo: prettytest.ss
unix.mo ${objdir}/unix.mo io.mo ${objdir}/io.mo 6.mo ${objdir}/6.mo: cat_flush
@ -381,15 +412,17 @@ 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

8
mats/cp0.ms
View File

@ -876,7 +876,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)
@ -884,7 +884,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 (#2%fx> y x)) x y)))
@ -2707,7 +2707,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)))
@ -2720,7 +2720,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)))

11
mats/hash.ms
View File

@ -3739,19 +3739,20 @@
(with-output-to-file "testfile.ss"
(lambda ()
(pretty-print
'(begin
(define-syntax $feh-ls
'(module ($feh-ls $feh-ht)
(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 (cdr $feh-ls) (cddr $feh-ls))
(eq-hashtable-set! ht (cddr $feh-ls) $feh-ls)
(eq-hashtable-set! ht ls (cdr ls))
(eq-hashtable-set! ht (cdr ls) (cddr ls))
(eq-hashtable-set! ht (cddr ls) ls)
(lambda (x) #`(quote #,(datum->syntax #'* ht)))))
a)))))
'replace)

222
mats/mat.ss
View File

@ -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: ")
(display-condition c *mat-output*)
(fprintf (mat-output) "Error reading mat input: ")
(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))]
[(path line char) (fprintf *mat-output* "~a at line ~a, char ~a of ~a~%" msg line char path)]))))
(fprintf *mat-output* "~a~%" msg))
(flush-output-port *mat-output*))))
[() (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)]))))
(fprintf (mat-output) "~a~%" msg))
(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,71 +229,105 @@
(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 () (close-output-port *mat-output*))))))))
(lambda ()
(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)]
[(name . clauses)
(fprintf *mat-output* "~%Starting mat ~s.~%" name)
(do ([clauses clauses (cdr clauses)]
[count 1 (+ count 1)])
((null? clauses) 'done)
(let ([clause (caar clauses)] [source (cadar clauses)])
(with-exception-handler
(lambda (c)
(if (warning? c)
(raise-continuable c)
(begin
(fprintf *mat-output* "Error printing mat clause: ")
(display-condition c *mat-output*)
(reset))))
(lambda ()
(pretty-print clause *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.~%")
(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*
"Expected ~s in mat ~s: \"~a\".~%"
expect name (ununicode (cdr ans)))]
[else
(mat-error source "Bug in mat ~s clause ~s" name count)]))))
(let ([ans (mat-one-exp #f (lambda () (eval clause)) #f)])
(case-lambda
[(name)
(fprintf (mat-output) "Warning: empty mat for ~s.~%" name)]
[(name . clauses)
(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)
(let ([clause (caar clauses)] [source (cadar clauses)])
(with-exception-handler
(lambda (c)
(if (warning? c)
(raise-continuable c)
(begin
(fprintf (mat-output) "Error printing mat clause: ")
(display-condition c (mat-output))
(reset))))
(lambda ()
(pretty-print clause (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.~%")
(let ([ans (mat-one-exp expect (lambda () (eval (cadr clause))) (eq? (car clause) 'sanitized-error?))])
(cond
[(pair? ans)
(mat-error source
"Error in mat ~s clause ~s: \"~a\""
name
count
(cdr ans))]
[(eq? ans 'false)
(mat-error source
"Bug in mat ~s clause ~s"
name
count)]
[(eq? ans 'true) (void)]
[else
(mat-error source
"Bug (nonboolean, nonstring return value) in mat ~s clause ~s"
name
count)])))))]))
[(and (pair? ans) (eq? (car ans) expect))
(fprintf (mat-output)
"Expected ~s in mat ~s: \"~a\".~%"
expect name (ununicode (cdr ans)))]
[else
(mat-error source "Bug in mat ~s clause ~s" name count)]))))
(let ([ans (mat-one-exp #f (lambda () (eval clause)) #f)])
(cond
[(pair? ans)
(mat-error source
"Error in mat ~s clause ~s: \"~a\""
name
count
(cdr ans))]
[(eq? ans 'false)
(mat-error source
"Bug in mat ~s clause ~s"
name
count)]
[(eq? ans 'true) (void)]
[else
(mat-error source
"Bug (nonboolean, nonstring return value) in mat ~s clause ~s"
name
count)])))))]))
);let
(define equivalent-expansion?
@ -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)
k
(or (fx< i 0)
(and (fx= (fxvector-ref x i) (fxvector-ref y i))
(f (fx1- i))))))]
[(box? x) (and (box? y) (e? (unbox x) (unbox y)))]
@ -376,7 +439,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 ()
@ -421,6 +484,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
@ -486,3 +550,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)))))

711
mats/misc.ms
View File

@ -1511,639 +1511,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
@ -2213,11 +1580,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)
@ -2227,65 +1595,50 @@
(compile-file x)))
'sff-1c)
#t)
(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?
(lambda (x)
(syntax-case x ()
[(_ q) (and (syntax->annotation #'q) #t)])))
'(list a (b so?) (x 3) y)
'(not (((inspect/object x) 'code) 'source))
'(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?
(separate-eval
'(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)))
(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
'(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)))
(go)
"(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
'(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)))
(go)
"(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
'(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)))
(go)
"(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))
@ -2301,8 +1654,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-1a.so did not define compile-time information for library (testfile-sff-1a)\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 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\
@ -5168,3 +4521,9 @@
(mutable-bytevector? '#vu8())
)
(mat show-allocation
(begin
(#%$show-allocation #t)
#t)
)

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

@ -1,7 +1,7 @@
*** errors-compile-0-f-f-f 2019-02-12 01:00:43.726170571 -0500
--- errors-compile-0-f-f-t 2019-02-12 01:14:58.071195602 -0500
*** errors-compile-0-f-f-f 2019-08-29 13:04:56.353541282 -0400
--- errors-compile-0-f-f-t 2019-08-29 13:13:37.159245573 -0400
***************
*** 3660,3666 ****
*** 3699,3705 ****
misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1".
misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"".
misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure".
@ -9,7 +9,7 @@
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 to #<procedure find-next>".
--- 3660,3666 ----
--- 3699,3705 ----
misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1".
misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"".
misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure".
@ -18,7 +18,7 @@
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 to #<procedure find-next>".
***************
*** 7159,7169 ****
*** 7182,7192 ****
7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1".
@ -30,7 +30,7 @@
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
--- 7159,7169 ----
--- 7182,7192 ----
7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1".
@ -43,7 +43,7 @@
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
***************
*** 8595,8607 ****
*** 8625,8637 ****
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".
@ -57,7 +57,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".
--- 8595,8607 ----
--- 8625,8637 ----
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".

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

@ -1,7 +1,7 @@
*** errors-compile-0-f-f-f 2019-03-20 19:56:48.000000000 -0600
--- errors-compile-0-f-t-f 2019-03-20 19:09:54.000000000 -0600
*** errors-compile-0-f-f-f 2019-09-03 15:44:15.000000000 -0700
--- errors-compile-0-f-t-f 2019-09-03 15:14:11.000000000 -0700
***************
*** 125,131 ****
*** 176,182 ****
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 ----
--- 176,182 ----
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 ****
*** 195,201 ****
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 ----
--- 195,201 ----
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 ****
*** 242,251 ****
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 ----
--- 242,251 ----
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".
***************
*** 3712,3718 ****
*** 3792,3798 ****
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".
--- 3712,3718 ----
--- 3792,3798 ----
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".
***************
*** 7182,7189 ****
*** 7243,7250 ****
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)".
--- 7182,7189 ----
--- 7243,7250 ----
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)".
***************
*** 7191,7205 ****
*** 7252,7266 ****
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".
--- 7191,7205 ----
--- 7252,7266 ----
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".
***************
*** 7212,7237 ****
*** 7273,7298 ****
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".
--- 7212,7237 ----
--- 7273,7298 ----
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".
***************
*** 7362,7400 ****
*** 7423,7461 ****
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".
--- 7362,7400 ----
--- 7423,7461 ----
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".
***************
*** 7409,7465 ****
*** 7470,7526 ****
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".
--- 7409,7465 ----
--- 7470,7526 ----
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".

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

File diff suppressed because it is too large Load Diff

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

@ -1,7 +1,7 @@
*** errors-compile-0-t-f-f 2019-02-12 01:30:17.595345564 -0500
--- errors-compile-0-t-f-t 2019-02-12 01:05:15.184684883 -0500
*** errors-compile-0-t-f-f 2019-08-29 13:23:28.054751053 -0400
--- errors-compile-0-t-f-t 2019-08-29 13:09:33.915590545 -0400
***************
*** 3660,3666 ****
*** 3699,3705 ****
misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1".
misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"".
misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure".
@ -9,7 +9,7 @@
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 to #<procedure find-next>".
--- 3660,3666 ----
--- 3699,3705 ----
misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1".
misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"".
misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure".
@ -18,7 +18,7 @@
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 to #<procedure find-next>".
***************
*** 7159,7169 ****
*** 7182,7192 ****
7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1".
@ -30,7 +30,7 @@
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
--- 7159,7169 ----
--- 7182,7192 ----
7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk".
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1".

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

@ -1,5 +1,5 @@
*** errors-compile-0-t-f-f 2019-02-12 01:30:17.595345564 -0500
--- errors-compile-0-t-t-f 2019-02-12 01:20:09.150192807 -0500
*** errors-compile-0-t-f-f 2019-08-29 13:23:28.054751053 -0400
--- errors-compile-0-t-t-f 2019-08-29 13:18:54.744598246 -0400
***************
*** 144,150 ****
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable b".
@ -18,7 +18,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".
***************
*** 3702,3708 ****
*** 3741,3747 ****
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".
@ -26,7 +26,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".
--- 3702,3708 ----
--- 3741,3747 ----
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".
@ -35,7 +35,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".
***************
*** 7169,7176 ****
*** 7192,7199 ****
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".
@ -44,7 +44,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)".
--- 7169,7176 ----
--- 7192,7199 ----
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".
@ -54,7 +54,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)".
***************
*** 7178,7192 ****
*** 7201,7215 ****
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".
@ -70,7 +70,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".
--- 7178,7192 ----
--- 7201,7215 ----
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".
@ -87,7 +87,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".
***************
*** 7199,7224 ****
*** 7222,7247 ****
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>".
@ -114,7 +114,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".
--- 7199,7224 ----
--- 7222,7247 ----
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>".
@ -142,7 +142,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".
***************
*** 7349,7387 ****
*** 7372,7410 ****
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>".
@ -182,7 +182,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".
--- 7349,7387 ----
--- 7372,7410 ----
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>".
@ -223,7 +223,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".
***************
*** 7407,7442 ****
*** 7430,7465 ****
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>".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point".
@ -260,7 +260,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record".
record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record".
record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed ex3".
--- 7407,7442 ----
--- 7430,7465 ----
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>".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point".

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

@ -1,7 +1,38 @@
*** errors-compile-0-f-f-f 2019-03-20 19:56:48.000000000 -0600
--- errors-interpret-0-f-f-f 2019-03-20 19:29:37.000000000 -0600
*** errors-compile-0-f-f-f 2019-09-03 15:44:15.000000000 -0700
--- errors-interpret-0-f-f-f 2019-09-03 15:28:53.000000000 -0700
***************
*** 1,7 ****
*** 1,3 ****
--- 1,9 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1010, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1012, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1019, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1021, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1028, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1030, char 4 of 6.ms
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
***************
*** 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
--- 24,31 ----
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
***************
*** 52,58 ****
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -9,13 +40,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: a is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
--- 1,13 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1005, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1007, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1014, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1016, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1023, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1025, char 4 of 6.ms
--- 58,64 ----
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -24,7 +49,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
***************
*** 28,98 ****
*** 79,149 ****
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 +121,7 @@
3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) (eq? x (...))))".
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
--- 34,104 ----
--- 85,155 ----
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 +194,7 @@
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
***************
*** 191,202 ****
*** 242,253 ****
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned zero values to single value return context".
@ -182,7 +207,7 @@
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
3.mo:Expected error in mat mrvs: "cdr: a is not a pair".
--- 197,208 ----
--- 248,259 ----
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 +221,7 @@
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
3.mo:Expected error in mat mrvs: "cdr: a is not a pair".
***************
*** 4086,4101 ****
*** 4131,4146 ****
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 +238,9 @@
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
--- 4092,4101 ----
--- 4137,4146 ----
***************
*** 7044,7050 ****
*** 7105,7111 ****
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 +248,7 @@
7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
--- 7044,7050 ----
--- 7105,7111 ----
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 +257,7 @@
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
***************
*** 7373,7379 ****
*** 7434,7440 ****
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 +265,7 @@
record.mo:Expected error in mat record25: "invalid value 12.0 for foreign type long-long".
record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
--- 7373,7379 ----
--- 7434,7440 ----
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 +274,7 @@
record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
***************
*** 8615,8627 ****
*** 8676,8688 ****
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".
@ -263,7 +288,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
--- 8615,8627 ----
--- 8676,8688 ----
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".
@ -278,7 +303,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
***************
*** 9382,9406 ****
*** 9443,9467 ****
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".
@ -304,7 +329,7 @@
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier booleen".
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
--- 9382,9406 ----
--- 9443,9467 ----
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".
@ -331,7 +356,7 @@
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
***************
*** 9413,9444 ****
*** 9474,9505 ****
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".
@ -364,7 +389,7 @@
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
--- 9413,9444 ----
--- 9474,9505 ----
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".
@ -398,7 +423,7 @@
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
***************
*** 9446,9471 ****
*** 9507,9532 ****
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>".
@ -425,7 +450,7 @@
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
--- 9446,9471 ----
--- 9507,9532 ----
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>".
@ -453,7 +478,7 @@
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
***************
*** 9476,9510 ****
*** 9537,9571 ****
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>".
@ -489,7 +514,7 @@
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
--- 9476,9510 ----
--- 9537,9571 ----
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>".
@ -526,7 +551,7 @@
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
***************
*** 10111,10120 ****
*** 10172,10181 ****
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 ...)))".
@ -537,7 +562,7 @@
oop.mo:Expected error in mat oop: "m1: not applicable to 17".
oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
--- 10111,10120 ----
--- 10172,10181 ----
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 ...)))".

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

@ -1,7 +1,38 @@
*** errors-compile-0-f-t-f 2019-03-20 19:09:54.000000000 -0600
--- errors-interpret-0-f-t-f 2019-03-20 19:40:13.000000000 -0600
*** errors-compile-0-f-t-f 2019-09-03 15:14:11.000000000 -0700
--- errors-interpret-0-f-t-f 2019-09-03 15:36:44.000000000 -0700
***************
*** 1,7 ****
*** 1,3 ****
--- 1,9 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1010, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1012, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1019, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1021, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1028, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1030, char 4 of 6.ms
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
***************
*** 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
--- 24,31 ----
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
***************
*** 52,58 ****
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -9,13 +40,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: a is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
--- 1,13 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1005, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1007, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1014, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1016, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1023, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1025, char 4 of 6.ms
--- 58,64 ----
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -24,7 +49,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
***************
*** 28,98 ****
*** 79,149 ****
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 +121,7 @@
3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) (eq? x (...))))".
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
--- 34,104 ----
--- 85,155 ----
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 +194,7 @@
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
***************
*** 4086,4101 ****
*** 4131,4146 ****
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 +211,9 @@
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
--- 4092,4101 ----
--- 4137,4146 ----
***************
*** 7044,7050 ****
*** 7105,7111 ****
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 +221,7 @@
7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
--- 7044,7050 ----
--- 7105,7111 ----
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 +230,7 @@
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
***************
*** 7182,7189 ****
*** 7243,7250 ****
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 +239,7 @@
record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
--- 7182,7189 ----
--- 7243,7250 ----
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 +249,7 @@
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
***************
*** 7191,7205 ****
*** 7252,7266 ****
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 +265,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid input #f".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
--- 7191,7205 ----
--- 7252,7266 ----
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 +282,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
***************
*** 7212,7237 ****
*** 7273,7298 ****
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 +309,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
--- 7212,7237 ----
--- 7273,7298 ----
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 +337,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
***************
*** 7362,7400 ****
*** 7423,7461 ****
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 +377,7 @@
record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
--- 7362,7400 ----
--- 7423,7461 ----
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 +418,7 @@
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
***************
*** 7409,7465 ****
*** 7470,7526 ****
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 +476,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
--- 7409,7465 ----
--- 7470,7526 ----
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 +535,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
***************
*** 8615,8627 ****
*** 8676,8688 ****
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 +549,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
--- 8615,8627 ----
--- 8676,8688 ----
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 +564,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
***************
*** 10111,10120 ****
*** 10172,10181 ****
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 +575,7 @@
oop.mo:Expected error in mat oop: "m1: not applicable to 17".
oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
--- 10111,10120 ----
--- 10172,10181 ----
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 ...)))".

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

@ -1,7 +1,38 @@
*** errors-compile-0-t-f-f 2019-02-12 01:30:17.595345564 -0500
--- errors-interpret-0-t-f-f 2019-02-12 03:03:25.069665634 -0500
*** errors-compile-0-t-f-f 2019-09-18 14:36:30.069343324 -0400
--- errors-interpret-0-t-f-f 2019-09-18 14:57:29.009466228 -0400
***************
*** 1,7 ****
*** 1,3 ****
--- 1,9 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1010, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1012, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1019, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1021, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1028, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1030, char 4 of 6.ms
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
***************
*** 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
--- 24,31 ----
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
***************
*** 52,58 ****
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -9,13 +40,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: a is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
--- 1,13 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1005, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1007, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1014, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1016, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1023, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1025, char 4 of 6.ms
--- 58,64 ----
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -24,7 +49,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
***************
*** 28,98 ****
*** 79,149 ****
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 +121,7 @@
3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) ((...) 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 ----
--- 85,155 ----
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 +194,7 @@
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
***************
*** 4076,4091 ****
*** 4131,4146 ****
6.mo:Expected error in mat pretty-print: "incorrect number of arguments to #<procedure pretty-format>".
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 +211,9 @@
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
--- 4082,4091 ----
--- 4137,4146 ----
***************
*** 7032,7038 ****
*** 7105,7111 ****
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 +221,7 @@
7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
--- 7032,7038 ----
--- 7105,7111 ----
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 +230,7 @@
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
***************
*** 7360,7366 ****
*** 7434,7440 ****
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".
@ -213,7 +238,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".
--- 7360,7366 ----
--- 7434,7440 ----
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".
@ -222,7 +247,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".
***************
*** 9362,9386 ****
*** 9443,9467 ****
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".
@ -248,7 +273,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".
--- 9362,9386 ----
--- 9443,9467 ----
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".
@ -275,7 +300,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".
***************
*** 9393,9424 ****
*** 9474,9505 ****
foreign.mo:Expected error in mat foreign-sizeof: "incorrect number of arguments to #<procedure foreign-sizeof>".
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".
@ -308,7 +333,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>".
--- 9393,9424 ----
--- 9474,9505 ----
foreign.mo:Expected error in mat foreign-sizeof: "incorrect number of arguments to #<procedure foreign-sizeof>".
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".
@ -342,7 +367,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>".
***************
*** 9426,9451 ****
*** 9507,9532 ****
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>".
@ -369,7 +394,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>".
--- 9426,9451 ----
--- 9507,9532 ----
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>".
@ -397,7 +422,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>".
***************
*** 9456,9490 ****
*** 9537,9571 ****
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>".
@ -433,7 +458,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>".
--- 9456,9490 ----
--- 9537,9571 ----
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>".
@ -470,7 +495,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>".
***************
*** 10091,10100 ****
*** 10172,10181 ****
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 ...)))".
@ -481,7 +506,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".
--- 10091,10100 ----
--- 10172,10181 ----
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 ...)))".

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

@ -1,7 +1,38 @@
*** errors-compile-0-t-t-f 2019-02-12 01:20:09.150192807 -0500
--- errors-interpret-0-t-t-f 2019-02-12 03:10:46.824077889 -0500
*** errors-compile-0-t-t-f 2019-09-18 14:32:22.453870860 -0400
--- errors-interpret-0-t-t-f 2019-09-18 15:03:50.499559489 -0400
***************
*** 1,7 ****
*** 1,3 ****
--- 1,9 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1010, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1012, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1019, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1021, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1028, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1030, char 4 of 6.ms
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
***************
*** 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
--- 24,31 ----
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
***************
*** 52,58 ****
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -9,13 +40,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: a is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
--- 1,13 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1005, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1007, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1014, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1016, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1023, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1025, char 4 of 6.ms
--- 58,64 ----
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -24,7 +49,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
***************
*** 28,98 ****
*** 79,149 ****
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 +121,7 @@
3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) ((...) 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 ----
--- 85,155 ----
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 +194,7 @@
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
***************
*** 4076,4091 ****
*** 4131,4146 ****
6.mo:Expected error in mat pretty-print: "incorrect number of arguments to #<procedure pretty-format>".
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 +211,9 @@
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
--- 4082,4091 ----
--- 4137,4146 ----
***************
*** 7032,7038 ****
*** 7105,7111 ****
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 +221,7 @@
7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
--- 7032,7038 ----
--- 7105,7111 ----
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 +230,7 @@
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
***************
*** 7169,7176 ****
*** 7243,7250 ****
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 +239,7 @@
record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
--- 7169,7176 ----
--- 7243,7250 ----
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 +249,7 @@
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
***************
*** 7178,7192 ****
*** 7252,7266 ****
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 +265,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid input #f".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
--- 7178,7192 ----
--- 7252,7266 ----
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 +282,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
***************
*** 7199,7224 ****
*** 7273,7298 ****
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 +309,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
--- 7199,7224 ----
--- 7273,7298 ----
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 +337,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
***************
*** 7349,7387 ****
*** 7423,7461 ****
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 +377,7 @@
record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
--- 7349,7387 ----
--- 7423,7461 ----
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 +418,7 @@
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
***************
*** 7407,7442 ****
*** 7481,7516 ****
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>".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point".
@ -430,7 +455,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record".
record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record".
record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed ex3".
--- 7407,7442 ----
--- 7481,7516 ----
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>".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point".
@ -468,7 +493,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record".
record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed ex3".
***************
*** 10091,10100 ****
*** 10172,10181 ****
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 ...)))".
@ -479,7 +504,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".
--- 10091,10100 ----
--- 10172,10181 ----
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 ...)))".

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

@ -1,17 +1,17 @@
*** errors-compile-3-f-f-f 2019-03-20 19:05:49.000000000 -0600
--- errors-interpret-3-f-f-f 2019-03-20 20:06:21.000000000 -0600
*** errors-compile-3-f-f-f 2019-09-03 15:10:42.000000000 -0700
--- errors-interpret-3-f-f-f 2019-09-03 15:48:13.000000000 -0700
***************
*** 1,3 ****
--- 1,9 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1005, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1007, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1014, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1016, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1023, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1025, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1010, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1012, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1019, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1021, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1028, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1030, 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".
profile.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".

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

@ -1,17 +1,17 @@
*** errors-compile-3-f-t-f 2019-03-20 19:14:06.000000000 -0600
--- errors-interpret-3-f-t-f 2019-03-20 19:45:10.000000000 -0600
*** errors-compile-3-f-t-f 2019-09-03 15:17:31.000000000 -0700
--- errors-interpret-3-f-t-f 2019-09-03 15:40:34.000000000 -0700
***************
*** 1,3 ****
--- 1,9 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1005, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1007, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1014, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1016, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1023, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1025, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1010, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1012, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1019, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1021, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1028, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1030, 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".
profile.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".

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

@ -1,17 +1,17 @@
*** errors-compile-3-t-f-f 2017-10-27 02:41:58.000000000 -0400
--- errors-interpret-3-t-f-f 2017-10-27 03:47:08.000000000 -0400
*** errors-compile-3-t-f-f 2019-08-29 14:17:18.177816308 -0400
--- errors-interpret-3-t-f-f 2019-08-29 14:38:33.501263784 -0400
***************
*** 1,3 ****
--- 1,9 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1005, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1007, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1014, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1016, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1023, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1025, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1010, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1012, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1019, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1021, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1028, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1030, 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".
profile.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".

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

@ -1,17 +1,17 @@
*** errors-compile-3-t-t-f 2017-10-27 02:36:19.000000000 -0400
--- errors-interpret-3-t-t-f 2017-10-27 03:52:31.000000000 -0400
*** errors-compile-3-t-t-f 2019-08-29 14:13:01.676337307 -0400
--- errors-interpret-3-t-t-f 2019-08-29 14:44:41.857727186 -0400
***************
*** 1,3 ****
--- 1,9 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1005, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1007, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1014, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1016, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1023, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1025, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1010, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1012, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1019, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1021, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1028, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1030, 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".
profile.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".

439
mats/primvars.ms
View File

@ -14,19 +14,66 @@
;;; limitations under the License.
(mat primvars
(let loop ([ls (oblist)] [bad '()])
(if (null? ls)
(or (null? bad)
(begin
(pretty-print bad)
(errorf #f "incorrect library-entry bindings for symbols ~s" bad)))
(let ([x (car ls)])
(if (let ([i (#%$sgetprop x '*library-entry* #f)])
(or (not i) (#%$lookup-library-entry i)))
(loop (cdr ls) bad)
(loop (cdr ls) (cons x 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 top-level bindings for symbols ~s" bad)))
(loop (cdr ls)
(let ([x (car ls)])
(if (gensym? x)
(let ([name (#%$symbol-name x)])
(if name
(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,137 +147,92 @@
(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 (okay-condition? prim 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))))))))
(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)))])
(unless (guard (c [else (okay-condition? c)])
(unless (guard (c [else (okay-condition? prim c)])
(eval `(begin ,call #f)))
(set! oops #t)
(printf "no argcount error for ~s\n" call))))
(for-each
(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))))))))
(printf "no argcount error for ~s\n" call)))
(let ([call `(,prim ,@(make-list n '(void)))])
(define (write-and-load x)
(with-output-to-file "testfile.ss"
(lambda () (pretty-print x))
'replace)
(load "testfile.ss"))
(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)])
(when a*
(let loop ([n 0] [a* a*])
(let ([mask (prim-arity prim)])
(when mask
(let ([pam (procedure-arity-mask (top-level-value prim (scheme-environment)))])
(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)]
[(= (- -1 (car a*)) n) (void)]
[(= (car a*) n) (loop (+ n 1) (cdr a*))]
[else (check prim n) (loop (+ n 1) a*)])))))
(oblist))
[(eqv? mask 0) (check prim n)]
[(eqv? mask -1) (void)]
[else
(unless (bitwise-bit-set? mask 0) (check prim n))
(loop (fx+ n 1) (ash mask -1))])))))
ls)
(not oops)))
)
@ -310,14 +316,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))
(let-values ([(binary-output-port getter) (open-bytevector-output-port)])
(def *annotation annotation)
(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 *eq-hashtable (make-eq-hashtable))
@ -333,6 +344,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))
@ -368,29 +380,31 @@
[(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)]
[(condition) (make-who-condition 'me) 'the-who]
[(compile-time-value) (make-compile-time-value 17) #f]
[(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]
[(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]
[(hashtable) *eq-hashtable '((a . b)) #f]
[(identifier) #'x x 17 #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]
[(identifier) #'x 'x 17 #f]
[(import-spec) '(chezscheme) 0 '(a . b) #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]
@ -398,24 +412,30 @@
[(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-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]
@ -435,21 +455,23 @@
[(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)]
[(sint) -1 'q]
[(sfd) *sfd '(q) #f]
[(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]
[(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-output-port) (current-output-port) 0 *binary-output-port (transcoded-port *binary-input-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 *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]
@ -466,7 +488,7 @@
[(uptr) 0 -1 'a (+ *max-uptr 1) #f]
[(uptr/iptr) -1 'q (+ *max-uptr 1) (- *min-iptr 1) #f]
[(vector) '#(a) "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*)
@ -475,6 +497,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)
@ -514,28 +543,106 @@
(unless (or (memq 'no-good rgood*) (memq 'no-good (cdr good*)))
(for-each
(lambda (bad)
(let ([call `(,name ,@(reverse rgood*) ,bad ,@(cdr good*))])
(printf "testing ~s..." call)
(flush-output-port)
(let ([c (call/cc
(lambda (k)
(with-exception-handler
(lambda (c) (unless (warning? c) (k c)))
(lambda () (eval call env) #f))))])
(if c
(if (and (violation? c)
(not (and (syntax-violation? c)
(message-condition? c)
(equal? (condition-message c) "invalid syntax")))
(not (and (irritants-condition? c)
; 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)
(newline))
(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)))))
(let ([bad (eval bad env)])
(let ([call `(,name ,@(reverse rgood*) ',bad ,@(cdr good*))])
(printf "testing ~s\n" call)
(flush-output-port)
(let ([c (call/cc
(lambda (k)
(with-exception-handler
(lambda (c) (unless (warning? c) (k c)))
(lambda () (eval call env) #f))))])
(if c
(if (and (violation? c)
(not (and (syntax-violation? c)
(message-condition? c)
(equal? (condition-message c) "invalid syntax")))
(not (and (irritants-condition? c)
; 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
; try to weed out common error messages
(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")))
(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))))))
(car bad**)))
(loop (cdr good*) (cdr bad**) (cons (car good*) rgood*)))))))
(map car in*/out**))))

935
mats/profile.ms Normal file
View File

@ -0,0 +1,935 @@
(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")
)
(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))
)

8
mats/record.ms
View File

@ -8331,7 +8331,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)
@ -8340,7 +8340,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))
@ -8782,7 +8782,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)
@ -8795,7 +8795,7 @@
r)))))
`(lambda (x) (#3%$record ',record-type-descriptor? 37 (#2%+ 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)

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

@ -1,3 +1,54 @@
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 (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-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 in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -14,7 +65,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 +381,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: "map: 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: "map: (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: "map: (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 . 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: "fold-right: (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".
@ -3634,6 +3685,41 @@ 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>".
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))".
@ -3668,10 +3754,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 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: r4rs is not 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: #t 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 a 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 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".
@ -3712,41 +3798,6 @@ 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".
@ -3759,7 +3810,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 3".
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".
@ -4048,8 +4099,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: parenthesized list terminated by bracket 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 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".
@ -4114,7 +4165,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".
@ -7080,11 +7131,11 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-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-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 run-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 run-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 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 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 compile-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"
@ -8399,9 +8450,9 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
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-ewl2.ss 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-ewl1.so did not define library (testfile-ewl1)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl2.so did not define library (testfile-ewl2)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl6.so did not define library (testfile-ewl6)".
8.mo:Expected error in mat library-directories: "library (testfile-ld1) not found".
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".
@ -8578,9 +8629,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<: <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<?: 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>?: "hi" is not a fixnum".
fx.mo:Expected error in mat fx>?: "fx>?: <int> is not a fixnum".

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

@ -1,3 +1,54 @@
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 (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-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 in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments to #<procedure>".
@ -14,7 +65,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 +381,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: "map: 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: "map: (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: "map: (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 . 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: "fold-right: (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".
@ -3634,6 +3685,41 @@ 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>".
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))".
@ -3668,10 +3754,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 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: r4rs is not 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: #t 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 a 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 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".
@ -3712,41 +3798,6 @@ 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".
@ -3759,7 +3810,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 3".
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".
@ -4048,8 +4099,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: parenthesized list terminated by bracket 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 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".
@ -4114,7 +4165,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".
@ -7080,11 +7131,11 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-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-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 run-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 run-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 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 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 compile-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"
@ -8399,9 +8450,9 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
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-ewl2.ss 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-ewl1.so did not define library (testfile-ewl1)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl2.so did not define library (testfile-ewl2)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl6.so did not define library (testfile-ewl6)".
8.mo:Expected error in mat library-directories: "library (testfile-ld1) not found".
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".
@ -8578,9 +8629,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<: <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<?: 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>?: "hi" is not a fixnum".
fx.mo:Expected error in mat fx>?: "fx>?: <int> is not a fixnum".

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

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

143
release_notes/release_notes.stex
View File

@ -2,7 +2,7 @@
\thisversion{Version 9.5.3}
\thatversion{Version 8.4}
\pubmonth{March}
\pubmonth{September}
\pubyear{2019}
\begin{document}
@ -58,6 +58,90 @@ Online versions of both books can be found at
%-----------------------------------------------------------------------------
\section{Functionality Changes}\label{section:functionality}
\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.
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.
@ -1695,6 +1779,20 @@ in fasl files does not generally make sense.
%-----------------------------------------------------------------------------
\section{Bug Fixes}\label{section:bugfixes}
\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
@ -2104,6 +2202,49 @@ x86\_64 has been fixed.
%-----------------------------------------------------------------------------
\section{Performance Enhancements}\label{section:performance}
\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}

82
s/4.ss
View File

@ -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))])
($apply p ($list-length r 'apply) r))])]
(let ([r (cons x ($apply list* ($list-length r who) 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))
($list-length ls 'map)
(unless (procedure? f) (nonprocedure-error who f))
($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 (fx= ($list-length ls1 'map) ($list-length ls2 'map))
(length-error 'map ls1 ls2))
(unless (procedure? f) (nonprocedure-error who f))
(unless (fx= ($list-length ls1 who) ($list-length ls2 who))
(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))
(length-check 'map ls more)
(unless (procedure? f) (nonprocedure-error who f))
(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))
(let ([n (length-check 'for-each ls more)])
(unless (procedure? f) (nonprocedure-error who f))
(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))
(let-values ([(cdrs cars) (getcxrs more 'for-each)])
(unless (pair? ls) (mutation-error who))
(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))
(length-check 'fold-left ls more)
(unless (procedure? combine) (nonprocedure-error who combine))
(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))
(let-values ([(cdrs cars) (getcxrs more 'fold-left)])
(unless (pair? cdrls) (mutation-error who))
(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))
($list-length ls 'fold-right)
(unless (procedure? combine) (nonprocedure-error who combine))
($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 (fx= ($list-length ls1 'map) ($list-length ls2 'map))
(length-error 'fold-right ls1 ls2))
(unless (procedure? combine) (nonprocedure-error who combine))
(unless (fx= ($list-length ls1 who) ($list-length ls2 who))
(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))
(length-check 'fold-right ls more)
(unless (procedure? combine) (nonprocedure-error who combine))
(length-check who ls more)
(let fold-right ([combine combine] [nil nil] [ls ls] [more more])
(if (null? ls)
nil
@ -391,10 +391,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?
@ -419,8 +419,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)))

22
s/5_2.ss
View File

@ -266,20 +266,26 @@
(if (null? xr) x1 (append x1 (f (car xr) (cdr xr)))))])))
(define-who append!
(rec append!
(let ()
(define (do-append! x1 x2)
(if (null? x1)
x2
(let f ([ls x1])
(if (null? (cdr ls))
(begin (set-cdr! ls x2) x1)
(f (cdr ls))))))
(case-lambda
[() '()]
[(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)))))]
(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)

157
s/7.ss
View File

@ -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 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) (fxsrl k 1))))
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,24 +153,53 @@
(and (not (eof-object? n)) ;(
(or (eqv? n (char->integer #\))) (f))))))
(malformed p)))
(lambda (p)
(define (go p situation)
(define (go1)
(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)])
(cond
[(eof-object? ty) ty]
[(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
[(eqv? ty (constant fasl-type-fasl-size))
(let ([n (get-uptr p)])
(if skip?
(begin
(if (and (port-has-port-position? p) (port-has-set-port-position!? p))
(set-port-position! p (+ (port-position p) n))
(get-bytevector-n p n))
(go1))
($bv-fasl-read (get-bytevector-n p n) (port-name p))))]
[else (malformed p)])))
(unless (and (input-port? p) (binary-port? p))
($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))
(port-name p))
(let fasl-entry ()
(let ([ty (get-u8 p)])
(cond
[(eof-object? ty) ty]
[(eqv? ty (constant fasl-type-header))
(check-header p)
(fasl-entry)]
[(eqv? ty (constant fasl-type-fasl-size))
($bv-fasl-read (get-bytevector-n p (get-uptr p)) (port-name p))]
[else (malformed 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)])
@ -184,54 +213,30 @@
(let ()
(define do-load-binary
(lambda (who fn ip situation for-import? results?)
(lambda (who fn ip situation for-import?)
(let ([load-binary (make-load-binary who fn situation for-import?)])
(let loop ([lookahead-x #f])
(let* ([x (or lookahead-x (fasl-read ip))]
[next-x (and results? (not (eof-object? x)) (fasl-read ip))])
(cond
[(eof-object? x) (close-port ip)]
[(and results? (eof-object? next-x)) (load-binary x)]
[else (load-binary x) (loop next-x)]))))))
(let ([x (fasl-read ip situation)])
(unless (eof-object? x)
(let loop ([x x])
(let ([next-x (fasl-read ip situation)])
(if (eof-object? next-x)
(load-binary x)
(begin (load-binary x) (loop next-x))))))))))
(define (make-load-binary who fn situation for-import?)
(module (Lexpand? visit-stuff? visit-stuff-inner revisit-stuff? revisit-stuff-inner
recompile-info? library/ct-info? library/rt-info? program-info?)
(module (Lexpand? 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)])
(unless (fx= n 0)
(let loop ([i 0])
(let ([x (vector-ref v i)] [i (fx+ i 1)])
(if (fx= i n)
(run-outer x) ; return value(s) of last form for load-compiled-from-port
(begin (run-outer x) (loop i)))))))))
(lambda (x)
(cond
[(vector? x) (run-vector x)]
[(Lexpand? x) ($interpret-backend x situation for-import? fn)]
[else (run-outer x)])))
[(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)]
[(recompile-info? x) (void)]
[(Lexpand? x) ($interpret-backend x situation for-import? fn)]
[else ($oops who "unexpected value ~s read from ~a" x fn)])))
(define (do-load who fn situation for-import? ksrc)
(let ([ip ($open-file-input-port who fn)])
@ -251,11 +256,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?)
(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))
@ -271,13 +281,26 @@
(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)))
(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)))
(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)))
(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)
@ -298,6 +321,7 @@
(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)
@ -335,6 +359,7 @@
(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)

25
s/Mf-base
View File

@ -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))'\
@ -566,7 +589,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

5
s/back.ss
View File

@ -119,6 +119,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)

22
s/cmacros.ss
View File

@ -445,15 +445,16 @@
(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-string 37)
(define-constant fasl-type-immutable-fxvector 38)
(define-constant fasl-type-immutable-bytevector 39)
(define-constant fasl-type-immutable-box 40)
(define-constant fasl-type-immutable-vector 37)
(define-constant fasl-type-immutable-string 38)
(define-constant fasl-type-immutable-fxvector 39)
(define-constant fasl-type-immutable-bytevector 40)
(define-constant fasl-type-immutable-box 41)
(define-constant fasl-fld-ptr 0)
(define-constant fasl-fld-u8 1)
@ -595,10 +596,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
@ -1492,8 +1489,9 @@
(with-syntax ([type (datum->syntax #'* (filter-scheme-type 'string-char))])
#''type)))
(define-constant annotation-debug 1)
(define-constant annotation-profile 2)
(define-constant annotation-debug #b0001)
(define-constant annotation-profile #b0010)
(define-constant annotation-all #b0011)
(eval-when (compile load eval)
(define flag->mask

1196
s/compile.ss
View File

File diff suppressed because it is too large Load Diff

3
s/cp0.ss
View File

@ -2522,7 +2522,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])

25
s/cprep.ss
View File

@ -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-include-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))]
[,pinfo `(program-info ,(program-info-invoke-req* pinfo))])
[(library/ct-info ,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))]
[(library/rt-info ,linfo/rt) `(library/rt-info ,(library-info-uid linfo/rt) ,(library/rt-info-invoke-req* linfo/rt))]
[(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
@ -292,4 +294,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!)))
)

126
s/date.ss
View File

@ -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)])
(check-nsec 'make-time nsec)
(check-ts-sec 'make-time sec)
(let ([typeno (ts-type->typeno who type)])
(check-nsec who nsec)
(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)
(ts-typeno-set! ts (ts-type->typeno 'set-time-type! type))))
(check-ts who ts)
(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-sec 'set-time-second! sec)
(check-ts who ts)
(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-nsec 'set-time-nanosecond! nsec)
(check-ts who ts)
(check-nsec who nsec)
(set-ts-nsec! ts nsec)))
(set! time=?
(set-who! time=?
(lambda (t1 t2)
(check-ts 'time=? t1)
(check-ts 'time=? t2)
(check-same-type 'time=? t1 t2)
(check-ts who t1)
(check-ts who 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 'time<? t2)
(check-same-type 'time<? t1 t2)
(check-ts who t1)
(check-ts who 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 'time<=? t2)
(check-same-type 'time<=? t1 t2)
(check-ts who t1)
(check-ts who 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 'time>=? t2)
(check-same-type 'time>=? t1 t2)
(check-ts who t1)
(check-ts who 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 'time>? t2)
(check-same-type 'time>? t1 t2)
(check-ts who t1)
(check-ts who 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-sec 'make-date sec)
(check-min 'make-date min)
(check-hour 'make-date hour)
(check-nsec who nsec)
(check-sec who sec)
(check-min who min)
(check-hour who hour)
; need more accurate check for day based on year and month
(check-day 'make-date day)
(check-mon 'make-date mon)
(check-year 'make-date year)
(check-day who day)
(check-mon who mon)
(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))]))

20
s/expand-lang.ss
View File

@ -38,13 +38,11 @@
(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 clo*))
(nongenerative #{library/ct-info fgf0koeh2zn6ajlujfyoyf-3})
(nongenerative #{library/ct-info fgf0koeh2zn6ajlujfyoyf-4})
(sealed #t))
(define-record-type library/rt-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)

42
s/fasl.ss
View File

@ -156,9 +156,12 @@
[(pair? x) (bld-graph x t a? bld-pair)]
[(vector? x) (bld-graph x t a? bld-vector)]
[(or (symbol? x) (string? x)) (bld-graph x t a? bld-simple)]
; this check must go before $record? check
[(and (annotation? x) (not a?))
(bld (annotation-stripped x) t a?)]
; this check must go before $record? check
[(eq-hashtable? x) (bld-graph x t a? bld-ht)]
; this check must go before $record? check
[(symbol-hashtable? x) (bld-graph x t a? bld-ht)]
[($record? x) (bld-graph x t a? bld-record)]
[(box? x) (bld-graph x t a? bld-box)]
@ -299,7 +302,7 @@
(wrf-bytevector-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))
@ -430,7 +433,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?)
@ -547,11 +561,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?))
(wrf (annotation-stripped x) p t a?)]
; this check must go before $record? check
; this check must go before $record? check
[(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)]
@ -571,7 +590,7 @@
[else ($oops 'fasl-write "invalid fasl object ~s" x)])))
(define start
(lambda (p t proc)
(lambda (p t situation proc)
(dump-graph)
(let-values ([(bv* size)
(let-values ([(p extractor) ($open-bytevector-list-output-port)])
@ -581,18 +600,19 @@
(put-uptr p n)))
(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*))))
(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)
(start p t (lambda (p) (wrf x p t #t))))))
(bld x t (constant annotation-all))
(start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf x p t (constant annotation-all)))))))
(define-who fasl-write
(lambda (x p)
@ -628,7 +648,7 @@
(emit-header p (constant machine-type-any))
(let ([t (make-table)])
(bld-graph x t #f really-bld-record)
(start p t (lambda (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))
)
@ -642,7 +662,7 @@
(set! $fasl-bld-graph (lambda (x t a? handler) ((target-fasl-bld-graph (fasl-target)) x t a? handler)))
(set! $fasl-enter (lambda (x t a?) ((target-fasl-enter (fasl-target)) x t a?)))
(set! $fasl-out (lambda (x p t a?) ((target-fasl-out (fasl-target)) x p t a?)))
(set! $fasl-start (lambda (p t proc) ((target-fasl-start (fasl-target)) 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)))

8
s/interpret.ss
View File

@ -673,16 +673,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)]
[,linfo/ct ($install-library/ct-desc linfo/ct for-import? ofn)]
[,pinfo ($install-program-desc pinfo)]
[(library/rt-info ,linfo/rt) ($install-library/rt-desc linfo/rt for-import? ofn)]
[(library/ct-info ,linfo/ct) ($install-library/ct-desc linfo/ct for-import? ofn)]
[(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))

29
s/io.ss
View File

@ -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 size to one less than real size so 'put' always has room
(set-binary-port-output-size! p (fx1- new-length)))))
(set-binary-port-output-buffer! p new-buffer))))
(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 size to one less than real size so 'put' always has room
(set-textual-port-output-size! p (fx1- new-length)))))
(set-textual-port-output-buffer! p new-buffer))))
(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?
(lambda (input-port)
(unless (and (input-port? input-port) (textual-port? input-port))
($oops who "~s is not a textual input port" input-port))
(let ()
(define ($char-ready? input-port who)
(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

2
s/library.ss
View File

@ -458,7 +458,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))

396
s/pdhtml.ss
View File

@ -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))
(set-who! profile-release-counters
(lambda ()
(set-counter-list!
(remp
(lambda (x) (bwp-object? (car x)))
(get-counter-list)))))
(define release-counters (foreign-procedure "(cs)s_profile_release_counters" () ptr))
(define rblock-count
(lambda (rblock)
(let sum ((op (rblock-op rblock)))
(if (profile-counter? op)
(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,33 +229,209 @@
(begin
(for-each clear-links (op+ op))
(for-each clear-links (op- op))))))
(for-each
(lambda (x)
(for-each (lambda (node) (clear-links (rblock-op node)))
(cdr x)))
(get-counter-list))))
(set-who! profile-dump
(let ([counter* (get-counter-list)])
(adjust-trackers! who '() counter*)
(for-each
(lambda (x)
(for-each
(lambda (node) (clear-links (rblock-op node)))
(cdr x)))
counter*))))
(set-who! profile-release-counters
(lambda ()
(define rblock-count
(lambda (rblock)
(let sum ((op (rblock-op rblock)))
; using #3%apply and #3%map in case the #2% versions are profiled,
; to avoid possible negative counts
(if (profile-counter? op)
(profile-counter-count op)
(- (#3%apply + (#3%map sum (op+ op)))
(#3%apply + (#3%map sum (op- op))))))))
(fold-left
(lambda (r x)
(fold-left
(lambda (r rblock)
(fold-left
; release-counters prunes out (and hands back) the released counters
(let* ([dropped-counter* (release-counters)]
[kept-counter* (get-counter-list)])
(adjust-trackers! who kept-counter* dropped-counter*))))
(set-who! profile-dump
; like profile-counts but returns ((src . count) ...), which requires more allocation
; profile-dump could use profile-counts but that would require even more allocation
(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)
(let ([count (rblock-count rblock)])
(lambda (r inst)
(cons (cons inst count) r)))
r (rblock-srecs rblock)))
r (cdr x)))
'() (get-counter-list)))))
(fold-left
(lambda (r src)
(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 ()

150
s/primdata.ss
View File

@ -216,21 +216,21 @@
(- [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
(/ [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
(abs [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(div-and-mod [sig [(number number) -> (number number)]] [flags discard])
(div [sig [(number number) -> (number)]] [flags arith-op mifoldable discard])
(mod [sig [(number number) -> (number)]] [flags arith-op mifoldable discard])
(div0-and-mod0 [sig [(number number) -> (number number)]] [flags discard])
(div0 [sig [(number number) -> (number)]] [flags arith-op mifoldable discard])
(mod0 [sig [(number number) -> (number)]] [flags arith-op mifoldable discard])
(gcd [sig [(number ...) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(lcm [sig [(number ...) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(div-and-mod [sig [(real real) -> (real real)]] [flags discard])
(div [sig [(real real) -> (real)]] [flags arith-op mifoldable discard])
(mod [sig [(real real) -> (real)]] [flags arith-op mifoldable discard])
(div0-and-mod0 [sig [(real real) -> (real real)]] [flags discard])
(div0 [sig [(real real) -> (real)]] [flags arith-op mifoldable discard])
(mod0 [sig [(real real) -> (real)]] [flags arith-op mifoldable discard])
(gcd [sig [(integer ...) -> (integer)]] [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 [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(ceiling [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(truncate [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(round [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(rationalize [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(floor [sig [(real) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
(ceiling [sig [(real) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
(truncate [sig [(real) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
(round [sig [(real) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
(rationalize [sig [(real real) -> (real)]] [flags arith-op mifoldable discard 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,15 +238,15 @@
(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 arith-op mifoldable discard])
(exact-integer-sqrt [sig [(exact-integer) -> (exact-integer exact-integer)]] [flags arith-op mifoldable discard])
(expt [sig [(number number) -> (number)]] [flags pure discard true cp02 ieee r5rs]) ; can take too long to fold
(make-rectangular [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(make-polar [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(real-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(imag-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(magnitude [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(make-rectangular [sig [(real real) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(make-polar [sig [(real real) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(real-part [sig [(number) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
(imag-part [sig [(number) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
(magnitude [sig [(number) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
(angle [sig [(number) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
((r6rs: number->string) [sig [(number) (number sub-ufixnum) (number sub-ufixnum sub-ufixnum) -> (string)]] [flags alloc ieee r5rs]) ; radix restricted to 2, 4, 8, 16
((r6rs: string->number) [sig [(string) (string sub-ufixnum) -> (maybe-number)]] [flags discard ieee r5rs]) ; radix restricted to 2, 4, 8, 16
@ -364,52 +364,52 @@
(bytevector-s8-set! [sig [(bytevector sub-index s8) -> (void)]] [flags true])
(bytevector->u8-list [sig [(bytevector) -> (list)]] [flags alloc])
(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-sint-ref [sig [(bytevector sub-index symbol sub-length) -> (sint)]] [flags true mifoldable discard])
(bytevector-uint-set! [sig [(bytevector sub-index sub-uint symbol sub-length) -> (void)]] [flags true])
(bytevector-sint-set! [sig [(bytevector sub-index sub-sint symbol sub-length) -> (void)]] [flags true])
(bytevector->uint-list [sig [(bytevector symbol sub-index) -> (list)]] [flags alloc])
(bytevector->sint-list [sig [(bytevector symbol sub-index) -> (list)]] [flags alloc])
(uint-list->bytevector [sig [(sub-list symbol sub-index) -> (bytevector)]] [flags alloc])
(sint-list->bytevector [sig [(sub-list symbol sub-index) -> (bytevector)]] [flags alloc])
(bytevector-u16-ref [sig [(bytevector sub-index symbol) -> (u16)]] [flags true mifoldable discard])
(bytevector-s16-ref [sig [(bytevector sub-index symbol) -> (s16)]] [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 endianness sub-length) -> (sint)]] [flags true mifoldable discard])
(bytevector-uint-set! [sig [(bytevector sub-index sub-uint endianness 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 endianness sub-index) -> (list)]] [flags alloc])
(bytevector->sint-list [sig [(bytevector endianness sub-index) -> (list)]] [flags alloc])
(uint-list->bytevector [sig [(sub-list endianness sub-index) -> (bytevector)]] [flags alloc])
(sint-list->bytevector [sig [(sub-list endianness sub-index) -> (bytevector)]] [flags alloc])
(bytevector-u16-ref [sig [(bytevector sub-index endianness) -> (u16)]] [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-s16-set! [sig [(bytevector sub-index s16 symbol) -> (void)]] [flags true])
(bytevector-u16-set! [sig [(bytevector sub-index u16 endianness) -> (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-s32-ref [sig [(bytevector sub-index symbol) -> (s32)]] [flags true mifoldable discard])
(bytevector-u32-ref [sig [(bytevector sub-index endianness) -> (u32)]] [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-s32-set! [sig [(bytevector sub-index s32 symbol) -> (void)]] [flags true])
(bytevector-u32-set! [sig [(bytevector sub-index u32 endianness) -> (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-s64-ref [sig [(bytevector sub-index symbol) -> (s64)]] [flags true mifoldable discard])
(bytevector-u64-ref [sig [(bytevector sub-index endianness) -> (u64)]] [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-s64-set! [sig [(bytevector sub-index s64 symbol) -> (void)]] [flags true])
(bytevector-u64-set! [sig [(bytevector sub-index u64 endianness) -> (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->utf32 [sig [(string) (string symbol) -> (bytevector)]] [flags alloc])
(string->utf16 [sig [(string) (string endianness) -> (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])
(utf32->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 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 ieee r5rs])
(inexact->exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard ieee r5rs])
(quotient [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(remainder [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(modulo [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 [(integer integer) -> (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])
@ -867,7 +867,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])
@ -888,7 +888,7 @@
(time-nanosecond [sig [(time) -> (uint)]] [flags mifoldable discard true])
(time-second [sig [(time) -> (fixnum)]] [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
@ -946,7 +946,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-cross-library-optimization [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
@ -957,6 +957,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])
@ -1209,13 +1210,13 @@
(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) -> (ptr)]] [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) -> (ptr)]] [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])
@ -1224,10 +1225,10 @@
(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])
(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])
@ -1281,7 +1282,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 true])
(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])
(file-access-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard])
(file-change-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard])
@ -1372,6 +1373,7 @@
(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) -> (ptr)]] [flags true])
(get-string-some! [sig [(textual-input-port string length length) -> (ptr)]] [flags true])
(getenv [sig [(string) -> (maybe-string)]] [flags discard])
@ -1411,7 +1413,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])
@ -1435,6 +1436,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])
@ -1451,8 +1453,8 @@
(make-parameter [sig [(ptr) (ptr procedure) -> (procedure)]] [flags true cp02 cp03])
(make-record-type [sig [(sub-ptr sub-list) (maybe-rtd sub-ptr sub-list) -> (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-object [sig [(sfd uint uint) (sfd uint uint uint uint) -> (source-object)]] [flags pure true mifoldable discard])
(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 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) -> (ptr)]] [flags true cp02 cp03])
(make-weak-eq-hashtable [sig [() (uint) -> (eq-hashtable)]] [flags alloc])
@ -1526,16 +1528,18 @@
(printf [sig [(string sub-ptr ...) -> (void)]] [flags true])
(procedure-arity-mask [sig [(procedure) -> (sint)]] [flags mifoldable discard true])
(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])
(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])
@ -1543,7 +1547,7 @@
(profile-query-weight [sig [(ptr) -> (maybe-flonum)]] [flags unrestricted 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])
(record-constructor [sig [(sub-ptr) -> (procedure)]] [flags cp02]) ; accepts rtd or rcd
@ -1568,6 +1572,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])
@ -1611,7 +1616,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) -> (ptr)]] [flags pure mifoldable discard true])
(source-file-descriptor-path [sig [(sfd) -> (ptr)]] [flags pure mifoldable discard true])
@ -1621,6 +1626,14 @@
(source-object-efp [sig [(source-object) -> (uint)]] [flags pure mifoldable discard])
(source-object-line [sig [(source-object) -> (ptr)]] [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])
@ -1709,6 +1722,7 @@
(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 [(who string sub-ptr ...) -> (ptr ...)]] [flags])
(warningf [sig [(who string sub-ptr ...) -> (ptr ...)]] [flags])
@ -1719,6 +1733,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 [(who pathname procedure) -> (ptr ...)]] [flags])
)
@ -2023,6 +2038,7 @@
($inexactnum? [flags])
($inexactnum-imag-part [flags])
($inexactnum-real-part [flags])
($insert-profile-src! [flags])
($install-ftype-guardian [flags])
($install-guardian [flags])
($install-library-clo-info [flags])

6
s/prims.ss
View File

@ -1693,9 +1693,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 $compile-profile (lambda (x) (memq x '(#f source block))) "valid compile-profile flag" #f)
(define-tc-parameter subset-mode (lambda (mode) (memq mode '(#f system))) "valid subset mode" #f)
(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))) "a valid compile-profile flag" #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)
)

37
s/read.ss
View File

@ -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
(let ([who 'read-token])
(set-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)
($port-flags-set? ip (constant port-flag-char-positions))
(port-position ip))])
(let ([fp (or fp
(and ($port-flags-set? ip (constant port-flag-char-positions))
(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)]
[(ip sfd)
(read-token ip #f #f)]
[(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)
($port-flags-set? ip (constant port-flag-char-positions))
(and ($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))

86
s/strip.ss
View File

@ -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)
(group vfasl)
(visit fasl)
(revisit fasl))
(indirect g i))
(define-datatype field
(ptr fasl)
@ -118,10 +115,15 @@
ty
(fasl-type-case ty
[(fasl-type-header) (read-header p)]
[(fasl-type-fasl-size)
(let ([size (read-uptr p)])
(fasl-entry (read-fasl p #f)))]
[else (bogus "expected header or entry in ~a" (port-name 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 situation (read-fasl p #f)))]
[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)]
[group (vfasl) ((build-vfasl! vfasl))]
[visit (fasl) (build! fasl t)]
[revisit (fasl) (build! fasl t)])))
[indirect (g i) (build! (vector-ref g i) 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))]
[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)])))
[indirect (g i) (write-fasl p t (vector-ref g i))])))
(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]
[revisit (fasl) #t]
[record (maybe-uid size nflds rtd pad-ty* fld*) (revisit-record? x)]
[else #f])))
(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])]
[entry (situation fasl)
(and (or (eqv? situation (constant fasl-type-revisit))
(eqv? situation (constant fasl-type-visit-revisit)))
x)]
[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")]
[group (vfasl) (vandmap fasl=? vfasl1 vfasl2)]
[visit (fasl) (fasl=? fasl1 fasl2)]
[revisit (fasl) (fasl=? fasl1 fasl2)])))))))
[indirect (g i) (sorry! "unexpected indirect")])))))))
(set-who! $fasl-file-equal?
(rec fasl-file-equal?

511
s/syntax.ss
View File

@ -817,9 +817,26 @@
(define build-recompile-info
(lambda (import-req* include-req*)
(make-recompile-info
(remp (lambda (x) (libdesc-system? (get-library-descriptor (libreq-uid x)))) import-req*)
include-req*)))
(with-output-language (Lexpand Outer)
`(recompile-info
,(make-recompile-info
(remp (lambda (x) (libdesc-system? (get-library-descriptor (libreq-uid x)))) import-req*)
include-req*)))))
(define build-library/ct-info
(lambda (linfo/ct)
(with-output-language (Lexpand Inner)
`(library/ct-info ,linfo/ct))))
(define build-library/rt-info
(lambda (linfo/rt)
(with-output-language (Lexpand Inner)
`(library/rt-info ,linfo/rt))))
(define build-program-info
(lambda (pinfo)
(with-output-language (Lexpand Inner)
`(program-info ,pinfo))))
(define build-top-library/rt
(lambda (uid dl* db* dv* de* init*)
@ -2351,7 +2368,6 @@
(define-record-type ctdesc
(fields
(immutable include-req*) ; libraries included when this library was compiled
(immutable import-req*) ; libraries imported when this library was imported
(immutable visit-visit-req*) ; libraries that must be visited (for meta definitions) when this library is visited
(immutable visit-req*) ; libraries that must be invoked (for regular definitions) when this library is visited
@ -2361,7 +2377,7 @@
(mutable export-id*) ; ids that need to be reset when visit-code raises an exception
(mutable import-code)
(mutable visit-code))
(nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-2})
(nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-3})
(sealed #t))
(define-record-type rtdesc
@ -2372,7 +2388,7 @@
(nongenerative #{rtdesc bthtzrrbhp7w9d02grnlh7-0})
(sealed #t))
(module (libdesc-import-req* libdesc-include-req* libdesc-visit-visit-req* libdesc-visit-req*
(module (libdesc-import-req* libdesc-visit-visit-req* libdesc-visit-req*
libdesc-loaded-import-reqs libdesc-loaded-import-reqs-set!
libdesc-loaded-visit-reqs libdesc-loaded-visit-reqs-set!
libdesc-import-code libdesc-import-code-set!
@ -2386,9 +2402,6 @@
(define libdesc-import-req*
(lambda (desc)
(ctdesc-import-req* (get-ctdesc desc))))
(define libdesc-include-req*
(lambda (desc)
(ctdesc-include-req* (get-ctdesc desc))))
(define libdesc-visit-visit-req*
(lambda (desc)
(ctdesc-visit-visit-req* (get-ctdesc desc))))
@ -2455,6 +2468,13 @@
(lambda (desc x)
(rtdesc-invoke-code-set! (get-rtdesc desc) x))))
(define-syntax with-message
(syntax-rules ()
[(_ msg e1 e2 ...)
(begin
(when (import-notify) (fprintf (console-output-port) "~a\n" msg))
e1 e2 ...)]))
(define visit-library
; library must already have been loaded, as well as those in its visit-req* list
(lambda (uid)
@ -2462,6 +2482,10 @@
[(get-library-descriptor uid) =>
(lambda (desc)
(cond
[(not (libdesc-ctdesc desc))
(with-message (format "attempting to 'visit' previously 'revisited' ~s for library ~s compile-time info" (libdesc-outfn desc) (libdesc-path desc))
($visit #f (libdesc-outfn desc)))
(visit-library uid)]
[(libdesc-visit-code desc) =>
(lambda (p)
(when (eq? p 'loading)
@ -2487,6 +2511,10 @@
[(get-library-descriptor uid) =>
(lambda (desc)
(cond
[(not (libdesc-rtdesc desc))
(with-message (format "attempting to 'revisit' previously 'visited' ~s for library ~s run-time info" (libdesc-outfn desc) (libdesc-path desc))
($revisit #f (libdesc-outfn desc)))
(invoke-library uid)]
[(libdesc-invoke-code desc) =>
(lambda (p)
(when (eq? p 'loading)
@ -2530,23 +2558,28 @@
(let ([req* '()])
(case-lambda
[(uid)
(cond
[(get-library-descriptor uid) =>
(lambda (desc)
(when invoke-now?
(cond
[(libdesc-invoke-code desc) =>
(lambda (p)
(when (eq? p 'pending)
($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc)))
(libdesc-invoke-code-set! desc 'pending)
(on-reset (libdesc-invoke-code-set! desc p)
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
(p))
(libdesc-invoke-code-set! desc #f))]))
(unless (memp (lambda (x) (eq? (libreq-uid x) uid)) req*)
(set! req* (cons (make-libreq (libdesc-path desc) (libdesc-version desc) uid) req*))))]
[else ($oops #f "library ~:s is not defined" uid)])]
(let retry ()
(cond
[(get-library-descriptor uid) =>
(lambda (desc)
(when invoke-now?
(cond
[(not (libdesc-rtdesc desc))
(with-message (format "attempting to 'revisit' previously 'visited' ~s for library ~s run-time info" (libdesc-outfn desc) (libdesc-path desc))
($revisit #f (libdesc-outfn desc)))
(retry)]
[(libdesc-invoke-code desc) =>
(lambda (p)
(when (eq? p 'pending)
($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc)))
(libdesc-invoke-code-set! desc 'pending)
(on-reset (libdesc-invoke-code-set! desc p)
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
(p))
(libdesc-invoke-code-set! desc #f))]))
(unless (memp (lambda (x) (eq? (libreq-uid x) uid)) req*)
(set! req* (cons (make-libreq (libdesc-path desc) (libdesc-version desc) uid) req*))))]
[else ($oops #f "library ~:s is not defined" uid)]))]
[() req*]))))
(define propagating-library-collector
@ -2642,7 +2675,7 @@
(install-library library-path library-uid
; import-code & visit-code is #f because vthunk invocation has already set up compile-time environment
(make-libdesc library-path library-version outfn #f
(make-ctdesc include-req* import-req* visit-visit-req* visit-req* '() #t #t '() #f #f)
(make-ctdesc import-req* visit-visit-req* visit-req* '() #t #t '() #f #f)
(make-rtdesc invoke-req* #t
(top-level-eval-hook
(build-lambda no-source '()
@ -2660,18 +2693,20 @@
,(rt-eval/residualize rtem
build-void
(lambda ()
(make-library/rt-info library-path library-version library-uid
invoke-req*)))
(build-library/rt-info
(make-library/rt-info library-path library-version library-uid
invoke-req*))))
,(ct-eval/residualize ctem
build-void
(lambda ()
(make-library/ct-info library-path library-version library-uid
include-req* import-req* visit-visit-req* visit-req*
(fold-left (lambda (clo* dl db)
(if dl
(cons (cons dl db) clo*)
clo*))
'() dl* db*))))
(build-library/ct-info
(make-library/ct-info library-path library-version library-uid
import-req* visit-visit-req* visit-req*
(fold-left (lambda (clo* dl db)
(if dl
(cons (cons dl db) clo*)
clo*))
'() dl* db*)))))
,(rt-eval/residualize rtem
build-void
(lambda ()
@ -2809,7 +2844,7 @@
(lambda ()
(build-primcall no-source 3 '$install-program-desc
(build-data no-source pinfo)))
(lambda () pinfo))
(lambda () (build-program-info pinfo)))
,(rt-eval/residualize rtem
(lambda ()
(build-top-program prog-uid
@ -4772,8 +4807,35 @@
[else (with-message (format "did not find corresponding object file ~s" obj-path) #f)]))))
(with-message (format "did not find source file ~s" src-path) (src-loop (cdr ext*))))))))))))))
(define load-recompile-info
(lambda (who fn)
(let ([fn (let ([host-fn (format "~a.~s" (path-root fn) (machine-type))])
(if (file-exists? host-fn) host-fn fn))])
(let ([ip ($open-file-input-port who fn)])
(on-reset (close-port ip)
(let ([fp (let ([start-pos (port-position ip)])
(if (and (eqv? (get-u8 ip) (char->integer #\#))
(eqv? (get-u8 ip) (char->integer #\!))
(let ([b (get-u8 ip)]) (or (eqv? b (char->integer #\space)) (eqv? b (char->integer #\/)))))
(let loop ([fp 3])
(let ([b (get-u8 ip)])
(if (eof-object? b)
fp
(let ([fp (+ fp 1)])
(if (eqv? b (char->integer #\newline))
fp
(loop fp))))))
(begin (set-port-position! ip start-pos) 0)))])
(port-file-compressed! ip)
(if ($compiled-file-header? ip)
(let ([x (fasl-read ip)])
(close-port ip)
(unless (recompile-info? x) ($oops who "expected recompile info at start of ~s, found ~a" fn x))
x)
($oops who "missing header for compiled file ~s" fn))))))))
(define load-library
(lambda (path version-ref needed-uid importer-path check-includes? ct? load-deps)
(lambda (path version-ref needed-uid importer-path ct? load-deps)
(define-syntax with-message
(syntax-rules ()
[(_ msg e1 e2 ...)
@ -4815,62 +4877,98 @@
(verify-uid found-uid src-path)
found-uid)]
[else ($oops #f "compiling ~a did not define library ~s" src-path path)])))
(define do-load/reload/recompile-library
(lambda (src-path obj-path compile-file?)
(let ([found-uid (guard (c [(and ($recompile-condition? c) (eq? ($recompile-importer-path c) path))
(with-message (format "re~:[loading~;compiling~] ~s because a dependency has changed" compile-file? src-path)
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))])
(if compile-file?
((compile-library-handler) src-path obj-path)
($load-library src-path load))))
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(load-deps found-uid)
found-uid)]
[else ($oops #f "re~:[loading~;compiling~] ~a did not define library ~s" compile-file? src-path path)])])
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))])
(guard (c [(and (irritants-condition? c) (member obj-path (condition-irritants c)))
(with-message (with-output-to-string
(lambda ()
(display-string "failed to load object file: ")
(display-condition c)))
($oops/c #f ($make-recompile-condition path)
"problem loading object file ~a ~s" obj-path c))])
($load-library obj-path (if ct? 'load 'revisit))))
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(load-deps found-uid)
(when check-includes?
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))])
(let ([obj-time (file-modification-time obj-path)])
(for-each
(lambda (include-req)
((guard (c [else (with-message (format "missing include file ~a" include-req)
($oops/c #f ($make-recompile-condition path)
"can't find include file ~a included by ~a when building ~a"
include-req src-path obj-path))])
; with-source-path tries to open include-req if it has to search for it ...
(with-source-path 'include include-req
(lambda (include-req)
; ... but not if it is an absolute path or begins with "./" or "..", so we
; call file-modification time before leaving the "missing include file"
; guard in case it doesn't actually exist.
(let ([t (file-modification-time include-req)])
(lambda ()
(when (time>? t obj-time)
(with-message (format "include file ~a is newer than ~a" include-req obj-path)
($oops/c #f ($make-recompile-condition path)
"include file ~a is newer than ~a"
include-req obj-path))))))))))
(libdesc-include-req* (get-library-descriptor found-uid))))))
found-uid)]
[else ($oops #f "loading ~a did not define library ~s" src-path path)]))])
(verify-uid found-uid src-path)
found-uid)))
(define do-recompile-or-load-library
(lambda (src-path obj-path)
(let ([compiled? #f])
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))]
[compile-library-handler
(let ([clh (compile-library-handler)])
(lambda (src-path obj-path)
(clh src-path obj-path)
(set! compiled? #t)))])
(maybe-compile-library src-path obj-path)
(unless compiled?
(with-message (format "no need to recompile, so loading ~s" obj-path)
($load-library obj-path (if ct? 'visit 'revisit)))))
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(load-deps found-uid)
(verify-uid found-uid src-path)
found-uid)]
[else
(if compiled?
($oops #f "compiling ~a did not define library ~s" src-path path)
($oops #f "loading ~a did not define library ~s" obj-path path))]))))
(define do-load-library-src-or-obj
(lambda (src-path obj-path)
(define (load-source)
(with-message "object file is out-of-date"
(with-message (format "loading source file ~s" src-path)
(do-load-library src-path 'load))))
(let ([obj-path-mod-time (file-modification-time obj-path)])
(if (time>=? obj-path-mod-time (file-modification-time src-path))
; NB: combine with $maybe-compile-file
(let ([rcinfo (guard (c [else (with-message (with-output-to-string
(lambda ()
(display-string "failed to process object file: ")
(display-condition c)))
#f)])
(load-recompile-info 'import obj-path))])
(if (and rcinfo
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))])
(andmap
(lambda (x)
((guard (c [else (with-message (with-output-to-string
(lambda ()
(display-string "failed to find include file: ")
(display-condition c)))
(lambda () #f))])
(with-source-path 'import x
(lambda (x)
(lambda ()
(and (file-exists? x)
(time<=? (file-modification-time x) obj-path-mod-time))))))))
(recompile-info-include-req* rcinfo))))
; NB: calling load-deps insures that we'll reload obj-path if one of
; the deps has to be reloaded, but it will miss other libraries that might have
; contributed to the generated code. For example, if the source file imports
; (a) and (b) but only (b) is one of the dependencies, we won't necessarily
; reload if a.ss is newer than a.so.
(with-message "object file is not older"
(with-message (format "loading object file ~s" obj-path)
(let ([found-uid (guard (c [(and ($recompile-condition? c) (eq? ($recompile-importer-path c) path))
(with-message (format "reloading ~s because a dependency has changed" src-path)
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))])
($load-library src-path 'load)))
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(load-deps found-uid)
found-uid)]
[else ($oops #f "reloading ~a did not define library ~s" src-path path)])])
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))])
(guard (c [(and (irritants-condition? c) (member obj-path (condition-irritants c)))
(with-message (with-output-to-string
(lambda ()
(display-string "failed to load object file: ")
(display-condition c)))
($oops/c #f ($make-recompile-condition path)
"problem loading object file ~a ~s" obj-path c))])
($load-library obj-path (if ct? 'visit 'revisit))))
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(load-deps found-uid)
found-uid)]
[else ($oops #f "loading ~a did not define library ~s" obj-path path)]))])
(verify-uid found-uid src-path)
found-uid)))
(load-source)))
(load-source)))))
($pass-time 'load-library
(lambda ()
(cond
@ -4899,17 +4997,9 @@
(with-message "source path and object path are the same"
(with-message (format "loading ~s" src-path)
(do-load-library src-path 'load)))
(if (time>=? (file-modification-time obj-path) (file-modification-time src-path))
(with-message "object file is not older"
(with-message (format "loading object file ~s" obj-path)
(do-load/reload/recompile-library src-path obj-path
(and (compile-imported-libraries) $compiler-is-loaded?))))
(with-message "object file is older"
(if (and (compile-imported-libraries) $compiler-is-loaded?)
(with-message (format "compiling ~s to ~s" src-path obj-path)
(do-compile-library src-path obj-path))
(with-message (format "loading source file ~s" src-path)
(do-load-library src-path 'load))))))
(if (and (compile-imported-libraries) $compiler-is-loaded?)
(do-recompile-or-load-library src-path obj-path)
(do-load-library-src-or-obj src-path obj-path)))
(if (and (compile-imported-libraries) $compiler-is-loaded?)
(with-message (format "compiling ~s to ~s" src-path obj-path)
(let f ([p obj-path])
@ -4922,7 +5012,7 @@
(do-load-library src-path 'load))))
(if obj-exists?
(with-message (format "loading object file ~s" obj-path)
(do-load-library obj-path (if ct? 'load 'revisit)))
(do-load-library obj-path (if ct? 'visit 'revisit)))
($oops #f "library ~s not found" path))))])))))
(define version-okay?
@ -5129,7 +5219,7 @@
(loader (libreq-path req) (libreq-version req) (libreq-uid req) path))))
(define load-invoke-library
(lambda (path version-ref uid importer-path)
(load-library path version-ref uid importer-path #f #f
(load-library path version-ref uid importer-path #f
(lambda (uid)
(let ([desc (get-library-descriptor uid)])
(unless (libdesc-rtdesc desc)
@ -5144,7 +5234,7 @@
[(pending) ($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc))]))))))
(define load-visit-library
(lambda (path version-ref uid importer-path)
(load-library path version-ref uid importer-path #f #t
(load-library path version-ref uid importer-path #t
(lambda (uid)
(let ([desc (get-library-descriptor uid)])
(unless (libdesc-ctdesc desc)
@ -5160,7 +5250,7 @@
[(pending) ($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc))]))))))
(define load-import-library
(lambda (path version-ref uid importer-path)
(load-library path version-ref uid importer-path #t #t
(load-library path version-ref uid importer-path #t
(lambda (uid)
(let ([desc (get-library-descriptor uid)])
(unless (libdesc-ctdesc desc)
@ -5208,123 +5298,72 @@
(import-library uid)
uid)))
(let ()
(define load-recompile-info
(lambda (who fn)
(let ([fn (let ([host-fn (format "~a.~s" (path-root fn) (machine-type))])
(if (file-exists? host-fn) host-fn fn))])
(let ([ip ($open-file-input-port who fn)])
(on-reset (close-port ip)
(let ([fp (let ([start-pos (port-position ip)])
(if (and (eqv? (get-u8 ip) (char->integer #\#))
(eqv? (get-u8 ip) (char->integer #\!))
(let ([b (get-u8 ip)]) (or (eqv? b (char->integer #\space)) (eqv? b (char->integer #\/)))))
(let loop ([fp 3])
(let ([b (get-u8 ip)])
(if (eof-object? b)
fp
(let ([fp (+ fp 1)])
(if (eqv? b (char->integer #\newline))
fp
(loop fp))))))
(begin (set-port-position! ip start-pos) 0)))])
(port-file-compressed! ip)
(if ($compiled-file-header? ip)
(let ()
(define unexpected-value!
(lambda (x)
($oops who "unexpected value ~s read from ~a" x fn)))
(let loop ([rcinfo* '()])
(let ([x (fasl-read ip)])
(define scan-outer
(lambda (x rcinfo*)
(cond
[(recompile-info? x) (cons x rcinfo*)]
[else rcinfo*])))
(cond
[(eof-object? x) (close-port ip) (reverse rcinfo*)]
[(vector? x)
(let ([n (vector-length x)])
(let vloop ([i 0] [rcinfo* rcinfo*])
(if (fx= i n)
(loop rcinfo*)
(vloop (fx+ i 1) (scan-outer (vector-ref x i) rcinfo*)))))]
[(Lexpand? x) (loop rcinfo*)]
[else (loop (scan-outer x rcinfo*))]))))
($oops who "missing header for compiled file ~s" fn))))))))
(set! $maybe-compile-file
(lambda (who ifn ofn handler)
(define with-new-who
(lambda (who th)
(with-exception-handler
(lambda (c)
(raise-continuable
(if (condition? c)
(apply condition (cons (make-who-condition who) (remp who-condition? (simple-conditions c))))
c)))
th)))
(define-syntax with-message
(syntax-rules ()
[(_ msg e1 e2 ...)
(begin
(when (import-notify) (fprintf (console-output-port) "~s: ~a\n" who msg))
e1 e2 ...)]))
(unless $compiler-is-loaded? ($oops '$maybe-compile-file "compiler is not loaded"))
(if (file-exists? ofn)
(let ([ofn-mod-time (file-modification-time ofn)])
(if (time>=? ofn-mod-time (with-new-who who (lambda () (file-modification-time ifn))))
(with-message "object file is not older"
(let ([rcinfo* (guard (c [else (with-message (with-output-to-string
(lambda ()
(display-string "failed to process object file: ")
(display-condition c)))
#f)])
(load-recompile-info who ofn))])
(if (and rcinfo*
(andmap
(lambda (rcinfo)
(andmap
(lambda (x)
((guard (c [else (with-message (with-output-to-string
(lambda ()
(display-string "failed to find include file: ")
(display-condition c)))
(lambda () #f))])
(with-source-path who x
(lambda (x)
(lambda ()
(and (file-exists? x)
(time<=? (file-modification-time x) ofn-mod-time))))))))
(recompile-info-include-req* rcinfo)))
rcinfo*))
(if (compile-imported-libraries)
(guard (c [(and ($recompile-condition? c) (eq? ($recompile-importer-path c) #f))
(with-message (format "recompiling ~s because a dependency has changed" ifn)
(handler ifn ofn))])
(for-each
(lambda (rcinfo)
(for-each (make-load-req load-import-library #f) (recompile-info-import-req* rcinfo)))
rcinfo*)
#f)
(if (andmap (lambda (rcinfo)
(andmap
(lambda (x)
(let ([path (libreq-path x)])
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path (libreq-version x) found-uid #f #f)
(eq? found-uid (libreq-uid x)))]
[else
(let-values ([(src-path obj-path obj-exists?) (library-search who path (library-directories) (library-extensions))])
(and obj-exists?
(time<=? (file-modification-time obj-path) ofn-mod-time)))])))
(recompile-info-import-req* rcinfo)))
rcinfo*)
#f
(handler ifn ofn)))
(handler ifn ofn))))
(handler ifn ofn)))
(handler ifn ofn)))))))
(set! $maybe-compile-file
(lambda (who ifn ofn handler)
(define with-new-who
(lambda (who th)
(with-exception-handler
(lambda (c)
(raise-continuable
(if (condition? c)
(apply condition (cons (make-who-condition who) (remp who-condition? (simple-conditions c))))
c)))
th)))
(define-syntax with-message
(syntax-rules ()
[(_ msg e1 e2 ...)
(begin
(when (import-notify) (fprintf (console-output-port) "~s: ~a\n" who msg))
e1 e2 ...)]))
(unless $compiler-is-loaded? ($oops '$maybe-compile-file "compiler is not loaded"))
(if (file-exists? ofn)
(let ([ofn-mod-time (file-modification-time ofn)])
(if (time>=? ofn-mod-time (with-new-who who (lambda () (file-modification-time ifn))))
(with-message "object file is not older"
(let ([rcinfo (guard (c [else (with-message (with-output-to-string
(lambda ()
(display-string "failed to process object file: ")
(display-condition c)))
#f)])
(load-recompile-info who ofn))])
(if (and rcinfo
(andmap
(lambda (x)
((guard (c [else (with-message (with-output-to-string
(lambda ()
(display-string "failed to find include file: ")
(display-condition c)))
(lambda () #f))])
(with-source-path who x
(lambda (x)
(lambda ()
(and (file-exists? x)
(time<=? (file-modification-time x) ofn-mod-time))))))))
(recompile-info-include-req* rcinfo)))
(if (compile-imported-libraries)
(guard (c [(and ($recompile-condition? c) (eq? ($recompile-importer-path c) #f))
(with-message (format "recompiling ~s because a dependency has changed" ifn)
(handler ifn ofn))])
(for-each (make-load-req load-import-library #f) (recompile-info-import-req* rcinfo))
#f)
(if (andmap
(lambda (x)
(let ([path (libreq-path x)])
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path (libreq-version x) found-uid #f #f)
(eq? found-uid (libreq-uid x)))]
[else
(let-values ([(src-path obj-path obj-exists?) (library-search who path (library-directories) (library-extensions))])
(and obj-exists?
(time<=? (file-modification-time obj-path) ofn-mod-time)))])))
(recompile-info-import-req* rcinfo))
#f
(handler ifn ofn)))
(handler ifn ofn))))
(handler ifn ofn)))
(handler ifn ofn)))))))
(set-who! $build-invoke-program
(lambda (uid body)
@ -5461,7 +5500,6 @@
($oops #f "attempting to re-install compile-time part of library ~s" (library-info-path linfo/ct))))
(install-library/ct-desc (library-info-path linfo/ct) (library-info-version linfo/ct) uid ofn
(make-ctdesc
(library/ct-info-include-req* linfo/ct)
(library/ct-info-import-req* linfo/ct)
(library/ct-info-visit-visit-req* linfo/ct)
(library/ct-info-visit-req* linfo/ct)
@ -5555,7 +5593,7 @@
(lambda (path uid)
(install-library path uid
(make-libdesc path (if (eq? (car path) 'rnrs) '(6) '()) #f #t
(make-ctdesc '() '() '() '() '() #t #t '() #f #f)
(make-ctdesc '() '() '() '() #t #t '() #f #f)
(make-rtdesc '() #t #f)))))
(set! $make-base-modules
(lambda ()
@ -6842,7 +6880,7 @@
(unless (environment? env)
($oops 'copy-environment "~s is not an environment" env))
(unless (and (list? syms) (andmap symbol? syms))
($oops 'copy-environment "~s is not an environment" env))
($oops 'copy-environment "~s is not a list of symbols" syms))
(copy-environment env mutable? syms)])))
(set! interaction-environment
@ -6868,10 +6906,17 @@
(initial-mode-set '(eval) #f)
(env-top-ribcage env)
#f)))))))
(let ([env ($make-environment (gensym) #t)])
(for-each (eval-import (datum->syntax #'* (cons 'environment import-spec*)) env) import-spec*)
(top-ribcage-mutable?-set! (env-top-ribcage env) #f)
env)))
(with-exception-handler
(lambda (c)
(raise-continuable
(if (who-condition? c)
c
(condition (make-who-condition 'environment) c))))
(lambda ()
(let ([env ($make-environment (gensym) #t)])
(for-each (eval-import (datum->syntax #'* (cons 'environment import-spec*)) env) import-spec*)
(top-ribcage-mutable?-set! (env-top-ribcage env) #f)
env)))))
(set-who! #(r6rs: eval)
(lambda (x env)

7
scheme.1.in
View File

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