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

committing a handful of changes, none of which should be particularly

Browse Source 
controversial, unless I damaged something in the process of integrating
them with other recent changes.  the user's guide and release notes
have been updated as well to reflect the changes of interest to end
users.
- the body of load-library is now wrapped in a $pass-time with
  to show the time spent loading libraries separately from the time
  spent in expand.
    syntax.ss
- interpret now plays the pass-time game
    interpret.ss
- added compile-time-value? predicate and
  compile-time-value-value accessor
    syntax.ss, primdata.ss,
    8.ms, primvars.ms, root-experr*
- $pass-stats now returns accurrate stats for the currently timed
  pass.
    7.ss
- compile-whole-program and compile-whole-library now propagate
  recompile info from the named wpo file to the object file
  to support maybe-compile-program and maybe-compile-library in
  the case where compile-whole-{program,library} overwrites the
  original object file.
    compile.ss,
    7.ms, mat.ss, primvars.ms
- replaced the ancient and unusable bintar with one that creates
  a useful tarball for binary installs
    bintar
- generated Mf-install InstallBin (InstallLib, InstallMan) now
  correctly indirects through InstallPrefix if the --installbin
  (--installlib, --installman) configure flag is not present.
    src/configure
- removed definition of generate-procedure-source-information
    patch.ss
- guardian tconc cells are now allocated in generation 0 in the hope
  that they can be released more quickly.
    gc.c
- added ftype-guardian syntax: (ftype-guardian A) creates a new
  guardian for ftype pointers of type A, the first base field (or
  one of the first base fields in the case of unions) of which must
  be a word-sized integer with native endianness representing a
  reference count.  ftype pointers are registered with and retrieved
  from the guardian just like objects are registered with and
  retrieved from any guardian.  the difference is that the garbage
  collector decrements the reference count before resurrecting an
  ftype pointer and resurrects only those whose reference counts
  become zero, i.e., are ready for deallocation.
    ftype.ss, cp0.ss, cmacros.ss, cpnanopass.ss, prims.ss, primdata.ss,
    gc.c,
    4.ms, root-experr*
- fixed a bug in automatic recompilation handling of missing include
  files specified with absolute pathnames or pathnames starting with
  "./" or "..": was erroring out in file-modification-time with a
  file-not-found or other exception rather than recompiling.
    syntax.ss,
    7.ms, root-experr*, patch*
- changed inline vector-for-each and string-for-each code to
  put the last call to the procedure in tail position, as was
  already done for the library definitions and for the inline
  code for for-each.
    cp0.ss,
    5_4.ms, 5_6.ms
- the compiler now generates better inline code for the bytevector
  procedure.  instead of one byte memory write for each argument,
  it writes up to 4 (32-bit machines) or 8 (64-bit machines) bytes
  at a time, which almost always results in fewer instructions and
  fewer writes.
    cpnanopass.ss,
    bytevector.ms
- packaged unchanging implicit reader arguments into a single record
  to reduce the number of arguments.
    read.ss
- recoded run-vector to handle zero-length vectors.  it appears
  we're not presently generating empty vectors (representing empty
  groups), but the fasl format permits them.
    7.ss

original commit: 7be1d190de7171f74a1ee71e348d3e6310392686
This commit is contained in:
dyb 2019-02-11 20:06:42 -08:00
parent 273aad6342
commit 2daf225cab
35 changed files with 2093 additions and 795 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
LOG
View File

@ -1061,3 +1061,74 @@
newhash.ss, primdata.ss,
hash.ms, root-experr*, patch*,
objects.stex, release_notes.stex
- the body of load-library is now wrapped in a $pass-time with
to show the time spent loading libraries separately from the time
spent in expand.
syntax.ss
- interpret now plays the pass-time game
interpret.ss
- added compile-time-value? predicate and
compile-time-value-value accessor
syntax.ss, primdata.ss,
8.ms, primvars.ms, root-experr*
- $pass-stats now returns accurrate stats for the currently timed
pass.
7.ss
- compile-whole-program and compile-whole-library now propagate
recompile info from the named wpo file to the object file
to support maybe-compile-program and maybe-compile-library in
the case where compile-whole-{program,library} overwrites the
original object file.
compile.ss,
7.ms, mat.ss, primvars.ms
- replaced the ancient and unusable bintar with one that creates
a useful tarball for binary installs
bintar
- generated Mf-install InstallBin (InstallLib, InstallMan) now
correctly indirects through InstallPrefix if the --installbin
(--installlib, --installman) configure flag is not present.
src/configure
- removed definition of generate-procedure-source-information
patch.ss
- guardian tconc cells are now allocated in generation 0 in the hope
that they can be released more quickly.
gc.c
- added ftype-guardian syntax: (ftype-guardian A) creates a new
guardian for ftype pointers of type A, the first base field (or
one of the first base fields in the case of unions) of which must
be a word-sized integer with native endianness representing a
reference count. ftype pointers are registered with and retrieved
from the guardian just like objects are registered with and
retrieved from any guardian. the difference is that the garbage
collector decrements the reference count before resurrecting an
ftype pointer and resurrects only those whose reference counts
become zero, i.e., are ready for deallocation.
ftype.ss, cp0.ss, cmacros.ss, cpnanopass.ss, prims.ss, primdata.ss,
gc.c,
4.ms, root-experr*
- fixed a bug in automatic recompilation handling of missing include
files specified with absolute pathnames or pathnames starting with
"./" or "..": was erroring out in file-modification-time with a
file-not-found or other exception rather than recompiling.
syntax.ss,
7.ms, root-experr*, patch*
- changed inline vector-for-each and string-for-each code to
put the last call to the procedure in tail position, as was
already done for the library definitions and for the inline
code for for-each.
cp0.ss,
5_4.ms, 5_6.ms
- the compiler now generates better inline code for the bytevector
procedure. instead of one byte memory write for each argument,
it writes up to 4 (32-bit machines) or 8 (64-bit machines) bytes
at a time, which almost always results in fewer instructions and
fewer writes.
cpnanopass.ss,
bytevector.ms
- packaged unchanging implicit reader arguments into a single record
to reduce the number of arguments.
read.ss
- recoded run-vector to handle zero-length vectors. it appears
we're not presently generating empty vectors (representing empty
groups), but the fasl format permits them.
7.ss

146
bintar
View File

@ -1,89 +1,73 @@
#! /bin/csh -f
if ($#argv < 3) then
echo "Usage: $BINTAR <release> <dist-type> <machine-type1> <machine-type2> ..."
exit(1)
endif
set release = $argv[1]
if (!(-d $release)) then
echo Release $release does not exist or is not a directory
exit(1)
set T = "."
if ("$argv[1]" == "--target-dir") then
set T = "$argv[2]"
shift
shift
endif
switch ($argv[2])
case tar.gz:
if (!($?tarfile)) set tarfile = "$release"
foreach x ($argv[3-])
set tarfile = "$tarfile"-$x
end
set tarfile = "$tarfile".tar.gz
alias command 'tar -chf - \!* | gzip -c >' $tarfile
if ($#argv != 2 && $#argv != 3) then
echo "Usage: $0 [ --target-dir <target-directory> ] <release> <machine-type> [ <workarea> ]"
exit 1
endif
set R = $argv[1]
set M = $argv[2]
if ($#argv == 2) then
set W = $M
else
set W = $argv[3]
endif
if (!(-d $W)) then
echo "Error: work area $W does not exist or is not a directory"
exit 1
endif
if (!(-e $W/boot/$M)) then
echo "Error: "$
exit 1
endif
if (-e $R) then
echo "Error: $R already exists"
exit 1
endif
onintr error
mkdir $R || goto error
( cd $R ; ln -s ../LICENSE ../NOTICE . ) || goto error
( cd $R ; ln -s ../$W/scheme.1.in ../$W/installsh ../$W/examples . ) || goto error
( cd $R ; ln -s ../$W/Mf-install Makefile ) || goto error
mkdir -p $R/boot/$M $R/bin/$M || goto error
( cd $R/boot/$M ; ln -s ../../../$W/boot/$M/{scheme.h,petite.boot,scheme.boot} . ) || goto error
switch ($M)
case a6nt:
case ta6nt:
case ti3nt:
case i3nt:
( cd $R/boot/$M ; ln -s ../../../$W/boot/$M/{csv951md.lib,csv951mt.lib,mainmd.obj,mainmt.obj,scheme.res} . ) || goto error
( cd $R/bin/$M ; ln -s ../../../$W/bin/$M/{scheme.exe,csv951.dll,csv951.lib,vcruntime140.lib} . ) || goto error
breaksw
default:
( cd $R/boot/$M ; ln -s ../../../$W/boot/$M/{main.o,kernel.o} . ) || goto error
( cd $R/bin/$M ; ln -s ../../../$W/bin/$M/{scheme} . ) || goto error
breaksw
default
echo Unknown target $argv[2]
exit(1)
endsw
set files = ()
set files = ($files $release/{Notice,ReadMe})
set files = ($files $release/License)
set files = ($files $release/examples/*)
set files = ($files $release/custom/{ReadMe,custom.c})
set files = ($files $release/custom/{crepl.c,sample.c,sample.ss})
foreach m ($argv[3-])
set files = ($files $release/boot/$m/scheme.h)
set files = ($files $release/boot/$m/petite.boot)
set files = ($files $release/boot/$m/scheme.boot)
switch ($m)
case a6nt:
case ta6nt:
case ti3nt:
case i3nt:
set files = ($files $release/bin/$m/scheme.exe)
set files = ($files $release/bin/$m/csv951.dll)
set files = ($files $release/bin/$m/csv951.lib)
set files = ($files $release/bin/$m/vcruntime140.dll)
set files = ($files $release/boot/$m/csv951md.lib)
set files = ($files $release/boot/$m/csv951mt.lib)
set files = ($files $release/boot/$m/custommd.obj)
set files = ($files $release/boot/$m/custommt.obj)
set files = ($files $release/boot/$m/scheme.res)
set files = ($files $release/custom/Makefile.$m)
breaksw
default:
set files = ($files $release/bin/$m/scheme)
set files = ($files $release/boot/$m/custom.o)
set files = ($files $release/boot/$m/kernel.o)
set files = ($files $release/custom/Mf-$m)
if (! $?custom_make) then
set files = ($files $release/custom/{configure,Makefile.in,Mf-none,Mf-install.in,installsh})
set files = ($files $release/custom/scheme.1.in)
set custom_make
endif
breaksw
endsw
end
if ($?INTERACTIVE) then
ls -lL $files | more -10
askokay:
echo -n "Okay? (y/n) [y]: "
set ans = $<
if ("$ans" == "n") exit(1)
if ("$ans" != "" && "$ans" != "y") goto askokay
again:
echo "Command Alias:"
alias command
echo -n "Okay? (y/n) [y]: "
set ans = $<
if ("$ans" != "" && "$ans" != "y") then
if ("$ans" == "n") then
echo -n "Enter appropriate command: "
alias command "$<"
endif
goto again
endif
set broken = `find -L $R -type l`
if ($#broken != 0) then
echo "Error: missing $broken"
goto error
endif
command $files
tar -czhf $T/csv$R-$M.tar.gz $R || goto error
rm -rf $R
exit
error:
rm -rf $R
exit 1

13
c/gc.c
View File

@ -916,6 +916,17 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) {
ptr old_end, new_end;
rep = GUARDIANREP(ls);
/* ftype_guardian_rep is a marker for reference-counted ftype pointer */
if (rep == ftype_guardian_rep) {
int b; uptr *addr;
rep = GUARDIANOBJ(ls);
if (FWDMARKER(rep) == forward_marker) rep = FWDADDRESS(rep);
/* Caution: Building in assumption about shape of an ftype pointer */
addr = RECORDINSTIT(rep, 0);
LOCKED_DECR(addr, b);
if (!b) continue;
}
relocate(&rep);
/* if tconc was old it's been forwarded */
@ -923,7 +934,7 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) {
old_end = Scdr(tconc);
/* allocating pair in tg means it will be swept, which is wasted effort, but should cause no harm */
new_end = S_cons_in(space_impure, tg, FIX(0), FIX(0));
new_end = S_cons_in(space_impure, 0, FIX(0), FIX(0));
#ifdef ENABLE_OBJECT_COUNTS
S_G.countof[tg][countof_pair] += 1;
#endif /* ENABLE_OBJECT_COUNTS */

6
configure vendored
View File

@ -249,15 +249,15 @@ if [ "$w" = "" ] ; then
fi
if [ "$installbin" = "" ] ; then
installbin=$installprefix/bin
installbin='${InstallPrefix}/bin'
fi
if [ "$installlib" = "" ] ; then
installlib=$installprefix/lib
installlib='${InstallPrefix}/lib'
fi
if [ "$installman" = "" ] ; then
installman=$installprefix/$installmansuffix
installman='${InstallPrefix}'/$installmansuffix
fi
if [ "$disablex11" = "no" ] ; then

26
csug/syntax.stex
View File

@ -629,6 +629,32 @@ prec ;=> \var{exception: invalid syntax prec}
\endschemedisplay
%----------------------------------------------------------------------------
\entryheader
\formdef{compile-time-value?}{\categoryprocedure}{(compile-time-value? \var{obj})}
\returns \scheme{#t} if \var{obj} is a compile-time value; \scheme{#f} otherwise
\listlibraries
\endentryheader
\schemedisplay
(define-syntax x (make-compile-time-value "eggs"))
(compile-time-value? (top-level-syntax 'x)) ;=> #t
\endschemedisplay
%----------------------------------------------------------------------------
\entryheader
\formdef{compile-time-value-value}{\categoryprocedure}{(compile-time-value-value \var{ctv})}
\returns the value of a compile-time value
\listlibraries
\endentryheader
\schemedisplay
(define-syntax x (make-compile-time-value "eggs"))
(compile-time-value-value (top-level-syntax 'x)) ;=> "eggs"
\endschemedisplay
%----------------------------------------------------------------------------
\entryheader
\formdef{define-property}{\categorysyntax}{(define-property \var{id} \var{key} \var{expr})}

112
csug/threads.stex
View File

@ -406,6 +406,118 @@ the specified field, subtracts $1$ from the value, and writes the new
value back into the field.
Both return \scheme{#t} if the new value is 0, otherwise \scheme{#f}.
\section{Reference counting with ftype guardians\label{SECTTHREADFTYPEGUARDIANS}}
\index{\scheme{ftype-guardian}}%
Applications that manage memory outside the Scheme heap can leverage
the Scheme storage management system to help perform reference
counting via \emph{ftype guardians}.
In a reference-counted memory management system, each object holds
a count of pointers to it.
The count is incremented when a new pointer is created and decremented
when a pointer is dropped.
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.
\entryheader
\formdef{ftype-guardian}{\categorysyntax}{(ftype-guardian \var{ftype-name})}
\returns a new ftype guardian
\listlibraries
\endentryheader
\var{ftype-name} must name an ftype.
The first base field of the ftype (or one of the first base fields
in the case of unions) must be a word-sized integer (iptr or uptr)
with native endianness.
This field is assumed to hold a reference count.
The return value is a new ftype guardian \var{g}, with which
ftype-pointers of type \var{ftype-name} (or some subtype of
\var{ftype-name}) can be registered.
An ftype pointer is registered with \var{g} by invoking \var{g}
with the ftype pointer as an argument.
An ftype guardian does not automatically protect from collection
the ftype pointers registered with it, as a normal guardian would
do.
Instead, for each registered ftype pointer that becomes inaccessible
via normal (non-weak, non-guardian pointers), the guardian decrements
the reference count of the object to which the ftype pointer points.
If the resulting reference-count value is zero, the ftype pointer
is preserved and can be retrieved from the guardian.
If the resulting reference-count value is non-zero, however, the
ftype pointer is not preserved.
Objects retrieved from an ftype guardian (by calling it without
arguments) are guaranteed to have zero reference counts, assuming
reference counts are maintained properly by code outside the
collector.
The collector decrements the reference count using the equivalent
of \index{\scheme{ftype-locked-decr!}}\scheme{ftype-locked-decr!}
to support systems in which non-Scheme objects are stored in memory
shared by multiple processes.
In such systems, programs should themselves use
\index{\scheme{ftype-locked-incr!}}\scheme{ftype-locked-incr!} and
\scheme{ftype-locked-decr!} or non-Scheme equivalents (e.g., the C
\index{\scheme{LOCKED_INCR}}\scheme{LOCKED_INCR} and
\index{\scheme{LOCKED_INCR}}\scheme{LOCKED_DECR} macros in scheme.h,
which are described in Section~\ref{SECTFOREIGNCLIB}) to maintain
reference counts.
The following example defines a simple ftype and an allocator for
objects of that ftype that frees any objects of that ftype that were
previously allocated and no longer accessible.
\schemedisplay
(module (A make-A free-dropped-As)
(define-ftype A
(struct
[refcount uptr]
[data int]))
(define g (ftype-guardian A))
(define free-dropped-As
(lambda ()
(let ([a (g)])
(when a
(printf "freeing ~s\n" (ftype-ref A (data) a))
(foreign-free (ftype-pointer-address a))
(free-dropped-As)))))
(define make-A
(lambda (n)
(free-dropped-As)
(let ([a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A)))])
(ftype-set! A (refcount) a 1)
(ftype-set! A (data) a n)
(g a)
a))))
\endschemedisplay
We can test this by allocating, dropping, and immediately collecting
ftype pointers to A.
\schemedisplay
> (do ([i 10 (fx- i 1)])
((fx= i 0))
(make-A i)
(collect))
freeing 10
freeing 9
freeing 8
freeing 7
freeing 6
freeing 5
freeing 4
freeing 3
freeing 2
> (free-dropped-As)
freeing 1
\endschemedisplay
Objects guarded by an ftype guardian might contain pointers to other
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}}

141
mats/4.ms
View File

@ -3470,6 +3470,147 @@
#t)
)
(mat refcount-guardians
(error? ; unrecognized ftype
(ftype-guardian NO!))
(error? ; first element must be a word-sized integer with native endianness
(let ()
(define-ftype A (struct))
(ftype-guardian A)))
(error? ; first element must be a word-sized integer with native endianness
(let ()
(define-ftype A (union [u1 (struct (refcount char))] [u2 (struct (foo (* A)))]))
(ftype-guardian A)))
(error? ; invalid ftype-guardian argument
(let ()
(define-ftype A (struct (refcount iptr) (x int)))
(define g (ftype-guardian A))
(g (cons 'ka 'blooie))))
(error? ; invalid ftype-guardian argument
(let ()
(define-ftype A (struct (refcount iptr) (x int)))
(define g (ftype-guardian A))
(g (make-ftype-pointer iptr 0))))
(eq?
(let ()
(define-ftype A (struct (refcount iptr) (x int)))
(define g (ftype-guardian iptr))
(g (make-ftype-pointer A 0)))
(void))
(with-interrupts-disabled
(let ()
(define-ftype A (struct (refcount iptr) (x int)))
(define g (ftype-guardian A))
(define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
(ftype-set! A (refcount) a 0)
(assert (not (ftype-locked-incr! A (refcount) a)))
(assert (eqv? (ftype-ref A (refcount) a) 1))
(g a)
(set! a #f)
(collect 0 0)
(assert (eqv? (ftype-ref A (refcount) (g)) 0))
(assert (not (g)))
#t))
(with-interrupts-disabled
(let ()
(define-ftype A (struct (refcount uptr) (x int)))
(define g (ftype-guardian A))
(define addr (foreign-alloc (ftype-sizeof A)))
(define a1 (make-ftype-pointer A addr))
(define a2 (make-ftype-pointer A addr))
(define wpa1 (weak-cons a1 '()))
(define wpa2 (weak-cons a2 '()))
(ftype-set! A (refcount) a1 0)
(ftype-set! A (x) a1 17)
(assert (eqv? (ftype-ref A (x) a1) 17))
(assert (eqv? (ftype-ref A (x) a2) 17))
(assert (eqv? (ftype-ref A (refcount) a1) 0))
(assert (eqv? (ftype-ref A (refcount) a2) 0))
(assert (not (ftype-locked-incr! A (refcount) a1)))
(assert (not (ftype-locked-incr! A (refcount) a2)))
(assert (eqv? (ftype-ref A (refcount) a1) 2))
(assert (eqv? (ftype-ref A (refcount) a2) 2))
(g a1)
(g a2)
(collect 0 0)
(assert (not (g)))
(set! a1 #f)
(collect 0 0)
(assert (not (g)))
(set! a2 #f)
(collect 0 0)
(set! a2 (g))
(assert (eq? (car wpa2) a2))
(assert (not (g)))
(assert (eqv? (ftype-ref A (refcount) a2) 0))
#t))
(with-interrupts-disabled
(let ()
(define-ftype A (struct (refcount iptr) (x int)))
(define g (ftype-guardian A))
(define regular-g (make-guardian))
(define addr (foreign-alloc (ftype-sizeof A)))
(define a (make-ftype-pointer A addr))
(ftype-set! A (refcount) a 0)
(assert (not (ftype-locked-incr! A (refcount) a)))
(assert (eqv? (ftype-ref A (refcount) a) 1))
(regular-g a)
(g a)
(regular-g a)
(set! a #f)
(collect 0 0)
(assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
(assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
(assert (eqv? (ftype-ref A (refcount) (g)) 0))
(assert (not (regular-g)))
(assert (not (g)))
#t))
(with-interrupts-disabled
(let ()
(define-ftype A (struct (refcount uptr) (x int)))
(define g (ftype-guardian A))
(define regular-g (make-guardian))
(define addr (foreign-alloc (ftype-sizeof A)))
(define a (make-ftype-pointer A addr))
(ftype-set! A (refcount) a 0)
(assert (not (ftype-locked-incr! A (refcount) a)))
(assert (not (ftype-locked-incr! A (refcount) a)))
(assert (eqv? (ftype-ref A (refcount) a) 2))
(regular-g a)
(g a)
(regular-g a)
(set! a #f)
(collect 0 0)
(assert (eqv? (ftype-ref A (refcount) (regular-g)) 1))
(assert (eqv? (ftype-ref A (refcount) (regular-g)) 1))
(assert (not (regular-g)))
(assert (not (g)))
#t))
(with-interrupts-disabled
(let ()
(define-ftype A (struct (refcount iptr) (x int)))
(define g (ftype-guardian A))
(define regular-g (make-guardian))
(define addr (foreign-alloc (ftype-sizeof A)))
(define a (make-ftype-pointer A addr))
(ftype-set! A (refcount) a 0)
(assert (not (ftype-locked-incr! A (refcount) a)))
(assert (not (ftype-locked-incr! A (refcount) a)))
(assert (eqv? (ftype-ref A (refcount) a) 2))
(regular-g a)
(g a)
(g a)
(regular-g a)
(set! a #f)
(collect 0 0)
(assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
(assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
(assert (eqv? (ftype-ref A (refcount) (g)) 0))
(assert (not (regular-g)))
(assert (not (g)))
#t))
)
(mat weak-cons
(procedure? weak-cons)
(procedure? weak-pair?)

34
mats/5_4.ms
View File

@ -927,6 +927,40 @@
"apkf1" "bqlg2" "crmh3" "dsni4" "etoj5" "uapkf1"
"vbqlg2" "wcrmh3" "xdsni4" "yetoj5" "aupkf1" "bvqlg2"
"cwrmh3" "dxsni4" "eytoj5"))
; check for proper tail recursion
(equal?
(list
(let ([s (statistics)])
(let ([k 100000] [str "abc"])
(let ([n k] [m 0])
(define (f) (unless (fx= n 0) (string-for-each foo str)))
(define (foo x)
(set! m (+ m 1))
(when (char=? x (string-ref str (fx- (string-length str) 1)))
(set! n (- n 1))
(f)
17)) ; blow tail recursion here
(f)
(list (> (sstats-bytes (sstats-difference (statistics) s))
10000)
(eqv? n 0)
(eqv? m (* k (string-length str)))))))
(let ([s (statistics)])
(let ([k 100000] [str "abc"])
(let ([n k] [m 0])
(define (f) (unless (fx= n 0) (string-for-each foo str)))
(define (foo x)
(set! m (+ m 1))
(when (char=? x (string-ref str (fx- (string-length str) 1)))
(set! n (- n 1))
(f)))
(f)
(list (<= 0
(sstats-bytes (sstats-difference (statistics) s))
1000)
(eqv? n 0)
(eqv? m (* k (string-length str))))))))
'((#t #t #t) (#t #t #t)))
)
(mat string-xcase-errors

34
mats/5_6.ms
View File

@ -1008,6 +1008,40 @@
(u a p k f 1) (v b q l g 2) (w c r m h 3) (x d s n i 4)
(y e t o j 5) (a u p k f 1) (b v q l g 2) (c w r m h 3)
(d x s n i 4) (e y t o j 5)))
; check for proper tail recursion
(equal?
(list
(let ([s (statistics)])
(let ([k 100000] [v '#(a b c)])
(let ([n k] [m 0])
(define (f) (unless (fx= n 0) (vector-for-each foo v)))
(define (foo x)
(set! m (+ m 1))
(when (eq? x (vector-ref v (fx- (vector-length v) 1)))
(set! n (- n 1))
(f)
17)) ; blow tail recursion here
(f)
(list (> (sstats-bytes (sstats-difference (statistics) s))
10000)
(eqv? n 0)
(eqv? m (* k (vector-length v)))))))
(let ([s (statistics)])
(let ([k 100000] [v '#(a b c)])
(let ([n k] [m 0])
(define (f) (unless (fx= n 0) (vector-for-each foo v)))
(define (foo x)
(set! m (+ m 1))
(when (eq? x (vector-ref v (fx- (vector-length v) 1)))
(set! n (- n 1))
(f)))
(f)
(list (<= 0
(sstats-bytes (sstats-difference (statistics) s))
1000)
(eqv? n 0)
(eqv? m (* k (vector-length v))))))))
'((#t #t #t) (#t #t #t)))
)
(define $merge-sort

428
mats/7.ms
View File

@ -286,19 +286,6 @@
)
(mat maybe-compile
(begin
(define touch
(lambda (objfn srcfn)
(let loop ()
(let ([p (open-file-input/output-port srcfn (file-options no-fail no-truncate))])
(put-u8 p (lookahead-u8 p))
(close-port p))
(when (file-exists? objfn)
(unless (time>? (file-modification-time srcfn) (file-modification-time objfn))
(sleep (make-time 'time-duration 1000000 1))
(loop))))
#t))
#t)
(error? ; not a procedure
(compile-program-handler 'ignore))
(procedure? (compile-program-handler))
@ -783,25 +770,15 @@
"testdir/testfile-mc-1b")
#t)
(error? ; can't find testfile-mc-1a.ss
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so"))])
(separate-compile 'maybe-compile-library "testdir/testfile-mc-1b")
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testdir/testfile-mc-1b.so"))
mt*)))
; make sure maybe-compile-file doesn't wipe out b.so when it fails to find a.ss
(file-exists? "testdir/testfile-mc-1b.so")
(equal?
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so"))])
(separate-compile '(lambda (x)
(parameterize ([source-directories (cons "testdir" (source-directories))])
(maybe-compile-library x)))
"testdir/testfile-mc-1b")
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testdir/testfile-mc-1b.so"))
mt*))
'(=))
(separate-compile 'maybe-compile-library "testdir/testfile-mc-1b"))
; make sure maybe-compile-file wipes out b.so when it fails to find a.ss
(or (= (optimize-level) 3) (not (file-exists? "testdir/testfile-mc-1b.so")))
(begin
(separate-compile '(lambda (x)
(parameterize ([source-directories (cons "testdir" (source-directories))])
(maybe-compile-library x)))
"testdir/testfile-mc-1b")
#t)
(touch "testdir/testfile-mc-1b.so" "testdir/testfile-mc-1a.ss")
(equal?
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so"))])
@ -828,17 +805,12 @@
'(>))
(delete-file "testdir/testfile-mc-1a.ss")
(error? ; maybe-compile-library: can't find testfile-mc-1a.ss
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so"))])
(separate-compile '(lambda (x)
(parameterize ([source-directories (cons "testdir" (source-directories))])
(maybe-compile-library x)))
"testdir/testfile-mc-1b")
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testdir/testfile-mc-1b.so"))
mt*)))
; make sure maybe-compile-file doesn't wipe out b.so when it fails to find a.ss
(file-exists? "testdir/testfile-mc-1b.so")
(separate-compile '(lambda (x)
(parameterize ([source-directories (cons "testdir" (source-directories))])
(maybe-compile-library x)))
"testdir/testfile-mc-1b"))
; make sure maybe-compile-file wipes out b.so when it fails to find a.ss
(or (= (optimize-level) 3) (not (file-exists? "testdir/testfile-mc-1b.so")))
(begin
(rm-rf "testdir")
#t)
@ -883,6 +855,170 @@
(close-port p))
(display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [compile-compressed #f] [import-notify #t]) (maybe-compile-program x))) 'mc-2))
#t)
; make sure maybe-compile-file handles missing include files gracefully
(begin
(mkfile "testfile-mc-3a.ss"
"hello from 3a!")
(mkfile "testfile-mc-3b.ss"
'(library (testfile-mc-3b)
(export q)
(import (chezscheme))
(define-syntax q
(begin
(printf "expanding testfile-mc-3b\n")
(lambda (x)
(printf "expanding q\n")
(include "./testfile-mc-3a.ss"))))))
(mkfile "testfile-mc-3.ss"
'(import (chezscheme) (testfile-mc-3b))
'(define-syntax qq
(begin
(printf "expanding testfile-mc-3\n")
(lambda (x)
(printf "expanding qq\n")
#'q)))
'(printf "qq => ~a\n" qq))
(delete-file "testfile-mc-3b.so")
(delete-file "testfile-mc-3.so")
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t])
(maybe-compile-program x)))
'mc-3)
#t)
(begin
(delete-file "testfile-mc-3a.ss")
#t)
(error? ; separate-compile: no such file or directory: testfile-mc-3a.ss
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t])
(maybe-compile-program x)))
'mc-3))
; make sure maybe-compile-file handles missing include files gracefully
(begin
(define-record-type hash-bang-chezscheme)
(record-writer (type-descriptor hash-bang-chezscheme) (lambda (x p wr) (display-string "#!chezscheme")))
(mkfile "testfile-mc-4a.ss"
"hello from 4a!")
(mkfile "testfile-mc-4b.ss"
(make-hash-bang-chezscheme)
'(library (testfile-mc-4b)
(export b)
(import (chezscheme))
(define-syntax q
(lambda (x)
(if (file-exists? "testfile-mc-4a.ss")
(begin
(printf "HEY!\n")
(#%$require-include "./testfile-mc-4a.ss")
(call-with-input-file "testfile-mc-4a.ss" read))
(begin
(printf "BARLEY!\n")
"testfile-mc-4a is no more"))))
(define (b) q)))
(mkfile "testfile-mc-4.ss"
'(import (chezscheme) (testfile-mc-4b))
'(printf "q => ~a\n" (b)))
(delete-file "testfile-mc-4b.so")
(delete-file "testfile-mc-4.so")
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t])
(maybe-compile-program x)))
'mc-4)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-4.so"))
"q => hello from 4a!\n")
(begin
(mkfile "testfile-mc-4a.ss"
"goodbye from 4a!")
(touch "testfile-mc-4.so" "testfile-mc-4a.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t] [import-notify #t])
(maybe-compile-program x)))
'mc-4)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-4.so"))
"q => goodbye from 4a!\n")
(begin
(delete-file "testfile-mc-4a.ss")
#t)
(begin
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t] [import-notify #t])
(maybe-compile-program x)))
'mc-4)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-4.so"))
"q => testfile-mc-4a is no more\n")
; make sure maybe-compile-file handles missing include files gracefully
(begin
(define-record-type hash-bang-chezscheme)
(record-writer (type-descriptor hash-bang-chezscheme) (lambda (x p wr) (display-string "#!chezscheme")))
(mkfile "testfile-mc-5a.ss"
"hello from 5a!")
(mkfile "testfile-mc-5b.ss"
(make-hash-bang-chezscheme)
'(library (testfile-mc-5b)
(export q)
(import (chezscheme))
(define-syntax q
(lambda (x)
(if (file-exists? "testfile-mc-5a.ss")
(begin
(printf "HEY!\n")
(#%$require-include "./testfile-mc-5a.ss")
(call-with-input-file "testfile-mc-5a.ss" read))
(begin
(printf "BARLEY!\n")
"testfile-mc-5a is no more"))))))
(mkfile "testfile-mc-5.ss"
'(import (chezscheme) (testfile-mc-5b))
'(define-syntax qq (lambda (x) #'q))
'(printf "qq => ~a\n" qq))
(delete-file "testfile-mc-5b.so")
(delete-file "testfile-mc-5.so")
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t])
(maybe-compile-program x)))
'mc-5)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-5.so"))
"qq => hello from 5a!\n")
(begin
(mkfile "testfile-mc-5a.ss"
"goodbye from 5a!")
(touch "testfile-mc-5.so" "testfile-mc-5a.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t] [import-notify #t])
(maybe-compile-program x)))
'mc-5)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-5.so"))
"qq => goodbye from 5a!\n")
(begin
(delete-file "testfile-mc-5a.ss")
#t)
(begin
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t] [import-notify #t])
(maybe-compile-program x)))
'mc-5)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-5.so"))
"qq => testfile-mc-5a is no more\n")
)
(mat make-boot-file
@ -3225,6 +3361,211 @@ evaluating module init
"(9 . 5)\n")
)
(mat maybe-compile-whole
(begin
(delete-file "testfile-mcw-a1.so")
(delete-file "testfile-mcw-a1.wpo")
(delete-file "testfile-mcw-b1.so")
(delete-file "testfile-mcw-b1.wpo")
(delete-file "testfile-mcw-c1.so")
(delete-file "testfile-mcw-c1.wpo")
(with-output-to-file "testfile-mcw-ha1.ss"
(lambda ()
(pretty-print
'(define minor-msg-number 97)))
'replace)
(with-output-to-file "testfile-mcw-hb1.ss"
(lambda ()
(pretty-print
'(define major-msg-number 113)))
'replace)
(with-output-to-file "testfile-mcw-a1.ss"
(lambda ()
(pretty-print
'(library (testfile-mcw-a1)
(export a)
(import (chezscheme))
(define a "hello from a"))))
'replace)
(with-output-to-file "testfile-mcw-b1.ss"
(lambda ()
(pretty-print
'(library (testfile-mcw-b1)
(export b)
(import (chezscheme) (testfile-mcw-a1))
(include "testfile-mcw-ha1.ss")
(define b (lambda () (format "~a and b [~s]" a minor-msg-number))))))
'replace)
(with-output-to-file "testfile-mcw-c1.ss"
(lambda ()
(for-each pretty-print
'((import (chezscheme) (testfile-mcw-b1))
(include "testfile-mcw-hb1.ss")
(printf "~a and c [~s]\n" (b) major-msg-number))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(compile-program x)))
'mcw-c1)
#t)
(equal?
(separate-eval '(load-program "testfile-mcw-c1.so"))
"hello from a and b [97] and c [113]\n")
(begin
(with-output-to-file "testfile-mcw-a1.ss"
(lambda ()
(pretty-print
'(library (testfile-mcw-a1)
(export a)
(import (chezscheme))
(define a "greetings from a"))))
'replace)
(touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(maybe-compile-program x)))
'mcw-c1)
#t)
(equal?
(separate-eval '(load-program "testfile-mcw-c1.so"))
"greetings from a and b [97] and c [113]\n")
(begin
(separate-compile
'(lambda (x)
(compile-whole-program (format "~a.wpo" x) (format "~a.so" x)) #f)
'mcw-c1)
#t)
(equal?
(separate-eval '(load-program "testfile-mcw-c1.so"))
"greetings from a and b [97] and c [113]\n")
(begin
(with-output-to-file "testfile-mcw-a1.ss"
(lambda ()
(pretty-print
'(library (testfile-mcw-a1)
(export a)
(import (chezscheme))
(define a "salutations from a"))))
'replace)
(touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(parameterize ([compile-program-handler
(lambda (ifn ofn)
(compile-program ifn ofn)
(compile-whole-program (format "~a.wpo" (path-root ofn)) ofn #t))])
(maybe-compile-program x))))
'mcw-c1)
#t)
(equal?
(separate-eval '(load-program "testfile-mcw-c1.so"))
"salutations from a and b [97] and c [113]\n")
(begin
(with-output-to-file "testfile-mcw-a1.ss"
(lambda ()
(pretty-print
'(library (testfile-mcw-a1)
(export a)
(import (chezscheme))
(define a "goodbye from a"))))
'replace)
(touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(parameterize ([compile-program-handler
(lambda (ifn ofn)
(compile-program ifn ofn)
(compile-whole-program (format "~a.wpo" (path-root ofn)) ofn #t))])
(maybe-compile-program x))))
'mcw-c1)
#t)
(equal?
(separate-eval '(load-program "testfile-mcw-c1.so"))
"goodbye from a and b [97] and c [113]\n")
(begin
(with-output-to-file "testfile-mcw-hb1.ss"
(lambda ()
(pretty-print
'(define major-msg-number 773)))
'replace)
(touch "testfile-mcw-c1.so" "testfile-mcw-hb1.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(parameterize ([compile-program-handler
(lambda (ifn ofn)
(compile-program ifn ofn)
(compile-whole-program (format "~a.wpo" (path-root ofn)) ofn #t))])
(maybe-compile-program x))))
'mcw-c1)
#t)
(equal?
(separate-eval '(load-program "testfile-mcw-c1.so"))
"goodbye from a and b [97] and c [773]\n")
(begin
(with-output-to-file "testfile-mcw-a1.ss"
(lambda ()
(pretty-print
'(library (testfile-mcw-a1)
(export a)
(import (chezscheme))
(define a "hello again from a"))))
'replace)
(touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(parameterize ([compile-library-handler
(lambda (ifn ofn)
(compile-library ifn ofn)
(compile-whole-library (format "~a.wpo" (path-root ofn)) ofn))])
(maybe-compile-library x))))
'mcw-b1)
#t)
(equal?
(separate-eval '(let () (import (testfile-mcw-b1)) (printf "~a\n" (b))))
"hello again from a and b [97]\n")
(begin
(with-output-to-file "testfile-mcw-ha1.ss"
(lambda ()
(pretty-print
'(define minor-msg-number -53)))
'replace)
(touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(parameterize ([compile-library-handler
(lambda (ifn ofn)
(compile-library ifn ofn)
(compile-whole-library (format "~a.wpo" (path-root ofn)) ofn))])
(maybe-compile-library x))))
'mcw-b1)
#t)
(equal?
(separate-eval '(let () (import (testfile-mcw-b1)) (printf "~a\n" (b))))
"hello again from a and b [-53]\n")
)
(mat library-manager
(begin
(with-output-to-file "testfile-lm-a.ss"
@ -3417,7 +3758,6 @@ evaluating module init
"\"odd\"\n"))
)
;;; section 7.2:
(mat top-level-value-functions

17
mats/8.ms
View File

@ -6111,6 +6111,8 @@
(lambda (r)
(r #'a #'frip "extra stuff"))))
a))
(error? ; not a compile-time value
(compile-time-value-value 17))
(begin
(with-output-to-file "testfile-mctv0.ss"
(lambda ()
@ -6132,6 +6134,7 @@
(begin
(import (testfile-mctv0))
#t)
(compile-time-value? (make-compile-time-value 'fred))
(begin
(define-syntax frob (make-compile-time-value 'rabf))
#t)
@ -6180,6 +6183,7 @@
(define-syntax x (make-compile-time-value 'xow)))
#t)
(eq? (let () (import (mctv l1)) (get-ctv x)) 'xow)
(eq? (compile-time-value-value (top-level-syntax 'x (environment '(mctv l1)))) 'xow)
(begin
(with-output-to-file "testfile-mctv1.ss"
(lambda ()
@ -6190,6 +6194,19 @@
(for-each separate-compile '(mctv1))
#t)
(eq? (let () (import (testfile-mctv1)) (get-ctv x)) 'xuko1)
(compile-time-value? (top-level-syntax 'x (environment '(testfile-mctv1))))
(eq? (compile-time-value-value (top-level-syntax 'x (environment '(testfile-mctv1)))) 'xuko1)
(begin
(with-output-to-file "testfile-mctv1a.ss"
(lambda ()
(pretty-print
'(library (testfile-mctv1a) (export x) (import (chezscheme))
(define-syntax x (make-compile-time-value 'xuko1)))))
'replace)
(for-each separate-compile '(mctv1a))
#t)
(eq? (compile-time-value-value (top-level-syntax 'x (environment '(testfile-mctv1a)))) 'xuko1)
(eq? (let () (import (testfile-mctv1a)) (get-ctv x)) 'xuko1)
(begin
(with-output-to-file "testfile-mctv2.ss"
(lambda ()

265
mats/bytevector.ms
View File

@ -111,6 +111,9 @@
(eqv? (bytevector) (make-bytevector (- 4 4) (+ 1 1)))
(eqv? (bytevector) (make-bytevector (- 4 4) (+ 1 1)))
(equal? (bytevector 1) #vu8(1))
(equal? (bytevector -1) #vu8(255))
(equal? (bytevector -1 2) #vu8(255 2))
(equal? (bytevector 2 -1) #vu8(2 255))
(equal?
(letrec-syntax ([z (syntax-rules ()
[(_) (list (bytevector))]
@ -135,29 +138,76 @@
#vu8(1)
#vu8()))
(equal?
(let ([a 1] [c 3] [d 4] [e 5] [f 6] [h 8] [k 11] [l 12] [p 16] [q 17])
(letrec-syntax ([z (syntax-rules ()
[(_) (list (bytevector))]
[(_ x ... y) (cons (bytevector x ... y) (z x ...))])])
(z -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17))
'(#vu8(255 254 253 252 251 250 249 248 247 246 245 244 243 242 241 240 239)
#vu8(255 254 253 252 251 250 249 248 247 246 245 244 243 242 241 240)
#vu8(255 254 253 252 251 250 249 248 247 246 245 244 243 242 241)
#vu8(255 254 253 252 251 250 249 248 247 246 245 244 243 242)
#vu8(255 254 253 252 251 250 249 248 247 246 245 244 243)
#vu8(255 254 253 252 251 250 249 248 247 246 245 244)
#vu8(255 254 253 252 251 250 249 248 247 246 245)
#vu8(255 254 253 252 251 250 249 248 247 246)
#vu8(255 254 253 252 251 250 249 248 247)
#vu8(255 254 253 252 251 250 249 248)
#vu8(255 254 253 252 251 250 249)
#vu8(255 254 253 252 251 250)
#vu8(255 254 253 252 251)
#vu8(255 254 253 252)
#vu8(255 254 253)
#vu8(255 254)
#vu8(255)
#vu8()))
(equal?
(let ([a 1] [c -3] [d -4] [e 5] [f 6] [h -8] [k 11] [l -12] [p -16] [q 17])
(letrec-syntax ([z (syntax-rules ()
[(_) (list (bytevector))]
[(_ x ... y) (cons (bytevector x ... y) (z x ...))])])
(z a 2 c d e f 7 h 9 10 k l 13 14 15 p q)))
'(#vu8(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)
#vu8(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
#vu8(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
#vu8(1 2 3 4 5 6 7 8 9 10 11 12 13 14)
#vu8(1 2 3 4 5 6 7 8 9 10 11 12 13)
#vu8(1 2 3 4 5 6 7 8 9 10 11 12)
#vu8(1 2 3 4 5 6 7 8 9 10 11)
#vu8(1 2 3 4 5 6 7 8 9 10)
#vu8(1 2 3 4 5 6 7 8 9)
#vu8(1 2 3 4 5 6 7 8)
#vu8(1 2 3 4 5 6 7)
#vu8(1 2 3 4 5 6)
#vu8(1 2 3 4 5)
#vu8(1 2 3 4)
#vu8(1 2 3)
(z a 2 c d e f -7 h 9 -10 k l -13 -14 15 p q)))
'(#vu8(1 2 253 252 5 6 249 248 9 246 11 244 243 242 15 240 17)
#vu8(1 2 253 252 5 6 249 248 9 246 11 244 243 242 15 240)
#vu8(1 2 253 252 5 6 249 248 9 246 11 244 243 242 15)
#vu8(1 2 253 252 5 6 249 248 9 246 11 244 243 242)
#vu8(1 2 253 252 5 6 249 248 9 246 11 244 243)
#vu8(1 2 253 252 5 6 249 248 9 246 11 244)
#vu8(1 2 253 252 5 6 249 248 9 246 11)
#vu8(1 2 253 252 5 6 249 248 9 246)
#vu8(1 2 253 252 5 6 249 248 9)
#vu8(1 2 253 252 5 6 249 248)
#vu8(1 2 253 252 5 6 249)
#vu8(1 2 253 252 5 6)
#vu8(1 2 253 252 5)
#vu8(1 2 253 252)
#vu8(1 2 253)
#vu8(1 2)
#vu8(1)
#vu8()))
(equal?
(let ([a -1] [c 3] [d 4] [e -5] [f -6] [h 8] [k -11] [l 12] [p 16] [q -17])
(letrec-syntax ([z (syntax-rules ()
[(_) (list (bytevector))]
[(_ x ... y) (cons (bytevector x ... y) (z x ...))])])
(z a -2 c d e f 7 h -9 10 k l 13 14 -15 p q)))
'(#vu8(255 254 3 4 251 250 7 8 247 10 245 12 13 14 241 16 239)
#vu8(255 254 3 4 251 250 7 8 247 10 245 12 13 14 241 16)
#vu8(255 254 3 4 251 250 7 8 247 10 245 12 13 14 241)
#vu8(255 254 3 4 251 250 7 8 247 10 245 12 13 14)
#vu8(255 254 3 4 251 250 7 8 247 10 245 12 13)
#vu8(255 254 3 4 251 250 7 8 247 10 245 12)
#vu8(255 254 3 4 251 250 7 8 247 10 245)
#vu8(255 254 3 4 251 250 7 8 247 10)
#vu8(255 254 3 4 251 250 7 8 247)
#vu8(255 254 3 4 251 250 7 8)
#vu8(255 254 3 4 251 250 7)
#vu8(255 254 3 4 251 250)
#vu8(255 254 3 4 251)
#vu8(255 254 3 4)
#vu8(255 254 3)
#vu8(255 254)
#vu8(255)
#vu8()))
(equal? (apply bytevector (make-list 20000 #xc7))
(u8-list->bytevector (make-list 20000 #xc7)))
(let ([n0 1] [n1 -2] [n4 5])
@ -175,6 +225,187 @@
(eqv? (bytevector-u8-ref x 3) 252)
(eqv? (bytevector-s8-ref x 4) 5)
(eqv? (bytevector-u8-ref x 4) 5))))
(begin
(define $bv-f
(lambda (a b c d e f g h i j k l m n o p q r s t u v w x y z)
(letrec-syntax ([foo (syntax-rules ()
[(_) (list (bytevector))]
[(_ x ... y) (cons (bytevector x ... y) (foo x ...))])])
(foo a b c d e f g h i j k l m n o p q r s t u v w x y z))))
#t)
(equal?
($bv-f 101 -102 103 -104 -105 106 107 -108 -109 -110 111 112 113 114 -115 -116 -117 -118 119 120 121 -122 -123 124 -125 126)
'(#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131 126)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112)
#vu8(101 154 103 152 151 106 107 148 147 146 111)
#vu8(101 154 103 152 151 106 107 148 147 146)
#vu8(101 154 103 152 151 106 107 148 147)
#vu8(101 154 103 152 151 106 107 148)
#vu8(101 154 103 152 151 106 107)
#vu8(101 154 103 152 151 106)
#vu8(101 154 103 152 151)
#vu8(101 154 103 152)
#vu8(101 154 103)
#vu8(101 154)
#vu8(101)
#vu8()))
(begin
(define $bv-g
(lambda (a c e g i k m o q s u w y)
(letrec-syntax ([foo (syntax-rules ()
[(_) (list (bytevector))]
[(_ x ... y) (cons (bytevector x ... y) (foo x ...))])])
(foo a -102 c -104 e 106 g -108 i -110 k 112 m 114 o -116 q -118 s 120 u -122 w 124 y 126))))
#t)
(equal?
($bv-g 101 103 -105 107 -109 111 113 -115 -117 119 121 -123 -125)
'(#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131 126)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112)
#vu8(101 154 103 152 151 106 107 148 147 146 111)
#vu8(101 154 103 152 151 106 107 148 147 146)
#vu8(101 154 103 152 151 106 107 148 147)
#vu8(101 154 103 152 151 106 107 148)
#vu8(101 154 103 152 151 106 107)
#vu8(101 154 103 152 151 106)
#vu8(101 154 103 152 151)
#vu8(101 154 103 152)
#vu8(101 154 103)
#vu8(101 154)
#vu8(101)
#vu8()))
(begin
(define $bv-h
(lambda (b d f h j l n p r t v x z)
(letrec-syntax ([foo (syntax-rules ()
[(_) (list (bytevector))]
[(_ x ... y) (cons (bytevector x ... y) (foo x ...))])])
(foo 101 b 103 d -105 f 107 h -109 j 111 l 113 n -115 p -117 r 119 t 121 v -123 x -125 z))))
#t)
(equal?
($bv-h -102 -104 106 -108 -110 112 114 -116 -118 120 -122 124 126)
'(#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131 126)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112)
#vu8(101 154 103 152 151 106 107 148 147 146 111)
#vu8(101 154 103 152 151 106 107 148 147 146)
#vu8(101 154 103 152 151 106 107 148 147)
#vu8(101 154 103 152 151 106 107 148)
#vu8(101 154 103 152 151 106 107)
#vu8(101 154 103 152 151 106)
#vu8(101 154 103 152 151)
#vu8(101 154 103 152)
#vu8(101 154 103)
#vu8(101 154)
#vu8(101)
#vu8()))
(begin
(define $bv-i-ls* '())
(define $bv-i
(lambda (b d f h j l n p r t v x z)
(define this)
(define (init!) (set! $bv-i-ls* (cons '() $bv-i-ls*)) (set! this 0))
(define (bump!) (set! this (fx+ this 1)) (set-car! $bv-i-ls* (cons this (car $bv-i-ls*))))
(define-syntax plink (syntax-rules () [(_ x) (begin (bump!) x)]))
(letrec-syntax ([foo (syntax-rules ()
[(_) (list (bytevector))]
[(_ x ... y) (cons (begin (init!) (bytevector (plink x) ... (plink y))) (foo x ...))])])
(foo 101 b 103 d -105 f 107 h -109 j 111 l 113 n -115 p -117 r 119 t 121 v -123 x -125 z))))
#t)
(equal?
($bv-i -102 -104 106 -108 -110 112 114 -116 -118 120 -122 124 126)
'(#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131 126)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124 131)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133 124)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134 133)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121 134)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120 121)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119 120)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138 119)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139 138)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140 139)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141 140)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114 141)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113 114)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112 113)
#vu8(101 154 103 152 151 106 107 148 147 146 111 112)
#vu8(101 154 103 152 151 106 107 148 147 146 111)
#vu8(101 154 103 152 151 106 107 148 147 146)
#vu8(101 154 103 152 151 106 107 148 147)
#vu8(101 154 103 152 151 106 107 148)
#vu8(101 154 103 152 151 106 107)
#vu8(101 154 103 152 151 106)
#vu8(101 154 103 152 151)
#vu8(101 154 103 152)
#vu8(101 154 103)
#vu8(101 154)
#vu8(101)
#vu8()))
(equal?
(sort (lambda (ls1 ls2) (fx<= (length ls1) (length ls2))) $bv-i-ls*)
'((1)
(2 1)
(3 2 1)
(4 3 2 1)
(5 4 3 2 1)
(6 5 4 3 2 1)
(7 6 5 4 3 2 1)
(8 7 6 5 4 3 2 1)
(9 8 7 6 5 4 3 2 1)
(10 9 8 7 6 5 4 3 2 1)
(11 10 9 8 7 6 5 4 3 2 1)
(12 11 10 9 8 7 6 5 4 3 2 1)
(13 12 11 10 9 8 7 6 5 4 3 2 1)
(14 13 12 11 10 9 8 7 6 5 4 3 2 1)
(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
(16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
(17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
(18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
(19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
(20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
(21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
(22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
(23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
(24 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
(25 24 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
(26 25 24 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)))
)
(mat bytevector-syntax

12
mats/mat.ss
View File

@ -464,3 +464,15 @@
(with-output-to-file filename
(lambda () (for-each pretty-print expr*))
'replace)))
(define touch
(lambda (objfn srcfn)
(let loop ()
(let ([p (open-file-input/output-port srcfn (file-options no-fail no-truncate))])
(put-u8 p (lookahead-u8 p))
(close-port p))
(when (file-exists? objfn)
(unless (time>? (file-modification-time srcfn) (file-modification-time objfn))
(sleep (make-time 'time-duration 1000000 1))
(loop))))
#t))

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

@ -1,5 +1,5 @@
*** errors-compile-0-f-f-f 2019-02-07 11:07:08.000000000 -0800
--- errors-compile-0-f-t-f 2019-02-07 10:28:25.000000000 -0800
*** errors-compile-0-f-f-f 2019-02-11 17:18:14.000000000 -0800
--- errors-compile-0-f-t-f 2019-02-11 16:37:31.000000000 -0800
***************
*** 125,131 ****
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
@ -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".
***************
*** 3697,3703 ****
*** 3702,3708 ****
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".
--- 3697,3703 ----
--- 3702,3708 ----
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".
***************
*** 7163,7170 ****
*** 7169,7176 ****
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)".
--- 7163,7170 ----
--- 7169,7176 ----
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)".
***************
*** 7172,7186 ****
*** 7178,7192 ****
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".
--- 7172,7186 ----
--- 7178,7192 ----
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".
***************
*** 7193,7218 ****
*** 7199,7224 ****
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".
--- 7193,7218 ----
--- 7199,7224 ----
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".
***************
*** 7343,7381 ****
*** 7349,7387 ****
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".
--- 7343,7381 ----
--- 7349,7387 ----
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".
***************
*** 7390,7446 ****
*** 7396,7452 ****
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".
--- 7390,7446 ----
--- 7396,7452 ----
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".

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

File diff suppressed because it is too large Load Diff

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

@ -1,5 +1,5 @@
*** errors-compile-0-f-f-f 2019-02-07 11:07:08.000000000 -0800
--- errors-interpret-0-f-f-f 2019-02-07 10:46:19.000000000 -0800
*** errors-compile-0-f-f-f 2019-02-11 17:18:14.000000000 -0800
--- errors-interpret-0-f-f-f 2019-02-11 16:56:11.000000000 -0800
***************
*** 1,7 ****
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
@ -196,7 +196,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".
***************
*** 4071,4086 ****
*** 4076,4091 ****
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,26 +213,26 @@
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)".
--- 4077,4086 ----
--- 4082,4091 ----
***************
*** 7026,7032 ****
*** 7032,7038 ****
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 maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
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
! 7.mo:Expected error in mat eval: "compile: 7 is not an environment".
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".
--- 7026,7032 ----
--- 7032,7038 ----
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 maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
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
! 7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
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".
***************
*** 7354,7360 ****
*** 7360,7366 ****
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 +240,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".
--- 7354,7360 ----
--- 7360,7366 ----
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 +249,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".
***************
*** 8588,8600 ****
*** 8595,8607 ****
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -263,7 +263,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".
--- 8588,8600 ----
--- 8595,8607 ----
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -278,7 +278,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".
***************
*** 9355,9379 ****
*** 9362,9386 ****
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@ -304,7 +304,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".
--- 9355,9379 ----
--- 9362,9386 ----
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@ -331,7 +331,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".
***************
*** 9386,9417 ****
*** 9393,9424 ****
foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@ -364,7 +364,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>".
--- 9386,9417 ----
--- 9393,9424 ----
foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@ -398,7 +398,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>".
***************
*** 9419,9444 ****
*** 9426,9451 ****
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@ -425,7 +425,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>".
--- 9419,9444 ----
--- 9426,9451 ----
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@ -453,7 +453,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>".
***************
*** 9449,9483 ****
*** 9456,9490 ****
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@ -489,7 +489,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>".
--- 9449,9483 ----
--- 9456,9490 ----
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@ -526,7 +526,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>".
***************
*** 10084,10093 ****
*** 10091,10100 ****
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
@ -537,7 +537,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".
--- 10084,10093 ----
--- 10091,10100 ----
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".

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

@ -1,5 +1,5 @@
*** errors-compile-0-f-t-f 2019-02-07 10:28:25.000000000 -0800
--- errors-interpret-0-f-t-f 2019-02-07 10:55:02.000000000 -0800
*** errors-compile-0-f-t-f 2019-02-11 16:37:31.000000000 -0800
--- errors-interpret-0-f-t-f 2019-02-11 17:05:28.000000000 -0800
***************
*** 1,7 ****
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
@ -169,7 +169,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".
***************
*** 4071,4086 ****
*** 4076,4091 ****
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,26 +186,26 @@
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)".
--- 4077,4086 ----
--- 4082,4091 ----
***************
*** 7026,7032 ****
*** 7032,7038 ****
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 maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
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
! 7.mo:Expected error in mat eval: "compile: 7 is not an environment".
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".
--- 7026,7032 ----
--- 7032,7038 ----
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 maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
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
! 7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
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".
***************
*** 7163,7170 ****
*** 7169,7176 ****
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 +214,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)".
--- 7163,7170 ----
--- 7169,7176 ----
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 +224,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)".
***************
*** 7172,7186 ****
*** 7178,7192 ****
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 +240,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".
--- 7172,7186 ----
--- 7178,7192 ----
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 +257,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".
***************
*** 7193,7218 ****
*** 7199,7224 ****
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 +284,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".
--- 7193,7218 ----
--- 7199,7224 ----
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 +312,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".
***************
*** 7343,7381 ****
*** 7349,7387 ****
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 +352,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".
--- 7343,7381 ----
--- 7349,7387 ----
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 +393,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".
***************
*** 7390,7446 ****
*** 7396,7452 ****
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 +451,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".
--- 7390,7446 ----
--- 7396,7452 ----
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 +510,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".
***************
*** 8588,8600 ****
*** 8595,8607 ****
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 +524,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".
--- 8588,8600 ----
--- 8595,8607 ----
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 +539,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".
***************
*** 10084,10093 ****
*** 10091,10100 ****
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 +550,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".
--- 10084,10093 ----
--- 10091,10100 ----
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".

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

@ -1,5 +1,5 @@
*** errors-compile-3-f-f-f 2019-02-07 10:23:48.000000000 -0800
--- errors-interpret-3-f-f-f 2019-02-07 11:13:51.000000000 -0800
*** errors-compile-3-f-f-f 2019-02-11 16:33:03.000000000 -0800
--- errors-interpret-3-f-f-f 2019-02-11 17:25:17.000000000 -0800
***************
*** 1,3 ****
--- 1,9 ----

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

@ -1,5 +1,5 @@
*** errors-compile-3-f-t-f 2019-02-07 10:32:58.000000000 -0800
--- errors-interpret-3-f-t-f 2019-02-07 10:59:14.000000000 -0800
*** errors-compile-3-f-t-f 2019-02-11 16:41:58.000000000 -0800
--- errors-interpret-3-f-t-f 2019-02-11 17:10:00.000000000 -0800
***************
*** 1,3 ****
--- 1,9 ----

3
mats/primvars.ms
View File

@ -109,7 +109,7 @@
separate-compile separate-eval run-script patch-exec-path $record->vector
$cat_flush
test-cp0-expansion
mkfile rm-rf)))
mkfile rm-rf touch)))
(let loop ([ls (remp gensym? (oblist))] [bad '()])
(if (null? ls)
(or (null? bad)
@ -370,6 +370,7 @@
[(char) #\a 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]
[(continuation-condition) (call/cc make-continuation-condition) (make-who-condition 'who) #f]
[(cost-center) *cost-center '(a) #f]

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

@ -527,6 +527,11 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat dynamic-wind: "variable gook is not bound".
4.mo:Expected error in mat dynamic-wind: "variable gook is not bound".
4.mo:Expected error in mat call/1cc: "attempt to invoke shot one-shot continuation".
4.mo:Expected error in mat refcount-guardians: "unrecognized ftype name NO!".
4.mo:Expected error in mat refcount-guardians: "first field must be a word-sized integer with native endianness (ftype-guardian A)".
4.mo:Expected error in mat refcount-guardians: "first field must be a word-sized integer with native endianness (ftype-guardian A)".
4.mo:Expected error in mat refcount-guardians: "ftype-guardian: (ka . blooie) is not an ftype pointer of the expected type #<ftd A>".
4.mo:Expected error in mat refcount-guardians: "ftype-guardian: <ftype-pointer> is not an ftype pointer of the expected type #<ftd A>".
4.mo:Expected error in mat $primitive: "fx+: a is not a fixnum".
4.mo:Expected error in mat $primitive: "invalid primitive name fubar".
4.mo:Expected error in mat $primitive: "incorrect argument count in call (car (quote a) (quote b))".
@ -7024,8 +7029,9 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat maybe-compile: "invalid syntax (if) at line 2, char 1 of testfile-mc.ss".
7.mo:Expected error in mat maybe-compile: "invalid syntax (define) at line 4, char 3 of testfile-mc.ss".
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 maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: 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-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
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
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".
@ -8284,6 +8290,7 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat make-compile-time-value: "first argument to lookup procedure is not an identifier (a)".
8.mo:Expected error in mat make-compile-time-value: "second argument to lookup procedure is not an identifier "frip"".
8.mo:Expected error in mat make-compile-time-value: "incorrect number of arguments to #<procedure rho>".
8.mo:Expected error in mat make-compile-time-value: "compile-time-value-value: 17 is not a compile-time value".
8.mo:Expected error in mat make-compile-time-value: "invalid syntax frob".
8.mo:Expected error in mat make-compile-time-value: "invalid syntax frob".
8.mo:Expected error in mat make-compile-time-value: "invalid syntax frob".

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

@ -527,6 +527,11 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat dynamic-wind: "variable gook is not bound".
4.mo:Expected error in mat dynamic-wind: "variable gook is not bound".
4.mo:Expected error in mat call/1cc: "attempt to invoke shot one-shot continuation".
4.mo:Expected error in mat refcount-guardians: "unrecognized ftype name NO!".
4.mo:Expected error in mat refcount-guardians: "first field must be a word-sized integer with native endianness (ftype-guardian A)".
4.mo:Expected error in mat refcount-guardians: "first field must be a word-sized integer with native endianness (ftype-guardian A)".
4.mo:Expected error in mat refcount-guardians: "ftype-guardian: (ka . blooie) is not an ftype pointer of the expected type #<ftd A>".
4.mo:Expected error in mat refcount-guardians: "ftype-guardian: <ftype-pointer> is not an ftype pointer of the expected type #<ftd A>".
4.mo:Expected error in mat $primitive: "fx+: a is not a fixnum".
4.mo:Expected error in mat $primitive: "invalid primitive name fubar".
4.mo:Expected error in mat $primitive: "incorrect argument count in call (car (quote a) (quote b))".
@ -3832,6 +3837,8 @@ cp0.mo:Expected error in mat cp0-regression: "source-object-bfp: #f is not a sou
cp0.mo:Expected error in mat cp0-regression: "source-object-efp: #f is not a source object".
cp0.mo:Expected error in mat cp0-regression: "source-object-sfd: #f is not a source object".
cp0.mo:Expected error in mat cp0-regression: "condition: #f is not a condition".
cp0.mo:Expected error in mat cp0-regression: "apply: 0 is not a proper list".
cp0.mo:Expected error in mat cp0-regression: "apply: 2 is not a proper list".
cp0.mo:Expected error in mat expand/optimize: "incorrect argument count in call (expand/optimize)".
cp0.mo:Expected error in mat expand/optimize: "expand/optimize: b is not an environment".
cp0.mo:Expected error in mat expand/optimize: "incorrect argument count in call (expand/optimize (quote a) (quote b) (quote c))".
@ -7022,8 +7029,9 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat maybe-compile: "invalid syntax (if) at line 2, char 1 of testfile-mc.ss".
7.mo:Expected error in mat maybe-compile: "invalid syntax (define) at line 4, char 3 of testfile-mc.ss".
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 maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: 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-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
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
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".
@ -7553,14 +7561,31 @@ hash.mo:Expected error in mat hashtable-arguments: "hashtable-clear!: #<eq hasht
hash.mo:Expected error in mat hashtable-arguments: "hashtable-clear!: #<eq hashtable> is not mutable".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-clear!: invalid size argument #t".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-keys)".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-keys $ht 72 43)".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-keys: (hash . table) is not a hashtable".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-keys: -79 is not a valid length".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-keys: not-an-unsigned-integer is not a valid length".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-keys)".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-keys $ht 72)".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-keys: (hash . table) is not a hashtable".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-values)".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-values $ht 72)".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-values $ht 72 43)".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-values: (hash . table) is not a hashtable".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-values: -79 is not a valid length".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-values: not-an-unsigned-integer is not a valid length".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-entries)".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-entries $ht 72 43)".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-entries: (hash . table) is not a hashtable".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-entries: -79 is not a valid length".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-entries: not-an-unsigned-integer is not a valid length".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-entries)".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-entries $ht 72)".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-entries: (hash . table) is not a hashtable".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-cells)".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-cells $ht 72 43)".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-cells: (hash . table) is not a hashtable".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-cells: -79 is not a valid length".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-cells: not-an-unsigned-integer is not a valid length".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-hash-function)".
hash.mo:Expected error in mat hashtable-arguments: "incorrect argument count in call (hashtable-hash-function $ht $ht)".
hash.mo:Expected error in mat hashtable-arguments: "hashtable-hash-function: (hash . table) is not an eq hashtable".
@ -8265,6 +8290,7 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat make-compile-time-value: "first argument to lookup procedure is not an identifier (a)".
8.mo:Expected error in mat make-compile-time-value: "second argument to lookup procedure is not an identifier "frip"".
8.mo:Expected error in mat make-compile-time-value: "incorrect number of arguments to #<procedure rho>".
8.mo:Expected error in mat make-compile-time-value: "compile-time-value-value: 17 is not a compile-time value".
8.mo:Expected error in mat make-compile-time-value: "invalid syntax frob".
8.mo:Expected error in mat make-compile-time-value: "invalid syntax frob".
8.mo:Expected error in mat make-compile-time-value: "invalid syntax frob".

52
release_notes/release_notes.stex
View File

@ -58,6 +58,33 @@ Online versions of both books can be found at
%-----------------------------------------------------------------------------
\section{Functionality Changes}\label{section:functionality}
\subsection{Ftype guardians (9.5.1)}
Applications that manage memory outside the Scheme heap can leverage
new support for ftype guardians to help perform reference counting.
An ftype guardian is like an ordinary guardian except that it does
not necessarily save from collection each ftype pointer registered
with it but instead decrements (atomically) a reference count at
the head of the object to which the ftype pointer points.
If the reference count becomes zero as a result of the decrement,
it preserves the object so that it can be retrieved from the guardian
and freed; otherwise it allows it to be collected.
\subsection{Recompile information and whole-program optimization (9.5.1)}
\scheme{compile-whole-program} and \scheme{compile-whole-library}
now propagate recompile information from the named \scheme{wpo}
file to the object file to support \scheme{maybe-compile-program}
and \scheme{maybe-compile-library} in the case where the new object
file overwrites the original object file.
\subsection{Directly accessing the value of compile-time values (9.5.1)}
The value of a compile-time value created by \scheme{make-compile-time-value}
can be retrieved via the new procedure \scheme{compile-time-value-value}.
The new predicate \scheme{compile-time-value?} can be used to determine if
an object is a compile-time value.
\subsection{Extracting a subset of hashtable entries (9.5.1)}
The new \scheme{hashtable-cells} function is similar to
@ -1613,6 +1640,16 @@ in fasl files does not generally make sense.
%-----------------------------------------------------------------------------
\section{Bug Fixes}\label{section:bugfixes}
\subsection{Automatic recompilation and missing include files (9.5.1)}
A bug in automatic recompilation involving missing include files
has been fixed.
The bug caused automatic recompilation to fail, often with an
exception in \scheme{file-modification-time}, when a file specified
by an absolute pathname or pathname starting with "./" or "../" was
included via \scheme{include} during a previous compilation run and
is no longer present.
\subsection{Invalid memory reference instantiating \protect\scheme{foreign-callable} code object (9.5.1)}
A bug that caused evaluation of a \scheme{foreign-callable} expression in
@ -1928,6 +1965,21 @@ x86\_64 has been fixed.
%-----------------------------------------------------------------------------
\section{Performance Enhancements}\label{section:performance}
\subsection{Better code for \protect\scheme{bytevector} (9.5.1)}
The compiler now generates better inline code for the \scheme{bytevector}
procedure.
Instead of one byte memory write for each argument, it writes up
to four (32-bit machines) or eight (64-bit machines) bytes at a
time, which almost always results in fewer instructions and fewer
writes.
\subsection{\protect\scheme{vector-for-each} and \protect\scheme{string-for-each} improvement (9.5.1)}
The last call to the procedure passed to \scheme{vector-for-each}
or \scheme{string-for-each} is now reliably implemented as tail
call, as was already the case for \scheme{for-each}.
\subsection{Lambda commonization (9.5.1)}
After running the main source optimization pass (cp0), the

37
s/7.ss
View File

@ -219,16 +219,17 @@
[(visit-stuff? x) (when (memq situation '(load visit)) (run-inner (visit-stuff-inner x)))]
[else (run-inner x)])))
(define run-vector
(lambda (x i)
(cond
[(fx= (fx+ i 1) (vector-length x))
(run-outer (vector-ref x i))]
[else
(run-outer (vector-ref x i))
(run-vector x (fx+ i 1))])))
(lambda (v)
(let ([n (vector-length v)])
(unless (fx= n 0)
(let loop ([i 0])
(let ([x (vector-ref v i)] [i (fx+ i 1)])
(if (fx= i n)
(run-outer x) ; return value(s) of last form for load-compiled-from-port
(begin (run-outer x) (loop i)))))))))
(lambda (x)
(cond
[(vector? x) (run-vector x 0)]
[(vector? x) (run-vector x)]
[(Lexpand? x) ($interpret-backend x situation for-import? fn)]
[else (run-outer x)])))
@ -1355,7 +1356,7 @@
(set! $pass-stats
(lambda ()
(let-values ([(namev psv) (with-tc-mutex (hashtable-entries stats-ht))])
(define (build-result namev psv)
(vector->list
(vector-map
(lambda (name ps)
@ -1365,7 +1366,23 @@
(pass-stats-gc-cpu ps)
(pass-stats-bytes ps)))
namev
psv)))))
psv)))
(with-tc-mutex
(if outer-ps
(let ([cpu (current-time 'time-thread)]
[gc-cpu (current-time 'time-collector-cpu)]
[bytes (+ (bytes-deallocated) (bytes-allocated))])
(set-time-type! cpu 'time-duration)
(set-time-type! gc-cpu 'time-duration)
(pass-stats-cpu-set! outer-ps (add-duration (pass-stats-cpu outer-ps) cpu))
(pass-stats-gc-cpu-set! outer-ps (add-duration (pass-stats-gc-cpu outer-ps) gc-cpu))
(pass-stats-bytes-set! outer-ps (+ (pass-stats-bytes outer-ps) bytes))
(let ([result (call-with-values (lambda () (hashtable-entries stats-ht)) build-result)])
(pass-stats-cpu-set! outer-ps (subtract-duration (pass-stats-cpu outer-ps) cpu))
(pass-stats-gc-cpu-set! outer-ps (subtract-duration (pass-stats-gc-cpu outer-ps) gc-cpu))
(pass-stats-bytes-set! outer-ps (- (pass-stats-bytes outer-ps) bytes))
result))
(call-with-values (lambda () (hashtable-entries stats-ht)) build-result)))))
(let ()
(define who '$print-pass-stats)

23
s/cmacros.ss
View File

@ -695,17 +695,18 @@
;;; note: for type-char, leave at least fixnum-offset zeros at top of
;;; type byte to simplify char->integer conversion
(define-constant type-boolean #b00000110)
(define-constant ptr sfalse #b00000110)
(define-constant ptr strue #b00001110)
(define-constant type-char #b00010110)
(define-constant ptr sunbound #b00011110)
(define-constant ptr snil #b00100110)
(define-constant ptr forward-marker #b00101110)
(define-constant ptr seof #b00110110)
(define-constant ptr svoid #b00111110)
(define-constant ptr black-hole #b01000110)
(define-constant ptr sbwp #b01001110)
(define-constant type-boolean #b00000110)
(define-constant ptr sfalse #b00000110)
(define-constant ptr strue #b00001110)
(define-constant type-char #b00010110)
(define-constant ptr sunbound #b00011110)
(define-constant ptr snil #b00100110)
(define-constant ptr forward-marker #b00101110)
(define-constant ptr seof #b00110110)
(define-constant ptr svoid #b00111110)
(define-constant ptr black-hole #b01000110)
(define-constant ptr sbwp #b01001110)
(define-constant ptr ftype-guardian-rep #b01010110)
;;; on 32-bit machines, vectors get two primary tag bits, including
;;; one for the immutable flag, and so do bytevectors, so their maximum

50
s/compile.ss
View File

@ -839,7 +839,7 @@
[(find-library who path "wpo" (map (lambda (ext) (cons (car ext) (string-append (path-root (cdr ext)) ".wpo"))) (library-extensions))) =>
(lambda (fn)
(let*-values ([(hash-bang-line ir*) (read-input-file who fn)]
[(no-program node*) (process-ir*! ir* fn #f libs-visible?)])
[(no-program node* ignore-rcinfo*) (process-ir*! ir* fn #f libs-visible?)])
(values fn node*)))]
[(find-library who path "so" (library-extensions)) =>
(lambda (fn) (values fn (read-binary-file path fn libs-visible?)))]
@ -888,10 +888,10 @@
($oops who "malformed binary input file ~s" fn)))))))
(define process-ir*!
(lambda (ir* ifn capture-program? libs-visible?)
(let ([libs-in-file '()] [maybe-program #f])
(let ([libs-in-file '()] [maybe-program #f] [rcinfo* '()])
(define-pass process-ir! : Lexpand (ir) -> * ()
(Outer : Outer (ir situation) -> * ()
[,rcinfo (values)]
[,rcinfo (set! rcinfo* (cons rcinfo rcinfo*)) (values)]
[(group ,[] ,[]) (values)]
[(visit-only ,[inner 'visit ->]) (values)]
[(revisit-only ,[inner 'revisit ->]) (values)])
@ -942,7 +942,7 @@
(unless (library-node-rtir node)
($oops who "missing run-time code for ~s" (library-node-path node))))
libs-in-file)
(values maybe-program libs-in-file))))
(values maybe-program libs-in-file rcinfo*))))
(define record-ct-lib!
(lambda (linfo/ct binary? situation ifn libs-visible?)
(when (eq? situation 'revisit) ($oops who "encountered revisit-only compile-time library ~s while processing file ~s" (library-info-path linfo/ct) ifn))
@ -1015,14 +1015,14 @@
(library-node-invoke-req* node)))
(unless (node-depend* node)
(node-depend*-set! node (find-dependencies (library-node-invoke-req* node))))))
(let-values ([(maybe-program node*) (process-ir*! ir* ifn capture-program? libs-visible?)])
(let-values ([(maybe-program node* rcinfo*) (process-ir*! ir* ifn capture-program? libs-visible?)])
(when capture-program?
(unless maybe-program ($oops who "missing entry program in file ~a" ifn))
(unless (program-node-ir maybe-program) ($oops who "loading ~a did not define expected program pieces" ifn))
(chase-program-dependencies! maybe-program))
(for-each chase-library-dependencies! node*)
(let-values ([(visible* invisible*) (partition library-node-visible? (vector->list (hashtable-values libs)))])
(values maybe-program visible* invisible* wpo*))))))
(values maybe-program visible* invisible* rcinfo* wpo*))))))
(define topological-sort
(lambda (program-entry library-entry*)
@ -1289,6 +1289,14 @@
(make-patch-env node*)))))
(with-output-language (Lexpand Outer)
(define add-recompile-info
(lambda (rcinfo* body)
(fold-left
(lambda (body rcinfo)
`(group ,rcinfo ,body))
body
rcinfo*)))
(define add-library-records
(lambda (node* visit-lib* body)
(fold-left
@ -1333,18 +1341,20 @@
body visit-lib*)))
(define build-program-body
(lambda (program-entry node* visit-lib* invisible*)
(add-library-records node* visit-lib*
(add-library-records node* invisible*
(add-visit-lib-install* visit-lib*
(add-visit-lib-install* invisible*
`(revisit-only ,(build-combined-program-ir program-entry node*))))))))
(lambda (program-entry node* visit-lib* invisible* rcinfo*)
(add-recompile-info rcinfo*
(add-library-records node* visit-lib*
(add-library-records node* invisible*
(add-visit-lib-install* visit-lib*
(add-visit-lib-install* invisible*
`(revisit-only ,(build-combined-program-ir program-entry node*)))))))))
(define build-library-body
(lambda (node* visit-lib*)
(add-library-records node* visit-lib*
(add-visit-lib-install* visit-lib*
`(revisit-only ,(build-combined-library-ir node*)))))))
(lambda (node* visit-lib* rcinfo*)
(add-recompile-info rcinfo*
(add-library-records node* visit-lib*
(add-visit-lib-install* visit-lib*
`(revisit-only ,(build-combined-library-ir node*))))))))
(define finish-compile
(lambda (who msg ifn ofn hash-bang-line x1)
@ -1407,12 +1417,12 @@
(unless (string? ifn) ($oops who "~s is not a string" ifn))
(unless (string? ofn) ($oops who "~s is not a string" ofn))
(let*-values ([(hash-bang-line ir*) (read-input-file who ifn)]
[(program-entry lib* invisible* no-wpo*) (build-graph who ir* ifn #t #f libs-visible?)])
[(program-entry lib* invisible* rcinfo* no-wpo*) (build-graph who ir* ifn #t #f libs-visible?)])
(safe-assert program-entry)
(safe-assert (null? no-wpo*))
(let ([node* (topological-sort program-entry lib*)])
(finish-compile who "whole program" ifn ofn hash-bang-line
(build-program-body program-entry node* lib* invisible*))
(build-program-body program-entry node* lib* invisible* rcinfo*))
(build-required-library-list node* lib*)))])))
(set-who! compile-whole-library
@ -1420,7 +1430,7 @@
(unless (string? ifn) ($oops who "~s is not a string" ifn))
(unless (string? ofn) ($oops who "~s is not a string" ofn))
(let*-values ([(hash-bang-line ir*) (read-input-file who ifn)]
[(no-program lib* invisible* wpo*) (build-graph who ir* ifn #f (generate-wpo-files) #t)])
[(no-program lib* invisible* rcinfo* wpo*) (build-graph who ir* ifn #f (generate-wpo-files) #t)])
(safe-assert (not no-program))
(safe-assert (null? invisible*))
(safe-assert (or (not (generate-wpo-files)) (not (null? wpo*))))
@ -1428,7 +1438,7 @@
(let ([node* (topological-sort #f lib*)])
(write-wpo-file who ofn wpo*)
(finish-compile who "whole library" ifn ofn hash-bang-line
(build-library-body node* lib*))
(build-library-body node* lib* rcinfo*))
(build-required-library-list node* lib*))))))
(set! $c-make-code

127
s/cp0.ss
View File

@ -3935,26 +3935,29 @@
(let ([p (cp0-make-temp #t)]
[n (cp0-make-temp #t)]
[i (cp0-make-temp #t)]
[j (cp0-make-temp #t)]
[do (cp0-make-temp #t)]
[v (cp0-make-temp #t)]
[v* (map (lambda (x) (cp0-make-temp #f)) ?v*)])
(build-lambda (cons* p v v*)
(build-let (list n)
(list (build-primcall 3 'vector-length
(list (build-ref v))))
(build-named-let do (list i) (list `(quote 0))
`(if ,(build-primcall 3 'fx=
(list (build-ref i) (build-ref n)))
,void-rec
,(make-seq 'value
`(call ,(app-preinfo ctxt) (ref #f ,p)
,(map (lambda (x)
(build-primcall 3 'vector-ref
(list (build-ref x) (build-ref i))))
(cons v v*)) ...)
`(call ,(make-preinfo) (ref #f ,do)
,(build-primcall 3 'fx1+
(list (build-ref i))))))))))
(build-let (list n) (list (build-primcall 3 'vector-length (list (build-ref v))))
`(if ,(build-primcall 3 'fx= (list (build-ref n) `(quote 0)))
,void-rec
,(build-named-let do (list i) (list `(quote 0))
(build-let (list j) (list (build-primcall 3 'fx1+ (list (build-ref i))))
`(if ,(build-primcall 3 'fx= (list (build-ref j) (build-ref n)))
(call ,(app-preinfo ctxt) (ref #f ,p)
,(map (lambda (x)
(build-primcall 3 'vector-ref
(list (build-ref x) (build-ref i))))
(cons v v*)) ...)
,(make-seq 'value
`(call ,(app-preinfo ctxt) (ref #f ,p)
,(map (lambda (x)
(build-primcall 3 'vector-ref
(list (build-ref x) (build-ref i))))
(cons v v*)) ...)
`(call ,(make-preinfo) (ref #f ,do) (ref #f ,j))))))))))
ctxt empty-env sc wd name moi))])])
(define-inline 3 string-for-each ; should combine with vector-for-each
@ -4007,26 +4010,29 @@
(let ([p (cp0-make-temp #t)]
[n (cp0-make-temp #t)]
[i (cp0-make-temp #t)]
[j (cp0-make-temp #t)]
[do (cp0-make-temp #t)]
[s (cp0-make-temp #t)]
[s* (map (lambda (x) (cp0-make-temp #f)) ?s*)])
(build-lambda (cons* p s s*)
(build-let (list n)
(list (build-primcall 3 'string-length
(list (build-ref s))))
(build-named-let do (list i) (list `(quote 0))
`(if ,(build-primcall 3 'fx=
(list (build-ref i) (build-ref n)))
,void-rec
,(make-seq 'value
`(call ,(app-preinfo ctxt) (ref #f ,p)
,(map (lambda (x)
(build-primcall 3 'string-ref
(list (build-ref x) (build-ref i))))
(cons s s*)) ...)
`(call ,(make-preinfo) (ref #f ,do)
,(build-primcall 3 'fx1+
(list (build-ref i))))))))))
(build-let (list n) (list (build-primcall 3 'string-length (list (build-ref s))))
`(if ,(build-primcall 3 'fx= (list (build-ref n) `(quote 0)))
,void-rec
,(build-named-let do (list i) (list `(quote 0))
(build-let (list j) (list (build-primcall 3 'fx1+ (list (build-ref i))))
`(if ,(build-primcall 3 'fx= (list (build-ref j) (build-ref n)))
(call ,(app-preinfo ctxt) (ref #f ,p)
,(map (lambda (x)
(build-primcall 3 'string-ref
(list (build-ref x) (build-ref i))))
(cons s s*)) ...)
,(make-seq 'value
`(call ,(app-preinfo ctxt) (ref #f ,p)
,(map (lambda (x)
(build-primcall 3 'string-ref
(list (build-ref x) (build-ref i))))
(cons s s*)) ...)
`(call ,(make-preinfo) (ref #f ,do) (ref #f ,j))))))))))
ctxt empty-env sc wd name moi))])])
(define-inline 3 fold-right
@ -4382,18 +4388,20 @@
[(?x) (mtp ctxt empty-env sc wd name moi #f 3)]
[(?x ?p) (mtp ctxt empty-env sc wd name moi ?p 3)]))))
(define-inline 2 make-guardian
[() (and likely-to-be-compiled?
(let ()
(define inline-make-guardian
(lambda (ctxt empty-env sc wd name moi formal* make-setter-clauses)
(and likely-to-be-compiled?
(cp0
(let* ([tc (cp0-make-temp #t)] [ref-tc (build-ref tc)])
(build-lambda '()
(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))
(list
(cons
(list '()
(let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
(let ([y (cp0-make-temp #f)])
@ -4407,19 +4415,46 @@
(seq
(seq
,(build-primcall 3 'set-car! (list ref-tc
(build-primcall 3 'cdr (list ref-x))))
(build-primcall 3 'cdr (list ref-x))))
,(build-primcall 3 'set-car! (list ref-x false-rec)))
,(build-primcall 3 'set-cdr! (list ref-x false-rec)))
(ref #f ,y))))))))
(let* ([obj (cp0-make-temp #t)] [ref-obj (build-ref obj)])
(list (list obj)
(build-primcall 3 '$install-guardian
(list ref-obj ref-obj ref-tc))))
(let ([obj (cp0-make-temp #f)] [rep (cp0-make-temp #f)])
(list (list obj rep)
(build-primcall 3 '$install-guardian
(list (build-ref obj) (build-ref rep) ref-tc)))))))))
ctxt empty-env sc wd name moi))]))
(make-setter-clauses ref-tc))))))
ctxt empty-env sc wd name moi))))
(define-inline 2 make-guardian
[() (inline-make-guardian ctxt empty-env sc wd name moi
'()
(lambda (ref-tc)
(list
(let* ([obj (cp0-make-temp #t)] [ref-obj (build-ref obj)])
(list (list obj)
(build-primcall 3 '$install-guardian
(list ref-obj ref-obj ref-tc))))
(let ([obj (cp0-make-temp #f)] [rep (cp0-make-temp #f)])
(list (list obj rep)
(build-primcall 3 '$install-guardian
(list (build-ref obj) (build-ref rep) ref-tc)))))))])
(define-inline 2 $make-ftype-guardian
[(?ftd)
(let ([ftd (cp0-make-temp #f)])
(inline-make-guardian ctxt empty-env sc wd name moi
(list ftd)
(lambda (ref-tc)
(list
(let* ([obj (cp0-make-temp #t)] [ref-obj (build-ref obj)])
(list (list obj)
(let ([e (build-primcall 3 '$install-ftype-guardian
(list ref-obj ref-tc))])
(if (fx= level 3)
e
(let ([ref-ftd (build-ref ftd)])
`(seq
(if ,(build-primcall 3 'record? (list ref-obj ref-ftd))
,void-rec
,(build-primcall 3 '$ftype-guardian-oops (list ref-ftd ref-obj)))
,e))))))))))])))
) ; with-output-language
(define-pass cp0 : Lsrc (ir ctxt env sc wd name moi) -> Lsrc ()

76
s/cpnanopass.ss
View File

@ -5385,6 +5385,17 @@
(set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries))
(set! ,(%tc-ref guardian-entries) ,t))))])
(define-inline 3 $install-ftype-guardian
[(e-obj e-tconc)
(bind #f (e-obj e-tconc)
(bind #t ([t (%constant-alloc typemod (constant size-guardian-entry))])
(%seq
(set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj)
(set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) (immediate ,(constant ftype-guardian-rep)))
(set! ,(%mref ,t ,(constant guardian-entry-tconc-disp)) ,e-tconc)
(set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries))
(set! ,(%tc-ref guardian-entries) ,t))))])
(define-inline 2 virtual-register-count
[() `(quote ,(constant virtual-register-count))])
(let ()
@ -8059,6 +8070,50 @@
(let ()
(define build-bytevector
(lambda (e*)
(define (find-k n)
(let loop ([bytes (constant-case ptr-bits [(32) 4] [(64) 8])]
[type* (constant-case ptr-bits
[(32) '(unsigned-32 unsigned-16 unsigned-8)]
[(64) '(unsigned-64 unsigned-32 unsigned-16 unsigned-8)])])
(let ([bytes/2 (fxsrl bytes 1)])
(if (fx<= n bytes/2)
(loop bytes/2 (cdr type*))
(values bytes (car type*))))))
(define (build-chunk k n e*)
(define (build-shift e shift)
(if (fx= shift 0) e (%inline sll ,e (immediate ,shift))))
(let loop ([k (constant-case native-endianness
[(little) (fxmin k n)]
[(big) k])]
[e* (constant-case native-endianness
[(little) (reverse (if (fx<= n k) e* (list-head e* k)))]
[(big) e*])]
[constant-part 0]
[expression-part #f]
[expression-shift 0]
[mask? #f]) ; no need to mask the high-order byte
(if (fx= k 0)
(if expression-part
(let ([expression-part (build-shift expression-part expression-shift)])
(if (= constant-part 0)
expression-part
(%inline logor ,expression-part (immediate ,constant-part))))
`(immediate ,constant-part))
(let ([k (fx- k 1)]
[constant-part (ash constant-part 8)]
[expression-shift (fx+ expression-shift 8)])
(if (null? e*)
(loop k e* constant-part expression-part expression-shift #t)
(let ([e (car e*)] [e* (cdr e*)])
(if (fixnum-constant? e)
(loop k e* (logor constant-part (logand (constant-value e) #xff)) expression-part expression-shift #t)
(loop k e* constant-part
(let* ([e (build-unfix e)]
[e (if mask? (%inline logand ,e (immediate #xff)) e)])
(if expression-part
(%inline logor ,(build-shift expression-part expression-shift) ,e)
e))
0 #t))))))))
(let ([len (length e*)])
(if (fx= len 0)
`(quote ,(bytevector))
@ -8068,16 +8123,19 @@
`(seq
(set! ,(%mref ,t ,(constant bytevector-type-disp))
(immediate ,(+ (* len (constant bytevector-length-factor))
(constant type-bytevector))))
,(let f ([e* e*] [offset (constant bytevector-data-disp)])
(let ([e (car e*)] [e* (cdr e*)])
(constant type-bytevector))))
; build and store k-octet (k = 4 on 32-bit machines, k = 8 on 64-bit
; machines) chunks, taking endianness into account. for the last
; chunk, set k = 1, 2, 4, or 8 depending on the number of octets
; remaining, padding with zeros as necessary.
,(let f ([e* e*] [n (length e*)] [offset (constant bytevector-data-disp)])
(let-values ([(k type) (find-k n)])
`(seq
(inline ,(make-info-load 'unsigned-8 #f) ,%store
,t ,%zero (immediate ,offset)
,(if (fixnum-constant? e)
`(immediate ,(constant-value e))
(build-unfix e)))
,(if (null? e*) t (f e* (fx+ offset 1)))))))))))))
(inline ,(make-info-load type #f) ,%store ,t ,%zero (immediate ,offset)
,(build-chunk k n e*))
,(if (fx<= n k)
t
(f (list-tail e* k) (fx- n k) (fx+ offset k)))))))))))))
(define-inline 2 bytevector
[e* (and (andmap

29
s/ftype.ss
View File

@ -1307,7 +1307,33 @@ ftype operators:
(trans #'ftype #'(a ...) #'fptr-expr 0)]
[(_ ftype (a ...) fptr-expr ?idx)
(identifier? #'ftype)
(trans #'ftype #'(a ...) #'fptr-expr #'?idx)]))))
(trans #'ftype #'(a ...) #'fptr-expr #'?idx)])))
(set! $trans-ftype-guardian
(lambda (q)
(lambda (r)
(syntax-case q ()
[(_ ftype)
(identifier? #'ftype)
(let ([ftd (expand-ftype-name r #'ftype)])
(unless (let lockable? ([ftd ftd])
(cond
[(ftd-base? ftd)
(let ([type (filter-foreign-type (ftd-base-type ftd))])
(and (memq type
(constant-case ptr-bits
[(64) '(unsigned-64 integer-64)]
[(32) '(unsigned-32 integer-32)]))
(not (ftd-base-swap? ftd))))]
[(ftd-struct? ftd)
(let ([ls (ftd-struct-field* ftd)])
(if (null? ls)
#f
(lockable? (caddr (car ls)))))]
[(ftd-union? ftd) (ormap lockable? (map cdr (ftd-union-field* ftd)))]
[(ftd-array? ftd) (lockable? (ftd-array-ftd ftd))]
[else #f]))
(syntax-error q "first field must be a word-sized integer with native endianness"))
#`(($primitive #,(if (fx= (optimize-level) 3) 3 2) $make-ftype-guardian) '#,ftd))])))))
; procedural entry point for inspector to simplify bootstrapping
(set! $ftype-pointer? (lambda (x) ($fptr? x)))
(set! $make-fptr
@ -2015,6 +2041,7 @@ ftype operators:
(define-syntax make-ftype-pointer (lambda (x) ($trans-make-ftype-pointer x)))
(define-syntax ftype-pointer? (lambda (x) ($trans-ftype-pointer? x)))
(define-syntax ftype-sizeof (lambda (x) ($trans-ftype-sizeof x)))
(define-syntax ftype-guardian (lambda (x) ($trans-ftype-guardian x)))
(define-syntax ftype-&ref (lambda (x) ($trans-ftype-&ref x)))
(define-syntax ftype-ref (lambda (x) ($trans-ftype-ref x)))
(define-syntax ftype-locked-incr! (lambda (x) ($trans-ftype-locked-op! #'ftype-locked-incr! x #'$fptr-locked-incr!)))

21
s/interpret.ss
View File

@ -649,18 +649,21 @@
(definitions
(define (ibeval x1)
($rt (parameterize ([$target-machine (machine-type)] [$sfd #f])
(let* ([x2 ($cpvalid x1)]
(let* ([x2 ($pass-time 'cpvalid (lambda () ($cpvalid x1)))]
[x2a (let ([cpletrec-ran? #f])
(let ([x ((run-cp0)
(lambda (x)
(set! cpletrec-ran? #t)
($cpletrec ($cp0 x #f)))
(let ([x ($pass-time 'cp0 (lambda () ($cp0 x #f)))])
($pass-time 'cpletrec
(lambda () ($cpletrec x)))))
x2)])
(if cpletrec-ran? x ($cpletrec x))))]
[x2b ($cpcheck x2a)]
[x2b ($cpcommonize x2b)])
(if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))]
[x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))]
[x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))])
(when eoo (pretty-print ($uncprep x2b) eoo))
(ip2 (ip1 x2b))))
(let ([x ($pass-time 'ip1 (lambda () (ip1 x2b)))])
($pass-time 'ip2 (lambda () (ip2 x))))))
([a0 0] [a1 0] [fp 0] [cp 0]))))
(Inner : Inner (ir) -> * (val)
[,lsrc (ibeval lsrc)]
@ -694,8 +697,10 @@
(interaction-environment)))]
[(x0 env-spec)
(unless (environment? env-spec) ($oops 'interpret "~s is not an environment" env-spec))
(let ([x1 (parameterize ([$target-machine (machine-type)] [$sfd #f])
(expand x0 env-spec #t))])
(let ([x1 ($pass-time 'expand
(lambda ()
(parameterize ([$target-machine (machine-type)] [$sfd #f])
(expand x0 env-spec #t))))])
($uncprep x1 #t) ; populate preinfo sexpr fields
(when (and (expand-output) (not ($noexpand? x0)))
(pretty-print ($uncprep x1) (expand-output)))

5
s/patch.ss
View File

@ -13,11 +13,6 @@
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(define generate-procedure-source-information
(case-lambda
[() #f]
[(v) (void)]))
(printf "loading ~s cross compiler~%" (constant machine-type-name))
; (current-expand (lambda args (apply sc-expand args)))

9
s/primdata.ss
View File

@ -1050,6 +1050,7 @@
(fluid-let-syntax [flags])
(foreign-callable [flags])
(foreign-procedure [flags])
(ftype-guardian [flags])
(ftype-init-lock! [flags])
(ftype-lock! [flags])
(ftype-locked-decr! [flags])
@ -1207,6 +1208,8 @@
(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-program [sig [(pathname) (pathname pathname) (pathname pathname sub-symbol) -> (list)]] [flags true])
(compile-script [sig [(pathname) (pathname pathname) (pathname pathname sub-symbol) -> (void)]] [flags true])
(compile-time-value? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(compile-time-value-value [sig [(compile-time-value) -> (ptr)]] [flags pure mifoldable discard])
(compile-to-file [sig [(list pathname) (list pathname maybe-sfd) -> (ptr)]] [flags true])
(compile-to-port [sig [(list binary-output-port) (list binary-output-port maybe-sfd) (list binary-output-port maybe-sfd maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port sub-symbol) (list binary-output-port maybe-sfd maybe-binary-output-port sub-symbol maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port sub-symbol maybe-binary-output-port maybe-pathname) -> (ptr)]] [flags true])
(compile-whole-program [sig [(string string) (string string ptr) -> (void)]] [flags])
@ -1423,7 +1426,7 @@
(make-annotation [sig [(ptr source-object ptr) (ptr source-object ptr annotation-options) -> (annotation)]] [flags pure true mifoldable discard])
(make-boot-file [sig [(pathname sub-list pathname ...) -> (void)]] [flags true])
(make-boot-header [sig [(pathname pathname pathname ...) -> (void)]] [flags true])
(make-compile-time-value [sig [(ptr) (ptr ptr) -> (ptr)]] [flags pure unrestricted alloc])
(make-compile-time-value [sig [(ptr) -> (compile-time-value)]] [flags pure unrestricted alloc])
(make-condition [feature pthreads] [sig [() -> (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])
@ -1990,6 +1993,7 @@
($ftd-compound? [flags])
($ftd-size [flags])
($ftd->members [flags])
($ftype-guardian-oops [flags])
($ftype-pointer? [flags])
($fxaddress [flags unrestricted alloc])
($fx-? [flags])
@ -2016,6 +2020,7 @@
($inexactnum? [flags])
($inexactnum-imag-part [flags])
($inexactnum-real-part [flags])
($install-ftype-guardian [flags])
($install-guardian [flags])
($install-library-clo-info [flags])
($install-library/ct-code [flags])
@ -2079,6 +2084,7 @@
($make-foreign-callable [flags])
($make-foreign-procedure [flags])
($make-fptr [flags pure mifoldable discard true])
($make-ftype-guardian [flags alloc cp02])
($make-graph-env [flags])
($make-library-requirements-options [flags pure discard true])
($make-load-binary [flags])
@ -2231,6 +2237,7 @@
($track-static-closure-counts [flags alloc]) ; added for closure instrumentation
($trans-define-ftype [flags])
($transformer->binding [flags])
($trans-ftype-guardian [flags])
($trans-ftype-locked-op! [flags])
($trans-ftype-pointer? [flags])
($trans-ftype-&ref [flags])

13
s/prims.ss
View File

@ -1409,11 +1409,22 @@
(define-who $install-guardian
(lambda (obj rep tconc)
(unless (and (pair? tconc) (pair? (car tconc)) (pair? (cdr tconc))) ($oops who "~s is not a tconc" tconc))
; tconc is assumed to be valid at all call sites
(#3%$install-guardian obj rep tconc)))
(define-who $install-ftype-guardian
(lambda (obj tconc)
; tconc is assumed to be valid at all call sites
(#3%$install-ftype-guardian obj tconc)))
(define-who $ftype-guardian-oops
(lambda (ftd obj)
($oops 'ftype-guardian "~s is not an ftype pointer of the expected type ~s" obj ftd)))
(define make-guardian (lambda () (#2%make-guardian)))
(define $make-ftype-guardian (lambda (ftd) (#2%$make-ftype-guardian ftd)))
(define $address-in-heap?
(foreign-procedure "(cs)s_addr_in_heap" (uptr) boolean))

174
s/read.ss
View File

@ -21,18 +21,25 @@
(let ()
(include "types.ss")
(define-record-type rcb
(nongenerative)
(sealed #t)
(fields
ip ; input port
sfd ; a source-file descriptor or #f
a? ; if true, wrap s-expressions with source annotations
who ; who's calling (read, read-token)
))
;;; xdefine, xcall, xmvlet, and xvalues manage implicit arguments and
;;; return values for most of the procedures defined in this file. This
;;; simplifies the code and makes it much easier to add new arguments
;;; universally. The implicit variables are:
;;; [i ] ip input port
;;; [i ] rcb reader control block
;;; [io] fp current file position or #f
;;; [i ] bfp beginning file position or #f
;;; [io] tb token buffer
;;; [io] it insert table (for marks and references)
;;; [i ] sfd a source file descriptor or #f
;;; [i ] a? if true, wrap s-expressions with source annotations
;;; [i ] who who's calling (read, read-token)
;;; i: input (xcall argument)
;;; o: output (xvalues return value)
@ -40,22 +47,22 @@
(lambda (x)
(syntax-case x ()
((key args b1 b2 ...)
(with-implicit (key ip fp bfp tb it sfd a? who)
#'(lambda (ip fp bfp tb it sfd a? who . args) b1 b2 ...))))))
(with-implicit (key rcb fp bfp tb it)
#'(lambda (rcb fp bfp tb it . args) b1 b2 ...))))))
(define-syntax xdefine
(lambda (x)
(syntax-case x ()
((key (name . args) b1 b2 ...)
(with-implicit (key ip fp bfp tb it sfd a? who)
#'(define (name ip fp bfp tb it sfd a? who . args) b1 b2 ...))))))
(with-implicit (key rcb fp bfp tb it)
#'(define (name rcb fp bfp tb it . args) b1 b2 ...))))))
(define-syntax xcall
(lambda (x)
(syntax-case x ()
((key p arg ...)
(with-implicit (key ip fp bfp tb it sfd a? who)
#'(p ip fp bfp tb it sfd a? who arg ...))))))
(with-implicit (key rcb fp bfp tb it)
#'(p rcb fp bfp tb it arg ...))))))
(define-syntax xmvlet
(lambda (x)
@ -150,24 +157,26 @@
(syntax-case x ()
((key id b1 b2 ...)
(identifier? #'id)
(with-implicit (key ip fp)
#'(let ((id (read-char ip)) (fp (and fp (+ fp 1)))) b1 b2 ...))))))
(with-implicit (key rcb fp)
#'(let ([id (read-char (rcb-ip rcb))])
(let ((fp (and fp (+ fp 1))))
b1 b2 ...)))))))
(define-syntax with-peek-char
(lambda (x)
(syntax-case x ()
((key id b1 b2 ...)
(identifier? #'id)
(with-implicit (key ip)
#'(let ((id (peek-char ip))) b1 b2 ...))))))
(with-implicit (key rcb)
#'(let ((id (peek-char (rcb-ip rcb)))) b1 b2 ...))))))
(define-syntax with-unread-char
(lambda (x)
(syntax-case x ()
[(key ?c b1 b2 ...)
(with-implicit (key ip fp)
(with-implicit (key rcb fp)
#'(let ([c ?c])
(unless (eof-object? c) (unread-char c ip))
(unless (eof-object? c) (unread-char c (rcb-ip rcb)))
(let ([fp (and fp (- fp 1))]) b1 b2 ...)))])))
(define-record-type delayed-record
@ -267,11 +276,12 @@
(make-source sfd bfp efp)))])))
(xdefine (rd-error ir? start? msg . args)
(cond
[(eq? ip (console-input-port)) ($lexical-error who msg args ip ir?)]
[(not fp) ($lexical-error who "~? on ~s" (list msg args ip) ip ir?)]
[sfd ($lexical-error who msg args ip ($make-source-object sfd bfp fp) start? ir?)]
[else ($lexical-error who "~? at char ~a of ~s" (list msg args (if start? bfp fp) ip) ip ir?)]))
(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?)]
[(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?)])))
(xdefine (rd-eof-error s)
(xcall rd-error #f #t "unexpected end-of-file reading ~a" s))
@ -286,8 +296,8 @@
(lambda (x)
(syntax-case x ()
[(k str)
(with-implicit (k ip xcall)
#'(when ($port-flags-set? ip (constant port-flag-r6rs))
(with-implicit (k rcb xcall)
#'(when ($port-flags-set? (rcb-ip rcb) (constant port-flag-r6rs))
(xcall rd-nonstandard-error str)))])))
(xdefine (rd-nonstandard-delimiter-error c)
@ -297,8 +307,8 @@
(lambda (x)
(syntax-case x ()
[(k c)
(with-implicit (k ip xcall)
#'(when ($port-flags-set? ip (constant port-flag-r6rs))
(with-implicit (k rcb xcall)
#'(when ($port-flags-set? (rcb-ip rcb) (constant port-flag-r6rs))
(xcall rd-nonstandard-delimiter-error c)))])))
(define-state (rd-token)
@ -440,7 +450,7 @@
[#\[ (nonstandard "#[...] record") (state-return record-brack #f)]
[#\{ (nonstandard "#{...} gensym") (*state rd-token-gensym)]
[#\& (nonstandard "#& box") (state-return box #f)]
[#\; (if (eq? who 'read-token)
[#\; (if (eq? (rcb-who rcb) 'read-token)
(state-return quote 'datum-comment)
(xmvlet (() (xcall rd-expression-comment)) (*state rd-token)))]
[#\! (*state rd-token-hash-bang)]
@ -453,12 +463,12 @@
(with-read-char c
(*state rd-token-symbol c 0 #f
(state-lambda (n slashed?)
(state-return atomic (list '$primitive (maybe-fold/intern ip tb n slashed?))))))]
(state-return atomic (list '$primitive (maybe-fold/intern (rcb-ip rcb) tb n slashed?))))))]
[#\: (nonstandard "#: gensym")
(with-read-char c
(*state rd-token-symbol c 0 #f
(state-lambda (n slashed?)
(state-return atomic (maybe-fold/gensym ip tb n slashed?)))))]
(state-return atomic (maybe-fold/gensym (rcb-ip rcb) tb n slashed?)))))]
[#\| (*state rd-token-block-comment 0)]
[else (xcall rd-error #f #t "invalid sharp-sign prefix #~c" c)])))
@ -489,7 +499,7 @@
(with-read-char c
(state-case c
[eof (xcall rd-eof-error "gensym")]
[(#\}) (state-return atomic (maybe-fold/intern ip tb n m slashed1? slashed2?))]
[(#\}) (state-return atomic (maybe-fold/intern (rcb-ip rcb) tb n m slashed1? slashed2?))]
[else (with-unread-char c
(xcall rd-error #f #f
"expected close brace terminating gensym syntax"))]))))])))))])))
@ -539,7 +549,7 @@
(with-read-char c
(*state rd-token-symbol c 0 #f
(state-lambda (m slashed?)
(state-return atomic (list '$primitive n (maybe-fold/intern ip tb m slashed?))))))]
(state-return atomic (list '$primitive n (maybe-fold/intern (rcb-ip rcb) tb m slashed?))))))]
[else (xcall rd-error #f #t "invalid sharp-sign prefix ~a~a"
(substring tb 0 i)
c)])))
@ -624,15 +634,15 @@
[else #f]))
(with-unread-char c
(state-return atomic
(or (let ([x (maybe-fold/intern ip tb n #f)])
(if ($port-flags-set? ip (constant port-flag-r6rs))
(or (let ([x (maybe-fold/intern (rcb-ip rcb) tb n #f)])
(if ($port-flags-set? (rcb-ip rcb) (constant port-flag-r6rs))
(r6rs-char-name x)
(char-name x)))
(let ([s (substring tb 0 n)])
(if (and (with-peek-char c (eof-object? c))
(valid-prefix? s
(map symbol->string
(if ($port-flags-set? ip (constant port-flag-r6rs))
(if ($port-flags-set? (rcb-ip rcb) (constant port-flag-r6rs))
(map car r6rs-char-names)
(let-values ([(keys vals) (hashtable-entries char-name-table)])
(apply append (vector->list vals)))))))
@ -665,18 +675,19 @@
(cond
[(ormap (lambda (a) (and (fx= (string-length (car a)) i) a)) undelimited*) =>
(lambda (a)
(case (cdr a)
[(r6rs) ($set-port-flags! ip (constant port-flag-r6rs)) (*state rd-token)]
[(fold-case)
($reset-port-flags! ip (constant port-flag-no-fold-case))
($set-port-flags! ip (constant port-flag-fold-case))
(*state rd-token)]
[(no-fold-case)
($reset-port-flags! ip (constant port-flag-fold-case))
($set-port-flags! ip (constant port-flag-no-fold-case))
(*state rd-token)]
[(chezscheme) ($reset-port-flags! ip (constant port-flag-r6rs)) (*state rd-token)]
[else (xcall rd-error #f #t "unexpected #!~s" (car a))]))]
(let ([ip (rcb-ip rcb)])
(case (cdr a)
[(r6rs) ($set-port-flags! ip (constant port-flag-r6rs)) (*state rd-token)]
[(fold-case)
($reset-port-flags! ip (constant port-flag-no-fold-case))
($set-port-flags! ip (constant port-flag-fold-case))
(*state rd-token)]
[(no-fold-case)
($reset-port-flags! ip (constant port-flag-fold-case))
($set-port-flags! ip (constant port-flag-no-fold-case))
(*state rd-token)]
[(chezscheme) ($reset-port-flags! ip (constant port-flag-r6rs)) (*state rd-token)]
[else (xcall rd-error #f #t "unexpected #!~s" (car a))])))]
[else
(with-read-char c
(state-case c
@ -874,14 +885,14 @@
(xcall rd-error #f #t "invalid character ~c in string hex escape" c1)))])))
(xdefine (rd-make-number-or-symbol n)
(let ([z ($str->num tb n 10 #f ($port-flags-set? ip (constant port-flag-r6rs)))])
(let ([z ($str->num tb n 10 #f ($port-flags-set? (rcb-ip rcb) (constant port-flag-r6rs)))])
(cond
[(number? z) z]
[(eq? z 'norep) (xcall rd-error #t #t "cannot represent ~a" (substring tb 0 n))]
[(eq? z '!r6rs) (xcall rd-nonstandard-error (format "~a number" (substring tb 0 n)))]
[else
(nonstandard (format "~a symbol" (substring tb 0 n)))
(maybe-fold/intern ip tb n #f)])))
(maybe-fold/intern (rcb-ip rcb) tb n #f)])))
(define-state (rd-token-number-or-symbol i)
(with-read-char c
@ -907,7 +918,7 @@
[else (*state rd-token-symbol c i #f rd-token-intern-nonstandard)])))
(xdefine (rd-make-number n)
(let ([z ($str->num tb n 10 #f ($port-flags-set? ip (constant port-flag-r6rs)))])
(let ([z ($str->num tb n 10 #f ($port-flags-set? (rcb-ip rcb) (constant port-flag-r6rs)))])
(cond
[(number? z) z]
[(and (eq? z #f) (with-peek-char c (eof-object? c))) (xcall rd-eof-error "number")]
@ -938,11 +949,11 @@
(*state rd-token-number (fx+ i 1)))])))
(define-state (rd-token-intern n slashed?)
(state-return atomic (maybe-fold/intern ip tb n slashed?)))
(state-return atomic (maybe-fold/intern (rcb-ip rcb) tb n slashed?)))
(define-state (rd-token-intern-nonstandard n slashed?)
(nonstandard (format "~a symbol" (substring tb 0 n)))
(state-return atomic (maybe-fold/intern ip tb n slashed?)))
(state-return atomic (maybe-fold/intern (rcb-ip rcb) tb n slashed?)))
(define-state (rd-token-symbol c i slashed? next)
(state-case c
@ -1026,7 +1037,7 @@
[else #f])
(values value fp)
(if (and (or (eq? type 'rparen) (eq? type 'rbrack))
(eq? ip (console-input-port)))
(eq? (rcb-ip rcb) (console-input-port)))
(call-with-token rd-top-level)
(xmvlet ((x stripped-x) (xcall rd type value))
(values (if it (xcall rd-fix-graph x) x) fp)))))
@ -1142,8 +1153,8 @@
(xdefine (rd type value)
(xmvlet ((x stripped) (xcall rd-help type value))
(xvalues
(if (and a? (not (procedure? x))) ; don't annotate code
(make-annotation x ($make-source-object sfd bfp fp) stripped)
(if (rcb-a? rcb)
(make-annotation x ($make-source-object (rcb-sfd rcb) bfp fp) stripped)
x)
stripped)))
@ -1191,7 +1202,7 @@
(xmvlet ((rest stripped-rest) (xcall rd-paren-tail expr-bfp))
(xvalues
(cons first rest)
(and a? (cons stripped-first stripped-rest)))))]))))
(and (rcb-a? rcb) (cons stripped-first stripped-rest)))))]))))
(xdefine (rd-paren-tail expr-bfp)
(with-token (type value)
@ -1218,7 +1229,7 @@
(xmvlet ((rest stripped-rest) (xcall rd-paren-tail expr-bfp))
(xvalues
(cons first rest)
(and a? (cons stripped-first stripped-rest)))))])))
(and (rcb-a? rcb) (cons stripped-first stripped-rest)))))])))
(xdefine (rd-brack-list)
(let ([expr-bfp bfp])
@ -1232,7 +1243,7 @@
(xmvlet ((rest stripped-rest) (xcall rd-brack-tail expr-bfp))
(xvalues
(cons first rest)
(and a? (cons stripped-first stripped-rest)))))]))))
(and (rcb-a? rcb) (cons stripped-first stripped-rest)))))]))))
(xdefine (rd-brack-tail expr-bfp)
(with-token (type value)
@ -1259,7 +1270,7 @@
(xmvlet ((rest stripped-rest) (xcall rd-brack-tail expr-bfp))
(xvalues
(cons first rest)
(and a? (cons stripped-first stripped-rest)))))])))
(and (rcb-a? rcb) (cons stripped-first stripped-rest)))))])))
(xdefine (rd-quote kind)
(let ([expr-bfp bfp])
@ -1269,7 +1280,7 @@
[else (xmvlet ((x stripped-x) (xcall rd type value))
(xvalues
(list kind x)
(and a? (list kind stripped-x))))]))))
(and (rcb-a? rcb) (list kind stripped-x))))]))))
(xdefine (rd-record)
(let ([expr-bfp bfp])
@ -1302,7 +1313,7 @@
(if (null? fds)
(xvalues
(apply (record-constructor rtd) vals)
(and a? (apply (record-constructor rtd) stripped-vals)))
(and (rcb-a? rcb) (apply (record-constructor rtd) stripped-vals)))
(if (and (apply (lambda (m t n)
(or (eq? m 'immutable)
(not (eq? (filter-foreign-type t) 'scheme-object))))
@ -1311,7 +1322,7 @@
(delayed-record? (car vs))))
(xvalues
(make-delayed-record rtd vals expr-bfp fp)
(and a? (make-delayed-record rtd stripped-vals expr-bfp fp)))
(and (rcb-a? rcb) (make-delayed-record rtd stripped-vals expr-bfp fp)))
(loop (cdr fds) (cdr vs)))))))))]
[else (xcall rd-error #f #t "unrecognized record name ~s" name)])]))))
@ -1332,25 +1343,25 @@
(xmvlet ((rest stripped-rest) (xcall rd-record-tail expr-bfp (- n 1) name))
(xvalues
(cons first rest)
(and a? (cons stripped-first stripped-rest))))))])))
(and (rcb-a? rcb) (cons stripped-first stripped-rest))))))])))
(xdefine (rd-vector expr-bfp i)
(with-token (type value)
(case type
[(rparen) (xvalues (make-vector i) (and a? (make-vector i)))]
[(rparen) (xvalues (make-vector i) (and (rcb-a? rcb) (make-vector i)))]
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "vector"))]
[else
(xmvlet ((x stripped-x) (xcall rd type value))
(xmvlet ((v stripped-v) (xcall rd-vector expr-bfp (fx+ i 1)))
(vector-set! v i x)
(when a? (vector-set! stripped-v i stripped-x))
(when (rcb-a? rcb) (vector-set! stripped-v i stripped-x))
(xvalues v stripped-v)))])))
(xdefine (rd-sized-vector n)
(unless (and (fixnum? n) (fxnonnegative? n))
(let ([bfp (and bfp (+ bfp 1))] [fp (and fp (- fp 1))])
(xcall rd-error #f #t "invalid vector length ~s" n)))
(xcall rd-fill-vector bfp (make-vector n) (and a? (make-vector n)) 0 n))
(xcall rd-fill-vector bfp (make-vector n) (and (rcb-a? rcb) (make-vector n)) 0 n))
(xdefine (rd-fill-vector expr-bfp v stripped-v i n)
(with-token (type value)
@ -1468,24 +1479,24 @@
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "box"))]
[else
(xmvlet ((x stripped-x) (xcall rd type value))
(xvalues (box x) (and a? (box stripped-x))))]))))
(xvalues (box x) (and (rcb-a? rcb) (box stripped-x))))]))))
(xdefine (rd-mark n)
(let ([a (eq-hashtable-cell it n #f)])
; set up insert(s) if not already present
(unless (cdr a) (set-cdr! a (cons (make-insert n bfp fp) (and a? (make-insert n bfp fp)))))
(unless (cdr a) (set-cdr! a (cons (make-insert n bfp fp) (and (rcb-a? rcb) (make-insert n bfp fp)))))
; check for duplicate marks
(when (insert-seen (cadr a)) (xcall rd-error #f #t "duplicate mark #~s= seen" n))
; mark seen before reading so that error comes from second duplicate
(insert-seen-set! (cadr a) #t)
(when a? (insert-seen-set! (cddr a) #t))
(when (rcb-a? rcb) (insert-seen-set! (cddr a) #t))
(let ([expr-bfp bfp])
(with-token (type value)
(case type
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "graph mark"))]
[else
(xmvlet ((obj stripped-obj) (xcall rd type value))
(if a?
(if (rcb-a? rcb)
(let ([ins (cadr a)] [stripped-ins (cddr a)])
(if (eq? stripped-obj stripped-ins)
(begin
@ -1503,8 +1514,8 @@
(xdefine (rd-insert n)
(let ([a (eq-hashtable-cell it n #f)])
; set up insert(s) if not already present
(unless (cdr a) (set-cdr! a (cons (make-insert n bfp fp) (and a? (make-insert n bfp fp)))))
(xvalues (cadr a) (and a? (cddr a)))))
(unless (cdr a) (set-cdr! a (cons (make-insert n bfp fp) (and (rcb-a? rcb) (make-insert n bfp fp)))))
(xvalues (cadr a) (and (rcb-a? rcb) (cddr a)))))
(xdefine (rd-expression-comment) ; called from scanner
(let ([expr-bfp bfp])
@ -1524,7 +1535,7 @@
(let ([fp (and (port-has-port-position? ip)
($port-flags-set? ip (constant port-flag-char-positions))
(port-position ip))])
(let ([tb ""] [bfp fp] [it #f] [a? #f])
(let ([rcb (make-rcb ip sfd #f who)] [tb ""] [bfp fp] [it #f])
(with-token (type value)
(values type value bfp fp))))))
(case-lambda
@ -1549,7 +1560,7 @@
(and (port-has-port-position? ip)
($port-flags-set? ip (constant port-flag-char-positions))
(port-position ip)))])
(let ([tb ""] [bfp fp] [it #f] [a? (and a? sfd fp #t)])
(let ([rcb (make-rcb ip sfd (and a? sfd fp #t) who)] [tb ""] [bfp fp] [it #f])
(call-with-token rd-top-level)))))
(set-who! get-datum
(lambda (ip)
@ -1651,17 +1662,17 @@
(let loop ([fp 0] [accum '(0)])
(let ([ch (read-char ip)])
(cond
[(eof-object? ch)
(close-input-port ip)
(list->vector (reverse accum))]
[(eqv? ch #\newline)
(let ([fp (fx+ fp 1)])
(loop fp (cons fp accum)))]
[else
(loop (fx+ fp 1) accum)]))))
[(eof-object? ch)
(close-input-port ip)
(list->vector (reverse accum))]
[(eqv? ch #\newline)
(let ([fp (fx+ fp 1)])
(loop fp (cons fp accum)))]
[else
(loop (fx+ fp 1) accum)]))))
(when use-cache?
(with-tc-mutex
(hashtable-set! source-lines-cache sfd (cons name table))))
(hashtable-set! source-lines-cache sfd (cons name table))))
(binary-search table name))]
[else (values)])))
@ -1781,7 +1792,6 @@
; make c entry for x
($sputprop x '*char-name* c))
(else ($oops 'char-name "~s is not a character" c))))])))
) ;let
(define source-directories

153
s/syntax.ss
View File

@ -966,8 +966,8 @@
(nongenerative #{g0 cz18zz6lfwg7mc7m-a})
(sealed #t))
(define-record-type (compile-time-value $make-compile-time-value compile-time-value?)
(fields (immutable value))
(define-record-type (compile-time-value $make-compile-time-value $compile-time-value?)
(fields (immutable value $compile-time-value-value))
(nongenerative #{g0 c0f3a5187l98t2ef-a})
(sealed #t))
@ -1077,7 +1077,7 @@
[(procedure? x) (make-binding 'macro x)]
[(core-transformer? x) (core-transformer-binding x)]
[(variable-transformer? x) (make-binding 'macro! (variable-transformer-procedure x))]
[(compile-time-value? x) (make-binding 'ctv x)]
[($compile-time-value? x) (make-binding 'ctv x)]
[else ($oops who "invalid transformer ~s" x)])))
(define defer-or-eval-transformer
@ -3660,7 +3660,7 @@
"first argument to lookup procedure is not an identifier"))
(let ([b (lookup (id->label id empty-wrap) r)])
(case (binding-type b)
[(ctv) (compile-time-value-value (binding-value b))]
[(ctv) ($compile-time-value-value (binding-value b))]
[else #f]))]
[(id key-id)
(unless (identifier? id)
@ -4841,70 +4841,77 @@
($oops/c #f ($make-recompile-condition path)
"can't find include file ~a included by ~a when building ~a"
include-req src-path obj-path))])
; with-source-path tries to open include-req if it has to search for it ...
(with-source-path 'include include-req
(lambda (include-req)
(lambda ()
(when (time>? (file-modification-time include-req) obj-time)
(with-message (format "include file ~a is newer than ~a" include-req obj-path)
($oops/c #f ($make-recompile-condition path)
"include file ~a is newer than ~a"
include-req obj-path)))))))))
; ... but not if it is an absolute path or begins with "./" or "..", so we
; call file-modification time before leaving the "missing include file"
; guard in case it doesn't actually exist.
(let ([t (file-modification-time include-req)])
(lambda ()
(when (time>? t obj-time)
(with-message (format "include file ~a is newer than ~a" include-req obj-path)
($oops/c #f ($make-recompile-condition path)
"include file ~a is newer than ~a"
include-req obj-path))))))))))
(libdesc-include-req* (get-library-descriptor found-uid))))))
found-uid)]
[else ($oops #f "loading ~a did not define library ~s" src-path path)]))])
(verify-uid found-uid src-path)
found-uid)))
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid #f #f)
(verify-uid found-uid #f)
(let ([desc (get-library-descriptor found-uid)])
(if ct?
(unless (libdesc-ctdesc desc)
(with-message (format "attempting to 'visit' previously 'revisited' ~s for library ~s compile-time info" (libdesc-outfn desc) path)
($visit #f (libdesc-outfn desc))))
(unless (libdesc-rtdesc desc)
(with-message (format "attempting to 'revisit' previously 'visited' ~s for library ~s run-time info" (libdesc-outfn desc) path)
($revisit #f (libdesc-outfn desc))))))
; need to call load-deps even if our library was already loaded,
; since we might, say, have previously loaded its invoke dependencies and
; now want to load its import dependencies
(load-deps found-uid)
found-uid)]
[else
(let-values ([(src-path obj-path obj-exists?) (library-search 'import path (library-directories) (library-extensions))])
(if src-path
(if obj-exists?
(if (equal? obj-path src-path)
(with-message "source path and object path are the same"
(with-message (format "loading ~s" src-path)
(do-load-library src-path 'load)))
(if (time>=? (file-modification-time obj-path) (file-modification-time src-path))
(with-message "object file is not older"
(with-message (format "loading object file ~s" obj-path)
(do-load/reload/recompile-library src-path obj-path
(and (compile-imported-libraries) $compiler-is-loaded?))))
(with-message "object file is older"
(if (and (compile-imported-libraries) $compiler-is-loaded?)
(with-message (format "compiling ~s to ~s" src-path obj-path)
(do-compile-library src-path obj-path))
(with-message (format "loading source file ~s" src-path)
(do-load-library src-path 'load))))))
(if (and (compile-imported-libraries) $compiler-is-loaded?)
(with-message (format "compiling ~s to ~s" src-path obj-path)
(let f ([p obj-path])
(let ([p (path-parent p)])
(unless (or (string=? p "") (file-exists? p))
(f p)
(with-message (format "creating subdirectory ~s" p) (mkdir p)))))
(do-compile-library src-path obj-path))
(with-message (format "loading source file ~s" src-path)
(do-load-library src-path 'load))))
(if obj-exists?
(with-message (format "loading object file ~s" obj-path)
(do-load-library obj-path (if ct? 'load 'revisit)))
($oops #f "library ~s not found" path))))])))
($pass-time 'load-library
(lambda ()
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid #f #f)
(verify-uid found-uid #f)
(let ([desc (get-library-descriptor found-uid)])
(if ct?
(unless (libdesc-ctdesc desc)
(with-message (format "attempting to 'visit' previously 'revisited' ~s for library ~s compile-time info" (libdesc-outfn desc) path)
($visit #f (libdesc-outfn desc))))
(unless (libdesc-rtdesc desc)
(with-message (format "attempting to 'revisit' previously 'visited' ~s for library ~s run-time info" (libdesc-outfn desc) path)
($revisit #f (libdesc-outfn desc))))))
; need to call load-deps even if our library was already loaded,
; since we might, say, have previously loaded its invoke dependencies and
; now want to load its import dependencies
(load-deps found-uid)
found-uid)]
[else
(let-values ([(src-path obj-path obj-exists?) (library-search 'import path (library-directories) (library-extensions))])
(if src-path
(if obj-exists?
(if (equal? obj-path src-path)
(with-message "source path and object path are the same"
(with-message (format "loading ~s" src-path)
(do-load-library src-path 'load)))
(if (time>=? (file-modification-time obj-path) (file-modification-time src-path))
(with-message "object file is not older"
(with-message (format "loading object file ~s" obj-path)
(do-load/reload/recompile-library src-path obj-path
(and (compile-imported-libraries) $compiler-is-loaded?))))
(with-message "object file is older"
(if (and (compile-imported-libraries) $compiler-is-loaded?)
(with-message (format "compiling ~s to ~s" src-path obj-path)
(do-compile-library src-path obj-path))
(with-message (format "loading source file ~s" src-path)
(do-load-library src-path 'load))))))
(if (and (compile-imported-libraries) $compiler-is-loaded?)
(with-message (format "compiling ~s to ~s" src-path obj-path)
(let f ([p obj-path])
(let ([p (path-parent p)])
(unless (or (string=? p "") (file-exists? p))
(f p)
(with-message (format "creating subdirectory ~s" p) (mkdir p)))))
(do-compile-library src-path obj-path))
(with-message (format "loading source file ~s" src-path)
(do-load-library src-path 'load))))
(if obj-exists?
(with-message (format "loading object file ~s" obj-path)
(do-load-library obj-path (if ct? 'load 'revisit)))
($oops #f "library ~s not found" path))))])))))
(define version-okay?
(lambda (version-ref version)
@ -5247,9 +5254,16 @@
(lambda (rcinfo)
(andmap
(lambda (x)
(with-source-path who x
(lambda (x)
(time<=? (with-new-who who (lambda () (file-modification-time x))) ofn-mod-time))))
((guard (c [else (with-message (with-output-to-string
(lambda ()
(display-string "failed to find include file: ")
(display-condition c)))
(lambda () #f))])
(with-source-path who x
(lambda (x)
(lambda ()
(and (file-exists? x)
(time<=? (file-modification-time x) ofn-mod-time))))))))
(recompile-info-include-req* rcinfo)))
rcinfo*))
(if (compile-imported-libraries)
@ -6459,7 +6473,7 @@
(record-writer (type-descriptor compile-time-value)
(lambda (x p wr)
(display "#<compile-time-value " p)
(wr (compile-time-value-value x) p)
(wr ($compile-time-value-value x) p)
(display ">" p)))
(record-writer syntax-object-rtd ; from types.ss
@ -6983,6 +6997,15 @@
(lambda (x)
($make-compile-time-value x)))
(set-who! compile-time-value?
(lambda (x)
($compile-time-value? x)))
(set-who! compile-time-value-value
(lambda (x)
(unless ($compile-time-value? x) ($oops who "~s is not a compile-time value" x))
($compile-time-value-value x)))
(set! $syntax->src
(lambda (x)
(let f ([x x] [n 0] [k (lambda () (values #f #t))])