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

Merge github.com:cisco/ChezScheme

Browse Source 
original commit: 8cf52012e2a7b5928cb2602bb17e0128ae0f2776
This commit is contained in:
Matthew Flatt 2020-02-22 10:11:30 -07:00
commit 995e53ca71
82 changed files with 9124 additions and 3659 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
BUILDING
View File

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

556
LOG
View File

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

2
c/Mf-a6nt
View File

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

2
c/Mf-i3nt
View File

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

2
c/Mf-ta6nt
View File

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

2
c/Mf-ti3nt
View File

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

61
c/alloc.c
View File

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

74
c/compress-io.c
View File

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

18
c/externs.h
View File

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

159
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>
*
@ -212,7 +215,7 @@ typedef struct faslFileObj {
static INT uf_read PROTO((unbufFaslFile uf, octet *s, iptr n));
static octet uf_bytein PROTO((unbufFaslFile uf));
static uptr uf_uptrin PROTO((unbufFaslFile uf));
static ptr fasl_entry PROTO((ptr tc, unbufFaslFile uf));
static ptr fasl_entry PROTO((ptr tc, IFASLCODE situation, unbufFaslFile uf));
static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, IFASLCODE ty, uptr offset, uptr len, unbufFaslFile uf));
static void fillFaslFile PROTO((faslFile f));
static void bytesin PROTO((octet *s, iptr n, faslFile f));
@ -288,7 +291,7 @@ void S_fasl_init() {
#endif
}
ptr S_fasl_read(ptr file, IBOOL gzflag, ptr path) {
ptr S_fasl_read(ptr file, IBOOL gzflag, IFASLCODE situation, ptr path) {
ptr tc = get_thread_context();
ptr x; struct unbufFaslFileObj uffo;
@ -302,7 +305,7 @@ ptr S_fasl_read(ptr file, IBOOL gzflag, ptr path) {
uffo.type = UFFO_TYPE_FD;
uffo.fd = GET_FD(file);
}
x = fasl_entry(tc, &uffo);
x = fasl_entry(tc, situation, &uffo);
tc_mutex_release()
return x;
}
@ -327,7 +330,7 @@ ptr S_boot_read(glzFile file, const char *path) {
uffo.path = Sstring_utf8(path, -1);
uffo.type = UFFO_TYPE_GZ;
uffo.file = file;
return fasl_entry(tc, &uffo);
return fasl_entry(tc, fasl_type_visit_revisit, &uffo);
}
#define GZ_IO_SIZE_T unsigned int
@ -379,11 +382,27 @@ static INT uf_read(unbufFaslFile uf, octet *s, iptr n) {
return 0;
}
int S_fasl_stream_read(void *stream, octet *dest, iptr n)
{
return uf_read((unbufFaslFile)stream, dest, n);
}
static void uf_skipbytes(unbufFaslFile uf, iptr n) {
switch (uf->type) {
case UFFO_TYPE_GZ:
if (S_glzseek(uf->file, (long)n, SEEK_CUR) == -1) {
S_error1("", "error seeking ~a", uf->path);
}
break;
case UFFO_TYPE_FD:
if (LSEEK(uf->fd, n, SEEK_CUR) == -1) {
S_error1("", "error seeking ~a", uf->path);
}
break;
}
}
static octet uf_bytein(unbufFaslFile uf) {
octet buf[1];
if (uf_read(uf, buf, 1) < 0)
@ -429,64 +448,81 @@ 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, fmt; 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 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 (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)) != 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 ((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 found in ~a", 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 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);
ty = uf_bytein(uf);
}
if ((ty != fasl_type_fasl_size)
&& (ty != fasl_type_vfasl_size))
S_error1("", "malformed fasl-object header found in ~a", uf->path);
ffo.size = uf_uptrin(uf);
if (ty == fasl_type_vfasl_size) {
if (S_vfasl_boot_mode == -1) {
S_vfasl_boot_mode = 1;
Scompact_heap();
ty = uf_bytein(uf);
}
x = S_vfasl((ptr)0, uf, 0, ffo.size);
} else {
ffo.buf = buf;
ffo.next = ffo.end = ffo.buf;
ffo.uf = uf;
faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
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;
}
fmt = uf_bytein(uf);
if ((fmt != fasl_type_fasl_size) && (fmt != fasl_type_vfasl_size))
S_error1("", "malformed fasl-object header (missing fasl-size) found in ~a", uf->path);
size = uf_uptrin(uf);
if (ty == situation || situation == fasl_type_visit_revisit || ty == fasl_type_visit_revisit) {
struct faslFileObj ffo; octet buf[SBUFSIZ];
ffo.size = size;
if (fmt == fasl_type_vfasl_size) {
if (S_vfasl_boot_mode == -1) {
S_vfasl_boot_mode = 1;
Scompact_heap();
}
x = S_vfasl((ptr)0, uf, 0, ffo.size);
} else {
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);
}
}
S_flush_instruction_cache(tc);
return x;
}
static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFaslFile uf) {
@ -674,7 +710,6 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
faslin(tc, &EXACTNUM_REAL_PART(*x), t, pstrbuf, f);
faslin(tc, &EXACTNUM_IMAG_PART(*x), t, pstrbuf, f);
return;
case fasl_type_group:
case fasl_type_vector:
case fasl_type_immutable_vector: {
iptr n; ptr *p;
@ -915,7 +950,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
IBOOL sign; iptr n; ptr t; bigit *p;
sign = bytein(f);
n = uptrin(f);
t = S_bignum(n, sign);
t = S_bignum(tc, n, sign);
p = &BIGIT(t, 0);
while (n--) *p++ = (bigit)uptrin(f);
*x = S_normalize_bignum(t);
@ -1003,18 +1038,6 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
case fasl_type_graph_ref:
*x = Svector_ref(t, uptrin(f));
return;
case fasl_type_visit: {
ptr p;
*x = p = Scons(FIX(visit_tag), FIX(0));
faslin(tc, &INITCDR(p), t, pstrbuf, f);
return;
}
case fasl_type_revisit: {
ptr p;
*x = p = Scons(FIX(revisit_tag), FIX(0));
faslin(tc, &INITCDR(p), t, pstrbuf, f);
return;
}
case fasl_type_begin: {
uptr n = uptrin(f) - 1; ptr v;
while (n--)

6
c/gc.c
View File

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

31
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");
@ -274,6 +275,33 @@ void Sunlock_object(x) ptr x; {
tc_mutex_release()
}
ptr s_help_unregister_guardian(ptr *pls, ptr tconc, ptr result) {
ptr rep, ls;
while ((ls = *pls) != Snil) {
if (GUARDIANTCONC(ls) == tconc) {
result = Scons(((rep = GUARDIANREP(ls)) == ftype_guardian_rep ? GUARDIANOBJ(ls) : rep), result);
*pls = ls = GUARDIANNEXT(ls);
} else {
ls = *(pls = &GUARDIANNEXT(ls));
}
}
return result;
}
ptr S_unregister_guardian(ptr tconc) {
ptr result, tc; IGEN g;
tc_mutex_acquire()
tc = get_thread_context();
/* in the interest of thread safety, gather entries only in the current thread, ignoring any others */
result = s_help_unregister_guardian(&GUARDIANENTRIES(tc), tconc, Snil);
/* plus, of course, any already known to the storage-management system */
for (g = 0; g <= static_generation; INCRGEN(g)) {
result = s_help_unregister_guardian(&S_G.guardians[g], tconc, result);
}
tc_mutex_release()
return result;
}
#ifndef WIN32
void S_register_child_process(INT child) {
tc_mutex_acquire()
@ -824,6 +852,9 @@ void S_do_gc(IGEN mcg, IGEN tg) {
}
}
/* tell profile_release_counters to scan only through new_g */
if (S_G.prcgeneration == old_g) S_G.prcgeneration = new_g;
/* finally reset max_nonstatic_generation */
S_G.min_free_gen = S_G.new_min_free_gen;
S_G.max_nonstatic_generation = new_g;

1
c/globals.h
View File

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

12
c/new-io.c
View File

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

340
c/number.c
View File

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

1
c/prim.c
View File

@ -190,6 +190,7 @@ void S_prim_init() {
Sforeign_symbol("(cs)enable_object_counts", (void *)S_enable_object_counts);
Sforeign_symbol("(cs)set_enable_object_counts", (void *)S_set_enable_object_counts);
Sforeign_symbol("(cs)object_counts", (void *)S_object_counts);
Sforeign_symbol("(cs)unregister_guardian", (void *)S_unregister_guardian);
Sforeign_symbol("(cs)fire_collector", (void *)S_fire_collector);
Sforeign_symbol("(cs)enable_object_backreferences", (void *)S_enable_object_backreferences);
Sforeign_symbol("(cs)set_enable_object_backreferences", (void *)S_set_enable_object_backreferences);

29
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)
@ -166,7 +166,7 @@ static iptr s_fxdiv(x, y) iptr x, y; {
static ptr s_trunc_rem(x, y) ptr x, y; {
ptr q, r;
S_trunc_rem(x, y, &q, &r);
S_trunc_rem(get_thread_context(), x, y, &q, &r);
return Scons(q, r);
}
@ -1467,8 +1467,25 @@ static ptr s_profile_counters(void) {
return S_G.profile_counters;
}
static void s_set_profile_counters(ptr counters) {
S_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) {
@ -1606,6 +1623,7 @@ void S_prim5_init() {
Sforeign_symbol("(cs)lognot", (void *)S_lognot);
Sforeign_symbol("(cs)fxmul", (void *)s_fxmul);
Sforeign_symbol("(cs)fxdiv", (void *)s_fxdiv);
Sforeign_symbol("(cs)s_big_negate", (void *)S_big_negate);
Sforeign_symbol("(cs)add", (void *)S_add);
Sforeign_symbol("(cs)gcd", (void *)S_gcd);
Sforeign_symbol("(cs)mul", (void *)S_mul);
@ -1641,6 +1659,7 @@ void S_prim5_init() {
#else
Sforeign_symbol("(cs)directory_list", (void *)S_directory_list);
#endif
Sforeign_symbol("(cs)dequeue_scheme_signals", (void *)S_dequeue_scheme_signals);
Sforeign_symbol("(cs)register_scheme_signal", (void *)S_register_scheme_signal);
Sforeign_symbol("(cs)exp", (void *)s_exp);
@ -1701,7 +1720,7 @@ void S_prim5_init() {
Sforeign_symbol("(cs)s_widechartomultibyte", (void *)s_widechartomultibyte);
#endif
Sforeign_symbol("(cs)s_profile_counters", (void *)s_profile_counters);
Sforeign_symbol("(cs)s_set_profile_counters", (void *)s_set_profile_counters);
Sforeign_symbol("(cs)s_profile_release_counters", (void *)s_profile_release_counters);
}
static ptr s_get_reloc(co, with_offsets) ptr co; IBOOL with_offsets; {

2
c/print.c
View File

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

25
c/scheme.c
View File

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

96
c/schsig.c
View File

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

2
c/thread.c
View File

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

3
c/vfasl.c
View File

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

66
csug/io.stex
View File

@ -1020,7 +1020,7 @@ be significantly smaller.
\noindent
\scheme{compress-level} determines the amount of effort spent on
compression and is thus relevant only for output.
It can be set to one of the symbols \scheme{low},
It can be set to one of the symbols \scheme{minimum}, \scheme{low},
\scheme{medium}, \scheme{high}, or \scheme{maximum}, which are
listed in order from shortest to longest expected compression time
and least to greatest expected effectiveness.
@ -1642,11 +1642,17 @@ the buffered input or a portion thereof is returned; otherwise
\entryheader
\formdef{read-token}{\categoryprocedure}{(read-token)}
\formdef{read-token}{\categoryprocedure}{(read-token \var{textual-input-port})}
\formdef{read-token}{\categoryprocedure}{(read-token \var{textual-input-port} \var{sfd} \var{bfp})}
\returns see below
\listlibraries
\endentryheader
\noindent
\var{sfd} must be a source-file descriptor.
\var{bfp} must be an exact nonnegative integer and should be the
character position of the next character to be read from
\var{textual-input-port}.
Parsing of a Scheme datum is conceptually performed in two steps.
First, the sequence of characters that form the datum are grouped into
\scheme{tokens}, such as symbols, numbers, left parentheses, and
@ -1671,13 +1677,18 @@ One token is read from the input port and returned as four values:
\item[\var{value}:] the token value,
\item[\var{start}:] the position of the first character of the token,
relative to the starting position of the input port, and
relative to the starting position of the input port (or \scheme{#f},
if the position cannot be determined), and
\item[\var{end}:] the first position beyond the token,
relative to the starting position of the input port.
relative to the starting position of the input port (or \scheme{#f},
if the position cannot be determined).
\end{description}
\noindent
The input port is left pointing to the first character position beyond
the token.
When the token type fully specifies the token,
\scheme{read-token} returns \scheme{#f} for the value.
The token types are listed below with the corresponding \var{value}
@ -1715,8 +1726,18 @@ in parentheses.
The set of token types is likely to change in future releases of the
system; check the release notes for details on such changes.
The input port is left pointing to the first character position beyond
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"))

59
csug/libraries.stex
View File

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

4
csug/objects.stex
View File

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

88
csug/smgmt.stex
View File

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

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

253
csug/system.stex
View File

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

9
csug/threads.stex
View File

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

5
csug/use.stex
View File

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

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

142
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?
@ -4194,8 +4205,53 @@
(let ([v (make-self #f)])
(self-v-set! v v)
(check-self-referencing v self-v)))
)
(parameterize ([collect-request-handler void])
(define (get-all g) (let ([q (g)]) (if q (cons q (get-all g)) '())))
(module (insist)
(define ($insist e? expr expected got)
(unless (e? got expected)
(errorf #f "expected ~s to return ~s, got ~s" expr expected got)))
(define-syntax insist
(syntax-rules ()
[(_ ?e? ?expr ?expected)
($insist ?e? '?expr ?expected ?expr)])))
(let ([g1 (make-guardian)] [g2 (make-guardian)])
(let ([x (box (cons 'a 'b))] [y (box (cons 'c 'd))])
(insist eq? (unregister-guardian g1) '())
(insist eq? (unregister-guardian g2) '())
(g1 (unbox x))
(g1 (unbox y))
(g2 (unbox x))
(g1 (unbox y))
(g1 (unbox x))
(collect 0 0)
(g2 (unbox x))
(g1 (cons 'e 'f))
(g2 (unbox x))
(g1 (unbox x))
(g2 (cons 'g 'h))
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(let ([q (unregister-guardian g2)])
(unless (and (= (length q) 4) (equal? (remove '(g . h) q) (list (unbox x) (unbox x) (unbox x))))
(errorf #f "expected (unregister-guardian g2) to contain x = (a . b), x = (a . b), and (g . h), got ~s" q)))
(insist eq? (unregister-guardian g2) '())
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(collect 0 0)
(insist equal? (get-all g1) '((e . f)))
(insist eq? (get-all g2) '())
(g2 (unbox x))
(set-box! x #f)
(collect 0 0)
(insist equal? (get-all g1) '((a . b) (a . b) (a . b)))
(insist equal? (get-all g2) '((a . b)))
(insist equal? (unregister-guardian g1) '((c . d) (c . d)))
(insist eq? (unregister-guardian g2) '())
(pretty-print (list g1 g2 x y)))) ; keep 'em live
#t)
)
(mat refcount-guardians
(error? ; unrecognized ftype
@ -4336,6 +4392,86 @@
(assert (not (regular-g)))
(assert (not (g)))
#t))
(parameterize ([collect-request-handler void])
(define-ftype A (struct (refcount iptr) (uid int)))
(define (get-all g)
(let ([a (g)])
(if a
(begin
(unless (eqv? (ftype-ref A (refcount) a) 0)
(errorf 'get-all "nonzero refcount ~s, uid ~s" (ftype-ref A (refcount) a) (ftype-ref A (uid) a)))
(cons a (get-all g)))
'())))
(module (insist)
(define ($insist e? expr expected got)
(unless (e? got expected)
(errorf #f "expected ~s to return ~s, got ~s" expr expected got)))
(define-syntax insist
(syntax-rules ()
[(_ ?e? ?expr ?expected)
($insist ?e? '?expr ?expected ?expr)])))
(define (get-uid a) (ftype-ref A (uid) a))
(define (fritter addr refcount uid)
(let ([a (make-ftype-pointer A addr)])
(ftype-set! A (refcount) a refcount)
(ftype-set! A (uid) a uid)
(box a)))
(let ([x-addr (foreign-alloc (ftype-sizeof A))] [y-addr (foreign-alloc (ftype-sizeof A))] [z-addr (foreign-alloc (ftype-sizeof A))])
(let ([x1 (fritter x-addr 6 73)] [x2 (box (make-ftype-pointer A x-addr))] [y (fritter y-addr 2 57)] [z (fritter z-addr 2 91)])
(let ([g1 (ftype-guardian A)] [g2 (ftype-guardian A)])
(insist eq? (unregister-guardian g1) '())
(insist eq? (unregister-guardian g2) '())
(g1 (unbox x1))
(g2 (unbox x1))
(g1 (unbox x1))
(g1 (unbox x2))
(g2 (unbox x1))
(g1 (unbox y))
(g1 (unbox y))
(g2 (unbox z))
(g1 (unbox z))
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(let ([q (unregister-guardian g2)])
(define (decr-refcount! a) (ftype-locked-decr! A (refcount) a))
(unless (and (= (length q) 3) (memq (unbox x1) (memq (unbox x1) q)) (memq (unbox z) q))
(errorf #f "expected (unregister-guardian g2) to contain x/uid 73, x/uid 73, and z/uid 91, got ~s" (map get-uid q)))
(map decr-refcount! q))
(insist eq? (unregister-guardian g2) '())
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(pretty-print z) ; keep it live
(set-box! z #f)
(collect 0 0)
(insist equal? (map get-uid (get-all g1)) '(91))
(insist eq? (get-all g2) '())
(g2 (unbox x1))
(pretty-print x1) ; keep it live
(set-box! x1 #f)
(collect 0 0)
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(insist eq? (unregister-guardian g2) '())
(insist eqv? (ftype-ref A (refcount) (unbox x2)) 1)
(pretty-print x2) ; keep it live
(set-box! x2 #f)
(collect 0 0)
(insist equal? (map get-uid (get-all g1)) '(73))
(insist equal? (map get-uid (get-all g2)) '())
(insist eq? (unregister-guardian g2) '())
(pretty-print y) ; keep it live
(set-box! y #f)
(collect 0 0)
(insist equal? (map get-uid (get-all g1)) '(57))
(insist equal? (map get-uid (get-all g2)) '())
(insist eq? (unregister-guardian g1) '())
(insist eq? (unregister-guardian g2) '())
(pretty-print (list g1 g2 x y)))) ; keep 'em live
(foreign-free x-addr)
(foreign-free y-addr)
(foreign-free z-addr))
#t)
)
(mat weak-cons

664
mats/5_3.ms
View File

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

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
@ -1654,25 +1659,24 @@
#t)
(error?
(let* ([ip (open-file-input-port "testfile.ss")]
[sfd (#%$source-file-descriptor "testfile.ss" ip)]
[sfd (make-source-file-descriptor "testfile.ss" ip #t)]
[ip (transcoded-port ip (native-transcoder))])
(dynamic-wind
void
(lambda () (read-token ip sfd))
(lambda () (read-token ip sfd 0))
(lambda () (close-input-port ip)))))
(let ()
(with-output-to-file "testfile.ss"
(lambda () (display "\neat\n"))
'replace)
#t)
; $transcoded-source-port is no more
#;(equal?
(equal?
(let-values ([vals (let* ([ip (open-file-input-port "testfile.ss")]
[sfd (#%$source-file-descriptor "testfile.ss" ip)]
[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))

1012
mats/7.ms
View File

File diff suppressed because it is too large Load Diff

199
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
@ -8747,6 +8747,105 @@
"revisiting testfile-l6-prog1\n#((10 . 12))\n")
)
(mat library7
(begin
(mkfile "testfile-l7-a1.ss"
'(library (testfile-l7-a1) (export a-macro a) (import (chezscheme)) (define-syntax a-macro (identifier-syntax 'aaa)) (define (a x) (+ x (* x x)))))
(mkfile "testfile-l7-b1.ss"
'(library (testfile-l7-b1) (export b) (import (chezscheme) (testfile-l7-a1)) (define (b x) (cons 'b a-macro))))
(mkfile "testfile-l7-c1.ss"
'(library (testfile-l7-c1) (export c) (import (chezscheme) (testfile-l7-a1)) (define (c x) (cons 'c (a x)))))
(mkfile "testfile-l7-d1.ss"
'(library (testfile-l7-d1) (export d) (import (chezscheme) (testfile-l7-a1)) (define (d x) (list 'd a-macro (a x)))))
(separate-compile
'(lambda (x) (for-each compile-library x))
'(list "testfile-l7-a1" "testfile-l7-b1" "testfile-l7-c1" "testfile-l7-d1"))
#t)
(equal?
(separate-eval
'(let () (import (testfile-l7-b1)) (b 7))
'(let () (import (testfile-l7-c1)) (c 7))
'(let () (import (testfile-l7-d1)) (d 7)))
"(b . aaa)\n(c . 56)\n(d aaa 56)\n")
(begin
(separate-compile
'(lambda (x) (for-each compile-library x))
'(list "testfile-l7-a1" "testfile-l7-b1" "testfile-l7-c1"))
#t)
(equal?
(separate-eval
'(let () (import (testfile-l7-b1)) (b 7))
'(let () (import (testfile-l7-c1)) (c 7))
; this should reload from source, since dependency is out-of-date
'(let () (import (testfile-l7-d1)) (d 7)))
"(b . aaa)\n(c . 56)\n(d aaa 56)\n")
(equal?
(separate-eval
; this should reload from source, since dependency is out-of-date
'(let () (import (testfile-l7-d1)) (d 7))
'(let () (import (testfile-l7-c1)) (c 7))
'(let () (import (testfile-l7-b1)) (b 7)))
"(d aaa 56)\n(c . 56)\n(b . aaa)\n")
(error? ; expected different compilation instance
(separate-eval
'(let () (import (testfile-l7-b1)) (b 7))
'(let () (import (testfile-l7-c1)) (c 7))
'(load-library "testfile-l7-d1.so")
'(let () (import (testfile-l7-d1)) (d 7))))
(error? ; expected different compilation instance
(separate-eval
'(load-library "testfile-l7-d1.so")
'(let () (import (testfile-l7-d1)) (d 7))))
(equal?
(separate-eval
'(load-library "testfile-l7-b1.ss")
'(let () (import (testfile-l7-b1)) (b 7))
; this should reload from source, since dependency is out-of-date
'(let () (import (testfile-l7-c1)) (c 7))
; this should reload from source, since dependency is out-of-date
'(let () (import (testfile-l7-d1)) (d 7)))
"(b . aaa)\n(c . 56)\n(d aaa 56)\n")
(error? ; expected different compilation instance
(separate-eval
'(load-library "testfile-l7-b1.ss")
'(load-library "testfile-l7-c1.ss")
'(load-library "testfile-l7-d1.so")
'(let () (import (testfile-l7-d1)) (d 7))))
(begin
(delete-file "testfile-l7-a1.so")
#t)
(equal?
(separate-eval
'(parameterize ([compile-imported-libraries #t]) (compile-library "testfile-l7-b1.ss"))
'(let () (import (testfile-l7-b1)) (b 7))
; this should reload from source, since dependency is out-of-date
'(let () (import (testfile-l7-c1)) (c 7))
'(let () (import (testfile-l7-d1)) (d 7)))
"compiling testfile-l7-b1.ss with output to testfile-l7-b1.so\ncompiling testfile-l7-a1.ss with output to testfile-l7-a1.so\n(b . aaa)\n(c . 56)\n(d aaa 56)\n")
(begin
(delete-file "testfile-l7-a1.so")
#t)
(error? ; expected different compilation instance
(separate-eval
'(parameterize ([compile-imported-libraries #t]) (compile-library "testfile-l7-b1.ss"))
'(load-library "testfile-l7-c1.so")
'(let () (import (testfile-l7-c1)) (c 7))))
(equal?
(separate-eval
'(library (testfile-l7-a1) (export a-macro a) (import (chezscheme)) (define-syntax a-macro (identifier-syntax 'aaa2)) (define (a x) (* x 11)))
'(let () (import (testfile-l7-b1)) (b 7))
'(let () (import (testfile-l7-c1)) (c 7))
'(let () (import (testfile-l7-d1)) (d 7)))
"(b . aaa2)\n(c . 77)\n(d aaa2 77)\n")
(error? ; expected different compilation instance
(separate-eval
'(library (testfile-l7-a1) (export a-macro a) (import (chezscheme)) (define-syntax a-macro (identifier-syntax 'aaa2)) (define (a x) (* x 11)))
'(let () (import (testfile-l7-b1)) (b 7))
'(let () (import (testfile-l7-c1)) (c 7))
'(load-library "testfile-l7-d1.so")
'(let () (import (testfile-l7-d1)) (d 7))))
)
(mat library-regression
; test that failing invoke code does not result in cyclic dependency problem on re-run
(equal?
@ -9033,8 +9132,82 @@
(string-append
"123\n"
"123\n"
"Exception in visit: library (testfile-lr-l4) is not visible\n"
"Exception in visit: library (testfile-lr-l4) is not visible\n"))))
"Exception in environment: attempt to import invisible library (testfile-lr-l4)\n"
"Exception in environment: attempt to import invisible library (testfile-lr-l4)\n"))))
(mat invoke-library
(error? ; invalid library reference
(invoke-library '(testfile-il1 (<= 3))))
(error? ; invalid library reference
(invoke-library '(testfile-il1 (what?))))
(error? ; invalid library reference
(invoke-library '()))
(error? ; invalid library reference
(invoke-library 'hello))
(error? ; invalid library reference
(invoke-library '(3 2 1)))
(begin
(mkfile "testfile-il1.ss"
'(library (testfile-il1 (2)) (export a) (import (chezscheme)) (define a 3) (printf "invoked (testfile-il1)\n")))
#t)
(equal?
(separate-eval
'(let () (import (testfile-il1)) a))
"invoked (testfile-il1)\n3\n")
(equal?
(separate-eval
'(invoke-library '(testfile-il1)))
"invoked (testfile-il1)\n")
(equal?
(separate-eval
'(invoke-library '(testfile-il1))
'(printf "hello\n")
'(let () (import (testfile-il1)) a))
"invoked (testfile-il1)\nhello\n3\n")
(equal?
(separate-eval
'(let () (import (testfile-il1)) a)
'(printf "hello\n")
'(invoke-library '(testfile-il1)))
"invoked (testfile-il1)\n3\nhello\n")
(begin
(separate-eval '(compile-library "testfile-il1"))
#t)
(delete-file "testfile-il1.ss")
(equal?
(separate-eval
'(let () (import (testfile-il1)) a))
"invoked (testfile-il1)\n3\n")
(equal?
(separate-eval
'(invoke-library '(testfile-il1)))
"invoked (testfile-il1)\n")
(equal?
(separate-eval
'(invoke-library '(testfile-il1))
'(printf "hello\n")
'(let () (import (testfile-il1)) a))
"invoked (testfile-il1)\nhello\n3\n")
(equal?
(separate-eval
'(let () (import (testfile-il1)) a)
'(printf "hello\n")
'(invoke-library '(testfile-il1)))
"invoked (testfile-il1)\n3\nhello\n")
(error? ; version mismatch
(separate-eval '(invoke-library '(testfile-il1 (3)))))
(error? ; version mismatch
(separate-eval
'(invoke-library '(testfile-il1 ((>= 3))))))
(equal?
(separate-eval
'(invoke-library '(testfile-il1 ((>= 2)))))
"invoked (testfile-il1)\n")
(equal?
(separate-eval
'(invoke-library '(testfile-il1 (2))))
"invoked (testfile-il1)\n")
)
(mat cross-library-optimization
(begin
@ -9568,6 +9741,16 @@
)
(mat library-directories
(error? ; invalid argument
(library-directories '("a" . hello)))
(error? ; invalid argument
(library-directories '("a" . ("src" . "obj"))))
(error? ; invalid argument
(library-directories '("a" . (("src")))))
(error? ; invalid argument
(library-directories '("a" . (("src" "obj")))))
(error? ; invalid argument
(library-directories '("a" . ((("src" "obj"))))))
(let ([x (library-directories)])
(and (list? x)
(andmap (lambda (x) (and (pair? x) (string? (car x)) (string? (cdr x)))) x)))
@ -9607,6 +9790,14 @@
)
(mat library-extensions
(error? ; invalid argument
(library-extensions '.a1.sls))
(error? ; invalid argument
(library-extensions '((".foo"))))
(error? ; invalid argument
(library-extensions '((".foo" ".bar"))))
(error? ; invalid argument
(library-extensions '(((".junk")))))
(let ([x (library-extensions)])
(and (list? x)
(andmap (lambda (x) (and (pair? x) (string? (car x)) (string? (cdr x)))) x)))
@ -10381,7 +10572,7 @@
(parameterize ([console-output-port (open-output-string)])
(eval '(lambda () (import (testfile-imno2)) y))
(get-output-string (console-output-port)))
"import: did not find source file \"testfile-imno2.chezscheme.sls\"\nimport: found source file \"testfile-imno2.ss\"\nimport: did not find corresponding object file \"testfile-imno2.so\"\nimport: loading source file \"testfile-imno2.ss\"\nimport: did not find source file \"testfile-imno1.chezscheme.sls\"\nimport: found source file \"testfile-imno1.ss\"\nimport: found corresponding object file \"testfile-imno1.so\"\nimport: object file is not older\nimport: loading object file \"testfile-imno1.so\"\n")
"import: did not find source file \"testfile-imno2.chezscheme.sls\"\nimport: found source file \"testfile-imno2.ss\"\nimport: did not find corresponding object file \"testfile-imno2.so\"\nimport: loading source file \"testfile-imno2.ss\"\nimport: did not find source file \"testfile-imno1.chezscheme.sls\"\nimport: found source file \"testfile-imno1.ss\"\nimport: found corresponding object file \"testfile-imno1.so\"\nimport: object file is not older\nimport: visiting object file \"testfile-imno1.so\"\nattempting to 'revisit' previously 'visited' \"testfile-imno1.so\" for library (testfile-imno1) run-time info\n")
(eq? (import-notify #f) (void))
)

94
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 cptypes 5_6 5_7 5_8 6 io format 7 record hash enum 8 fx fl cfl foreign\
ftype unix windows examples ieee date exceptions oop
@ -140,15 +147,15 @@ src = $(mats:%=%.ms)
# prettysrc is src to use for pretty-print test; we leave out mat files
# with cycles, e.g., primvars.ms, misc.ms, 4.ms, 5_1.ms, hash.ms
prettysrc = 3.ms 5_3.ms 5_4.ms 5_5.ms bytevector.ms\
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,23 +404,26 @@ bullyprettytest.ss: ${src}
mat.so: ${patchfile}
foreign.mo ${objdir}/foreign.mo: ${fobj}
thread.mo ${objdir}/thread.mo: ${fobj}
examples.mo ${objdir}/examples.mo: m4test.in m4test.out freq.in freq.out examples
examples.mo ${objdir}/examples.mo: m4test.in m4test.out freq.in freq.out build-examples
6.mo ${objdir}/6.mo: prettytest.ss
bytevector.mo ${objdir}/bytevector.mo: prettytest.ss
io.mo ${objdir}/io.mo: prettytest.ss
unix.mo ${objdir}/unix.mo io.mo ${objdir}/io.mo 6.mo ${objdir}/6.mo: cat_flush
oop.mo ${objdir}/oop.mo: oop.ss
ftype.mo ${objdir}/ftype.mo: ftype.h
hash.mo ${objdir}/hash.mo: ht.ss
examples:
build-examples:
( cd ../examples && ${MAKE} Scheme=${Scheme} )
touch build-examples
prettyclean:
rm -f *.o ${mdclean} *.so *.mo experr* errors* report* summary testfile* testscript\
rm -f *.o ${mdclean} *.so *.mo *.covout experr* errors* report* summary testfile* testscript\
${fobj} prettytest.ss cat_flush so_locations\
script.all? *.html experr*.rej experr*.orig
build-examples script.all? *.html experr*.rej experr*.orig
rm -rf testdir*
rm -rf output-*
( cd ../examples && ${MAKE} Scheme=${Scheme} clean )
clean: prettyclean
rm -f Make.out

3
mats/bytevector.ms
View File

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

8
mats/cp0.ms
View File

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

4
mats/foreign.ms
View File

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

11
mats/hash.ms
View File

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

239
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,70 +229,104 @@
(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
@ -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)))]
@ -364,7 +427,7 @@
(list->string (subst #\\ #\/ (string->list p)))
p)))
(module (separate-eval run-script separate-compile)
(module separate-eval-tools (separate-eval run-script separate-compile)
(define (slurp ip)
(with-output-to-string
(lambda ()
@ -383,7 +446,11 @@
(close-port to-stdin)
(let* ([stdout-stuff (slurp from-stdout)]
[stderr-stuff (slurp from-stderr)])
(unless (string=? stderr-stuff "") (errorf who "~a" stderr-stuff))
(when (string=? stderr-stuff "")
(printf "$separate-eval command succeeeded with\nSTDERR:\n~a\nSTDOUT:\n~a\nEND\n" stderr-stuff stdout-stuff))
(unless (string=? stderr-stuff "")
(printf "$separate-eval command failed with\nSTDERR:\n~a\nSTDOUT:\n~a\nEND\n" stderr-stuff stdout-stuff)
(errorf who "~a" stderr-stuff))
(close-port from-stdout)
(close-port from-stderr)
stdout-stuff)))
@ -409,6 +476,7 @@
[(x) (separate-compile 'compile-file x)]
[(cf x) ($separate-eval 'separate-compile `((,cf ,(if (symbol? x) (format "testfile-~a" x) x))))])))
(import separate-eval-tools)
#;(collect-request-handler
(begin
@ -440,12 +508,13 @@
(define test-cp0-expansion
(rec test-cp0-expansion
(case-lambda
[(expr result) (test-cp0-expansion equivalent-expansion? expr result)]
[(equiv? expr result)
(equiv?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize `(let () (import scheme) ,expr)))
result)])))
[(expr expected) (test-cp0-expansion equivalent-expansion? expr expected)]
[(equiv? expr expected)
(let ([actual (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize `(let () (import scheme) ,expr)))])
(unless (equiv? actual expected)
(errorf 'test-cp0-expansion "expected ~s for ~s, got ~s\n" expected expr actual))
#t)])))
(define rm-rf
(lambda (path)
@ -474,3 +543,21 @@
(sleep (make-time 'time-duration 1000000 1))
(loop))))
#t))
(define preexisting-profile-dump-entry?
(let ([ht (make-eq-hashtable)])
(for-each (lambda (x) (eq-hashtable-set! ht (car x) #t)) (profile-dump))
(lambda (x) (eq-hashtable-contains? ht (car x)))))
(define heap-check-interval (make-parameter 0))
(collect-request-handler
(let ([counter 0])
(lambda ()
(parameterize ([#%$enable-check-heap
(let ([interval (heap-check-interval)])
(and (not (fx= interval 0))
(let ([n (fxmod (fx+ counter 1) interval)])
(set! counter n)
(fx= n 0))))])
(collect)))))

759
mats/misc.ms
View File

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

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

@ -1,7 +1,7 @@
*** errors-compile-0-f-f-f 2019-07-26 13:30:16.000000000 -0400
--- errors-compile-0-f-t-f 2019-07-26 13:41:01.000000000 -0400
*** errors-compile-0-f-f-f 2020-02-22 12:22:03.000000000 -0700
--- errors-compile-0-f-t-f 2020-02-22 12:57:01.000000000 -0700
***************
*** 125,131 ****
*** 254,260 ****
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable c".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable m".
@ -9,7 +9,7 @@
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable y".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
--- 125,131 ----
--- 254,260 ----
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable c".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable m".
@ -18,7 +18,7 @@
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
***************
*** 144,150 ****
*** 273,279 ****
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable b".
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable a".
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable g".
@ -26,7 +26,7 @@
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable f".
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable c".
3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x".
--- 144,150 ----
--- 273,279 ----
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable b".
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable a".
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable g".
@ -35,7 +35,7 @@
3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable c".
3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x".
***************
*** 191,200 ****
*** 320,329 ****
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned zero values to single value return context".
@ -46,7 +46,7 @@
3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound".
3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17".
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
--- 191,200 ----
--- 320,329 ----
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned zero values to single value return context".
@ -58,7 +58,7 @@
3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17".
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
***************
*** 3741,3747 ****
*** 4080,4086 ****
misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar".
@ -66,7 +66,7 @@
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
--- 3741,3747 ----
--- 4080,4086 ----
misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar".
@ -75,7 +75,7 @@
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
***************
*** 7259,7266 ****
*** 7645,7652 ****
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat error: "a: hit me!".
7.mo:Expected error in mat error: "f: n is 0".
@ -84,7 +84,7 @@
record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
--- 7259,7266 ----
--- 7645,7652 ----
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat error: "a: hit me!".
7.mo:Expected error in mat error: "f: n is 0".
@ -94,7 +94,7 @@
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
***************
*** 7268,7282 ****
*** 7654,7668 ****
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@ -110,7 +110,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid input #f".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
--- 7268,7282 ----
--- 7654,7668 ----
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@ -127,7 +127,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
***************
*** 7289,7314 ****
*** 7675,7700 ****
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@ -154,7 +154,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
--- 7289,7314 ----
--- 7675,7700 ----
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@ -182,7 +182,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
***************
*** 7439,7477 ****
*** 7825,7863 ****
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@ -222,7 +222,7 @@
record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
--- 7439,7477 ----
--- 7825,7863 ----
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@ -263,7 +263,7 @@
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
***************
*** 7486,7542 ****
*** 7872,7928 ****
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
@ -321,7 +321,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
--- 7486,7542 ----
--- 7872,7928 ----
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".

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

File diff suppressed because it is too large Load Diff

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

@ -1,7 +1,26 @@
*** errors-compile-0-f-f-f 2019-07-26 13:30:16.000000000 -0400
--- errors-interpret-0-f-f-f 2019-07-26 14:04:09.000000000 -0400
*** errors-compile-0-f-f-f 2020-02-22 12:22:03.000000000 -0700
--- errors-interpret-0-f-f-f 2020-02-22 12:57:46.000000000 -0700
***************
*** 1,7 ****
*** 18,25 ****
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure
primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure
! primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in compile: ((a . b)) is not an environment
! primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in compile: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f)): Exception in sc-expand: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b))) 1.0+2.0i): Exception in sc-expand: ((a . b)) is not an environment
--- 18,25 ----
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure
primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure
! primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in interpret: ((a . b)) is not an environment
! primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in interpret: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f)): Exception in sc-expand: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b))) 1.0+2.0i): Exception in sc-expand: ((a . b)) is not an environment
***************
*** 130,136 ****
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>".
@ -9,13 +28,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: a is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
--- 1,13 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1045, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1047, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1054, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1056, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1063, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1065, char 4 of 6.ms
--- 130,136 ----
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>".
@ -24,7 +37,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
***************
*** 28,98 ****
*** 157,227 ****
primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36".
primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure".
primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port".
@ -96,7 +109,7 @@
3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) (eq? x (...))))".
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
--- 34,104 ----
--- 157,227 ----
primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36".
primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure".
primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port".
@ -169,7 +182,7 @@
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
***************
*** 191,202 ****
*** 320,331 ****
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned zero values to single value return context".
@ -182,7 +195,7 @@
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
3.mo:Expected error in mat mrvs: "cdr: a is not a pair".
--- 197,208 ----
--- 320,331 ----
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned three values to single value return context".
3.mo:Expected error in mat mrvs: "returned zero values to single value return context".
@ -196,7 +209,7 @@
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
3.mo:Expected error in mat mrvs: "cdr: a is not a pair".
***************
*** 4147,4162 ****
*** 4483,4498 ****
6.mo:Expected error in mat pretty-print: "incorrect argument count in call (pretty-format (quote foo) (quote x) (quote x))".
6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
@ -213,9 +226,9 @@
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
--- 4153,4162 ----
--- 4483,4492 ----
***************
*** 7121,7127 ****
*** 7457,7463 ****
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@ -223,7 +236,7 @@
7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
--- 7121,7127 ----
--- 7451,7457 ----
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@ -232,7 +245,7 @@
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
***************
*** 7450,7456 ****
*** 7836,7842 ****
record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
@ -240,7 +253,7 @@
record.mo:Expected error in mat record25: "invalid value 12.0 for foreign type long-long".
record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
--- 7450,7456 ----
--- 7830,7836 ----
record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
@ -249,7 +262,7 @@
record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
***************
*** 7492,7498 ****
*** 7878,7884 ****
record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
@ -257,7 +270,7 @@
record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 4 to #<procedure constructor>".
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor #<record constructor descriptor> is not for parent of record type #<record type grand-child>".
record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar>".
--- 7492,7498 ----
--- 7872,7878 ----
record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
@ -266,7 +279,7 @@
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor #<record constructor descriptor> is not for parent of record type #<record type grand-child>".
record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar>".
***************
*** 8715,8727 ****
*** 9122,9134 ****
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -280,7 +293,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
--- 8715,8727 ----
--- 9116,9128 ----
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -295,7 +308,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
***************
*** 9482,9506 ****
*** 9889,9913 ****
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@ -321,7 +334,7 @@
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier booleen".
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
--- 9482,9506 ----
--- 9883,9907 ----
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@ -348,7 +361,7 @@
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
***************
*** 9513,9544 ****
*** 9920,9951 ****
foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@ -381,7 +394,7 @@
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
--- 9513,9544 ----
--- 9914,9945 ----
foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@ -415,7 +428,7 @@
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
***************
*** 9546,9571 ****
*** 9953,9978 ****
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@ -442,7 +455,7 @@
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
--- 9546,9571 ----
--- 9947,9972 ----
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@ -470,7 +483,7 @@
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
***************
*** 9576,9610 ****
*** 9983,10017 ****
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@ -506,7 +519,7 @@
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
--- 9576,9610 ----
--- 9977,10011 ----
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@ -543,7 +556,7 @@
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
***************
*** 10211,10220 ****
*** 10618,10627 ****
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
@ -554,7 +567,7 @@
oop.mo:Expected error in mat oop: "m1: not applicable to 17".
oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
--- 10211,10220 ----
--- 10612,10621 ----
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".

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

@ -1,7 +1,26 @@
*** errors-compile-0-f-t-f 2019-07-26 13:41:01.000000000 -0400
--- errors-interpret-0-f-t-f 2019-07-26 14:16:35.000000000 -0400
*** errors-compile-0-f-t-f 2020-02-22 12:57:01.000000000 -0700
--- errors-interpret-0-f-t-f 2020-02-22 12:56:12.000000000 -0700
***************
*** 1,7 ****
*** 18,25 ****
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure
primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure
! primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in compile: ((a . b)) is not an environment
! primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in compile: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f)): Exception in sc-expand: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b))) 1.0+2.0i): Exception in sc-expand: ((a . b)) is not an environment
--- 18,25 ----
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure
primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure
! primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in interpret: ((a . b)) is not an environment
! primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in interpret: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f)): Exception in sc-expand: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b))) 1.0+2.0i): Exception in sc-expand: ((a . b)) is not an environment
***************
*** 130,136 ****
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>".
@ -9,13 +28,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: a is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
--- 1,13 ----
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1045, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1047, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1054, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1056, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1063, char 4 of 6.ms
+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1065, char 4 of 6.ms
--- 130,136 ----
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>".
@ -24,7 +37,7 @@
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
***************
*** 28,98 ****
*** 157,227 ****
primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36".
primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure".
primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port".
@ -96,7 +109,7 @@
3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) (eq? x (...))))".
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
--- 34,104 ----
--- 157,227 ----
primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36".
primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure".
primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port".
@ -169,7 +182,7 @@
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
***************
*** 4147,4162 ****
*** 4483,4498 ****
6.mo:Expected error in mat pretty-print: "incorrect argument count in call (pretty-format (quote foo) (quote x) (quote x))".
6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
@ -186,9 +199,9 @@
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
--- 4153,4162 ----
--- 4483,4492 ----
***************
*** 7121,7127 ****
*** 7457,7463 ****
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@ -196,7 +209,7 @@
7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
--- 7121,7127 ----
--- 7451,7457 ----
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@ -205,7 +218,7 @@
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
***************
*** 7259,7266 ****
*** 7645,7652 ****
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat error: "a: hit me!".
7.mo:Expected error in mat error: "f: n is 0".
@ -214,7 +227,7 @@
record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
--- 7259,7266 ----
--- 7639,7646 ----
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat error: "a: hit me!".
7.mo:Expected error in mat error: "f: n is 0".
@ -224,7 +237,7 @@
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
***************
*** 7268,7282 ****
*** 7654,7668 ****
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@ -240,7 +253,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid input #f".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
--- 7268,7282 ----
--- 7648,7662 ----
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@ -257,7 +270,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
***************
*** 7289,7314 ****
*** 7675,7700 ****
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@ -284,7 +297,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
--- 7289,7314 ----
--- 7669,7694 ----
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@ -312,7 +325,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
***************
*** 7439,7477 ****
*** 7825,7863 ****
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@ -352,7 +365,7 @@
record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
--- 7439,7477 ----
--- 7819,7857 ----
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@ -393,7 +406,7 @@
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
***************
*** 7486,7542 ****
*** 7872,7928 ****
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
@ -451,7 +464,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
--- 7486,7542 ----
--- 7866,7922 ----
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
@ -510,7 +523,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
***************
*** 8715,8727 ****
*** 9122,9134 ****
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -524,7 +537,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
--- 8715,8727 ----
--- 9116,9128 ----
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -539,7 +552,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
***************
*** 10211,10220 ****
*** 10618,10627 ****
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
@ -550,7 +563,7 @@
oop.mo:Expected error in mat oop: "m1: not applicable to 17".
oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
--- 10211,10220 ----
--- 10612,10621 ----
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".

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

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

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

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

447
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,93 @@
(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)])
(void)
(let ([call `(($primitive ,prim) ,@(make-list n `',(void)))])
(unless (guard (c [else (okay-condition? prim c)])
(eval `(begin ,call #f)))
(set! oops #t)
(printf "no argcount error for ~s\n" call))))
(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))))))))
(let ([call `(,prim ,@(make-list n '(void)))])
(printf "no argcount error for ~s\n" call)))
(let ([call `(($primitive ,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 (eval `($primitive ,prim)))])
(unless (= mask pam)
(printf "primref arity mask ~s differs from procedure-arity-mask return value ~s for ~s\n"
mask pam prim)
(set! oops #t)))
(let loop ([n 0] [mask mask])
(cond
[(null? a*) (check prim n)]
[(= (- -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 +317,19 @@
[binary-input-port (open-bytevector-input-port bv)]
[sfd (make-source-file-descriptor "foo" binary-input-port #t)]
[source-object (make-source-object sfd 2 3)]
[annotation (make-annotation '(if #f #f) source-object '(source expr))])
[annotation (make-annotation '(if #f #f) source-object '(source expr))]
[textual-input-port (transcoded-port binary-input-port (native-transcoder))])
(def *binary-input-port binary-input-port)
(def *sfd sfd)
(def *source-object source-object)
(def *annotation annotation))
(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 *phantom-bytevector (make-phantom-bytevector 10))
@ -334,6 +346,7 @@
(def *record ((record-constructor rcd) 3)))
(def *sstats (statistics))
(def *time (make-time 'time-duration 0 5))
(def *time-utc (make-time 'time-utc 0 5))
(cond
[(fx< (fixnum-width) 32)
(def *max-iptr (- (expt 2 31) 1))
@ -369,31 +382,34 @@
[(bytevector) '#vu8(0) "a" #f]
[(cflonum) 0.0+1.0i 0 'a #f]
[(char) #\a 0 #f]
[(codec) latin-1-codec 0 #f]
[(codec) (latin-1-codec) 0 #f]
[(code) (closure-code 'values) 0 #f]
[(compile-time-value) (make-compile-time-value 17)]
[(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]
[(eof/char) #\a 0 #f]
[(eof/u8) 0 -1 (expt 2 8) "a" #f]
[(fasl-strip-options) (fasl-strip-options inspector-source) (file-options compressed) #f]
[(file-options) (file-options compressed) 1/2 #f]
[(fixnum) -1 'q (+ (most-positive-fixnum) 1) (- (most-negative-fixnum) 1)]
[(fixnum) -1 'q (+ (most-positive-fixnum) 1) (- (most-negative-fixnum) 1) #f]
[(flonum) 0.0 0 0.0+1.0i 'a #f]
[(ftype-pointer) *ftype-pointer 0 *time #f]
[(fxvector) '#vfx(0) "a" #f]
[(gensym) *genny sym #f]
[(gensym) *genny 'sym #f]
[(guardian) (make-guardian) values "oops" #f]
[(hashtable) *eq-hashtable '((a . b)) #f]
[(identifier) #'x x 17 #f]
[(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]
@ -401,25 +417,31 @@
[(i/o-port-error) (make-i/o-port-error 17) (make-who-condition 'who) '(a) #f]
[(irritants-condition) (make-irritants-condition 17) (make-who-condition 'who) 'a #f]
[(length) 0 -1 (+ (most-positive-fixnum) 1) 'a #f]
[(library-path) '(a) "hereiam" #f]
[(library-requirements-options) (library-requirements-options import invoke) 1/2 #f]
[(list) '(a) '#1=(a . #1#) 17 '#() #f]
[(list-of-string-pairs) '(("a" . "b")) '("a") #f]
[(list-of-symbols) '(a b c) '("a") #f]
[(maybe-binary-output-port) *binary-output-port *binary-input-port (current-output-port)]
[(maybe-char) #\a 0]
[(maybe-pathname) "a" 'a]
[(maybe-procedure) values 0]
[(maybe-rtd) *rtd *record ""]
[(maybe-sfd) *sfd '(q)]
[(maybe-source-table) (make-source-table) *time]
[(maybe-string) "a" 'a]
[(maybe-symbol) 'a 0 "a"]
[(maybe-textual-output-port) (current-output-port) 0 *binary-output-port (transcoded-port *binary-input-port (native-transcoder))]
[(maybe-textual-output-port) (current-output-port) 0 *binary-output-port *textual-input-port]
[(maybe-transcoder) (native-transcoder) 0]
[(maybe-ufixnum) 0 -1 (+ (most-positive-fixnum) 1) 'a]
[(maybe-uint) 0 -1 'a]
[(maybe-who) 'who 17]
[(maybe-timeout) *time 371]
[(message-condition) (make-message-condition 17) (make-who-condition 'who) 'q #f]
[(number) 1+2i 'oops #f]
[(nzuint) 1 0 'a #f]
[(old-hash-table) *old-hash-table '((a . b)) #f]
[(output-port) (current-output-port) 0 *binary-input-port (transcoded-port *binary-input-port (native-transcoder)) #f]
[(output-port) (current-output-port) 0 *binary-input-port *textual-input-port #f]
[(pair) '(a . b) 'a #f]
[(pathname) "a" 'a #f]
[(pfixnum) 1 0 #f]
@ -441,22 +463,24 @@
[(s56) -1 'q (expt 2 55) (- -1 (expt 2 55)) #f]
[(s64) -1 'q (expt 2 63) (- -1 (expt 2 63)) #f]
[(s8) -1 'q (expt 2 7) (- -1 (expt 2 7)) #f]
[(sfd) *sfd '(q)]
[(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]
[(string/bytevector) no-good]
[(sub-ptr) no-good]
[(sub-uint sub-ufixnum sub-index sub-length sub-list sub-fixnum sub-flonum sub-integer sub-number sub-port sub-rtd sub-sint sub-string sub-symbol sub-textual-output-port sub-vector maybe-sub-rcd maybe-sub-symbol) no-good #!eof]
[(sub-uint sub-ufixnum sub-index sub-length sub-list sub-fixnum sub-flonum sub-integer sub-number sub-port sub-rtd sub-sint sub-string sub-symbol sub-textual-output-port sub-vector) no-good #!eof #f]
[(maybe-sub-rcd maybe-sub-symbol) no-good #!eof]
[(symbol) 'a 0 "a" #f]
[(symbol-hashtable) *symbol-hashtable *eq-hashtable '() #f]
[(syntax-violation) (make-syntax-violation '(if) #f) 'oops #f]
[(textual-input-port) (current-input-port) 0 *binary-input-port (transcoded-port *binary-output-port (native-transcoder)) #f]
[(textual-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]
@ -474,7 +498,8 @@
[(uptr/iptr) -1 'q (+ *max-uptr 1) (- *min-iptr 1) #f]
[(vector) '#(a) "a" #f]
[(stencil-vector) (stencil-vector 7 1 2 3) "a" #f]
[(who-condition) (make-who-condition 'me) (make-message-condition "hello") 'the-who])
[(who-condition) (make-who-condition 'me) (make-message-condition "hello") 'the-who #f]
[(who) 'who 17])
(meta-cond
[(memq 'pthreads feature*)
(declare-types
@ -482,6 +507,13 @@
[(mutex) (make-mutex) "not a mutex" #f])])
ht))
(define (fuzz-prim-args name unprefixed-name lib* flag* in*/out**)
(define (prefix=? prefix str)
(let ([n (string-length prefix)])
(and (>= (string-length str) n)
(string=? (substring str 0 n) prefix))))
(define (who=? x y)
(define ->string (lambda (x) (if (symbol? x) (symbol->string x) x)))
(equal? (->string x) (->string y)))
(define-syntax flags-set? (syntax-rules () [(_ x ...) (and (memq 'x flag*) ...)]))
(define good/bad
(lambda (in* k)
@ -522,28 +554,107 @@
(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"
"invalid code page ~s")))
(equal? (condition-irritants c) (list bad)))
(and (or (member (condition-message c)
'("~s is not a valid index for ~s"
"~s is not a valid size for ~s"
"invalid index ~s for bytevector ~s"
"invalid new length ~s for ~s"))
(prefix=? "invalid message argument ~s" (condition-message c))
(prefix=? "invalid who argument ~s" (condition-message c)))
(let ([ls (condition-irritants c)])
(and (not (null? ls)) (equal? (car ls) bad)))))))
; if it looks good, print to stdout
(fprintf (mat-output) "seemingly appropriate argument-type error testing ~s: " call)
; otherwise, mark it as an expected error for user audit
(fprintf (mat-output) "Expected error testing ~s: " call))
(display-condition c (mat-output))
(newline (mat-output)))
(errorf 'fuzz-prim-args "unexpected exception occurred evaluating ~s: ~a" call
(with-output-to-string (lambda () (display-condition c)))))
(errorf 'fuzz-prim-args "no exception occurred evaluating ~s" call))))))
(car bad**)))
(loop (cdr good*) (cdr bad**) (cons (car good*) rgood*)))))))
(map car in*/out**))))

999
mats/profile.ms Normal file
View File

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

8
mats/record.ms
View File

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

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

@ -1,3 +1,132 @@
primvars.mo:Expected error testing (environment (quote 0)): Exception in environment: invalid library reference 0
primvars.mo:Expected error testing (environment (quote (a . b))): Exception in environment: invalid library reference (a . b)
primvars.mo:Expected error testing (environment (quote #f)): Exception in environment: invalid library reference #f
primvars.mo:Expected error testing (environment (quote 0) (quote (chezscheme))): Exception in environment: invalid library reference 0
primvars.mo:Expected error testing (environment (quote (a . b)) (quote (chezscheme))): Exception in environment: invalid library reference (a . b)
primvars.mo:Expected error testing (environment (quote #f) (quote (chezscheme))): Exception in environment: invalid library reference #f
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote 0)): Exception in environment: invalid library reference 0
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (a . b))): Exception in environment: invalid library reference (a . b)
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
primvars.mo:Expected error testing (environment (quote 0) (quote (chezscheme)) (quote (chezscheme))): Exception in environment: invalid library reference 0
primvars.mo:Expected error testing (environment (quote (a . b)) (quote (chezscheme)) (quote (chezscheme))): Exception in environment: invalid library reference (a . b)
primvars.mo:Expected error testing (environment (quote #f) (quote (chezscheme)) (quote (chezscheme))): Exception in environment: invalid library reference #f
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote 0) (quote (chezscheme))): Exception in environment: invalid library reference 0
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (a . b)) (quote (chezscheme))): Exception in environment: invalid library reference (a . b)
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote #f) (quote (chezscheme))): Exception in environment: invalid library reference #f
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote 0)): Exception in environment: invalid library reference 0
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote (a . b))): Exception in environment: invalid library reference (a . b)
primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure
primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure
primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in compile: ((a . b)) is not an environment
primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in compile: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f)): Exception in sc-expand: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b))) 1.0+2.0i): Exception in sc-expand: ((a . b)) is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f) 1.0+2.0i): Exception in sc-expand: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b))) 1.0+2.0i 1.0+2.0i): Exception in sc-expand: ((a . b)) is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f) 1.0+2.0i 1.0+2.0i): Exception in sc-expand: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b))) 1.0+2.0i 1.0+2.0i "a"): Exception in sc-expand: ((a . b)) is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f) 1.0+2.0i 1.0+2.0i "a"): Exception in sc-expand: #f is not an environment
primvars.mo:Expected error testing (expand 1.0+2.0i *env 1.0+2.0i 1.0+2.0i (quote a)): Exception in sc-expand: a is not a string or #f
primvars.mo:Expected error testing (fxpopcount (quote #!eof)): Exception in fxpopcount32: #!eof is not a non-negative fixnum
primvars.mo:Expected error testing (fxpopcount (quote #f)): Exception in fxpopcount32: #f is not a non-negative fixnum
primvars.mo:Expected error testing (hashtable-cells (quote ((a . b)))): Exception in hashtable-size: ((a . b)) is not a hashtable
primvars.mo:Expected error testing (hashtable-cells (quote #f)): Exception in hashtable-size: #f is not a hashtable
primvars.mo:Expected error testing (make-input-port (quote 0) "a"): Exception in make-input-port: fixnum handler no longer supported; use open-fd-input-port
primvars.mo:Expected error testing (make-input/output-port (quote 0) "a" "a"): Exception in make-input/output-port: fixnum handler no longer supported; use open-fd-input-port
primvars.mo:Expected error testing (make-output-port (quote 0) "a"): Exception in make-output-port: fixnum handler no longer supported; use open-fd-input-port
primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i (quote q) (- (most-negative-fixnum) 1)): Exception in make-record-type-descriptor*: invalid field count q
primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i (quote 1152921504606846976) (- (most-negative-fixnum) 1)): Exception in make-record-type-descriptor*: invalid field count 1152921504606846976
primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i (quote -1152921504606846977) (- (most-negative-fixnum) 1)): Exception in make-record-type-descriptor*: invalid field count -1152921504606846977
primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i (quote #f) (- (most-negative-fixnum) 1)): Exception in make-record-type-descriptor*: invalid field count #f
primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i -1 (quote 2.0)): Exception in make-record-type-descriptor*: invalid field count -1
primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i -1 (quote 1/2)): Exception in make-record-type-descriptor*: invalid field count -1
primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i -1 (quote #f)): Exception in make-record-type-descriptor*: invalid field count -1
primvars.mo:Expected error testing (make-sstats (quote "no-time") *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: cpu value "no-time" is not a time record
primvars.mo:Expected error testing (make-sstats (quote #f) *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: cpu value #f is not a time record
primvars.mo:Expected error testing (make-sstats *time (quote "no-time") (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: real value "no-time" is not a time record
primvars.mo:Expected error testing (make-sstats *time (quote #f) (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: real value #f is not a time record
primvars.mo:Expected error testing (make-sstats *time *time (quote 2.0) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: bytes value 2.0 is not an exact integer
primvars.mo:Expected error testing (make-sstats *time *time (quote 1/2) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: bytes value 1/2 is not an exact integer
primvars.mo:Expected error testing (make-sstats *time *time (quote #f) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: bytes value #f is not an exact integer
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (quote 2.0) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-count value 2.0 is not an exact integer
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (quote 1/2) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-count value 1/2 is not an exact integer
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (quote #f) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-count value #f is not an exact integer
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) (quote "no-time") *time (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-cpu value "no-time" is not a time record
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) (quote #f) *time (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-cpu value #f is not a time record
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time (quote "no-time") (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-real value "no-time" is not a time record
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time (quote #f) (- (most-negative-fixnum) 1)): Exception in make-sstats: gc-real value #f is not a time record
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (quote 2.0)): Exception in make-sstats: gc-bytes value 2.0 is not an exact integer
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (quote 1/2)): Exception in make-sstats: gc-bytes value 1/2 is not an exact integer
primvars.mo:Expected error testing (make-sstats *time *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (quote #f)): Exception in make-sstats: gc-bytes value #f is not an exact integer
primvars.mo:Expected error testing (pseudo-random-generator->vector (quote #f)): Exception in pseudo-random-generator->vector: not a pseudo-random generator #f
primvars.mo:Expected error testing (pseudo-random-generator-seed! *pseudo-random-generator (quote #!eof)): Exception: variable *pseudo-random-generator is not bound
primvars.mo:Expected error testing (pseudo-random-generator-seed! *pseudo-random-generator (quote #f)): Exception: variable *pseudo-random-generator is not bound
primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #f)): Exception in pseudo-random-generator-next!: not a pseudo-random generator #f
primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #!eof) *pseudo-random-generator): Exception: variable *pseudo-random-generator is not bound
primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #f) *pseudo-random-generator): Exception: variable *pseudo-random-generator is not bound
primvars.mo:Expected error testing (set-wrapper-procedure! 1.0+2.0i (quote 0)): Exception in set-wrapper-procedure!: 1.0+2.0i is not a wrapper procedure
primvars.mo:Expected error testing (set-wrapper-procedure! 1.0+2.0i (quote #f)): Exception in set-wrapper-procedure!: 1.0+2.0i is not a wrapper procedure
primvars.mo:Expected error testing (stencil-vector (quote -1)): Exception in stencil-vector: invalid mask -1
primvars.mo:Expected error testing (stencil-vector (quote a)): Exception in stencil-vector: invalid mask a
primvars.mo:Expected error testing (stencil-vector (quote 18446744073709551616)): Exception in stencil-vector: invalid mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector (quote #f)): Exception in stencil-vector: invalid mask #f
primvars.mo:Expected error testing (stencil-vector (quote -1) 1.0+2.0i): Exception in stencil-vector: invalid mask -1
primvars.mo:Expected error testing (stencil-vector (quote a) 1.0+2.0i): Exception in stencil-vector: invalid mask a
primvars.mo:Expected error testing (stencil-vector (quote 18446744073709551616) 1.0+2.0i): Exception in stencil-vector: invalid mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector (quote #f) 1.0+2.0i): Exception in stencil-vector: invalid mask #f
primvars.mo:Expected error testing (stencil-vector (quote -1) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask -1
primvars.mo:Expected error testing (stencil-vector (quote a) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask a
primvars.mo:Expected error testing (stencil-vector (quote 18446744073709551616) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector (quote #f) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask #f
primvars.mo:Expected error testing (stencil-vector (quote -1) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask -1
primvars.mo:Expected error testing (stencil-vector (quote a) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask a
primvars.mo:Expected error testing (stencil-vector (quote 18446744073709551616) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector (quote #f) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask #f
primvars.mo:Expected error testing (stencil-vector-truncate! (stencil-vector 7 1 2 3) (quote -1)): Exception in stencil-vector-truncate!: invalid mask -1
primvars.mo:Expected error testing (stencil-vector-truncate! (stencil-vector 7 1 2 3) (quote a)): Exception in stencil-vector-truncate!: invalid mask a
primvars.mo:Expected error testing (stencil-vector-truncate! (stencil-vector 7 1 2 3) (quote 18446744073709551616)): Exception in stencil-vector-truncate!: invalid mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector-truncate! (stencil-vector 7 1 2 3) (quote #f)): Exception in stencil-vector-truncate!: invalid mask #f
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote -1) 0): Exception in stencil-vector-update: invalid removal mask -1
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote a) 0): Exception in stencil-vector-update: invalid removal mask a
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote 18446744073709551616) 0): Exception in stencil-vector-update: invalid removal mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote #f) 0): Exception in stencil-vector-update: invalid removal mask #f
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote -1)): Exception in stencil-vector-update: invalid addition mask -1
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote a)): Exception in stencil-vector-update: invalid addition mask a
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote 18446744073709551616)): Exception in stencil-vector-update: invalid addition mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote #f)): Exception in stencil-vector-update: invalid addition mask #f
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote -1) 0 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask -1
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote a) 0 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask a
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote 18446744073709551616) 0 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote #f) 0 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask #f
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote -1) 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask -1
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote a) 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask a
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote 18446744073709551616) 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote #f) 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask #f
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote -1) 0 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask -1
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote a) 0 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask a
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote 18446744073709551616) 0 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote #f) 0 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask #f
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote -1) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask -1
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote a) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask a
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote 18446744073709551616) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote #f) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask #f
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote -1) 0 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask -1
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote a) 0 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask a
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote 18446744073709551616) 0 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote #f) 0 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask #f
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote -1) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask -1
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote a) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask a
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote 18446744073709551616) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask 18446744073709551616
primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote #f) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask #f
primvars.mo:Expected error testing (vector->pseudo-random-generator (quote "a")): Exception in vector->pseudo-random-generator: not a valid pseudo-random generator state vector "a"
primvars.mo:Expected error testing (vector->pseudo-random-generator (quote #f)): Exception in vector->pseudo-random-generator: not a valid pseudo-random generator state vector #f
primvars.mo:Expected error testing (vector->pseudo-random-generator! (quote #f) (quote #(a))): Exception in vector->pseudo-random-generator!: not a pseudo-random generator #f
primvars.mo:Expected error testing (vector->pseudo-random-generator! *pseudo-random-generator (quote "a")): Exception: variable *pseudo-random-generator is not bound
primvars.mo:Expected error testing (vector->pseudo-random-generator! *pseudo-random-generator (quote #f)): Exception: variable *pseudo-random-generator is not bound
primvars.mo:Expected error testing (verify-loadability (quote #!eof)): Exception in verify-loadability: invalid situation #!eof; should be one of load, visit, or revisit
primvars.mo:Expected error testing (verify-loadability (quote #f)): Exception in verify-loadability: invalid situation #f; should be one of load, visit, or revisit
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>".
@ -14,7 +143,7 @@ primvars.mo:Expected error in mat current-output-port: "current-output-port: #<i
primvars.mo:Expected error in mat eval-syntax-expanders-when: "eval-syntax-expanders-when: invalid eval-when list (compiling)".
primvars.mo:Expected error in mat gensym-count: "gensym-count: "g" is not a nonnegative integer".
primvars.mo:Expected error in mat keyboard-interrupt-handler: "keyboard-interrupt-handler: 0 is not a procedure".
primvars.mo:Expected error in mat optimize-level: "optimize-level: 4 is not valid optimize level".
primvars.mo:Expected error in mat optimize-level: "optimize-level: 4 is not a valid optimize level".
primvars.mo:Expected error in mat pretty-line-length: "pretty-line-length: -1 is not a positive fixnum".
primvars.mo:Expected error in mat pretty-line-length: "pretty-line-length: <int> is not a positive fixnum".
primvars.mo:Expected error in mat pretty-one-line-limit: "pretty-one-line-limit: 0 is not a positive fixnum".
@ -330,12 +459,12 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular".
4.mo:Expected error in mat fold-right: "fold-right: lists (a b) and (p q r) differ in length".
4.mo:Expected error in mat fold-right: "fold-right: lists (1 2) and (p q r) differ in length".
4.mo:Expected error in mat fold-right: "map: a is not a proper list".
4.mo:Expected error in mat fold-right: "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".
@ -1725,6 +1854,85 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
5_3.mo:Expected error in mat div0-and-mod0: "mod0: undefined for 0".
5_3.mo:Expected error in mat div0-and-mod0: "mod0: undefined for a".
5_3.mo:Expected error in mat div0-and-mod0: "mod0: undefined for (a)".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "mod: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "quotient: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "quotient: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "quotient: 4+3i is not an integer".
5_3.mo:Expected error in mat special-cases: "quotient: 4.5 is not an integer".
5_3.mo:Expected error in mat special-cases: "quotient: undefined for 0".
5_3.mo:Expected error in mat special-cases: "quotient: undefined for 0".
5_3.mo:Expected error in mat special-cases: "quotient: undefined for 0".
5_3.mo:Expected error in mat special-cases: "remainder: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "remainder: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "remainder: 4+3i is not an integer".
5_3.mo:Expected error in mat special-cases: "remainder: 4.5 is not an integer".
5_3.mo:Expected error in mat special-cases: "remainder: undefined for 0".
5_3.mo:Expected error in mat special-cases: "remainder: undefined for 0".
5_3.mo:Expected error in mat special-cases: "remainder: undefined for 0".
5_3.mo:Expected error in mat special-cases: "modulo: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "modulo: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "modulo: 4+3i is not an integer".
5_3.mo:Expected error in mat special-cases: "modulo: 4.5 is not an integer".
5_3.mo:Expected error in mat special-cases: "modulo: undefined for 0".
5_3.mo:Expected error in mat special-cases: "modulo: undefined for 0".
5_3.mo:Expected error in mat special-cases: "modulo: undefined for 0".
5_3.mo:Expected error in mat special-cases: "/: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "/: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "+: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "+: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "-: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "-: bogus is not a number".
5_3.mo:Expected error in mat popcount: "fxpopcount32: #f is not a non-negative fixnum".
5_3.mo:Expected error in mat popcount: "fxpopcount32: 1.0 is not a non-negative fixnum".
5_3.mo:Expected error in mat popcount: "fxpopcount32: 1267650600228229401496703205376 is not a non-negative fixnum".
@ -3704,6 +3912,97 @@ bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress:
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
profile.mo:Expected error in mat compile-profile: "compile-profile: invalid mode src [must be #f, #t, source, or block]".
profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump (quote ()))".
profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-clear (quote ()))".
profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-list #t (quote ()) 3)".
profile.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump 17".
profile.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump (17)".
profile.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump ((a . 17))".
profile.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump ((#<source abc[0:3]> . q))".
profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-html "" (quote ()) 3)".
profile.mo:Expected error in mat compile-profile: "profile-dump-html: (prefix) is not a string".
profile.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump 17".
profile.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump (17)".
profile.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump ((a . 17))".
profile.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump ((#<source abc[0:3]> . q))".
profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-data)".
profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-data "profile.data" (quote ()) (quote q))".
profile.mo:Expected error in mat compile-profile: "profile-dump-data: #t is not a string".
profile.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump 17".
profile.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump (17)".
profile.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump ((a . 17))".
profile.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump ((#<source abc[0:3]> . q))".
profile.mo:Expected error in mat compile-profile: "profile-load-data: what? is not a string".
profile.mo:Expected error in mat compile-profile: "profile-palette: palette #() has too few entries".
profile.mo:Expected error in mat compile-profile: "profile-palette: palette #(("black" . "white")) has too few entries".
profile.mo:Expected error in mat compile-profile: "profile-palette: palette #(("black" . "white") ("red" . "white")) has too few entries".
profile.mo:Expected error in mat compile-profile: "profile-palette: invalid palette #(("black" . "white") #("red" "white") ("blue" . "black"))".
profile.mo:Expected error in mat compile-profile: "profile-palette: invalid palette #(("black" . "white") ("red" . "white") ("blue" . black))".
profile.mo:Expected error in mat compile-profile: "profile-palette: invalid palette #(("black" . "white") ("red" . "white") (255 . "black"))".
profile.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
profile.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
profile.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
profile.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
profile.mo:Expected error in mat profile-form: "invalid syntax (profile)".
profile.mo:Expected error in mat profile-form: "invalid syntax (profile 1 2 3)".
profile.mo:Expected error in mat profile-form: "profile subform is not a source object 3".
misc.mo:Expected error in mat compiler1: "variable i-am-not-bound is not bound".
misc.mo:Expected error in mat compiler1: "attempt to apply non-procedure oops".
misc.mo:Expected error in mat compiler1: "incorrect argument count in call (g (list))".
@ -3743,10 +4042,10 @@ misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid g
misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen".
misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1".
misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments 1 to #<procedure find-next>".
misc.mo:Expected error in mat subset: "subset-mode: ieee is not valid subset mode".
misc.mo:Expected error in mat subset: "subset-mode: 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".
@ -3787,45 +4086,14 @@ misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
misc.mo:Expected error in mat cpletrec: "attempt to assign undefined variable b".
misc.mo:Expected error in mat compile-profile: "compile-profile: invalid mode src [must be #f, #t, source, or block]".
misc.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump (quote ()))".
misc.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-clear (quote ()))".
misc.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-list #t (quote ()) 3)".
misc.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump 17".
misc.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump (17)".
misc.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump ((a . 17))".
misc.mo:Expected error in mat compile-profile: "profile-dump-list: invalid dump ((#<source abc[0:3]> . q))".
misc.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-html "" (quote ()) 3)".
misc.mo:Expected error in mat compile-profile: "profile-dump-html: (prefix) is not a string".
misc.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump 17".
misc.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump (17)".
misc.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump ((a . 17))".
misc.mo:Expected error in mat compile-profile: "profile-dump-html: invalid dump ((#<source abc[0:3]> . q))".
misc.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-data)".
misc.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump-data "profile.data" (quote ()) (quote q))".
misc.mo:Expected error in mat compile-profile: "profile-dump-data: #t is not a string".
misc.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump 17".
misc.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump (17)".
misc.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump ((a . 17))".
misc.mo:Expected error in mat compile-profile: "profile-dump-data: invalid dump ((#<source abc[0:3]> . q))".
misc.mo:Expected error in mat compile-profile: "profile-load-data: what? is not a string".
misc.mo:Expected error in mat compile-profile: "profile-palette: palette #() has too few entries".
misc.mo:Expected error in mat compile-profile: "profile-palette: palette #(("black" . "white")) has too few entries".
misc.mo:Expected error in mat compile-profile: "profile-palette: palette #(("black" . "white") ("red" . "white")) has too few entries".
misc.mo:Expected error in mat compile-profile: "profile-palette: invalid palette #(("black" . "white") #("red" "white") ("blue" . "black"))".
misc.mo:Expected error in mat compile-profile: "profile-palette: invalid palette #(("black" . "white") ("red" . "white") ("blue" . black))".
misc.mo:Expected error in mat compile-profile: "profile-palette: invalid palette #(("black" . "white") ("red" . "white") (255 . "black"))".
misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories".
misc.mo:Expected error in mat profile-form: "invalid syntax (profile)".
misc.mo:Expected error in mat profile-form: "invalid syntax (profile 1 2 3)".
misc.mo:Expected error in mat profile-form: "profile subform is not a source object 3".
misc.mo:Expected error in mat strip-fasl-file: "invalid fasl strip option ratfink".
misc.mo:Expected error in mat strip-fasl-file: "strip-fasl-file: #<enum-set> is not a string".
misc.mo:Expected error in mat strip-fasl-file: "strip-fasl-file: #<enum-set> is not a string".
misc.mo:Expected error in mat strip-fasl-file: "strip-fasl-file: "testfile.so" is not a fasl-strip-options object".
misc.mo:Expected error in mat strip-fasl-file: "separate-eval: Exception: loading testfile-sff-4.so did not define library (testfile-sff-4)
misc.mo:Expected error in mat strip-fasl-file: "separate-eval: Exception in environment: loading testfile-sff-4.so did not define compile-time information for library (testfile-sff-4)
misc.mo:Expected error in mat strip-fasl-file: "separate-eval: Exception: loading testfile-sff-4.so did not define compile-time information for library (testfile-sff-4)
misc.mo:Expected error in mat strip-fasl-file: "separate-eval: Exception: loading testfile-sff-4.so did not define compile-time information for library (testfile-sff-4)
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: testfile-fatfib1.so is not a string".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: testfile-fatfib1.so is not a string".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: 13.4 is not a string".
@ -3834,7 +4102,7 @@ misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: record comparison failed while comparing testfile-fatfib1.so and testfile-fatfib3.so within fasl entry 2".
misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: record comparison failed while comparing testfile-fatfib1.so and testfile-fatfib3.so within fasl entry 4".
misc.mo:Expected error in mat cost-center: "incorrect argument count in call (make-cost-center (quote foo))".
misc.mo:Expected error in mat cost-center: "with-cost-center: foo is not a cost center".
misc.mo:Expected error in mat cost-center: "with-cost-center: bar is not a procedure".
@ -4183,8 +4451,8 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat port-operations: "with-output-to-string: (this too?) is not a procedure".
6.mo:Expected error in mat port-operations: "incorrect argument count in call (eof-object #!eof)".
6.mo:Expected error in mat port-operations: "read: unexpected end-of-file reading quote at char 0 of #<input port string>".
6.mo:Expected error in mat port-operations: "read: more than one item found after dot (.) on #<input port testfile.ss>".
6.mo:Expected error in mat port-operations: "read: 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".
@ -4249,7 +4517,7 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat string-escapes: "read: invalid character " in string hex escape at char 3 of #<input port string>".
6.mo:Expected error in mat string-escapes: "read: invalid character * in string hex escape at char 3 of #<input port string>".
6.mo:Expected error in mat string-escapes: "read: invalid character g in string hex escape at char 3 of #<input port string>".
6.mo:Expected error in mat read-token: "read-token: invalid number syntax #eat on #<input port testfile.ss>".
6.mo:Expected error in mat read-token: "read-token: invalid number syntax #eat at line 2, char 1 of testfile.ss".
6.mo:Expected error in mat read-test: "read: unsupported old fasl format detected---use new format with binary i/o at line 4, char 1 of testfile.ss".
6.mo:Expected error in mat load-test: "read: unsupported old fasl format detected---use new format with binary i/o at line 4, char 1 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: unsupported old fasl format detected---use new format with binary i/o at line 4, char 1 of testfile.ss".
@ -7210,20 +7478,70 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat eval-when: "invalid syntax revisit-x".
7.mo:Expected error in mat compile-whole-program: "compile-whole-program: failed for nosuchfile.wpo: no such file or directory".
7.mo:Expected error in mat compile-whole-program: "incorrect argument count in call (compile-whole-program "testfile-wpo-ab.wpo")".
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in visit: library (testfile-wpo-lib) is not visible
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in environment: attempt to import invisible library (testfile-wpo-lib)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-a4) not found
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-c4) not found
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke library (testfile-wpo-c5) while it is still being loaded
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c5)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke invisible library (testfile-wpo-c10)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to import invisible library (testfile-wpo-c10)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in verify-loadability: attempting to invoke invisible library (testfile-wpo-c10)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in verify-loadability: attempting to invoke invisible library (testfile-wpo-c10)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c12)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c12)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c12)
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: library (testfile-cwl-a1) not found
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: attempting to re-install run-time part of library (testfile-cwl-a5)
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: attempting to re-install 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"
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception in compile-whole-program: encountered library (testfile-deja-vu-one) in testfile-deja-vu-dup.wpo, but had already encountered it in testfile-deja-vu-two.wpo
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid situation never; should be one of load, visit, or revisit".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid situation never; should be one of load, visit, or revisit".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid situation #f; should be one of load, visit, or revisit".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input hello: expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input (a . "testdir"): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input #("a" "testdir"): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input hello: expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input (a . "testdir"): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input ("a" . hello): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input ("a" "src" . "obj"): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input ("a" ("src" "obj")): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: invalid input ("a" (("src" "obj"))): expected either a string or a pair of a string and a valid library-directories value".
7.mo:Expected error in mat verify-loadability: "verify-loadability: failed for probably not found: no such file or directory".
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clB1)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clB1)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clC1)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clC1)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: testdir-dist2/testfile-clA.so requires a different compilation instance of (testfile-clB) from the one previously compiled
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: testdir-dist2/testfile-clA.so requires a different compilation instance of (testfile-clB) from the one previously compiled
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: loading testfile-clC.so yielded a different compilation instance of (testfile-clC) from that required by compiled program
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: loading testfile-clC.so yielded a different compilation instance of (testfile-clC) from that required by testfile-clA.so
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: loading testfile-clC.so yielded a different compilation instance of (testfile-clC) from that required by testfile-clA.so
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: loading testdir-dist1/testfile-clB.so yielded a different compilation instance of (testfile-clB) from that required by testdir-dist2/testfile-clA.so
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: testdir-dist2/testfile-clA.so requires a different compilation instance of (testfile-clB) from the one previously compiled
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: incompatible record type Q in testfile-clPE.so
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: testdir-obj/testfile-clH1.so requires a different compilation instance of (testfile-clH0) from the one previously compiled
7.mo:Expected error in mat verify-loadability: "verify-loadability: cannot find object file for library (testfile-clI0)".
7.mo:Expected error in mat verify-loadability: "verify-loadability: cannot find object file for library (testfile-clI0)".
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clJ0)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: library (testfile-clJ0) not found
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-clJ2)
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: library (testfile-clJ2) not found
7.mo:Expected error in mat verify-loadability: "verify-loadability: loading "testfile-clK0.so" did not define library (testfile-clK0)".
7.mo:Expected error in mat verify-loadability: "verify-loadability: visiting "testfile-clK0.so" does not define compile-time information for (testfile-clK0)".
7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: loading testfile-clK0.so did not define library (testfile-clK0)
7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception: library (testfile-catlibA) not found
7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception: library (testfile-catlibA) not found
7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1A)
7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1B)
7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: "hello" is not a symbol".
7.mo:Expected error in mat top-level-value-functions: "incorrect argument count in call (top-level-bound?)".
7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: 45 is not a symbol".
@ -8517,7 +8835,7 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat library1: "attempt to export assigned variable $l1-x".
8.mo:Expected error in mat library1: "attempt to export assigned variable $l1-x".
8.mo:Expected error in mat library1: "library ($l1-ham) not found".
8.mo:Expected error in mat library1: "compiled program requires different compilation instance of (testfile-b2) from one found in testfile-b2.ss".
8.mo:Expected error in mat library1: "loading testfile-b2.ss yielded a different compilation instance of (testfile-b2) from that required by compiled program".
8.mo:Expected error in mat library1: "attempt to reference unbound identifier cons".
8.mo:Expected error in mat library1: "invalid library reference (add-prefix (rnrs eval) x)".
8.mo:Expected error in mat library1: "invalid library reference (drop-prefix (rnrs eval) x)".
@ -8552,15 +8870,36 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat library2: "invalid context for library form (library (foo) (export) (import (scheme)) (library (bar) (export) (import)))".
8.mo:Expected error in mat library2: "invalid context for library form (library (foo) (export) (import))".
8.mo:Expected error in mat library2: "invalid context for library form (library (bar) (export) (import))".
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so and originally imported by (testfile-l7-b1)
8.mo:Expected error in mat library7: "separate-eval: Exception: loading testfile-l7-a1.ss yielded a different compilation instance of (testfile-l7-a1) from that required by compiled (testfile-l7-d1)
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-c1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously compiled
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference (testfile-il1 (<= 3))".
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference (testfile-il1 (what?))".
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference ()".
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference hello".
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference (3 2 1)".
8.mo:Expected error in mat invoke-library: "separate-eval: Exception in invoke-library: library (testfile-il1) version mismatch: want (3) but found (2) at testfile-il1.so
8.mo:Expected error in mat invoke-library: "separate-eval: Exception in invoke-library: library (testfile-il1) version mismatch: want ((>= 3)) but found (2) at testfile-il1.so
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl1.ss did not define library (testfile-ewl1)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl3.ss did not define library (testfile-ewl3)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl4.ss did not define library (testfile-ewl4)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl5.ss did not define library (testfile-ewl5)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl6.ss did not define library (testfile-ewl6)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl1.ss did not define library (testfile-ewl1)".
8.mo:Expected error in mat eval-when-library: "loading testfile-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-directories: invalid path list ("a" . hello)".
8.mo:Expected error in mat library-directories: "library-directories: invalid path list ("a" "src" . "obj")".
8.mo:Expected error in mat library-directories: "library-directories: invalid path-list element ("src")".
8.mo:Expected error in mat library-directories: "library-directories: invalid path-list element ("src" "obj")".
8.mo:Expected error in mat library-directories: "library-directories: invalid path-list element (("src" "obj"))".
8.mo:Expected error in mat library-directories: "library (testfile-ld1) not found".
8.mo:Expected error in mat library-extensions: "library-extensions: invalid extension list \x2E;a1.sls".
8.mo:Expected error in mat library-extensions: "library-extensions: invalid extension-list element (".foo")".
8.mo:Expected error in mat library-extensions: "library-extensions: invalid extension-list element (".foo" ".bar")".
8.mo:Expected error in mat library-extensions: "library-extensions: invalid extension-list element ((".junk"))".
8.mo:Expected error in mat library-search-handler: "default-library-search-handler: "not-symbol" is not a symbol".
8.mo:Expected error in mat library-search-handler: "default-library-search-handler: invalid library name bad-library-name".
8.mo:Expected error in mat library-search-handler: "default-library-search-handler: invalid path list (("invalid" "path" "list"))".
@ -8569,7 +8908,7 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat library-search-handler: "library-search-handler: returned invalid object-file path (bad object path)".
8.mo:Expected error in mat library-search-handler: "library-search-handler: claimed object file was found but returned no object-file path".
8.mo:Expected error in mat top-level-program: "invalid syntax (if (inc 3)) at line 4, char 1 of testfile.ss".
8.mo:Expected error in mat top-level-program: "compiled program requires different compilation instance of (testfile-tlp1) from one already loaded".
8.mo:Expected error in mat top-level-program: "compiled program requires a different compilation instance of (testfile-tlp1) from the one previously compiled".
8.mo:Expected error in mat top-level-program: "read: #<n>(...) vector syntax is not allowed in #!r6rs mode at line 4, char 19 of testfile-tlp1.ss".
8.mo:Expected error in mat top-level-program: "read: #<n>(...) vector syntax is not allowed in #!r6rs mode at line 2, char 31 of testfile-tlp.ss".
8.mo:Expected error in mat top-level-program: "read: #<n>(...) vector syntax is not allowed in #!r6rs mode at line 4, char 19 of testfile-tlp1.ss".
@ -8736,9 +9075,9 @@ fx.mo:Expected error in mat fx=?: "fx=?: (a) is not a fixnum".
fx.mo:Expected error in mat fx=?: "fx=?: <int> is not a fixnum".
fx.mo:Expected error in mat fx=?: "fx=?: <-int> is not a fixnum".
fx.mo:Expected error in mat fx=?: "incorrect argument count in call (fx=? 1)".
fx.mo:Expected error in mat fx<?: "fx<: a is not a fixnum".
fx.mo:Expected error in mat fx<?: "fx<: <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".

9
mats/unix.ms
View File

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

234
release_notes/release_notes.stex
View File

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

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
@ -407,10 +407,10 @@
;;; make-promise and force
(define $make-promise
(define-who $make-promise
(lambda (thunk)
(unless (procedure? thunk)
($oops '$make-promise "~s is not a procedure" thunk))
($oops who "~s is not a procedure" thunk))
(let ([value (void)] [set? #f])
(lambda ()
(case set?
@ -435,8 +435,8 @@
(set! set? 'multiple)
(apply values x)])]))])))))
(define force
(define-who force
(lambda (promise)
(unless (procedure? promise)
($oops 'force "~s is not a procedure" promise))
($oops who "~s is not a procedure" promise))
(promise)))

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)

398
s/5_3.ss
View File

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

225
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 int uptr uptr ptr) ptr))
(define (get-uptr p)
(let ([k (get-u8 p)])
@ -129,7 +129,7 @@
(let ([k (get-u8 p)])
(f k (logor (ash n 7) (fxand k #x7F))))
n))))
(define (malformed p) ($oops 'fasl-read "malformed fasl-object header found in ~s" p))
(define (malformed p) ($oops who "malformed fasl-object header found in ~s" p))
(define (check-header p)
(let ([bv (make-bytevector 8 (constant fasl-type-header))])
(unless (and (eqv? (get-bytevector-n! p bv 1 7) 7)
@ -137,14 +137,14 @@
(malformed p)))
(let ([n (get-uptr p)])
(unless (= n (constant scheme-version))
($oops 'fasl-read "incompatible fasl-object version ~a found in ~s"
($oops who "incompatible fasl-object version ~a found in ~s"
($format-scheme-version n) p)))
(let ([n (get-uptr p)])
(unless (or (= n (constant machine-type-any)) (= n (constant machine-type)))
(cond
[(assv n (constant machine-type-alist)) =>
(lambda (a)
($oops 'fasl-read "incompatible fasl-object machine-type ~s found in ~s"
($oops who "incompatible fasl-object machine-type ~s found in ~s"
(cdr a) p))]
[else (malformed p)])))
(unless (and (eqv? (get-u8 p) (char->integer #\()) ;)
@ -153,42 +153,70 @@
(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
[(or (eqv? ty (constant fasl-type-fasl-size))
(eqv? ty (constant fasl-type-vfasl-size)))
(let ([len (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) len))
(get-bytevector-n p len))
(go1))
(let ([name (port-name p)])
;; fasl-read directly from the port buffer if it has `len`
;; bytes ready, which works for a bytevector port; disable
;; interrupt to make sure the bytes stay available (and
;; `$bv-fasl-read` takes tc-mutex, anyway)
((with-interrupts-disabled
(let ([idx (binary-port-input-index p)])
(cond
[(<= len (fx- (binary-port-input-size p) idx))
(let ([result ($bv-fasl-read (binary-port-input-buffer p) ty
idx len name)])
(set-binary-port-input-index! p (+ idx len))
(lambda () result))]
[else
;; Call `get-bytevector-n`, etc. with interrupts reenabled
(lambda ()
($bv-fasl-read (get-bytevector-n p len) ty 0 len name))])))))))]
[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)]
[(or (eqv? ty (constant fasl-type-fasl-size))
(eqv? ty (constant fasl-type-vfasl-size)))
(let ([len (get-uptr p)]
[name (port-name p)])
;; fasl-read directly from the port buffer if it has `len`
;; bytes ready, which works for a bytevector port; disable
;; interrupt to make sure the bytes stay available (and
;; `$bv-fasl-read` takes tc-mutex, anyway)
((with-interrupts-disabled
(let ([idx (binary-port-input-index p)])
(cond
[(<= len (fx- (binary-port-input-size p) idx))
(let ([result ($bv-fasl-read (binary-port-input-buffer p) ty
idx len name)])
(set-binary-port-input-index! p (+ idx len))
(lambda () result))]
[else
;; Call `get-bytevector-n`, etc. with interrupts reenabled
(lambda ()
($bv-fasl-read (get-bytevector-n p len) ty 0 len name))])))))]
[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)])
@ -202,40 +230,21 @@
(let ()
(define do-load-binary
(lambda (who fn ip situation for-import? results?)
(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)]))))))
(lambda (who fn ip situation for-import? importer)
(let ([load-binary (make-load-binary who fn situation for-import? importer)])
(let ([x (fasl-read ip situation)])
(unless (eof-object? x)
(let loop ([x x])
(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?)
(define (make-load-binary who fn situation for-import? importer)
(module (Lexpand? recompile-info? library/ct-info? library/rt-info? program-info?)
(import (nanopass))
(include "base-lang.ss")
(include "expand-lang.ss"))
(define unexpected-value!
(lambda (x)
($oops who "unexpected value ~s read from ~a" x fn)))
(define run-inner
(lambda (x)
(cond
[(procedure? x) (x)]
[(library/rt-info? x) ($install-library/rt-desc x for-import? fn)]
[(library/ct-info? x) ($install-library/ct-desc x for-import? fn)]
[(program-info? x) ($install-program-desc x)]
[else (unexpected-value! x)])))
(define run-outer
(lambda (x)
(cond
[(recompile-info? x) (void)]
[(revisit-stuff? x) (when (memq situation '(load revisit)) (run-inner (revisit-stuff-inner x)))]
[(visit-stuff? x) (when (memq situation '(load visit)) (run-inner (visit-stuff-inner x)))]
[else (run-inner x)])))
(define run-vector
(lambda (v)
(let ([n (vector-length v)])
@ -245,13 +254,23 @@
(if (fx= i n)
(run-outer x) ; return value(s) of last form for load-compiled-from-port
(begin (run-outer x) (loop i)))))))))
(lambda (x)
(cond
[(vector? x) (run-vector x)]
[(Lexpand? x) ($interpret-backend x situation for-import? fn)]
[else (run-outer x)])))
(define run-outer
(lambda (x)
(cond
[(procedure? x) (x)]
[(library/rt-info? x) ($install-library/rt-desc x for-import? importer fn)]
[(library/ct-info? x) ($install-library/ct-desc x for-import? importer fn)]
[(program-info? x) ($install-program-desc x)]
[(recompile-info? x) (void)]
[(Lexpand? x) ($interpret-backend x situation for-import? importer fn)]
; NB: this is here to support the #t inserted by compile-file-help2 after header information
[(eq? x #t) (void)]
;; for vfasl combinations:
[(vector? x) (run-vector x)]
[else ($oops who "unexpected value ~s read from ~a" x fn)])))
(lambda (x) (run-outer x)))
(define (do-load who fn situation for-import? ksrc)
(define (do-load who fn situation for-import? importer ksrc)
(let ([ip ($open-file-input-port who fn)])
(on-reset (close-port ip)
(let ([fp (let ([start-pos (port-position ip)])
@ -269,11 +288,16 @@
(begin (set-port-position! ip start-pos) 0)))])
(port-file-compressed! ip)
(if ($compiled-file-header? ip)
(do-load-binary who fn ip situation for-import? #f)
(begin
(do-load-binary who fn ip situation for-import? importer)
(close-port ip))
(begin
(when ($port-flags-set? ip (constant port-flag-compressed))
(close-port ip)
($oops who "missing header for compiled file ~s" fn))
(unless ksrc ($oops who "~a is not a compiled file" fn))
(unless ksrc
(close-port ip)
($oops who "~a is not a compiled file" fn))
(unless (eqv? fp 0) (set-port-position! ip 0))
(let ([sfd ($source-file-descriptor fn ip (eqv? fp 0))])
(unless (eqv? fp 0) (set-port-position! ip fp))
@ -282,24 +306,37 @@
(ksrc ip sfd ($make-read ip sfd fp)))))))))
(set! $make-load-binary
(lambda (fn situation for-import?)
(make-load-binary '$make-load-binary fn situation for-import?)))
(lambda (fn)
(make-load-binary '$make-load-binary fn 'load #f #f)))
(set-who! load-compiled-from-port
(lambda (ip)
(unless (and (input-port? ip) (binary-port? ip))
($oops who "~s is not a binary input port" ip))
(do-load-binary who (port-name ip) ip 'load #f #t)))
(do-load-binary who (port-name ip) ip 'load #f #f)))
(set-who! visit-compiled-from-port
(lambda (ip)
(unless (and (input-port? ip) (binary-port? ip))
($oops who "~s is not a binary input port" ip))
(do-load-binary who (port-name ip) ip 'visit #f #f)))
(set-who! revisit-compiled-from-port
(lambda (ip)
(unless (and (input-port? ip) (binary-port? ip))
($oops who "~s is not a binary input port" ip))
(do-load-binary who (port-name ip) ip 'revisit #f #f)))
(set-who! load-program
(rec load-program
(case-lambda
[(fn) (load-program fn eval)]
[(fn ev)
(unless (string? fn) ($oops who "~s is not a string" fn))
(unless (procedure? ev) ($oops who "~s is not a procedure" ev))
(with-source-path who fn
(lambda (fn)
(do-load who fn 'load #f
(do-load who fn 'load #f #f
(lambda (ip sfd do-read)
($set-port-flags! ip (constant port-flag-r6rs))
(let loop ([x* '()])
@ -316,10 +353,11 @@
(case-lambda
[(fn) (load-library fn eval)]
[(fn ev)
(unless (string? fn) ($oops who "~s is not a string" fn))
(unless (procedure? ev) ($oops who "~s is not a procedure" ev))
(with-source-path who fn
(lambda (fn)
(do-load who fn 'load #f
(do-load who fn 'load #f #f
(lambda (ip sfd do-read)
($set-port-flags! ip (constant port-flag-r6rs))
(let loop ()
@ -333,11 +371,11 @@
; like load, but sets #!r6rs mode and does not use with-source-path,
; since syntax.ss load-library has already determined the path.
; adds fn's directory to source-directories
(lambda (fn situation)
(lambda (fn situation importer)
(define who 'import)
(let ([fn (let ([host-fn (format "~a.~s" (path-root fn) (machine-type))])
(if (file-exists? host-fn) host-fn fn))])
(do-load who fn situation #t
(do-load who fn situation #t importer
(lambda (ip sfd do-read)
($set-port-flags! ip (constant port-flag-r6rs))
(parameterize ([source-directories (cons (path-parent fn) (source-directories))])
@ -353,10 +391,11 @@
(case-lambda
[(fn) (load fn eval)]
[(fn ev)
(unless (string? fn) ($oops who "~s is not a string" fn))
(unless (procedure? ev) ($oops who "~s is not a procedure" ev))
(with-source-path who fn
(lambda (fn)
(do-load who fn 'load #f
(do-load who fn 'load #f #f
(lambda (ip sfd do-read)
(let loop ()
(let ([x (do-read)])
@ -366,20 +405,20 @@
(close-port ip)))))])))
(set! $visit
(lambda (who fn)
(do-load who fn 'visit #t #f)))
(lambda (who fn importer)
(do-load who fn 'visit #t importer #f)))
(set! $revisit
(lambda (who fn)
(do-load who fn 'revisit #t #f)))
(lambda (who fn importer)
(do-load who fn 'revisit #t importer #f)))
(set-who! visit
(lambda (fn)
(do-load who fn 'visit #f #f)))
(do-load who fn 'visit #f #f #f)))
(set-who! revisit
(lambda (fn)
(do-load who fn 'revisit #f #f))))
(do-load who fn 'revisit #f #f #f))))
(let ()
(module sstats-record (make-sstats sstats? sstats-cpu sstats-real

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))'\
@ -567,7 +590,7 @@ examples:
( cd ../examples && ${MAKE} all Scheme="${Scheme} ../s/${patchfile}" )
prettyclean:
rm -f *.$m xpatch ${patch} *.patch *.so *.asm script.all header.tmp *.html
rm -f *.$m xpatch ${patch} *.patch *.so *.covin *.asm script.all header.tmp *.html
rm -rf nanopass
profileclean: prettyclean

7
s/back.ss
View File

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

62
s/cmacros.ss
View File

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

1459
s/compile.ss
View File

File diff suppressed because it is too large Load Diff

9
s/cp0.ss
View File

@ -2866,7 +2866,8 @@
(and (okay-to-handle?)
(visit-and-maybe-extract* bytevector? ([dx x])
(visit-and-maybe-extract* (lambda (y)
(and (exact? y)
(and (integer? y)
(exact? y)
(nonnegative? y)
(= (modulo y align) 0)))
([dy y])
@ -4838,13 +4839,17 @@
(and likely-to-be-compiled?
(cp0
(let* ([tc (cp0-make-temp #t)] [ref-tc (build-ref tc)])
; if the free variables of the closure created for a guardian changes, the code
; for unregister-guardian in prims.ss might also need to be updated
(build-lambda formal*
(build-let (list tc)
(list (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
(let ([zero `(quote 0)])
(build-let (list x) (list (build-primcall 3 'cons (list zero zero)))
(build-primcall 3 'cons (list ref-x ref-x))))))
(build-case-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt) (app-name ctxt))
(build-case-lambda (let ([preinfo (preinfo-call->preinfo-lambda (app-preinfo ctxt) (app-name ctxt))])
(make-preinfo-lambda (preinfo-src preinfo) (preinfo-sexpr preinfo) #f #f
(constant code-flag-guardian)))
(cons
(list '()
(let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])

24
s/cpnanopass.ss
View File

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

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
@ -310,4 +312,13 @@
[(clause (,x* ...) ,interface ,body)
(for-each initialize-id! x*)
`(clause (,x* ...) ,interface ,(Expr body))]))
(Lexpand-to-go x cpcheck-prelex-flags))))
(Lexpand-to-go x cpcheck-prelex-flags)))
(set-who! $insert-profile-src! ; called from compiler only
(lambda (st x)
; NB: the output should be *, but nanopass won't autogenerate the pass
(define-pass record-coverage-info! : Lsrc (ir) -> Lsrc ()
(Expr : Expr (ir) -> Expr ()
[(profile ,src) (source-table-set! st src 0) `(profile ,src)]))
(Lexpand-to-go x record-coverage-info!)))
)

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

30
s/expand-lang.ss
View File

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

44
s/fasl.ss
View File

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

16
s/interpret.ss
View File

@ -666,7 +666,7 @@
($cptypes x))
x)
(define-pass interpret-Lexpand : Lexpand (ir situation for-import? ofn eoo) -> * (val)
(define-pass interpret-Lexpand : Lexpand (ir situation for-import? importer ofn eoo) -> * (val)
(definitions
(define (ibeval x1)
($rt (parameterize ([$target-machine (machine-type)] [$sfd #f])
@ -694,16 +694,16 @@
(ibeval ($build-install-library/ct-code uid export-id* import-code visit-code))]
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
(ibeval ($build-install-library/rt-code uid dl* db* dv* de* body))]
[,linfo/rt ($install-library/rt-desc linfo/rt for-import? ofn)]
[,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? importer ofn)]
[(library/ct-info ,linfo/ct) ($install-library/ct-desc linfo/ct for-import? importer ofn)]
[(program-info ,pinfo) ($install-program-desc pinfo)]
[else (sorry! who "unexpected language form ~s" ir)])
(Outer : Outer (ir) -> * (val)
; can't use cata since (Outer outer1) might return 0 or more than one value
[(group ,outer1 ,outer2) (Outer outer1) (Outer outer2)]
[(visit-only ,inner) (unless (eq? situation 'revisit) (Inner inner))]
[(revisit-only ,inner) (unless (eq? situation 'visit) (Inner inner))]
[,rcinfo (void)]
[(recompile-info ,rcinfo) (void)]
[,inner (Inner inner)]
[else (sorry! who "unexpected language form ~s" ir)])
(Outer ir))
@ -725,11 +725,11 @@
($uncprep x1 #t) ; populate preinfo sexpr fields
(when (and (expand-output) (not ($noexpand? x0)))
(pretty-print ($uncprep x1) (expand-output)))
(interpret-Lexpand x1 'load #f #f (and (not ($noexpand? x0)) (expand/optimize-output))))])))
(interpret-Lexpand x1 'load #f #f #f (and (not ($noexpand? x0)) (expand/optimize-output))))])))
(set! $interpret-backend
(lambda (x situation for-import? ofn)
(interpret-Lexpand x situation for-import? ofn (expand/optimize-output))))
(lambda (x situation for-import? importer ofn)
(interpret-Lexpand x situation for-import? importer ofn (expand/optimize-output))))
)
(current-eval interpret)

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

4
s/library.ss
View File

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

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

139
s/primdata.ss
View File

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

33
s/prims.ss
View File

@ -84,6 +84,11 @@
()
scheme-object))
(define $dequeue-scheme-signals
(foreign-procedure "(cs)dequeue_scheme_signals"
(ptr)
ptr))
(define-who $show-allocation
(let ([fp (foreign-procedure "(cs)s_showalloc" (boolean string) void)])
(case-lambda
@ -1544,6 +1549,28 @@
; tconc is assumed to be valid at all call sites
(#3%$install-ftype-guardian obj tconc)))
(define guardian?
(lambda (g)
(#3%guardian? g)))
(define-who unregister-guardian
(let ([fp (foreign-procedure "(cs)unregister_guardian" (scheme-object) scheme-object)])
(define probable-tconc? ; full tconc? could be expensive ...
(lambda (x)
(and (pair? x) (pair? (car x)) (pair? (cdr x)))))
(lambda (g)
(unless (guardian? g) ($oops who "~s is not a guardian" g))
; at present, guardians should have either one free variable (the tcond) or two(the tconc and an ftd)
; but we just look for a probable tconc among whatever free variables it has
(fp (let ([n ($code-free-count ($closure-code g))])
(let loop ([i 0])
(if (fx= i n)
($oops #f "failed to find a tconc among the free variables of guardian ~s" g)
(let ([x ($closure-ref g i)])
(if (probable-tconc? x)
x
(loop (fx+ i 1)))))))))))
(define-who $ftype-guardian-oops
(lambda (ftd obj)
($oops 'ftype-guardian "~s is not an ftype pointer of the expected type ~s" obj ftd)))
@ -1870,9 +1897,9 @@
(define-tc-parameter $sfd (lambda (x) (or (eq? x #f) (source-file-descriptor? x))) "a source-file descriptor or #f" #f)
(define-tc-parameter $current-mso (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f)
(define-tc-parameter $target-machine symbol? "a symbol")
(define-tc-parameter optimize-level (lambda (x) (and (fixnum? x) (fx<= 0 x 3))) "valid optimize level" 0)
(define-tc-parameter $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?

993
s/syntax.ss
View File

File diff suppressed because it is too large Load Diff

8
s/x86_64.ss
View File

@ -3495,10 +3495,10 @@
'()
'())]
[else
(values(lambda (x)
`(set! ,%Cretval ,x))
(list %Cretval)
'())]))
(values (lambda (x)
`(set! ,%Cretval ,x))
(list %Cretval)
'())]))
(define (unactivate result-regs)
(let ([e `(seq
(set! ,%Carg1 ,(%mref ,%sp ,(+ (push-registers-size result-regs) (if-feature windows 72 176))))

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